Implement building discussion message tree from DB

This commit is contained in:
fr33domlover 2016-05-19 12:06:27 +00:00
parent 6d29553844
commit 93aeae36a8
4 changed files with 102 additions and 1 deletions

28
src/Data/Tree/Local.hs Normal file
View file

@ -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)

62
src/Vervis/Discussion.hs Normal file
View file

@ -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

View file

@ -21,6 +21,7 @@ import ClassyPrelude.Conduit
import Yesod hiding (Header, parseTime) import Yesod hiding (Header, parseTime)
import Database.Persist.Quasi import Database.Persist.Quasi
import Database.Persist.Sql (fromSqlKey)
import Yesod.Auth.HashDB (HashDBUser (..)) import Yesod.Auth.HashDB (HashDBUser (..))
import Vervis.Model.Repo import Vervis.Model.Repo
@ -34,3 +35,8 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"]
instance HashDBUser Person where instance HashDBUser Person where
userPasswordHash = personHash userPasswordHash = personHash
setPasswordHash hash person = person { personHash = Just hash } 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

View file

@ -59,6 +59,7 @@ library
Data.Text.UTF8.Local Data.Text.UTF8.Local
Data.Text.Lazy.UTF8.Local Data.Text.Lazy.UTF8.Local
Data.Time.Clock.Local Data.Time.Clock.Local
Data.Tree.Local
Development.DarcsRev Development.DarcsRev
Network.SSH.Local Network.SSH.Local
Text.FilePath.Local Text.FilePath.Local
@ -70,6 +71,7 @@ library
Vervis.Changes Vervis.Changes
Vervis.Content Vervis.Content
Vervis.Darcs Vervis.Darcs
Vervis.Discussion
Vervis.Field.Key Vervis.Field.Key
Vervis.Field.Person Vervis.Field.Person
Vervis.Field.Project Vervis.Field.Project
@ -163,6 +165,9 @@ library
, dlist , dlist
, esqueleto , esqueleto
, fast-logger , fast-logger
-- for building a message tree using DFS in
-- Vervis.Discussion, possibly also used by some git
-- graph related code?
, fgl , fgl
, file-embed , file-embed
, filepath , filepath