From 93aeae36a88f942ca73b0091887c5b8b04b85f1d Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@rel4tion.org>
Date: Thu, 19 May 2016 12:06:27 +0000
Subject: [PATCH] Implement building discussion message tree from DB
---
src/Data/Tree/Local.hs | 28 ++++++++++++++++++
src/Vervis/Discussion.hs | 62 ++++++++++++++++++++++++++++++++++++++++
src/Vervis/Model.hs | 8 +++++-
vervis.cabal | 5 ++++
4 files changed, 102 insertions(+), 1 deletion(-)
create mode 100644 src/Data/Tree/Local.hs
create mode 100644 src/Vervis/Discussion.hs
diff --git a/src/Data/Tree/Local.hs b/src/Data/Tree/Local.hs
new file mode 100644
index 0000000..45137ab
--- /dev/null
+++ b/src/Data/Tree/Local.hs
@@ -0,0 +1,28 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Data.Tree.Local
+ ( sortForestOn
+ )
+where
+
+import Prelude
+
+import Data.List (sortOn)
+import Data.Tree
+
+sortForestOn :: Ord b => (a -> b) -> Forest a -> Forest a
+sortForestOn f =
+ sortOn (f . rootLabel) . map (\ (Node r s) -> Node r $ sortForestOn f s)
diff --git a/src/Vervis/Discussion.hs b/src/Vervis/Discussion.hs
new file mode 100644
index 0000000..e853b4b
--- /dev/null
+++ b/src/Vervis/Discussion.hs
@@ -0,0 +1,62 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Vervis.Discussion
+ ( getDiscussion
+ )
+where
+
+import Prelude
+
+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 Yesod.Persist.Core (runDB)
+
+import qualified Data.HashMap.Lazy as M (fromList, lookup)
+
+import Data.Tree.Local (sortForestOn)
+import Vervis.Foundation
+import Vervis.Model
+
+getMessages :: DiscussionId -> Handler [Entity Message]
+getMessages did = runDB $ selectList [MessageRoot ==. did] []
+
+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) =
+ 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, ())
+ edges = mapMaybe (uncurry mkEdge) nodes
+ graph = mkGraph nodes edges :: Gr (Entity Message) ()
+ roots = [n | (n, Entity _ m) <- nodes, isNothing $ messageParent m]
+ in dffWith lab' roots graph
+
+sortByTime :: Forest (Entity Message) -> Forest (Entity Message)
+sortByTime = sortForestOn $ messageCreated . entityVal
+
+-- | Get the tree of messages in a given discussion, with siblings sorted from
+-- old to new.
+getDiscussion :: DiscussionId -> Handler (Forest (Entity Message))
+getDiscussion did = sortByTime . discussionTree <$> getMessages did
diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs
index 95f93e0..b5430cc 100644
--- a/src/Vervis/Model.hs
+++ b/src/Vervis/Model.hs
@@ -13,7 +13,7 @@
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
module Vervis.Model where
@@ -21,6 +21,7 @@ import ClassyPrelude.Conduit
import Yesod hiding (Header, parseTime)
import Database.Persist.Quasi
+import Database.Persist.Sql (fromSqlKey)
import Yesod.Auth.HashDB (HashDBUser (..))
import Vervis.Model.Repo
@@ -34,3 +35,8 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"]
instance HashDBUser Person where
userPasswordHash = personHash
setPasswordHash hash person = person { personHash = Just hash }
+
+-- "Vervis.Discussion" uses a 'HashMap' where the key type is 'MessageId'
+instance Hashable MessageId where
+ hashWithSalt salt = hashWithSalt salt . fromSqlKey
+ hash = hash . fromSqlKey
diff --git a/vervis.cabal b/vervis.cabal
index 5b18e18..352ea68 100644
--- a/vervis.cabal
+++ b/vervis.cabal
@@ -59,6 +59,7 @@ library
Data.Text.UTF8.Local
Data.Text.Lazy.UTF8.Local
Data.Time.Clock.Local
+ Data.Tree.Local
Development.DarcsRev
Network.SSH.Local
Text.FilePath.Local
@@ -70,6 +71,7 @@ library
Vervis.Changes
Vervis.Content
Vervis.Darcs
+ Vervis.Discussion
Vervis.Field.Key
Vervis.Field.Person
Vervis.Field.Project
@@ -163,6 +165,9 @@ library
, dlist
, esqueleto
, fast-logger
+ -- for building a message tree using DFS in
+ -- Vervis.Discussion, possibly also used by some git
+ -- graph related code?
, fgl
, file-embed
, filepath