vervis/src/Vervis/Discussion.hs

{- 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 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 (Forest)
import Database.Esqueleto hiding (isNothing)
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, 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, 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 (Message, Sharer) ()
        roots = [n | (n, (m, _s)) <- nodes, isNothing $ messageParent m]
    in  dffWith lab' roots graph

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 (Message, Sharer))
getDiscussion did = sortByTime . discussionTree <$> getMessages did