Replace dummy discussion widget with a real one

src/Vervis/Discussion.hs

@@ -20,12 +20,13 @@ where
 
 import Prelude
 
+import Control.Arrow (second)
 import Data.Graph.Inductive.Graph (mkGraph, lab')
 import Data.Graph.Inductive.PatriciaTree (Gr)
 import Data.Graph.Inductive.Query.DFS (dffWith)
 import Data.Maybe (isNothing, mapMaybe)
-import Data.Tree (Tree (..), Forest)
-import Database.Persist (Entity (..), selectList, (==.))
+import Data.Tree (Forest)
+import Database.Esqueleto hiding (isNothing)
 import Yesod.Persist.Core (runDB)
 
 import qualified Data.HashMap.Lazy as M (fromList, lookup)
@@ -34,29 +35,37 @@ import Data.Tree.Local (sortForestOn)
 import Vervis.Foundation
 import Vervis.Model
 
-getMessages :: DiscussionId -> Handler [Entity Message]
-getMessages did = runDB $ selectList [MessageRoot ==. did] []
+getMessages :: DiscussionId -> Handler [(Entity Message, Sharer)]
+getMessages did = fmap (map $ second entityVal) $ runDB $
+    select $ from $ \ (message, person, sharer) -> do
+        where_ $
+          message ^. MessageRoot   ==. val did            &&.
+          message ^. MessageAuthor ==. person ^. PersonId &&.
+          person  ^. PersonIdent   ==. sharer ^. SharerId
+        return (message, sharer)
 
-discussionTree :: [Entity Message] -> Forest (Entity Message)
-discussionTree messages =
-    let nodes = zip [1..] messages
-        nodeMap = M.fromList $ map (\ (n, Entity mid _m) -> (mid, n)) nodes
-        mkEdge n (Entity _ m) =
+discussionTree :: [(Entity Message, Sharer)] -> Forest (Message, Sharer)
+discussionTree mss =
+    let numbered = zip [1..] mss
+        mkEntry n ((Entity mid _m), _s) = (mid, n)
+        nodeMap = M.fromList $ map (uncurry mkEntry) numbered
+        mkEdge n (m, _s) =
             case messageParent m of
                 Nothing  -> Nothing
                 Just mid ->
                     case M.lookup mid nodeMap of
                         Nothing -> error "message parent not in discussion"
                         Just p  -> Just (p, n, ())
+        nodes = map (\ (n, (Entity _ m, s)) -> (n, (m, s))) numbered
         edges = mapMaybe (uncurry mkEdge) nodes
-        graph = mkGraph nodes edges :: Gr (Entity Message) ()
-        roots = [n | (n, Entity _ m) <- nodes, isNothing $ messageParent m]
+        graph = mkGraph nodes edges :: Gr (Message, Sharer) ()
+        roots = [n | (n, (m, _s)) <- nodes, isNothing $ messageParent m]
     in  dffWith lab' roots graph
 
-sortByTime :: Forest (Entity Message) -> Forest (Entity Message)
-sortByTime = sortForestOn $ messageCreated . entityVal
+sortByTime :: Forest (Message, Sharer) -> Forest (Message, Sharer)
+sortByTime = sortForestOn $ messageCreated . fst
 
 -- | Get the tree of messages in a given discussion, with siblings sorted from
 -- old to new.
-getDiscussion :: DiscussionId -> Handler (Forest (Entity Message))
+getDiscussion :: DiscussionId -> Handler (Forest (Message, Sharer))
 getDiscussion did = sortByTime . discussionTree <$> getMessages did

src/Vervis/Widget/Discussion.hs

@@ -20,10 +20,44 @@ where
 
 import Prelude
 
+import Control.Monad.IO.Class (liftIO)
+import Data.Foldable (traverse_)
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)
+import Data.Tree (Tree (..))
+import Text.Cassius (cassiusFile)
+import Yesod.Core.Handler (newIdent)
+import Yesod.Core.Widget (whamlet, toWidget, handlerToWidget)
+
+import Data.EventTime.Local (intervalToEventTime, showEventTime)
+import Data.Time.Clock.Local ()
+import Vervis.Discussion (getDiscussion)
 import Vervis.Foundation
-import Vervis.Model (DiscussionId)
+import Vervis.MediaType (MediaType (Markdown))
+import Vervis.Model
+import Vervis.Render (renderSourceT)
 import Vervis.Settings (widgetFile)
 
+messageW :: Sharer -> UTCTime -> UTCTime -> Text -> Widget
+messageW sharer created now content =
+    $(widgetFile "discussion/widget/message")
+
+messageTreeW :: Text -> UTCTime -> Tree (Message, Sharer) -> Widget
+messageTreeW cReplies now t = go t
+    where
+    go (Node (message, sharer) trees) = do
+        messageW sharer (messageCreated message) now (messageContent message)
+        [whamlet|
+            <div .#{cReplies}>
+              $forall tree <- trees
+                ^{go tree}
+        |]
+
 discussionW :: DiscussionId -> Widget
 discussionW did = do
-    $(widgetFile "discussion/widget/tree")
+    forest <- handlerToWidget $ getDiscussion did
+    cReplies <- newIdent
+    now <- liftIO getCurrentTime
+    toWidget $(cassiusFile "templates/discussion/widget/tree.cassius")
+    traverse_ (messageTreeW cReplies now) forest