S2S: repoApplyF: Support local repo-hosted proposals

src/Vervis/Federation/Ticket.hs

@@ -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
+                        applyDarcsPatch patch
-                        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 ()
 
                 -- 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