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.Time.Clock (getCurrentTime)
import Database.Persist
import Text.Blaze.Html (Html)
import Yesod.Auth (requireAuthId)
import Yesod.Core (Route, defaultLayout)
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 Vervis.Discussion
import Vervis.Form.Discussion
import Vervis.Foundation (App, Handler, AppDB)
import Vervis.Model
import Vervis.Settings (widgetFile)
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

getDiscussionMessage
    :: (MessageId -> Route App)
    -> AppDB DiscussionId
    -> MessageId
    -> Handler Html
getDiscussionMessage reply getdid mid = do
    mtn <- runDB $ getNode getdid mid
    now <- liftIO getCurrentTime
    defaultLayout $ messageW now mtn reply

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
                    }
                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
                    }
                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")