S2S: repoApplyF: Support local repo-hosted proposals
This commit is contained in:
fr33domlover
parent
c3ff3c40eb
commit
02734d02f2
1 changed files with 199 additions and 84 deletions
|
|
@ -1476,55 +1476,6 @@ repoApplyF now shrRecip rpRecip author body mfwd luApply uObject uTarget = do
|
||||||
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
||||||
getBy404 $ UniqueRepo rpRecip sid
|
getBy404 $ UniqueRepo rpRecip sid
|
||||||
return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do
|
return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do
|
||||||
case bundle of
|
|
||||||
Left (Left (shr, talid, bnid)) ->
|
|
||||||
error "Applying local bundle not supported yet"
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
Left (Right (ltid, bnid)) ->
|
|
||||||
error "Applying local bundle not supported yet"
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
Right uBundle@(ObjURI hBundle luBundle) -> do
|
|
||||||
|
|
||||||
-- Verify it's a latest-version bundle pointed by a ticket we
|
|
||||||
-- have listed under the receiving repo
|
|
||||||
manager <- asksSite appHttpManager
|
|
||||||
Doc h b <- withExceptT T.pack $ AP.fetchAP manager $ Left uBundle
|
|
||||||
(BundleLocal bid ctx _prevs mcurr, lus) <-
|
|
||||||
case b of
|
|
||||||
BundleHosted Nothing _ -> throwE "No bundle @id"
|
|
||||||
BundleHosted (Just l) ps -> return (l, ps)
|
|
||||||
BundleOffer _ _ -> throwE "Why does bundle contain patch objects"
|
|
||||||
unless (h == hBundle && bid == luBundle) $
|
|
||||||
throwE "Bundle 'id' differs from the URI we fetched"
|
|
||||||
for_ mcurr $ \ curr ->
|
|
||||||
throwE $
|
|
||||||
if curr == bid
|
|
||||||
then "Bundle currentVersion points to itself"
|
|
||||||
else "Bundle isn't the latest version"
|
|
||||||
let uTicket = ObjURI h ctx
|
|
||||||
Doc _ ticket <- withExceptT T.pack $ AP.fetchAP manager $ Left uTicket
|
|
||||||
(_, tlocal) <- fromMaybeE (AP.ticketLocal ticket) "Ticket has no @id"
|
|
||||||
(h', mr) <- fromMaybeE (AP.ticketAttachment ticket) "Ticket has no 'attachment'"
|
|
||||||
unless (ObjURI h' (mrTarget mr) == uTarget) $
|
|
||||||
throwE "Ticket MR target isn't me / branch"
|
|
||||||
case mrBundle mr of
|
|
||||||
Left u ->
|
|
||||||
if u == uBundle
|
|
||||||
then pure ()
|
|
||||||
else throwE "Bundle isn't the one pointed by ticket"
|
|
||||||
Right _ -> throwE "Ticket has bundle object instead of just URI"
|
|
||||||
e <- runSiteDBExcept $ getRemoteTicketByURI uTicket
|
|
||||||
case e of
|
|
||||||
Right (_, _, _, _, _, Right (Entity _ trl))
|
|
||||||
| ticketRepoLocalRepo trl == ridRecip -> pure ()
|
|
||||||
_ -> throwE "I don't have the ticket listed under me"
|
|
||||||
|
|
||||||
-- Check in DB whether the provided capability matches a DB
|
-- Check in DB whether the provided capability matches a DB
|
||||||
-- record we have, and that it includes permission to apply MRs
|
-- record we have, and that it includes permission to apply MRs
|
||||||
|
|
@ -1589,6 +1540,124 @@ repoApplyF now shrRecip rpRecip author body mfwd luApply uObject uTarget = do
|
||||||
"Apply author's role in repo doesn't have \
|
"Apply author's role in repo doesn't have \
|
||||||
\ApplyPatch access"
|
\ApplyPatch access"
|
||||||
|
|
||||||
|
-- We verified apply permission, now let's examine the bundle itself
|
||||||
|
case bundle of
|
||||||
|
Left (Left (shr, talid, bnid)) ->
|
||||||
|
error "Applying local sharer-bundle not supported yet"
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
Left (Right (ltid, bnid)) -> do
|
||||||
|
-- Verify we have this ticket and bundle in the DB, and that
|
||||||
|
-- the bundle is the latest version
|
||||||
|
mticket <- lift $ runSiteDB $ getRepoProposal shrRecip rpRecip ltid
|
||||||
|
(_, _, _, _, _, _, _, mresolved, bnid' :| _) <- fromMaybeE mticket "Apply object: No such local ticket"
|
||||||
|
_ <- fromMaybeE mresolved "Apply object: Proposal already applied"
|
||||||
|
unless (bnid == bnid') $
|
||||||
|
throwE "Apply object: Bundle isn't the latest version"
|
||||||
|
|
||||||
|
-- Grab the bundle's patches from DB and apply them
|
||||||
|
patches <- lift $ runSiteDB $ selectList [PatchBundle ==. bnid] [Asc PatchId]
|
||||||
|
case repoVcs repoRecip of
|
||||||
|
VCSGit -> error "Patching a Git repo unsupported yet"
|
||||||
|
VCSDarcs -> do
|
||||||
|
patch <-
|
||||||
|
case patches of
|
||||||
|
[] -> error "Local repo-bundle without any patches found"
|
||||||
|
_ : (_ : _) -> throwE "Darcs repo given multiple patch bundles"
|
||||||
|
(Entity _ (Patch _ _ PatchMediaTypeDarcs t)) : [] -> return t
|
||||||
|
applyDarcsPatch patch
|
||||||
|
|
||||||
|
-- Insert Apply activity to repo's inbox
|
||||||
|
-- Produce an Accept activity and deliver locally
|
||||||
|
-- Mark the ticket as resolved
|
||||||
|
mhttp <- lift $ runSiteDB $ do
|
||||||
|
mractid <- insertToInbox now author body (repoInbox repoRecip) luApply False
|
||||||
|
for mractid $ \ ractid -> do
|
||||||
|
mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
|
||||||
|
ltkhid <- encodeKeyHashid ltid
|
||||||
|
let sieve =
|
||||||
|
makeRecipientSet
|
||||||
|
[]
|
||||||
|
[ LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip ltkhid
|
||||||
|
, LocalPersonCollectionRepoTeam shrRecip rpRecip
|
||||||
|
, LocalPersonCollectionRepoFollowers shrRecip rpRecip
|
||||||
|
]
|
||||||
|
remoteRecips <-
|
||||||
|
insertRemoteActivityToLocalInboxes
|
||||||
|
False ractid $
|
||||||
|
localRecipSieve'
|
||||||
|
sieve False False localRecips
|
||||||
|
(sig,) <$> deliverRemoteDB_R (actbBL body) ractid ridRecip sig remoteRecips
|
||||||
|
obiidAccept <- insertEmptyOutboxItem (repoOutbox repoRecip) now
|
||||||
|
|
||||||
|
_ <- insertResolve author ltid ractid obiidAccept
|
||||||
|
|
||||||
|
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||||
|
insertAcceptLocalRepo luApply ltid obiidAccept
|
||||||
|
|
||||||
|
knownRemoteRecipsAccept <-
|
||||||
|
deliverLocal'
|
||||||
|
False
|
||||||
|
(LocalActorRepo shrRecip rpRecip)
|
||||||
|
(repoInbox repoRecip)
|
||||||
|
obiidAccept
|
||||||
|
localRecipsAccept
|
||||||
|
(mremotesHttpFwd, obiidAccept, docAccept, fwdHostsAccept,) <$>
|
||||||
|
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||||
|
|
||||||
|
-- Run inbox-forwarding on the Apply activity
|
||||||
|
-- Deliver Accept activity to remote recipients via HTTP
|
||||||
|
case mhttp of
|
||||||
|
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
||||||
|
Just (mremotesHttpFwd, obiid, doc, fwdHosts, recips) -> do
|
||||||
|
for_ mremotesHttpFwd $ \ (sig, remotes) ->
|
||||||
|
forkWorker "repoApplyF inbox-forwarding" $
|
||||||
|
deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotes
|
||||||
|
forkWorker "repoApplyF Accept HTTP delivery" $
|
||||||
|
deliverRemoteHttp' fwdHosts obiid doc recips
|
||||||
|
return $
|
||||||
|
if isJust mremotesHttpFwd
|
||||||
|
then "Applied patches, did inbox-forwarding"
|
||||||
|
else "Applied patches, no inbox-forwarding to do"
|
||||||
|
|
||||||
|
Right uBundle@(ObjURI hBundle luBundle) -> do
|
||||||
|
|
||||||
|
-- Verify it's a latest-version bundle pointed by a ticket we
|
||||||
|
-- have listed under the receiving repo
|
||||||
|
manager <- asksSite appHttpManager
|
||||||
|
Doc h b <- withExceptT T.pack $ AP.fetchAP manager $ Left uBundle
|
||||||
|
(BundleLocal bid ctx _prevs mcurr, lus) <-
|
||||||
|
case b of
|
||||||
|
BundleHosted Nothing _ -> throwE "No bundle @id"
|
||||||
|
BundleHosted (Just l) ps -> return (l, ps)
|
||||||
|
BundleOffer _ _ -> throwE "Why does bundle contain patch objects"
|
||||||
|
unless (h == hBundle && bid == luBundle) $
|
||||||
|
throwE "Bundle 'id' differs from the URI we fetched"
|
||||||
|
for_ mcurr $ \ curr ->
|
||||||
|
throwE $
|
||||||
|
if curr == bid
|
||||||
|
then "Bundle currentVersion points to itself"
|
||||||
|
else "Bundle isn't the latest version"
|
||||||
|
let uTicket = ObjURI h ctx
|
||||||
|
Doc _ ticket <- withExceptT T.pack $ AP.fetchAP manager $ Left uTicket
|
||||||
|
(_, tlocal) <- fromMaybeE (AP.ticketLocal ticket) "Ticket has no @id"
|
||||||
|
(h', mr) <- fromMaybeE (AP.ticketAttachment ticket) "Ticket has no 'attachment'"
|
||||||
|
unless (ObjURI h' (mrTarget mr) == uTarget) $
|
||||||
|
throwE "Ticket MR target isn't me / branch"
|
||||||
|
case mrBundle mr of
|
||||||
|
Left u ->
|
||||||
|
if u == uBundle
|
||||||
|
then pure ()
|
||||||
|
else throwE "Bundle isn't the one pointed by ticket"
|
||||||
|
Right _ -> throwE "Ticket has bundle object instead of just URI"
|
||||||
|
e <- runSiteDBExcept $ getRemoteTicketByURI uTicket
|
||||||
|
case e of
|
||||||
|
Right (_, _, _, _, _, Right (Entity _ trl))
|
||||||
|
| ticketRepoLocalRepo trl == ridRecip -> pure ()
|
||||||
|
_ -> throwE "I don't have the ticket listed under me"
|
||||||
|
|
||||||
-- HTTP GET all the patches, examine and apply them
|
-- HTTP GET all the patches, examine and apply them
|
||||||
patches <- for lus $ \ luPatch -> do
|
patches <- for lus $ \ luPatch -> do
|
||||||
Doc _ (AP.Patch mlocal _luAttrib _mpub typ content) <-
|
Doc _ (AP.Patch mlocal _luAttrib _mpub typ content) <-
|
||||||
|
|
@ -1608,22 +1677,7 @@ repoApplyF now shrRecip rpRecip author body mfwd luApply uObject uTarget = do
|
||||||
case patches of
|
case patches of
|
||||||
_ :| (_ : _) -> throwE "Darcs repo given multiple patch bundles"
|
_ :| (_ : _) -> throwE "Darcs repo given multiple patch bundles"
|
||||||
(PatchMediaTypeDarcs, t) :| [] -> return t
|
(PatchMediaTypeDarcs, t) :| [] -> return t
|
||||||
path <- askRepoDir shrRecip rpRecip
|
applyDarcsPatch patch
|
||||||
let input = BL.fromStrict $ TE.encodeUtf8 patch
|
|
||||||
(exitCode, out, err) <-
|
|
||||||
readProcess $ setStdin (byteStringInput input) $
|
|
||||||
proc "darcs" ["apply", "--all", "--no-allow-conflicts", "--repodir='" ++ path ++ "'"]
|
|
||||||
let out2text = TU.decodeLenient . BL.toStrict
|
|
||||||
case exitCode of
|
|
||||||
ExitFailure n ->
|
|
||||||
throwE $
|
|
||||||
T.concat
|
|
||||||
[ "`darcs apply` failed with exit code "
|
|
||||||
, T.pack (show n)
|
|
||||||
, "\nstdout: ", out2text out
|
|
||||||
, "\nstderr: ", out2text err
|
|
||||||
]
|
|
||||||
ExitSuccess -> return ()
|
|
||||||
|
|
||||||
-- Insert Apply activity to repo's inbox
|
-- Insert Apply activity to repo's inbox
|
||||||
-- Produce an Accept activity and deliver locally
|
-- Produce an Accept activity and deliver locally
|
||||||
|
|
@ -1644,8 +1698,10 @@ repoApplyF now shrRecip rpRecip author body mfwd luApply uObject uTarget = do
|
||||||
sieve False False localRecips
|
sieve False False localRecips
|
||||||
(sig,) <$> deliverRemoteDB_R (actbBL body) ractid ridRecip sig remoteRecips
|
(sig,) <$> deliverRemoteDB_R (actbBL body) ractid ridRecip sig remoteRecips
|
||||||
obiidAccept <- insertEmptyOutboxItem (repoOutbox repoRecip) now
|
obiidAccept <- insertEmptyOutboxItem (repoOutbox repoRecip) now
|
||||||
|
|
||||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||||
insertAccept luApply hBundle tlocal obiidAccept
|
insertAcceptRemote luApply hBundle tlocal obiidAccept
|
||||||
|
|
||||||
knownRemoteRecipsAccept <-
|
knownRemoteRecipsAccept <-
|
||||||
deliverLocal'
|
deliverLocal'
|
||||||
False
|
False
|
||||||
|
|
@ -1703,8 +1759,25 @@ repoApplyF now shrRecip rpRecip author body mfwd luApply uObject uTarget = do
|
||||||
-}
|
-}
|
||||||
|
|
||||||
where
|
where
|
||||||
|
applyDarcsPatch patch = do
|
||||||
|
path <- askRepoDir shrRecip rpRecip
|
||||||
|
let input = BL.fromStrict $ TE.encodeUtf8 patch
|
||||||
|
(exitCode, out, err) <-
|
||||||
|
readProcess $ setStdin (byteStringInput input) $
|
||||||
|
proc "darcs" ["apply", "--all", "--no-allow-conflicts", "--repodir='" ++ path ++ "'"]
|
||||||
|
let out2text = TU.decodeLenient . BL.toStrict
|
||||||
|
case exitCode of
|
||||||
|
ExitFailure n ->
|
||||||
|
throwE $
|
||||||
|
T.concat
|
||||||
|
[ "`darcs apply` failed with exit code "
|
||||||
|
, T.pack (show n)
|
||||||
|
, "\nstdout: ", out2text out
|
||||||
|
, "\nstderr: ", out2text err
|
||||||
|
]
|
||||||
|
ExitSuccess -> return ()
|
||||||
|
|
||||||
insertAccept luApply hTicket tlocal obiidAccept = do
|
insertAcceptRemote luApply hTicket tlocal obiidAccept = do
|
||||||
encodeRouteLocal <- getEncodeRouteLocal
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
hLocal <- asksSite siteInstanceHost
|
hLocal <- asksSite siteInstanceHost
|
||||||
|
|
@ -1745,6 +1818,48 @@ repoApplyF now shrRecip rpRecip author body mfwd luApply uObject uTarget = do
|
||||||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
return (doc, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
|
insertAcceptLocalRepo luApply ltid obiidAccept = do
|
||||||
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
hLocal <- asksSite siteInstanceHost
|
||||||
|
obikhidAccept <- encodeKeyHashid obiidAccept
|
||||||
|
ltkhid <- encodeKeyHashid ltid
|
||||||
|
ra <- getJust $ remoteAuthorId author
|
||||||
|
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||||
|
|
||||||
|
audAuthor =
|
||||||
|
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
|
||||||
|
|
||||||
|
audTicket =
|
||||||
|
AudLocal [] [LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip ltkhid]
|
||||||
|
|
||||||
|
audRepo =
|
||||||
|
AudLocal
|
||||||
|
[]
|
||||||
|
[ LocalPersonCollectionRepoTeam shrRecip rpRecip
|
||||||
|
, LocalPersonCollectionRepoFollowers shrRecip rpRecip
|
||||||
|
]
|
||||||
|
|
||||||
|
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||||
|
collectAudience [audAuthor, audTicket, audRepo]
|
||||||
|
|
||||||
|
recips = map encodeRouteHome audLocal ++ audRemote
|
||||||
|
doc = Doc hLocal Activity
|
||||||
|
{ activityId =
|
||||||
|
Just $ encodeRouteLocal $
|
||||||
|
RepoOutboxItemR shrRecip rpRecip obikhidAccept
|
||||||
|
, activityActor = encodeRouteLocal $ RepoR shrRecip rpRecip
|
||||||
|
, activityCapability = Nothing
|
||||||
|
, activitySummary = Nothing
|
||||||
|
, activityAudience = Audience recips [] [] [] [] []
|
||||||
|
, activitySpecific = AcceptActivity Accept
|
||||||
|
{ acceptObject = ObjURI hAuthor luApply
|
||||||
|
, acceptResult = Nothing
|
||||||
|
}
|
||||||
|
}
|
||||||
|
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||||
|
return (doc, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
sharerOfferDepF
|
sharerOfferDepF
|
||||||
:: UTCTime
|
:: UTCTime
|
||||||
-> ShrIdent
|
-> ShrIdent
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue