vervis/src/Vervis/Handler/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.Handler.Discussion
    ( getDiscussion
    , getDiscussionMessage
    , getTopReply
    , postTopReply
    , getReply
    , postReply
    )
where

import Prelude

import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except
import Data.Maybe
import Data.Time.Clock (getCurrentTime)
import Database.Persist
import Database.Persist.Sql
import Data.Traversable
import Text.Blaze.Html (Html)
import Data.Text (Text)
import Yesod.Auth
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.Auth.Unverified
import Yesod.FedURI
import Yesod.Hashids

import Database.Persist.Local
import Yesod.Persist.Local

import Vervis.Discussion
import Vervis.Form.Discussion
import Vervis.Federation
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 $ remoteActorInstance rs
            return $ MessageTreeNodeRemote $
                l2f (instanceHost i) (remoteActorIdent 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
    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 $ TicketR shr prj $ ticketNumber t
            (Nothing, Just rd) -> do
                i <- getJust $ remoteDiscussionInstance rd
                return $ l2f (instanceHost i) (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
                lmhidParent <- encodeKeyHashid lmidParent
                return $ route2fed $ MessageR (sharerIdent s) lmhidParent
            (Nothing, Just rmParent) -> do
                rs <- getJust $ remoteMessageAuthor rmParent
                i <- getJust $ remoteActorInstance rs
                return $ l2f (instanceHost i) (remoteActorIdent rs)

    host <- getsYesod $ appInstanceHost . appSettings
    route2local <- getEncodeRouteLocal
    lmhid <- encodeKeyHashid lmid
    return $ Doc host Note
        { noteId        = Just $ route2local $ MessageR shr lmhid
        , noteAttrib    = route2local $ SharerR shr
        , noteAudience  = error "TODO noteAudience"
        , 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
    :: Text
    -> [Route App]
    -> Route App
    -> Route App
    -> (LocalMessageId -> Route App)
    -> Handler Html
postTopReply hDest recips context replyP after = do
    ((result, widget), enctype) <- runFormPost newMessageForm
    elmid <- runExceptT $ do
        msg <- case result of
            FormMissing -> throwE "Field(s) missing."
            FormFailure _l -> throwE "Message submission failed, see errors below."
            FormSuccess nm -> return $ nmContent nm
        encodeRouteFed <- getEncodeRouteFed
        encodeRouteLocal <- getEncodeRouteLocal
        let encodeRecipRoute = l2f hDest . encodeRouteLocal
        shrAuthor <- do
            Entity _ p <- requireVerifiedAuth
            lift $ runDB $ sharerIdent <$> get404 (personIdent p)
        let (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor
            uContext = encodeRecipRoute context
            note = Note
                { noteId        = Nothing
                , noteAttrib    = luAuthor
                , noteAudience  = Audience
                    { audienceTo      = map encodeRecipRoute recips
                    , audienceBto     = []
                    , audienceCc      = []
                    , audienceBcc     = []
                    , audienceGeneral = []
                    }
                , noteReplyTo   = Just uContext
                , noteContext   = Just uContext
                , notePublished = Nothing
                , noteContent   = msg
                }
        ExceptT $ handleOutboxNote hLocal note
    case elmid of
        Left e -> do
            setMessage $ toHtml e
            defaultLayout $(widgetFile "discussion/top-reply")
        Right lmid -> do
            setMessage "Message submitted."
            redirect $ after lmid

getReply
    :: (MessageId -> Route App)
    -> (MessageId -> Route App)
    -> AppDB DiscussionId
    -> MessageId
    -> Handler Html
getReply replyG replyP getdid midParent = do
    mtn <- runDB $ getNode getdid midParent
    now <- liftIO getCurrentTime
    ((_result, widget), enctype) <- runFormPost newMessageForm
    defaultLayout $(widgetFile "discussion/reply")

postReply
    :: Text
    -> [Route App]
    -> Route App
    -> (MessageId -> Route App)
    -> (MessageId -> Route App)
    -> (LocalMessageId -> Route App)
    -> AppDB DiscussionId
    -> MessageId
    -> Handler Html
postReply hDest recips context replyG replyP after getdid midParent = do
    ((result, widget), enctype) <- runFormPost newMessageForm
    elmid <- runExceptT $ do
        msg <- case result of
            FormMissing -> throwE "Field(s) missing."
            FormFailure _l -> throwE "Message submission failed, see errors below."
            FormSuccess nm -> return $ nmContent nm
        encodeRouteFed <- getEncodeRouteFed
        encodeRouteLocal <- getEncodeRouteLocal
        let encodeRecipRoute = l2f hDest . encodeRouteLocal
        (shrAuthor, uParent) <- do
            Entity _ p <- requireVerifiedAuth
            lift $ runDB $ do
                _m <- get404 midParent
                shr <- sharerIdent <$> get404 (personIdent p)
                mlocal <- getBy $ UniqueLocalMessage midParent
                mremote <- getValBy $ UniqueRemoteMessage midParent
                parent <- case (mlocal, mremote) of
                    (Nothing, Nothing) -> error "Message with no author"
                    (Just _, Just _) -> error "Message used as both local and remote"
                    (Just (Entity lmidParent lm), Nothing) -> do
                        p <- getJust $ localMessageAuthor lm
                        s <- getJust $ personIdent p
                        lmkhid <- encodeKeyHashid lmidParent
                        return $ encodeRouteFed $ MessageR (sharerIdent s) lmkhid
                    (Nothing, Just rm) -> do
                        i <- getJust $ remoteMessageInstance rm
                        return $ l2f (instanceHost i) (remoteMessageIdent rm)
                return (shr, parent)
        let (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor
            uContext = encodeRecipRoute context
            note = Note
                { noteId        = Nothing
                , noteAttrib    = luAuthor
                , noteAudience  = Audience
                    { audienceTo      = map encodeRecipRoute recips
                    , audienceBto     = []
                    , audienceCc      = []
                    , audienceBcc     = []
                    , audienceGeneral = []
                    }
                , noteReplyTo   = Just uParent
                , noteContext   = Just uContext
                , notePublished = Nothing
                , noteContent   = msg
                }
        ExceptT $ handleOutboxNote hLocal note
    case elmid of
        Left e -> do
            setMessage $ toHtml e
            mtn <- runDB $ getNode getdid midParent
            now <- liftIO getCurrentTime
            defaultLayout $(widgetFile "discussion/reply")
        Right lmid -> do
            setMessage "Message submitted."
            redirect $ after lmid