diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index a478084..f1882d6 100644 --- 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) = diff --git a/vervis.cabal b/vervis.cabal index b04bd7e..fc1c6b9 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -381,6 +381,7 @@ library -- for text drawing in 'diagrams' , SVGFonts , template-haskell + , temporary , text , these , time