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
|
||||
getBy404 $ UniqueRepo rpRecip sid
|
||||
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
|
||||
-- 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 \
|
||||
\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
|
||||
patches <- for lus $ \ luPatch -> do
|
||||
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
|
||||
_ :| (_ : _) -> throwE "Darcs repo given multiple patch bundles"
|
||||
(PatchMediaTypeDarcs, t) :| [] -> return t
|
||||
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 ()
|
||||
applyDarcsPatch patch
|
||||
|
||||
-- Insert Apply activity to repo's inbox
|
||||
-- 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
|
||||
(sig,) <$> deliverRemoteDB_R (actbBL body) ractid ridRecip sig remoteRecips
|
||||
obiidAccept <- insertEmptyOutboxItem (repoOutbox repoRecip) now
|
||||
|
||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
insertAccept luApply hBundle tlocal obiidAccept
|
||||
insertAcceptRemote luApply hBundle tlocal obiidAccept
|
||||
|
||||
knownRemoteRecipsAccept <-
|
||||
deliverLocal'
|
||||
False
|
||||
|
|
@ -1703,8 +1759,25 @@ repoApplyF now shrRecip rpRecip author body mfwd luApply uObject uTarget = do
|
|||
-}
|
||||
|
||||
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
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
|
|
@ -1745,6 +1818,48 @@ repoApplyF now shrRecip rpRecip author body mfwd luApply uObject uTarget = do
|
|||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
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
|
||||
:: UTCTime
|
||||
-> ShrIdent
|
||||
|
|
|
|||
Loading…
Reference in a new issue