[Initial addition of Sqlite integration for hit tracking.  Some other optimizations.
prb@mult.ifario.us**20080702212744] {
hunk ./perpubplat.cabal 20
-  base64-string, hxt >= 8.0, hslogger >= 1.0.5,
+  base64-string, hxt == 7.5, hslogger >= 1.0.5,
hunk ./servletsrc/perpubplat.hs 9
+import qualified Blog.BackEnd.RefererStream as RefS
+import qualified Blog.BackEnd.HitTracker as HitT
hunk ./servletsrc/perpubplat.hs 32
-import Data.Digest.MD5 ( md5 )
+import Data.Digest.Pure.MD5 ( md5 )
hunk ./servletsrc/perpubplat.hs 34
-import Data.Maybe (fromJust)
+import Data.Maybe (fromJust, isJust)
+import Control.Monad (when)
hunk ./servletsrc/perpubplat.hs 42
-                               {-, referer_stream :: RefererStream -}
+                               , referer_stream :: RefS.RefererStream
hunk ./servletsrc/perpubplat.hs 68
-serve_content con v = do { --requestHeader "Referer" >>= liftIO $ send_referer 
+serve_content con v = do { r <- requestHeader "Referer"
+                         ; when (isJust r) $ liftIO $ RefS.send_referer (referer_stream con) v (fromJust r)
hunk ./servletsrc/perpubplat.hs 73
-                         ; h <- liftIO $ DataC.get_model (data_c con) >>= P.assemble_page v (chrome_b con)
+                         ; m <- liftIO $ DataC.get_model (data_c con)
+                         ; when (V.kind v == V.Single) $ 
+                               liftIO $ mapM_ (HitT.tally_hit . ChromeB.hit_tracker . chrome_b $ con) $ ((V.lens v) m)
+                         ; h <- liftIO $ P.assemble_page v (chrome_b con) m
hunk ./servletsrc/perpubplat.hs 216
-          ; let con = Controllers dc cc cb
+          ; rs <- RefS.boot
+          ; let con = Controllers dc cc cb rs
addfile ./src/Blog/BackEnd/HitTracker.hs
hunk ./src/Blog/BackEnd/HitTracker.hs 1
-
+module Blog.BackEnd.HitTracker where
+
+import qualified Database.HDBC as DH
+import qualified Database.HDBC.Sqlite3 as DHS3
+import qualified Blog.Constants as C
+import qualified Control.Monad as CM
+import qualified Control.Concurrent as CC
+import qualified Control.Concurrent.Chan as CCC
+import qualified Control.Concurrent.MVar as CCM
+import Blog.Model.Entry ( Item ( permatitle ) )
+import qualified Data.Map as DM
+import qualified Data.List as DL
+import qualified System.Log.Logger as L
+
+data HitTracker = HitTracker { events :: CCC.Chan Request
+                             , database_worker :: DatabaseWorker
+                             , hits :: ! (DM.Map String Int)
+                             , tracker_tid :: CC.ThreadId }
+
+data Request = TallyHit { h_item :: Item }
+             | GetAllHits { hb :: CCM.MVar (DM.Map String Int) }
+             | GetHits { h_item :: Item
+                       , gh_hb :: CCM.MVar Int }             
+
+data DatabaseWorker = DatabaseWorker { queue :: CCC.Chan DatabaseRequest
+                                     , connection :: DHS3.Connection
+                                     , update_stmt :: DH.Statement
+                                     , initialize_stmt :: DH.Statement
+                                     , db_worker_tid :: CC.ThreadId }
+
+data DatabaseRequest = Initialize { db_item :: Item }
+                     | SetCount { db_item :: Item 
+                                 , count :: Int }
+
+log_handle :: String
+log_handle = "HitTracker"
+
+boot :: IO HitTracker
+boot = do { defaultTid <- CC.myThreadId
+          ; conn <- DHS3.connectSqlite3 C.sqlite_hits_db_filename
+          ; L.infoM log_handle $ "Connected to SQLite3 database " ++ C.sqlite_hits_db_filename ++ "."
+          ; tables <- DH.getTables conn 
+          ; CM.unless ("hit_counts" `DL.elem` tables) $ 
+            ( DH.run conn table_create_sql [] >> DH.commit conn ) >> return ()
+          ; cnt <- count_rows conn "hit_counts"
+          ; L.infoM log_handle $ "Found " ++ (show cnt) ++ " rows in the database; processing."
+          ; vals <- DH.quickQuery' conn select_all_sql []
+          ; L.infoM log_handle $ "Processed " ++ (show $ length vals) ++ " rows from the database; building internal structures."
+          ; let hit_map = foldl to_pair DM.empty vals
+          ; u_st <- DH.prepare conn update_count_sql
+          ; i_st <- DH.prepare conn initialize_count_sql
+          ; q_c <- CCC.newChan
+          ; let db_w = DatabaseWorker q_c conn u_st i_st defaultTid
+          ; db_tid <- CC.forkIO $ db_loop db_w
+          ; r_c <- CCC.newChan
+          ; let h = HitTracker r_c ( db_w  { db_worker_tid = db_tid } ) hit_map defaultTid
+          ; h_tid <- CC.forkIO $ loop h
+          ; return $ h { tracker_tid = h_tid} }
+
+to_pair :: DM.Map String Int -> [DH.SqlValue] -> DM.Map String Int
+to_pair m [k,v] = DM.insert (DH.fromSql k) (DH.fromSql v) m 
+
+count_rows :: DH.IConnection conn => conn -> String -> IO Int
+count_rows c t = do { [[ cnt ]] <- DH.quickQuery' c ("SELECT count(*) FROM " ++ t) []
+                    ; return . read . DH.fromSql $ cnt }
+
+table_create_sql :: String 
+table_create_sql = "CREATE TABLE hit_counts (ptitle TEXT NOT NULL, hits INTEGER NOT NULL DEFAULT 0)"
+
+select_count_sql :: String
+select_count_sql = "SELECT count(*) FROM hit_counts"
+
+select_all_sql :: String
+select_all_sql = "SELECT * FROM hit_counts"
+
+update_count_sql :: String
+update_count_sql = "UPDATE hit_counts SET hits=? WHERE ptitle=?" 
+
+initialize_count_sql :: String
+initialize_count_sql = "INSERT INTO hit_counts (ptitle,hits) VALUES (?,1)"
+
+get_hits :: HitTracker -> Item -> IO Int
+get_hits h i = do { hb <- CCM.newEmptyMVar
+                  ; CCC.writeChan ( events h) $ GetHits i hb
+                  ; CCM.takeMVar hb }
+
+tally_hit :: HitTracker -> Item -> IO ()
+tally_hit h i = CCC.writeChan (events h) $ TallyHit i
+
+get_all_hits :: HitTracker -> IO (DM.Map String Int)
+get_all_hits h = do { hb <- CCM.newEmptyMVar
+                    ; CCC.writeChan (events h) $ GetAllHits hb
+                    ; CCM.takeMVar hb }
+
+send_hit_to_db :: HitTracker -> Item -> Int -> IO ()
+send_hit_to_db h i 1 = CCC.writeChan ( queue $ database_worker h ) $ Initialize i
+send_hit_to_db h i c = CCC.writeChan ( queue $ database_worker h ) $ SetCount i c
+
+loop :: HitTracker -> IO ()
+loop h = do { req <- CCC.readChan $ events h
+            ; case req of
+                TallyHit item ->
+                    do { let new_hits = DM.insertWith (+) (permatitle item) 1 ( hits h )
+                       ; send_hit_to_db h item (new_hits DM.! (permatitle item))
+                       ; loop h { hits = new_hits }
+                       }
+                GetHits item hb ->
+                    do { let cnt = DM.findWithDefault 0 (permatitle item) (hits h)
+                       ; CCM.putMVar hb cnt
+                       ; loop h
+                       }
+                GetAllHits hb -> 
+                    do { CCM.putMVar hb (hits h)
+                       ; loop h
+                       }
+            }
+
+db_loop :: DatabaseWorker -> IO ()
+db_loop dw = do { req <- CCC.readChan $ queue dw
+                ; do { case req of 
+                         SetCount item val ->
+                             do { L.debugM log_handle $ "Post permatitle " ++ (permatitle item) ++ " is already tracked; updating database with new count of " ++ (show val) ++ "."
+                                ; r <- DH.execute (update_stmt dw) [ DH.iToSql val, DH.toSql (permatitle item) ]
+                                ; CM.unless (r == 1) $ L.warningM log_handle $ "Whoa."
+                                }
+                         Initialize item -> 
+                             do { L.debugM log_handle $ "Post id " ++ (permatitle item) ++ " is not yet tallied; inserting new record into database."
+                                ; r <- DH.execute (initialize_stmt dw) [ DH.toSql (permatitle item) ]
+                                ; CM.unless (r == 1) $ L.warningM log_handle $ "Whoa!"
+                                }
+                     ; L.debugM log_handle $ "Committing."
+                     ; DH.commit (connection dw) } 
+                  `DH.catchSql` (log_sql_error "db_loop")
+                ; db_loop dw
+                }
+
+log_sql_error :: String -> DH.SqlError -> IO ()
+log_sql_error f se = L.errorM log_handle $ "Encountered SqlError in " ++ f ++ ": state=" ++ (DH.seState se)
+                     ++ ", native_error=" ++ (show $ DH.seNativeError se) ++ ", message="
+                     ++ (DH.seErrorMsg se) 
hunk ./src/Blog/Constants.hs 52
+data_dir :: String
+data_dir = content_root ++ "/data"
+
+sqlite_hits_db_filename :: String
+sqlite_hits_db_filename = data_dir ++ "/hits.db"
+
hunk ./src/Blog/FrontEnd/Presentation.hs 15
+import qualified Blog.BackEnd.HitTracker as HitT
hunk ./src/Blog/FrontEnd/Presentation.hs 42
-      posts = (V.lens v) . B.all_posts $ m
+      posts = (V.lens v) m
hunk ./src/Blog/FrontEnd/Presentation.hs 60
-                           , bold . stringToHtml . show $ length ((V.lens w) . B.all_posts $ m)
+                           , bold . stringToHtml . show $ length ((V.lens w) m)
hunk ./src/Blog/FrontEnd/Presentation.hs 163
-                               ; return $ render_ render_comments_as_text dc m i }
+                               ; let tags = (render_tags i)
+                               ; counts <- comment_count_and_hit_count cb m i
+                               ; return $ render_ render_comments_as_text (concatHtml [ meta_heading
+                                                                                      , tags
+                                                                                      , _group dc
+                                                                                      , counts]) m i }
hunk ./src/Blog/FrontEnd/Presentation.hs 177
-    = ( thediv ( (post_heading m i) 
-                 +++ (render_body "entry" i)
-                 +++ (render_tags i)
-                 +++ chrome)
-        ! [  theclass "entry_wrapper" ] )
+    = ( thediv ! [  theclass "entry_wrapper" ] $ concatHtml [ post_heading m i
+                                                            , render_body "entry" i
+                                                            , chrome ]
+         )
hunk ./src/Blog/FrontEnd/Presentation.hs 183
+meta_heading :: Html
+meta_heading = h3 ! [ theclass "meta_heading" ] << stringToHtml "Meta"
+
hunk ./src/Blog/FrontEnd/Presentation.hs 187
-render_comments_as_count m i = p ( comment_count +++ ( comment_link m i ) )
-    where 
-      comment_count = case (length $ B.children m i) of
-                        0 -> stringToHtml "No comments.  "
-                        1 -> _at (U.comments $ B.permalink m i) "One comment.  "
-                        n -> _at (U.comments $ B.permalink m i) ((show n) ++ " comments.  ")
+render_comments_as_count m i = _group $ concatHtml [ _left $ fancy_comment_count m i
+                                                   , _right $ add_comment_link m i ]
+
+comment_or_comments :: B.Model -> B.Item -> String
+comment_or_comments m i = case length $ B.children m i of
+                            1 -> " comment"
+                            _ -> " comments"
+
+fancy_comment_count :: B.Model -> B.Item -> Html
+fancy_comment_count m i = concatHtml [ image ! [ src "images/comments.png"
+                                               , thestyle "vertical-align: top;" ]
+                                     , stringToHtml " "
+                                     , thespan ! [ theclass "comment_count" ] << (show . length . (B.children m) $ i)
+                                     , stringToHtml $ comment_or_comments m i ]
+
+hit_count :: Int -> Html
+hit_count i = concatHtml [ thespan ! [ theclass "hit_count" ] << (show i)
+                         , stringToHtml $ " direct views" ]
+
+comment_count_and_hit_count :: CB.ChromeBackEnd -> B.Model -> B.Item -> IO Html
+comment_count_and_hit_count cb m i = do { hc <- HitT.get_hits (CB.hit_tracker cb) i
+                                        ; return $ _group . concatHtml
+                                                     $ [ _left $ fancy_comment_count m i
+                                                       , _right $ hit_count hc ] }
+
+_left :: Html -> Html
+_left h = thediv ! [ theclass "left" ] << h
+
+_right :: Html -> Html
+_right h = thediv ! [ theclass "right" ] << h
+
+empty_right :: Html
+empty_right = _right $ stringToHtml " "
+
+_group :: Html -> Html
+_group h = thediv ! [ theclass "group" ] << h
hunk ./src/Blog/FrontEnd/Presentation.hs 225
-comment_link _ i = _at (U.add_comment $ B.permatitle i) "Add a comment."
+comment_link _ i = _at (U.add_comment $ B.permatitle i) "Add a comment." ! [ theclass "add_comment_link" ]
+
+add_comment_link :: B.Model -> B.Item -> Html
+add_comment_link m i = concatHtml [ image ! [ src "images/comment_add.png"
+                                            , thestyle "vertical-align: top;" ]
+                                  , stringToHtml " "
+                                  , comment_link m i]
hunk ./src/Blog/FrontEnd/Presentation.hs 246
-      . concatHtml $ [ render_comments_as_count' m i
-                     , x
-                     , p << ( comment_link m i ) ]
+      $ comment_block +++ comments_as_text
hunk ./src/Blog/FrontEnd/Presentation.hs 248
-      x = case (length $ B.children m i) of
-            0 -> noHtml
-            _ -> concatHtml (map (render_comment_as_text m i) (B.children m i))
+      comment_block = _group $ concatHtml [ _left $ add_comment_link m i
+                                          , empty_right ]
+      comments_as_text = case (length $ B.children m i) of
+                           0 -> noHtml
+                           _ -> concatHtml (map (render_comment_as_text m i) (B.children m i))
hunk ./src/Blog/FrontEnd/Presentation.hs 261
-post_heading m i = h2 (_a (B.permalink m i) (primHtml$B.title i))
-                        +++ p ( ( post_author$B.author i)
-                                +++ (timestamp i))
+post_heading m i = concatHtml [ h2 (_a (B.permalink m i) (primHtml$B.title i))
+                              , _group . _right $ (( post_author$B.author i)
+                                                   +++ (timestamp i)) ]
hunk ./src/Blog/FrontEnd/Presentation.hs 301
-render_tag tag = (_a (tag_link tag) t)
+render_tag tag = image ! [ src "images/tag.png" ] +++ (_a (tag_link tag) t)
hunk ./src/Blog/FrontEnd/Presentation.hs 304
-      t = stringToHtml ("[" ++ tag ++ "]")
+      t = stringToHtml tag
hunk ./src/Blog/FrontEnd/Views.hs 17
+import Data.Maybe (maybeToList)
hunk ./src/Blog/FrontEnd/Views.hs 38
-    lens :: v -> [B.Item] -> [B.Item]
+    lens :: v -> B.Model -> [B.Item]
hunk ./src/Blog/FrontEnd/Views.hs 106
-    lens (All _) = filter $ ((==) B.Post) . B.kind
-    lens (ByYear y _) = B.year_filter y
-    lens (ByMonth y m _) = B.month_filter y m
-    lens (ByDay y m d _) = B.day_filter y m d
-    lens (ByTag t _) = B.tag_filter t
-    lens (ByTags t _) = B.tags_filter t
-    lens (ByYMDPermatitle y m d t) = B.ymd_plink_finder y m d t
-    lens (ByPermatitle t) = B.plink_filter t
+    lens (All _) = (filter $ ((==) B.Post) . B.kind) . B.all_posts
+    lens (ByYear y _) = (B.year_filter y) . B.all_posts
+    lens (ByMonth y m _) = (B.month_filter y m) . B.all_posts
+    lens (ByDay y m d _) = (B.day_filter y m d) . B.all_posts
+    lens (ByTag t _) = (B.tag_filter t) . B.all_posts
+    lens (ByTags t _) = (B.tags_filter t) . B.all_posts
+    lens (ByYMDPermatitle _ _ _ t) = maybeToList . ((flip B.maybe_post_by_permatitle) t)
+    lens (ByPermatitle t) = maybeToList . ((flip B.maybe_post_by_permatitle) t)
hunk ./src/Blog/FrontEnd/Views.hs 145
+
hunk ./src/Blog/FrontEnd/Views.hs 158
-page_count w m = last_page (page_size w) ((lens w) (B.all_items m))
+page_count w m = last_page (page_size w) ((lens w) m)
hunk ./src/Blog/Model/Entry.hs 121
+maybe_post_by_permatitle :: Model -> String -> Maybe Item
+maybe_post_by_permatitle = (flip M.lookup) . by_permatitle
+
hunk ./src/Blog/Widgets/ChromeBackEnd.hs 8
+import qualified Blog.BackEnd.HitTracker as HitT
hunk ./src/Blog/Widgets/ChromeBackEnd.hs 17
-                                   , soc :: SoCController }
+                                   , soc :: SoCController
+                                   , hit_tracker :: HitT.HitTracker }
hunk ./src/Blog/Widgets/ChromeBackEnd.hs 35
-            ; return $ ChromeBackEnd f t dc s ffd socc }
+            ; ht <- HitT.boot
+            ; return $ ChromeBackEnd f t dc s ffd socc ht }
hunk ./src/Blog/Widgets/Delicious.hs 12
-import Data.Digest.MD5
+import Data.Digest.Pure.MD5
hunk ./test.sh 3
-ghc --make -i../src runtests.hs
+ghc -fhpc --make -i../src runtests.hs
}