diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs index 30b3ecf..66fe8da 100644 --- a/src/Vervis/Handler/Discussion.hs +++ b/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| +
#{encodePrettyToLazyText doc} + |] getTopReply :: Route App -> Handler Html getTopReply replyP = do