vervis/src/Vervis/Widget/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.Widget.Discussion
    ( messageW
    , discussionW
    )
where

import Prelude

import Control.Monad.IO.Class (liftIO)
import Data.Foldable (traverse_)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)
import Data.Tree (Tree (..))
import Text.Cassius (cassiusFile)
import Yesod.Core (Route)
import Yesod.Core.Handler (newIdent)
import Yesod.Core.Widget (whamlet, toWidget, handlerToWidget)

import qualified Data.Text as T (filter)

import Data.EventTime.Local
import Data.Time.Clock.Local ()
import Vervis.Discussion (getDiscussionTree)
import Vervis.Foundation
import Vervis.MediaType (MediaType (Markdown))
import Vervis.Model
import Vervis.Render (renderSourceT)
import Vervis.Settings (widgetFile)
import Vervis.Widget.Person (sharerLinkW)

messageW :: UTCTime -> Sharer -> Message -> (Int -> Route App) -> Widget
messageW now shr msg reply =
    let showTime =
            showEventTime .
            intervalToEventTime .
            FriendlyConvert .
            diffUTCTime now
        showContent = renderSourceT Markdown . T.filter (/= '\r')
    in  $(widgetFile "discussion/widget/message")

messageTreeW
    :: (Int -> Route App)
    -> Text
    -> UTCTime
    -> Tree (Message, Sharer)
    -> Widget
messageTreeW reply cReplies now t = go t
    where
    go (Node (message, sharer) trees) = do
        messageW now sharer message reply
        [whamlet|
            <div .#{cReplies}>
              $forall tree <- trees
                ^{go tree}
        |]

discussionW :: AppDB DiscussionId -> Route App -> (Int -> Route App) -> Widget
discussionW getdid topic reply = do
    forest <- handlerToWidget $ getDiscussionTree getdid
    cReplies <- newIdent
    now <- liftIO getCurrentTime
    let msgTree = messageTreeW reply cReplies now
    $(widgetFile "discussion/widget/tree")