S2S: Implement loomApplyF (remote person asking to apply bundle on local loom)

src/Vervis/API.hs

@@ -115,6 +115,7 @@ import Vervis.Model.Ticket
 import Vervis.Path
 import Vervis.Persist.Actor
 import Vervis.Persist.Collab
+import Vervis.Persist.Ticket
 import Vervis.Recipient
 import Vervis.RemoteActorStore
 import Vervis.Settings
@@ -597,24 +598,10 @@ applyC
     -> Audience URIMode
     -> Apply URIMode
     -> ExceptT Text Handler OutboxItemId
-applyC (Entity senderPersonID senderPerson) senderActor muCap summary audience (AP.Apply uObject target) = do
+applyC (Entity senderPersonID senderPerson) senderActor muCap summary audience apply = do
 
     -- Check input
-    maybeLocalTarget <- do
+    maybeLocalTarget <- checkApplyLocalLoom apply
-        bundle <- parseProposalBundle "Apply object" uObject
-        targetTip <- nameExceptT "Apply target" $ checkTip target
-        let maybeLocal =
-                case targetTip of
-                    TipLocalRepo repoID -> Just (repoID, Nothing)
-                    TipLocalBranch repoID branch -> Just (repoID, Just branch)
-                    TipRemote _ -> Nothing
-                    TipRemoteBranch _ _ -> Nothing
-        for maybeLocal $ \ (repoID, maybeBranch) -> do
-            (loomID, clothID, bundleID) <-
-                case bundle of
-                    Left b -> pure b
-                    Right _ -> throwE "Applying a remote bundle on local loom"
-            return (repoID, maybeBranch, loomID, clothID, bundleID)
     ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
         mrecips <- parseAudience audience
         fromMaybeE mrecips "Apply with no recipients"
@@ -636,89 +623,23 @@ applyC (Entity senderPersonID senderPerson) senderActor muCap summary audience (
     maybeLocalTargetDB <- for maybeLocalTarget $
         \ (repoID, maybeBranch, loomID, clothID, bundleID) -> runDBExcept $ do
 
-            -- Find the bundle and its loom in DB
+            -- Find the repo and the bundle in our DB, and verify that the loom
-            (loom, clothBranch, ticketID, maybeResolve, latest) <- do
+            -- hosting the bundle is willing to accept the request from sender
-                maybeBundle <- lift $ runMaybeT $ do
+            -- to apply this specific bundle to this repo/branch
-                    (Entity _ loom, Entity _ cloth, Entity ticketID _, _author, resolve, proposal) <-
+            (loom, ticketID, diffs) <-
-                        MaybeT $ getCloth loomID clothID
+                checkApplyDB
-                    bundle <- MaybeT $ get bundleID
+                    (Left senderPersonID)
-                    guard $ bundleTicket bundle == clothID
+                    capID
-                    latest :| _prevs <-
+                    (repoID, maybeBranch)
-                        case justHere proposal of
+                    (loomID, clothID, bundleID)
-                            Nothing ->
-                                error "Why didn't getCloth find any bundles"
-                            Just bundles -> return bundles
-                    return (loom, ticketLoomBranch cloth, ticketID, resolve, latest)
-                fromMaybeE maybeBundle ""
-
-            -- Verify the target repo/branch iof the Apply is identical to the
-            -- target repo/branch of the MR
-            unless (maybeBranch == clothBranch) $
-                throwE "Apply target != MR target"
-
-            -- Find target repo in DB and verify it consents to being served by
-            -- the loom
-            unless (repoID == loomRepo loom) $
-                throwE "MR target repo isn't the one served by the Apply object bundle's loom"
-            repo <- getE repoID "Apply target: No such local repo in DB"
-            unless (repoLoom repo == Just loomID) $
-                throwE "Apply object bunde's loom doesn't have repo's consent to serve it"
-
-            -- Verify that VCS type matches the presence of a branch:
-            -- Branch specified for Git, isn't specified for Darcs
-            case (repoVcs repo, maybeBranch) of
-                (VCSDarcs, Nothing) -> pure ()
-                (VCSGit, Just _) -> pure ()
-                _ -> throwE "VCS type and branch presence mismatch"
-
-            -- Verify the MR isn't already resolved and the bundle is the
-            -- latest version
-            unless (isNothing maybeResolve) $
-                throwE "MR is already resolved"
-            unless (bundleID == latest) $
-                throwE "Bundle isn't the latest version"
-
-            -- Verify the sender is authorized by the loom to apply a patch
-            capability <-
-                case capID of
-                    Left (actor, _, item) -> return (actor, item)
-                    Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local loom"
-            verifyCapability capability (Left senderPersonID) (GrantResourceLoom loomID)
-
-            -- Get the patches from DB, verify VCS match just in case
-            diffs <- do
-                ps <-
-                    lift $ map entityVal <$>
-                        selectList [PatchBundle ==. bundleID] [Asc PatchId]
-                let patchVCS = patchMediaTypeVCS . patchType
-                case NE.nonEmpty ps of
-                    Nothing -> error "Bundle without patches"
-                    Just ne ->
-                        if all ((== repoVcs repo) . patchVCS) ne
-                            then return $ NE.map patchContent ne
-                            else throwE "Patch type mismatch with repo VCS type"
 
             return
                 (Entity loomID loom, clothID, ticketID, repoID, maybeBranch, diffs)
 
     -- Apply patches
-    for_ maybeLocalTargetDB $ \ (_, _, _, repoID, maybeBranch, diffs) -> do
+    for_ maybeLocalTargetDB $
-        repoPath <- do
+        \ (_, _, _, repoID, maybeBranch, diffs) ->
-            repoHash <- encodeKeyHashid repoID
+            applyPatches repoID maybeBranch diffs
-            repoDir <- askRepoDir repoHash
-            liftIO $ makeAbsolute repoDir
-        case maybeBranch of
-            Just branch -> do
-                ExceptT $ liftIO $ runExceptT $
-                    withSystemTempDirectory "vervis-applyC" $
-                        applyGitPatches repoPath (T.unpack branch) diffs
-            Nothing -> do
-                patch <-
-                    case diffs of
-                        t :| [] -> return t
-                        _ :| (_ : _) ->
-                            throwE "Darcs repo given multiple patch bundles"
-                applyDarcsPatch repoPath patch
 
     senderHash <- encodeKeyHashid senderPersonID
     now <- liftIO getCurrentTime
@@ -824,7 +745,7 @@ applyC (Entity senderPersonID senderPerson) senderActor muCap summary audience (
                 , activitySummary    = summary
                 , activityAudience   = blinded
                 , activityFulfills   = []
-                , activitySpecific   = ApplyActivity $ Apply uObject target
+                , activitySpecific   = ApplyActivity apply
                 }
         update applyID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
         return (luApply, doc)

src/Vervis/Data/Ticket.hs

@@ -19,8 +19,8 @@ module Vervis.Data.Ticket
     , Merge (..)
     , TrackerAndMerge (..)
     , WorkItemOffer (..)
-    , checkTip
     , checkOfferTicket
+    , checkApplyLocalLoom
 
     -- These are exported only for Vervis.Client
     , Tracker (..)
@@ -50,6 +50,7 @@ import Control.Monad.Trans.Except.Local
 import Vervis.Foundation
 import Vervis.FedURI
 import Vervis.Model
+import Vervis.Ticket
 
 data Tip
     = TipLocalRepo RepoId
@@ -199,3 +200,30 @@ checkOfferTicket host ticket uTarget = do
         unless (tracker == target) $ throwE "Offer target != ticket context"
     tam <- checkTrackerAndMerge target maybeBundle
     return $ WorkItemOffer author title desc source tam
+
+checkApply
+    :: AP.Apply URIMode
+    -> ExceptT Text Handler
+        (Either (LoomId, TicketLoomId, BundleId) FedURI, Tip)
+checkApply (AP.Apply uObject target) =
+    (,) <$> parseProposalBundle "Apply object" uObject
+        <*> nameExceptT "Apply target" (checkTip target)
+
+checkApplyLocalLoom
+    :: AP.Apply URIMode
+    -> ExceptT Text Handler
+        (Maybe (RepoId, Maybe Text, LoomId, TicketLoomId, BundleId))
+checkApplyLocalLoom apply = do
+    (bundle, targetTip) <- checkApply apply
+    let maybeLocal =
+            case targetTip of
+                TipLocalRepo repoID -> Just (repoID, Nothing)
+                TipLocalBranch repoID branch -> Just (repoID, Just branch)
+                TipRemote _ -> Nothing
+                TipRemoteBranch _ _ -> Nothing
+    for maybeLocal $ \ (repoID, maybeBranch) -> do
+        (loomID, clothID, bundleID) <-
+            case bundle of
+                Left b -> pure b
+                Right _ -> throwE "Applying a remote bundle on local loom"
+        return (repoID, maybeBranch, loomID, clothID, bundleID)

src/Vervis/Federation/Ticket.hs

@@ -20,8 +20,7 @@ module Vervis.Federation.Ticket
 
     --, repoAddBundleF
 
-    --, repoApplyF
+    , loomApplyF
-    --, loomApplyF
 
     --, deckOfferDepF
     --, repoOfferDepF
@@ -94,6 +93,7 @@ import Development.PatchMediaType
 
 import Vervis.ActivityPub
 import Vervis.Cloth
+import Vervis.Data.Actor
 import Vervis.Data.Ticket
 import Vervis.Darcs
 import Vervis.Delivery
@@ -107,6 +107,7 @@ import Vervis.Model
 import Vervis.Model.Role
 import Vervis.Model.Ticket
 import Vervis.Path
+import Vervis.Persist.Ticket
 import Vervis.Query
 import Vervis.Recipient
 import Vervis.Ticket
@@ -499,6 +500,12 @@ deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do
         update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
         return (doc, recipientSet, remoteActors, fwdHosts)
 
+activityAlreadyInInbox hAct luAct inboxID = fmap isJust . runMaybeT $ do
+    instanceID <- MaybeT $ getKeyBy $ UniqueInstance hAct
+    remoteObjectID <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID luAct
+    remoteActivityID <- MaybeT $ getKeyBy $ UniqueRemoteActivity remoteObjectID
+    MaybeT $ getBy $ UniqueInboxItemRemote inboxID remoteActivityID
+
 loomOfferTicketF
     :: UTCTime
     -> KeyHashid Loom
@@ -577,13 +584,11 @@ loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do
 
         -- Has the loom already received this activity to its inbox? If yes, we
         -- won't process it again
-        maybeAlreadyInInbox <- runMaybeT $ do
+        alreadyInInbox <- do
-            instanceID <- MaybeT $ getKeyBy $ UniqueInstance $ objUriAuthority $ remoteAuthorURI author
+            let hOffer = objUriAuthority $ remoteAuthorURI author
-            remoteObjectID <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID luOffer
+            activityAlreadyInInbox hOffer luOffer (actorInbox actor)
-            remoteActivityID <- MaybeT $ getKeyBy $ UniqueRemoteActivity remoteObjectID
-            MaybeT $ getBy $ UniqueInboxItemRemote (actorInbox actor) remoteActivityID
 
-        return (recipLoomRepoID, recipLoomActor, isJust maybeAlreadyInInbox)
+        return (recipLoomRepoID, recipLoomActor, alreadyInInbox)
 
     if alreadyInInbox
         then return ("I already have this activity in my inbox, ignoring", Nothing)
@@ -1169,564 +1174,204 @@ repoAddBundleF now recipHash author body mfwd luAdd patches uTarget = do
                         shrRecip rpRecip (hashLTID ltid)
 -}
 
-repoApplyF
+loomApplyF
     :: UTCTime
-    -> KeyHashid Repo
+    -> KeyHashid Loom
     -> RemoteAuthor
     -> ActivityBody
     -> Maybe (RecipientRoutes, ByteString)
     -> LocalURI
-    -> FedURI
+    -> AP.Apply URIMode
-    -> FedURI
     -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-repoApplyF now recipHash author body mfwd luApply uObject uTarget = do
+loomApplyF now recipLoomHash author body mfwd luApply apply = (,Nothing) <$> do
-    error "repoApplyF temporarily disabled"
 
-
+    -- Check input
-{-
+    recipLoomID <- decodeKeyHashid404 recipLoomHash
-
+    (repoID, maybeBranch, clothID, bundleID) <- do
-
+        maybeLocalTarget <- checkApplyLocalLoom apply
-    -- Verify the patch bundle URI is one of:
+        (repoID, maybeBranch, loomID, clothID, bundleID) <-
-    --   * A local sharer-hosted bundle
+            fromMaybeE
-    --   * A local repo-hosted bundle under the receiving repo
+                maybeLocalTarget
-    --   * A remote URI
+                "Bundle doesn't belong to a local loom, in particular not to \
-    bundle <- do
+                \me, so I won't apply it. Was I supposed to receive it?"
-        b <- parseProposalBundle "repoApplyF Apply object, a URI" uObject
+        unless (loomID == recipLoomID) $
-        case b of
+            throwE
-            Left (Right (shr, rp, ltid, bnid)) ->
+                "Bundle belongs to some other local loom, so I won't apply \
-                if shr == shrRecip && rp == rpRecip
+                \it. Was I supposed to receive it?"
-                    then return $ Left $ Right (ltid, bnid)
+        return (repoID, maybeBranch, clothID, bundleID)
-                    else throwE "Bundle is some other local repo's repo-hosted bundle"
-            Left (Left x) -> return $ Left $ Left x
-            Right u -> return $ Right u
-
-    -- Verify the apply's target is one of:
-    --   * The URI of the receiving repo
-    --   * A local branch URI under the receiving repo
-    --   * A remote URI
-    mbranch <- do
-        target <- checkBranch' uTarget
-        case target of
-            Left (shr, rp, mb) | shr == shrRecip && rp == rpRecip -> return mb
-            _ -> throwE "Apply target isn't me, so, ignoring this activity"
 
     -- Verify the capability URI is one of:
     --   * Outbox item URI of a local actor, i.e. a local activity
     --   * A remote URI
-    capID <- do
+    uCap <- do
         let muCap = activityCapability $ actbActivity body
-        uCap <- fromMaybeE muCap "Asking to apply patch but no capability provided"
+        fromMaybeE muCap "Asking to apply patch but no capability provided"
-        parseActivityURI "Apply capability" uCap
+    capID <- nameExceptT "Apply capability" $ parseActivityURI uCap
 
-    -- Make sure receiving repo exists in DB, otherwise its inbox doesn't exist
+    maybeNewApply <- runDBExcept $ do
-    -- either thus we return 404
-    Entity ridRecip repoRecip <- lift $ runDB $ 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
+        -- Find recipient loom in DB, returning 404 if doesn't exist because
-        -- record we have, and that it includes permission to apply MRs
+        -- we're in the loom's inbox post handler
-        runSiteDBExcept $ do
+        recipLoom <- lift $ get404 recipLoomID
-            -- Find the activity itself by URI in the DB
+        let recipLoomActorID = loomActor recipLoom
-            act <- do
+        recipLoomActor <- lift $ getJust recipLoomActorID
-                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
+        -- Has the loom already received this activity to its inbox? If yes, we
-        case bundle of
+        -- won't process it again
-            Left (Left (shr, talid, bnid)) -> do
+        alreadyInInbox <- lift $ do
-                -- Verify we have this ticket and bundle in the DB
+            let hOffer = objUriAuthority $ remoteAuthorURI author
-                -- Verify the ticket is listed under the repo
+            activityAlreadyInInbox hOffer luApply (actorInbox recipLoomActor)
-                -- 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
+        -- Find the repo and the bundle in our DB, and verify that the loom is
-                patches <- lift $ runSiteDB $ selectList [PatchBundle ==. bnid] [Asc PatchId]
+        -- willing to accept the request from sender to apply this specific
-                case repoVcs repoRecip of
+        -- bundle to this repo/branch
-                    VCSGit -> do
+        if alreadyInInbox
-                        branch <- fromMaybeE mbranch "Apply target is a Git repo, branch not specified"
+            then pure Nothing
-                        patches' <-
+            else Just <$> do
-                            case NE.nonEmpty patches of
+                (_, ticketID, diffs) <-
-                                Nothing -> error "No patches found in DB"
+                    checkApplyDB
-                                Just ps -> return ps
+                        (Right $ remoteAuthorId author) capID
-                        let essence (Patch _ _ typ t) = (typ, t)
+                        (repoID, maybeBranch) (recipLoomID, clothID, bundleID)
-                            patches'' = NE.map (essence . entityVal) patches'
+                return (Entity recipLoomActorID recipLoomActor, ticketID, diffs)
-                        unless (all ((== PatchMediaTypeGit) . fst) patches'') $
-                            throwE "Trying to apply non-Git patch to a Git repo"
-                        applyGitPatches shrRecip rpRecip branch $ NE.map snd patches''
-                    VCSDarcs -> do
-                        verifyNothingE mbranch "Apply target is a branch of a Darcs repo"
-                        patch <-
-                            case patches of
-                                [] -> error "Local repo-bundle without any patches found"
-                                _ : (_ : _) -> throwE "Darcs repo given multiple patch bundles"
-                                (Entity _ (Patch _ _ typ t)) : [] ->
-                                    case typ of
-                                        PatchMediaTypeDarcs -> return t
-                                        _ -> throwE "Trying to apply non-Darcs patch to a Darcs repo"
-                        applyDarcsPatch shrRecip rpRecip patch
 
-                -- Insert Apply activity to repo's inbox
+    case maybeNewApply of
-                -- Produce an Accept activity and deliver locally
+        Nothing ->
-                -- Mark the ticket as resolved
+            return "I already have this activity in my inbox, doing nothing"
-                mhttp <- lift $ runSiteDB $ do
+        Just (Entity recipLoomActorID recipLoomActor, ticketID, diffs) -> do
-                    mractid <- insertToInbox now author body (repoInbox repoRecip) luApply False
+
-                    for mractid $ \ ractid -> do
+            -- Apply patches
-                        mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
+            applyPatches repoID maybeBranch diffs
-                            talkhid <- encodeKeyHashid talid
+
+            maybeHttp <- lift $ runDB $ do
+
+                -- Insert the Apply to loom's inbox
+                mractid <- insertToInbox now author body (actorInbox recipLoomActor) luApply False
+                for mractid $ \ applyID -> do
+
+                    -- Forward the Apply activity to relevant local stages, and
+                    -- schedule delivery for unavailable remote members of them
+                    maybeHttpFwdApply <- for mfwd $ \ (localRecips, sig) -> do
+                        clothHash <- encodeKeyHashid clothID
                         let sieve =
                                 makeRecipientSet
                                     []
-                                        [ LocalPersonCollectionSharerProposalFollowers shrRecip talkhid
+                                    [ LocalStageLoomFollowers recipLoomHash
-                                        , LocalPersonCollectionRepoTeam shrRecip rpRecip
+                                    , LocalStageClothFollowers recipLoomHash clothHash
-                                        , LocalPersonCollectionRepoFollowers shrRecip rpRecip
                                     ]
                         remoteRecips <-
-                                insertRemoteActivityToLocalInboxes
+                            insertRemoteActivityToLocalInboxes False applyID $
-                                    False ractid $
+                                localRecipSieve' sieve False False localRecips
-                                        localRecipSieve'
+                        remoteRecipsHttp <-
-                                            sieve False False localRecips
+                            deliverRemoteDB_L
-                            (sig,) <$> deliverRemoteDB_R (actbBL body) ractid ridRecip sig remoteRecips
+                                (actbBL body) applyID recipLoomID sig remoteRecips
-                        obiidAccept <- insertEmptyOutboxItem (repoOutbox repoRecip) now
+                        return $
+                            deliverRemoteHTTP_L
+                                now recipLoomHash (actbBL body) sig remoteRecipsHttp
 
-                        _ <- insertResolve author ltid ractid obiidAccept
+                    -- Mark ticket in DB as resolved by the Apply
+                    acceptID <-
+                        insertEmptyOutboxItem (actorOutbox recipLoomActor) now
+                    insertResolve ticketID applyID acceptID
 
+                    -- Prepare an Accept activity and insert to loom's outbox
                     (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
-                            insertAcceptLocalSharer luApply shr talid obiidAccept
+                        insertAcceptToOutbox uCap clothID acceptID
 
+                    -- Deliver the Accept to local recipients, and schedule delivery
+                    -- for unavailable remote recipients
                     knownRemoteRecipsAccept <-
                         deliverLocal'
-                                False
+                            False (LocalActorLoom recipLoomHash) recipLoomActorID
-                                (LocalActorRepo shrRecip rpRecip)
+                            acceptID localRecipsAccept
-                                (repoInbox repoRecip)
+                    remoteRecipsHttpAccept <-
-                                obiidAccept
+                        deliverRemoteDB''
-                                localRecipsAccept
+                            fwdHostsAccept acceptID remoteRecipsAccept
-                        (mremotesHttpFwd, obiidAccept, docAccept, fwdHostsAccept,) <$>
+                            knownRemoteRecipsAccept
-                            deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
 
-                -- Run inbox-forwarding on the Apply activity
+                    -- Return instructions for HTTP inbox-forwarding of the Apply
-                -- Deliver Accept activity to remote recipients via HTTP
+                    -- activity, and for HTTP delivery of the Accept activity to
-                case mhttp of
+                    -- remote recipients
-                    Nothing -> return "I already have this activity in my inbox, doing nothing"
+                    return
-                    Just (mremotesHttpFwd, obiid, doc, fwdHosts, recips) -> do
+                        ( maybeHttpFwdApply
-                        for_ mremotesHttpFwd $ \ (sig, remotes) ->
+                        , deliverRemoteHttp'
-                            forkWorker "repoApplyF inbox-forwarding" $
+                            fwdHostsAccept acceptID docAccept remoteRecipsHttpAccept
-                                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
+            -- Launch asynchronous HTTP forwarding of the Apply activity and HTTP
-                -- Verify we have this ticket and bundle in the DB, and that
+            -- delivery of the Accept activity
-                -- the bundle is the latest version
+            case maybeHttp of
-                mticket <- lift $ runSiteDB $ getRepoProposal shrRecip rpRecip ltid
+                Nothing ->
-                (_, _, _, _, _, _, _, mresolved, bnid' :| _) <- fromMaybeE mticket "Apply object: No such local ticket"
+                    return
-                _ <- fromMaybeE mresolved "Apply object: Proposal already applied"
+                        "When I started serving this activity, I didn't have it in my inbox, \
-                unless (bnid == bnid') $
+                        \but now suddenly it seems I already do, so ignoring"
-                    throwE "Apply object: Bundle isn't the latest version"
+                Just (maybeHttpFwdApply, deliverHttpAccept) -> do
-
+                    forkWorker "loomApplyF Accept HTTP delivery" deliverHttpAccept
-                -- Grab the bundle's patches from DB and apply them
+                    case maybeHttpFwdApply of
-                patches <- lift $ runSiteDB $ selectList [PatchBundle ==. bnid] [Asc PatchId]
+                        Nothing -> return "Applied the patch(es), no inbox-forwarding to do"
-                case repoVcs repoRecip of
+                        Just forwardHttpApply -> do
-                    VCSGit -> do
+                            forkWorker "loomApplyF inbox-forwarding" forwardHttpApply
-                        branch <- fromMaybeE mbranch "Apply target is a Git repo, branch not specified"
+                            return "Applied the patch(es) and ran inbox-forwarding of the Apply"
-                        patches' <-
-                            case NE.nonEmpty patches of
-                                Nothing -> error "No patches found in DB"
-                                Just ps -> return ps
-                        let essence (Patch _ _ typ t) = (typ, t)
-                            patches'' = NE.map (essence . entityVal) patches'
-                        unless (all ((== PatchMediaTypeGit) . fst) patches'') $
-                            throwE "Trying to apply non-Git patch to a Git repo"
-                        applyGitPatches shrRecip rpRecip branch $ NE.map snd patches''
-                    VCSDarcs -> do
-                        verifyNothingE mbranch "Apply target is a branch of a Darcs repo"
-                        patch <-
-                            case patches of
-                                [] -> error "Local repo-bundle without any patches found"
-                                _ : (_ : _) -> throwE "Darcs repo given multiple patch bundles"
-                                (Entity _ (Patch _ _ typ t)) : [] ->
-                                    case typ of
-                                        PatchMediaTypeDarcs -> return t
-                                        _ -> throwE "Trying to apply non-Darcs patch to a Darcs repo"
-                        applyDarcsPatch shrRecip rpRecip 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) <-
-                        withExceptT T.pack $ AP.fetchAP manager $ Left $ ObjURI hBundle luPatch
-                    (h, PatchLocal luP luC) <- fromMaybeE mlocal "No patch @id"
-                    unless (ObjURI h luP == ObjURI hBundle luPatch) $
-                        throwE "Patch @id doesn't match the URI we fetched"
-                    unless (luC == luBundle) $
-                        throwE "Patch doesn't point back to the bundle"
-                    unless (patchMediaTypeVCS typ == repoVcs repoRecip) $
-                        throwE "Patch type and repo VCS mismatch"
-                    return (typ, content)
-                case repoVcs repoRecip of
-                    VCSGit -> do
-                        branch <- fromMaybeE mbranch "Apply target is a Git repo, branch not specified"
-                        unless (all ((== PatchMediaTypeGit) . fst) patches) $
-                            throwE "Trying to apply non-Git patch to a Git repo"
-                        applyGitPatches shrRecip rpRecip branch $ NE.map snd patches
-                    VCSDarcs -> do
-                        verifyNothingE mbranch "Apply target is a branch of a Darcs repo"
-                        patch <-
-                            case patches of
-                                _ :| (_ : _) -> throwE "Darcs repo given multiple patch bundles"
-                                (typ, t) :| [] ->
-                                    case typ of
-                                        PatchMediaTypeDarcs -> return t
-                                        _ -> throwE "Trying to apply non-Darcs patch to a Darcs repo"
-                        applyDarcsPatch shrRecip rpRecip patch
-
-                -- Insert Apply activity to repo's inbox
-                -- Produce an Accept activity and deliver locally
-                mhttp <- lift $ runSiteDB $ do
-                    mractid <- insertToInbox now author body (repoInbox repoRecip) luApply False
-                    for mractid $ \ ractid -> do
-                        mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
-                            let sieve =
-                                    makeRecipientSet
-                                        []
-                                        [ 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
-
-                        (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
-                            insertAcceptRemote luApply hBundle tlocal 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"
-
-    {-
-    TODO to be clear: When a repo receives a Ticket, does it store the whole
-         ticket and bundle and patches in DB?
-         ANSWER: Yes, it does
-
-         And when a repo is notified on a new bundle version for such a
-         remotely hosted Ticket, does it store this new bundle and its patches
-         in the local DB?
-         ANSWER: No, it stores only for a repo-hosted own Ticket
-
-    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?
-    -}
 
     where
-    insertAcceptRemote luApply hTicket tlocal obiidAccept = do
+
+    insertResolve ticketID applyID acceptID = do
+        trid <- insert TicketResolve
+            { ticketResolveTicket = ticketID
+            , ticketResolveAccept = acceptID
+            }
+        insert_ TicketResolveRemote
+            { ticketResolveRemoteTicket   = trid
+            , ticketResolveRemoteActivity = applyID
+            , ticketResolveRemoteActor    = remoteAuthorId author
+            }
+        update ticketID [TicketStatus =. TSClosed]
+
+    insertAcceptToOutbox uCap clothID acceptID = do
         encodeRouteLocal <- getEncodeRouteLocal
         encodeRouteHome <- getEncodeRouteHome
         hLocal <- asksSite siteInstanceHost
-        obikhidAccept <- encodeKeyHashid obiidAccept
+
+        clothHash <- encodeKeyHashid clothID
+        acceptHash <- encodeKeyHashid acceptID
+
         ra <- getJust $ remoteAuthorId author
+
         let ObjURI hAuthor luAuthor = remoteAuthorURI author
 
-            audAuthor =
+            audSender =
-                AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
+                AudRemote hAuthor
-
+                    [luAuthor]
-            audTicket =
+                    (maybeToList $ remoteActorFollowers ra)
-                AudRemote hTicket [] [AP.ticketParticipants tlocal]
+            audTracker =
-
-            audRepo =
                 AudLocal
                     []
-                    [ LocalPersonCollectionRepoTeam shrRecip rpRecip
+                    [ LocalStageLoomFollowers recipLoomHash
-                    , LocalPersonCollectionRepoFollowers shrRecip rpRecip
+                    , LocalStageClothFollowers recipLoomHash clothHash
                     ]
 
             (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
-                collectAudience [audAuthor, audTicket, audRepo]
+                collectAudience [audSender, audTracker]
 
             recips = map encodeRouteHome audLocal ++ audRemote
-            doc = Doc hLocal Activity
+            doc = AP.Doc hLocal AP.Activity
-                { activityId       =
+                { AP.activityId         =
                     Just $ encodeRouteLocal $
-                        RepoOutboxItemR shrRecip rpRecip obikhidAccept
+                        LoomOutboxItemR recipLoomHash acceptHash
-                , activityActor    = encodeRouteLocal $ RepoR shrRecip rpRecip
+                , AP.activityActor      =
-                , activityCapability = Nothing
+                    encodeRouteLocal $ LoomR recipLoomHash
-                , activitySummary  = Nothing
+                , AP.activityCapability = Just uCap
-                , activityAudience = Audience recips [] [] [] [] []
+                , AP.activitySummary    = Nothing
-                , activitySpecific = AcceptActivity Accept
+                , AP.activityAudience   = AP.Audience recips [] [] [] [] []
+                , AP.activityFulfills   = []
+                , AP.activitySpecific   = AP.AcceptActivity AP.Accept
                     { acceptObject = ObjURI hAuthor luApply
                     , acceptResult = Nothing
                     }
                 }
-        update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+
+        update acceptID [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)
-
-    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)
--}
-
 personOfferDepF
     :: UTCTime
     -> KeyHashid Person

src/Vervis/Handler/Loom.hs

@@ -142,6 +142,8 @@ postLoomInboxR recipLoomHash =
         case specific of
             AP.AcceptActivity accept ->
                 loomAcceptF now recipLoomHash author body mfwd luActivity accept
+            AP.ApplyActivity apply->
+                loomApplyF now recipLoomHash author body mfwd luActivity apply
             AP.InviteActivity invite ->
                 topicInviteF now (GrantResourceLoom recipLoomHash) author body mfwd luActivity invite
             AP.OfferActivity (AP.Offer obj target) ->

src/Vervis/Persist/Ticket.hs

@@ -0,0 +1,144 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Vervis.Persist.Ticket
+    ( checkApplyDB
+    )
+where
+
+import Control.Monad
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Maybe
+import Data.Text (Text)
+import Data.These
+import Database.Persist
+
+import qualified Data.List.NonEmpty as NE
+
+import Development.PatchMediaType
+import Yesod.Hashids
+
+import Control.Monad.Trans.Except.Local
+import Database.Persist.Local
+
+import Vervis.Access
+import Vervis.Cloth
+import Vervis.FedURI
+import Vervis.Foundation
+import Vervis.Model
+import Vervis.Recipient
+
+-- | Given:
+--
+-- * A local tip (i.e. a repository or a branch), parsed from a URI
+-- * A local bundle to apply to it, parsed from a URI
+-- * A local or remote actor requesting to apply the bundle to the tip, already
+--   known to be in our DB
+-- * An activity URI provided by that actor as a capability, parsed from URI
+--
+-- Find the tip and the bundle in our DB, and verify that the loom hosting the
+-- bundle is willing to accept the request from that specific actor to apply
+-- that bundle to that repo. More specifically:
+--
+-- * Verify the tip matches the MR target
+-- * Verify that the loom and the repo are linked
+-- * Verify that a branch is specified if repo is Git, isn't specified if Darcs
+-- * Verify the MR isn't already resolved
+-- * Verify bundle is the latest version of the MR
+-- * Verify the requester actor is authorized to apply
+-- * Verify that patch type matches repo VCS type
+--
+-- Returns:
+--
+-- * The loom (so it can send an Accept after applying)
+-- * The MR's ticket ID (so it can be marked as resolved after applying)
+-- * The actual patch diffs, in first-to-last order
+checkApplyDB
+    :: Either PersonId RemoteActorId    -- ^ Actor requesting to apply
+    -> (Either
+            (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
+            FedURI
+       )                                -- ^ Capability specified by the actor
+    -> (RepoId, Maybe Text)             -- ^ Repository (or branch) to apply to
+    -> (LoomId, TicketLoomId, BundleId) -- ^ Parsed bundle URI to apply
+    -> ExceptT Text AppDB (Loom, TicketId, NonEmpty Text)
+checkApplyDB actor capID (repoID, maybeBranch) (loomID, clothID, bundleID) = do
+
+    -- Find the bundle and its loom in DB
+    (loom, clothBranch, ticketID, maybeResolve, latest) <- do
+        maybeBundle <- lift $ runMaybeT $ do
+            (Entity _ loom, Entity _ cloth, Entity ticketID _, _author, resolve, proposal) <-
+                MaybeT $ getCloth loomID clothID
+            bundle <- MaybeT $ get bundleID
+            guard $ bundleTicket bundle == clothID
+            latest :| _prevs <-
+                case justHere proposal of
+                    Nothing ->
+                        error "Why didn't getCloth find any bundles"
+                    Just bundles -> return bundles
+            return (loom, ticketLoomBranch cloth, ticketID, resolve, latest)
+        fromMaybeE maybeBundle "Apply object bundle not found in DB"
+
+    -- Verify the target repo/branch of the Apply is identical to the
+    -- target repo/branch of the MR
+    unless (maybeBranch == clothBranch) $
+        throwE "Apply target != MR target"
+
+    -- Find target repo in DB and verify it consents to being served by
+    -- the loom
+    unless (repoID == loomRepo loom) $
+        throwE "MR target repo isn't the one served by the Apply object bundle's loom"
+    repo <- getE repoID "Apply target: No such local repo in DB"
+    unless (repoLoom repo == Just loomID) $
+        throwE "Apply object bunde's loom doesn't have repo's consent to serve it"
+
+    -- Verify that VCS type matches the presence of a branch:
+    -- Branch specified for Git, isn't specified for Darcs
+    case (repoVcs repo, maybeBranch) of
+        (VCSDarcs, Nothing) -> pure ()
+        (VCSGit, Just _) -> pure ()
+        _ -> throwE "VCS type and branch presence mismatch"
+
+    -- Verify the MR isn't already resolved and the bundle is the
+    -- latest version
+    unless (isNothing maybeResolve) $
+        throwE "MR is already resolved"
+    unless (bundleID == latest) $
+        throwE "Bundle isn't the latest version"
+
+    -- Verify the sender is authorized by the loom to apply a patch
+    capability <-
+        case capID of
+            Left (capActor, _, capItem) -> return (capActor, capItem)
+            Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local loom"
+    verifyCapability capability actor (GrantResourceLoom loomID)
+
+    -- Get the patches from DB, verify VCS match just in case
+    diffs <- do
+        ps <-
+            lift $ map entityVal <$>
+                selectList [PatchBundle ==. bundleID] [Asc PatchId]
+        let patchVCS = patchMediaTypeVCS . patchType
+        case NE.nonEmpty ps of
+            Nothing -> error "Bundle without patches"
+            Just ne ->
+                if all ((== repoVcs repo) . patchVCS) ne
+                    then return $ NE.map patchContent ne
+                    else throwE "Patch type mismatch with repo VCS type"
+
+    return (loom, ticketID, diffs)

src/Vervis/Web/Repo.hs

@@ -16,11 +16,13 @@
 module Vervis.Web.Repo
     ( serveCommit
     , generatePatches
+    , applyPatches
     )
 where
 
 import Control.Monad
 import Control.Monad.Trans.Except
+import Data.List.NonEmpty (NonEmpty (..))
 import Data.Text (Text)
 import Data.Text.Encoding
 import Data.Time.Clock
@@ -47,6 +49,7 @@ import Data.Patch.Local hiding (Patch)
 
 import qualified Data.Patch.Local as P
 
+import Vervis.Darcs
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Git
@@ -138,3 +141,24 @@ generatePatches (clothID, targetRepoID, hasBundle, tipInfo) = unless hasBundle $
     lift $ runSiteDB $ do
         bundleID <- insert $ Bundle clothID True
         insertMany_ $ NE.toList $ NE.map (Patch bundleID now PatchMediaTypeGit) $ NE.reverse patches
+
+applyPatches
+    :: (MonadSite m, SiteEnv m ~ App)
+    => RepoId -> Maybe Text -> NonEmpty Text -> ExceptT Text m ()
+applyPatches repoID maybeBranch diffs = do
+    repoPath <- do
+        repoHash <- encodeKeyHashid repoID
+        repoDir <- askRepoDir repoHash
+        liftIO $ makeAbsolute repoDir
+    case maybeBranch of
+        Just branch -> do
+            ExceptT $ liftIO $ runExceptT $
+                withSystemTempDirectory "vervis-applyPatches" $
+                    applyGitPatches repoPath (T.unpack branch) diffs
+        Nothing -> do
+            patch <-
+                case diffs of
+                    t :| [] -> return t
+                    _ :| (_ : _) ->
+                        throwE "Darcs repo given multiple patch bundles"
+            applyDarcsPatch repoPath patch

vervis.cabal

@@ -210,6 +210,7 @@ library
 
                        Vervis.Persist.Actor
                        Vervis.Persist.Collab
+                       Vervis.Persist.Ticket
 
                        Vervis.Query
                        Vervis.Readme