Link C2S handler with ClientMsg Person actor handler & port inviteC

src/Control/Concurrent/Actor.hs

@@ -17,6 +17,7 @@ module Control.Concurrent.Actor
     ( Stage (..)
     , TheaterFor ()
     , ActFor ()
+    , runActor
     , MonadActor (..)
     , asksEnv
     , Next ()

src/Vervis/API.hs

@@ -17,7 +17,8 @@
 {-# LANGUAGE DeriveGeneric #-}
 
 module Vervis.API
-    ( acceptC
+    ( handleViaActor
+    , acceptC
     --, addBundleC
     , applyC
     --, noteC
@@ -26,7 +27,6 @@ module Vervis.API
     , createRepositoryC
     , createTicketTrackerC
     , followC
-    , inviteC
     , offerTicketC
     --, offerDepC
     , resolveC
@@ -74,9 +74,11 @@ import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
 import qualified Data.Text.Lazy as TL
 
+import Control.Concurrent.Actor
 import Database.Persist.JSON
 import Development.PatchMediaType
 import Network.FedURI
+import Text.Read (readMaybe)
 import Web.ActivityPub hiding (Patch (..), Ticket, Follow, Repo (..), ActorLocal (..), ActorDetail (..), Actor (..))
 import Web.Text
 import Yesod.ActivityPub
@@ -95,8 +97,8 @@ import qualified Data.Git.Local as G (createRepo)
 import qualified Data.Text.UTF8.Local as TU
 import qualified Darcs.Local.Repository as D (createRepo)
 
-import Vervis.Access
 import Vervis.ActivityPub
+import Vervis.Actor hiding (hashLocalActor)
 import Vervis.Cloth
 import Vervis.Darcs
 import Vervis.Data.Actor
@@ -127,6 +129,33 @@ import Vervis.Ticket
 import Vervis.Web.Delivery
 import Vervis.Web.Repo
 
+handleViaActor
+    :: PersonId
+    -> Maybe
+        (Either
+            (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
+            FedURI
+        )
+    -> RecipientRoutes
+    -> [(Host, NonEmpty LocalURI)]
+    -> [Host]
+    -> AP.Action URIMode
+    -> ExceptT Text Handler OutboxItemId
+handleViaActor personID maybeCap localRecips remoteRecips fwdHosts action = do
+    theater <- asksSite appTheater
+    let maybeCap' = first (\ (byKey, _, i) -> (byKey, i)) <$> maybeCap
+        msg = ClientMsg maybeCap' localRecips remoteRecips fwdHosts action
+    maybeResult <-
+        liftIO $ callIO theater (LocalActorPerson personID) (Right msg)
+    itemText <-
+        case maybeResult of
+            Nothing -> error "Person not found in theater"
+            Just (Left e) -> throwE e
+            Just (Right t) -> return t
+    case readMaybe $ T.unpack itemText of
+        Nothing -> error "read itemText failed"
+        Just outboxItemID -> return outboxItemID
+
 verifyResourceAddressed
     :: (MonadSite m, YesodHashids (SiteEnv m))
     => RecipientRoutes -> GrantResourceBy Key -> ExceptT Text m ()
@@ -1838,237 +1867,6 @@ followC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
                 }
             }
 
--- Meaning: The human wants to invite someone A to a resource R
--- Behavior:
---      * Some basic sanity checks
---          * Parse the Invite
---          * Make sure not inviting myself
---          * Verify that a capability is specified
---          * If resource is local, verify it exists in DB
---      * Verify the target A and resource R are addressed in the Invite
---      * Insert Invite to my inbox
---      * Asynchrnously:
---          * Deliver a request to the resource
---          * Deliver a notification to the target
---          * Deliver a notification to my followers
-inviteC
-    :: Entity Person
-    -> Actor
-    -> Maybe
-        (Either
-            (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
-            FedURI
-        )
-    -> RecipientRoutes
-    -> [(Host, NonEmpty LocalURI)]
-    -> [Host]
-    -> AP.Action URIMode
-    -> AP.Invite URIMode
-    -> ExceptT Text Handler OutboxItemId
-inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action invite = do
-    error "Disabled for actor refactoring"
-{-
-    -- Check input
-    (resource, recipient) <- parseInvite (Left senderPersonID) invite
-    _capID <- fromMaybeE maybeCap "No capability provided"
-
-    -- If resource is remote, HTTP GET it and its managing actor, and insert to
-    -- our DB. If resource is local, find it in our DB.
-    resourceDB <-
-        bitraverse
-            (runDBExcept . flip getGrantResource "Grant context not found in DB")
-            (\ u@(ObjURI h lu) -> do
-                instanceID <-
-                    lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
-                result <-
-                    ExceptT $ first (T.pack . show) <$>
-                        fetchRemoteResource instanceID h lu
-                case result of
-                    Left (Entity actorID actor) ->
-                        return (remoteActorIdent actor, actorID, u)
-                    Right (objectID, luManager, (Entity actorID _)) ->
-                        return (objectID, actorID, ObjURI h luManager)
-            )
-            resource
-
-    -- If recipient is remote, HTTP GET it, make sure it's an actor, and insert
-    -- it to our DB. If recipient is local, find it in our DB.
-    recipientDB <-
-        bitraverse
-            (runDBExcept . flip getGrantRecip "Grant recipient not found in DB")
-            (\ u@(ObjURI h lu) -> do
-                instanceID <-
-                    lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
-                result <-
-                    ExceptT $ first (T.pack . displayException) <$>
-                        fetchRemoteActor' instanceID h lu
-                case result of
-                    Left Nothing -> throwE "Recipient @id mismatch"
-                    Left (Just err) -> throwE $ T.pack $ displayException err
-                    Right Nothing -> throwE "Recipient isn't an actor"
-                    Right (Just actor) -> return (entityKey actor, u)
-            )
-            recipient
-
-    -- Verify that resource and recipient are addressed by the Invite
-    bitraverse_
-        (verifyResourceAddressed localRecips . bmap entityKey)
-        (\ (_, _, u) -> verifyRemoteAddressed remoteRecips u)
-        resourceDB
-    bitraverse_
-        (verifyRecipientAddressed localRecips . bmap entityKey)
-        (verifyRemoteAddressed remoteRecips . snd)
-        recipientDB
-
-    now <- liftIO getCurrentTime
-    senderHash <- encodeKeyHashid senderPersonID
-
-    ? <- withDBExcept $ do
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-    (obiidInvite, deliverHttpInvite) <- runDBExcept $ do
-
-        -- Insert the Invite activity to author's outbox
-        inviteID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
-        _luInvite <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) inviteID action
-
-        -- Deliver the Invite activity to local recipients, and schedule
-        -- delivery for unavailable remote recipients
-        deliverHttpInvite <- do
-            sieve <- do
-                resourceHash <- bitraverse hashGrantResource pure resource
-                recipientHash <- bitraverse hashGrantRecip pure recipient
-                let sieveActors = catMaybes
-                        [ case resourceHash of
-                            Left (GrantResourceRepo r) -> Just $ LocalActorRepo r
-                            Left (GrantResourceDeck d) -> Just $ LocalActorDeck d
-                            Left (GrantResourceLoom l) -> Just $ LocalActorLoom l
-                            Right _                    -> Nothing
-                        , case recipientHash of
-                            Left (GrantRecipPerson p) -> Just $ LocalActorPerson p
-                            Right _                   -> Nothing
-                        ]
-                    sieveStages = catMaybes
-                        [ Just $ LocalStagePersonFollowers senderHash
-                        , case resourceHash of
-                            Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r
-                            Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d
-                            Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l
-                            Right _                    -> Nothing
-                        , case recipientHash of
-                            Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p
-                            Right _                   -> Nothing
-                        ]
-                return $ makeRecipientSet sieveActors sieveStages
-            let localRecipsFinal = localRecipSieve sieve False localRecips
-            deliverActivityDB
-                (LocalActorPerson senderHash) (personActor senderPerson)
-                localRecipsFinal remoteRecips fwdHosts inviteID action
-
-        -- If resource is local, verify it has received the Grant
-        case resourceDB of
-            Left localResource -> do
-                let resourceActorID =
-                        case localResource of
-                            GrantResourceRepo (Entity _ r) -> repoActor r
-                            GrantResourceDeck (Entity _ d) -> deckActor d
-                            GrantResourceLoom (Entity _ l) -> loomActor l
-                verifyActorHasItem resourceActorID inviteID "Local topic didn't receive the Invite"
-            Right _ -> pure ()
-
-        -- If recipient is local, verify it has received the invite
-        case recipientDB of
-            Left (GrantRecipPerson (Entity _ p)) ->
-                verifyActorHasItem (personActor p) inviteID "Local recipient didn't receive the Invite"
-            Right _ -> pure ()
-
-        -- Return instructions for HTTP delivery to remote recipients
-        return (inviteID, deliverHttpInvite)
-
-
-
-
-
-
-    -- Notify the resource
-
-
-
-
-
-
-
-
-
-
-    -- Launch asynchronous HTTP delivery of the Grant activity
-    lift $ do
-        forkWorker "inviteC: async HTTP Grant delivery" deliverHttpInvite
-
-    return obiidInvite
-
-    where
-
-    fetchRemoteResource instanceID host localURI = do
-        maybeActor <- withDB $ runMaybeT $ do
-            roid <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID localURI
-            MaybeT $ getBy $ UniqueRemoteActor roid
-        case maybeActor of
-            Just actor -> return $ Right $ Left actor
-            Nothing -> do
-                manager <- asksEnv getHttpManager
-                errorOrResource <- fetchResource manager host localURI
-                case errorOrResource of
-                    Left maybeError ->
-                        return $ Left $ maybe ResultIdMismatch ResultGetError maybeError
-                    Right resource -> do
-                        case resource of
-                            ResourceActor (AP.Actor local detail) -> withDB $ do
-                                roid <- either entityKey id <$> insertBy' (RemoteObject instanceID localURI)
-                                let ra = RemoteActor
-                                        { remoteActorIdent      = roid
-                                        , remoteActorName       =
-                                            AP.actorName detail <|> AP.actorUsername detail
-                                        , remoteActorInbox      = AP.actorInbox local
-                                        , remoteActorFollowers  = AP.actorFollowers local
-                                        , remoteActorErrorSince = Nothing
-                                        }
-                                Right . Left . either id id <$> insertByEntity' ra
-                            ResourceChild luId luManager -> do
-                                roid <- withDB $ either entityKey id <$> insertBy' (RemoteObject instanceID localURI)
-                                result <- fetchRemoteActor' instanceID host luManager
-                                return $
-                                    case result of
-                                        Left e -> Left $ ResultSomeException e
-                                        Right (Left Nothing) -> Left ResultIdMismatch
-                                        Right (Left (Just e)) -> Left $ ResultGetError e
-                                        Right (Right Nothing) -> Left ResultNotActor
-                                        Right (Right (Just actor)) -> Right $ Right (roid, luManager, actor)
-
-    verifyRecipientAddressed localRecips recipient = do
-        recipientHash <- hashGrantRecip recipient
-        fromMaybeE (verify recipientHash) "Recipient not addressed"
-        where
-        verify (GrantRecipPerson p) = do
-            routes <- lookup p $ recipPeople localRecips
-            guard $ routePerson routes
-
-    hashGrantRecip (GrantRecipPerson k) =
-        GrantRecipPerson <$> encodeKeyHashid k
--}
-
 offerTicketC
     :: Entity Person
     -> Actor

src/Vervis/Access.hs

@@ -13,11 +13,6 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE UndecidableInstances #-}
-
 -- | In this module I'd like to collect all the operation access checks. When a
 -- given user asks to perform a certain operation, do we accept the request and
 -- perform the changes to our database etc.? The functions here should provide
@@ -62,22 +57,6 @@ module Vervis.Access
     , checkRepoAccess'
     , checkRepoAccess
     , checkProjectAccess
-
-    , GrantResourceBy (..)
-    , unhashGrantResourcePure
-    , unhashGrantResource
-    , unhashGrantResourceE
-    , unhashGrantResource'
-    , unhashGrantResourceE'
-    , unhashGrantResource404
-    , hashGrantResource
-    , getGrantResource
-    , getGrantResource404
-
-    , grantResourceLocalActor
-
-    , verifyCapability
-    , verifyCapability'
     )
 where
 
@@ -107,6 +86,8 @@ import Web.Actor.Persist (stageHashidsContext)
 import Yesod.Hashids
 import Yesod.MonadSite
 
+import qualified Web.Actor.Persist as WAP
+
 import Control.Monad.Trans.Except.Local
 import Data.Either.Local
 import Database.Persist.Local
@@ -269,142 +250,3 @@ checkProjectAccess mpid op deckHash = do
                 return $ topic E.^. CollabTopicDeckCollab
     asUser = fmap RoleID . deckCollabUser
     asAnon = fmap RoleID . deckCollabAnon
-
-data GrantResourceBy f
-    = GrantResourceRepo (f Repo)
-    | GrantResourceDeck (f Deck)
-    | GrantResourceLoom (f Loom)
-    deriving (Generic, FunctorB, TraversableB, ConstraintsB)
-
-deriving instance AllBF Eq f GrantResourceBy => Eq (GrantResourceBy f)
-
-unhashGrantResourcePure ctx = f
-    where
-    f (GrantResourceRepo r) =
-        GrantResourceRepo <$> decodeKeyHashidPure ctx r
-    f (GrantResourceDeck d) =
-        GrantResourceDeck <$> decodeKeyHashidPure ctx d
-    f (GrantResourceLoom l) =
-        GrantResourceLoom <$> decodeKeyHashidPure ctx l
-
-unhashGrantResource resource = do
-    ctx <- asksSite siteHashidsContext
-    return $ unhashGrantResourcePure ctx resource
-
-unhashGrantResourceE resource e =
-    ExceptT $ maybe (Left e) Right <$> unhashGrantResource resource
-
-unhashGrantResource' resource = do
-    ctx <- asksEnv stageHashidsContext
-    return $ unhashGrantResourcePure ctx resource
-
-unhashGrantResourceE' resource e =
-    ExceptT $ maybe (Left e) Right <$> unhashGrantResource' resource
-
-unhashGrantResource404 = maybe notFound return <=< unhashGrantResource
-
-hashGrantResource (GrantResourceRepo k) =
-    GrantResourceRepo <$> encodeKeyHashid k
-hashGrantResource (GrantResourceDeck k) =
-    GrantResourceDeck <$> encodeKeyHashid k
-hashGrantResource (GrantResourceLoom k) =
-    GrantResourceLoom <$> encodeKeyHashid k
-
-getGrantResource (GrantResourceRepo k) e =
-    GrantResourceRepo <$> getEntityE k e
-getGrantResource (GrantResourceDeck k) e =
-    GrantResourceDeck <$> getEntityE k e
-getGrantResource (GrantResourceLoom k) e =
-    GrantResourceLoom <$> getEntityE k e
-
-getGrantResource404 = maybe notFound return <=< getGrantResourceEntity
-    where
-    getGrantResourceEntity (GrantResourceRepo k) =
-        fmap GrantResourceRepo <$> getEntity k
-    getGrantResourceEntity (GrantResourceDeck k) =
-        fmap GrantResourceDeck <$> getEntity k
-    getGrantResourceEntity (GrantResourceLoom k) =
-        fmap GrantResourceLoom <$> getEntity k
-
-grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f
-grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r
-grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d
-grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l
-
-verifyCapability
-    :: MonadIO m
-    => (LocalActorBy Key, OutboxItemId)
-    -> Either PersonId RemoteActorId
-    -> GrantResourceBy Key
-    -> ExceptT Text (ReaderT SqlBackend m) ()
-verifyCapability (capActor, capItem) actor resource = do
-
-    -- Find the activity itself by URI in the DB
-    nameExceptT "Capability activity not found" $
-        verifyLocalActivityExistsInDB capActor capItem
-
-    -- Find the Collab record for that activity
-    collabID <- do
-        maybeEnable <- lift $ getValBy $ UniqueCollabEnableGrant capItem
-        collabEnableCollab <$>
-            fromMaybeE maybeEnable "No CollabEnable for this activity"
-
-    -- Find the recipient of that Collab
-    recipID <-
-        lift $ bimap collabRecipLocalPerson collabRecipRemoteActor <$>
-            requireEitherAlt
-                (getValBy $ UniqueCollabRecipLocal collabID)
-                (getValBy $ UniqueCollabRecipRemote collabID)
-                "No collab recip"
-                "Both local and remote recips for collab"
-
-    -- Verify the recipient is the expected one
-    unless (recipID == actor) $
-        throwE "Collab recipient is someone else"
-
-    -- Find the local topic, on which this Collab gives access
-    topic <- lift $ do
-        maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
-        maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
-        maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
-        case (maybeRepo, maybeDeck, maybeLoom) of
-            (Nothing, Nothing, Nothing) -> error "Collab without topic"
-            (Just r, Nothing, Nothing) ->
-                return $ GrantResourceRepo $ collabTopicRepoRepo r
-            (Nothing, Just d, Nothing) ->
-                return $ GrantResourceDeck $ collabTopicDeckDeck d
-            (Nothing, Nothing, Just l) ->
-                return $ GrantResourceLoom $ collabTopicLoomLoom l
-            _ -> error "Collab with multiple topics"
-
-    -- Verify that topic is indeed the sender of the Grant
-    unless (grantResourceLocalActor topic == capActor) $
-        error "Grant sender isn't the topic"
-
-    -- Verify the topic matches the resource specified
-    unless (topic == resource) $
-        throwE "Capability topic is some other local resource"
-
-    -- Since there are currently no roles, and grants allow only the "Admin"
-    -- role that supports every operation, we don't need to check role access
-    return ()
-
-verifyCapability'
-    :: MonadIO m
-    => (LocalActorBy Key, OutboxItemId)
-    -> Either
-        (LocalActorBy Key, ActorId, OutboxItemId)
-        (RemoteAuthor, LocalURI, Maybe ByteString)
-    -> GrantResourceBy Key
-    -> ExceptT Text (ReaderT SqlBackend m) ()
-verifyCapability' cap actor resource = do
-    actorP <- processActor actor
-    verifyCapability cap actorP resource
-    where
-    processActor = bitraverse processLocal processRemote
-        where
-        processLocal (actorByKey, _, _) =
-            case actorByKey of
-                LocalActorPerson personID -> return personID
-                _ -> throwE "Non-person local actors can't get Grants at the moment"
-        processRemote (author, _, _) = pure $ remoteAuthorId author

src/Vervis/Actor.hs

@@ -300,11 +300,11 @@ data Verse = Verse
     }
 
 data ClientMsg = ClientMsg
-    { _cmMaybeCap     :: Maybe (Either (LocalActorBy Key, OutboxItemId) FedURI)
+    { cmMaybeCap     :: Maybe (Either (LocalActorBy Key, OutboxItemId) FedURI)
-    , _cmLocalRecips  :: RecipientRoutes
+    , cmLocalRecips  :: RecipientRoutes
-    , _cmRemoteRecips :: [(Host, NonEmpty LocalURI)]
+    , cmRemoteRecips :: [(Host, NonEmpty LocalURI)]
-    , _cmFwdHosts     :: [Host]
+    , cmFwdHosts     :: [Host]
-    , _cmAction       :: AP.Action URIMode
+    , cmAction       :: AP.Action URIMode
     }
 
 type VerseExt = Either Verse ClientMsg

src/Vervis/Actor/Person/Client.hs

@@ -18,23 +18,37 @@ module Vervis.Actor.Person.Client
     )
 where
 
+import Control.Applicative
+import Control.Exception.Base
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Logger.CallStack
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Reader
+import Data.Barbie
+import Data.Bifoldable
+import Data.Bifunctor
+import Data.Bitraversable
 import Data.ByteString (ByteString)
 import Data.Foldable
+import Data.List.NonEmpty (NonEmpty)
+import Data.Maybe
 import Data.Text (Text)
 import Data.Time.Clock
+import Data.Traversable
 import Database.Persist
+import Database.Persist.Sql
+import Optics.Core
 import Yesod.Persist.Core
 
 import qualified Data.Text as T
 
 import Control.Concurrent.Actor
 import Network.FedURI
+import Web.Actor
+import Web.Actor.Persist
 import Yesod.MonadSite
 
 import qualified Web.ActivityPub as AP
@@ -42,15 +56,183 @@ import qualified Web.ActivityPub as AP
 import Control.Monad.Trans.Except.Local
 import Database.Persist.Local
 
+import Vervis.Access
+import Vervis.ActivityPub
 import Vervis.Actor
+import Vervis.Actor2
 import Vervis.Cloth
+import Vervis.Data.Actor
+import Vervis.Data.Collab
 import Vervis.Data.Discussion
+import Vervis.Data.Follow
 import Vervis.FedURI
-import Vervis.Federation.Util
+import Vervis.Fetch
 import Vervis.Foundation
 import Vervis.Model
+import Vervis.Persist.Actor
+import Vervis.Persist.Collab
 import Vervis.Persist.Discussion
+import Vervis.Persist.Follow
+import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localRecipSieve)
+import Vervis.RemoteActorStore
 import Vervis.Ticket
 
+verifyResourceAddressed :: RecipientRoutes -> GrantResourceBy Key -> ActE ()
+verifyResourceAddressed localRecips resource = do
+    resourceHash <- hashGrantResource' resource
+    fromMaybeE (verify resourceHash) "Local resource not addressed"
+    where
+    verify (GrantResourceRepo r) = do
+        routes <- lookup r $ recipRepos localRecips
+        guard $ routeRepo routes
+    verify (GrantResourceDeck d) = do
+        routes <- lookup d $ recipDecks localRecips
+        guard $ routeDeck $ familyDeck routes
+    verify (GrantResourceLoom l) = do
+        routes <- lookup l $ recipLooms localRecips
+        guard $ routeLoom $ familyLoom routes
+
+verifyRecipientAddressed localRecips recipient = do
+    recipientHash <- hashGrantRecip recipient
+    fromMaybeE (verify recipientHash) "Recipient not addressed"
+    where
+    verify (GrantRecipPerson p) = do
+        routes <- lookup p $ recipPeople localRecips
+        guard $ routePerson routes
+
+verifyRemoteAddressed :: [(Host, NonEmpty LocalURI)] -> FedURI -> ActE ()
+verifyRemoteAddressed remoteRecips u =
+    fromMaybeE (verify u) "Given remote entity not addressed"
+    where
+    verify (ObjURI h lu) = do
+        lus <- lookup h remoteRecips
+        guard $ lu `elem` lus
+
+-- Meaning: The human wants to invite someone A to a resource R
+-- Behavior:
+--      * Some basic sanity checks
+--          * Parse the Invite
+--          * Make sure not inviting myself
+--          * Verify that a capability is specified
+--          * If resource is local, verify it exists in DB
+--      * Verify the target A and resource R are addressed in the Invite
+--      * Insert Invite to my inbox
+--      * Asynchrnously deliver to:
+--          * Resource+followers
+--          * Target+followers
+--          * My followers
+clientInvite
+    :: UTCTime
+    -> PersonId
+    -> ClientMsg
+    -> AP.Invite URIMode
+    -> ActE OutboxItemId
+clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) invite = do
+
+    -- Check input
+    (resource, recipient) <- parseInvite (Left $ LocalActorPerson personMeID) invite
+    _capID <- fromMaybeE maybeCap "No capability provided"
+
+    -- If resource is remote, HTTP GET it and its managing actor, and insert to
+    -- our DB. If resource is local, find it in our DB.
+    resourceDB <-
+        bitraverse
+            (withDBExcept . flip getGrantResource "Grant context not found in DB")
+            (\ u@(ObjURI h lu) -> do
+                instanceID <-
+                    lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                result <-
+                    ExceptT $ first (T.pack . show) <$>
+                        fetchRemoteResource instanceID h lu
+                case result of
+                    Left (Entity actorID actor) ->
+                        return (remoteActorIdent actor, actorID, u)
+                    Right (objectID, luManager, (Entity actorID _)) ->
+                        return (objectID, actorID, ObjURI h luManager)
+            )
+            resource
+
+    -- If recipient is remote, HTTP GET it, make sure it's an actor, and insert
+    -- it to our DB. If recipient is local, find it in our DB.
+    recipientDB <-
+        bitraverse
+            (withDBExcept . flip getGrantRecip "Grant recipient not found in DB")
+            (\ u@(ObjURI h lu) -> do
+                instanceID <-
+                    lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                result <-
+                    ExceptT $ first (T.pack . displayException) <$>
+                        fetchRemoteActor' instanceID h lu
+                case result of
+                    Left Nothing -> throwE "Recipient @id mismatch"
+                    Left (Just err) -> throwE $ T.pack $ displayException err
+                    Right Nothing -> throwE "Recipient isn't an actor"
+                    Right (Just actor) -> return (entityKey actor, u)
+            )
+            recipient
+
+    -- Verify that resource and recipient are addressed by the Invite
+    bitraverse_
+        (verifyResourceAddressed localRecips . bmap entityKey)
+        (\ (_, _, u) -> verifyRemoteAddressed remoteRecips u)
+        resourceDB
+    bitraverse_
+        (verifyRecipientAddressed localRecips . bmap entityKey)
+        (verifyRemoteAddressed remoteRecips . snd)
+        recipientDB
+
+    (actorMeID, localRecipsFinal, inviteID) <- withDBExcept $ do
+
+        -- Grab me from DB
+        (personMe, actorMe) <- lift $ do
+            p <- getJust personMeID
+            (p,) <$> getJust (personActor p)
+
+        -- Insert the Invite activity to my outbox
+        inviteID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
+        _luInvite <- lift $ updateOutboxItem' (LocalActorPerson personMeID) inviteID action
+
+        -- Prepare local recipients for Invite delivery
+        sieve <- lift $ do
+            resourceHash <- bitraverse hashGrantResource' pure resource
+            recipientHash <- bitraverse hashGrantRecip pure recipient
+            senderHash <- encodeKeyHashid personMeID
+            let sieveActors = catMaybes
+                    [ case resourceHash of
+                        Left (GrantResourceRepo r) -> Just $ LocalActorRepo r
+                        Left (GrantResourceDeck d) -> Just $ LocalActorDeck d
+                        Left (GrantResourceLoom l) -> Just $ LocalActorLoom l
+                        Right _                    -> Nothing
+                    , case recipientHash of
+                        Left (GrantRecipPerson p) -> Just $ LocalActorPerson p
+                        Right _                   -> Nothing
+                    ]
+                sieveStages = catMaybes
+                    [ Just $ LocalStagePersonFollowers senderHash
+                    , case resourceHash of
+                        Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r
+                        Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d
+                        Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l
+                        Right _                    -> Nothing
+                    , case recipientHash of
+                        Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p
+                        Right _                   -> Nothing
+                    ]
+            return $ makeRecipientSet sieveActors sieveStages
+        return
+            ( personActor personMe
+            , localRecipSieve sieve False localRecips
+            , inviteID
+            )
+
+    lift $ sendActivity
+        (LocalActorPerson personMeID) actorMeID localRecipsFinal remoteRecips
+        fwdHosts inviteID action
+    return inviteID
+
 clientBehavior :: UTCTime -> PersonId -> ClientMsg -> ActE (Text, Act (), Next)
-clientBehavior _ _ _ = throwE "ClientMsg handlers coming soon!"
+clientBehavior now personID msg =
+    done . T.pack . show =<<
+    case AP.actionSpecific $ cmAction msg of
+        AP.InviteActivity invite -> clientInvite now personID msg invite
+        _ -> throwE "Unsupported activity type for C2S"

src/Vervis/Actor2.hs

@@ -28,13 +28,20 @@ module Vervis.Actor2
     , makeAudSenderWithFollowers
     , getActivityURI
     , getActorURI
+      -- * Running actor pieces in Handler
+    , runAct
+    , runActE
+      -- * Fetching remote objects
+    , fetchRemoteResource
     )
 where
 
+import Control.Applicative
 import Control.Concurrent.STM.TVar
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
 import Data.Barbie
 import Data.Bifunctor
 import Data.ByteString (ByteString)
@@ -49,7 +56,7 @@ import Data.Traversable
 import Data.Typeable
 import Database.Persist.Sql
 import GHC.Generics
-import UnliftIO.Exception
+import UnliftIO.Exception hiding (Handler)
 import Web.Hashids
 
 import qualified Data.Aeson as A
@@ -65,15 +72,19 @@ import Web.Actor.Deliver
 import Web.Actor.Persist
 
 import qualified Web.ActivityPub as AP
+import qualified Yesod.MonadSite as YM
 
 import Control.Monad.Trans.Except.Local
+import Database.Persist.Local
 
 import Vervis.Actor
 import Vervis.Data.Actor
 import Vervis.FedURI
+import Vervis.Fetch
 import Vervis.Foundation
 import Vervis.Model hiding (Actor, Message)
 import Vervis.Recipient (renderLocalActor, localRecipSieve', localActorFollowers, Aud (..), ParsedAudience (..), parseAudience')
+import Vervis.RemoteActorStore
 import Vervis.Settings
 
 askLatestInstanceKey :: Act (Maybe (Route App, ActorKey))
@@ -372,3 +383,48 @@ getActorURI (Left (actorByKey, _, _)) = do
     actorByHash <- hashLocalActor actorByKey
     return $ encodeRouteHome $ renderLocalActor actorByHash
 getActorURI (Right (author, _, _)) = pure $ remoteAuthorURI author
+
+runAct :: Act a -> Handler a
+runAct act = do
+    theater <- YM.asksSite appTheater
+    env <- YM.asksSite appEnv
+    liftIO $ runActor theater env act
+
+runActE :: ActE a -> ExceptT Text Handler a
+runActE (ExceptT act) = ExceptT $ runAct act
+
+fetchRemoteResource instanceID host localURI = do
+    maybeActor <- withDB $ runMaybeT $ do
+        roid <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID localURI
+        MaybeT $ getBy $ UniqueRemoteActor roid
+    case maybeActor of
+        Just actor -> return $ Right $ Left actor
+        Nothing -> do
+            manager <- asksEnv envHttpManager
+            errorOrResource <- AP.fetchResource manager host localURI
+            case errorOrResource of
+                Left maybeError ->
+                    return $ Left $ maybe ResultIdMismatch ResultGetError maybeError
+                Right resource -> do
+                    case resource of
+                        AP.ResourceActor (AP.Actor local detail) -> withDB $ do
+                            roid <- either entityKey id <$> insertBy' (RemoteObject instanceID localURI)
+                            let ra = RemoteActor
+                                    { remoteActorIdent      = roid
+                                    , remoteActorName       =
+                                        AP.actorName detail <|> AP.actorUsername detail
+                                    , remoteActorInbox      = AP.actorInbox local
+                                    , remoteActorFollowers  = AP.actorFollowers local
+                                    , remoteActorErrorSince = Nothing
+                                    }
+                            Right . Left . either id id <$> insertByEntity' ra
+                        AP.ResourceChild luId luManager -> do
+                            roid <- withDB $ either entityKey id <$> insertBy' (RemoteObject instanceID localURI)
+                            result <- fetchRemoteActor' instanceID host luManager
+                            return $
+                                case result of
+                                    Left e -> Left $ ResultSomeException e
+                                    Right (Left Nothing) -> Left ResultIdMismatch
+                                    Right (Left (Just e)) -> Left $ ResultGetError e
+                                    Right (Right Nothing) -> Left ResultNotActor
+                                    Right (Right (Just actor)) -> Right $ Right (roid, luManager, actor)

src/Vervis/Client.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -37,6 +37,7 @@ module Vervis.Client
     , createDeck
     , createLoom
     , createRepo
+    , invite
     )
 where
 
@@ -78,7 +79,10 @@ import Data.Either.Local
 import Database.Persist.Local
 
 import Vervis.ActivityPub
+import Vervis.Actor
+import Vervis.Actor2
 import Vervis.Cloth
+import Vervis.Data.Collab
 import Vervis.Data.Ticket
 import Vervis.FedURI
 import Vervis.Foundation
@@ -943,3 +947,84 @@ createRepo senderHash name desc = do
             }
 
     return (Nothing, audience, detail)
+
+invite
+    :: PersonId
+    -> FedURI
+    -> FedURI
+    -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Invite URIMode)
+invite personID uRecipient uResource = do
+
+    theater <- asksSite appTheater
+    env <- asksSite appEnv
+
+    let activity = AP.Invite (Left RoleAdmin) uRecipient uResource
+    (resource, recipient) <-
+        runActE $ parseInvite (Left $ LocalActorPerson personID) activity
+
+    -- If resource is remote, we need to get it from DB/HTTP to determine its
+    -- managing actor & followers collection
+    resourceDB <-
+        bitraverse
+            hashGrantResource
+            (\ u@(ObjURI h lu) -> do
+                instanceID <-
+                    lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
+                result <-
+                    ExceptT $ first (T.pack . show) <$>
+                        runAct (fetchRemoteResource instanceID h lu)
+                case result of
+                    Left (Entity _ actor) ->
+                        return (actor, u)
+                    Right (_objectID, luManager, (Entity _ actor)) ->
+                        return (actor, ObjURI h luManager)
+            )
+            resource
+
+    -- If target is remote, get it via HTTP/DB to determine its followers
+    -- collection
+    recipientDB <-
+        bitraverse
+            (runActE . hashGrantRecip)
+            (\ u@(ObjURI h lu) -> do
+                instanceID <-
+                    lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
+                result <-
+                    ExceptT $ first (T.pack . displayException) <$>
+                        fetchRemoteActor instanceID h lu
+                case result of
+                    Left Nothing -> throwE "Recipient @id mismatch"
+                    Left (Just err) -> throwE $ T.pack $ displayException err
+                    Right Nothing -> throwE "Recipient isn't an actor"
+                    Right (Just actor) -> return (entityVal actor, u)
+            )
+            recipient
+
+    senderHash <- encodeKeyHashid personID
+
+    let audResource =
+            case resourceDB of
+                Left (GrantResourceRepo r) ->
+                    AudLocal [LocalActorRepo r] [LocalStageRepoFollowers r]
+                Left (GrantResourceDeck d) ->
+                    AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d]
+                Left (GrantResourceLoom l) ->
+                    AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l]
+                Right (remoteActor, ObjURI h lu) ->
+                    AudRemote h
+                        [lu]
+                        (maybeToList $ remoteActorFollowers remoteActor)
+        audRecipient =
+            case recipientDB of
+                Left (GrantRecipPerson p) ->
+                    AudLocal [] [LocalStagePersonFollowers p]
+                Right (remoteActor, ObjURI h lu) ->
+                    AudRemote h
+                        [lu]
+                        (maybeToList $ remoteActorFollowers remoteActor)
+        audAuthor =
+            AudLocal [] [LocalStagePersonFollowers senderHash]
+
+        audience = [audResource, audRecipient, audAuthor]
+
+    return (Nothing, audience, activity)

src/Vervis/Data/Collab.hs

@@ -20,6 +20,7 @@
 
 module Vervis.Data.Collab
     ( GrantRecipBy (..)
+    , hashGrantRecip
 
     , parseInvite
     , parseJoin
@@ -28,6 +29,20 @@ module Vervis.Data.Collab
     , parseReject
 
     , grantResourceActorID
+
+    , GrantResourceBy (..)
+    , unhashGrantResourcePure
+    , unhashGrantResource
+    , unhashGrantResourceE
+    , unhashGrantResource'
+    , unhashGrantResourceE'
+    , unhashGrantResource404
+    , hashGrantResource
+    , hashGrantResource'
+    , getGrantResource
+    , getGrantResource404
+
+    , grantResourceLocalActor
     )
 where
 
@@ -38,14 +53,15 @@ import Data.Bifunctor
 import Data.Bitraversable
 import Data.Functor.Identity
 import Data.Text (Text)
+import Database.Persist
 import Database.Persist.Types
 import GHC.Generics
+import Yesod.Core
 
 import Control.Concurrent.Actor
 import Data.Time.Clock
 import Network.FedURI
 import Web.Actor
-import Web.Actor.Persist
 import Yesod.ActivityPub
 import Yesod.Actor
 import Yesod.FedURI
@@ -53,12 +69,13 @@ import Yesod.Hashids
 import Yesod.MonadSite (asksSite)
 
 import qualified Web.ActivityPub as AP
+import qualified Web.Actor.Persist as WAP
 
 import Control.Monad.Trans.Except.Local
+import Database.Persist.Local
 
-import Vervis.Access
 import Vervis.Actor
-import Vervis.Actor2
+--import Vervis.Actor2
 import Vervis.Data.Actor
 import Vervis.FedURI
 import Vervis.Foundation
@@ -77,6 +94,9 @@ deriving instance AllBF Eq f GrantRecipBy => Eq (GrantRecipBy f)
 parseGrantRecip (PersonR p) = Just $ GrantRecipPerson p
 parseGrantRecip _           = Nothing
 
+hashGrantRecip (GrantRecipPerson k) =
+    GrantRecipPerson <$> WAP.encodeKeyHashid k
+
 unhashGrantRecipPure ctx = f
     where
     f (GrantRecipPerson p) =
@@ -87,7 +107,7 @@ unhashGrantRecipOld resource = do
     return $ unhashGrantRecipPure ctx resource
 
 unhashGrantRecip resource = do
-    ctx <- asksEnv stageHashidsContext
+    ctx <- asksEnv WAP.stageHashidsContext
     return $ unhashGrantRecipPure ctx resource
 
 unhashGrantRecipEOld resource e =
@@ -245,3 +265,71 @@ grantResourceActorID :: GrantResourceBy Identity -> ActorId
 grantResourceActorID (GrantResourceRepo (Identity r)) = repoActor r
 grantResourceActorID (GrantResourceDeck (Identity d)) = deckActor d
 grantResourceActorID (GrantResourceLoom (Identity l)) = loomActor l
+
+data GrantResourceBy f
+    = GrantResourceRepo (f Repo)
+    | GrantResourceDeck (f Deck)
+    | GrantResourceLoom (f Loom)
+    deriving (Generic, FunctorB, TraversableB, ConstraintsB)
+
+deriving instance AllBF Eq f GrantResourceBy => Eq (GrantResourceBy f)
+
+unhashGrantResourcePure ctx = f
+    where
+    f (GrantResourceRepo r) =
+        GrantResourceRepo <$> decodeKeyHashidPure ctx r
+    f (GrantResourceDeck d) =
+        GrantResourceDeck <$> decodeKeyHashidPure ctx d
+    f (GrantResourceLoom l) =
+        GrantResourceLoom <$> decodeKeyHashidPure ctx l
+
+unhashGrantResource resource = do
+    ctx <- asksSite siteHashidsContext
+    return $ unhashGrantResourcePure ctx resource
+
+unhashGrantResourceE resource e =
+    ExceptT $ maybe (Left e) Right <$> unhashGrantResource resource
+
+unhashGrantResource' resource = do
+    ctx <- asksEnv WAP.stageHashidsContext
+    return $ unhashGrantResourcePure ctx resource
+
+unhashGrantResourceE' resource e =
+    ExceptT $ maybe (Left e) Right <$> unhashGrantResource' resource
+
+unhashGrantResource404 = maybe notFound return <=< unhashGrantResource
+
+hashGrantResource (GrantResourceRepo k) =
+    GrantResourceRepo <$> encodeKeyHashid k
+hashGrantResource (GrantResourceDeck k) =
+    GrantResourceDeck <$> encodeKeyHashid k
+hashGrantResource (GrantResourceLoom k) =
+    GrantResourceLoom <$> encodeKeyHashid k
+
+hashGrantResource' (GrantResourceRepo k) =
+    GrantResourceRepo <$> WAP.encodeKeyHashid k
+hashGrantResource' (GrantResourceDeck k) =
+    GrantResourceDeck <$> WAP.encodeKeyHashid k
+hashGrantResource' (GrantResourceLoom k) =
+    GrantResourceLoom <$> WAP.encodeKeyHashid k
+
+getGrantResource (GrantResourceRepo k) e =
+    GrantResourceRepo <$> getEntityE k e
+getGrantResource (GrantResourceDeck k) e =
+    GrantResourceDeck <$> getEntityE k e
+getGrantResource (GrantResourceLoom k) e =
+    GrantResourceLoom <$> getEntityE k e
+
+getGrantResource404 = maybe notFound return <=< getGrantResourceEntity
+    where
+    getGrantResourceEntity (GrantResourceRepo k) =
+        fmap GrantResourceRepo <$> getEntity k
+    getGrantResourceEntity (GrantResourceDeck k) =
+        fmap GrantResourceDeck <$> getEntity k
+    getGrantResourceEntity (GrantResourceLoom k) =
+        fmap GrantResourceLoom <$> getEntity k
+
+grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f
+grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r
+grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d
+grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l

src/Vervis/Data/Ticket.hs

@@ -75,7 +75,7 @@ import qualified Web.ActivityPub as AP
 
 import Control.Monad.Trans.Except.Local
 
-import Vervis.Access
+import Vervis.Data.Collab
 import Vervis.Foundation
 import Vervis.FedURI
 import Vervis.Model

src/Vervis/Federation/Ticket.hs

@@ -94,11 +94,11 @@ import qualified Data.Text.UTF8.Local as TU
 
 import Development.PatchMediaType
 
-import Vervis.Access
 import Vervis.ActivityPub
 import Vervis.Actor
 import Vervis.Cloth
 import Vervis.Data.Actor
+import Vervis.Data.Collab
 import Vervis.Data.Ticket
 import Vervis.Darcs
 import Vervis.Web.Delivery

src/Vervis/Fetch.hs

@@ -80,7 +80,7 @@ import qualified Data.Git.Local as G (createRepo)
 import qualified Data.Text.UTF8.Local as TU
 import qualified Darcs.Local.Repository as D (createRepo)
 
-import Vervis.Access
+--import Vervis.Access
 import Vervis.ActivityPub
 import Vervis.Cloth
 import Vervis.Data.Actor

src/Vervis/Handler/Person.hs

@@ -235,7 +235,6 @@ postPersonOutboxR personHash = do
                     AP.CreatePatchTracker detail repos mlocal ->
                         run createPatchTrackerC detail repos mlocal mtarget
                     _ -> throwE "Unsupported Create 'object' type"
-            AP.InviteActivity invite -> run inviteC invite
             {-
             AddActivity (AP.Add obj target) ->
                 case obj of
@@ -254,7 +253,10 @@ postPersonOutboxR personHash = do
                     _ -> throwE "Unsupported Offer 'object' type"
             AP.ResolveActivity resolve -> run resolveC resolve
             AP.UndoActivity undo -> run undoC undo
-            _ -> throwE "Unsupported activity type"
+            _ ->
+                handleViaActor
+                    (entityKey eperson) maybeCap localRecips remoteRecips
+                    fwdHosts action
 
 getPersonOutboxItemR
     :: KeyHashid Person -> KeyHashid OutboxItem -> Handler TypedContent

src/Vervis/Persist/Actor.hs

@@ -59,7 +59,7 @@ import qualified Web.Actor.Persist as WAP
 import Control.Monad.Trans.Except.Local
 import Database.Persist.Local
 
-import Vervis.Actor2 ()
+--import Vervis.Actor2 ()
 import Vervis.Data.Actor
 import Vervis.FedURI
 import Vervis.Foundation

src/Vervis/Persist/Collab.hs

@@ -20,21 +20,36 @@ module Vervis.Persist.Collab
     , getTopicGrants
     , getTopicInvites
     , getTopicJoins
+
+    , verifyCapability
+    , verifyCapability'
     )
 where
 
+import Control.Monad
 import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
 import Control.Monad.Trans.Reader
+import Data.Bifunctor
+import Data.Bitraversable
+import Data.ByteString (ByteString)
+import Data.Text (Text)
 import Data.Time.Clock
 import Database.Persist.Sql
 
 import qualified Database.Esqueleto as E
 
+import Network.FedURI
+
+import Control.Monad.Trans.Except.Local
+import Data.Either.Local
 import Database.Persist.Local
 
-import Vervis.Access
+import Vervis.Actor
 import Vervis.Data.Collab
 import Vervis.Model
+import Vervis.Persist.Actor
 
 getCollabTopic
     :: MonadIO m => CollabId -> ReaderT SqlBackend m (GrantResourceBy Key)
@@ -219,3 +234,81 @@ getTopicJoins topicCollabField topicActorField resourceID =
                 (Just (personID, time), Nothing) -> (Left personID, time)
                 (Nothing, Just (remoteActorID, time)) -> (Right remoteActorID, time)
                 (Just _, Just _) -> error "Multi recip"
+
+verifyCapability
+    :: MonadIO m
+    => (LocalActorBy Key, OutboxItemId)
+    -> Either PersonId RemoteActorId
+    -> GrantResourceBy Key
+    -> ExceptT Text (ReaderT SqlBackend m) ()
+verifyCapability (capActor, capItem) actor resource = do
+
+    -- Find the activity itself by URI in the DB
+    nameExceptT "Capability activity not found" $
+        verifyLocalActivityExistsInDB capActor capItem
+
+    -- Find the Collab record for that activity
+    collabID <- do
+        maybeEnable <- lift $ getValBy $ UniqueCollabEnableGrant capItem
+        collabEnableCollab <$>
+            fromMaybeE maybeEnable "No CollabEnable for this activity"
+
+    -- Find the recipient of that Collab
+    recipID <-
+        lift $ bimap collabRecipLocalPerson collabRecipRemoteActor <$>
+            requireEitherAlt
+                (getValBy $ UniqueCollabRecipLocal collabID)
+                (getValBy $ UniqueCollabRecipRemote collabID)
+                "No collab recip"
+                "Both local and remote recips for collab"
+
+    -- Verify the recipient is the expected one
+    unless (recipID == actor) $
+        throwE "Collab recipient is someone else"
+
+    -- Find the local topic, on which this Collab gives access
+    topic <- lift $ do
+        maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
+        maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
+        maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
+        case (maybeRepo, maybeDeck, maybeLoom) of
+            (Nothing, Nothing, Nothing) -> error "Collab without topic"
+            (Just r, Nothing, Nothing) ->
+                return $ GrantResourceRepo $ collabTopicRepoRepo r
+            (Nothing, Just d, Nothing) ->
+                return $ GrantResourceDeck $ collabTopicDeckDeck d
+            (Nothing, Nothing, Just l) ->
+                return $ GrantResourceLoom $ collabTopicLoomLoom l
+            _ -> error "Collab with multiple topics"
+
+    -- Verify that topic is indeed the sender of the Grant
+    unless (grantResourceLocalActor topic == capActor) $
+        error "Grant sender isn't the topic"
+
+    -- Verify the topic matches the resource specified
+    unless (topic == resource) $
+        throwE "Capability topic is some other local resource"
+
+    -- Since there are currently no roles, and grants allow only the "Admin"
+    -- role that supports every operation, we don't need to check role access
+    return ()
+
+verifyCapability'
+    :: MonadIO m
+    => (LocalActorBy Key, OutboxItemId)
+    -> Either
+        (LocalActorBy Key, ActorId, OutboxItemId)
+        (RemoteAuthor, LocalURI, Maybe ByteString)
+    -> GrantResourceBy Key
+    -> ExceptT Text (ReaderT SqlBackend m) ()
+verifyCapability' cap actor resource = do
+    actorP <- processActor actor
+    verifyCapability cap actorP resource
+    where
+    processActor = bitraverse processLocal processRemote
+        where
+        processLocal (actorByKey, _, _) =
+            case actorByKey of
+                LocalActorPerson personID -> return personID
+                _ -> throwE "Non-person local actors can't get Grants at the moment"
+        processRemote (author, _, _) = pure $ remoteAuthorId author

src/Vervis/Persist/Ticket.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -45,13 +45,14 @@ import Control.Monad.Trans.Except.Local
 import Data.Either.Local
 import Database.Persist.Local
 
-import Vervis.Access
 import Vervis.Cloth
+import Vervis.Data.Collab
 import Vervis.Data.Ticket
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Persist.Actor
+import Vervis.Persist.Collab
 import Vervis.Recipient
 
 getTicketResolve (Entity _ tr, resolve) = do