forge/Vervis
1
0
Fork 0
Code Pull requests Activity

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

Browse source 
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
This commit is contained in:
fr33domlover 2022-09-22 17:12:37 +00:00
parent 2e7c5f767c
commit de51fb9ab5
2 changed files with 121 additions and 24 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

144
src/Vervis/API.hs
View file

@ -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) =

1
vervis.cabal
View file

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