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
2024-12-27 16:24:52 +09:00 · 2022-09-22 17:12:37 +00:00 · 2022-09-22 17:12:37 +00:00 · de51fb9ab5
commit de51fb9ab5
parent 2e7c5f767c
2 changed files with 121 additions and 24 deletions
--- a/src/Vervis/API.hs
+++ b/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) =
--- a/vervis.cabal
+++ b/vervis.cabal
@ -381,6 +381,7 @@ library
                       -- for text drawing in 'diagrams'
                     , SVGFonts
                     , template-haskell
+                     , temporary
                     , text
                     , these
                     , time