S2S: Prepare Offer/Ticket parsing code for handling a remote patch/MR

src/Vervis/Federation/Ticket.hs

@@ -83,11 +83,16 @@ import Vervis.Federation.Util
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
+import Vervis.Model.Repo
 import Vervis.Model.Ticket
 import Vervis.Patch
 import Vervis.Ticket
 import Vervis.WorkItem
 
+data WorkItemTarget
+    = WTTProject ShrIdent PrjIdent
+    | WTTRepo ShrIdent RpIdent (Maybe Text) VersionControlSystem Text
+
 checkOfferTicket
     :: RemoteAuthor
     -> AP.Ticket URIMode
@@ -95,17 +100,18 @@ checkOfferTicket
     -> ExceptT
         Text
         Handler
-        ( Either (ShrIdent, PrjIdent) FedURI
+        ( Either WorkItemTarget (Host, LocalURI, Maybe (Maybe LocalURI, PatchType, Text))
         , TextHtml
         , TextHtml
         , TextPandocMarkdown
         )
 checkOfferTicket author ticket uTarget = do
     target <- checkProject uTarget
-    (muContext, summary, content, source) <- checkTicket ticket
+    (muContext, summary, content, source, mmr) <- checkTicket ticket
     for_ muContext $
         \ u -> unless (u == uTarget) $ throwE "Offer target != Ticket context"
-    return (target, summary, content, source)
+    target' <- matchTargetAndMR target mmr
+    return (target', summary, content, source)
     where
     checkProject u@(ObjURI h lu) = do
         hl <- hostIsLocal h
@@ -116,11 +122,12 @@ checkOfferTicket author ticket uTarget = do
                         (decodeRouteLocal lu)
                         "Offer target is local but isn't a valid route"
                 case route of
-                    ProjectR shr prj -> return (shr, prj)
+                    ProjectR shr prj -> return $ Left (shr, prj)
+                    RepoR shr rp -> return $ Right (shr, rp)
                     _ ->
                         throwE
                             "Offer target is a valid local route, but isn't a \
-                            \project route"
+                            \project or repo route"
             else return $ Right u
 
     checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext summary
@@ -133,9 +140,66 @@ checkOfferTicket author ticket uTarget = do
         verifyNothingE mupdated "Ticket has 'updated'"
         verifyNothingE muAssigned "Ticket has 'assignedTo'"
         when resolved $ throwE "Ticket is resolved"
-        verifyNothingE mmr "Ticket has 'attachment'"
 
-        return (muContext, summary, content, source)
+        mmr' <- traverse (uncurry checkMR) mmr
+
+        return (muContext, summary, content, source, mmr')
+        where
+        checkMR h (MergeRequest muOrigin luTarget epatch) = do
+            verifyNothingE muOrigin "MR with 'origin'"
+            branch <- checkBranch h luTarget
+            (typ, content) <-
+                case epatch of
+                    Left _ -> throwE "MR patch specified as a URI"
+                    Right (hPatch, patch) -> checkPatch hPatch patch
+            return (branch, typ, content)
+            where
+            checkBranch h lu = do
+                hl <- hostIsLocal h
+                if hl
+                    then Left <$> do
+                        route <-
+                            fromMaybeE
+                                (decodeRouteLocal lu)
+                                "MR target is local but isn't a valid route"
+                        case route of
+                            RepoR shr rp -> return (shr, rp, Nothing)
+                            RepoBranchR shr rp b -> return (shr, rp, Just b)
+                            _ ->
+                                throwE
+                                    "MR target is a valid local route, but isn't a \
+                                    \repo or branch route"
+                    else return $ Right $ ObjURI h lu
+            checkPatch h (AP.Patch mlocal attrib mpub typ content) = do
+                verifyNothingE mlocal "Patch with 'id'"
+                unless (ObjURI h attrib == remoteAuthorURI author) $
+                    throwE "Ticket and Patch attrib mismatch"
+                verifyNothingE mpub "Patch has 'published'"
+                return (typ, content)
+
+    matchTargetAndMR (Left (Left (shr, prj))) Nothing = return $ Left $ WTTProject shr prj
+    matchTargetAndMR (Left (Left (shr, prj))) (Just _) = throwE "Patch offered to project"
+    matchTargetAndMR (Left (Right (shr, rp))) Nothing = throwE "Issue offered to repo"
+    matchTargetAndMR (Left (Right (shr, rp))) (Just (branch, typ, content)) = do
+        branch' <-
+            case branch of
+                Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb
+                _ -> throwE "MR target repo/branch and Offer target repo mismatch"
+        return $ Left $ WTTRepo shr rp branch' (typ2vcs typ) content
+        where
+        typ2vcs PatchTypeDarcs = VCSDarcs
+    matchTargetAndMR (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing)
+    matchTargetAndMR (Right (ObjURI h lu)) (Just (branch, typ, content)) = do
+        luBranch <-
+            case branch of
+                Right (ObjURI h' lu') | h == h' -> return lu
+                _ -> throwE "MR target repo/branch and Offer target repo mismatch"
+        let patch =
+                ( if lu == luBranch then Nothing else Just luBranch
+                , typ
+                , content
+                )
+        return $ Right (h, lu, Just patch)
 
 sharerOfferTicketF
     :: UTCTime
@@ -154,11 +218,16 @@ sharerOfferTicketF now shrRecip author body mfwd luOffer ticket uTarget = do
             sid <- getKeyBy404 $ UniqueSharer shrRecip
             personInbox <$> getValBy404 (UniquePersonIdent sid)
         case target of
-            Left (shr, prj) -> do
+            Left (WTTProject shr prj) -> do
                 mjid <- lift $ runMaybeT $ do
                     sid <- MaybeT $ getKeyBy $ UniqueSharer shr
                     MaybeT $ getKeyBy $ UniqueProject prj sid
                 void $ fromMaybeE mjid "Offer target: No such local project"
+            Left (WTTRepo shr rp _ _ _) -> do
+                mrid <- lift $ runMaybeT $ do
+                    sid <- MaybeT $ getKeyBy $ UniqueSharer shr
+                    MaybeT $ getKeyBy $ UniqueRepo rp sid
+                void $ fromMaybeE mrid "Offer target: No such local repo"
             Right _ -> return ()
         lift $ insertToInbox now author body ibidRecip luOffer True
     return $
@@ -229,7 +298,7 @@ projectOfferTicketF now shrRecip prjRecip author body mfwd luOffer ticket uTarge
                             Nothing -> "Accepted new ticket, no inbox-forwarding to do"
                             Just _ -> "Accepted new ticket and ran inbox-forwarding of the Offer"
     where
-    targetRelevance (Left (shr, prj))
+    targetRelevance (Left (WTTProject shr prj))
         | shr == shrRecip && prj == prjRecip = Just ()
     targetRelevance _ = Nothing
     insertTicket now author jid summary content source ractidOffer obiidAccept = do

src/Vervis/Handler/Patch.hs

@@ -283,7 +283,7 @@ getSharerPatchVersionR shr talkhid ptkhid = do
                     }
                 )
             , AP.patchAttributedTo = encodeRouteLocal $ SharerR shr
-            , AP.patchPublished    = patchCreated patch
+            , AP.patchPublished    = Just $ patchCreated patch
             , AP.patchType         =
                 case vcs of
                     VCSDarcs -> PatchTypeDarcs
@@ -576,7 +576,7 @@ getRepoPatchVersionR shr rp ltkhid ptkhid = do
                     Left sharer ->
                         encodeRouteLocal $ SharerR $ sharerIdent sharer
                     Right (_, object) -> remoteObjectIdent object
-            , AP.patchPublished    = patchCreated patch
+            , AP.patchPublished    = Just $ patchCreated patch
             , AP.patchType         =
                 case vcs of
                     VCSDarcs -> PatchTypeDarcs

src/Web/ActivityPub.hs

@@ -875,7 +875,7 @@ encodePatchLocal a (PatchLocal id_ context versions)
 data Patch u = Patch
     { patchLocal        :: Maybe (Authority u, PatchLocal)
     , patchAttributedTo :: LocalURI
-    , patchPublished    :: UTCTime
+    , patchPublished    :: Maybe UTCTime
     , patchType         :: PatchType
     , patchContent      :: Text
     }
@@ -894,7 +894,7 @@ instance ActivityPub Patch where
             Patch
                 <$> parsePatchLocal o
                 <*> pure attrib
-                <*> o .: "published"
+                <*> o .:? "published"
                 <*> o .: "mediaType"
                 <*> o .: "content"
 
@@ -902,7 +902,7 @@ instance ActivityPub Patch where
         =  maybe mempty (uncurry encodePatchLocal) local
         <> "type"             .= ("Patch" :: Text)
         <> "attributedTo"     .= ObjURI a attrib
-        <> "published"        .= published
+        <> "published"        .=? published
         <> "mediaType"        .= typ
         <> "content"          .= content