Web.ActivityPub: Add PatchLocal type similar to TicketLocal

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.patchLocal        = Just
-            , AP.patchAttributedTo = encodeRouteHome $ SharerR shr
+                ( 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
+                        encodeRouteLocal $ SharerR $ sharerIdent sharer
-                    Right (inztance, object) ->
+                    Right (_, object) -> remoteObjectIdent object
-                        ObjURI
-                            (instanceHost inztance)
-                            (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

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_
+            Patch
-                <$> o .: "attributedTo"
+                <$> 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)
+    toSeries a (Patch local attrib published typ content)
-        =  "id"               .= ObjURI a id_
+        =  maybe mempty (uncurry encodePatchLocal) local
         <> "type"             .= ("Patch" :: Text)
-        <> "attributedTo"     .= attrib
+        <> "attributedTo"     .= ObjURI a attrib
-        <> "context"          .= ObjURI a context
         <> "published"        .= published
         <> "mediaType"        .= typ
         <> "content"          .= content
-        <> "previousVersions" .= map (ObjURI a) vers
 
 data TicketLocal = TicketLocal
     { ticketId           :: LocalURI