Merge pull request #1 from prb/claude/review-haskell-blog-server-011CUze3o7w6pDJcA8GWncVG

Review legacy Haskell blog server code

Author: prb

perpubplat.cabal

@@ -11,20 +11,25 @@ stability: 		alpha
 build-type:		Simple
 cabal-version:		>= 1.2
 
-Executable perpubplat.fcgi
+Executable perpubplat
  build-depends:
-  base >= 3.0 && < 4.0, parsec >= 2.0, xhtml >= 3000, haskell98, filepath >= 1.0,
-  old-time >= 1.0, containers, directory, utf8-string >= 0.2, HTTP >= 4000.0.4,
-  old-locale >= 1.0, json >= 0.4.3, network >= 2.1, time >= 1.1.2.0,
-  unix >= 2.3, fastcgi >= 3001.0.2.2, bytestring >= 0.9.0.1.1, pureMD5 >= 0.2.2, 
+  base >= 4.9 && < 5, parsec >= 3.1, filepath >= 1.0,
+  containers, directory, utf8-string >= 0.2,
+  network >= 2.1, network-uri >= 2.6, time >= 1.9,
+  unix >= 2.3, bytestring >= 0.9.0.1.1, pureMD5 >= 0.2.2,
   base64-string, hslogger >= 1.0.5, xml >= 1.3.4,
-  HDBC >= 2.1.0, HDBC-sqlite3 >= 2.1.0.0
+  HDBC >= 2.1.0, HDBC-sqlite3 >= 2.1.0.0,
+  http-client >= 0.5, http-client-tls >= 0.3, http-types >= 0.12,
+  aeson >= 2.0, text >= 1.2, vector >= 0.12, scientific >= 0.3,
+  lucid >= 2.9,
+  wai >= 3.2, warp >= 3.3, case-insensitive >= 1.2,
+  random >= 1.2
  main-is:
   perpubplat.hs
  hs-source-dirs:
   src, servletsrc
  ghc-options:
-  -O -Werror -fwarn-unused-binds -fwarn-unused-imports -fwarn-unused-matches -threaded
+  -O -fwarn-unused-binds -fwarn-unused-imports -fwarn-unused-matches -threaded
 
 Executable runtests
  buildable:
@@ -36,4 +41,4 @@ Executable runtests
  hs-source-dirs:
   testsrc
  ghc-options:
-  -O -Werror -fwarn-unused-binds -fwarn-unused-imports -fwarn-unused-matches -threaded
+  -O -fwarn-unused-binds -fwarn-unused-imports -fwarn-unused-matches -threaded

servletsrc/perpubplat.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Blog.Admin.PendingComments where
 
 import qualified Blog.Model.CommentBodyParser as CBP
@@ -8,149 +9,152 @@ import Utilities
 
 import Data.Maybe
 import Blog.FrontEnd.ContentAtoms
-import Text.XHtml.Strict
+import Lucid
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
 
 display_comments :: B.Model -> Int -> [B.Item] -> String
-display_comments m page cmts
-    = showHtml
-      . concatHtml $ [ header << stylesheet
-                     , body . (divid "container") . concatHtml $ [ navigation page cmts
-                                                                 , nuke page chunk
-                                                                 , concatHtml ( map (render m page) chunk ) ] ]
-    where
-      chunk = paginate C.comment_view_size page cmts
-     
-
-nuke :: Int -> [B.Item] -> Html
-nuke _ [] = noHtml
-nuke n items = ( p ! [ theclass "nuke_em" ] )
-               $ nuke_comments_form (map (show . B.internal_id) items) n
- 
-navigation :: Int -> [B.Item] -> Html
-navigation _ [] = (p ! [ theclass "comment_nav" ] )
-                  << stringToHtml "There are no comments waiting for review."                               
-navigation n cmts = ( p ! [ theclass "comment_nav" ] )
-                    . concatHtml $ [ stringToHtml ( "There " ++ isare )
-                                   , bold . stringToHtml . show . length $ cmts
-                                   , stringToHtml ( plural ++ " waiting for review." )
-                                   , br 
-                                   , page_enumeration n cmts ]
-    where
-      isare = case length cmts of
-                1 -> "is "
-                _ -> "are "
-      plural = case length cmts of
-                 1 -> " comment "
-                 _ -> " comments "
-
-page_enumeration :: Int -> [B.Item] -> Html
-page_enumeration _ [] = noHtml
-page_enumeration n s | (1 == last_page C.comment_view_size s) = noHtml
-                     | otherwise = concatHtml $ map (page_link n lp) [1..lp]
+display_comments m page cmts =
+    TL.unpack . renderText $ do
+        head_ stylesheet
+        body_ $ divid "container" $ do
+            navigation page cmts
+            nuke page chunk
+            mconcat $ map (render m page) chunk
+  where
+    chunk = paginate C.comment_view_size page cmts
+
+nuke :: Int -> [B.Item] -> Html ()
+nuke _ [] = mempty
+nuke n items = p_ [class_ "nuke_em"] $
+    nuke_comments_form (map (show . B.internal_id) items) n
+
+navigation :: Int -> [B.Item] -> Html ()
+navigation _ [] = p_ [class_ "comment_nav"] $
+    toHtml ("There are no comments waiting for review." :: String)
+navigation n cmts = p_ [class_ "comment_nav"] $ do
+    toHtml ( "There " ++ isare )
+    strong_ $ toHtml $ show $ length cmts
+    toHtml ( plural ++ " waiting for review." )
+    br_ []
+    page_enumeration n cmts
+  where
+    isare = case length cmts of
+              1 -> "is "
+              _ -> "are "
+    plural = case length cmts of
+               1 -> " comment "
+               _ -> " comments "
+
+page_enumeration :: Int -> [B.Item] -> Html ()
+page_enumeration _ [] = mempty
+page_enumeration n s | (1 == last_page C.comment_view_size s) = mempty
+                     | otherwise = mconcat $ map (page_link n lp) [1..lp]
     where
       lp = last_page C.comment_view_size s
 
-page_link :: Int -> Int -> Int -> Html
-page_link i k j | (i == j)  = (bold . stringToHtml . show $ j)
-                              +++ if (j==k) then
-                                      noHtml
-                                  else
-                                      (stringToHtml " ")
-                | otherwise = (_at (U.pending_comments $ Just j) (show j)) +++ (stringToHtml " ")
-
-render :: B.Model -> Int -> B.Item -> Html
-render m n i = (thediv ! [ theclass "comment_container" ])
-               . (table ! [ theclass "comment_wrapper" ] ) . tr . concatHtml $
-               [ ( td ! [ theclass "data_cell" ] )
-                 . concatHtml $ [ ( p ! [ theclass "comment_preview_fields" ])
-                                  . concatHtml $ [ render_author . B.author $ i
-                                                 , br
-                                                 , d . B.created $ i
-                                                 , stringToHtml " / # "
-                                                 , d . show . B.internal_id $ i
-                                                 , stringToHtml " / re: "
-                                                 , _a (parent_plink) (primHtml . B.title $ parent) ]
-                                , (thediv ! [ theclass "comment_body_preview"])
-                                  << ( CBP.convert_comment_body . B.body $ i ) ]
-               , ( td ! [ theclass "action_cell" ] )
-                 . concatHtml $ [ post_comment_form int_id n
-                                , edit_comment_form int_id
-                                , delete_comment_form int_id n ]
-               ]
-    where
-      int_id = show . B.internal_id $ i
-      parent = (B.item_by_id m) . fromJust . B.parent $ i
-      parent_plink = B.permalink m parent
-      d = bold . stringToHtml
-
-post_comment_form :: String -> Int -> Html
-post_comment_form int_id n = ( form ! [ identifier $ "post-" ++ int_id
-                                      , method "post"
-                                      , action . U.post_comment $ int_id] )
-                             . concatHtml $ [ callback int_id n
-                                            , input ! [ thetype "submit"
-                                                      , value "Post"
-                                                      , theclass "post_comment_submit" ] ]
-
-delete_comment_form :: String -> Int -> Html
-delete_comment_form int_id n = ( form ! [ identifier $ "delete-" ++ int_id
-                                        , method "post"
-                                        , action U.delete_comment] )
-                               . concatHtml $ [ callback int_id n
-                                              , input ! [ thetype "submit"
-                                                        , value "Delete"
-                                                        , theclass "delete_comment_submit" ] ]
-
-
-nuke_comments_form :: [String] -> Int -> Html
-nuke_comments_form int_ids n = ( form ! [ identifier $ "nuke"
-                                        , method "post"
-                                        , action U.delete_comments ] )
-                               . concatHtml $ [ callbacks int_ids n
-                                              , input ! [ thetype "submit"
-                                                        , value "Nuke All On Page"
-                                                        , theclass "nuke_comments_submit" ] ]
-
-callbacks :: [String] -> Int -> Html
-callbacks int_ids n = (hidden_int_ids int_ids)
-                      +++ (hidden_page n)
-
-hidden_int_id :: String -> Html
-hidden_int_id int_id =  input ! [ thetype "hidden"
-                                , name "id"
-                                , value int_id ]
-
-hidden_int_ids :: [String] -> Html
-hidden_int_ids = concatHtml . map (\x -> input ! [ thetype "hidden"
-                                             , name $ "id_" ++ x
-                                             , value x ])
-
-hidden_page :: Int -> Html
-hidden_page n = input ! [ thetype "hidden"
-                        , name "page"
-                        , value (show n) ]
-
-callback :: String -> Int -> Html
-callback int_id n = (hidden_int_id int_id) 
-                    +++ (hidden_page n)
-
-edit_comment_form :: String -> Html
-edit_comment_form int_id = ( form ! [ identifier $ "edit-" ++ int_id
-                                    , method "get"
-                                    , action . U.review_comment $ int_id ] )
-                           << input ! [ thetype "submit"
-                                      , value "Edit"
-                                      , theclass "edit_comment_submit" ]
-
-render_author :: B.Author -> Html
-render_author a = concatHtml [ bold . stringToHtml . B.name $ a
-                             , stringToHtml " / "
-                             , bold . stringToHtml $ case (B.email a) of
-                                                Nothing -> "<no email>"
-                                                Just e -> e
-                             , stringToHtml " / "
-                             , case B.uri a of
-                                 Nothing ->
-                                     stringToHtml "<no URI>"
-                                 Just u ->
-                                     _a u (bold . stringToHtml $ u) ]
+page_link :: Int -> Int -> Int -> Html ()
+page_link i k j | (i == j)  = do
+                      strong_ $ toHtml $ show j
+                      if (j==k) then mempty else toHtml (" " :: String)
+                | otherwise = do
+                      _at (U.pending_comments $ Just j) (show j)
+                      toHtml (" " :: String)
+
+render :: B.Model -> Int -> B.Item -> Html ()
+render m n i = div_ [class_ "comment_container"] $
+    table_ [class_ "comment_wrapper"] $ tr_ $ do
+        td_ [class_ "data_cell"] $ do
+            p_ [class_ "comment_preview_fields"] $ do
+                render_author $ B.author i
+                br_ []
+                d $ B.created i
+                toHtml (" / # " :: String)
+                d $ show $ B.internal_id i
+                toHtml (" / re: " :: String)
+                _a parent_plink (toHtmlRaw $ B.title parent)
+            div_ [class_ "comment_body_preview"] $
+                CBP.convert_comment_body $ B.body i
+        td_ [class_ "action_cell"] $ do
+            post_comment_form int_id n
+            edit_comment_form int_id
+            delete_comment_form int_id n
+  where
+    int_id = show . B.internal_id $ i
+    parent = (B.item_by_id m) . fromJust . B.parent $ i
+    parent_plink = B.permalink m parent
+    d = strong_ . toHtml
+
+post_comment_form :: String -> Int -> Html ()
+post_comment_form int_id n = form_ [ id_ (T.pack $ "post-" ++ int_id)
+                                   , method_ "post"
+                                   , action_ (T.pack $ U.post_comment int_id) ] $ do
+    callback int_id n
+    input_ [ type_ "submit"
+           , value_ "Post"
+           , class_ "post_comment_submit" ]
+
+delete_comment_form :: String -> Int -> Html ()
+delete_comment_form int_id n = form_ [ id_ (T.pack $ "delete-" ++ int_id)
+                                     , method_ "post"
+                                     , action_ (T.pack U.delete_comment) ] $ do
+    callback int_id n
+    input_ [ type_ "submit"
+           , value_ "Delete"
+           , class_ "delete_comment_submit" ]
+
+nuke_comments_form :: [String] -> Int -> Html ()
+nuke_comments_form int_ids n = form_ [ id_ "nuke"
+                                     , method_ "post"
+                                     , action_ (T.pack U.delete_comments) ] $ do
+    callbacks int_ids n
+    input_ [ type_ "submit"
+           , value_ "Nuke All On Page"
+           , class_ "nuke_comments_submit" ]
+
+callbacks :: [String] -> Int -> Html ()
+callbacks int_ids n = do
+    hidden_int_ids int_ids
+    hidden_page n
+
+hidden_int_id :: String -> Html ()
+hidden_int_id int_id = input_ [ type_ "hidden"
+                               , name_ "id"
+                               , value_ (T.pack int_id) ]
+
+hidden_int_ids :: [String] -> Html ()
+hidden_int_ids = mconcat . map (\x -> input_ [ type_ "hidden"
+                                              , name_ (T.pack $ "id_" ++ x)
+                                              , value_ (T.pack x) ])
+
+hidden_page :: Int -> Html ()
+hidden_page n = input_ [ type_ "hidden"
+                       , name_ "page"
+                       , value_ (T.pack $ show n) ]
+
+callback :: String -> Int -> Html ()
+callback int_id n = do
+    hidden_int_id int_id
+    hidden_page n
+
+edit_comment_form :: String -> Html ()
+edit_comment_form int_id = form_ [ id_ (T.pack $ "edit-" ++ int_id)
+                                 , method_ "get"
+                                 , action_ (T.pack $ U.review_comment int_id) ] $
+    input_ [ type_ "submit"
+           , value_ "Edit"
+           , class_ "edit_comment_submit" ]
+
+render_author :: B.Author -> Html ()
+render_author a = do
+    strong_ $ toHtml $ B.name a
+    toHtml (" / " :: String)
+    strong_ $ toHtml $ case (B.email a) of
+                         Nothing -> "<no email>"
+                         Just e -> e
+    toHtml (" / " :: String)
+    case B.uri a of
+        Nothing ->
+            toHtml ("<no URI>" :: String)
+        Just u ->
+            _a u (strong_ $ toHtml u)

src/Blog/Admin/PendingComments.hs

@@ -40,5 +40,5 @@ append n i h c = do { ((p,m),l,ts) <- readChan c
                       else
                           append n (i+1) h c }
 
-printex :: Handle -> CE.Exception -> IO ()
+printex :: Handle -> CE.SomeException -> IO ()
 printex h e = hPutStrLn System.IO.stderr $ "Error writing to log handle " ++ (show h) ++ ": " ++ show e

src/Blog/BackEnd/AsyncLogHandler.hs

@@ -14,7 +14,7 @@ import qualified System.Log.Logger as L
 
 data HitTracker = HitTracker { events :: CCC.Chan Request
                              , database_worker :: DatabaseWorker
-                             , hits :: ! (DM.Map String Int)
+                             , hits :: !(DM.Map String Int)
                              , tracker_tid :: CC.ThreadId }
 
 data Request = TallyHit { h_item :: Item }