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 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

getDiscussionMessage
    :: (MessageId -> Route App)
    -> AppDB DiscussionId
    -> MessageId
    -> Handler Html
getDiscussionMessage reply getdid mid = do
    (msg, shr) <- runDB $ do
        did <- getdid
        m <- get404 mid
        unless (messageRoot m == did) notFound
        p <- get404 $ messageAuthor m
        s <- get404 $ personIdent p
        return (m, s)
    now <- liftIO getCurrentTime
    defaultLayout $ messageW now shr (Entity mid msg) reply

getTopReply :: Route App -> Handler Html
getTopReply replyP = do
    ((_result, widget), enctype) <- runFormPost newMessageForm
    defaultLayout $(widgetFile "discussion/top-reply")

postTopReply
    :: Route App
    -> (MessageId -> 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
                let message = Message
                        { messageAuthor  = author
                        , messageCreated = now
                        , messageContent = nmContent nm
                        , messageParent  = Nothing
                        , messageRoot    = did
                        }
                insert message
            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
    (msg, shr) <- runDB $ do
        did <- getdid
        m <- get404 mid
        unless (messageRoot m == did) notFound
        p <- get404 $ messageAuthor m
        s <- get404 $ personIdent p
        return (m, s)
    now <- liftIO getCurrentTime
    ((_result, widget), enctype) <- runFormPost newMessageForm
    defaultLayout $(widgetFile "discussion/reply")

postReply
    :: (MessageId -> Route App)
    -> (MessageId -> Route App)
    -> (MessageId -> 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
                let message = Message
                        { messageAuthor  = author
                        , messageCreated = now
                        , messageContent = nmContent nm
                        , messageParent  = Just parent
                        , messageRoot    = did
                        }
                insert message
            setMessage "Message submitted."
            redirect $ after msgid
        FormMissing -> do
            setMessage "Field(s) missing."
            (msg, shr) <- runDB $ do
                did <- getdid
                m <- get404 mid
                unless (messageRoot m == did) notFound
                p <- get404 $ messageAuthor m
                s <- get404 $ personIdent p
                return (m, s)
            defaultLayout $(widgetFile "discussion/reply")
        FormFailure _l -> do
            setMessage "Message submission failed, see errors below."
            (msg, shr) <- runDB $ do
                did <- getdid
                m <- get404 mid
                unless (messageRoot m == did) notFound
                p <- get404 $ messageAuthor m
                s <- get404 $ personIdent p
                return (m, s)
            defaultLayout $(widgetFile "discussion/reply")