vervis/src/Vervis/Discussion.hs

{- This file is part of Vervis.
 -
 - Written in 2016, 2019 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
    ( MessageTreeNodeAuthor (..)
    , MessageTreeNode (..)
    , getDiscussionTree
    )
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.Text (Text)
import Data.Tree (Forest)
import Database.Esqueleto hiding (isNothing)
import Yesod.Persist.Core (runDB)

import qualified Data.HashMap.Lazy as M (fromList, lookup)

import Network.FedURI

import Data.Tree.Local (sortForestOn)
import Vervis.Foundation
import Vervis.Model

data MessageTreeNodeAuthor
    = MessageTreeNodeLocal LocalMessageId Sharer
    | MessageTreeNodeRemote Text LocalURI LocalURI

data MessageTreeNode = MessageTreeNode
    { mtnMessageId :: MessageId
    , mtnMessage   :: Message
    , mtnAuthor    :: MessageTreeNodeAuthor
    }

getMessages :: AppDB DiscussionId -> Handler [MessageTreeNode]
getMessages getdid = runDB $ do
    did <- getdid
    l <- select $ from $ \ (lm `InnerJoin` m `InnerJoin` p `InnerJoin` s) -> do
        on $ p ^. PersonIdent ==. s ^. SharerId
        on $ lm ^. LocalMessageAuthor ==. p ^. PersonId
        on $ lm ^. LocalMessageRest ==. m ^. MessageId
        where_ $ m ^. MessageRoot ==. val did
        return (m, lm ^. LocalMessageId, s)
    r <- select $ from $ \ (rm `InnerJoin` m `InnerJoin` rs `InnerJoin` i) -> do
        on $ rs ^. RemoteActorInstance ==. i ^. InstanceId
        on $ rm ^. RemoteMessageAuthor ==. rs ^. RemoteActorId
        on $ rm ^. RemoteMessageRest ==. m ^. MessageId
        where_ $ m ^. MessageRoot ==. val did
        return
            ( m
            , i ^. InstanceHost
            , rm ^. RemoteMessageIdent
            , rs ^. RemoteActorIdent
            )
    return $ map mklocal l ++ map mkremote r
    where
    mklocal (Entity mid m, Value lmid, Entity _ s) =
        MessageTreeNode mid m $ MessageTreeNodeLocal lmid s
    mkremote (Entity mid m, Value h, Value luMsg, Value luAuthor) =
        MessageTreeNode mid m $ MessageTreeNodeRemote h luMsg luAuthor

discussionTree :: [MessageTreeNode] -> Forest MessageTreeNode
discussionTree mss =
    let nodes = zip [1..] mss
        mkEntry n mtn = (mtnMessageId mtn, n)
        nodeMap = M.fromList $ map (uncurry mkEntry) nodes
        mkEdge n mtn =
            case messageParent $ mtnMessage mtn 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 MessageTreeNode ()
        roots =
            [n | (n, mtn) <- nodes, isNothing $ messageParent $ mtnMessage mtn]
    in  dffWith lab' roots graph

sortByTime :: Forest MessageTreeNode -> Forest MessageTreeNode
sortByTime = sortForestOn $ messageCreated . mtnMessage

-- | Get the tree of messages in a given discussion, with siblings sorted from
-- old to new.
getDiscussionTree :: AppDB DiscussionId -> Handler (Forest MessageTreeNode)
getDiscussionTree getdid = sortByTime . discussionTree <$> getMessages getdid