From e7ab9e701c73f0eb58cd215649e6d8883069e856 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Wed, 21 Sep 2022 17:45:38 +0000
Subject: [PATCH] C2S: offerTicketC: Add VCS-type and patch-type consistency
 checks

---
 src/Vervis/API.hs | 61 +++++++++++++++++++++++++++++++++++++----------
 1 file changed, 48 insertions(+), 13 deletions(-)

diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs
index 0779bcb..82ea642 100644
--- a/src/Vervis/API.hs
+++ b/src/Vervis/API.hs
@@ -2572,18 +2572,56 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
                 unless (repoLoom targetRepo == Just loomID) $
                     throwE "Offer target loom doesn't have repo's consent to serve it"
 
+                for_ (justThere originOrBundle) $ \ (Material typ diffs) -> do
+                    unless (repoVcs targetRepo == patchMediaTypeVCS typ) $
+                        throwE "Patch type and local target repo VCS mismatch"
+                    case (typ, diffs) of
+                        (PatchMediaTypeDarcs, _ :| _ : _) ->
+                            throwE "More than one Darcs dpatch file provided"
+                        _ -> pure ()
+
                 originOrBundle' <-
                     bitraverse
-                        (bitraverse
-                            (\ (repoID, maybeBranch) -> do
-                                repo <- getE repoID "MR origin local repo not found in DB"
-                                return (repoID, repoVcs repo, maybeBranch)
-                            )
-                            pure
+                        (\ origin -> do
+                            (vcs, origin') <-
+                                case origin of
+                                    Left (repoID, maybeBranch) -> do
+                                        repo <- getE repoID "MR origin local repo not found in DB"
+                                        return (repoVcs repo, Left (repoID, maybeBranch))
+                                    Right (vcs, remoteActorID, maybeBranch) ->
+                                        pure (vcs, Right (remoteActorID, maybeBranch))
+                            unless (vcs == repoVcs targetRepo) $
+                                throwE "Origin repo VCS differs from target repo VCS"
+                            return origin'
                         )
                         pure
                         originOrBundle
 
+                -- Verify that the VCS of target repo, origin repo and patches
+                -- all match, and that branches are specified for Git and
+                -- aren't specified for Darcs
+                _ <- case repoVcs targetRepo of
+                    VCSGit -> do
+                        targetBranch <- fromMaybeE maybeTargetBranch "Local target repo is Git but no target branch specified"
+                        maybeOrigin <- for (justHere originOrBundle') $ \case
+                            Left (originRepoID, maybeOriginBranch) -> do
+                                originBranch <- fromMaybeE maybeOriginBranch "Local origin repo is Git but no origin branch specified"
+                                return (Left originRepoID, originBranch)
+                            Right (remoteActorID, maybeOriginBranch) -> do
+                                (_maybeURI, originBranch) <- fromMaybeE maybeOriginBranch "Remote origin repo is Git but no origin branch specified"
+                                return (Right remoteActorID, originBranch)
+                        return $ Left (targetBranch, maybeOrigin)
+                    VCSDarcs -> do
+                        verifyNothingE maybeTargetBranch "Local target repo is Darcs but target branch specified"
+                        maybeOriginRepo <- for (justHere originOrBundle') $ \case
+                            Left (originRepoID, maybeOriginBranch) -> do
+                                verifyNothingE maybeOriginBranch "Local origin repo is Darcs but origin branch specified"
+                                return $ Left originRepoID
+                            Right (remoteActorID, maybeOriginBranch) -> do
+                                verifyNothingE maybeOriginBranch "Remote origin repo is Darcs but origin branch specified"
+                                return $ Right remoteActorID
+                        return $ Right $ maybeOriginRepo
+
                 return (loomID, loomActor loom, originOrBundle', targetRepoID, maybeTargetBranch)
             )
 
@@ -2712,9 +2750,6 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
 
     return offerID
 
-    --unless (repoVcs r == patchMediaTypeVCS typ) $
-    --    throwE "Patch type and repo VCS mismatch"
-
     where
 
     fetchRepoE h lu = do
@@ -2823,17 +2858,17 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
         -> Maybe Text
         -> These
             (Either
-                (RepoId, VersionControlSystem, Maybe Text)
-                (VersionControlSystem, RemoteActorId, Maybe (Maybe LocalURI, Text))
+                (RepoId, Maybe Text)
+                (RemoteActorId, Maybe (Maybe LocalURI, Text))
             )
             Material
         -> AppDB (Route App)
     insertMerge now loomID ticketID maybeBranch originOrBundle = do
         clothID <- insert $ TicketLoom ticketID loomID maybeBranch
         for_ (justHere originOrBundle) $ \case
-            Left (repoID, _, maybeOriginBranch) ->
+            Left (repoID, maybeOriginBranch) ->
                 insert_ $ MergeOriginLocal clothID repoID maybeOriginBranch
-            Right (_, remoteActorID, maybeOriginBranch) -> do
+            Right (remoteActorID, maybeOriginBranch) -> do
                 originID <- insert $ MergeOriginRemote clothID remoteActorID
                 for_ maybeOriginBranch $ \ (mlu, b) ->
                     insert_ $ MergeOriginRemoteBranch originID mlu b