forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Serve trivial HTML (that just displays the JSON object) in getMessageR

Browse source
This commit is contained in:
fr33domlover 2019-05-24 16:09:58 +00:00
parent bd99729656
commit 5479c99e1c
1 changed files with 59 additions and 50 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

109
src/Vervis/Handler/Discussion.hs
View file

@ -42,6 +42,7 @@ import Yesod.Form.Functions (runFormPost)
import Yesod.Form.Types (FormResult (..)) import Yesod.Form.Types (FormResult (..))
import Yesod.Persist.Core (runDB, get404, getBy404) import Yesod.Persist.Core (runDB, get404, getBy404)
import Data.Aeson.Encode.Pretty.ToEncoding
import Network.FedURI import Network.FedURI
import Web.ActivityPub import Web.ActivityPub
import Yesod.Auth.Unverified import Yesod.Auth.Unverified
@ -107,57 +108,65 @@ getNodeL getdid lmid = do
-} -}
getDiscussionMessage :: ShrIdent -> LocalMessageId -> Handler TypedContent getDiscussionMessage :: ShrIdent -> LocalMessageId -> Handler TypedContent
getDiscussionMessage shr lmid = selectRep $ provideAP $ runDB $ do getDiscussionMessage shr lmid = do
sid <- getKeyBy404 $ UniqueSharer shr doc <- runDB $ do
pid <- getKeyBy404 $ UniquePersonIdent sid sid <- getKeyBy404 $ UniqueSharer shr
lm <- get404 lmid pid <- getKeyBy404 $ UniquePersonIdent sid
unless (localMessageAuthor lm == pid) notFound lm <- get404 lmid
m <- getJust $ localMessageRest lm unless (localMessageAuthor lm == pid) notFound
route2fed <- getEncodeRouteHome m <- getJust $ localMessageRest lm
uContext <- do route2fed <- getEncodeRouteHome
let did = messageRoot m uContext <- do
mt <- getValBy $ UniqueTicketDiscussion did let did = messageRoot m
mrd <- getValBy $ UniqueRemoteDiscussion did mt <- getValBy $ UniqueTicketDiscussion did
case (mt, mrd) of mrd <- getValBy $ UniqueRemoteDiscussion did
(Nothing, Nothing) -> fail $ "DiscussionId #" ++ show did ++ " has no context" case (mt, mrd) of
(Just _, Just _) -> fail $ "DiscussionId #" ++ show did ++ " has both ticket and remote contexts" (Nothing, Nothing) -> fail $ "DiscussionId #" ++ show did ++ " has no context"
(Just t, Nothing) -> do (Just _, Just _) -> fail $ "DiscussionId #" ++ show did ++ " has both ticket and remote contexts"
j <- getJust $ ticketProject t (Just t, Nothing) -> do
s <- getJust $ projectSharer j j <- getJust $ ticketProject t
let shr = sharerIdent s s <- getJust $ projectSharer j
prj = projectIdent j let shr = sharerIdent s
return $ route2fed $ TicketR shr prj $ ticketNumber t prj = projectIdent j
(Nothing, Just rd) -> do return $ route2fed $ TicketR shr prj $ ticketNumber t
i <- getJust $ remoteDiscussionInstance rd (Nothing, Just rd) -> do
return $ l2f (instanceHost i) (remoteDiscussionIdent rd) i <- getJust $ remoteDiscussionInstance rd
muParent <- for (messageParent m) $ \ midParent -> do return $ l2f (instanceHost i) (remoteDiscussionIdent rd)
mlocal <- getBy $ UniqueLocalMessage midParent muParent <- for (messageParent m) $ \ midParent -> do
mremote <- getValBy $ UniqueRemoteMessage midParent mlocal <- getBy $ UniqueLocalMessage midParent
case (mlocal, mremote) of mremote <- getValBy $ UniqueRemoteMessage midParent
(Nothing, Nothing) -> fail "Message with no author" case (mlocal, mremote) of
(Just _, Just _) -> fail "Message used as both local and remote" (Nothing, Nothing) -> fail "Message with no author"
(Just (Entity lmidParent lmParent), Nothing) -> do (Just _, Just _) -> fail "Message used as both local and remote"
p <- getJust $ localMessageAuthor lmParent (Just (Entity lmidParent lmParent), Nothing) -> do
s <- getJust $ personIdent p p <- getJust $ localMessageAuthor lmParent
lmhidParent <- encodeKeyHashid lmidParent s <- getJust $ personIdent p
return $ route2fed $ MessageR (sharerIdent s) lmhidParent lmhidParent <- encodeKeyHashid lmidParent
(Nothing, Just rmParent) -> do return $ route2fed $ MessageR (sharerIdent s) lmhidParent
rs <- getJust $ remoteMessageAuthor rmParent (Nothing, Just rmParent) -> do
i <- getJust $ remoteActorInstance rs rs <- getJust $ remoteMessageAuthor rmParent
return $ l2f (instanceHost i) (remoteActorIdent rs) i <- getJust $ remoteActorInstance rs
return $ l2f (instanceHost i) (remoteActorIdent rs)
host <- getsYesod $ appInstanceHost . appSettings host <- getsYesod $ appInstanceHost . appSettings
route2local <- getEncodeRouteLocal route2local <- getEncodeRouteLocal
lmhid <- encodeKeyHashid lmid lmhid <- encodeKeyHashid lmid
return $ Doc host Note return $ Doc host Note
{ noteId = Just $ route2local $ MessageR shr lmhid { noteId = Just $ route2local $ MessageR shr lmhid
, noteAttrib = route2local $ SharerR shr , noteAttrib = route2local $ SharerR shr
, noteAudience = error "TODO noteAudience" , noteAudience = error "TODO noteAudience"
, noteReplyTo = Just $ fromMaybe uContext muParent , noteReplyTo = Just $ fromMaybe uContext muParent
, noteContext = Just uContext , noteContext = Just uContext
, notePublished = Just $ messageCreated m , notePublished = Just $ messageCreated m
, noteContent = messageContent m , noteContent = messageContent m
} }
selectRep $ do
provideAP $ pure doc
provideRep $
defaultLayout
[whamlet|
<div><pre>#{encodePrettyToLazyText doc}
|]
getTopReply :: Route App -> Handler Html getTopReply :: Route App -> Handler Html
getTopReply replyP = do getTopReply replyP = do