diff --git a/src/Vervis/Handler/Patch.hs b/src/Vervis/Handler/Patch.hs index 7533642..58e891f 100644 --- a/src/Vervis/Handler/Patch.hs +++ b/src/Vervis/Handler/Patch.hs @@ -265,19 +265,26 @@ getSharerPatchVersionR shr talkhid ptkhid = do encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome encodePatchId <- getEncodeKeyHashid + hLocal <- getsYesod siteInstanceHost let versionUrl = SharerPatchVersionR shr talkhid . encodePatchId versionAP = AP.Patch - { AP.patchId = encodeRouteLocal here - , AP.patchAttributedTo = encodeRouteHome $ SharerR shr + { AP.patchLocal = Just + ( hLocal + , AP.PatchLocal + { AP.patchId = encodeRouteLocal here + , AP.patchContext = + encodeRouteLocal $ SharerPatchR shr talkhid + , AP.patchPrevVersions = + map (encodeRouteLocal . versionUrl) versions + } + ) + , AP.patchAttributedTo = encodeRouteLocal $ SharerR shr , AP.patchPublished = patchCreated patch - , AP.patchContext = encodeRouteLocal $ SharerPatchR shr talkhid , AP.patchType = case vcs of VCSDarcs -> PatchTypeDarcs VCSGit -> error "TODO add PatchType for git patches" , AP.patchContent = patchContent patch - , AP.patchPrevVersions = - map (encodeRouteLocal . versionUrl) versions } provideHtmlAndAP versionAP $ redirectToPrettyJSON here where @@ -541,27 +548,35 @@ getRepoPatchVersionR shr rp ltkhid ptkhid = do encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome encodePatchId <- getEncodeKeyHashid + hLocal <- getsYesod siteInstanceHost let versionUrl = RepoPatchVersionR shr rp ltkhid . encodePatchId + host = + case author of + Left _ -> hLocal + Right (i, _) -> instanceHost i versionAP = AP.Patch - { AP.patchId = encodeRouteLocal here + { AP.patchLocal = Just + ( hLocal + , AP.PatchLocal + { AP.patchId = encodeRouteLocal here + , AP.patchContext = + encodeRouteLocal $ RepoPatchR shr rp ltkhid + , AP.patchPrevVersions = + map (encodeRouteLocal . versionUrl) versions + } + ) , AP.patchAttributedTo = case author of Left sharer -> - encodeRouteHome $ SharerR $ sharerIdent sharer - Right (inztance, object) -> - ObjURI - (instanceHost inztance) - (remoteObjectIdent object) + encodeRouteLocal $ SharerR $ sharerIdent sharer + Right (_, object) -> remoteObjectIdent object , AP.patchPublished = patchCreated patch - , AP.patchContext = encodeRouteLocal $ RepoPatchR shr rp ltkhid , AP.patchType = case vcs of VCSDarcs -> PatchTypeDarcs VCSGit -> error "TODO add PatchType for git patches" , AP.patchContent = patchContent patch - , AP.patchPrevVersions = - map (encodeRouteLocal . versionUrl) versions } - provideHtmlAndAP versionAP $ redirectToPrettyJSON here + provideHtmlAndAP' host versionAP $ redirectToPrettyJSON here where here = RepoPatchVersionR shr rp ltkhid ptkhid diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 188cb0f..2b83a7d 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -47,6 +47,7 @@ module Web.ActivityPub , TextHtml (..) , TextPandocMarkdown (..) , PatchType (..) + , PatchLocal (..) , Patch (..) , TicketLocal (..) , MergeRequest (..) @@ -838,14 +839,45 @@ instance ToJSON PatchType where where render PatchTypeDarcs = "application/x-darcs-patch" :: Text -data Patch u = Patch +data PatchLocal = PatchLocal { patchId :: LocalURI - , patchAttributedTo :: ObjURI u - , patchPublished :: UTCTime , patchContext :: LocalURI + , patchPrevVersions :: [LocalURI] + } + +parsePatchLocal + :: UriMode u => Object -> Parser (Maybe (Authority u, PatchLocal)) +parsePatchLocal o = do + mid <- o .:? "id" + case mid of + Nothing -> do + verifyNothing "context" + verifyNothing "previousVersions" + return Nothing + Just (ObjURI a id_) -> + fmap (Just . (a,)) $ + PatchLocal + <$> pure id_ + <*> withAuthorityO a (o .: "context") + <*> (traverse (withAuthorityO a . return) =<< o .:? "previousVersions" .!= []) + where + verifyNothing t = + if t `M.member` o + then fail $ T.unpack t ++ " field found, expected none" + else return () + +encodePatchLocal :: UriMode u => Authority u -> PatchLocal -> Series +encodePatchLocal a (PatchLocal id_ context versions) + = "id" .= ObjURI a id_ + <> "context" .= ObjURI a context + <> "previousVersions" .= map (ObjURI a) versions + +data Patch u = Patch + { patchLocal :: Maybe (Authority u, PatchLocal) + , patchAttributedTo :: LocalURI + , patchPublished :: UTCTime , patchType :: PatchType , patchContent :: Text - , patchPrevVersions :: [LocalURI] } instance ActivityPub Patch where @@ -856,26 +888,23 @@ instance ActivityPub Patch where unless (typ == ("Patch" :: Text)) $ fail "type isn't Patch" - ObjURI a id_ <- o .: "id" + ObjURI a attrib <- o .: "attributedTo" fmap (a,) $ - Patch id_ - <$> o .: "attributedTo" + Patch + <$> parsePatchLocal o + <*> pure attrib <*> o .: "published" - <*> withAuthorityO a (o .: "context") <*> o .: "mediaType" <*> o .: "content" - <*> (traverse (withAuthorityO a . return) =<< o .:? "previousVersions" .!= []) - toSeries a (Patch id_ attrib published context typ content vers) - = "id" .= ObjURI a id_ + toSeries a (Patch local attrib published typ content) + = maybe mempty (uncurry encodePatchLocal) local <> "type" .= ("Patch" :: Text) - <> "attributedTo" .= attrib - <> "context" .= ObjURI a context + <> "attributedTo" .= ObjURI a attrib <> "published" .= published <> "mediaType" .= typ <> "content" .= content - <> "previousVersions" .= map (ObjURI a) vers data TicketLocal = TicketLocal { ticketId :: LocalURI