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 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 Yesod.Hashids

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
    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 $ remoteSharerInstance rs
                return $ l2f (instanceHost i) (remoteSharerIdent 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
    :: 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")