From 93aeae36a88f942ca73b0091887c5b8b04b85f1d Mon Sep 17 00:00:00 2001 From: fr33domlover 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 . + - + - ♡ 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 + - . + -} + +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 . + - + - ♡ 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 + - . + -} + +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 @@ - . -} -{-# 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