S2S: Add repo patch support to checkCreateTicket

src/Vervis/Federation/Ticket.hs

@@ -488,26 +488,54 @@ repoOfferTicketF now shrRecip rpRecip author body mfwd luOffer ticket uTarget =
         update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
         return (doc, recipientSet, remoteActors, fwdHosts)
 
+data RemotePatch = RemotePatch
+    { rpBranch  :: Maybe LocalURI
+    , rpType    :: PatchType
+    , rpContent :: Text
+    }
+
+data RemoteWorkItem = RemoteWorkItem
+    { rwiHost    :: Host
+    , rwiTarget  :: Maybe LocalURI
+    , rwiContext :: LocalURI
+    , rwiPatch   :: Maybe RemotePatch
+    }
+
+data RemoteWorkItem' = RemoteWorkItem'
+    { rwiHost'    :: Host
+    , rwiContext' :: LocalURI
+    , rwiPatch'   :: Maybe RemotePatch
+    }
+
+data ParsedCreateTicket = ParsedCreateTicket
+    { pctItem      :: Either (Bool, WorkItemTarget) RemoteWorkItem
+    , pctLocal     :: TicketLocal
+    , pctPublished :: UTCTime
+    , pctTitle     :: TextHtml
+    , pctDesc      :: TextHtml
+    , pctSource    :: TextPandocMarkdown
+    }
+
 checkCreateTicket
     :: RemoteAuthor
     -> AP.Ticket URIMode
     -> Maybe FedURI
-    -> ExceptT
+    -> ExceptT Text Handler ParsedCreateTicket
-        Text
-        Handler
-        ( (Either (Bool, ShrIdent, PrjIdent) (Host, Maybe LocalURI, LocalURI))
-        , TicketLocal
-        , UTCTime
-        , TextHtml
-        , TextHtml
-        , TextPandocMarkdown
-        )
 checkCreateTicket author ticket muTarget = do
     mtarget <- traverse (checkTracker "Create target") muTarget
-    (context, ticketData, published, title, desc, src) <- checkTicket ticket
+    (context, tlocal, published, summary, content, source) <-
-    (, ticketData, published, title, desc, src) <$>
+        checkTicket ticket
-        checkTargetAndContext mtarget context
+    item <- checkTargetAndContext mtarget context
+    return $ ParsedCreateTicket item tlocal published summary content source
     where
+    checkTracker
+        :: Text
+        -> FedURI
+        -> ExceptT Text Handler
+            (Either
+                (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent))
+                FedURI
+            )
     checkTracker name u@(ObjURI h lu) = do
         hl <- hostIsLocal h
         if hl
@@ -517,14 +545,24 @@ checkCreateTicket author ticket muTarget = do
                         (decodeRouteLocal lu)
                         (name <> " 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 $
                             name <>
-                            " is a valid local route, but isn't a project \
+                            " is a valid local route, but isn't a \
-                            \route"
+                            \project/repo route"
             else return $ Right u
-
+    checkTicket
+        :: AP.Ticket URIMode
+        -> ExceptT Text Handler
+            ( Either WorkItemTarget (Host, LocalURI, Maybe RemotePatch)
+            , TicketLocal
+            , UTCTime
+            , TextHtml
+            , TextHtml
+            , TextPandocMarkdown
+            )
     checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext summary
                            content source muAssigned resolved mmr) = do
         (hTicket, tlocal) <- fromMaybeE mlocal "Ticket without 'id'"
@@ -541,30 +579,166 @@ checkCreateTicket author ticket muTarget = do
         verifyNothingE mupdated "Ticket has 'updated'"
         verifyNothingE muAssigned "Ticket has 'assignedTo'"
         when resolved $ throwE "Ticket is resolved"
-        verifyNothingE mmr "Ticket has 'attachment'"
 
-        return (context, tlocal, pub, summary, content, source)
+        mmr' <- traverse (uncurry checkMR) mmr
+        context' <- matchTicketAndMR (AP.ticketId tlocal) pub context mmr'
 
+        return (context', tlocal, pub, summary, content, source)
+        where
+        checkMR
+            :: Host
+            -> MergeRequest URIMode
+            -> ExceptT Text Handler
+                ( Either (ShrIdent, RpIdent, Maybe Text) FedURI
+                , Maybe (LocalURI, LocalURI)
+                , Maybe UTCTime
+                , PatchType
+                , Text
+                )
+        checkMR h (MergeRequest muOrigin luTarget epatch) = do
+            verifyNothingE muOrigin "MR with 'origin'"
+            branch <- checkBranch h luTarget
+            (mlocal, mpub, typ, content) <-
+                case epatch of
+                    Left _ -> throwE "MR patch specified as a URI"
+                    Right (hPatch, patch) -> checkPatch hPatch patch
+            return (branch, mlocal, mpub, typ, content)
+            where
+            checkBranch
+                :: Host
+                -> LocalURI
+                -> ExceptT Text Handler
+                    (Either (ShrIdent, RpIdent, Maybe Text) FedURI)
+            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
+                :: Host
+                -> AP.Patch URIMode
+                -> ExceptT Text Handler
+                    ( Maybe (LocalURI, LocalURI)
+                    , Maybe UTCTime
+                    , PatchType
+                    , Text
+                    )
+            checkPatch h (AP.Patch mlocal attrib mpub typ content) = do
+                mlocal' <-
+                    for mlocal $
+                        \ (h', PatchLocal luId luContext versions) -> do
+                            unless (h == h') $
+                                throwE "Patch & its author on different hosts"
+                            unless (null versions) $
+                                throwE "Patch has versions"
+                            return (luId, luContext)
+                unless (ObjURI h attrib == remoteAuthorURI author) $
+                    throwE "Ticket & Patch attrib mismatch"
+                return (mlocal', mpub, typ, content)
+        matchTicketAndMR
+            :: LocalURI
+            -> UTCTime
+            -> Either
+                (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent))
+                FedURI
+            -> Maybe
+                ( Either (ShrIdent, RpIdent, Maybe Text) FedURI
+                , Maybe (LocalURI, LocalURI)
+                , Maybe UTCTime
+                , PatchType
+                , Text
+                )
+            -> ExceptT Text Handler (Either WorkItemTarget (Host, LocalURI, Maybe RemotePatch))
+        matchTicketAndMR _ _ (Left (Left (shr, prj))) Nothing = return $ Left $ WTTProject shr prj
+        matchTicketAndMR _ _ (Left (Left (shr, prj))) (Just _) = throwE "Patch offered to project"
+        matchTicketAndMR _ _ (Left (Right (shr, rp))) Nothing = throwE "Issue offered to repo"
+        matchTicketAndMR luTicket pub (Left (Right (shr, rp))) (Just (branch, mlocal, mpub, 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"
+            _mluPatch <- for mlocal $ \ (luPatch, luPatchContext) -> do
+                unless (luPatchContext == luTicket) $
+                    throwE "Patch 'context' != Ticket 'id'"
+                return luPatch
+            for_ mpub $ \ pub' ->
+                unless (pub == pub') $
+                    throwE "Ticket & Patch 'published' differ"
+            let vcs = typ2vcs typ
+            case vcs of
+                VCSDarcs ->
+                    unless (isNothing branch') $
+                        throwE "Darcs MR specifies a branch"
+                VCSGit ->
+                    unless (isJust branch') $
+                        throwE "Git MR doesn't specify the branch"
+            return $ Left $ WTTRepo shr rp branch' vcs content
+            where
+            typ2vcs PatchTypeDarcs = VCSDarcs
+        matchTicketAndMR _ _ (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing)
+        matchTicketAndMR luTicket pub (Right (ObjURI h lu)) (Just (branch, mlocal, mpub, 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"
+            _mluPatch <- for mlocal $ \ (luPatch, luPatchContext) -> do
+                unless (luPatchContext == luTicket) $
+                    throwE "Patch 'context' != Ticket 'id'"
+                return luPatch
+            for_ mpub $ \ pub' ->
+                unless (pub == pub') $
+                    throwE "Ticket & Patch 'published' differ"
+            let patch =
+                    RemotePatch
+                        (if lu == luBranch then Nothing else Just luBranch)
+                        typ
+                        content
+            return $ Right (h, lu, Just patch)
+    checkTargetAndContext
+        :: Maybe
+            ( Either
+                (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent))
+                FedURI
+            )
+        -> Either WorkItemTarget (Host, LocalURI, Maybe RemotePatch)
+        -> ExceptT Text Handler (Either (Bool, WorkItemTarget) RemoteWorkItem)
     checkTargetAndContext Nothing context =
         return $
             case context of
-                Left (shr, prj) -> Left (False, shr, prj)
+                Left wit -> Left (False, wit)
-                Right (ObjURI h lu) -> Right (h, Nothing, lu)
+                Right (h, luCtx, mpatch) -> Right $ RemoteWorkItem h Nothing luCtx mpatch
     checkTargetAndContext (Just target) context =
         case (target, context) of
             (Left _, Right _) ->
                 throwE "Create target is local but ticket context is remote"
             (Right _, Left _) ->
                 throwE "Create target is remote but ticket context is local"
-            (Right (ObjURI hTarget luTarget), Right (ObjURI hContext luContext)) ->
+            (Right (ObjURI hTarget luTarget), Right (hContext, luContext, mpatch)) ->
                 if hTarget == hContext
-                    then return $ Right (hTarget, Just luTarget, luContext)
+                    then return $ Right $ RemoteWorkItem hTarget (Just luTarget) luContext mpatch
                     else throwE "Create target and ticket context on \
                                 \different remote hosts"
-            (Left (shr, prj), Left (shr', prj')) ->
+            (Left proj, Left wit) ->
-                if shr == shr' && prj == prj'
+                case (proj, wit) of
-                    then return $ Left (True, shr, prj)
+                    (Left (shr, prj), WTTProject shr' prj')
-                    else throwE "Create target and ticket context are \
+                        | shr == shr' && prj == prj' ->
+                            return $ Left (True, wit)
+                    (Right (shr, rp), WTTRepo shr' rp' _ _ _)
+                        | shr == shr' && rp == rp' ->
+                            return $ Left (True, wit)
+                    _ -> throwE
+                            "Create target and ticket context are \
                             \different local projects"
 
 sharerCreateTicketF
@@ -578,8 +752,7 @@ sharerCreateTicketF
     -> Maybe FedURI
     -> ExceptT Text Handler Text
 sharerCreateTicketF now shrRecip author body mfwd luCreate ticket muTarget = do
-    (targetAndContext, _, _, _, _, _) <-
+    targetAndContext <- pctItem <$> checkCreateTicket author ticket muTarget
-        checkCreateTicket author ticket muTarget
     mractid <- runDBExcept $ do
         ibidRecip <- lift $ do
             sid <- getKeyBy404 $ UniqueSharer shrRecip
@@ -591,11 +764,16 @@ sharerCreateTicketF now shrRecip author body mfwd luCreate ticket muTarget = do
             Nothing -> "Activity already exists in my inbox"
             Just _ -> "Activity inserted to my inbox"
     where
-    checkTargetAndContextDB (Left (_, shr, prj)) = do
+    checkTargetAndContextDB (Left (_, WTTProject shr prj)) = do
         mj <- lift $ runMaybeT $ do
             sid <- MaybeT $ getKeyBy $ UniqueSharer shr
             MaybeT $ getBy $ UniqueProject prj sid
         unless (isJust mj) $ throwE "Local context: No such project"
+    checkTargetAndContextDB (Left (_, WTTRepo shr rp _ _ _)) = do
+        mr <- lift $ runMaybeT $ do
+            sid <- MaybeT $ getKeyBy $ UniqueSharer shr
+            MaybeT $ getBy $ UniqueRepo rp sid
+        unless (isJust mr) $ throwE "Local context: No such repo"
     checkTargetAndContextDB (Right _) = return ()
 
 projectCreateTicketF
@@ -610,7 +788,8 @@ projectCreateTicketF
     -> Maybe FedURI
     -> ExceptT Text Handler Text
 projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTarget = do
-    (targetAndContext, tlocal, published, title, desc, src) <- checkCreateTicket author ticket muTarget
+    ParsedCreateTicket targetAndContext tlocal published title desc src <-
+        checkCreateTicket author ticket muTarget
     mmhttp <- for (targetRelevance targetAndContext) $ \ () -> lift $ runDB $ do
         Entity jid j <- do
             sid <- getKeyBy404 $ UniqueSharer shrRecip
@@ -665,7 +844,7 @@ projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTa
                                     Nothing -> "Accepted and listed ticket, no inbox-forwarding to do"
                                     Just _ -> "Accepted and listed ticket and ran inbox-forwarding of the Create"
     where
-    targetRelevance (Left (_, shr, prj))
+    targetRelevance (Left (_, WTTProject shr prj))
         | shr == shrRecip && prj == prjRecip = Just ()
     targetRelevance _ = Nothing
     insertTicket jid author luTicket published summary content source ractidCreate obiidAccept = do