Eventually-decentralized project hosting and management platform
Clone
HTTPS:
darcs clone https://vervis.peers.community/repos/WvWbo
SSH:
darcs clone USERNAME@vervis.peers.community:WvWbo
Tags
TODO
Discussion.hs
{- This file is part of Vervis.
-
- Written in 2016, 2019, 2022 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 Control.Monad.IO.Class (liftIO)
import Data.Text (Text)
import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)
import Data.Tree (Tree (..))
import Database.Persist.Types (Entity (..))
import Yesod.Core
import Yesod.Core.Handler (newIdent)
import Yesod.Core.Widget
import qualified Data.Text as T (filter)
import Data.MediaType
import Network.FedURI
import Web.Text
import Yesod.Hashids
import Yesod.RenderSource
import Data.EventTime.Local
import Data.Time.Clock.Local ()
import Vervis.Data.Discussion
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Persist.Discussion
import Vervis.Recipient
import Vervis.Settings (widgetFile)
import Vervis.Widget.Person
actorLinkW :: MessageTreeNodeAuthor -> Widget
actorLinkW actor = do
hashAuthor <- getHashLocalActor
$(widgetFile "widget/actor-link")
where
shortURI h (LocalURI p) = renderAuthority h <> p
messageW
:: UTCTime -> MessageTreeNode -> (MessageId -> Route App) -> Widget
messageW now (MessageTreeNode msgid msg author) reply = do
hashAuthor <- getHashLocalActor
encodeHid <- getEncodeKeyHashid
let showTime =
showEventTime .
intervalToEventTime .
FriendlyConvert .
diffUTCTime now
$(widgetFile "discussion/widget/message")
messageTreeW
:: (MessageId -> Route App)
-> Text
-> UTCTime
-> Tree MessageTreeNode
-> Widget
messageTreeW reply cReplies now t = go t
where
go (Node mtn trees) = do
messageW now mtn reply
[whamlet|
<ul .#{cReplies}>
$forall tree <- trees
^{go tree}
|]
discussionW :: AppDB DiscussionId -> Route App -> (MessageId -> 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")
|