vervis/src/Vervis/Handler/Discussion.hs

{- This file is part of Vervis.
 -
 - Written in 2016 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
    , getMessage
    , getTopReply
    , postTopReply
    , getReply
    , postReply
    )
where

import Prelude

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 (setMessage, redirect)
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
    :: (Int -> Route App) -> Route App -> AppDB DiscussionId -> Handler Html
getDiscussion reply topic getdid =
    defaultLayout $ discussionW getdid topic reply

getMessage :: (Int -> Route App) -> AppDB DiscussionId -> Int -> Handler Html
getMessage reply getdid num = do
    (msg, shr) <- runDB $ do
        did <- getdid
        Entity _mid m <- getBy404 $ UniqueMessage did num
        p <- get404 $ messageAuthor m
        s <- get404 $ personIdent p
        return (m, s)
    now <- liftIO getCurrentTime
    defaultLayout $ messageW now shr msg reply

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

postTopReply
    :: Route App
    -> (Int -> 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
                next <- do
                    discussion <- get404 did
                    return $ discussionNextMessage discussion
                update did [DiscussionNextMessage +=. 1]
                let message = Message
                        { messageAuthor  = author
                        , messageCreated = now
                        , messageContent = nmContent nm
                        , messageParent  = Nothing
                        , messageRoot    = did
                        , messageNumber  = next
                        }
                insert_ message
                return $ messageNumber 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
    :: (Int -> Route App)
    -> (Int -> Route App)
    -> AppDB DiscussionId
    -> Int
    -> Handler Html
getReply replyG replyP getdid num = do
    (msg, shr) <- runDB $ do
        did <- getdid
        Entity _mid m <- getBy404 $ UniqueMessage did num
        p <- get404 $ messageAuthor m
        s <- get404 $ personIdent p
        return (m, s)
    now <- liftIO getCurrentTime
    ((_result, widget), enctype) <- runFormPost newMessageForm
    defaultLayout $(widgetFile "discussion/reply")

postReply
    :: (Int -> Route App)
    -> (Int -> Route App)
    -> (Int -> Route App)
    -> AppDB DiscussionId
    -> Int
    -> Handler Html
postReply replyG replyP after getdid cnum = do
    ((result, widget), enctype) <- runFormPost newMessageForm
    now <- liftIO getCurrentTime
    case result of
        FormSuccess nm -> do
            author <- requireAuthId
            mnum <- runDB $ do
                did <- getdid
                (parent, next) <- do
                    discussion <- get404 did
                    Entity mid _message <- getBy404 $ UniqueMessage did cnum
                    return (mid, discussionNextMessage discussion)
                update did [DiscussionNextMessage +=. 1]
                let message = Message
                        { messageAuthor  = author
                        , messageCreated = now
                        , messageContent = nmContent nm
                        , messageParent  = Just parent
                        , messageRoot    = did
                        , messageNumber  = next
                        }
                insert_ message
                return $ messageNumber message
            setMessage "Message submitted."
            redirect $ after mnum
        FormMissing -> do
            setMessage "Field(s) missing."
            (msg, shr) <- runDB $ do
                did <- getdid
                Entity _mid m <- getBy404 $ UniqueMessage did cnum
                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
                Entity _mid m <- getBy404 $ UniqueMessage did cnum
                p <- get404 $ messageAuthor m
                s <- get404 $ personIdent p
                return (m, s)
            defaultLayout $(widgetFile "discussion/reply")