Serve trivial HTML (that just displays the JSON object) in getMessageR
This commit is contained in:
fr33domlover
parent
bd99729656
commit
5479c99e1c
1 changed files with 59 additions and 50 deletions
|
|
@ -42,6 +42,7 @@ import Yesod.Form.Functions (runFormPost)
|
|||
import Yesod.Form.Types (FormResult (..))
|
||||
import Yesod.Persist.Core (runDB, get404, getBy404)
|
||||
|
||||
import Data.Aeson.Encode.Pretty.ToEncoding
|
||||
import Network.FedURI
|
||||
import Web.ActivityPub
|
||||
import Yesod.Auth.Unverified
|
||||
|
|
@ -107,57 +108,65 @@ getNodeL getdid lmid = do
|
|||
-}
|
||||
|
||||
getDiscussionMessage :: ShrIdent -> LocalMessageId -> Handler TypedContent
|
||||
getDiscussionMessage shr lmid = selectRep $ provideAP $ 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)
|
||||
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)
|
||||
|
||||
host <- getsYesod $ appInstanceHost . appSettings
|
||||
route2local <- getEncodeRouteLocal
|
||||
lmhid <- encodeKeyHashid lmid
|
||||
return $ Doc host Note
|
||||
{ noteId = Just $ route2local $ MessageR shr lmhid
|
||||
, noteAttrib = route2local $ SharerR shr
|
||||
, noteAudience = error "TODO noteAudience"
|
||||
, noteReplyTo = Just $ fromMaybe uContext muParent
|
||||
, noteContext = Just uContext
|
||||
, notePublished = Just $ messageCreated m
|
||||
, noteContent = messageContent m
|
||||
}
|
||||
host <- getsYesod $ appInstanceHost . appSettings
|
||||
route2local <- getEncodeRouteLocal
|
||||
lmhid <- encodeKeyHashid lmid
|
||||
return $ Doc host Note
|
||||
{ noteId = Just $ route2local $ MessageR shr lmhid
|
||||
, noteAttrib = route2local $ SharerR shr
|
||||
, noteAudience = error "TODO noteAudience"
|
||||
, 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
|
||||
|
|
|
|||
Loading…
Reference in a new issue