mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-27 17:54:53 +09:00
S2S: loomOfferTicketF, open MR sent by remote author
This commit is contained in:
fr33domlover
parent
ef8e1c1108
commit
b5adfce971
7 changed files with 670 additions and 154 deletions
|
|
@ -62,7 +62,6 @@ 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)
|
||||
|
|
@ -103,6 +102,7 @@ import Vervis.Data.Collab
|
|||
import Vervis.Data.Ticket
|
||||
import Vervis.Delivery
|
||||
import Vervis.FedURI
|
||||
import Vervis.Fetch
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
|
|
@ -118,6 +118,7 @@ import Vervis.Settings
|
|||
import Vervis.Query
|
||||
import Vervis.Ticket
|
||||
import Vervis.WorkItem
|
||||
import Vervis.Web.Repo
|
||||
|
||||
verifyResourceAddressed
|
||||
:: (MonadSite m, YesodHashids (SiteEnv m))
|
||||
|
|
@ -2242,13 +2243,6 @@ followC (Entity pidSender personSender) summary audience follow@(AP.Follow uObje
|
|||
ibiid <- insert $ InboxItem True now
|
||||
insert_ $ InboxItemLocal ibidAuthor obiidAccept ibiid
|
||||
|
||||
data Result
|
||||
= ResultSomeException SomeException
|
||||
| ResultIdMismatch
|
||||
| ResultGetError APGetError
|
||||
| ResultNotActor
|
||||
deriving Show
|
||||
|
||||
inviteC
|
||||
:: Entity Person
|
||||
-> Actor
|
||||
|
|
@ -2774,66 +2768,6 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
|
|||
|
||||
where
|
||||
|
||||
fetchRepoE h lu = do
|
||||
manager <- asksSite getHttpManager
|
||||
let apRepoId = AP.actorId . AP.actorLocal . AP.repoActor
|
||||
ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$>
|
||||
fetchAPID' manager apRepoId h lu
|
||||
|
||||
insertRemoteActor h lu (AP.Actor local detail) = do
|
||||
iid <- either entityKey id <$> insertBy' (Instance h)
|
||||
roid <- either entityKey id <$> insertBy' (RemoteObject iid lu)
|
||||
let ra = RemoteActor
|
||||
{ remoteActorIdent = roid
|
||||
, remoteActorName =
|
||||
AP.actorName detail <|> AP.actorUsername detail
|
||||
, remoteActorInbox = AP.actorInbox local
|
||||
, remoteActorFollowers = AP.actorFollowers local
|
||||
, remoteActorErrorSince = Nothing
|
||||
}
|
||||
either entityKey id <$> insertBy' ra
|
||||
|
||||
httpGetRemoteTip
|
||||
:: FedURI
|
||||
-> ExceptT Result Handler
|
||||
( VersionControlSystem
|
||||
, RemoteActorId
|
||||
, FedURI
|
||||
, Maybe (LocalURI, Text)
|
||||
)
|
||||
httpGetRemoteTip (ObjURI host localURI) = do
|
||||
repoOrBranch <- fetchTipE host localURI
|
||||
case repoOrBranch of
|
||||
Left repo -> do
|
||||
remoteActorID <-
|
||||
lift $ runSiteDB $
|
||||
insertRemoteActor host localURI $ AP.repoActor repo
|
||||
let uClone = ObjURI host $ NE.head $ AP.repoClone repo
|
||||
return (AP.repoVcs repo, remoteActorID, uClone, Nothing)
|
||||
Right (AP.Branch name _ luRepo) -> do
|
||||
repo <- fetchRepoE host luRepo
|
||||
remoteActorID <-
|
||||
lift $ runSiteDB $
|
||||
insertRemoteActor host luRepo $ AP.repoActor repo
|
||||
let uClone = ObjURI host $ NE.head $ AP.repoClone repo
|
||||
return (AP.repoVcs repo, remoteActorID, uClone, Just (localURI, name))
|
||||
where
|
||||
fetchTipE h lu = do
|
||||
manager <- asksSite getHttpManager
|
||||
ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$>
|
||||
fetchTip manager h lu
|
||||
|
||||
httpGetRemoteRepo
|
||||
:: FedURI
|
||||
-> ExceptT Result Handler (VersionControlSystem, RemoteActorId, FedURI)
|
||||
httpGetRemoteRepo (ObjURI host localURI) = do
|
||||
repo <- fetchRepoE host localURI
|
||||
remoteActorID <-
|
||||
lift $ runSiteDB $
|
||||
insertRemoteActor host localURI $ AP.repoActor repo
|
||||
let uClone = ObjURI host $ NE.head $ AP.repoClone repo
|
||||
return (AP.repoVcs repo, remoteActorID, uClone)
|
||||
|
||||
insertOfferToOutbox senderHash blinded offerID = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
|
|
@ -2943,79 +2877,6 @@ 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 True
|
||||
insertMany_ $ NE.toList $ NE.map (Patch bundleID now PatchMediaTypeGit) $ NE.reverse patches
|
||||
|
||||
{-
|
||||
verifyHosterRecip _ _ (Right _) = return ()
|
||||
verifyHosterRecip localRecips name (Left wi) =
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@
|
|||
module Vervis.Federation.Ticket
|
||||
( --personOfferTicketF
|
||||
deckOfferTicketF
|
||||
--, repoOfferTicketF
|
||||
, loomOfferTicketF
|
||||
|
||||
--, repoAddBundleF
|
||||
|
||||
|
|
@ -40,6 +40,8 @@ import Control.Monad.Trans.Except
|
|||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Aeson
|
||||
import Data.Align
|
||||
import Data.Bifoldable
|
||||
import Data.Bifunctor
|
||||
import Data.Bitraversable
|
||||
import Data.ByteString (ByteString)
|
||||
|
|
@ -50,6 +52,7 @@ import Data.List (nub, union)
|
|||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Data.These
|
||||
import Data.Time.Calendar
|
||||
import Data.Time.Clock
|
||||
import Data.Traversable
|
||||
|
|
@ -94,9 +97,10 @@ import Vervis.Cloth
|
|||
import Vervis.Data.Ticket
|
||||
import Vervis.Darcs
|
||||
import Vervis.Delivery
|
||||
import Vervis.FedURI
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Federation.Util
|
||||
import Vervis.FedURI
|
||||
import Vervis.Fetch
|
||||
import Vervis.Foundation
|
||||
import Vervis.Git
|
||||
import Vervis.Model
|
||||
|
|
@ -106,6 +110,7 @@ import Vervis.Path
|
|||
import Vervis.Query
|
||||
import Vervis.Recipient
|
||||
import Vervis.Ticket
|
||||
import Vervis.Web.Repo
|
||||
import Vervis.WorkItem
|
||||
|
||||
{-
|
||||
|
|
@ -494,6 +499,365 @@ deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do
|
|||
update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
loomOfferTicketF
|
||||
:: UTCTime
|
||||
-> KeyHashid Loom
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.Ticket URIMode
|
||||
-> FedURI
|
||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||
loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do
|
||||
|
||||
-- Check input
|
||||
recipLoomID <- decodeKeyHashid404 recipLoomHash
|
||||
(title, desc, source, originTipOrBundle, targetRepoID, maybeTargetBranch) <- do
|
||||
let uAuthor@(ObjURI hAuthor _) = remoteAuthorURI author
|
||||
WorkItemOffer {..} <- checkOfferTicket hAuthor ticket uTarget
|
||||
unless (wioAuthor == Right (remoteAuthorURI author)) $
|
||||
throwE "Offering a Ticket attributed to someone else"
|
||||
Merge maybeOriginTip maybeBundle targetTip <- case wioRest of
|
||||
TAM_Task _ ->
|
||||
throwE
|
||||
"Offer target is some local deck, so I have no use for \
|
||||
\this Offer. Was I supposed to receive it?"
|
||||
TAM_Merge loomID merge ->
|
||||
if loomID == recipLoomID
|
||||
then return merge
|
||||
else throwE
|
||||
"Offer target is some other local loom, so I have \
|
||||
\no use for this Offer. Was I supposed to receive \
|
||||
\it?"
|
||||
TAM_Remote _ _ ->
|
||||
throwE
|
||||
"Offer target is some remote tracker, so I have no use \
|
||||
\for this Offer. Was I supposed to receive it?"
|
||||
originTipOrBundle <-
|
||||
fromMaybeE
|
||||
(align maybeOriginTip maybeBundle)
|
||||
"MR provides neither origin nor patches"
|
||||
(targetRepoID, maybeTargetBranch) <-
|
||||
case targetTip of
|
||||
TipLocalRepo repoID -> pure (repoID, Nothing)
|
||||
TipLocalBranch repoID branch -> pure (repoID, Just branch)
|
||||
_ -> throwE "MR target is a remote repo (this tracker serves only local repos)"
|
||||
return (wioTitle, wioDesc, wioSource, originTipOrBundle, targetRepoID, maybeTargetBranch)
|
||||
|
||||
-- Soon we're going to proceed asynchronously to be able to HTTP GET the
|
||||
-- origin repo AP object, because:
|
||||
--
|
||||
-- * No support for providing a signed repo object directly in the
|
||||
-- Offer activity
|
||||
-- * It may be nice to make sure a remote origin repo's VCS type
|
||||
-- matches the target repo's VCS, even if patches are provided too
|
||||
-- + However there's no support for caching VCS type when
|
||||
-- remembering remote repo in our DB, so we'd have to check this
|
||||
-- every time
|
||||
-- * If origin is remote and no patches are provided, we'll need to
|
||||
-- know the clone URL to generate the patches ourselves
|
||||
-- + However the code here, for some simplicity, doesn't have a
|
||||
-- way to skip that and do the whole handler synchronously in
|
||||
-- case patches are provided or the origin is a local repo
|
||||
-- + And no support for caching the clone URI in DB when
|
||||
-- remembering the remote repo, so we'd need to do this every
|
||||
-- time
|
||||
--
|
||||
-- So first let's do some checks using the DB, on the loom, on the target
|
||||
-- repo (which is always local), and on the origin repo if it's local
|
||||
(recipLoomRepoID, Entity recipLoomActorID recipLoomActor, alreadyInInbox) <- lift $ runDB $ do
|
||||
|
||||
-- Find recipient loom in DB, returning 404 if doesn't exist because
|
||||
-- we're in the loom's inbox post handler
|
||||
(recipLoomRepoID, recipLoomActor@(Entity _ actor)) <- do
|
||||
loom <- get404 recipLoomID
|
||||
let actorID = loomActor loom
|
||||
(loomRepo loom,) . Entity actorID <$> getJust actorID
|
||||
|
||||
-- Has the loom already received this activity to its inbox? If yes, we
|
||||
-- won't process it again
|
||||
maybeAlreadyInInbox <- runMaybeT $ do
|
||||
instanceID <- MaybeT $ getKeyBy $ UniqueInstance $ objUriAuthority $ remoteAuthorURI author
|
||||
remoteObjectID <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID luOffer
|
||||
remoteActivityID <- MaybeT $ getKeyBy $ UniqueRemoteActivity remoteObjectID
|
||||
MaybeT $ getBy $ UniqueInboxItemRemote (actorInbox actor) remoteActivityID
|
||||
|
||||
return (recipLoomRepoID, recipLoomActor, isJust maybeAlreadyInInbox)
|
||||
|
||||
if alreadyInInbox
|
||||
then return ("I already have this activity in my inbox, ignoring", Nothing)
|
||||
else do
|
||||
(targetRepoVCS, originOrBundle) <- runDBExcept $ do
|
||||
|
||||
-- Grab loom's repo from DB and verify that it consents to be served by
|
||||
-- the loom, otherwise this loom doesn't accept tickets
|
||||
unless (targetRepoID == recipLoomRepoID) $
|
||||
throwE "MR target repo isn't the one served by the Offer target loom"
|
||||
targetRepo <- lift $ getJust targetRepoID
|
||||
unless (repoLoom targetRepo == Just recipLoomID) $
|
||||
throwE "Offer target loom doesn't have repo's consent to serve it"
|
||||
|
||||
-- Verify VCS type match between patch bundle and target repo
|
||||
for_ (justThere originTipOrBundle) $ \ (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 ()
|
||||
|
||||
-- If origin repo is local, find it in our DB and verify its VCS type
|
||||
-- matches the target repo
|
||||
originOrBundle <- flip (bifor originTipOrBundle) pure $ \ originTip -> do
|
||||
let origin =
|
||||
case originTip of
|
||||
TipLocalRepo repoID -> Left (repoID, Nothing)
|
||||
TipLocalBranch repoID branch -> Left (repoID, Just branch)
|
||||
TipRemote uOrigin -> Right (uOrigin, Nothing)
|
||||
TipRemoteBranch uRepo branch -> Right (uRepo, Just branch)
|
||||
bitraverse_
|
||||
(\ (repoID, maybeBranch) -> do
|
||||
repo <- getE repoID "MR origin local repo not found in DB"
|
||||
unless (repoVcs repo == repoVcs targetRepo) $
|
||||
throwE "Local origin repo VCS differs from target repo VCS"
|
||||
)
|
||||
pure
|
||||
origin
|
||||
return origin
|
||||
|
||||
return (repoVcs targetRepo, originOrBundle)
|
||||
|
||||
return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do
|
||||
|
||||
-- If origin repo is remote, HTTP GET its AP representation and
|
||||
-- remember it in our DB
|
||||
originOrBundle' <-
|
||||
bitraverse
|
||||
(bitraverse
|
||||
pure
|
||||
(\ (uOrigin, maybeOriginBranch) -> do
|
||||
(vcs, remoteOrigin) <-
|
||||
case maybeOriginBranch of
|
||||
Nothing -> do
|
||||
(vcs, raid, uClone, mb) <- withExceptT (T.pack . show) $ httpGetRemoteTip uOrigin
|
||||
return (vcs, (raid, uClone, first Just <$> mb))
|
||||
Just branch -> do
|
||||
(vcs, raid, uClone) <- withExceptT (T.pack . show) $ httpGetRemoteRepo uOrigin
|
||||
return (vcs, (raid, uClone, Just (Nothing, branch)))
|
||||
unless (vcs == targetRepoVCS) $
|
||||
throwE "Remote origin repo VCS differs from target repo VCS"
|
||||
return remoteOrigin
|
||||
)
|
||||
)
|
||||
pure
|
||||
originOrBundle
|
||||
|
||||
-- Verify that branches are specified for Git and aren't specified for
|
||||
-- Darcs
|
||||
-- Also, produce a data structure separating by VCS rather than by
|
||||
-- local/remote origin, which we'll need for generating patches
|
||||
tipInfo <- case targetRepoVCS 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, uClone, maybeOriginBranch) -> do
|
||||
(_maybeURI, originBranch) <- fromMaybeE maybeOriginBranch "Remote origin repo is Git but no origin branch specified"
|
||||
return (Right uClone, 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, uClone, maybeOriginBranch) -> do
|
||||
verifyNothingE maybeOriginBranch "Remote origin repo is Darcs but origin branch specified"
|
||||
return $ Right uClone
|
||||
return $ Right $ maybeOriginRepo
|
||||
|
||||
maybeHttp <- lift $ runSiteDB $ do
|
||||
|
||||
-- Insert the Offer to loom's inbox
|
||||
mractid <- insertToInbox now author body (actorInbox recipLoomActor) luOffer False
|
||||
for mractid $ \ offerID -> do
|
||||
|
||||
-- Forward the Offer activity to relevant local stages, and
|
||||
-- schedule delivery for unavailable remote members of them
|
||||
maybeHttpFwdOffer <- for mfwd $ \ (localRecips, sig) -> do
|
||||
let sieve =
|
||||
makeRecipientSet
|
||||
[]
|
||||
[LocalStageLoomFollowers recipLoomHash]
|
||||
remoteRecips <-
|
||||
insertRemoteActivityToLocalInboxes False offerID $
|
||||
localRecipSieve' sieve False False localRecips
|
||||
remoteRecipsHttp <-
|
||||
deliverRemoteDB_L
|
||||
(actbBL body) offerID recipLoomID sig remoteRecips
|
||||
return $
|
||||
deliverRemoteHTTP_L
|
||||
now recipLoomHash (actbBL body) sig remoteRecipsHttp
|
||||
|
||||
-- Insert the new ticket to our DB
|
||||
acceptID <- insertEmptyOutboxItem (actorOutbox recipLoomActor) now
|
||||
ticketID <- insertTicket now title desc source offerID acceptID
|
||||
clothID <- insertMerge recipLoomID ticketID maybeTargetBranch originOrBundle'
|
||||
let maybePull =
|
||||
let maybeTipInfo =
|
||||
case tipInfo of
|
||||
Left (b, mo) -> Left . (b,) <$> mo
|
||||
Right mo -> Right <$> mo
|
||||
hasBundle = isJust $ justThere originOrBundle'
|
||||
in (clothID, targetRepoID, hasBundle,) <$> maybeTipInfo
|
||||
|
||||
-- Prepare an Accept activity and insert to loom's outbox
|
||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
insertAcceptToOutbox clothID acceptID
|
||||
|
||||
-- Deliver the Accept to local recipients, and schedule delivery
|
||||
-- for unavailable remote recipients
|
||||
knownRemoteRecipsAccept <-
|
||||
deliverLocal'
|
||||
False (LocalActorLoom recipLoomHash) recipLoomActorID
|
||||
acceptID localRecipsAccept
|
||||
remoteRecipsHttpAccept <-
|
||||
deliverRemoteDB''
|
||||
fwdHostsAccept acceptID remoteRecipsAccept
|
||||
knownRemoteRecipsAccept
|
||||
|
||||
-- Return instructions for HTTP inbox-forwarding of the Offer
|
||||
-- activity, and for HTTP delivery of the Accept activity to
|
||||
-- remote recipients, and for generating patches from
|
||||
-- the origin repo
|
||||
return
|
||||
( maybeHttpFwdOffer
|
||||
, deliverRemoteHttp'
|
||||
fwdHostsAccept acceptID docAccept remoteRecipsHttpAccept
|
||||
, maybePull
|
||||
)
|
||||
|
||||
-- Launch asynchronous HTTP forwarding of the Offer activity and HTTP
|
||||
-- delivery of the Accept activity, and generate patches if we opened
|
||||
-- a local MR that mentions just an origin
|
||||
case maybeHttp of
|
||||
Nothing ->
|
||||
return
|
||||
"When I started serving this activity, I didn't have it in my inbox, \
|
||||
\but now suddenly it seems I already do, so ignoring"
|
||||
Just (maybeHttpFwdOffer, deliverHttpAccept, maybePull) -> do
|
||||
forkWorker "loomOfferTicketF Accept HTTP delivery" deliverHttpAccept
|
||||
traverse generatePatches maybePull
|
||||
case maybeHttpFwdOffer of
|
||||
Nothing -> return "Opened a merge request, no inbox-forwarding to do"
|
||||
Just forwardHttpOffer -> do
|
||||
forkWorker "loomOfferTicketF inbox-forwarding" forwardHttpOffer
|
||||
return "Opened a merge request and ran inbox-forwarding of the Offer"
|
||||
|
||||
where
|
||||
|
||||
insertTicket now title desc source offerID acceptID = do
|
||||
did <- insert Discussion
|
||||
fsid <- insert FollowerSet
|
||||
tid <- insert Ticket
|
||||
{ ticketNumber = Nothing
|
||||
, ticketCreated = now
|
||||
, ticketTitle = title
|
||||
, ticketSource = source
|
||||
, ticketDescription = desc
|
||||
, ticketStatus = TSNew
|
||||
, ticketDiscuss = did
|
||||
, ticketFollowers = fsid
|
||||
, ticketAccept = acceptID
|
||||
}
|
||||
insert_ TicketAuthorRemote
|
||||
{ ticketAuthorRemoteTicket = tid
|
||||
, ticketAuthorRemoteAuthor = remoteAuthorId author
|
||||
, ticketAuthorRemoteOpen = offerID
|
||||
}
|
||||
return tid
|
||||
|
||||
insertMerge
|
||||
:: LoomId
|
||||
-> TicketId
|
||||
-> Maybe Text
|
||||
-> These
|
||||
(Either
|
||||
(RepoId, Maybe Text)
|
||||
(RemoteActorId, FedURI, Maybe (Maybe LocalURI, Text))
|
||||
)
|
||||
Material
|
||||
-> WorkerDB TicketLoomId
|
||||
insertMerge loomID ticketID maybeTargetBranch originOrBundle = do
|
||||
clothID <- insert $ TicketLoom ticketID loomID maybeTargetBranch
|
||||
for_ (justHere originOrBundle) $ \case
|
||||
Left (repoID, maybeOriginBranch) ->
|
||||
insert_ $ MergeOriginLocal clothID repoID maybeOriginBranch
|
||||
Right (remoteActorID, _uClone, maybeOriginBranch) -> do
|
||||
originID <- insert $ MergeOriginRemote clothID remoteActorID
|
||||
for_ maybeOriginBranch $ \ (mlu, b) ->
|
||||
insert_ $ MergeOriginRemoteBranch originID mlu b
|
||||
for_ (justThere originOrBundle) $ \ (Material typ diffs) -> do
|
||||
bundleID <- insert $ Bundle clothID False
|
||||
insertMany_ $ NE.toList $ NE.reverse $
|
||||
NE.map (Patch bundleID now typ) diffs
|
||||
return clothID
|
||||
|
||||
insertAcceptToOutbox
|
||||
:: TicketLoomId
|
||||
-> OutboxItemId
|
||||
-> WorkerDB
|
||||
( AP.Doc AP.Activity URIMode
|
||||
, RecipientRoutes
|
||||
, [(Host, NonEmpty LocalURI)]
|
||||
, [Host]
|
||||
)
|
||||
insertAcceptToOutbox clothID acceptID = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
|
||||
clothHash <- encodeKeyHashid clothID
|
||||
acceptHash <- encodeKeyHashid acceptID
|
||||
|
||||
ra <- getJust $ remoteAuthorId author
|
||||
|
||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||
|
||||
audSender =
|
||||
AudRemote hAuthor
|
||||
[luAuthor]
|
||||
(maybeToList $ remoteActorFollowers ra)
|
||||
audTracker = AudLocal [] [LocalStageLoomFollowers recipLoomHash]
|
||||
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audSender, audTracker]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
doc = AP.Doc hLocal AP.Activity
|
||||
{ AP.activityId =
|
||||
Just $ encodeRouteLocal $
|
||||
LoomOutboxItemR recipLoomHash acceptHash
|
||||
, AP.activityActor =
|
||||
encodeRouteLocal $ LoomR recipLoomHash
|
||||
, AP.activityCapability = Nothing
|
||||
, AP.activitySummary = Nothing
|
||||
, AP.activityAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.activityFulfills = []
|
||||
, AP.activitySpecific = AP.AcceptActivity AP.Accept
|
||||
{ acceptObject = ObjURI hAuthor luOffer
|
||||
, acceptResult =
|
||||
Just $ encodeRouteLocal $
|
||||
ClothR recipLoomHash clothHash
|
||||
}
|
||||
}
|
||||
|
||||
update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
repoOfferTicketF
|
||||
:: UTCTime
|
||||
-> KeyHashid Repo
|
||||
|
|
|
|||
181
src/Vervis/Fetch.hs
Normal file
181
src/Vervis/Fetch.hs
Normal file
|
|
@ -0,0 +1,181 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
- The author(s) have dedicated all copyright and related and neighboring
|
||||
- rights to this software to the public domain worldwide. This software is
|
||||
- distributed without any warranty.
|
||||
-
|
||||
- You should have received a copy of the CC0 Public Domain Dedication along
|
||||
- with this software. If not, see
|
||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
module Vervis.Fetch
|
||||
( Result (..)
|
||||
, httpGetRemoteTip
|
||||
, httpGetRemoteRepo
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Base
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Align
|
||||
import Data.Barbie
|
||||
import Data.Bifunctor
|
||||
import Data.Bifoldable
|
||||
import Data.Bitraversable
|
||||
import Data.Foldable
|
||||
import Data.Functor
|
||||
import Data.Functor.Identity
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Data.These
|
||||
import Data.Time.Clock
|
||||
import Data.Traversable
|
||||
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
|
||||
import Development.PatchMediaType
|
||||
import Network.FedURI
|
||||
import Web.ActivityPub hiding (Patch, Ticket, Follow, Repo (..), ActorLocal (..), ActorDetail (..), Actor (..))
|
||||
import Web.Text
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
import Yesod.MonadSite
|
||||
|
||||
import qualified Web.ActivityPub as AP
|
||||
|
||||
import Control.Monad.Trans.Except.Local
|
||||
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
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.Cloth
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.Data.Collab
|
||||
import Vervis.Data.Ticket
|
||||
import Vervis.Delivery
|
||||
import Vervis.FedURI
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
import Vervis.Model.Role
|
||||
import Vervis.Model.Workflow
|
||||
import Vervis.Model.Ticket
|
||||
import Vervis.Path
|
||||
import Vervis.Persist.Actor
|
||||
import Vervis.Persist.Collab
|
||||
import Vervis.Recipient
|
||||
import Vervis.RemoteActorStore
|
||||
import Vervis.Settings
|
||||
import Vervis.Query
|
||||
import Vervis.Ticket
|
||||
import Vervis.WorkItem
|
||||
|
||||
data Result
|
||||
= ResultSomeException SomeException
|
||||
| ResultIdMismatch
|
||||
| ResultGetError APGetError
|
||||
| ResultNotActor
|
||||
deriving Show
|
||||
|
||||
fetchRepoE :: (MonadSite m, SiteEnv m ~ App) => Host -> LocalURI -> ExceptT Result m (AP.Repo URIMode)
|
||||
fetchRepoE h lu = do
|
||||
manager <- asksSite getHttpManager
|
||||
let apRepoId = AP.actorId . AP.actorLocal . AP.repoActor
|
||||
ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$>
|
||||
fetchAPID' manager apRepoId h lu
|
||||
|
||||
insertRemoteActor
|
||||
:: MonadIO m
|
||||
=> Host
|
||||
-> LocalURI
|
||||
-> AP.Actor URIMode
|
||||
-> ReaderT SqlBackend m RemoteActorId
|
||||
insertRemoteActor h lu (AP.Actor local detail) = do
|
||||
iid <- either entityKey id <$> insertBy' (Instance h)
|
||||
roid <- either entityKey id <$> insertBy' (RemoteObject iid lu)
|
||||
let ra = RemoteActor
|
||||
{ remoteActorIdent = roid
|
||||
, remoteActorName =
|
||||
AP.actorName detail <|> AP.actorUsername detail
|
||||
, remoteActorInbox = AP.actorInbox local
|
||||
, remoteActorFollowers = AP.actorFollowers local
|
||||
, remoteActorErrorSince = Nothing
|
||||
}
|
||||
either entityKey id <$> insertBy' ra
|
||||
|
||||
httpGetRemoteTip
|
||||
:: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App)
|
||||
=> FedURI
|
||||
-> ExceptT Result m
|
||||
( VersionControlSystem
|
||||
, RemoteActorId
|
||||
, FedURI
|
||||
, Maybe (LocalURI, Text)
|
||||
)
|
||||
httpGetRemoteTip (ObjURI host localURI) = do
|
||||
repoOrBranch <- fetchTipE host localURI
|
||||
case repoOrBranch of
|
||||
Left repo -> do
|
||||
remoteActorID <-
|
||||
lift $ runSiteDB $
|
||||
insertRemoteActor host localURI $ AP.repoActor repo
|
||||
let uClone = ObjURI host $ NE.head $ AP.repoClone repo
|
||||
return (AP.repoVcs repo, remoteActorID, uClone, Nothing)
|
||||
Right (AP.Branch name _ luRepo) -> do
|
||||
repo <- fetchRepoE host luRepo
|
||||
remoteActorID <-
|
||||
lift $ runSiteDB $
|
||||
insertRemoteActor host luRepo $ AP.repoActor repo
|
||||
let uClone = ObjURI host $ NE.head $ AP.repoClone repo
|
||||
return (AP.repoVcs repo, remoteActorID, uClone, Just (localURI, name))
|
||||
where
|
||||
fetchTipE h lu = do
|
||||
manager <- asksSite getHttpManager
|
||||
ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$>
|
||||
fetchTip manager h lu
|
||||
|
||||
httpGetRemoteRepo
|
||||
:: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App)
|
||||
=> FedURI
|
||||
-> ExceptT Result m (VersionControlSystem, RemoteActorId, FedURI)
|
||||
httpGetRemoteRepo (ObjURI host localURI) = do
|
||||
repo <- fetchRepoE host localURI
|
||||
remoteActorID <-
|
||||
lift $ runSiteDB $
|
||||
insertRemoteActor host localURI $ AP.repoActor repo
|
||||
let uClone = ObjURI host $ NE.head $ AP.repoClone repo
|
||||
return (AP.repoVcs repo, remoteActorID, uClone)
|
||||
|
|
@ -21,11 +21,13 @@ module Vervis.Git
|
|||
, readPatch
|
||||
--, lastCommitTime
|
||||
, writePostReceiveHooks
|
||||
, generateGitPatches
|
||||
--, applyGitPatches
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Arrow ((***))
|
||||
import Control.Exception.Base
|
||||
import Control.Monad (join)
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
|
|
@ -55,12 +57,13 @@ import Data.Traversable (for)
|
|||
import Data.Word (Word32)
|
||||
import Database.Persist
|
||||
import System.Exit
|
||||
import System.FilePath
|
||||
import System.Hourglass (timeCurrent)
|
||||
import System.Process.Typed
|
||||
import Text.Email.Validate (emailAddress)
|
||||
import Time.Types (Elapsed (..), Seconds (..))
|
||||
|
||||
import qualified Data.ByteString as B (intercalate)
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.DList as D (DList, empty, snoc, toList)
|
||||
import qualified Data.Git as G
|
||||
|
|
@ -77,6 +80,7 @@ import Yesod.ActivityPub
|
|||
import Yesod.Hashids
|
||||
import Yesod.MonadSite
|
||||
|
||||
import Control.Monad.Trans.Except.Local
|
||||
import Data.ByteString.Char8.Local (takeLine)
|
||||
import Data.DList.Local
|
||||
import Data.EventTime.Local
|
||||
|
|
@ -355,6 +359,59 @@ writePostReceiveHooks = do
|
|||
path <- askRepoDir repoHash
|
||||
liftIO $ writeHookFile path hook authority (keyHashidText repoHash)
|
||||
|
||||
-- | Given a temporary directory to use freely for this operation, generate
|
||||
-- patches from the difference between the origin branch and the target branch
|
||||
-- (origin branch must be an ancestor of target branch)
|
||||
--
|
||||
-- Target repo must be local, origin repo may be remote on the network
|
||||
generateGitPatches
|
||||
:: FilePath -- ^ Absolute path to target repo
|
||||
-> String -- ^ Target branch
|
||||
-> String -- ^ Absolute path or HTTP URI of origin repo
|
||||
-> String -- ^ Origin branch
|
||||
-> FilePath -- ^ Temporary directory to use for the operation
|
||||
-> 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
|
||||
|
||||
where
|
||||
|
||||
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
|
||||
|
||||
{-
|
||||
applyGitPatches shr rp branch patches = do
|
||||
path <- askRepoDir shr rp
|
||||
|
|
|
|||
|
|
@ -73,6 +73,7 @@ import Vervis.Access
|
|||
import Vervis.API
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Federation.Collab
|
||||
import Vervis.Federation.Ticket
|
||||
import Vervis.FedURI
|
||||
import Vervis.Form.Project
|
||||
import Vervis.Form.Ticket
|
||||
|
|
@ -143,6 +144,11 @@ postLoomInboxR recipLoomHash =
|
|||
loomAcceptF now recipLoomHash author body mfwd luActivity accept
|
||||
AP.InviteActivity invite ->
|
||||
topicInviteF now (GrantResourceLoom recipLoomHash) author body mfwd luActivity invite
|
||||
AP.OfferActivity (AP.Offer obj target) ->
|
||||
case obj of
|
||||
AP.OfferTicket ticket ->
|
||||
loomOfferTicketF now recipLoomHash author body mfwd luActivity ticket target
|
||||
_ -> return ("Unsupported offer object type for looms", Nothing)
|
||||
_ -> return ("Unsupported activity type for looms", Nothing)
|
||||
|
||||
getLoomOutboxR :: KeyHashid Loom -> Handler TypedContent
|
||||
|
|
|
|||
|
|
@ -15,22 +15,31 @@
|
|||
|
||||
module Vervis.Web.Repo
|
||||
( serveCommit
|
||||
, generatePatches
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding
|
||||
import Data.Time.Clock
|
||||
import Data.Traversable
|
||||
import Database.Persist
|
||||
import System.Directory
|
||||
import System.IO.Temp
|
||||
import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
|
||||
import Yesod.Persist.Core
|
||||
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Web.ActivityPub hiding (Author (..), Ticket, Repo, ActorLocal (..))
|
||||
import Development.PatchMediaType
|
||||
import Network.FedURI
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
import Yesod.MonadSite
|
||||
|
||||
import qualified Web.ActivityPub as AP
|
||||
|
||||
|
|
@ -38,8 +47,11 @@ import Data.Patch.Local hiding (Patch)
|
|||
|
||||
import qualified Data.Patch.Local as P
|
||||
|
||||
import Vervis.FedURI
|
||||
import Vervis.Foundation
|
||||
import Vervis.Git
|
||||
import Vervis.Model
|
||||
import Vervis.Path
|
||||
import Vervis.Settings
|
||||
import Vervis.Time
|
||||
import Vervis.Widget.Person
|
||||
|
|
@ -62,20 +74,20 @@ serveCommit repoHash ref patch parents = do
|
|||
mcommitter = patchCommitted patch
|
||||
makeAuthor' = makeAuthor hashPerson encodeRouteHome
|
||||
patchAP = AP.Commit
|
||||
{ commitId = encodeRouteLocal $ RepoCommitR repoHash ref
|
||||
, commitRepository = encodeRouteLocal $ RepoR repoHash
|
||||
, commitAuthor = makeAuthor' mpersonWritten author
|
||||
, commitCommitter =
|
||||
{ AP.commitId = encodeRouteLocal $ RepoCommitR repoHash ref
|
||||
, AP.commitRepository = encodeRouteLocal $ RepoR repoHash
|
||||
, AP.commitAuthor = makeAuthor' mpersonWritten author
|
||||
, AP.commitCommitter =
|
||||
makeAuthor' mpersonCommitted . fst <$> mcommitter
|
||||
, commitTitle = patchTitle patch
|
||||
, commitHash = Hash $ encodeUtf8 ref
|
||||
, commitDescription =
|
||||
, AP.commitTitle = patchTitle patch
|
||||
, AP.commitHash = AP.Hash $ encodeUtf8 ref
|
||||
, AP.commitDescription =
|
||||
let desc = patchDescription patch
|
||||
in if T.null desc
|
||||
then Nothing
|
||||
else Just desc
|
||||
, commitWritten = written
|
||||
, commitCommitted = snd <$> patchCommitted patch
|
||||
, AP.commitWritten = written
|
||||
, AP.commitCommitted = snd <$> patchCommitted patch
|
||||
}
|
||||
provideHtmlAndAP patchAP $
|
||||
let number = zip ([1..] :: [Int])
|
||||
|
|
@ -92,3 +104,37 @@ serveCommit repoHash ref patch parents = do
|
|||
}
|
||||
makeAuthor hashPerson encodeRouteHome (Just (Entity personID _, _)) _ =
|
||||
Right $ encodeRouteHome $ PersonR $ hashPerson personID
|
||||
|
||||
generatePatches
|
||||
:: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App)
|
||||
=> ( TicketLoomId
|
||||
, RepoId
|
||||
, Bool
|
||||
, Either
|
||||
(Text, (Either RepoId FedURI, Text))
|
||||
(Either RepoId FedURI)
|
||||
)
|
||||
-> ExceptT Text m ()
|
||||
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 $ runSiteDB $ do
|
||||
bundleID <- insert $ Bundle clothID True
|
||||
insertMany_ $ NE.toList $ NE.map (Patch bundleID now PatchMediaTypeGit) $ NE.reverse patches
|
||||
|
|
|
|||
|
|
@ -154,6 +154,7 @@ library
|
|||
Vervis.Federation.Ticket
|
||||
Vervis.Federation.Util
|
||||
Vervis.FedURI
|
||||
Vervis.Fetch
|
||||
-- Vervis.Field.Key
|
||||
Vervis.Field.Person
|
||||
--Vervis.Field.Project
|
||||
|
|
|
|||
Loading…
Reference in a new issue