{- This file is part of Vervis. - - Written in 2016, 2019 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.Handler.Discussion ( getDiscussion , getDiscussionMessage , getTopReply , postTopReply , getReply , postReply ) where import Prelude import Control.Monad import Control.Monad.IO.Class (liftIO) import Data.Maybe import Data.Time.Clock (getCurrentTime) import Database.Persist import Database.Persist.Sql import Data.Traversable import Text.Blaze.Html (Html) import Yesod.Auth (requireAuthId) import Yesod.Core import Yesod.Core.Handler import Yesod.Form.Functions (runFormPost) import Yesod.Form.Types (FormResult (..)) import Yesod.Persist.Core (runDB, get404, getBy404) import Network.FedURI import Web.ActivityPub import Yesod.FedURI import Database.Persist.Local import Yesod.Persist.Local import Vervis.Discussion import Vervis.Form.Discussion import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident import Vervis.Settings import Vervis.Widget.Discussion getDiscussion :: (MessageId -> Route App) -> Route App -> AppDB DiscussionId -> Handler Html getDiscussion reply topic getdid = defaultLayout $ discussionW getdid topic reply getNode :: AppDB DiscussionId -> MessageId -> AppDB MessageTreeNode getNode getdid mid = do did <- getdid m <- get404 mid unless (messageRoot m == did) notFound mlocal <- getBy $ UniqueLocalMessage mid mremote <- getBy $ UniqueRemoteMessage mid author <- case (mlocal, mremote) of (Nothing, Nothing) -> fail "Message with no author" (Just _, Just _) -> fail "Message used as both local and remote" (Just (Entity lmid lm), Nothing) -> do p <- getJust $ localMessageAuthor lm s <- getJust $ personIdent p return $ MessageTreeNodeLocal lmid s (Nothing, Just (Entity _rmid rm)) -> do rs <- getJust $ remoteMessageAuthor rm i <- getJust $ remoteSharerInstance rs return $ MessageTreeNodeRemote $ l2f (instanceHost i) (remoteSharerIdent rs) return $ MessageTreeNode mid m author {- getNodeL :: AppDB DiscussionId -> LocalMessageId -> AppDB MessageTreeNode getNodeL getdid lmid = do did <- getdid lm <- get404 lmid let mid = localMessageRest lm m <- getJust mid unless (messageRoot m == did) notFound p <- getJust $ localMessageAuthor lm s <- getJust $ personIdent p return $ MessageTreeNode mid m $ MessageTreeNodeLocal lmid s -} getDiscussionMessage :: ShrIdent -> LocalMessageId -> Handler TypedContent getDiscussionMessage shr lmid = selectRep $ provideAP $ runDB $ do sid <- getKeyBy404 $ UniqueSharer shr pid <- getKeyBy404 $ UniquePersonIdent sid lm <- get404 lmid unless (localMessageAuthor lm == pid) notFound m <- getJust $ localMessageRest lm route2fed <- getEncodeRouteFed encodeHid <- getsYesod appHashidEncode (uRecip, uContext) <- do let did = messageRoot m mt <- getValBy $ UniqueTicketDiscussion did mrd <- getValBy $ UniqueRemoteDiscussion did case (mt, mrd) of (Nothing, Nothing) -> fail $ "DiscussionId #" ++ show did ++ " has no context" (Just _, Just _) -> fail $ "DiscussionId #" ++ show did ++ " has both ticket and remote contexts" (Just t, Nothing) -> do j <- getJust $ ticketProject t s <- getJust $ projectSharer j let shr = sharerIdent s prj = projectIdent j return ( route2fed $ ProjectR shr prj , route2fed $ TicketR shr prj $ ticketNumber t ) (Nothing, Just rd) -> do let iid = remoteDiscussionInstance rd i <- getJust iid let hInstance = instanceHost i mrs <- traverse getJust $ remoteDiscussionActor rd let muActor = f2l <$> remoteDiscussionUnlinkedActor rd luActor <- case (mrs, muActor) of (Nothing, Nothing) -> fail "RemoteDiscussion actor and unlinkedActor both unset" (Just _, Just _) -> fail "RemoteDiscussion actor and unlinkedActor both set" (Just rs, Nothing) -> do unless (iid == remoteSharerInstance rs) $ fail "RemoteDiscussion and its actor on different hosts" return $ remoteSharerIdent rs (Nothing, Just (h, lu)) -> do unless (hInstance == h) $ fail "RemoteDiscussion and its unlinked actor on different hosts" return lu return ( l2f hInstance luActor , l2f hInstance (remoteDiscussionIdent rd) ) muParent <- for (messageParent m) $ \ midParent -> do mlocal <- getBy $ UniqueLocalMessage midParent mremote <- getValBy $ UniqueRemoteMessage midParent case (mlocal, mremote) of (Nothing, Nothing) -> fail "Message with no author" (Just _, Just _) -> fail "Message used as both local and remote" (Just (Entity lmidParent lmParent), Nothing) -> do p <- getJust $ localMessageAuthor lmParent s <- getJust $ personIdent p let lmhidParent = encodeHid $ fromSqlKey lmidParent return $ route2fed $ MessageR (sharerIdent s) lmhidParent (Nothing, Just rmParent) -> do rs <- getJust $ remoteMessageAuthor rmParent i <- getJust $ remoteSharerInstance rs return $ l2f (instanceHost i) (remoteSharerIdent rs) host <- getsYesod $ appInstanceHost . appSettings route2local <- getEncodeRouteLocal let lmhid = encodeHid $ fromSqlKey lmid return $ Doc host Note { noteId = Just $ route2local $ MessageR shr lmhid , noteAttrib = route2local $ SharerR shr , noteAudience = deliverTo uRecip , noteReplyTo = Just $ fromMaybe uContext muParent , noteContext = Just uContext , notePublished = Just $ messageCreated m , noteContent = messageContent m } getTopReply :: Route App -> Handler Html getTopReply replyP = do ((_result, widget), enctype) <- runFormPost newMessageForm defaultLayout $(widgetFile "discussion/top-reply") postTopReply :: Route App -> (LocalMessageId -> Route App) -> AppDB DiscussionId -> Handler Html postTopReply replyP after getdid = do ((result, widget), enctype) <- runFormPost newMessageForm now <- liftIO getCurrentTime case result of FormSuccess nm -> do author <- requireAuthId mnum <- runDB $ do did <- getdid mid <- insert Message { messageCreated = now , messageContent = nmContent nm , messageParent = Nothing , messageRoot = did } lmid <- insert LocalMessage { localMessageAuthor = author , localMessageRest = mid , localMessageUnlinkedParent = Nothing } return lmid setMessage "Message submitted." redirect $ after mnum FormMissing -> do setMessage "Field(s) missing." defaultLayout $(widgetFile "discussion/top-reply") FormFailure _l -> do setMessage "Message submission failed, see errors below." defaultLayout $(widgetFile "discussion/top-reply") getReply :: (MessageId -> Route App) -> (MessageId -> Route App) -> AppDB DiscussionId -> MessageId -> Handler Html getReply replyG replyP getdid mid = do mtn <- runDB $ getNode getdid mid now <- liftIO getCurrentTime ((_result, widget), enctype) <- runFormPost newMessageForm defaultLayout $(widgetFile "discussion/reply") postReply :: (MessageId -> Route App) -> (MessageId -> Route App) -> (LocalMessageId -> Route App) -> AppDB DiscussionId -> MessageId -> Handler Html postReply replyG replyP after getdid mid = do ((result, widget), enctype) <- runFormPost newMessageForm now <- liftIO getCurrentTime case result of FormSuccess nm -> do author <- requireAuthId msgid <- runDB $ do did <- getdid parent <- do message <- get404 mid unless (messageRoot message == did) notFound return mid mid <- insert Message { messageCreated = now , messageContent = nmContent nm , messageParent = Just parent , messageRoot = did } lmid <- insert LocalMessage { localMessageAuthor = author , localMessageRest = mid , localMessageUnlinkedParent = Nothing } return lmid setMessage "Message submitted." redirect $ after msgid FormMissing -> do setMessage "Field(s) missing." mtn <- runDB $ getNode getdid mid defaultLayout $(widgetFile "discussion/reply") FormFailure _l -> do setMessage "Message submission failed, see errors below." mtn <- runDB $ getNode getdid mid defaultLayout $(widgetFile "discussion/reply")