diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 12a0b3c..36e29c4 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -1542,11 +1542,85 @@ repoApplyF now shrRecip rpRecip author body mfwd luApply uObject uTarget = do -- 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 (Left (shr, talid, bnid)) -> do + -- Verify we have this ticket and bundle in the DB + -- Verify the ticket is listed under the repo + -- Verify the bundle is the latest version + mticket <- lift $ runSiteDB $ getSharerProposal shr talid + (_, Entity ltid _, _, context, mresolved, bnid' :| _) <- fromMaybeE mticket "Apply object: No such local ticket" + case context of + Left (_, Entity _ trl) -> + unless (ticketRepoLocalRepo trl == ridRecip) $ + throwE "Apply object: Ticket under some other local repo" + Right _ -> throwE "Apply object: Ticket not under a local repo" + _ <- 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 + talkhid <- encodeKeyHashid talid + let sieve = + makeRecipientSet + [] + [ LocalPersonCollectionSharerProposalFollowers shrRecip talkhid + , 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) <- + insertAcceptLocalSharer luApply shr talid 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" Left (Right (ltid, bnid)) -> do -- Verify we have this ticket and bundle in the DB, and that @@ -1737,25 +1811,9 @@ repoApplyF now shrRecip rpRecip author body mfwd luApply uObject uTarget = do in the local DB? ANSWER: No, it stores only for a repo-hosted own Ticket - TODO there are 3 options for the bundle referred by uObject: - 1: It's under a remote Ticket - 2: It's under a sharer-hosted local Ticket - 3: It's under a repo-hosted local Ticket - And here's what to do in each case: - 1: HTTP GET the bundle to check to which Ticket it belongs, then see - if this our repo has such a remotely-hosted Ticket - 2: Find this Bundle in DB, make sure indeed belongs to specified - sharer, and if so, does our repo have this Ticket listed? - 3: Does this repo-hosted ticket belong to our repo? Make sure in the - route and in the DB - TODO if I'm the target, am I a darcs repo? TODO if a branch of mine is the target, am I a git repo? - - TODO do I have this bundle registered under a proposal I know? - - TODO is this bundle the latest version in that proposal? -} where @@ -1860,6 +1918,48 @@ repoApplyF now shrRecip rpRecip author body mfwd luApply uObject uTarget = do update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (doc, recipientSet, remoteActors, fwdHosts) + insertAcceptLocalSharer luApply shr talid obiidAccept = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + hLocal <- asksSite siteInstanceHost + obikhidAccept <- encodeKeyHashid obiidAccept + talkhid <- encodeKeyHashid talid + ra <- getJust $ remoteAuthorId author + let ObjURI hAuthor luAuthor = remoteAuthorURI author + + audAuthor = + AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra) + + audTicket = + AudLocal [] [LocalPersonCollectionSharerProposalFollowers shr talkhid] + + 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