Comments

Handler/Blog.hs

@@ -14,6 +14,7 @@ import Data.List (groupBy)
 import Data.Function (on)
 import Data.Text (pack)
 import Control.Arrow ((&&&))
+import Handler.Topic (comments)
 
 getBlogR :: Handler ()
 getBlogR = do
@@ -49,6 +50,7 @@ getBlogPostR year month slug = do
     tree <- loadTree tmid
     let showMap = $(widgetFile "show-map")
     defaultLayout $ do
+        comments
         addScript $ StaticR jquery_js
         addScript $ StaticR jquery_cookie_js
         addScript $ StaticR jquery_treeview_js

Handler/Book.hs

@@ -7,6 +7,7 @@ module Handler.Book
 import Wiki
 import Util (renderContent)
 import Handler.ShowMap (loadTreeNode, showTree)
+import Handler.Topic (comments)
 
 data TOC = TOC
     { tocLink :: Maybe WikiRoute
@@ -51,7 +52,9 @@ getBookR = do
     mtopic <-
         case bookTopic book of
             Nothing -> return []
-            Just tid -> fmap (map snd) $ runDB $ selectList [TopicContentTopicEq tid] [TopicContentChangedDesc] 1 0
+            Just tid -> do
+                x <- fmap (map snd) $ runDB $ selectList [TopicContentTopicEq tid] [TopicContentChangedDesc] 1 0
+                return $ map (\y -> (tid, y)) x
     defaultLayout $(hamletFile "book")
 
 getBookChapterR :: MapNodeSlug -> Handler RepHtml
@@ -66,3 +69,4 @@ getBookChapterR mnslug = do
         addLucius $(luciusFile "book")
         addLucius $(luciusFile "show-map")
         addHamlet $ showTree 2 (tMapNodeMap mn) [tree]
+        comments

Handler/Root.hs

@@ -21,14 +21,14 @@ getRootR = do
                 x <- selectList [TopicContentTopicEq tid] [TopicContentChangedDesc] 1 0
                 case x of
                     [] -> return Nothing
-                    (_, TopicContent {..}):_ -> return $ Just (topicContentFormat, topicContentContent)
+                    (_, TopicContent {..}):_ -> return $ Just (topicContentFormat, topicContentContent, tid)
     let html' =
             case mcontent of
                 Nothing -> [hamlet|
 <h1>No homepage set.
 <p>The site admin has no yet set a homepage topic.
 |]
-                Just (format, content) -> renderContent format content
+                Just (format, content, tid) -> renderContent tid format content
     defaultLayout $ addHamlet html'
 
 getPageR :: Text -> Handler RepHtml

Handler/ShowMap.hs

@@ -31,7 +31,8 @@ $forall tree <- trees
             \#{treeTitle tree}
         \</h#{show depth}>
         $maybe c <- treeContent tree
-            ^{renderContent (topicContentFormat c) (topicContentContent c)}
+            $maybe tid <- treeTopicId tree
+                ^{renderContent tid (topicContentFormat c) (topicContentContent c)}
         ^{showTree (incr depth) tmid $ treeChildren tree}
 |]
   where

Handler/Topic.hs

@@ -6,16 +6,23 @@ module Handler.Topic
     , postTopicR
     , postTopicLabelsR
     , showLTree
+    , comments
+    , getCommentCountR
+    , getCommentsR
+    , postCommentsR
     ) where
 
 import Wiki
-import Util (renderContent, validateContent)
+import Util (renderContent, validateContent, prettyDate)
 import Data.Text (pack)
 import Control.Monad (unless, when)
 import Text.Hamlet.NonPoly (html)
 import Handler.Labels (LTree (..), getLTree)
-import Data.Maybe (mapMaybe)
+import Data.Maybe (mapMaybe, fromJust, catMaybes)
 import Handler.CreateTopic (richEdit)
+import Yesod.Json
+import qualified Data.Text as T
+import qualified Text.Blaze.Renderer.String as S
 
 topicForm :: (Text, TopicFormat, Textarea, Maybe Text)
           -> Handler ((FormResult (Text, TopicFormat, Textarea, Maybe Text), Widget ()), Enctype)
@@ -55,7 +62,15 @@ getTopicR' showAuthor tid = do
     ltree <- getLTree
     slabels <- runDB $ fmap (map $ topicLabelLabel . snd) $ selectList [TopicLabelTopicEq tid] [] 0 0
     let activeLabel = flip elem slabels
-    defaultLayout $ richEdit >> $(widgetFile "topic")
+    defaultLayout $ do
+        comments
+        richEdit >> $(widgetFile "topic")
+
+comments :: Widget ()
+comments = do
+    addScript $ StaticR jquery_js
+    addJulius $(juliusFile "comments")
+    addLucius $(luciusFile "comments")
 
 showLTree :: (LabelId -> Bool) -> [LTree] -> Widget ()
 showLTree al lt = [whamlet|
@@ -112,3 +127,62 @@ postTopicLabelsR tid = do
             when (lid' `elem` sel) $
                 insert (TopicLabel tid lid') >> return ()
     redirect RedirectTemporary $ TopicR tid
+
+getCommentCountR :: Handler RepJson
+getCommentCountR = do
+    topic' <- runInputGet $ ireq textField "topic"
+    let topic = fromJust $ fromSinglePiece topic'
+    element <- runInputGet $ ireq textField "element"
+    x <- runDB $ count [CommentTopicEq topic, CommentElementEq element]
+    jsonToRepJson $ jsonMap [("count", jsonScalar $ show x)]
+
+getCommentsR :: Handler RepJson
+getCommentsR = do
+    muid <- maybeAuthId
+    topic' <- runInputGet $ ireq textField "topic"
+    let topic = fromJust $ fromSinglePiece topic'
+    element <- runInputGet $ ireq textField "element"
+    render <- getUrlRenderParams
+    comments' <- runDB $ selectList [CommentTopicEq topic, CommentElementEq element] [CommentTimeAsc] 0 0 >>= (mapM $ \(_, c) -> do
+        let tid = commentContent c
+        tcs <- selectList [TopicContentTopicEq tid] [TopicContentChangedDesc] 1 0
+        case tcs of
+            [] -> return Nothing
+            (_, tc):_ -> do
+                a <- get404 $ topicContentAuthor tc
+                let ham = renderContent tid (topicContentFormat tc) (topicContentContent tc)
+                let html' = ham render
+                return $ Just $ jsonMap
+                    [ ("name", jsonScalar $ T.unpack $ userName a)
+                    , ("date", jsonScalar $ prettyDate $ topicContentChanged tc)
+                    , ("content", jsonScalar $ S.renderHtml html')
+                    ]
+        )
+    jsonToRepJson $ jsonMap
+        [ ("comments", jsonList $ catMaybes comments')
+        , ("loggedin", jsonScalar $ maybe "false" (const "true") muid)
+        ]
+
+postCommentsR :: Handler ()
+postCommentsR = do
+    uid <- requireAuthId
+    topic' <- runInputGet $ ireq textField "topic"
+    let topic = fromJust $ fromSinglePiece topic'
+    element <- runInputGet $ ireq textField "element"
+    content <- runInputPost $ ireq textField "content"
+    source <- runInputPost $ ireq textField "source"
+    now <- liftIO getCurrentTime
+    runDB $ do
+        src <- get404 topic
+        fam <- insert $ TFamily now
+        tid <- insert $ Topic uid ("Comment on " `T.append` topicTitle src) now fam
+        _ <- insert $ TopicContent tid uid Nothing now TFText content
+        _ <- insert $ Comment topic element tid now
+        return ()
+    redirectText RedirectTemporary $ T.concat
+        [ T.takeWhile (/= '#') source
+        , "#comment-"
+        , topic'
+        , "-"
+        , element
+        ]

Util.hs

@@ -9,7 +9,7 @@ module Util
     , prettyMonthYear
     ) where
 
-import Model (TopicFormat (..), User (userEmail))
+import Model (TopicFormat (..), User (userEmail), TopicId)
 import Data.Text (Text, pack, unpack)
 import Data.Text.Encoding (encodeUtf8)
 import Text.Hamlet (Html, preEscapedText, toHtml, preEscapedString)
@@ -38,24 +38,28 @@ import Control.Monad.Trans.State (evalState, get, put)
 import Text.XML.Enumerator.Render (renderText)
 import Data.Monoid (mconcat)
 import System.IO.Unsafe (unsafePerformIO)
+import Yesod.Core (toSinglePiece)
 
-renderContent :: TopicFormat -> Text -> Hamlet WikiRoute
-renderContent TFHtml t = const $ preEscapedText t
-renderContent TFText t = const $ toHtml $ Textarea t
-renderContent TFMarkdown t = const $ preEscapedString $ writeHtmlString defaultWriterOptions $ readMarkdown defaultParserState $ unpack t
-renderContent TFDitaConcept t = ditaToHtml t
-renderContent TFDitaTopic t = ditaToHtml t
+renderContent :: TopicId -> TopicFormat -> Text -> Hamlet WikiRoute
+renderContent _ TFHtml t = const $ preEscapedText t
+renderContent _ TFText t = const $ toHtml $ Textarea t
+renderContent _ TFMarkdown t = const $ preEscapedString $ writeHtmlString defaultWriterOptions $ readMarkdown defaultParserState $ unpack t
+renderContent tid TFDitaConcept t = ditaToHtml tid t
+renderContent tid TFDitaTopic t = ditaToHtml tid t
 
-ditaToHtml :: Text -> Hamlet WikiRoute
-ditaToHtml txml render =
+ditaToHtml :: TopicId -> Text -> Hamlet WikiRoute
+ditaToHtml topic txml render =
     case runIdentity $ run $ enumList 3 ["<body>", txml, "</body>"] $$ joinI $ parseText decodeEntities $$ fromEvents of
         Left e -> toHtml $ show e
         Right (Document _ (Element _ _ nodes) _) -> mapM_ go nodes
   where
     go (NodeContent (ContentText t')) = toHtml t'
     go (NodeElement (Element n as children)) = go' n as $ mapM_ go children
     go _ = return ()
-    go' "p" _ x = [html|<p>#{x}|]
+    go' "p" as x =
+        case lookup "id" as of
+            Just [ContentText t] -> [html|<p .hascomments #comment-#{toSinglePiece topic}-#{t}>#{x}|]
+            _ -> [html|<p>#{x}|]
     go' "ul" _ x = [html|<ul>#{x}|]
     go' "ol" _ x = [html|<ol>#{x}|]
     go' "li" _ x = [html|<li>#{x}|]

Wiki.hs

@@ -252,6 +252,8 @@ instance YesodBreadcrumbs Wiki where
     breadcrumb UploadDitamapR{} = return (MsgNotFound, Nothing)
     breadcrumb BlogPostNoDateR{} = return (MsgNotFound, Nothing)
     breadcrumb UploadBlogsR{} = return (MsgNotFound, Nothing)
+    breadcrumb CommentCountR{} = return (MsgNotFound, Nothing)
+    breadcrumb CommentsR{} = return (MsgNotFound, Nothing)
 
 class YesodBreadcrumbs y where
     -- | Returns the title and the parent resource, if available. If you return

config/models

@@ -83,3 +83,9 @@ Book -- singleton
 StaticContent
     mimetype ByteString
     content ByteString
+
+Comment
+    topic TopicId Eq
+    element Text Eq
+    content TopicId
+    time UTCTime Asc

config/routes

@@ -44,3 +44,6 @@
 
 /book BookR GET
 /book/#MapNodeSlug BookChapterR GET
+
+/comments/count CommentCountR GET
+/comments CommentsR GET POST

hamlet/book.hamlet

@@ -1,4 +1,4 @@
 <h1>#{tMapTitle tm}
 $forall topic <- mtopic
-    ^{addHamlet $ renderContent (topicContentFormat topic) (topicContentContent topic)}
+    ^{addHamlet $ renderContent (fst topic) (topicContentFormat $ snd topic) (topicContentContent $ snd topic)}
 ^{showTOC tocs}

hamlet/topic.hamlet

@@ -5,7 +5,7 @@ $if showAuthor
         $maybe author <- mauthor
             \ | _{MsgTopicAuthor $ userName author}
 <div #content>
-    ^{addHamlet $ renderContent topicContentFormat topicContentContent}
+    ^{addHamlet $ renderContent tid topicContentFormat topicContentContent}
 
 $maybe form <- mform
     <div .edit-page>

julius/comments.julius

@@ -0,0 +1,44 @@
+$(function(){
+    $.each($(".hascomments"), function(i, e){
+        var x = $(e);
+        var y = x.attr("id").split("-");
+        $.getJSON("@{CommentCountR}", {topic:y[1], element:y[2]}, function(z){
+            var c = z.count == 1 ? "comment" : "comments";
+            x.append(" <a class='commentlink'> " + z.count + " " + c + "</a>"); // TRANS
+            var notLoaded = true;
+            var open = function(){
+                if (notLoaded) {
+                    notLoaded = false;
+                    x.after("<div class='comments'>Loading...</div>");
+                    $.getJSON("@{CommentsR}", {topic:y[1], element:y[2]}, function(comments){
+                        var html = ["<dl>"];
+                        $.each(comments.comments, function(i, comment){
+                            html.push("<dt>");
+                            html.push(comment.name);
+                            html.push(" <i>");
+                            html.push(comment.date);
+                            html.push("</i></dt><dd>");
+                            html.push(comment.content);
+                            html.push("</dd></dt>");
+                        });
+                        html.push("</dl>");
+                        if (comments.loggedin) {
+                            html.push("<form method='post' action='@{CommentsR}?topic=" + y[1] + "&element=" + y[2] + "'>");
+                            html.push("<input type='hidden' name='source' value='" + document.location + "'>");
+                            html.push("<textarea name='content' placeholder='Enter your comment here'></textarea>");
+                            html.push("<input type='submit' value='Add comment'>");
+                            html.push("</form>");
+                        } else {
+                            html.push("<p>You must be <a href='@{AuthR LoginR}'>logged in</a> to comment.</p>");
+                        }
+                        x.next().html(html.join(""));
+                    });
+                } else {
+                    x.next().toggleClass("hidden");
+                }
+            }
+            x.children("a.commentlink").click(open);
+            if (document.location.hash == "#" + x.attr("id")) open();
+        });
+    });
+});

lucius/comments.lucius

@@ -0,0 +1,19 @@
+a.commentlink {
+    font-size: 0.7em;
+    color: #666;
+    cursor: pointer;
+}
+
+div.comments {
+    margin-left: 1em;
+    border: 1px solid #666;
+    padding: 0.5em;
+}
+
+div.comments.hidden {
+    display: none;
+}
+
+div.comments input {
+    display: block;
+}

yesodwiki.cabal

@@ -99,3 +99,5 @@ executable         yesodwiki
                  , random
                  , old-locale
                  , base64-bytestring
+                 , yesod-json
+                 , blaze-html