[Initial cut at comments and several bugfixes.
prb@mult.ifario.us**20080115064129] {
hunk ./README 54
+
+BOOTSTRAPPING CONTENT
hunk ./perpubplat/perpubplat.cabal 14
-			Blog.Model.Entry, Blog.Model.EntryParser,
+			Blog.Model.Entry, Blog.Model.EntryParser, Blog.Model.CommentBodyParser,
+			Blog.Model.CommentForm, Blog.Model.CommentQueue
+			Blog.FrontEnd.ContentAtoms, Blog.FrontEnd.CommentEntry,
hunk ./perpubplat/perpubplat.cabal 22
-			Blog.Widgets.TagCloud, Blog.Widgets.FlickrBadge
+			Blog.Widgets.TagCloud, Blog.Widgets.FlickrBadge,
+			Blog.Admin.PendingComments,
hunk ./perpubplat/src/Blog/BackEnd/DataController.hs 5
+import qualified Blog.BackEnd.IoOperations as IoO
hunk ./perpubplat/src/Blog/BackEnd/DataController.hs 9
+import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, putMVar )
hunk ./perpubplat/src/Blog/BackEnd/DataController.hs 11
-data Request = GetModel { response_channel :: Chan Model }
-             | IngestDraft { draft_name :: String,
-                             response_channel :: Chan Model }
+data Request = GetModel { get_handback :: MVar Model }
+             | IngestDraft { draft_name :: String
+                           , ingest_handback :: MVar (Item,Model) }
+             | PostComment { comment :: Item }
+             | Boot { boot_handback :: MVar Model }
hunk ./perpubplat/src/Blog/BackEnd/DataController.hs 20
-spawn_controller :: Model -> IO DataController
-spawn_controller m = do { rc <- newChan 
-                        ; t <- forkIO (loop rc m)
-                        ; return $ DataController rc t }
+spawn :: Model -> IO DataController
+spawn m = do { rc <- newChan 
+             ; t <- forkIO (loop rc m)
+             ; return $ DataController rc t }
hunk ./perpubplat/src/Blog/BackEnd/DataController.hs 28
+boot :: DataController -> IO Model
+boot c = do { cb <- newEmptyMVar
+            ; send c (Boot cb)
+            ; takeMVar cb }
+
hunk ./perpubplat/src/Blog/BackEnd/DataController.hs 34
-get_model c = do { cb <- newChan
+get_model c = do { cb <- newEmptyMVar
hunk ./perpubplat/src/Blog/BackEnd/DataController.hs 36
-                 ; readChan cb }
+                 ; takeMVar cb }
hunk ./perpubplat/src/Blog/BackEnd/DataController.hs 38
-ingest_draft :: DataController -> String -> IO Model
-ingest_draft dc s = do { cb <- newChan
+ingest_draft :: DataController -> String -> IO (Item,Model)
+ingest_draft dc s = do { cb <- newEmptyMVar
hunk ./perpubplat/src/Blog/BackEnd/DataController.hs 41
-                       ; readChan cb }
+                       ; takeMVar cb }
+
+post_comment :: DataController -> Item -> IO ()
+post_comment dc i = send dc $ PostComment i
hunk ./perpubplat/src/Blog/BackEnd/DataController.hs 48
-                ; case req of
-                    (GetModel resp) ->
-                        do {writeChan resp m 
-                           ; loop c m }
-                    (IngestDraft d resp) ->
-                        do { (_,m') <- MT.ingest_draft m d
-                           ; writeChan resp m'
-                           ; loop c m' }
+              ; case req of
+                  (GetModel hb) ->
+                      do { putMVar hb m 
+                         ; loop c m }
+                  (IngestDraft d hb) ->
+                      do { (s,m') <- MT.ingest_draft m d
+                         ; putMVar hb (s,m')
+                         ; loop c m' }
+                  (PostComment i) ->
+                      do { m' <- MT.ingest_comment m i
+                         ; loop c m' }
+                  (Boot hb) ->
+                      do { m' <- IoO.boot
+                         ; putMVar hb m'
+                         ; loop c m' }
hunk ./perpubplat/src/Blog/BackEnd/IoOperations.hs 12
--- import System.Log.Logger
-
hunk ./perpubplat/src/Blog/BackEnd/IoOperations.hs 56
-load_content f = load_ $ C.content_storage_dir </> f </> "content.ppp"
+load_content f = load $ C.content_storage_dir </> f </> "content.ppp"
hunk ./perpubplat/src/Blog/BackEnd/IoOperations.hs 62
-load_ :: FilePath -> IO B.Item
-load_ f = do { content <- readFile' f
-             ; return $ EP.item_from_string f $! content }
+load_comment :: FilePath -> IO B.Item
+load_comment f = do { content <- readFile' $ C.comment_dir </> f
+                    ; return $ EP.item_from_string f $! content }
+
+load :: FilePath -> IO B.Item
+load f = do { content <- readFile' f
+            ; return $ EP.item_from_string f $! content }
hunk ./perpubplat/src/Blog/BackEnd/ModelTransformations.hs 8
+import Control.Concurrent ( forkIO )
hunk ./perpubplat/src/Blog/BackEnd/ModelTransformations.hs 11
-ingest_draft :: Model -> String -> IO (String, Model)
+ingest_draft :: Model -> String -> IO (Item, Model)
hunk ./perpubplat/src/Blog/BackEnd/ModelTransformations.hs 22
-                             ; let plink = permatitle new_item
-                             ; I.save model' new_item
-                             ; return (plink, model') }
-
-
+                             ; forkIO $ I.save model' new_item
+                             ; return (new_item, model') }
hunk ./perpubplat/src/Blog/BackEnd/ModelTransformations.hs 28
-ingest_comment :: Model -> Item -> Item -> IO Model
-ingest_comment model p c = do {ts <- now
-                              ; let int_id = next_id model
-                              ; let new_comment = c { internal_id = int_id
-                                                    , parent = Just $ internal_id p
-                                                    , created = ts
-                                                    , updated = ts
-                                                    , permatitle = "comment-" ++ (show int_id)
-                                                    , kind = Comment }
-                              ; return $ insert model new_comment }
+ingest_comment :: Model -> Item -> IO Model
+ingest_comment model c = do { ts <- now
+                            ; let int_id = next_id model
+                            ; let new_comment = c { internal_id = int_id
+                                                  , updated = ts
+                                                  , permatitle = "comment-" ++ (show int_id)
+                                                  , kind = Comment }
+                            ; let model' = insert model new_comment
+                            ; I.save model' new_comment
+                            ; return model' }
hunk ./perpubplat/src/Blog/Constants.hs 46
+comment_dir :: String
+comment_dir = "/tmp/comments"
+
hunk ./perpubplat/src/Blog/Constants.hs 61
+comment_view_size :: Int
+comment_view_size = 30
+
addfile ./perpubplat/src/Blog/FrontEnd/CommentEntry.hs
hunk ./perpubplat/src/Blog/FrontEnd/CommentEntry.hs 1
-
+module Blog.FrontEnd.CommentEntry where
+
+import qualified Blog.Model.Entry as B
+import qualified Blog.Model.CommentForm as CF
+import Blog.FrontEnd.ContentAtoms
+
+import Text.XHtml.Strict
+
+{-
+
+Design for comments:
+
+- Unique comment submission URIs: Open a new page for the form to
+  submit a comment, create a submission URI that depends on the page.
+  This is a substitute for session state.  The form processor is
+  expected to compare the submission URI with a value sent down in the
+  form.
+
+- Allow editing a comment via the back button?
+
+- Allow no-moderation posting of a comment if we've seen the email
+  address and URI before.
+
+- Markup Approach 1 - Minimal HTML syntax: Support <code>,
+  <blockquote>, <pre>, and <a>.  Automatically turn linebreaks into
+  <p>...</p> pairs.  Automatically escape entities, i.e., turn every &
+  into &amp;. 
+
+- Markup Approach 2 - Macro syntax: Steal Reddit's.
+
+- Markup Approach 3 - Plain text only.
+
+
+-}
+
+comment_form :: B.Model -> B.Item -> String -> Maybe CF.CommentForm -> String
+comment_form m i targ cf =
+    showHtml . concatHtml $
+                 [ topmatter ( "Comment on " ++ B.permatitle i )
+                 , body . ( divid "container" )
+                            . concatHtml $ [ heading                                     
+                                           , ( divid "comment_entry" )
+                                             . concatHtml $ [ h3
+                                                              . concatHtml $ [ stringToHtml "Comment on "
+                                                                             , _a plink (primHtml $ B.title i) ]
+                                                            , build_form targ plink cf ]
+                                           , comment_sidebar
+                                           , footer ] ]
+    where
+      plink = B.permalink m i
+
+
+build_form :: String -> String -> Maybe CF.CommentForm -> Html
+build_form targ plink cf = ( form ! [ action targ
+                                    , method "post" ] )
+                           . concatHtml $ [ textarea ! [ name "commentBody"
+                                                       , theclass "body_entry"
+                                                       , rows "10" ]
+                                            << (stringToHtml bod)
+                                          , inp "Name" True "authorName" nam
+                                          , inp "Email (will not be published)" True "authorEmail" email
+                                          , inp "URL" True "authorUri" uri
+                                          , input ! [ theclass "comment_submit"
+                                                    , thetype "submit"
+                                                    , value "Post Comment" ]
+                                          , stringToHtml " or just go "
+                                          , _at plink "back"
+                                          , stringToHtml "." ]
+    where
+      bod = case cf of
+              (Just c) -> CF.body c
+              _ -> ""
+      nam = case cf of
+              (Just c) -> CF.authorName c
+              _ -> ""
+      uri = case cf of
+              (Just c) -> CF.authorUri c
+              _ -> ""
+      email = case cf of
+                (Just c) -> CF.authorEmail c
+                _ -> ""
+
+topmatter :: String -> Html
+topmatter tit = header . concatHtml $ [ thetitle . stringToHtml $ tit
+                                      , base_url
+                                      , stylesheet
+                                      , robots ]
+
+inp :: String -> Bool -> String -> String -> Html
+inp f r n v = ( p ! [ theclass "comment_datum" ] )
+              . concatHtml $ [ input ! [ name n
+                                       , theclass "datum_entry"
+                                       , value v ]
+                             , if r then
+                                   (thespan ! [ theclass "required" ]) . stringToHtml $ "*"
+                               else 
+                                   noHtml
+                             , stringToHtml (" " ++ f) ]
+
+robots :: Html
+robots = meta ! [ name "ROBOTS", content "NOINDEX, FOLLOW"]
+
+comment_sidebar :: Html
+comment_sidebar = ( divid "sidebar" )
+                  . concatHtml $ [ h3 . stringToHtml $ "Comment Formatting"
+                                 , formatting_help
+                                 , h3 . stringToHtml $ "Comment Policies"
+                                 , policy_ "All comments are moderated to avoid spam, so your comment won't appear until after I've had a chance to look at it.  Once approved, comments are displayed in the order received."
+                                 , policy_ "You can find out when your comment appears and track other comments on this entry by subscribing to the entry's comment feed."
+                                 , policy_ "I'll post pretty much anything that's not purely inflammatory, but I do reserve the right to edit comments for formatting or grammar or even to not post a comment that I feel is in poor taste or low on merit."
+                                 , policy_ "By posting a comment, you place it under the " ]
+
+formatting_help :: Html
+formatting_help = ( p ! [ theclass "formatting" ] )
+                  . ( ulist ! [ theclass "formatting" ] )
+                  . concatHtml $ [ formatting_ "Paragraphs"
+                                               " Lines are translated into paragraphs.  Blank lines are ignored."
+                                 , formatting_ "Quotes"
+                                               " Lines prefixed with a | (pipe) are treated as quotations."
+                                 , formatting_ "Code"
+                                               " Lines prefixed with a > are treated as displayed code.  Contiguous blocks of lines prefixed with a > are displayed in the same block."
+                                 , formatting "Links"
+                                              $ concatHtml [ stringToHtml " Hyperlinks of the form "
+                                                           , thecode
+                                                             << stringToHtml
+                                                                "^displayed text|http://example.com^"
+                                                           , stringToHtml
+                                                             " are supported, but that's it for markup." ] ]
+
+formatting :: String -> Html -> Html
+formatting s h = li . concatHtml $ [ bold . stringToHtml $ s
+                                   , h ]
+
+formatting_ :: String -> String -> Html
+formatting_ s = (formatting s) . stringToHtml
+
+policy :: Html -> Html
+policy h = p ! [ theclass "policies" ] << h
+
+policy_ :: String -> Html
+policy_ = policy . stringToHtml 
addfile ./perpubplat/src/Blog/FrontEnd/ContentAtoms.hs
hunk ./perpubplat/src/Blog/FrontEnd/ContentAtoms.hs 1
-
+module Blog.FrontEnd.ContentAtoms ( heading, footer, divid, _a, _at
+                                  , stylesheet, base_url ) where
+
+import Text.XHtml.Strict
+import qualified Blog.Constants as C
+import qualified Blog.FrontEnd.Views as V
+
+heading :: Html
+heading = divid "header" ( (h1 $ _at (V.url $ V.All Nothing) C.blog_title)
+                           +++
+                           (h2 $ stringToHtml C.blog_tagline) )
+
+footer :: Html
+footer = (divid "footer") . concatHtml $ [  p ! [ theclass "copyright" ] << primHtml C.license_xhtml
+                                         , p ! [ theclass "generator" ] << generator_tagline ]
+    where
+      generator_tagline =  concatHtml [ stringToHtml "Running "
+                                      , _at C.generator_uri C.generator_name
+                                      , stringToHtml " version "
+                                      , stringToHtml C.generator_version ]
+
+divid :: String -> Html -> Html
+divid label h = thediv ! [ identifier label ] << h
+
+_a :: String -> Html -> Html
+_a s h = toHtml (hotlink s h)
+
+_at :: String -> String -> Html
+_at s t = toHtml (hotlink s (stringToHtml t))
+
+stylesheet :: Html
+stylesheet = thelink ! [ href C.stylesheet_url, rel "stylesheet",  thetype "text/css" ] << noHtml
+
+base_url :: Html
+base_url = thebase ! [ href C.base_url ]
hunk ./perpubplat/src/Blog/FrontEnd/Presentation.hs 6
+import Blog.FrontEnd.ContentAtoms
hunk ./perpubplat/src/Blog/FrontEnd/Presentation.hs 23
-                  | otherwise = showHtml ( header ( (thetitle . stringToHtml $ V.title v)
-                                                    +++ (build_base)
-                                                    +++ (build_discoverable_feeds v)
-                                                    +++ stylesheet
-                                                    +++ (robots v)
-                                                  )
-                                           +++ body ( container ( heading
-                                                                  +++ (post_div $ phunk
-                                                                       +++ bottom_nav v m)
-                                                                  +++ (sidebar v m paged_posts)
-                                                                  +++ footer )
-                                                    )
-                                         )
+                  | otherwise = showHtml . concatHtml $
+                                [ topmatter v                                         
+                                , body . (divid "container") . concatHtml $
+                                  [ heading
+                                  , divid "posts" $ phunk +++ bottom_nav v m
+                                  , sidebar v m paged_posts
+                                  , footer ] ]
hunk ./perpubplat/src/Blog/FrontEnd/Presentation.hs 35
-robots :: (V.Viewable v) => v -> Html
-robots w = if (V.kind w == V.Single) then
-               meta ! [ name "ROBOTS", content "INDEX, FOLLOW"]
-           else
-               meta ! [ name "ROBOTS", content "NOINDEX, FOLLOW"]
-
-container :: Html -> Html
-container h = thediv ! [ identifier "container" ] << h
-
-post_div :: Html -> Html
-post_div h = thediv ! [ identifier "posts" ] << h
+topmatter :: (V.Viewable v) => v -> Html
+topmatter v = header . concatHtml $ [ thetitle . stringToHtml $ V.title v
+                                    , base_url
+                                    , build_discoverable_feeds v
+                                    , stylesheet
+                                    , robots ]
+    where
+      robots = if (V.kind v == V.Single) then
+                   meta ! [ name "ROBOTS", content "INDEX, FOLLOW"]
+               else
+                   meta ! [ name "ROBOTS", content "NOINDEX, FOLLOW"]
hunk ./perpubplat/src/Blog/FrontEnd/Presentation.hs 59
-               | otherwise = thediv ! [ identifier "bottomnav" ] <<
-                             ( p . concatHtml $ [ nav_blurb w m
-                                                , br
-                                                , pages w m ] )
+               | otherwise = divid "bottomnav" . p . concatHtml $ [ nav_blurb w m
+                                                                  , br
+                                                                  , pages w m ]
hunk ./perpubplat/src/Blog/FrontEnd/Presentation.hs 96
-heading :: Html
-heading = thediv ! [ identifier "header" ] << ( (h1 $ _at (V.url $ V.All Nothing) C.blog_title)
-                                                +++
-                                                (h2 $ stringToHtml C.blog_tagline) )
-
-footer :: Html
-footer = thediv ! [ identifier "footer" ] << concatHtml [  p ! [ theclass "copyright" ]
-                                                          << primHtml C.license_xhtml
-                                                        , p ! [ theclass "generator" ]
-                                                          << generator_tagline ]
-    where
-      generator_tagline =  concatHtml [ stringToHtml "Running "
-                                      , _at C.generator_uri C.generator_name
-                                      , stringToHtml " version "
-                                      , stringToHtml C.generator_version ]
-
hunk ./perpubplat/src/Blog/FrontEnd/Presentation.hs 98
-sidebar w b p = thediv ! [ identifier "sidebar" ]
-                << concatHtml [ sidebar_nav w b
-                              , contents_block "sidebarcontents" w b p 
-                              , h3 $ stringToHtml "Tags"
-                              , TC.tag_cloud (B.all_posts b) C.tags_to_show
-                              , h3 $ stringToHtml "Pictures"
-                              , FB.flickr_badge ]
+sidebar w b p = (divid "sidebar") . concatHtml $ 
+                [ sidebar_nav w b
+                , contents_block "sidebarcontents" w b p 
+                , h3 $ stringToHtml "Tags"
+                , TC.tag_cloud (B.all_posts b) C.tags_to_show
+                , h3 $ stringToHtml "Pictures"
+                , FB.flickr_badge ]
hunk ./perpubplat/src/Blog/FrontEnd/Presentation.hs 106
-
hunk ./perpubplat/src/Blog/FrontEnd/Presentation.hs 123
-build_base :: Html
-build_base = thebase ! [ href C.base_url ]
-
hunk ./perpubplat/src/Blog/FrontEnd/Presentation.hs 132
-stylesheet :: Html
-stylesheet = thelink ! [ href C.stylesheet_url, rel "stylesheet",  thetype "text/css" ] << noHtml
-
hunk ./perpubplat/src/Blog/FrontEnd/Presentation.hs 140
-
hunk ./perpubplat/src/Blog/FrontEnd/Presentation.hs 162
-render_comments_as_count m i = p << 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 = 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.")
+
+comment_link :: B.Model -> B.Item -> Html
+comment_link _ i = _at (U.add_comment $ B.permatitle i) "Add a comment."
hunk ./perpubplat/src/Blog/FrontEnd/Presentation.hs 176
-            0 -> "No comments."
-            1 -> "One comment."
-            n -> ((show n) ++ " comments.")
+            0 -> "No comments.  "
+            1 -> "One comment.  "
+            n -> ((show n) ++ " comments.  ")
hunk ./perpubplat/src/Blog/FrontEnd/Presentation.hs 183
-render_comments_as_text m i = thediv ( (render_comments_as_count' m i) +++ x ) ! [ theclass "comments" ]
+render_comments_as_text m i
+    = ( thediv ! [ theclass "comments" ] )
+      . concatHtml $ [ render_comments_as_count' m i
+                     , x
+                     , p << ( comment_link m i ) ]
hunk ./perpubplat/src/Blog/FrontEnd/Presentation.hs 226
-_a :: String -> Html -> Html
-_a s h = toHtml (hotlink s h)
-
-_at :: String -> String -> Html
-_at s t = toHtml (hotlink s (stringToHtml t))
hunk ./perpubplat/src/Blog/FrontEnd/Routes.hs 2
-module Blog.FrontEnd.Routes (parse_uri,
-                             Route (XhtmlView, AtomFeed, NoSuchUri, Command,
-                                    view, feed, uri, command)
+module Blog.FrontEnd.Routes ( parse_uri
+                            , Route ( XhtmlView, AtomFeed, NoSuchUri, Command, CommentFormView
+                                    , CommentSubmission, ReviewComments, PostComment, DeleteComment
+                                    , AlterComment, ReviewComment
+                                    , view, feed, uri, command, permatitle, page_n, int_id )
hunk ./perpubplat/src/Blog/FrontEnd/Routes.hs 17
+           | CommentFormView { permatitle :: String }
+           | CommentSubmission { permatitle :: String }
+           | ReviewComments { page_n :: Maybe Int }
+           | ReviewComment { int_id :: Int }
+           | PostComment
+           | DeleteComment
+           | AlterComment { int_id :: Int }
hunk ./perpubplat/src/Blog/FrontEnd/Routes.hs 36
+            <|> try submit_comment
+            <|> try post_comment
+            <|> try delete_comment
+            <|> try edit_comment
hunk ./perpubplat/src/Blog/FrontEnd/Routes.hs 48
-             <|> feeds }
+             <|> try feeds
+             <|> try review_pending_comments
+             <|> try review_comment
+             <|> add_comment_form }
hunk ./perpubplat/src/Blog/FrontEnd/Routes.hs 64
+submit_comment :: Parser Route
+submit_comment = do { post_method
+                    ; string "/e/add-comment/"
+                    ; t <- p_plink_title
+                    ; eof
+                    ; return $ CommentSubmission t }
+
+edit_comment :: Parser Route
+edit_comment = do { post_method
+                  ; string "/x/edit-comment/"
+                  ; int_id <- p_int
+                  ; eof
+                  ; return $ AlterComment int_id }
+
+post_comment :: Parser Route
+post_comment = do { post_method
+                  ; string "/x/post-comment"
+                  ; eof
+                  ; return PostComment }
+
+delete_comment :: Parser Route
+delete_comment = do { post_method
+                  ; string "/x/delete-comment"
+                  ; eof
+                  ; return DeleteComment }
+
+review_pending_comments :: Parser Route
+review_pending_comments = do { string "/z/review-comments"
+                             ; p <- page
+                             ; eof
+                             ; return $ ReviewComments p }
+
+review_comment :: Parser Route
+review_comment = do { string "/z/review-comment/"
+                    ; n <- p_int
+                    ; eof
+                    ; return $ ReviewComment n }
+
+add_comment_form :: Parser Route
+add_comment_form = do { string "/c/add-comment/"
+                      ; t <- p_plink_title
+                      ; eof
+                      ; return $ CommentFormView t }
+
hunk ./perpubplat/src/Blog/FrontEnd/Urls.hs 17
+
+add_comment :: String -> String
+add_comment p = C.base_url ++ "/c/add-comment/" ++ p
+
+pending_comments :: Maybe Int -> String
+pending_comments Nothing = C.base_url ++ "/z/review-comments"
+pending_comments (Just n) = C.base_url ++ "/z/review-comments/p/" ++ (show n)
+
+add_comment_target :: String -> String
+add_comment_target p = C.base_url ++ "/e/add-comment/" ++ p
+
+post_comment :: String -> String
+post_comment _ = C.base_url ++ "/x/post-comment"
+
+review_comment :: String -> String
+review_comment i = C.base_url ++ "/z/review-comment/" ++ i
+
+edit_comment_target :: Int -> String
+edit_comment_target i = C.base_url ++ "/x/edit-comment/" ++ (show i)
+
+delete_comment :: String -> String
+delete_comment _ = C.base_url ++ "/x/delete-comment"
hunk ./perpubplat/src/Blog/FrontEnd/Views.hs 11
-      page, last_page, page_count, page_
+      page, page_count
hunk ./perpubplat/src/Blog/FrontEnd/Views.hs 17
+import Utilities
hunk ./perpubplat/src/Blog/FrontEnd/Views.hs 149
-page v = page_ (page_size v) (one_if_nothing $ page_number v)
+page v = paginate (page_size v) (one_if_nothing $ page_number v)
hunk ./perpubplat/src/Blog/FrontEnd/Views.hs 155
-page_ :: Int -- ^ the page size
-      -> Int -- ^ the page index, starting from 1
-      -> [a] -- ^ the list to page through
-      -> [a]
-page_ _ _ [] = []
-page_ s i l | i < 1 = page_ s 1 l
-            | i <= last_page s l = take s (drop (s*(i-1)) l)
-            | otherwise = page_ s (last_page s l) l
-                                 
-last_page :: Int -> [a] -> Int
-last_page s as = (((length as) - 1) `div` s) + 1
-
addfile ./perpubplat/src/Blog/Model/CommentBodyParser.hs
hunk ./perpubplat/src/Blog/Model/CommentBodyParser.hs 1
-
+module Blog.Model.CommentBodyParser where
+
+import Blog.FrontEnd.ContentAtoms
+
+import Text.ParserCombinators.Parsec
+import Text.XHtml.Strict
+
+import Data.List (intersperse) 
+
+data Block = Code { lines :: [String] }
+           | Quote { lines :: [String] }
+           | Paragraph { hunks :: [Block] }
+           | Text { text :: String }
+           | Link { url :: String, text :: String }
+             deriving ( Show, Eq, Ord )
+
+convert_comment_body :: String -> Html
+convert_comment_body s = case (parse parse_comment_body "<internal>" s) of
+                           Left err ->
+                               concatHtml [ p . concatHtml $ [ bold << stringToHtml "Parsing Error: "
+                                                             , stringToHtml . show $ err ]
+                                          , pre << stringToHtml s ]
+                           Right b ->
+                               blocks_to_xhtml b
+
+parse_comment :: String -> Either ParseError [Block]
+parse_comment = parse parse_comment_body "<internal>"
+
+blocks_to_xhtml :: [Block] -> Html
+blocks_to_xhtml b = concatHtml . (map render) $ collect_ b []
+
+blocks_to_string :: [Block] -> String
+blocks_to_string = showHtmlFragment . blocks_to_xhtml
+
+render :: Block -> Html
+render (Code a) = ( pre ! [ theclass "code" ] ) . concatHtml . (intersperse (stringToHtml "\n")) . (map stringToHtml) $ a
+render (Quote a) = blockquote . concatHtml . (map ( p . stringToHtml )) $ a
+render (Paragraph a) = p . concatHtml . (map render) $ a
+render (Text a) = stringToHtml a
+render (Link u t) = _at u t
+
+collect_ :: [Block] -> [Block] -> [Block]
+collect_ [] s = reverse s
+collect_ (a:as) [] = collect_ as [a]
+collect_ (a:as) y@(b:bs) = case (a,b) of
+                            (Code l, Code m) -> collect_ as ((Code (m ++ l)):bs)
+                            (Quote q, Quote r) -> collect_ as ((Quote (r ++ q)):bs)
+                            _ -> collect_ as (a:y)
+
+parse_comment_body :: Parser [Block]
+parse_comment_body = sepEndBy parse_block eol
+
+parse_block :: Parser Block
+parse_block = parse_code_block
+              <|> parse_quote_block
+              <|> parse_paragraph_block
+
+parse_code_block :: Parser Block
+parse_code_block = do { char '>'
+                      ; s <- many not_eol
+                      ; return $ Code [s] }
+
+parse_quote_block :: Parser Block
+parse_quote_block = do { char '|'
+                       ; s <- many not_eol
+                       ; return $ Quote [s] }
+
+parse_paragraph_block :: Parser Block
+parse_paragraph_block = do { b <- many1 ( parse_link_block <|> parse_text_block )
+                           ; return $ Paragraph b }
+
+parse_link_block :: Parser Block
+parse_link_block = do { start_link
+                      ; s <- many1 $ noneOf [ '^','|','\n','\r' ]
+                      ; char '|'
+                      ; t <- many1 $ uriChar
+                      ; end_link
+                      ; return $ Link s t }
+
+parse_text_block :: Parser Block
+parse_text_block = do { s <- many1 $ noneOf ['^','\r','\n']
+                      ; return $ Text s }
+
+uriChar :: Parser Char
+uriChar = unreserved <|> gen_delim <|> sub_delim
+
+gen_delim :: Parser Char
+gen_delim = oneOf ":/?#[]@"
+
+sub_delim :: Parser Char
+sub_delim = oneOf "!$&'()*+,;=" 
+
+unreserved :: Parser Char
+unreserved = letter <|> digit <|> oneOf "-._~"
+
+start_link :: Parser ()
+start_link = do { char '^'
+                ; spaces }
+
+end_link :: Parser Char
+end_link = do { spaces
+              ; char '^' }
+
+not_eol :: Parser Char
+not_eol  = noneOf $ [ '\n','\r' ]
+
+eol :: Parser ()
+eol = skipMany1 . oneOf $ ['\n', '\r']
addfile ./perpubplat/src/Blog/Model/CommentForm.hs
hunk ./perpubplat/src/Blog/Model/CommentForm.hs 1
-
+module Blog.Model.CommentForm where
+
+import qualified Blog.Model.Entry as B
+import Utilities
+
+data CommentForm = CommentForm { authorName :: String
+                               , authorEmail :: String
+                               , authorUri :: String
+                               , body :: String }
+                   deriving ( Show, Read, Eq, Ord )
+
+from_item :: B.Item -> CommentForm
+from_item i = CommentForm (B.name a) (blankIfNothing . B.email $ a) (blankIfNothing . B.uri $ a) (B.body i)
+    where
+      a = B.author i
+          
+to_item :: B.Item -> CommentForm -> IO B.Item
+to_item i cf = do { ts <- now
+                  ; return $
+                    B.Item 0 B.Comment "" Nothing (body cf)
+                         [] "" "" ts ts
+                         ( B.Author ( authorName cf )
+                           ( Just $ authorUri cf )
+                           ( Just $ authorEmail cf )
+                           False )
+                         True (Just $ B.internal_id i) }
+
+validate :: CommentForm -> ([String],Bool)
+validate _ = ([],True)
+
+blankIfNothing :: Maybe String -> String
+blankIfNothing Nothing = ""
+blankIfNothing (Just s) = s
addfile ./perpubplat/src/Blog/Model/CommentQueue.hs
hunk ./perpubplat/src/Blog/Model/CommentQueue.hs 1
-
+module Blog.Model.CommentQueue where
+
+import qualified Blog.Model.CommentBodyParser as CBP
+import qualified Blog.Model.Entry as B
+import qualified Data.Map as M
+import Data.Map ( (!) )
+import qualified Blog.Constants as C
+import qualified Blog.Model.CommentForm as CF
+import Blog.BackEnd.IoOperations ( load )
+import qualified Blog.BackEnd.DataController as DC
+import Utilities
+
+import System.IO
+import System.FilePath ( (</>) )
+import System.Directory ( removeFile, getDirectoryContents, doesFileExist )
+import Data.List ( isPrefixOf )
+import Control.Monad ( filterM )
+import Control.Concurrent ( ThreadId, forkIO )
+import Control.Concurrent.MVar ( MVar, newEmptyMVar, putMVar, takeMVar )
+import Control.Concurrent.Chan ( Chan, newChan,  writeChan, readChan )
+
+
+{-
+Maybe just track the filenames or even just the IDs?
+-}
+data CommentQueue = CommentQueue { comments :: M.Map Int B.Item
+                                 , next_id :: Int }
+
+data CommentController = CommentController { request_channel :: Chan Request
+                                           , thread_id :: ThreadId }
+
+data Request = AddComment { parent :: B.Item
+                          , form_data :: CF.CommentForm }
+             | EditComment { comment_id :: Int
+                           , form_data :: CF.CommentForm }
+             | DeleteComment { comment_id :: Int }
+             | FetchComment { index :: Int                  
+                            , handback_item :: MVar (Maybe B.Item) }
+             | FetchComments { start :: Int
+                             , count :: Int
+                             , handback_items :: MVar [B.Item] }
+             | FetchAllComments { handback_queue :: MVar CommentQueue }
+             | Boot
+
+spawn :: CommentQueue -> IO CommentController
+spawn cq = do { c <- newChan
+              ; t <- forkIO (loop c cq)
+              ; return $ CommentController c t }
+
+loop :: Chan Request -> CommentQueue -> IO ()
+loop c cq = do { req <- readChan c
+               ; case req of
+                   (AddComment p cf) ->
+                       do { i <- CF.to_item p cf 
+                          ; cq' <- add_ cq i
+                          ; loop c cq' }
+                   (DeleteComment idx) ->
+                       do { cq' <- delete_ cq idx
+                          ; loop c cq' }
+                   (FetchComment idx res) ->
+                       do { putMVar res $ M.lookup idx (comments cq)
+                          ; loop c cq }
+                   (FetchAllComments res) ->
+                       do { putMVar res cq
+                          ; loop c cq }
+                   (EditComment k cf) ->
+                       do { let cmts = comments cq
+                          ; if M.notMember k cmts then
+                                loop c cq
+                            else
+                                do { ts <- now
+                                   ; let i' = ((comments cq) ! k) { B.author = B.Author ( CF.authorName cf )
+                                                                               ( Just $ CF.authorUri cf )
+                                                                               ( Just $ CF.authorEmail cf )
+                                                                               False
+                                                                  , B.body = CF.body cf
+                                                                  , B.updated = ts }
+                                   ; cq' <- alter_ cq i'
+                                   ; loop c cq' }
+                          }
+                   Boot ->
+                       do { cq' <- boot
+                          ; loop c cq' }
+               }
+
+post_comment :: DC.DataController -> CommentController -> Int -> IO ()
+post_comment dc cc idx = do { c <- fetch_comment cc idx
+                            ; case c of
+                                (Just i) ->
+                                    do { case (CBP.parse_comment $ B.body i) of 
+                                           Left _ ->
+                                               return ()
+                                           Right b -> 
+                                               do { let b' =  CBP.blocks_to_string b
+                                                  ; DC.post_comment dc (i { B.body = b' }) 
+                                                  ; delete_comment cc idx }
+                                       }
+                                Nothing ->
+                                    return ()
+                            }
+
+send :: CommentController -> Request -> IO ()
+send = writeChan . request_channel
+
+fetch_comment :: CommentController -> Int -> IO (Maybe B.Item)
+fetch_comment cc idx = do { v <- newEmptyMVar
+                        ; (send cc) $ FetchComment idx v
+                        ; takeMVar v }
+
+alter_comment :: CommentController -> Int -> CF.CommentForm -> IO ()
+alter_comment cc n cf = (send cc) $ EditComment n cf
+
+fetch_comments_page :: CommentController -> Int -> IO [B.Item]
+fetch_comments_page cc n = do { v <- newEmptyMVar
+                              ; (send cc) $ FetchAllComments v
+                              ; cq <- takeMVar v
+                              ; let cmts = map snd $ M.toAscList (comments cq)
+                              ; return $ paginate C.comment_view_size n cmts }
+
+fetch_comments :: CommentController -> IO [B.Item]
+fetch_comments cc = do { v <- newEmptyMVar
+                       ; (send cc) $ FetchAllComments v
+                       ; cq <- takeMVar v
+                       ; return $ map snd $ M.toAscList (comments cq) }
+
+add_comment :: CommentController -> B.Item -> CF.CommentForm -> IO ()
+add_comment cc i cf = (send cc) $ AddComment i cf
+
+delete_comment :: CommentController -> Int -> IO ()
+delete_comment cc idx = (send cc) $ DeleteComment idx
+
+empty :: CommentQueue
+empty = CommentQueue M.empty 0
+
+boot :: IO CommentQueue
+boot = do { print "Booting comment manager."
+          ; files <- getDirectoryContents C.comment_dir
+          ; let files' = (map (\x -> C.comment_dir </> x)) . (filter is_filename) $ files
+          ; files'' <- filterM (doesFileExist) files'
+          ; comments <- mapM load files''
+          ; case comments of
+              [] ->
+                  return $ empty
+              _ ->
+                  do { let m = map_by (B.internal_id) comments
+                     ; return $ CommentQueue m ((fst . M.findMax $ m) + 1) } }
+
+alter_ :: CommentQueue -> B.Item -> IO CommentQueue
+alter_ cq i = do { let cq' = cq { comments = M.insert (B.internal_id i) i (comments cq) }
+                 ; write_ i
+                 ; return cq' }
+                                
+
+add_ :: CommentQueue -> B.Item -> IO CommentQueue
+add_ cq i = do { let n = next_id cq
+               ; let i' = i { B.internal_id = n }
+               ; let cq' = cq { comments = M.insert n i' (comments cq)
+                              , next_id = n + 1 }
+               ; write_ i'
+               ; return cq' }
+
+delete_ :: CommentQueue -> Int -> IO CommentQueue
+delete_ cq idx = do { let cq' = cq { comments = M.delete idx (comments cq) }
+                    ; let f = filename idx
+                    ; removeFile f
+                    ; return cq' }
+
+write_ :: B.Item -> IO ()
+write_ i = do { let f = filename (B.internal_id i)
+              ; h <- openFile f WriteMode
+              ; hPutStr h $ B.to_string i
+              ; hClose h }
+
+filename :: Int -> FilePath
+filename k = C.comment_dir </> ("pending-comment-" ++ (show k))
+
+is_filename :: FilePath -> Bool
+is_filename = isPrefixOf "pending-comment-"
hunk ./perpubplat/src/Blog/Model/Entry.hs 55
--- internal identifier have been correctly set and that its parent, if 
+-- internal identifier have been correctly set.
hunk ./perpubplat/src/Blog/Model/Entry.hs 58
-               , by_int_id = M.insert (internal_id i') i' $ by_int_id m
-               , child_map = if (parent i == Nothing) then
-                                 M.insert (internal_id i') [] $ child_map m
-                             else 
-                                 M.insert p_id (insert_comment_ m p i') $ child_map m
+               , by_int_id = M.insert n i' $ by_int_id m
+               , child_map = M.insert (internal_id i') [] $
+                             case parent i of
+                               Nothing ->
+                                  child_map m
+                               (Just p_id) ->
+                                   M.insert p_id (insert_comment_ m (item_by_id m p_id) i') $ child_map m
hunk ./perpubplat/src/Blog/Model/Entry.hs 70
-      p_id = unwrap $ parent i
-      p = item_by_id m p_id
hunk ./perpubplat/src/Blog/Model/Entry.hs 77
-                         (y:s)
-                     else
hunk ./perpubplat/src/Blog/Model/Entry.hs 78
+                     else
+                         (y:s)
hunk ./perpubplat/src/Blog/Model/Entry.hs 115
-range :: (a->b) -> [a] -> [(b,a)]
-range f is = zip (map f is) is
-
-map_by :: (Ord b) => (a -> b) -> [a] -> M.Map b a
-map_by f is = M.fromList $ range f is
-
hunk ./perpubplat/src/Utilities.hs 1
-module Utilities (subst,hotness,readFile',now) where
+module Utilities ( subst, hotness, readFile', now
+                 , map_by, paginate, last_page ) where
hunk ./perpubplat/src/Utilities.hs 10
+import qualified Data.Map as M
+
+paginate :: Int -- ^ the page size
+      -> Int -- ^ the page index, starting from 1
+      -> [a] -- ^ the list to page through
+      -> [a]
+paginate _ _ [] = []
+paginate s i l | i < 1 = paginate s 1 l
+               | i <= last_page s l = take s (drop (s*(i-1)) l)
+               | otherwise = paginate s (last_page s l) l
+                                 
+last_page :: Int -> [a] -> Int
+last_page s as = (((length as) - 1) `div` s) + 1
hunk ./perpubplat/src/Utilities.hs 29
+range :: (a->b) -> [a] -> [(b,a)]
+range f is = zip (map f is) is
+
+map_by :: (Ord b) => (a -> b) -> [a] -> M.Map b a
+map_by f is = M.fromList $ range f is
+
+
hunk ./perpubplat_servlet/perpubplat_servlet.cabal 12
-			directory >= 1.0, xhtml >= 3000.0.2.1
+			directory >= 1.0, xhtml >= 3000.0.2.1,
+			bytestring >= 0.9
hunk ./perpubplat_servlet/src/blog.hs 5
---import qualified Blog.Errors as E
+import qualified Blog.Model.Entry as B
+import qualified Blog.Model.CommentForm as CF
hunk ./perpubplat_servlet/src/blog.hs 8
+import qualified Blog.Model.CommentQueue as CommentQ
hunk ./perpubplat_servlet/src/blog.hs 14
+import qualified Blog.FrontEnd.Urls as U
+import qualified Blog.FrontEnd.CommentEntry as CE
+import qualified Blog.Admin.PendingComments as PC
+
+import Data.ByteString.Lazy ( copy )
+import Data.ByteString.Lazy.Char8 ( unpack )
hunk ./perpubplat_servlet/src/blog.hs 21
+-- import Control.Monad ( liftM )
+import Data.Maybe (fromJust)
hunk ./perpubplat_servlet/src/blog.hs 26
-serve :: DataC.DataController -> CGI CGIResult
-serve dc = do { u <- requestURI
-              ; p <- progURI
-              ; m <- requestMethod
-              ; let c = m ++ " " ++ drop (length $ uriPath p) (uriPath u)
-              ; let route = parse_uri c
-              ; case route of 
-                  (NoSuchUri u) -> outputNotFound u
-                  (XhtmlView v) -> serve_content dc v 
-                  (AtomFeed f) -> serve_feed dc f
-                  (Command c) -> perform_command dc c }
+data Controllers = Controllers { data_c :: DataC.DataController
+                               , comment_c :: CommentQ.CommentController }
+
+serve :: Controllers -> CGI CGIResult
+serve con = do { u <- requestURI
+               ; p <- progURI
+               ; m <- requestMethod
+               ; let c = m ++ " " ++ drop (length $ uriPath p) (uriPath u)
+               ; let route = parse_uri c
+               ; case route of 
+                   (NoSuchUri u) -> outputNotFound u
+                   (XhtmlView v) -> serve_content con v 
+                   (AtomFeed f) -> serve_feed con f
+                   (CommentFormView t) -> add_comment_form con t
+                   (CommentSubmission t) -> process_comment_form con t
+                   (ReviewComments n) -> review_comments con n
+                   (ReviewComment n) -> review_comment con n
+                   PostComment -> post_comment con
+                   DeleteComment -> delete_comment con
+                   (AlterComment n) -> edit_comment con n
+                   (Command c) -> perform_command con c }
hunk ./perpubplat_servlet/src/blog.hs 48
-serve_content :: (V.Viewable v) => DataC.DataController -> v -> CGI CGIResult
-serve_content dc v = do { m <- liftIO $ DataC.get_model dc
-                        ; setStatus 200 "OK"
-                        -- ; setHeader "Content-type" "application/xhtml+xml"
-                        ; output $ P.assemble_page v m }                     
+serve_content :: (V.Viewable v) => Controllers -> v -> CGI CGIResult
+serve_content con v = do { m <- liftIO $ DataC.get_model (data_c con)
+                         ; setStatus 200 "OK"
+                         -- ; setHeader "Content-type" "application/xhtml+xml"
+                         ; output $ P.assemble_page v m }                     
hunk ./perpubplat_servlet/src/blog.hs 54
-serve_feed :: (F.Feedable f) => DataC.DataController -> f -> CGI CGIResult
-serve_feed dc f = do { m <- liftIO $ DataC.get_model dc
+serve_feed :: (F.Feedable f) => Controllers -> f -> CGI CGIResult
+serve_feed con f = do { m <- liftIO $ DataC.get_model (data_c con)
hunk ./perpubplat_servlet/src/blog.hs 60
-perform_command :: DataC.DataController -> A.Action -> CGI CGIResult
-perform_command dc c = do { setHeader "Content-type" "text/plain"
-                          ; case c of
-                              (A.Ingest d) -> liftIO ( DataC.ingest_draft dc d )
-                          ; output $ show c }
+review_comments :: Controllers -> Maybe Int -> CGI CGIResult
+review_comments con n = do { cmts <- liftIO $ CommentQ.fetch_comments (comment_c con)
+                           ; m <- liftIO $ DataC.get_model (data_c con)
+                           ; let p = case n of
+                                       Nothing -> 1
+                                       Just i -> i
+                           ; output $ PC.display_comments m p cmts }
+
+review_comment :: Controllers -> Int -> CGI CGIResult
+review_comment con n = do { cmt <- liftIO $ CommentQ.fetch_comment (comment_c con) n
+                          ; case cmt of
+                              (Just c) -> 
+                                  do { m <- liftIO $ DataC.get_model (data_c con)
+                                     ; let i = B.item_by_id m (fromJust $ B.parent c)
+                                     ; let cf = CF.from_item c
+                                     ; output $ CE.comment_form m i (U.edit_comment_target n) (Just cf) }
+                              Nothing ->
+                                  redirect $ U.pending_comments Nothing }
+
+edit_comment :: Controllers -> Int -> CGI CGIResult
+edit_comment con n = do { cf <- request_to_comment_form
+                        ; liftIO $ CommentQ.alter_comment (comment_c con) n cf
+                        ; redirect $ U.pending_comments Nothing }
+
+post_comment :: Controllers -> CGI CGIResult
+post_comment con = do { int_id <- readInput "id"
+                      ; pg <- readInput "page"
+                      ; liftIO $ CommentQ.post_comment (data_c con) (comment_c con) (fromJust int_id)
+                      ; redirect $ U.pending_comments pg }
+
+delete_comment :: Controllers -> CGI CGIResult
+delete_comment con = do { int_id <- readInput "id"
+                        ; pg <- readInput "page"
+                        ; case int_id of
+                            Nothing ->
+                                liftIO $ return ()
+                            Just n ->
+                                liftIO $ CommentQ.delete_comment (comment_c con) n
+                        ; redirect $ U.pending_comments pg }
+
+perform_command :: Controllers -> A.Action -> CGI CGIResult
+perform_command con c = do { setHeader "Content-type" "text/plain"
+                           ; case c of
+                               (A.Ingest d) ->
+                                   do { (i,m) <- liftIO ( DataC.ingest_draft (data_c con) d )
+                                      ; redirect $ B.permalink m i} }
+
+add_comment_form :: Controllers -> String -> CGI CGIResult
+add_comment_form con t = do { m <- liftIO $ DataC.get_model (data_c con)
+                            ; let i = B.post_by_permatitle m t
+                            ; output $ CE.comment_form m i (U.add_comment_target $ B.permatitle i) Nothing }
+
+process_comment_form :: Controllers -> String -> CGI CGIResult
+process_comment_form con t = do { cf<- request_to_comment_form
+                                ; m <- liftIO $ DataC.get_model (data_c con)
+                                ; let i = B.post_by_permatitle m t
+                                ; liftIO $ CommentQ.add_comment (comment_c con) i cf
+                                ; redirect $ B.permalink m i}
+
+request_to_comment_form :: CGI CF.CommentForm
+request_to_comment_form = do { authorName <- getI "authorName"
+                             ; authorEmail <- getI "authorEmail"
+                             ; authorUri <- getI "authorUri"
+                             ; body <- getI "commentBody"
+                             ; return $ CF.CommentForm authorName authorEmail authorUri body }
+
+getI :: (MonadCGI m) => String -> m String
+getI s = do { mbs <- getInputFPS s
+            ; case mbs of 
+                Nothing ->
+                    return ""
+                (Just bs) ->
+                    return $ unpack $! copy bs } -- avoid segfault
hunk ./perpubplat_servlet/src/blog.hs 134
-main :: IO ()
-main = do { m <- O.boot
-          ; dc <- DataC.spawn_controller m
-          ; runFastCGIConcurrent' forkIO 50 (serve dc) }
+main :: IO () 
+main = do { print "Booting master application."
+          ; m <- O.boot
+          ; cq <- CommentQ.boot
+          ; dc <- DataC.spawn m
+          ; cc <- CommentQ.spawn cq
+          ; let con = Controllers dc cc
+          ; runFastCGIConcurrent' forkIO 50 (serve con) }
}