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,19 +1476,151 @@ 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
|
||||
|
||||
-- Check in DB whether the provided capability matches a DB
|
||||
-- record we have, and that it includes permission to apply MRs
|
||||
runSiteDBExcept $ do
|
||||
-- Find the activity itself by URI in the DB
|
||||
act <- do
|
||||
mact <- getActivity capID
|
||||
fromMaybeE mact "Capability activity not known to me"
|
||||
-- Find the Collab record for that activity
|
||||
cid <-
|
||||
case act of
|
||||
Left (_actor, obiid) -> do
|
||||
mcsl <- lift $ getValBy $ UniqueCollabSenderLocalActivity obiid
|
||||
collabSenderLocalCollab <$>
|
||||
fromMaybeE mcsl "Capability is a local activity but no matching capability"
|
||||
Right ractid -> do
|
||||
mcsr <- lift $ getValBy $ UniqueCollabSenderRemoteActivity ractid
|
||||
collabSenderRemoteCollab <$>
|
||||
fromMaybeE mcsr "Capability is a known remote activity but no matching capability"
|
||||
-- Find the recipient of that Collab
|
||||
raidCollab <- do
|
||||
mcrr <- lift $ getValBy $ UniqueCollabRecipRemote cid
|
||||
crr <- fromMaybeE mcrr "No remote recip for capability"
|
||||
mcrl <- lift $ getBy $ UniqueCollabRecipLocal cid
|
||||
verifyNothingE mcrl "Both local & remote recip for capability!"
|
||||
return $ collabRecipRemoteActor crr
|
||||
-- Verify the recipient is the author of the Apply activity
|
||||
unless (raidCollab == remoteAuthorId author) $
|
||||
throwE "Collab recipient isn't the Apply author"
|
||||
-- Find the repo to which this Collab gives access
|
||||
ridCap <- do
|
||||
mctlr <- lift $ getValBy $ UniqueCollabTopicLocalRepo cid
|
||||
rid <-
|
||||
collabTopicLocalRepoRepo <$>
|
||||
fromMaybeE mctlr "Collab isn't for a repo"
|
||||
mctlj <- lift $ getBy $ UniqueCollabTopicLocalProject cid
|
||||
verifyNothingE mctlj "Collab topic duplicate, found project"
|
||||
mctr <- lift $ getBy $ UniqueCollabTopicRemote cid
|
||||
verifyNothingE mctr "Collab topic duplicate, found remote"
|
||||
return rid
|
||||
-- Verify that repo is us
|
||||
unless (ridCap == ridRecip) $
|
||||
throwE "Capability topic is some other local repo"
|
||||
-- Find the collaborator's role in the repo
|
||||
mrlid <-
|
||||
lift $ fmap collabRoleLocalRole <$>
|
||||
getValBy (UniqueCollabRoleLocal cid)
|
||||
-- If no role specified, that means Developer role with
|
||||
-- access to apply changes to repo source code, otherwise
|
||||
-- make sure the specified role (or an ancestor of it) has
|
||||
-- access to the relevant operation
|
||||
for_ mrlid $ \ rlid -> do
|
||||
let roleHas role op = getBy $ UniqueRoleAccess role op
|
||||
ancestorHas = flip getProjectRoleAncestorWithOpQ
|
||||
roleHasAccess role op =
|
||||
fmap isJust . runMaybeT $
|
||||
MaybeT (roleHas role op) <|>
|
||||
MaybeT (ancestorHas role op)
|
||||
has <- lift $ roleHasAccess rlid ProjOpApplyPatch
|
||||
unless has $
|
||||
throwE
|
||||
"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 bundle not supported yet"
|
||||
error "Applying local sharer-bundle not supported yet"
|
||||
|
||||
|
||||
|
||||
|
||||
Left (Right (ltid, bnid)) ->
|
||||
error "Applying local 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
|
||||
|
||||
|
|
@ -1526,69 +1658,6 @@ repoApplyF now shrRecip rpRecip author body mfwd luApply uObject uTarget = do
|
|||
| 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
|
||||
runSiteDBExcept $ do
|
||||
-- Find the activity itself by URI in the DB
|
||||
act <- do
|
||||
mact <- getActivity capID
|
||||
fromMaybeE mact "Capability activity not known to me"
|
||||
-- Find the Collab record for that activity
|
||||
cid <-
|
||||
case act of
|
||||
Left (_actor, obiid) -> do
|
||||
mcsl <- lift $ getValBy $ UniqueCollabSenderLocalActivity obiid
|
||||
collabSenderLocalCollab <$>
|
||||
fromMaybeE mcsl "Capability is a local activity but no matching capability"
|
||||
Right ractid -> do
|
||||
mcsr <- lift $ getValBy $ UniqueCollabSenderRemoteActivity ractid
|
||||
collabSenderRemoteCollab <$>
|
||||
fromMaybeE mcsr "Capability is a known remote activity but no matching capability"
|
||||
-- Find the recipient of that Collab
|
||||
raidCollab <- do
|
||||
mcrr <- lift $ getValBy $ UniqueCollabRecipRemote cid
|
||||
crr <- fromMaybeE mcrr "No remote recip for capability"
|
||||
mcrl <- lift $ getBy $ UniqueCollabRecipLocal cid
|
||||
verifyNothingE mcrl "Both local & remote recip for capability!"
|
||||
return $ collabRecipRemoteActor crr
|
||||
-- Verify the recipient is the author of the Apply activity
|
||||
unless (raidCollab == remoteAuthorId author) $
|
||||
throwE "Collab recipient isn't the Apply author"
|
||||
-- Find the repo to which this Collab gives access
|
||||
ridCap <- do
|
||||
mctlr <- lift $ getValBy $ UniqueCollabTopicLocalRepo cid
|
||||
rid <-
|
||||
collabTopicLocalRepoRepo <$>
|
||||
fromMaybeE mctlr "Collab isn't for a repo"
|
||||
mctlj <- lift $ getBy $ UniqueCollabTopicLocalProject cid
|
||||
verifyNothingE mctlj "Collab topic duplicate, found project"
|
||||
mctr <- lift $ getBy $ UniqueCollabTopicRemote cid
|
||||
verifyNothingE mctr "Collab topic duplicate, found remote"
|
||||
return rid
|
||||
-- Verify that repo is us
|
||||
unless (ridCap == ridRecip) $
|
||||
throwE "Capability topic is some other local repo"
|
||||
-- Find the collaborator's role in the repo
|
||||
mrlid <-
|
||||
lift $ fmap collabRoleLocalRole <$>
|
||||
getValBy (UniqueCollabRoleLocal cid)
|
||||
-- If no role specified, that means Developer role with
|
||||
-- access to apply changes to repo source code, otherwise
|
||||
-- make sure the specified role (or an ancestor of it) has
|
||||
-- access to the relevant operation
|
||||
for_ mrlid $ \ rlid -> do
|
||||
let roleHas role op = getBy $ UniqueRoleAccess role op
|
||||
ancestorHas = flip getProjectRoleAncestorWithOpQ
|
||||
roleHasAccess role op =
|
||||
fmap isJust . runMaybeT $
|
||||
MaybeT (roleHas role op) <|>
|
||||
MaybeT (ancestorHas role op)
|
||||
has <- lift $ roleHasAccess rlid ProjOpApplyPatch
|
||||
unless has $
|
||||
throwE
|
||||
"Apply author's role in repo doesn't have \
|
||||
\ApplyPatch access"
|
||||
|
||||
-- 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