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 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 qualified Data.Text as T

import Data.Aeson.Encode.Pretty.ToEncoding
import Database.Persist.JSON
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.API
import Vervis.Discussion
import Vervis.Form.Discussion
import Vervis.Federation
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Yesod.RenderSource
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
                    (instanceHost i)
                    (remoteMessageIdent rm)
                    (remoteActorIdent rs)
                    (remoteActorName 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 = do
    doc <- runDB $ do
        sid <- getKeyBy404 $ UniqueSharer shr
        pid <- getKeyBy404 $ UniquePersonIdent sid
        lm <- get404 lmid
        unless (localMessageAuthor lm == pid) notFound
        m <- getJust $ localMessageRest lm
        route2fed <- getEncodeRouteHome
        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)
        ob <- getJust $ localMessageCreate lm
        let activity = docValue $ persistJSONValue $ outboxItemActivity ob

        host <- getsYesod $ appInstanceHost . appSettings
        route2local <- getEncodeRouteLocal
        lmhid <- encodeKeyHashid lmid
        return $ Doc host Note
            { noteId        = Just $ route2local $ MessageR shr lmhid
            , noteAttrib    = route2local $ SharerR shr
            , noteAudience  =
                case activitySpecific activity of
                    CreateActivity (Create note) -> noteAudience note
                    _ -> error $ "lmid#" ++ show (fromSqlKey lmid) ++ "'s create isn't a Create activity!"
            , noteReplyTo   = Just $ fromMaybe uContext muParent
            , noteContext   = Just uContext
            , notePublished = Just $ messageCreated m
            , noteSource    = messageSource m
            , noteContent   = messageContent m
            }
    selectRep $ do
        provideAP $ pure doc
        provideRep $
            defaultLayout
                [whamlet|
                    <div><pre>#{encodePrettyToLazyText doc}
                |]

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
    -> Route App
    -> (LocalMessageId -> Route App)
    -> Handler Html
postTopReply hDest recipsA recipsC 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 <- getEncodeRouteHome
        encodeRouteLocal <- getEncodeRouteLocal
        let encodeRecipRoute = l2f hDest . encodeRouteLocal
        shrAuthor <- do
            Entity _ p <- requireVerifiedAuth
            lift $ runDB $ sharerIdent <$> get404 (personIdent p)
        let msg' = T.filter (/= '\r') msg
        contentHtml <- ExceptT . pure $ renderPandocMarkdown msg'
        let (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor
            uContext = encodeRecipRoute context
            recips = recipsA ++ recipsC
            note = Note
                { noteId        = Nothing
                , noteAttrib    = luAuthor
                , noteAudience  = Audience
                    { audienceTo        = map encodeRecipRoute recips
                    , audienceBto       = []
                    , audienceCc        = []
                    , audienceBcc       = []
                    , audienceGeneral   = []
                    , audienceNonActors = map encodeRecipRoute recipsC
                    }
                , noteReplyTo   = Just uContext
                , noteContext   = Just uContext
                , notePublished = Nothing
                , noteSource    = msg'
                , noteContent   = contentHtml
                }
        ExceptT $ createNoteC 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]
    -> Route App
    -> (MessageId -> Route App)
    -> (MessageId -> Route App)
    -> (LocalMessageId -> Route App)
    -> AppDB DiscussionId
    -> MessageId
    -> Handler Html
postReply hDest recipsA recipsC 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 <- getEncodeRouteHome
        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 msg' = T.filter (/= '\r') msg
        contentHtml <- ExceptT . pure $ renderPandocMarkdown msg'
        let (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor
            uContext = encodeRecipRoute context
            recips = recipsA ++ recipsC
            note = Note
                { noteId        = Nothing
                , noteAttrib    = luAuthor
                , noteAudience  = Audience
                    { audienceTo        = map encodeRecipRoute recips
                    , audienceBto       = []
                    , audienceCc        = []
                    , audienceBcc       = []
                    , audienceGeneral   = []
                    , audienceNonActors = map encodeRecipRoute recipsC
                    }
                , noteReplyTo   = Just uParent
                , noteContext   = Just uContext
                , notePublished = Nothing
                , noteSource    = msg'
                , noteContent   = contentHtml
                }
        ExceptT $ createNoteC 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