S2S: repoApplyF: Support local sharer-hosted proposals

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)) ->
+            Left (Left (shr, talid, bnid)) -> do
-                error "Applying local sharer-bundle not supported yet"
+                -- 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