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

src/Vervis/Handler/Discussion.hs

@@ -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