C2S: offerTicketC: If origin provided but not bundle, generate patches from git

For now it's implemented only for Git:

If tracker is a local loom, and a (local or remote) origin repo is specified,
but no patches are provided, then generate them ourselves!

* Clone the (local) target repo
* Add the (local or remote) origin repo as a git remote
* Make sure target branch is an ancestor of the origin branch
* Generate patches for the commits that origin adds on top of target
* Insert them into our DB

src/Vervis/API.hs

@@ -38,6 +38,7 @@ where
 import Control.Applicative
 import Control.Exception hiding (Handler, try)
 import Control.Monad
+import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Reader
@@ -59,12 +60,19 @@ import Database.Persist hiding (deleteBy)
 import Database.Persist.Sql hiding (deleteBy)
 import Network.HTTP.Client
 import System.Directory
+import System.Exit
+import System.FilePath
+import System.IO.Temp
+import System.Process.Typed
 import Text.Blaze.Html.Renderer.Text
 import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
 import Yesod.Persist.Core
 
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as BL
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
 import qualified Data.Text.Lazy as TL
 
 import Database.Persist.JSON
@@ -84,6 +92,7 @@ import Data.Either.Local
 import Database.Persist.Local
 
 import qualified Data.Git.Local as G (createRepo)
+import qualified Data.Text.UTF8.Local as TU
 import qualified Darcs.Local.Repository as D (createRepo)
 
 import Vervis.Access
@@ -2554,7 +2563,7 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
                 return $ Just $ Right (loomID, originOrBundle, targetRepoID, maybeTargetBranch)
             TAM_Remote _ _ -> pure Nothing
 
-    (offerID, deliverHttpOffer, maybeDeliverHttpAccept) <- runDBExcept $ do
+    (offerID, deliverHttpOffer, maybeAcceptMaybePull) <- runDBExcept $ do
 
         -- If target tracker is local, find it in our DB
         -- If that tracker is a loom, find and check the MR too
@@ -2600,7 +2609,7 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
                 -- 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
+                tipInfo <- case repoVcs targetRepo of
                     VCSGit -> do
                         targetBranch <- fromMaybeE maybeTargetBranch "Local target repo is Git but no target branch specified"
                         maybeOrigin <- for (justHere originOrBundle') $ \case
@@ -2622,7 +2631,7 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
                                 return $ Right uClone
                         return $ Right $ maybeOriginRepo
 
-                return (loomID, loomActor loom, originOrBundle', targetRepoID, maybeTargetBranch)
+                return (loomID, loomActor loom, originOrBundle', targetRepoID, maybeTargetBranch, tipInfo)
             )
 
         -- Insert Offer to sender's outbox
@@ -2681,25 +2690,33 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
 
         -- If Offer target is a local deck/loom, verify that it has received
         -- the Offer, insert a new Ticket to DB, and publish Accept
-        maybeDeliverHttpAccept <- for maybeLocalTrackerDB $ \ tracker -> do
+        maybeAcceptMaybePull <- for maybeLocalTrackerDB $ \ tracker -> do
 
             -- Verify that tracker received the Offer
             let trackerActorID =
                     case tracker of
                         Left (_, actorID) -> actorID
-                        Right (_, actorID, _, _, _) -> actorID
+                        Right (_, actorID, _, _, _, _) -> actorID
             verifyActorHasItem trackerActorID offerID "Local tracker didn't receive the Offer"
 
             -- Insert ticket/MR to DB
             acceptID <- lift $ do
                 trackerActor <- getJust trackerActorID
                 insertEmptyOutboxItem (actorOutbox trackerActor) now
-            ticketRoute <- lift $ do
+            (ticketRoute, maybePull) <- lift $ do
                 ticketID <- insertTicket now title desc source offerID acceptID
                 case tracker of
-                    Left (deckID, _) -> insertTask deckID ticketID
-                    Right (loomID, _, originOrBundle, _, maybeTargetBranch) ->
-                        insertMerge now loomID ticketID maybeTargetBranch originOrBundle
+                    Left (deckID, _) ->
+                        (,Nothing) <$> insertTask deckID ticketID
+                    Right (loomID, _, originOrBundle, targetRepoID, maybeTargetBranch, tipInfo) -> do
+                        (clothID, route) <- insertMerge now loomID ticketID maybeTargetBranch originOrBundle
+                        let maybeTipInfo =
+                                case tipInfo of
+                                    Left (b, mo) -> Left . (b,) <$> mo
+                                    Right mo -> Right <$> mo
+                            hasBundle = isJust $ justThere originOrBundle
+                            pull = (clothID, targetRepoID, hasBundle,) <$> maybeTipInfo
+                        return (route, pull)
 
             -- Insert an Accept activity to tracker's outbox
             hashDeck <- getEncodeKeyHashid
@@ -2709,7 +2726,7 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
                     [ case tracker of
                         Left (deckID, _) ->
                             LocalStageDeckFollowers $ hashDeck deckID
-                        Right (loomID, _, _, _, _) ->
+                        Right (loomID, _, _, _, _, _) ->
                             LocalStageLoomFollowers $ hashLoom loomID
                     , LocalStagePersonFollowers senderHash
                     ]
@@ -2723,7 +2740,7 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
                         case tracker of
                             Left (deckID, _) ->
                                 LocalActorDeck $ hashDeck deckID
-                            Right (loomID, _, _, _, _) ->
+                            Right (loomID, _, _, _, _, _) ->
                                 LocalActorLoom $ hashLoom loomID
                 remoteRecips <-
                     lift $ deliverLocal' True trackerLocalActor trackerActorID acceptID $
@@ -2731,22 +2748,27 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
                 checkFederation remoteRecips
                 lift $ deliverRemoteDB'' [] acceptID [] remoteRecips
 
-            -- Return instructions for HTTP delivery to remote recipients
-            return $
-                deliverRemoteHttp' [] acceptID docAccept remoteRecipsHttpAccept
+            -- Return instructions for HTTP delivery to remote recipients, and
+            -- info for pulling origin branch to generate patches
+            return
+                ( deliverRemoteHttp' [] acceptID docAccept remoteRecipsHttpAccept
+                , maybePull
+                )
 
-        -- Return instructions for HTTP delivery to remote recipients
+        -- Return instructions for HTTP delivery to remote recipients, and info
+        -- for pulling origin branch to generate patches
         return
             ( offerID
             , deliverRemoteHttp' fwdHosts offerID docOffer remoteRecipsHttpOffer
-            , maybeDeliverHttpAccept
+            , maybeAcceptMaybePull
             )
 
-    -- Launch asynchronous HTTP delivery of Offer and Accept
-    lift $ do
-        forkWorker "offerTicketC: async HTTP Offer delivery" deliverHttpOffer
-        for_ maybeDeliverHttpAccept $
-            forkWorker "offerTicketC: async HTTP Accept delivery"
+    -- Launch asynchronous HTTP delivery of Offer and Accept, and generate
+    -- patches if we opened a local MR that mentions just an origin
+    lift $ forkWorker "offerTicketC: async HTTP Offer delivery" deliverHttpOffer
+    for_ maybeAcceptMaybePull $ \ (deliverHttpAccept, maybePull) -> do
+        lift $ forkWorker "offerTicketC: async HTTP Accept delivery" deliverHttpAccept
+        traverse generatePatches maybePull
 
     return offerID
 
@@ -2867,7 +2889,7 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
                 (RemoteActorId, FedURI, Maybe (Maybe LocalURI, Text))
             )
             Material
-        -> AppDB (Route App)
+        -> AppDB (TicketLoomId, Route App)
     insertMerge now loomID ticketID maybeBranch originOrBundle = do
         clothID <- insert $ TicketLoom ticketID loomID maybeBranch
         for_ (justHere originOrBundle) $ \case
@@ -2881,7 +2903,8 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
             bundleID <- insert $ Bundle clothID
             insertMany_ $ NE.toList $ NE.reverse $
                 NE.map (Patch bundleID now typ) diffs
-        ClothR <$> encodeKeyHashid loomID <*> encodeKeyHashid clothID
+        route <- ClothR <$> encodeKeyHashid loomID <*> encodeKeyHashid clothID
+        return (clothID, route)
 
     insertAcceptToOutbox personHash tracker ticketRoute offerID acceptID actors stages = do
         encodeRouteLocal <- getEncodeRouteLocal
@@ -2889,7 +2912,7 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
         tracker' <-
             bitraverse
                 (\ (deckID, _) -> encodeKeyHashid deckID)
-                (\ (loomID, _, _, _, _) -> encodeKeyHashid loomID)
+                (\ (loomID, _, _, _, _, _) -> encodeKeyHashid loomID)
                 tracker
         hLocal <- asksSite siteInstanceHost
         offerHash <- encodeKeyHashid offerID
@@ -2920,6 +2943,79 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
         update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
         return doc
 
+    runProcessE name spec = do
+        exitCode <- runProcess spec
+        case exitCode of
+            ExitFailure n ->
+                throwE $
+                    T.concat
+                        [ "`", name, "` failed with exit code "
+                        , T.pack (show n)
+                        ]
+            ExitSuccess -> return ()
+
+    readProcessE name spec = do
+        (exitCode, out) <- readProcessStdout spec
+        case exitCode of
+            ExitFailure n ->
+                throwE $
+                    T.concat
+                        [ "`", name, "` failed with exit code "
+                        , T.pack (show n)
+                        ]
+            ExitSuccess -> return $ TU.decodeStrict $ BL.toStrict out
+
+    generateGitPatches :: FilePath -> String -> String -> String -> FilePath -> ExceptT Text IO (NonEmpty Text)
+    generateGitPatches targetRepoPath targetBranch originRepoURI originBranch tempDir = do
+        runProcessE "git clone" $ proc "git" ["clone", "--bare", "--verbose", "--origin", "target", "--single-branch", "--branch", targetBranch, "--", targetRepoPath, tempDir]
+        runProcessE "git remote add" $ proc "git" ["-C", tempDir, "remote", "--verbose", "add", "-t", originBranch, "real-origin", originRepoURI]
+        runProcessE "git fetch" $ proc "git" ["-C", tempDir, "fetch", "real-origin", originBranch]
+        runProcessE "git merge-base --is-ancestor" $ proc "git" ["-C", tempDir, "merge-base", "--is-ancestor", targetBranch, "real-origin/" ++ originBranch]
+        patchFileNames <- do
+            names <- T.lines <$> readProcessE "git format-patch" (proc "git" ["-C", tempDir, "format-patch", targetBranch ++ "..real-origin/" ++ originBranch])
+            fromMaybeE (NE.nonEmpty names) "No new patches found in origin branch"
+        for patchFileNames $ \ name -> do
+            b <- lift $ B.readFile $ tempDir </> T.unpack name
+            case TE.decodeUtf8' b of
+                Left e -> throwE $ T.concat
+                    [ "UTF-8 decoding error while reading Git patch file "
+                    , name, ": " , T.pack $ displayException e
+                    ]
+                Right t -> return t
+
+    generatePatches
+        :: ( TicketLoomId
+           , RepoId
+           , Bool
+           , Either
+                (Text, (Either RepoId FedURI, Text))
+                (Either RepoId FedURI)
+           )
+        -> ExceptT Text Handler ()
+    generatePatches (clothID, targetRepoID, hasBundle, tipInfo) = unless hasBundle $ do
+        patches <-
+            case tipInfo of
+                Right _ -> error "Auto-pulling from Darcs remote origin not supported yet"
+                Left (targetBranch, (originRepo, originBranch)) -> do
+                    targetPath <- do
+                        repoHash <- encodeKeyHashid targetRepoID
+                        repoDir <- askRepoDir repoHash
+                        liftIO $ makeAbsolute repoDir
+                    originURI <-
+                        case originRepo of
+                            Left repoID -> do
+                                repoHash <- encodeKeyHashid repoID
+                                repoDir <- askRepoDir repoHash
+                                liftIO $ makeAbsolute repoDir
+                            Right uClone -> pure $ T.unpack $ renderObjURI uClone
+                    ExceptT $ liftIO $ runExceptT $
+                        withSystemTempDirectory "vervis-generatePatches" $
+                            generateGitPatches targetPath (T.unpack targetBranch) originURI (T.unpack originBranch)
+        now <- liftIO getCurrentTime
+        lift $ runDB $ do
+            bundleID <- insert $ Bundle clothID
+            insertMany_ $ NE.toList $ NE.map (Patch bundleID now PatchMediaTypeGit) $ NE.reverse patches
+
 {-
 verifyHosterRecip _           _    (Right _) = return ()
 verifyHosterRecip localRecips name (Left wi) =

vervis.cabal

@@ -381,6 +381,7 @@ library
                        -- for text drawing in 'diagrams'
                      , SVGFonts
                      , template-haskell
+                     , temporary
                      , text
                      , these
                      , time