S2S: repoApplyF: Support local repo-hosted proposals

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