C2S: Implement applyC, works only for Darcs right now

src/Vervis/API.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -15,6 +15,7 @@
 
 module Vervis.API
     ( addBundleC
+    , applyC
     , noteC
     , createNoteC
     , createTicketC
@@ -108,15 +109,18 @@ import Yesod.Persist.Local
 import Vervis.ActivityPub
 import Vervis.ActivityPub.Recipient
 import Vervis.ActorKey
+import Vervis.Darcs
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
+import Vervis.Model.Role
 import Development.PatchMediaType
 import Vervis.Model.Ticket
 import Vervis.RemoteActorStore
 import Vervis.Settings
 import Vervis.Patch
+import Vervis.Query
 import Vervis.Ticket
 import Vervis.WorkItem
 
@@ -323,6 +327,416 @@ addBundleC (Entity pidUser personUser) sharerUser summary audience patches uTarg
                     Right (shr, rp, ltid) ->
                         RepoProposalBundleR shr rp $ hashLTID ltid
 
+applyC
+    :: Entity Person
+    -> Sharer
+    -> Maybe TextHtml
+    -> Audience URIMode
+    -> Maybe (ObjURI URIMode)
+    -> Apply URIMode
+    -> ExceptT Text Handler OutboxItemId
+applyC (Entity pidUser personUser) sharerUser summary audience muCap (Apply uObject uTarget) = do
+    -- Verify the patch bundle URI is one of:
+    --   * A local sharer-hosted bundle
+    --   * A local repo-hosted bundle
+    --   * A remote URI
+    bundle <- parseProposalBundle "Apply object" uObject
+
+    -- Identify local & remote recipients
+    -- Produce recipient list for public use, i.e. with BTO and BCC hidden
+    -- Produce list of hosts whom to authorize to inbox-forward our activity
+    ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
+        mrecips <- parseAudience audience
+        fromMaybeE mrecips "Apply with no recipients"
+
+    -- If remote recipients are specified, make sure federation is enabled
+    federation <- asksSite $ appFederation . appSettings
+    unless (federation || null remoteRecips) $
+        throwE "Federation disabled, but remote recipients specified"
+
+    -- Verify the apply's target is one of:
+    --   * A local repo
+    --   * A local repo's branch
+    --   * A remote URI
+    target <- checkBranch uTarget
+
+    -- 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 <- fromMaybeE muCap "Asking to apply patch but no capability provided"
+        parseActivityURI "Apply capability" uCap
+
+    -- If target is remote, just proceed to send out the Apply activity
+    -- If target is a local repo/branch, consider to apply the patch(es)
+    mapplied <- case target of
+        Right _u -> return Nothing
+
+        Left (shrTarget, rpTarget, mb) -> Just <$> do
+
+            -- Find the target repo in DB
+            mrepo <- lift $ runDB $ runMaybeT $ do
+                sid <- MaybeT $ getKeyBy $ UniqueSharer shrTarget
+                MaybeT $ getBy $ UniqueRepo rpTarget sid
+            Entity ridTarget repoTarget <- fromMaybeE mrepo "Apply target: No such local repo in DB"
+
+            -- Verify the repo is among the activity recipients
+            let repoRecipFound = do
+                    sharerSet <- lookup shrTarget localRecips
+                    repoSet <- lookup rpTarget $ localRecipRepoRelated sharerSet
+                    guard $ localRecipRepo $ localRecipRepoDirect repoSet
+            fromMaybeE repoRecipFound "Target local repo isn't listed as a recipient"
+
+            -- Check in DB whether the provided capability matches a DB
+            -- record we have, and that it gives the Apply author permission to
+            -- apply patches to the target repo
+            runDBExcept $ verifyCapability ridTarget capID
+
+            -- Grab the bundle and its patches from DB or HTTP
+            -- Make sure the ticket it's attached to is listed under the repo
+            -- Make sure ticket isn't marked as resolved
+            -- Make sure the bundle is the latest version
+            (patches, mltid, ticketFollowers) <-
+                case bundle of
+                    Left (Left (shr, talid, bnid)) -> do
+
+                        mticket <- lift $ runDB $ 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 == ridTarget) $
+                                    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"
+
+                        let grabContent (Entity _ (Patch _ _ typ content)) =
+                                (typ, content)
+                        ps <- lift $ runDB $ selectList [PatchBundle ==. bnid] [Asc PatchId]
+                        case ps of
+                            [] -> error "Local sharer-bundle without any patches found"
+                            p : l -> return (NE.map grabContent $ p :| l, Just ltid, Left $ Left (shr, talid))
+
+                    Left (Right (shr, rp, ltid, bnid)) -> do
+
+                        unless (shr == shrTarget && rp == rpTarget) $
+                            throwE "Bundle's repo mismatches Apply target"
+
+                        mticket <- lift $ runDB $ getRepoProposal shrTarget rpTarget 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"
+
+                        let grabContent (Entity _ (Patch _ _ typ content)) =
+                                (typ, content)
+                        ps <- lift $ runDB $ selectList [PatchBundle ==. bnid] [Asc PatchId]
+                        case ps of
+                            [] -> error "Local repo-bundle without any patches found"
+                            p : l -> return (NE.map grabContent $ p :| l, Just ltid, Left $ Right ltid)
+
+                    Right uBundle@(ObjURI hBundle luBundle) -> do
+
+                        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"
+
+                        verifyNothingE (AP.ticketResolved ticket) "Apply object: Ticket already marked as resolved"
+
+                        e <- runDBExcept $ getRemoteTicketByURI uTicket
+                        case e of
+                            Right (_, _, _, _, _, Right (Entity _ trl))
+                                | ticketRepoLocalRepo trl == ridTarget -> pure ()
+                            _ -> throwE "Target repo doesn't have the ticket listed under it"
+
+                        let followers =
+                                ObjURI hBundle $ AP.ticketParticipants tlocal
+                        fmap (,Nothing,Right followers) $ 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 repoTarget) $
+                                throwE "Patch type and repo VCS mismatch"
+                            return (typ, content)
+
+            -- Apply patches
+            case repoVcs repoTarget of
+                VCSGit -> error "Patching a Git repo unsupported yet"
+                VCSDarcs -> do
+                    patch <-
+                        case patches of
+                            _ :| (_ : _) -> throwE "Darcs repo given multiple patch bundles"
+                            (PatchMediaTypeDarcs, t) :| [] -> return t
+                    applyDarcsPatch shrTarget rpTarget patch
+
+            return (shrTarget, rpTarget, repoTarget, mltid, ticketFollowers)
+
+    -- Insert Apply to outbox and deliver to local recipients via DB
+    -- If we applied patches to a local repo, produce Accept and deliver via DB
+    (obiid, doc, remotesHttp, maybeAccept) <- runDBExcept $ do
+        (obiidApply, docApply, luApply) <- lift $ insertApplyToOutbox (personOutbox personUser) blinded
+        remotesHttpApply <- do
+            encodeLTID <- getEncodeKeyHashid
+            encodeTALID <- getEncodeKeyHashid
+            let shrUser = sharerIdent sharerUser
+                sieve =
+                    let ticketC =
+                            case bundle of
+                                Left (Left (shr, talid, _)) ->
+                                    [LocalPersonCollectionSharerProposalFollowers shr $ encodeTALID talid]
+                                Left (Right (shr, rp, ltid, _)) ->
+                                    [LocalPersonCollectionRepoProposalFollowers shr rp $ encodeLTID ltid]
+                                Right _u ->
+                                    []
+                        (repoA, repoC) =
+                            case target of
+                                Left (shr, rp, _) ->
+                                    ( [LocalActorRepo shr rp]
+                                    , [ LocalPersonCollectionRepoTeam shr rp
+                                      , LocalPersonCollectionRepoFollowers shr rp
+                                      ]
+                                    )
+                                Right _u ->
+                                    ([], [])
+                        actors = repoA
+                        collections = ticketC ++ repoC
+                    in  makeRecipientSet
+                            actors
+                            (LocalPersonCollectionSharerFollowers shrUser :
+                             collections
+                            )
+            moreRemoteRecips <-
+                lift $
+                    deliverLocal'
+                        True
+                        (LocalActorSharer shrUser)
+                        (personInbox personUser)
+                        obiidApply
+                        (localRecipSieve sieve False localRecips)
+            unless (federation || null moreRemoteRecips) $
+                throwE "Federation disabled, but recipient collection remote members found"
+            lift $ deliverRemoteDB'' fwdHosts obiidApply remoteRecips moreRemoteRecips
+
+        maccept <- lift $ for mapplied $ \ (shr, rp, repo, mltid, ticketFollowers) -> do
+            now <- liftIO getCurrentTime
+            obiidAccept <- insertEmptyOutboxItem (repoOutbox repo) now
+            for_ mltid $ \ ltid -> insertResolve ltid obiidApply obiidAccept
+            (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
+                insertAccept shr rp ticketFollowers obiidApply obiidAccept
+            knownRemoteRecipsAccept <-
+                deliverLocal'
+                    False
+                    (LocalActorRepo shr rp)
+                    (repoInbox repo)
+                    obiidAccept
+                    localRecipsAccept
+            (obiidAccept,docAccept,fwdHostsAccept,) <$>
+                deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
+
+        return (obiidApply, docApply, remotesHttpApply, maccept)
+
+    -- Deliver Apply and Accept to remote recipients via HTTP
+    lift $ do
+        forkWorker "applyC: async HTTP Apply delivery" $ deliverRemoteHttp' fwdHosts obiid doc remotesHttp
+        for_ maybeAccept $ \ (obiidAccept, docAccept, fwdHostsAccept, remotesHttpAccept) ->
+            forkWorker "applyC: async HTTP Accept delivery" $ deliverRemoteHttp' fwdHostsAccept obiidAccept docAccept remotesHttpAccept
+    return obiid
+    where
+    checkBranch u@(ObjURI h lu) = do
+        hl <- hostIsLocal h
+        if hl
+            then Left <$> do
+                route <-
+                    fromMaybeE
+                        (decodeRouteLocal lu)
+                        "Apply target is local but isn't a valid route"
+                case route of
+                    RepoR shr rp -> return (shr, rp, Nothing)
+                    RepoBranchR shr rp b -> return (shr, rp, Just b)
+                    _ ->
+                        throwE
+                            "Apply target is a valid local route, but isn't a \
+                            \repo or branch route"
+            else return $ Right u
+
+    verifyCapability ridTarget capID = 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
+        pidCollab <- do
+            mcrl <- lift $ getValBy $ UniqueCollabRecipLocal cid
+            crl <- fromMaybeE mcrl "No local recip for capability"
+            mcrr <- lift $ getBy $ UniqueCollabRecipRemote cid
+            verifyNothingE mcrr "Both local & remote recip for capability!"
+            return $ collabRecipLocalPerson crl
+        -- Verify the recipient is the author of the Apply activity
+        unless (pidCollab == pidUser) $
+            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 == ridTarget) $
+            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"
+
+    insertApplyToOutbox obid blinded = do
+        let shrUser = sharerIdent sharerUser
+        now <- liftIO getCurrentTime
+        hLocal <- asksSite siteInstanceHost
+        obiid <- insertEmptyOutboxItem obid now
+        encodeRouteLocal <- getEncodeRouteLocal
+        obikhid <- encodeKeyHashid obiid
+        let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
+            doc = Doc hLocal Activity
+                { activityId         = Just luAct
+                , activityActor      = encodeRouteLocal $ SharerR shrUser
+                , activityCapability = muCap
+                , activitySummary    = summary
+                , activityAudience   = blinded
+                , activitySpecific   = ApplyActivity $ Apply uObject uTarget
+                }
+        update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+        return (obiid, doc, luAct)
+
+    insertResolve ltid obiidApply obiidAccept = do
+        trid <- insert TicketResolve
+            { ticketResolveTicket = ltid
+            , ticketResolveAccept = obiidAccept
+            }
+        insert_ TicketResolveLocal
+            { ticketResolveLocalTicket   = trid
+            , ticketResolveLocalActivity = obiidApply
+            }
+        tid <- localTicketTicket <$> getJust ltid
+        update tid [TicketStatus =. TSClosed]
+
+    insertAccept shrTarget rpTarget ticketFollowers obiidApply obiidAccept = do
+        encodeRouteLocal <- getEncodeRouteLocal
+        encodeRouteHome <- getEncodeRouteHome
+        encodeTALID <- getEncodeKeyHashid
+        encodeLTID <- getEncodeKeyHashid
+        hLocal <- asksSite siteInstanceHost
+
+        obikhidApply <- encodeKeyHashid obiidApply
+        obikhidAccept <- encodeKeyHashid obiidAccept
+
+        let shrUser = sharerIdent sharerUser
+            audAuthor =
+                AudLocal
+                    [LocalActorSharer shrUser]
+                    [LocalPersonCollectionSharerFollowers shrUser]
+            audTicket =
+                case ticketFollowers of
+                    Left (Left (shr, talid)) -> AudLocal [] [LocalPersonCollectionSharerProposalFollowers shr $ encodeTALID talid]
+                    Left (Right ltid) -> AudLocal [] [LocalPersonCollectionRepoProposalFollowers shrTarget rpTarget $ encodeLTID ltid]
+                    Right (ObjURI h lu) -> AudRemote h [] [lu]
+            audRepo =
+                AudLocal
+                    []
+                    [ LocalPersonCollectionRepoTeam shrTarget rpTarget
+                    , LocalPersonCollectionRepoFollowers shrTarget rpTarget
+                    ]
+
+            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience [audAuthor, audTicket, audRepo]
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            doc = Doc hLocal Activity
+                { activityId         =
+                    Just $ encodeRouteLocal $
+                        RepoOutboxItemR shrTarget rpTarget obikhidAccept
+                , activityActor      =
+                    encodeRouteLocal $ RepoR shrTarget rpTarget
+                , activityCapability = Nothing
+                , activitySummary    = Nothing
+                , activityAudience   = Audience recips [] [] [] [] []
+                , activitySpecific   = AcceptActivity Accept
+                    { acceptObject   =
+                        encodeRouteHome $
+                            SharerOutboxItemR shrUser obikhidApply
+                    , acceptResult   = Nothing
+                    }
+                }
+
+        update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+        return (doc, recipientSet, remoteActors, fwdHosts)
+
 parseComment :: LocalURI -> ExceptT Text Handler (ShrIdent, LocalMessageId)
 parseComment luParent = do
     route <- case decodeRouteLocal luParent of

src/Vervis/Darcs.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2020, 2022
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -20,6 +21,7 @@ module Vervis.Darcs
     , lastChange
     , readPatch
     , writePostApplyHooks
+    , applyDarcsPatch
     )
 where
 
@@ -28,7 +30,7 @@ import Prelude hiding (lookup)
 import Control.Applicative ((<|>))
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT)
+import Control.Monad.Trans.Except
 import Darcs.Util.Path
 import Darcs.Util.Tree
 import Darcs.Util.Tree.Hashed
@@ -49,16 +51,19 @@ import Development.Darcs.Internal.Inventory.Parser
 import Development.Darcs.Internal.Inventory.Read
 import Development.Darcs.Internal.Inventory.Types
 import Development.Darcs.Internal.Patch.Types
+import System.Exit
 import System.FilePath ((</>))
+import System.Process.Typed
 import Text.Email.Validate (emailAddress)
 
 import qualified Data.Attoparsec.Text as A
 import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as BL (ByteString)
+import qualified Data.ByteString.Lazy as BL
 import qualified Data.ByteString.Base16 as B16 (encode, decode)
 import qualified Data.Foldable as F (find)
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
 import qualified Data.Vector as V (empty)
 import qualified Database.Esqueleto as E
 
@@ -78,6 +83,7 @@ import Data.Text.UTF8.Local (decodeStrict)
 import Data.Time.Clock.Local ()
 
 import qualified Data.Patch.Local as DP
+import qualified Data.Text.UTF8.Local as TU
 
 import Vervis.Changes
 import Vervis.Foundation
@@ -390,3 +396,21 @@ writePostApplyHooks = do
         path <- askRepoDir shr rp
         liftIO $
             writeDefaultsFile path hook authority (shr2text shr) (rp2text rp)
+
+applyDarcsPatch shr rp patch = do
+    path <- askRepoDir shr rp
+    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 ()

src/Vervis/Federation/Ticket.hs

@@ -97,6 +97,7 @@ import Development.PatchMediaType
 
 import Vervis.ActivityPub
 import Vervis.ActivityPub.Recipient
+import Vervis.Darcs
 import Vervis.FedURI
 import Vervis.Federation.Auth
 import Vervis.Federation.Util
@@ -1567,7 +1568,7 @@ repoApplyF now shrRecip rpRecip author body mfwd luApply uObject uTarget = do
                                 [] -> error "Local repo-bundle without any patches found"
                                 _ : (_ : _) -> throwE "Darcs repo given multiple patch bundles"
                                 (Entity _ (Patch _ _ PatchMediaTypeDarcs t)) : [] -> return t
-                        applyDarcsPatch patch
+                        applyDarcsPatch shrRecip rpRecip patch
 
                 -- Insert Apply activity to repo's inbox
                 -- Produce an Accept activity and deliver locally
@@ -1641,7 +1642,7 @@ repoApplyF now shrRecip rpRecip author body mfwd luApply uObject uTarget = do
                                 [] -> error "Local repo-bundle without any patches found"
                                 _ : (_ : _) -> throwE "Darcs repo given multiple patch bundles"
                                 (Entity _ (Patch _ _ PatchMediaTypeDarcs t)) : [] -> return t
-                        applyDarcsPatch patch
+                        applyDarcsPatch shrRecip rpRecip patch
 
                 -- Insert Apply activity to repo's inbox
                 -- Produce an Accept activity and deliver locally
@@ -1751,7 +1752,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
-                        applyDarcsPatch patch
+                        applyDarcsPatch shrRecip rpRecip patch
 
                 -- Insert Apply activity to repo's inbox
                 -- Produce an Accept activity and deliver locally
@@ -1817,24 +1818,6 @@ 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 ()
-
     insertAcceptRemote luApply hTicket tlocal obiidAccept = do
         encodeRouteLocal <- getEncodeRouteLocal
         encodeRouteHome <- getEncodeRouteHome

src/Vervis/Handler/Client.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2020, 2022
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -370,7 +371,7 @@ postSharerOutboxR shr = do
             obikhid <- encodeKeyHashid obiid
             sendResponseCreated $ SharerOutboxItemR shr obikhid
     where
-    handle eperson sharer (Activity _mid actor _mcap summary audience specific) = do
+    handle eperson sharer (Activity _mid actor mcap summary audience specific) = do
         case decodeRouteLocal actor of
             Just (SharerR shr') | shr' == shr -> return ()
             _ -> throwE "Can't post activity sttributed to someone else"
@@ -380,6 +381,8 @@ postSharerOutboxR shr = do
                     Right (AddBundle patches) ->
                         addBundleC eperson sharer summary audience patches target
                     _ -> throwE "Unsupported Add 'object' type"
+            ApplyActivity apply ->
+                applyC eperson sharer summary audience mcap apply
             CreateActivity (Create obj mtarget) ->
                 case obj of
                     CreateNote note ->