S2S: repoApplyF, for now only on remotely hosted patches

migrations/2016_08_04.model

@@ -68,7 +68,7 @@ RepoRoleInherit
 
 RepoAccess
     role RepoRoleId
-    op   RepoOperation
+    op   Text
 
     UniqueRepoAccess role op
 

src/Development/PatchMediaType.hs

@@ -36,7 +36,7 @@ data VersionControlSystem = VCSDarcs | VCSGit deriving Eq
 data PatchMediaType = PatchMediaTypeDarcs deriving Eq
 
 forgeFedPrefix :: Text
-forgeFedPrefix = "https://forgefed.peers.community/ns#"
+forgeFedPrefix = "https://forgefed.org/ns#"
 
 parseVersionControlSystemName :: Text -> Maybe VersionControlSystem
 parseVersionControlSystemName = parse . T.toLower

src/Vervis/Access.hs

@@ -101,6 +101,7 @@ roleHasAccess User          op = pure $ userAccess op
     userAccess ProjOpAddTicketDep    = False
     userAccess ProjOpRemoveTicketDep = False
     userAccess ProjOpPush            = False
+    userAccess ProjOpApplyPatch      = False
 roleHasAccess Guest         _  = pure False
 roleHasAccess (RoleID rlid) op =
     fmap isJust . runMaybeT $

src/Vervis/ActivityPub.hs

@@ -53,6 +53,7 @@ module Vervis.ActivityPub
     , verifyContentTypeAP
     , verifyContentTypeAP_E
     , parseActivity
+    , parseActivityURI
     , getActivity
     , ActorEntity (..)
     , getOutboxActorEntity
@@ -1221,22 +1222,33 @@ verifyContentTypeAP_E = do
         "application/ld+json; \
         \profile=\"https://www.w3.org/ns/activitystreams\""
 
-parseActivity u@(ObjURI h lu) = do
+-- | If the given URI is remote, return as is. If the URI is local, verify that
+-- it parses as an activity URI, i.e. an outbox item route, and return the
+-- parsed route.
+parseActivityURI name u@(ObjURI h lu) = do
     hl <- hostIsLocal h
     if hl
         then Left <$> do
-            route <- fromMaybeE (decodeRouteLocal lu) "Object isn't a valid route"
+            route <-
+                fromMaybeE
+                    (decodeRouteLocal lu)
+                    (name <> " is local but isn't a valid route")
             case route of
                 SharerOutboxItemR shr obikhid ->
-                    (LocalActorSharer shr,) <$>
+                    (LocalActorSharer shr,) <$> decodeKH obikhid
-                        decodeKeyHashidE obikhid "No such obikhid"
+                ProjectOutboxItemR shr prj obikhid ->
-                ProjectOutboxItemR shr prj obikhid -> do
+                    (LocalActorProject shr prj,) <$> decodeKH obikhid
-                    (LocalActorProject shr prj,) <$>
+                RepoOutboxItemR shr rp obikhid ->
-                        decodeKeyHashidE obikhid "No such obikhid"
+                    (LocalActorRepo shr rp,) <$> decodeKH obikhid
-                RepoOutboxItemR shr rp obikhid -> do
+                _ ->
-                    (LocalActorRepo shr rp,) <$>
+                    throwE $
-                        decodeKeyHashidE obikhid "No such obikhid"
+                        name <> " is a valid local route, but isn't an outbox \
+                        \item route"
         else return $ Right u
+    where
+    decodeKH obikhid = decodeKeyHashidE obikhid (name <> ": Invalid obikhid")
+
+parseActivity = parseActivityURI "Activity URI"
 
 getActivity (Left (actor, obiid)) = Just . Left <$> do
     obid <- getActorOutbox actor

src/Vervis/Federation.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.
  -
@@ -379,6 +379,8 @@ handleRepoInbox shrRecip rpRecip now auth body = do
     msig <- checkForward $ LocalActorRepo shrRecip rpRecip
     let mfwd = (localRecips,) <$> msig
     case activitySpecific $ actbActivity body of
+        ApplyActivity (AP.Apply uObject uTarget) ->
+            repoApplyF now shrRecip rpRecip remoteAuthor body mfwd luActivity uObject uTarget
         AddActivity (AP.Add obj target) ->
             case obj of
                 Right (AddBundle patches) ->

src/Vervis/Federation/Ticket.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2021, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -25,6 +25,8 @@ module Vervis.Federation.Ticket
     , sharerAddBundleF
     , repoAddBundleF
 
+    , repoApplyF
+
     , sharerOfferDepF
     , projectOfferDepF
     , repoOfferDepF
@@ -35,6 +37,7 @@ module Vervis.Federation.Ticket
     )
 where
 
+import Control.Applicative
 import Control.Exception hiding (Handler)
 import Control.Monad
 import Control.Monad.Logger.CallStack
@@ -58,15 +61,19 @@ import Data.Time.Clock
 import Data.Traversable
 import Database.Persist
 import Database.Persist.Sql
+import System.Exit
+import System.Process.Typed
 import Text.Blaze.Html (preEscapedToHtml)
 import Text.Blaze.Html.Renderer.Text
 import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
 import Yesod.Core.Handler
 import Yesod.Persist.Core
 
+import qualified Data.ByteString.Lazy as BL
 import qualified Data.List.NonEmpty as NE
 import qualified Data.List.Ordered as LO
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
 import qualified Data.Text.Lazy as TL
 
 import Database.Persist.JSON
@@ -84,6 +91,10 @@ import Data.Tuple.Local
 import Database.Persist.Local
 import Yesod.Persist.Local
 
+import qualified Data.Text.UTF8.Local as TU
+
+import Development.PatchMediaType
+
 import Vervis.ActivityPub
 import Vervis.ActivityPub.Recipient
 import Vervis.FedURI
@@ -92,12 +103,37 @@ import Vervis.Federation.Util
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
-import Development.PatchMediaType
+import Vervis.Model.Role
 import Vervis.Model.Ticket
 import Vervis.Patch
+import Vervis.Path
+import Vervis.Query
 import Vervis.Ticket
 import Vervis.WorkItem
 
+checkBranch
+    :: Host
+    -> LocalURI
+    -> ExceptT Text Handler (Either (ShrIdent, RpIdent, Maybe Text) FedURI)
+checkBranch h lu = do
+    hl <- hostIsLocal h
+    if hl
+        then Left <$> do
+            route <-
+                fromMaybeE
+                    (decodeRouteLocal lu)
+                    "MR 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
+                        "MR target is a valid local route, but isn't a repo \
+                        \or branch route"
+        else return $ Right $ ObjURI h lu
+
+checkBranch' (ObjURI h lu) = checkBranch h lu
+
 checkOfferTicket
     :: RemoteAuthor
     -> AP.Ticket URIMode
@@ -163,22 +199,6 @@ checkOfferTicket author ticket uTarget = do
                 _ -> return ()
             return (branch, typ, diffs)
             where
-            checkBranch h lu = do
-                hl <- hostIsLocal h
-                if hl
-                    then Left <$> do
-                        route <-
-                            fromMaybeE
-                                (decodeRouteLocal lu)
-                                "MR 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
-                                    "MR target is a valid local route, but isn't a \
-                                    \repo or branch route"
-                    else return $ Right $ ObjURI h lu
             checkBundle _ (AP.BundleHosted _ _) =
                 throwE "Patches specified as URIs"
             checkBundle h (AP.BundleOffer mlocal patches) = do
@@ -626,27 +646,6 @@ checkCreateTicket author ticket muTarget = do
                 _ -> return ()
             return (branch, typ, patches)
             where
-            checkBranch
-                :: Host
-                -> LocalURI
-                -> ExceptT Text Handler
-                    (Either (ShrIdent, RpIdent, Maybe Text) FedURI)
-            checkBranch h lu = do
-                hl <- hostIsLocal h
-                if hl
-                    then Left <$> do
-                        route <-
-                            fromMaybeE
-                                (decodeRouteLocal lu)
-                                "MR 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
-                                    "MR target is a valid local route, but isn't a \
-                                    \repo or branch route"
-                    else return $ Right $ ObjURI h lu
             checkBundle _ (AP.BundleHosted _ _) =
                 throwE "Patches specified as URIs"
             checkBundle h (AP.BundleOffer mblocal patches) = do
@@ -1427,6 +1426,325 @@ repoAddBundleF now shrRecip rpRecip author body mfwd luAdd patches uTarget = do
                     LocalPersonCollectionRepoProposalFollowers
                         shrRecip rpRecip (hashLTID ltid)
 
+repoApplyF
+    :: UTCTime
+    -> ShrIdent
+    -> RpIdent
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (LocalRecipientSet, ByteString)
+    -> LocalURI
+    -> FedURI
+    -> FedURI
+    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
+repoApplyF now shrRecip rpRecip author body mfwd luApply uObject uTarget = do
+    -- Verify the patch bundle URI is one of:
+    --   * A local sharer-hosted bundle
+    --   * A local repo-hosted bundle under the receiving repo
+    --   * A remote URI
+    bundle <- do
+        b <- parseProposalBundle "repoApplyF Apply object, a URI" uObject
+        case b of
+            Left (Right (shr, rp, ltid, bnid)) ->
+                if shr == shrRecip && rp == rpRecip
+                    then return $ Left $ Right (ltid, bnid)
+                    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
+        let muCap = activityCapability $ actbActivity body
+        uCap <- fromMaybeE muCap "Asking to apply patch but no capability provided"
+        parseActivityURI "Apply capability" uCap
+
+    -- Make sure receiving repo exists in DB, otherwise its inbox doesn't exist
+    -- 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
+        case bundle of
+            Left (Left (shr, talid, bnid)) ->
+                error "Applying local bundle not supported yet"
+
+
+
+
+            Left (Right (ltid, bnid)) ->
+                error "Applying local bundle not supported yet"
+
+
+
+
+
+            Right uBundle@(ObjURI hBundle luBundle) -> do
+
+                -- Verify it's a latest-version bundle pointed by a ticket we
+                -- have listed under the receiving repo
+                manager <- asksSite appHttpManager
+                Doc h b <- withExceptT T.pack $ AP.fetchAP manager $ Left uBundle
+                (BundleLocal bid ctx _prevs mcurr, lus) <-
+                    case b of
+                        BundleHosted Nothing _ -> throwE "No bundle @id"
+                        BundleHosted (Just l) ps -> return (l, ps)
+                        BundleOffer _ _ -> throwE "Why does bundle contain patch objects"
+                unless (h == hBundle && bid == luBundle) $
+                    throwE "Bundle 'id' differs from the URI we fetched"
+                for_ mcurr $ \ curr ->
+                    throwE $
+                        if curr == bid
+                            then "Bundle currentVersion points to itself"
+                            else "Bundle isn't the latest version"
+                let uTicket = ObjURI h ctx
+                Doc _ ticket <- withExceptT T.pack $ AP.fetchAP manager $ Left uTicket
+                (_, tlocal) <- fromMaybeE (AP.ticketLocal ticket) "Ticket has no @id"
+                (h', mr) <- fromMaybeE (AP.ticketAttachment ticket) "Ticket has no 'attachment'"
+                unless (ObjURI h' (mrTarget mr) == uTarget) $
+                    throwE "Ticket MR target isn't me / branch"
+                case mrBundle mr of
+                    Left u ->
+                        if u == uBundle
+                            then pure ()
+                            else throwE "Bundle isn't the one pointed by ticket"
+                    Right _ -> throwE "Ticket has bundle object instead of just URI"
+                e <- runSiteDBExcept $ getRemoteTicketByURI uTicket
+                case e of
+                    Right (_, _, _, _, _, Right (Entity _ trl))
+                        | ticketRepoLocalRepo trl == ridRecip -> pure ()
+                    _ -> throwE "I don't have the ticket listed under me"
+
+                -- Check in DB whether the provided capability matches a DB
+                -- record we have, and that it includes permission to apply MRs
+                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) <-
+                        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 -> error "Patching a Git repo unsupported yet"
+                    VCSDarcs -> do
+                        patch <-
+                            case patches of
+                                _ :| (_ : _) -> throwE "Darcs repo given multiple patch bundles"
+                                (PatchMediaTypeDarcs, t) :| [] -> return t
+                        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 ()
+
+                -- 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) <-
+                            insertAccept 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 there are 3 options for the bundle referred by uObject:
+         1: It's under a remote Ticket
+         2: It's under a sharer-hosted local Ticket
+         3: It's under a repo-hosted local Ticket
+         And here's what to do in each case:
+         1: HTTP GET the bundle to check to which Ticket it belongs, then see
+            if this our repo has such a remotely-hosted Ticket
+         2: Find this Bundle in DB, make sure indeed belongs to specified
+            sharer, and if so, does our repo have this Ticket listed?
+         3: Does this repo-hosted ticket belong to our repo? Make sure in the
+            route and in the DB
+
+    TODO if I'm the target, am I a darcs repo?
+
+    TODO if a branch of mine is the target, am I a git repo?
+
+    TODO do I have this bundle registered under a proposal I know?
+
+    TODO is this bundle the latest version in that proposal?
+    -}
+
+    where
+
+    insertAccept luApply hTicket tlocal obiidAccept = do
+        encodeRouteLocal <- getEncodeRouteLocal
+        encodeRouteHome <- getEncodeRouteHome
+        hLocal <- asksSite siteInstanceHost
+        obikhidAccept <- encodeKeyHashid obiidAccept
+        ra <- getJust $ remoteAuthorId author
+        let ObjURI hAuthor luAuthor = remoteAuthorURI author
+
+            audAuthor =
+                AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
+
+            audTicket =
+                AudRemote hTicket [] [AP.ticketParticipants tlocal]
+
+            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

src/Vervis/Model/Role.hs

@@ -33,6 +33,7 @@ data ProjectOperation
     | ProjOpAddTicketDep
     | ProjOpRemoveTicketDep
     | ProjOpPush
+    | ProjOpApplyPatch
     deriving (Eq, Show, Read, Enum, Bounded)
 
 derivePersistField "ProjectOperation"

src/Vervis/Ticket.hs

@@ -42,6 +42,8 @@ module Vervis.Ticket
     , askWorkItemRoute
     , getWorkItem
     , parseWorkItem
+    , parseProposalBundle
+    , getRemoteTicketByURI
 
     , checkDepAndTarget
     )
@@ -888,6 +890,71 @@ parseWorkItem name u@(ObjURI h lu) = do
                 _ -> throwE $ name <> ": not a work item route"
         else return $ Right u
 
+parseProposalBundle name u@(ObjURI h lu) = do
+    hl <- hostIsLocal h
+    if hl
+        then Left <$> do
+            route <-
+                fromMaybeE (decodeRouteLocal lu) $
+                    name <> ": Not a valid route"
+            case route of
+                SharerProposalBundleR shr talkhid bnkhid-> do
+                    talid <- decodeKeyHashidE talkhid $ name <> ": Invalid talkhid"
+                    bnid <- decodeKeyHashidE bnkhid $ name <> ": Invalid bnkhid"
+                    return $ Left (shr, talid, bnid)
+                RepoProposalBundleR shr rp ltkhid bnkhid -> do
+                    ltid <- decodeKeyHashidE ltkhid $ name <> ": Invalid ltkhid"
+                    bnid <- decodeKeyHashidE bnkhid $ name <> ": Invalid bnkhid"
+                    return $ Right (shr, rp, ltid, bnid)
+                _ -> throwE $ name <> ": not a bundle route"
+        else return $ Right u
+
+getRemoteTicketByURI
+    :: MonadIO m
+    => ObjURI URIMode
+    -> ExceptT Text (ReaderT SqlBackend m)
+        (Either
+            Text
+            ( Entity Instance
+            , Entity RemoteObject
+            , Entity RemoteTicket
+            , Entity TicketAuthorRemote
+            , Entity TicketContextLocal
+            , Either (Entity TicketProjectLocal) (Entity TicketRepoLocal)
+            )
+        )
+getRemoteTicketByURI (ObjURI h lu) = adapt $ do
+    ei@(Entity iid _) <- do
+        mei <- lift $ getBy $ UniqueInstance h
+        fromMaybeE mei $ Right "Instance not known"
+    ero@(Entity roid _) <- do
+        mero <- lift $ getBy $ UniqueRemoteObject iid lu
+        fromMaybeE mero $ Right "Remote object not known"
+    ert@(Entity _ rt) <- do
+        mert <- lift $ getBy $ UniqueRemoteTicketIdent roid
+        fromMaybeE mert $ Right "Not a known RemoteTicket"
+    etar@(Entity _ tar) <- do
+        metar <- lift $ getEntity $ remoteTicketTicket rt
+        fromMaybeE metar $ Left "RT's TAR not found in DB"
+    etcl@(Entity tclid _) <- do
+        metcl <- lift $ getEntity $ ticketAuthorRemoteTicket tar
+        fromMaybeE metcl $ Left "TAR's TCL not found in DB"
+    ctx <- do
+        metjl <- lift $ getBy $ UniqueTicketProjectLocal tclid
+        metrl <- lift $ getBy $ UniqueTicketRepoLocal tclid
+        case (metjl, metrl) of
+            (Nothing, Nothing) -> throwE $ Left "TCL has neither TJL nor TRL"
+            (Just j, Nothing) -> return $ Left j
+            (Nothing, Just r) -> return $ Right r
+            (Just _, Just _) -> throwE $ Left "TCL has both TJL and TRL"
+    return (ei, ero, ert, etar, etcl, ctx)
+    where
+    adapt m = ExceptT $ adapt' <$> runExceptT m
+        where
+        adapt' (Left (Left e)) = Left e
+        adapt' (Left (Right e)) = Right $ Left e
+        adapt' (Right x) = Right $ Right x
+
 checkDepAndTarget
     :: (MonadSite m, SiteEnv m ~ App)
     => TicketDependency URIMode

src/Web/ActivityPub.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020, 2021 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2021, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -62,6 +62,7 @@ module Web.ActivityPub
     , Accept (..)
     , AddObject (..)
     , Add (..)
+    , Apply (..)
     , CreateObject (..)
     , Create (..)
     , Follow (..)
@@ -163,10 +164,10 @@ as2Context :: Text
 as2Context = "https://www.w3.org/ns/activitystreams"
 
 secContext :: Text
-secContext = "https://w3id.org/security/v1"
+secContext = "https://w3id.org/security/v2"
 
 forgeContext :: Text
-forgeContext = "https://forgefed.peers.community/ns"
+forgeContext = "https://forgefed.org/ns"
 
 extContext :: Text
 extContext = "https://angeley.es/as2-ext"
@@ -1334,6 +1335,22 @@ encodeAdd h (Add obj target)
         Right o -> "object" `pair` pairs (toSeries h o)
     <> "target" .= target
 
+data Apply u = Apply
+    { applyObject :: ObjURI u
+    , applyTarget :: ObjURI u
+    }
+
+parseApply :: UriMode u => Object -> Parser (Apply u)
+parseApply o =
+    Apply
+        <$> o .: "object"
+        <*> o .: "target"
+
+encodeApply :: UriMode u => Apply u -> Series
+encodeApply (Apply obj target)
+    =  "object" .= obj
+    <> "target" .= target
+
 data CreateObject u = CreateNote (Note u) | CreateTicket (Ticket u)
 
 instance ActivityPub CreateObject where
@@ -1490,6 +1507,7 @@ encodeUndo a (Undo obj) = "object" .= obj
 data SpecificActivity u
     = AcceptActivity  (Accept u)
     | AddActivity     (Add u)
+    | ApplyActivity   (Apply u)
     | CreateActivity  (Create u)
     | FollowActivity  (Follow u)
     | OfferActivity   (Offer u)
@@ -1523,6 +1541,7 @@ instance ActivityPub Activity where
                     case typ of
                         "Accept"  -> AcceptActivity  <$> parseAccept a o
                         "Add"     -> AddActivity     <$> parseAdd o a
+                        "Apply"   -> ApplyActivity   <$> parseApply o
                         "Create"  -> CreateActivity  <$> parseCreate o a actor
                         "Follow"  -> FollowActivity  <$> parseFollow o
                         "Offer"   -> OfferActivity   <$> parseOffer o a actor
@@ -1545,6 +1564,7 @@ instance ActivityPub Activity where
         activityType :: SpecificActivity u -> Text
         activityType (AcceptActivity _)  = "Accept"
         activityType (AddActivity _)     = "Add"
+        activityType (ApplyActivity _)   = "Apply"
         activityType (CreateActivity _)  = "Create"
         activityType (FollowActivity _)  = "Follow"
         activityType (OfferActivity _)   = "Offer"
@@ -1554,6 +1574,7 @@ instance ActivityPub Activity where
         activityType (UndoActivity _)    = "Undo"
         encodeSpecific h _ (AcceptActivity a)  = encodeAccept h a
         encodeSpecific h _ (AddActivity a)     = encodeAdd h a
+        encodeSpecific _ _ (ApplyActivity a)   = encodeApply a
         encodeSpecific h u (CreateActivity a)  = encodeCreate h u a
         encodeSpecific _ _ (FollowActivity a)  = encodeFollow a
         encodeSpecific h u (OfferActivity a)   = encodeOffer h u a

stack.yaml

@@ -12,7 +12,7 @@ packages:
 # Packages to be pulled from upstream that are not in the resolver (e.g.,
 # acme-missiles-0.3)
 extra-deps:
-  - git: https://dev.angeley.es/s/fr33domlover/r/yesod-auth-account
+  - git: https://dev.openheart.work/s/fr33domlover/r/yesod-auth-account
     commit: 2d19eea0fae58897a02372a84cc48e7696a4e288
   - ./lib/darcs-lights
   - ./lib/darcs-rev

vervis.cabal

@@ -8,8 +8,8 @@ description:
   Most of the source code is in the public domain using the CC0 public domain
   dedication, but the application as a whole has GPL dependencies, and is
   released under the AGPL 3 license.
-homepage:            https://dev.angeley.es/s/fr33domlover/p/vervis
+homepage:            https://dev.openheart.work/s/fr33domlover/p/vervis
-bug-reports:         https://dev.angeley.es/s/fr33domlover/p/vervis/t
+bug-reports:         https://dev.openheart.work/s/fr33domlover/p/vervis/t
 license:             OtherLicense
 license-file:        COPYING
 author:              fr33domlover
@@ -27,7 +27,7 @@ cabal-version:       >=1.10
 
 source-repository head
   type:                darcs
-  location:            https://dev.angeley.es/s/fr33domlover/r/vervis
+  location:            https://dev.openheart.work/s/fr33domlover/r/vervis
 
 flag dev
   description: Turn on development settings, like auto-reload templates.
@@ -363,6 +363,7 @@ library
                      , transformers
                        -- probably should be replaced with lenses once I learn
                      , tuple
+                     , typed-process
                        -- For making git hooks executable, i.e. set file mode
                      , unix
                        -- For httpAPEither