mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-09 21:16:45 +09:00
311 lines
12 KiB
Haskell
311 lines
12 KiB
Haskell
{- 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 Control.Monad.Trans.Except
|
|
import Data.Maybe
|
|
import Data.Time.Clock (getCurrentTime)
|
|
import Database.Persist
|
|
import Database.Persist.Sql
|
|
import Data.Traversable
|
|
import Text.Blaze.Html (Html)
|
|
import Data.Text (Text)
|
|
import Yesod.Auth
|
|
import Yesod.Core
|
|
import Yesod.Core.Handler
|
|
import Yesod.Form.Functions (runFormPost)
|
|
import Yesod.Form.Types (FormResult (..))
|
|
import Yesod.Persist.Core (runDB, get404, getBy404)
|
|
|
|
import Data.Aeson.Encode.Pretty.ToEncoding
|
|
import Database.Persist.JSON
|
|
import Network.FedURI
|
|
import Web.ActivityPub
|
|
import Yesod.Auth.Unverified
|
|
import Yesod.FedURI
|
|
import Yesod.Hashids
|
|
|
|
import Database.Persist.Local
|
|
import Yesod.Persist.Local
|
|
|
|
import Vervis.Discussion
|
|
import Vervis.Form.Discussion
|
|
import Vervis.Federation
|
|
import Vervis.Foundation
|
|
import Vervis.Model
|
|
import Vervis.Model.Ident
|
|
import Vervis.Settings
|
|
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 $ remoteActorInstance rs
|
|
return $
|
|
MessageTreeNodeRemote
|
|
(instanceHost i)
|
|
(remoteMessageIdent rm)
|
|
(remoteActorIdent rs)
|
|
(remoteActorName rs)
|
|
return $ MessageTreeNode mid m author
|
|
|
|
{-
|
|
getNodeL :: AppDB DiscussionId -> LocalMessageId -> AppDB MessageTreeNode
|
|
getNodeL getdid lmid = do
|
|
did <- getdid
|
|
lm <- get404 lmid
|
|
let mid = localMessageRest lm
|
|
m <- getJust mid
|
|
unless (messageRoot m == did) notFound
|
|
p <- getJust $ localMessageAuthor lm
|
|
s <- getJust $ personIdent p
|
|
return $ MessageTreeNode mid m $ MessageTreeNodeLocal lmid s
|
|
-}
|
|
|
|
getDiscussionMessage :: ShrIdent -> LocalMessageId -> Handler TypedContent
|
|
getDiscussionMessage shr lmid = do
|
|
doc <- runDB $ do
|
|
sid <- getKeyBy404 $ UniqueSharer shr
|
|
pid <- getKeyBy404 $ UniquePersonIdent sid
|
|
lm <- get404 lmid
|
|
unless (localMessageAuthor lm == pid) notFound
|
|
m <- getJust $ localMessageRest lm
|
|
route2fed <- getEncodeRouteHome
|
|
uContext <- do
|
|
let did = messageRoot m
|
|
mt <- getValBy $ UniqueTicketDiscussion did
|
|
mrd <- getValBy $ UniqueRemoteDiscussion did
|
|
case (mt, mrd) of
|
|
(Nothing, Nothing) -> fail $ "DiscussionId #" ++ show did ++ " has no context"
|
|
(Just _, Just _) -> fail $ "DiscussionId #" ++ show did ++ " has both ticket and remote contexts"
|
|
(Just t, Nothing) -> do
|
|
j <- getJust $ ticketProject t
|
|
s <- getJust $ projectSharer j
|
|
let shr = sharerIdent s
|
|
prj = projectIdent j
|
|
return $ route2fed $ TicketR shr prj $ ticketNumber t
|
|
(Nothing, Just rd) -> do
|
|
i <- getJust $ remoteDiscussionInstance rd
|
|
return $ l2f (instanceHost i) (remoteDiscussionIdent rd)
|
|
muParent <- for (messageParent m) $ \ midParent -> do
|
|
mlocal <- getBy $ UniqueLocalMessage midParent
|
|
mremote <- getValBy $ UniqueRemoteMessage midParent
|
|
case (mlocal, mremote) of
|
|
(Nothing, Nothing) -> fail "Message with no author"
|
|
(Just _, Just _) -> fail "Message used as both local and remote"
|
|
(Just (Entity lmidParent lmParent), Nothing) -> do
|
|
p <- getJust $ localMessageAuthor lmParent
|
|
s <- getJust $ personIdent p
|
|
lmhidParent <- encodeKeyHashid lmidParent
|
|
return $ route2fed $ MessageR (sharerIdent s) lmhidParent
|
|
(Nothing, Just rmParent) -> do
|
|
rs <- getJust $ remoteMessageAuthor rmParent
|
|
i <- getJust $ remoteActorInstance rs
|
|
return $ l2f (instanceHost i) (remoteActorIdent rs)
|
|
ob <- getJust $ localMessageCreate lm
|
|
let activity = docValue $ persistJSONValue $ outboxItemActivity ob
|
|
|
|
host <- getsYesod $ appInstanceHost . appSettings
|
|
route2local <- getEncodeRouteLocal
|
|
lmhid <- encodeKeyHashid lmid
|
|
return $ Doc host Note
|
|
{ noteId = Just $ route2local $ MessageR shr lmhid
|
|
, noteAttrib = route2local $ SharerR shr
|
|
, noteAudience =
|
|
case activitySpecific activity of
|
|
CreateActivity (Create note) -> noteAudience note
|
|
_ -> error $ "lmid#" ++ show (fromSqlKey lmid) ++ "'s create isn't a Create activity!"
|
|
, noteReplyTo = Just $ fromMaybe uContext muParent
|
|
, noteContext = Just uContext
|
|
, notePublished = Just $ messageCreated m
|
|
, noteContent = messageContent m
|
|
}
|
|
selectRep $ do
|
|
provideAP $ pure doc
|
|
provideRep $
|
|
defaultLayout
|
|
[whamlet|
|
|
<div><pre>#{encodePrettyToLazyText doc}
|
|
|]
|
|
|
|
getTopReply :: Route App -> Handler Html
|
|
getTopReply replyP = do
|
|
((_result, widget), enctype) <- runFormPost newMessageForm
|
|
defaultLayout $(widgetFile "discussion/top-reply")
|
|
|
|
postTopReply
|
|
:: Text
|
|
-> [Route App]
|
|
-> [Route App]
|
|
-> Route App
|
|
-> Route App
|
|
-> (LocalMessageId -> Route App)
|
|
-> Handler Html
|
|
postTopReply hDest recipsA recipsC context replyP after = do
|
|
((result, widget), enctype) <- runFormPost newMessageForm
|
|
elmid <- runExceptT $ do
|
|
msg <- case result of
|
|
FormMissing -> throwE "Field(s) missing."
|
|
FormFailure _l -> throwE "Message submission failed, see errors below."
|
|
FormSuccess nm -> return $ nmContent nm
|
|
encodeRouteFed <- getEncodeRouteHome
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
let encodeRecipRoute = l2f hDest . encodeRouteLocal
|
|
shrAuthor <- do
|
|
Entity _ p <- requireVerifiedAuth
|
|
lift $ runDB $ sharerIdent <$> get404 (personIdent p)
|
|
let (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor
|
|
uContext = encodeRecipRoute context
|
|
recips = recipsA ++ recipsC
|
|
note = Note
|
|
{ noteId = Nothing
|
|
, noteAttrib = luAuthor
|
|
, noteAudience = Audience
|
|
{ audienceTo = map encodeRecipRoute recips
|
|
, audienceBto = []
|
|
, audienceCc = []
|
|
, audienceBcc = []
|
|
, audienceGeneral = []
|
|
, audienceNonActors = map encodeRecipRoute recipsC
|
|
}
|
|
, noteReplyTo = Just uContext
|
|
, noteContext = Just uContext
|
|
, notePublished = Nothing
|
|
, noteContent = msg
|
|
}
|
|
ExceptT $ handleOutboxNote hLocal note
|
|
case elmid of
|
|
Left e -> do
|
|
setMessage $ toHtml e
|
|
defaultLayout $(widgetFile "discussion/top-reply")
|
|
Right lmid -> do
|
|
setMessage "Message submitted."
|
|
redirect $ after lmid
|
|
|
|
getReply
|
|
:: (MessageId -> Route App)
|
|
-> (MessageId -> Route App)
|
|
-> AppDB DiscussionId
|
|
-> MessageId
|
|
-> Handler Html
|
|
getReply replyG replyP getdid midParent = do
|
|
mtn <- runDB $ getNode getdid midParent
|
|
now <- liftIO getCurrentTime
|
|
((_result, widget), enctype) <- runFormPost newMessageForm
|
|
defaultLayout $(widgetFile "discussion/reply")
|
|
|
|
postReply
|
|
:: Text
|
|
-> [Route App]
|
|
-> [Route App]
|
|
-> Route App
|
|
-> (MessageId -> Route App)
|
|
-> (MessageId -> Route App)
|
|
-> (LocalMessageId -> Route App)
|
|
-> AppDB DiscussionId
|
|
-> MessageId
|
|
-> Handler Html
|
|
postReply hDest recipsA recipsC context replyG replyP after getdid midParent = do
|
|
((result, widget), enctype) <- runFormPost newMessageForm
|
|
elmid <- runExceptT $ do
|
|
msg <- case result of
|
|
FormMissing -> throwE "Field(s) missing."
|
|
FormFailure _l -> throwE "Message submission failed, see errors below."
|
|
FormSuccess nm -> return $ nmContent nm
|
|
encodeRouteFed <- getEncodeRouteHome
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
let encodeRecipRoute = l2f hDest . encodeRouteLocal
|
|
(shrAuthor, uParent) <- do
|
|
Entity _ p <- requireVerifiedAuth
|
|
lift $ runDB $ do
|
|
_m <- get404 midParent
|
|
shr <- sharerIdent <$> get404 (personIdent p)
|
|
mlocal <- getBy $ UniqueLocalMessage midParent
|
|
mremote <- getValBy $ UniqueRemoteMessage midParent
|
|
parent <- case (mlocal, mremote) of
|
|
(Nothing, Nothing) -> error "Message with no author"
|
|
(Just _, Just _) -> error "Message used as both local and remote"
|
|
(Just (Entity lmidParent lm), Nothing) -> do
|
|
p <- getJust $ localMessageAuthor lm
|
|
s <- getJust $ personIdent p
|
|
lmkhid <- encodeKeyHashid lmidParent
|
|
return $ encodeRouteFed $ MessageR (sharerIdent s) lmkhid
|
|
(Nothing, Just rm) -> do
|
|
i <- getJust $ remoteMessageInstance rm
|
|
return $ l2f (instanceHost i) (remoteMessageIdent rm)
|
|
return (shr, parent)
|
|
let (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor
|
|
uContext = encodeRecipRoute context
|
|
recips = recipsA ++ recipsC
|
|
note = Note
|
|
{ noteId = Nothing
|
|
, noteAttrib = luAuthor
|
|
, noteAudience = Audience
|
|
{ audienceTo = map encodeRecipRoute recips
|
|
, audienceBto = []
|
|
, audienceCc = []
|
|
, audienceBcc = []
|
|
, audienceGeneral = []
|
|
, audienceNonActors = map encodeRecipRoute recipsC
|
|
}
|
|
, noteReplyTo = Just uParent
|
|
, noteContext = Just uContext
|
|
, notePublished = Nothing
|
|
, noteContent = msg
|
|
}
|
|
ExceptT $ handleOutboxNote hLocal note
|
|
case elmid of
|
|
Left e -> do
|
|
setMessage $ toHtml e
|
|
mtn <- runDB $ getNode getdid midParent
|
|
now <- liftIO getCurrentTime
|
|
defaultLayout $(widgetFile "discussion/reply")
|
|
Right lmid -> do
|
|
setMessage "Message submitted."
|
|
redirect $ after lmid
|