diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 560f68d..12a0b3c 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -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