S2S: Project: Send ext-Grants to new collab upon getting their delegator-Grant

Until now, adding a direct collaborator to a Project worked exactly like
with components: Invite or Join, then Accept, finally the direct-Grant.
I missed the fact that much like with project-component relationships,
projects (and teams) need to be able to send extension-Grants to their
direct collaborators.

So in Project's Grant handler it now:

- Recognizes the delegator-Grant coming from a new collaborator
- Sends extension-Grants, using the delegator-Grant as the capability
- When getting a new component and sending extension-Grants for it to
  direct collaborators, Project uses their delegator-Grants as
  capability

And in Project's Accept handler, it no longer sends extension-Grants
(because it doesn't yet have the collaborator's delegator-Grant at this
point).

NOTE, THIS TEMPORARILY BREAKS grant chains: If you create a Project and
add a Deck to it, you won't get an extension-Grant-for-the-Deck from the
Project, because the Project doesn't yet have your delegator-Grant.

The next commits will implement the Person-side of Collab records, and
will cause Person actors to automatically send the delegator-Grant,
fixing the break.

migrations/554_2023-11-21_further_local_deleg.model

@@ -0,0 +1,61 @@
+ComponentEnable
+Actor
+
+Outbox
+
+OutboxItem
+    outbox    OutboxId
+    activity  PersistJSONObject
+    published UTCTime
+
+Collab
+    role Role
+
+CollabRecipLocal
+    collab CollabId
+    person PersonId
+
+    UniqueCollabRecipLocal collab
+
+CollabEnable
+    collab CollabId
+    grant  OutboxItemId
+
+    UniqueCollabEnable      collab
+    UniqueCollabEnableGrant grant
+
+CollabDelegLocal
+    enable CollabEnableId
+    recip  CollabRecipLocalId
+    grant  OutboxItemId
+
+    UniqueCollabDelegLocal      enable
+    UniqueCollabDelegLocalRecip recip
+    UniqueCollabDelegLocalGrant grant
+
+ComponentFurtherLocal
+    component ComponentEnableId
+    collab    CollabRecipLocalId
+    collabNew CollabDelegLocalId
+    grant     OutboxItemId
+
+    UniqueComponentFurtherLocal      component collab
+    UniqueComponentFurtherLocalGrant grant
+
+Person
+    username            Username
+    login               Text
+    passphraseHash      ByteString
+    email               EmailAddress
+    verified            Bool
+    verifiedKey         Text
+    verifiedKeyCreated  UTCTime
+    resetPassKey        Text
+    resetPassKeyCreated UTCTime
+    actor               ActorId
+--  reviewFollow        Bool
+
+    UniquePersonUsername username
+    UniquePersonLogin    login
+    UniquePersonEmail    email
+    UniquePersonActor    actor

src/Vervis/API.hs

@@ -34,6 +34,7 @@ import Control.Applicative
 import Control.Exception hiding (Handler, try)
 import Control.Monad
 import Control.Monad.IO.Class
+import Control.Monad.Logger.CallStack
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Reader
@@ -158,26 +159,8 @@ handleViaActor personID maybeCap localRecips remoteRecips fwdHosts action = do
 
 verifyResourceAddressed
     :: (MonadSite m, YesodHashids (SiteEnv m))
-    => RecipientRoutes -> GrantResourceBy Key -> ExceptT Text m ()
+    => RecipientRoutes -> LocalActorBy Key -> ExceptT Text m ()
-verifyResourceAddressed localRecips resource = do
+verifyResourceAddressed localRecips resource = logWarn "Vervis.API verifyResourceAddressed"
-    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
-    verify (GrantResourceProject r) = do
-        routes <- lookup r $ recipProjects localRecips
-        guard $ routeProject routes
-    verify (GrantResourceGroup r) = do
-        routes <- lookup r $ recipGroups localRecips
-        guard $ routeGroup routes
 
 verifyRemoteAddressed
     :: Monad m => [(Host, NonEmpty LocalURI)] -> FedURI -> ExceptT Text m ()

src/Vervis/Actor.hs

@@ -78,10 +78,13 @@ module Vervis.Actor
 
     , RemoteRecipient (..)
     , sendToLocalActors
+
+    , actorIsAddressed
     )
 where
 
 import Control.Concurrent.STM.TVar
+import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Maybe
@@ -689,3 +692,25 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
             E.on $ f E.^. FollowActor E.==. p E.^. actorField
             E.where_ $ f E.^. FollowTarget `E.in_` E.valList followerSetIDs
             return $ p E.^. persistIdField
+
+actorIsAddressed :: RecipientRoutes -> LocalActor -> Bool
+actorIsAddressed recips = isJust . verify
+    where
+    verify (LocalActorPerson p) = do
+        routes <- lookup p $ recipPeople recips
+        guard $ routePerson routes
+    verify (LocalActorGroup g) = do
+        routes <- lookup g $ recipGroups recips
+        guard $ routeGroup routes
+    verify (LocalActorRepo r) = do
+        routes <- lookup r $ recipRepos recips
+        guard $ routeRepo routes
+    verify (LocalActorDeck d) = do
+        routes <- lookup d $ recipDecks recips
+        guard $ routeDeck $ familyDeck routes
+    verify (LocalActorLoom l) = do
+        routes <- lookup l $ recipLooms recips
+        guard $ routeLoom $ familyLoom routes
+    verify (LocalActorProject j) = do
+        routes <- lookup j $ recipProjects recips
+        guard $ routeProject routes

src/Vervis/Actor/Common.hs

@@ -14,6 +14,7 @@
  -}
 
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Vervis.Actor.Common
     ( actorFollow
@@ -227,16 +228,16 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
 --          * Otherwise, just ignore the Accept
 --     * Otherwise respond with error
 topicAccept
-    :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
+    :: forall topic.
+       (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
     => (topic -> ActorId)
-    -> (forall f. f topic -> GrantResourceBy f)
     -> (forall f. f topic -> ComponentBy f)
     -> UTCTime
     -> Key topic
     -> Verse
     -> AP.Accept URIMode
     -> ActE (Text, Act (), Next)
-topicAccept topicActor topicResource topicComponent now recipKey (Verse authorIdMsig body) accept = do
+topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) accept = do
 
     -- Check input
     acceptee <- parseAccept accept
@@ -282,6 +283,9 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId
 
     where
 
+    topicResource :: forall f. f topic -> LocalActorBy f
+    topicResource = componentActor . topicComponent
+
     tryInviteCollab (Left (actorByKey, _actorEntity, itemID)) =
         (,Left actorByKey) . collabInviterLocalCollab <$>
             MaybeT (getValBy $ UniqueCollabInviterLocalInvite itemID)
@@ -341,7 +345,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId
         audAccepter <- makeAudSenderWithFollowers authorIdMsig
         audApprover <- lift $ makeAudSenderOnly authorIdMsig
         recipHash <- encodeKeyHashid recipKey
-        let topicByHash = grantResourceLocalActor $ topicResource recipHash
+        let topicByHash = topicResource recipHash
 
         senderHash <- bitraverse hashLocalActor pure sender
 
@@ -475,7 +479,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId
                     _ -> error "topicAccept impossible"
 
                 -- Prepare forwarding of Accept to my followers
-                let recipByID = grantResourceLocalActor $ topicResource recipKey
+                let recipByID = topicResource recipKey
                 recipByHash <- hashLocalActor recipByID
                 let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
 
@@ -491,7 +495,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId
                     grant@(actionGrant, _, _, _) <- do
                         Collab role <- lift $ getJust collabID
                         lift $ prepareGrant isInvite inviterOrJoiner role
-                    let recipByKey = grantResourceLocalActor $ topicResource recipKey
+                    let recipByKey = topicResource recipKey
                     _luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant
                     return (grantID, grant)
 
@@ -500,7 +504,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId
         case maybeNew of
             Nothing -> done "I already have this activity in my inbox"
             Just (recipActorID, sieve, (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant))) -> do
-                let recipByID = grantResourceLocalActor $ topicResource recipKey
+                let recipByID = topicResource recipKey
                 forwardActivity authorIdMsig body recipByID recipActorID sieve
                 lift $ sendActivity
                     recipByID recipActorID localRecipsGrant
@@ -539,7 +543,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId
         audAccepter <- lift $ makeAudSenderOnly authorIdMsig
         audMe <-
             AudLocal [] . pure . localActorFollowers .
-            grantResourceLocalActor . topicResource <$>
+            topicResource <$>
                 encodeKeyHashid recipKey
 
         let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
@@ -655,7 +659,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId
                                         insert_ $ StemComponentGestureRemote stemID (remoteAuthorId author) acceptID
 
                                 -- Prepare forwarding of Accept to my followers
-                                let recipByID = grantResourceLocalActor $ topicResource recipKey
+                                let recipByID = topicResource recipKey
                                 recipByHash <- hashLocalActor recipByID
                                 let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
 
@@ -667,7 +671,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId
 
                                     -- Prepare an Accept activity and insert to my outbox
                                     react@(actionReact, _, _, _) <- lift $ prepareReact project inviter
-                                    let recipByKey = grantResourceLocalActor $ topicResource recipKey
+                                    let recipByKey = topicResource recipKey
                                     _luReact <- lift $ updateOutboxItem' recipByKey reactID actionReact
                                     return (reactID, react)
 
@@ -679,7 +683,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId
             Nothing -> done "I already have this activity in my inbox"
             Just Nothing -> done "Done"
             Just (Just (sieve, (reactID, (actionReact, localRecipsReact, remoteRecipsReact, fwdHostsReact)))) -> do
-                let recipByID = grantResourceLocalActor $ topicResource recipKey
+                let recipByID = topicResource recipKey
                 forwardActivity authorIdMsig body recipByID recipActorID sieve
                 lift $ sendActivity
                     recipByID recipActorID localRecipsReact
@@ -689,7 +693,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId
 topicReject
     :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
     => (topic -> ActorId)
-    -> (forall f. f topic -> GrantResourceBy f)
+    -> (forall f. f topic -> LocalActorBy f)
     -> UTCTime
     -> Key topic
     -> Verse
@@ -815,7 +819,7 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
             lift $ delete collabID
 
             -- Prepare forwarding of Reject to my followers
-            let recipByID = grantResourceLocalActor $ topicResource recipKey
+            let recipByID = topicResource recipKey
             recipByHash <- hashLocalActor recipByID
             let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
 
@@ -827,7 +831,7 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
                     isInvite = isLeft collab
                 newReject@(actionReject, _, _, _) <-
                     lift $ prepareReject isInvite inviterOrJoiner
-                let recipByKey = grantResourceLocalActor $ topicResource recipKey
+                let recipByKey = topicResource recipKey
                 _luNewReject <- lift $ updateOutboxItem' recipByKey newRejectID actionReject
                 return (newRejectID, newReject)
 
@@ -836,7 +840,7 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
     case maybeNew of
         Nothing -> done "I already have this activity in my inbox"
         Just (recipActorID, sieve, (newRejectID, (action, localRecips, remoteRecips, fwdHosts))) -> do
-            let recipByID = grantResourceLocalActor $ topicResource recipKey
+            let recipByID = topicResource recipKey
             forwardActivity authorIdMsig body recipByID recipActorID sieve
             lift $ sendActivity
                 recipByID recipActorID localRecips
@@ -879,7 +883,7 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
         audRejecter <- makeAudSenderWithFollowers authorIdMsig
         audForbidder <- lift $ makeAudSenderOnly authorIdMsig
         recipHash <- encodeKeyHashid recipKey
-        let topicByHash = grantResourceLocalActor $ topicResource recipHash
+        let topicByHash = topicResource recipHash
 
         senderHash <- bitraverse hashLocalActor pure sender
 
@@ -942,12 +946,12 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
 --          * Insert the Invite to my inbox
 --          * Forward the Invite to my followers
 topicInvite
-    :: ( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic
+    :: forall topic ct si.
+       ( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic
        , PersistRecordBackend ct SqlBackend
        , PersistRecordBackend si SqlBackend
        )
     => (topic -> ActorId)
-    -> (forall f. f topic -> GrantResourceBy f)
     -> (forall f. f topic -> ComponentBy f)
     -> EntityField ct (Key topic)
     -> EntityField ct CollabId
@@ -958,7 +962,7 @@ topicInvite
     -> Verse
     -> AP.Invite URIMode
     -> ActE (Text, Act (), Next)
-topicInvite grabActor topicResource topicComponent topicField topicCollabField collabTopicCtor stemIdentCtor now topicKey (Verse authorIdMsig body) invite = do
+topicInvite grabActor topicComponent topicField topicCollabField collabTopicCtor stemIdentCtor now topicKey (Verse authorIdMsig body) invite = do
 
     -- Check invite
     recipOrProject <- do
@@ -1141,7 +1145,7 @@ topicInvite grabActor topicResource topicComponent topicField topicCollabField c
             sieve <- do
                 topicHash <- encodeKeyHashid topicKey
                 let topicByHash =
-                        grantResourceLocalActor $ topicResource topicHash
+                        topicResource topicHash
                 return $ makeRecipientSet [] [localActorFollowers topicByHash]
 
             -- Insert Collab or Stem record to DB
@@ -1152,7 +1156,7 @@ topicInvite grabActor topicResource topicComponent topicField topicCollabField c
                     acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
                     insertCollab role targetDB inviteDB acceptID
                     accept@(actionAccept, _, _, _) <- lift $ prepareAccept targetByKey
-                    let topicByKey = grantResourceLocalActor $ topicResource topicKey
+                    let topicByKey = topicResource topicKey
                     _luAccept <- updateOutboxItem' topicByKey acceptID actionAccept
                     return (acceptID, accept)
                 Right projectDB -> do
@@ -1164,7 +1168,7 @@ topicInvite grabActor topicResource topicComponent topicField topicCollabField c
     case maybeNew of
         Nothing -> done "I already have this activity in my inbox"
         Just (topicActorID, sieve, maybeAccept) -> do
-            let topicByID = grantResourceLocalActor $ topicResource topicKey
+            let topicByID = topicResource topicKey
             forwardActivity authorIdMsig body topicByID topicActorID sieve
             lift $ for_ maybeAccept $ \ (acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) ->
                 sendActivity
@@ -1174,6 +1178,9 @@ topicInvite grabActor topicResource topicComponent topicField topicCollabField c
 
     where
 
+    topicResource :: forall f. f topic -> LocalActorBy f
+    topicResource = componentActor . topicComponent
+
     insertCollab role recipient inviteDB acceptID = do
         collabID <- insert $ Collab role
         fulfillsID <- insert $ CollabFulfillsInvite collabID acceptID
@@ -1217,7 +1224,7 @@ topicInvite grabActor topicResource topicComponent topicField topicCollabField c
                 Right (ObjURI h lu) -> return $ AudRemote h [lu] []
         audTopic <-
             AudLocal [] . pure . localActorFollowers .
-            grantResourceLocalActor . topicResource <$>
+            topicResource <$>
                 encodeKeyHashid topicKey
         uInvite <- getActivityURI authorIdMsig
 
@@ -1243,7 +1250,7 @@ topicRemove
        , PersistRecordBackend ct SqlBackend
        )
     => (topic -> ActorId)
-    -> (forall f. f topic -> GrantResourceBy f)
+    -> (forall f. f topic -> LocalActorBy f)
     -> EntityField ct (Key topic)
     -> EntityField ct CollabId
     -> UTCTime
@@ -1406,13 +1413,13 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
             sieve <- lift $ do
                 topicHash <- encodeKeyHashid topicKey
                 let topicByHash =
-                        grantResourceLocalActor $ topicResource topicHash
+                        topicResource topicHash
                 return $ makeRecipientSet [] [localActorFollowers topicByHash]
 
             -- Prepare a Revoke activity and insert to my outbox
             revoke@(actionRevoke, _, _, _) <-
                 lift $ prepareRevoke memberDB grantID
-            let recipByKey = grantResourceLocalActor $ topicResource topicKey
+            let recipByKey = topicResource topicKey
             revokeID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
             _luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke
 
@@ -1421,7 +1428,7 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
     case maybeNew of
         Nothing -> done "I already have this activity in my inbox"
         Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke)) -> do
-            let topicByID = grantResourceLocalActor $ topicResource topicKey
+            let topicByID = topicResource topicKey
             forwardActivity authorIdMsig body topicByID topicActorID sieve
             lift $ sendActivity
                 topicByID topicActorID localRecipsRevoke
@@ -1435,7 +1442,7 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
         encodeRouteLocal <- getEncodeRouteLocal
 
         recipHash <- encodeKeyHashid topicKey
-        let topicByHash = grantResourceLocalActor $ topicResource recipHash
+        let topicByHash = topicResource recipHash
 
         memberHash <- bitraverse (hashGrantRecip . bmap entityKey) pure member
 
@@ -1475,7 +1482,7 @@ topicJoin
        , PersistRecordBackend ct SqlBackend
        )
     => (topic -> ActorId)
-    -> (forall f. f topic -> GrantResourceBy f)
+    -> (forall f. f topic -> LocalActorBy f)
     -> EntityField ct (Key topic)
     -> EntityField ct CollabId
     -> (CollabId -> Key topic -> ct)
@@ -1546,14 +1553,14 @@ topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor no
             sieve <- lift $ do
                 topicHash <- encodeKeyHashid topicKey
                 let topicByHash =
-                        grantResourceLocalActor $ topicResource topicHash
+                        topicResource topicHash
                 return $ makeRecipientSet [] [localActorFollowers topicByHash]
             return (topicActorID, sieve)
 
     case maybeNew of
         Nothing -> done "I already have this activity in my inbox"
         Just (topicActorID, sieve) -> do
-            let topicByID = grantResourceLocalActor $ topicResource topicKey
+            let topicByID = topicResource topicKey
             forwardActivity authorIdMsig body topicByID topicActorID sieve
             done "Recorded and forwarded the Join"
 
@@ -1577,7 +1584,7 @@ topicCreateMe
        , PersistRecordBackend ct SqlBackend
        )
     => (topic -> ActorId)
-    -> (forall f. f topic -> GrantResourceBy f)
+    -> (forall f. f topic -> LocalActorBy f)
     -> EntityField ct (Key topic)
     -> (CollabId -> Key topic -> ct)
     -> UTCTime
@@ -1622,7 +1629,7 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
 
             -- Prepare a Grant activity and insert to my outbox
             grant@(actionGrant, _, _, _) <- lift prepareGrant
-            let recipByKey = grantResourceLocalActor $ topicResource recipKey
+            let recipByKey = topicResource recipKey
             _luGrant <- updateOutboxItem' recipByKey grantID actionGrant
 
             return (recipActorID, grantID, grant)
@@ -1630,7 +1637,7 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
     case maybeNew of
         Nothing -> done "I already have this activity in my inbox"
         Just (recipActorID, grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) -> do
-            let recipByID = grantResourceLocalActor $ topicResource recipKey
+            let recipByID = topicResource recipKey
             lift $ sendActivity
                 recipByID recipActorID localRecipsGrant
                 remoteRecipsGrant fwdHostsGrant grantID actionGrant
@@ -1653,7 +1660,7 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
         recipHash <- encodeKeyHashid recipKey
         uCreator <- getActorURI authorIdMsig
         uCreate <- getActivityURI authorIdMsig
-        let topicByHash = grantResourceLocalActor $ topicResource recipHash
+        let topicByHash = topicResource recipHash
             audience =
                 let audTopic = AudLocal [] [localActorFollowers topicByHash]
                 in  [audCreator, audTopic]
@@ -1707,16 +1714,16 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
 --      * Otherwise, if I've already seen this Grant or it's simply not related
 --        to me, ignore it
 componentGrant
-    :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
+    :: forall topic.
+       (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
     => (topic -> ActorId)
-    -> (forall f. f topic -> GrantResourceBy f)
     -> (forall f. f topic -> ComponentBy f)
     -> UTCTime
     -> Key topic
     -> Verse
     -> AP.Grant URIMode
     -> ActE (Text, Act (), Next)
-componentGrant grabActor topicResource topicComponent now recipKey (Verse authorIdMsig body) grant = do
+componentGrant grabActor topicComponent now recipKey (Verse authorIdMsig body) grant = do
 
     -- Check grant
     project <- checkDelegatorGrant grant
@@ -1791,7 +1798,7 @@ componentGrant grabActor topicResource topicComponent now recipKey (Verse author
             sieve <- do
                 recipHash <- encodeKeyHashid recipKey
                 let recipByHash =
-                        grantResourceLocalActor $ topicResource recipHash
+                        topicResource recipHash
                 return $ makeRecipientSet [] [localActorFollowers recipByHash]
 
             -- Update the Stem record in DB
@@ -1806,7 +1813,7 @@ componentGrant grabActor topicResource topicComponent now recipKey (Verse author
             chain <- do
                 Stem role <- getJust stemID
                 chain@(actionChain, _, _, _) <- prepareChain role
-                let recipByKey = grantResourceLocalActor $ topicResource recipKey
+                let recipByKey = topicResource recipKey
                 _luChain <- updateOutboxItem' recipByKey chainID actionChain
                 return chain
 
@@ -1815,7 +1822,7 @@ componentGrant grabActor topicResource topicComponent now recipKey (Verse author
     case maybeNew of
         Nothing -> done "I already have this activity in my inbox"
         Just (recipActorID, sieve, chainID, (actionChain, localRecipsChain, remoteRecipsChain, fwdHostsChain)) -> do
-            let recipByID = grantResourceLocalActor $ topicResource recipKey
+            let recipByID = topicResource recipKey
             forwardActivity authorIdMsig body recipByID recipActorID sieve
             lift $ sendActivity
                 recipByID recipActorID localRecipsChain remoteRecipsChain
@@ -1824,6 +1831,9 @@ componentGrant grabActor topicResource topicComponent now recipKey (Verse author
 
     where
 
+    topicResource :: forall f. f topic -> LocalActorBy f
+    topicResource = componentActor . topicComponent
+
     checkDelegatorGrant g = do
         (role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <-
             parseGrant' g
@@ -1833,7 +1843,7 @@ componentGrant grabActor topicResource topicComponent now recipKey (Verse author
         project <-
             bitraverse
                 (\case
-                    GrantResourceProject j -> return j
+                    LocalActorProject j -> return j
                     _ -> throwE "Resource isn't a project"
                 )
                 pure
@@ -1885,12 +1895,12 @@ componentGrant grabActor topicResource topicComponent now recipKey (Verse author
         audProject <- makeAudSenderWithFollowers authorIdMsig
         audMe <-
             AudLocal [] . pure . localActorFollowers .
-            grantResourceLocalActor . topicResource <$>
+            topicResource <$>
                 encodeKeyHashid recipKey
         uProject <- lift $ getActorURI authorIdMsig
         uGrant <- lift $ getActivityURI authorIdMsig
         recipHash <- encodeKeyHashid recipKey
-        let topicByHash = grantResourceLocalActor $ topicResource recipHash
+        let topicByHash = topicResource recipHash
 
             (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
                 collectAudience [audProject, audMe]

src/Vervis/Actor/Deck.hs

@@ -191,7 +191,7 @@ deckAdd now deckID (Verse authorIdMsig body) add = do
 
         -- Verify the specified capability gives relevant access
         verifyCapability'
-            capability authorIdMsig (GrantResourceDeck deckID) AP.RoleAdmin
+            capability authorIdMsig (LocalActorDeck deckID) AP.RoleAdmin
 
         -- Insert the Add to my inbox
         mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actor) False
@@ -292,7 +292,7 @@ deckCreateMe
     -> ActE (Text, Act (), Next)
 deckCreateMe =
     topicCreateMe
-        deckActor GrantResourceDeck CollabTopicDeckDeck CollabTopicDeck
+        deckActor LocalActorDeck CollabTopicDeckDeck CollabTopicDeck
 
 deckCreate
     :: UTCTime
@@ -391,11 +391,11 @@ deckOffer now deckID (Verse authorIdMsig body) (AP.Offer object uTarget) = do
                 verifyCapability'
                     lcap
                     authorIdMsig
-                    (GrantResourceDeck deckID)
+                    (LocalActorDeck deckID)
                     AP.RoleReport
 
             -- Prepare forwarding the Offer to my followers
-            let recipByID = grantResourceLocalActor $ GrantResourceDeck deckID
+            let recipByID = LocalActorDeck deckID
             recipByHash <- hashLocalActor recipByID
             let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
 
@@ -528,7 +528,7 @@ deckResolve now deckID (Verse authorIdMsig body) (AP.Resolve uObject) = do
     verifyCapability''
         uCap
         authorIdMsig
-        (GrantResourceDeck deckID)
+        (LocalActorDeck deckID)
         AP.RoleTriage
 
     {-
@@ -744,7 +744,7 @@ deckAccept
     -> Verse
     -> AP.Accept URIMode
     -> ActE (Text, Act (), Next)
-deckAccept = topicAccept deckActor GrantResourceDeck ComponentDeck
+deckAccept = topicAccept deckActor ComponentDeck
 
 -- Meaning: An actor rejected something
 -- Behavior:
@@ -769,7 +769,7 @@ deckReject
     -> Verse
     -> AP.Reject URIMode
     -> ActE (Text, Act (), Next)
-deckReject = topicReject deckActor GrantResourceDeck
+deckReject = topicReject deckActor LocalActorDeck
 
 -- Meaning: An actor A invited actor B to a resource
 -- Behavior:
@@ -800,7 +800,7 @@ deckInvite
     -> ActE (Text, Act (), Next)
 deckInvite =
     topicInvite
-        deckActor GrantResourceDeck ComponentDeck
+        deckActor ComponentDeck
         CollabTopicDeckDeck CollabTopicDeckCollab
         CollabTopicDeck StemIdentDeck
 
@@ -823,7 +823,7 @@ deckRemove
     -> ActE (Text, Act (), Next)
 deckRemove =
     topicRemove
-        deckActor GrantResourceDeck
+        deckActor LocalActorDeck
         CollabTopicDeckDeck CollabTopicDeckCollab
 
 -- Meaning: An actor A asked to join a resource
@@ -840,7 +840,7 @@ deckJoin
     -> ActE (Text, Act (), Next)
 deckJoin =
     topicJoin
-        deckActor GrantResourceDeck
+        deckActor LocalActorDeck
         CollabTopicDeckDeck CollabTopicDeckCollab CollabTopicDeck
 
 -- Meaning: An actor is granting access-to-some-resource to another actor
@@ -873,7 +873,7 @@ deckGrant
     -> Verse
     -> AP.Grant URIMode
     -> ActE (Text, Act (), Next)
-deckGrant = componentGrant deckActor GrantResourceDeck ComponentDeck
+deckGrant = componentGrant deckActor ComponentDeck
 
 ------------------------------------------------------------------------------
 -- Ambiguous: Following/Resolving
@@ -1014,7 +1014,7 @@ deckUndo now recipDeckID (Verse authorIdMsig body) (AP.Undo uObject) = do
             verifyCapability'
                 capability
                 authorIdMsig
-                (GrantResourceDeck recipDeckID)
+                (LocalActorDeck recipDeckID)
                 AP.RoleTriage
 
         lift $ lift deleteFromDB

src/Vervis/Actor/Group.hs

@@ -92,7 +92,7 @@ groupCreateMe
     -> ActE (Text, Act (), Next)
 groupCreateMe =
     topicCreateMe
-        groupActor GrantResourceGroup
+        groupActor LocalActorGroup
         CollabTopicGroupGroup CollabTopicGroup
 
 groupCreate

src/Vervis/Actor/Loom.hs

@@ -279,11 +279,11 @@ loomOffer now loomID (Verse authorIdMsig body) (AP.Offer object uTarget) = do
                 verifyCapability'
                     lcap
                     authorIdMsig
-                    (GrantResourceLoom loomID)
+                    (LocalActorLoom loomID)
                     AP.RoleReport
 
             -- Prepare forwarding the Offer to my followers
-            let recipByID = grantResourceLocalActor $ GrantResourceLoom loomID
+            let recipByID = LocalActorLoom loomID
             recipByHash <- hashLocalActor recipByID
             let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
 
@@ -485,7 +485,7 @@ loomResolve now loomID (Verse authorIdMsig body) (AP.Resolve uObject) = do
             verifyCapability'
                 capability
                 authorIdMsig
-                (GrantResourceLoom loomID)
+                (LocalActorLoom loomID)
                 AP.RoleTriage
 
             -- Prepare forwarding the Resolve to my followers & ticket

src/Vervis/Actor/Person/Client.hs

@@ -81,26 +81,11 @@ import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectA
 import Vervis.RemoteActorStore
 import Vervis.Ticket
 
-verifyResourceAddressed :: RecipientRoutes -> GrantResourceBy Key -> ActE ()
+verifyActorAddressed :: RecipientRoutes -> LocalActorBy Key -> ActE ()
-verifyResourceAddressed localRecips resource = do
+verifyActorAddressed localRecips resource = do
-    resourceHash <- hashGrantResource' resource
+    resourceHash <- hashLocalActor resource
-    fromMaybeE (verify resourceHash) "Local resource not addressed"
+    unless (actorIsAddressed localRecips resourceHash) $
-    where
+        throwE "Local resource not addressed"
-    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
-    verify (GrantResourceProject r) = do
-        routes <- lookup r $ recipProjects localRecips
-        guard $ routeProject routes
-    verify (GrantResourceGroup r) = do
-        routes <- lookup r $ recipGroups localRecips
-        guard $ routeGroup routes
 
 verifyProjectAddressed localRecips projectID = do
     projectHash <- encodeKeyHashid projectID
@@ -838,7 +823,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
     resourceDB <-
         bitraverse
             (bitraverse
-                (withDBExcept . flip getGrantResource "Grant resource not found in DB")
+                (withDBExcept . flip getLocalActorEntityE "Grant resource not found in DB")
                 (withDBExcept . flip getEntityE "Grant context project not found in DB")
             )
             (\ u@(ObjURI h luColl) -> do
@@ -887,7 +872,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
     -- Verify that resource and recipient are addressed by the Invite
     bitraverse_
         (bitraverse_
-            (verifyResourceAddressed localRecips . bmap entityKey)
+            (verifyActorAddressed localRecips . bmap entityKey)
             (verifyProjectAddressed localRecips . entityKey)
         )
         (\ (_, _, u) -> verifyRemoteAddressed remoteRecips u)
@@ -913,12 +898,12 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
 
         -- Prepare local recipients for Invite delivery
         sieve <- lift $ do
-            resourceHash <- bitraverse (bitraverse hashGrantResource' encodeKeyHashid) pure resource
+            resourceHash <- bitraverse (bitraverse hashLocalActor encodeKeyHashid) pure resource
             recipientHash <- bitraverse (bitraverse hashGrantRecip hashComponent) pure recipient
             senderHash <- encodeKeyHashid personMeID
             let sieveActors = catMaybes
                     [ case resourceHash of
-                        Left (Left r)  -> Just $ grantResourceLocalActor r
+                        Left (Left a)  -> Just a
                         Left (Right j) -> Just $ LocalActorProject j
                         Right _        -> Nothing
                     , case recipientHash of
@@ -929,7 +914,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
                 sieveStages = catMaybes
                     [ Just $ LocalStagePersonFollowers senderHash
                     , case resourceHash of
-                        Left (Left r)  -> Just $ localActorFollowers $ grantResourceLocalActor r
+                        Left (Left a)  -> Just $ localActorFollowers a
                         Left (Right j) -> Just $ LocalStageProjectFollowers j
                         Right _        -> Nothing
                     , case recipientHash of
@@ -1088,7 +1073,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
 
     -- Verify that resource is addressed by the Remove
     bitraverse_
-        (verifyResourceAddressed localRecips)
+        (verifyActorAddressed localRecips)
         (verifyRemoteAddressed remoteRecips)
         resource'
 
@@ -1103,7 +1088,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
         -- If resource is local, find it in our DB
         _resourceDB <-
             bitraverse
-                (flip getGrantResource "Resource not found in DB")
+                (flip getLocalActorEntityE "Resource not found in DB")
                 pure
                 resource'
 
@@ -1125,16 +1110,12 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
 
         -- Prepare local recipients for Remove delivery
         sieve <- lift $ do
-            resourceHash <- bitraverse hashGrantResource' pure resource'
+            resourceHash <- bitraverse hashLocalActor pure resource'
             recipientHash <- bitraverse hashGrantRecip pure member
             senderHash <- encodeKeyHashid personMeID
             let sieveActors = catMaybes
                     [ case resourceHash of
-                        Left (GrantResourceRepo r) -> Just $ LocalActorRepo r
+                        Left a -> Just a
-                        Left (GrantResourceDeck d) -> Just $ LocalActorDeck d
-                        Left (GrantResourceLoom l) -> Just $ LocalActorLoom l
-                        Left (GrantResourceProject l) -> Just $ LocalActorProject l
-                        Left (GrantResourceGroup l) -> Just $ LocalActorGroup l
                         Right _                    -> Nothing
                     , case recipientHash of
                         Left (GrantRecipPerson p) -> Just $ LocalActorPerson p
@@ -1143,11 +1124,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
                 sieveStages = catMaybes
                     [ Just $ LocalStagePersonFollowers senderHash
                     , case resourceHash of
-                        Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r
+                        Left a -> Just $ localActorFollowers a
-                        Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d
-                        Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l
-                        Left (GrantResourceProject l) -> Just $ LocalStageProjectFollowers l
-                        Left (GrantResourceGroup l) -> Just $ LocalStageGroupFollowers l
                         Right _                    -> Nothing
                     , case recipientHash of
                         Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p

src/Vervis/Actor/Project.hs

@@ -137,10 +137,6 @@ import Vervis.Ticket
 --                 - Component's followers
 --                 - My followers
 --                 - The Accept's sender
---
---      * In collab mode, if we just sent the collaborator-Grant, also send to
---        my new collaborator a delegation-extension Grant for each component I
---        have
 projectAccept
     :: UTCTime
     -> ProjectId
@@ -223,7 +219,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
                     verifyCapability'
                         capability
                         authorIdMsig
-                        (GrantResourceProject projectID)
+                        (LocalActorProject projectID)
                         AP.RoleAdmin
                     return fulfillsID
                 )
@@ -267,7 +263,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
                             verifyCapability'
                                 capability
                                 authorIdMsig
-                                (GrantResourceProject projectID)
+                                (LocalActorProject projectID)
                                 AP.RoleAdmin
                 )
 
@@ -358,15 +354,14 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
                             return (componentID, ident, grantID, enableID, True)
 
             -- Prepare forwarding of Accept to my followers
-            let recipByID = grantResourceLocalActor $ GrantResourceProject projectID
+            let recipByID = LocalActorProject projectID
             recipByHash <- hashLocalActor recipByID
             let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
 
             maybeGrant <-
                 case idsForGrant of
 
-                    -- In collab mode, prepare a regular Grant and extension
+                    -- In collab mode, prepare a regular Grant
-                    -- Grants
                     Left (collabID, inviterOrJoiner, collab, grantID, collabEnableID) -> lift $ do
                         let isInvite = isLeft collab
                         grant@(actionGrant, _, _, _) <- do
@@ -374,81 +369,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
                             prepareCollabGrant isInvite inviterOrJoiner role
                         let recipByKey = LocalActorProject projectID
                         _luGrant <- updateOutboxItem' recipByKey grantID actionGrant
-
+                        return $ Just (grantID, grant)
-                        recip <-
-                            requireEitherAlt
-                                (getBy $ UniqueCollabRecipLocal collabID)
-                                (getBy $ UniqueCollabRecipRemote collabID)
-                                "Found Collab with no recip"
-                                "Found Collab with multiple recips"
-                        let insertExt =
-                                case bimap entityKey entityKey recip of
-                                    Left localID ->
-                                        \ enableID furtherID -> insert_ $ ComponentFurtherLocal enableID localID furtherID
-                                    Right remoteID ->
-                                        \ enableID furtherID -> insert_ $ ComponentFurtherRemote enableID remoteID furtherID
-                        locals <-
-                            fmap (map $ over _1 Left) $
-                            E.select $ E.from $ \ (deleg `E.InnerJoin` local `E.InnerJoin` comp `E.InnerJoin` enable) -> do
-                                E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent
-                                E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId
-                                E.on $ deleg E.^. ComponentDelegateLocalComponent E.==.local E.^. ComponentLocalId
-                                E.where_ $ comp E.^. ComponentProject E.==. E.val projectID
-                                return (deleg E.^. ComponentDelegateLocalGrant, comp, enable)
-                        remotes <-
-                            fmap (map $ over _1 Right) $
-                            E.select $ E.from $ \ (deleg `E.InnerJoin` remote `E.InnerJoin` comp `E.InnerJoin` enable) -> do
-                                E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent
-                                E.on $ remote E.^. ComponentRemoteComponent E.==. comp E.^. ComponentId
-                                E.on $ deleg E.^. ComponentDelegateRemoteComponent E.==.remote E.^. ComponentRemoteId
-                                E.where_ $ comp E.^. ComponentProject E.==. E.val projectID
-                                return (deleg E.^. ComponentDelegateRemoteGrant, comp, enable)
-                        (uCollab, audCollab) <-
-                            case recip of
-                                Left (Entity _ (CollabRecipLocal _ personID)) -> do
-                                    personHash <- encodeKeyHashid personID
-                                    encodeRouteHome <- getEncodeRouteHome
-                                    return
-                                        ( encodeRouteHome $ PersonR personHash
-                                        , AudLocal [LocalActorPerson personHash] []
-                                        )
-                                Right (Entity _ (CollabRecipRemote _ raID)) -> do
-                                    ra <- getJust raID
-                                    u@(ObjURI h lu) <- getRemoteActorURI ra
-                                    return (u, AudRemote h [lu] [])
-                        Collab role <- getJust collabID
-                        exts <- for (locals ++ remotes) $ \ (start, Entity componentID component, Entity enableID _) -> do
-                            extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
-                            insertExt enableID extID
-                            componentIdent <- do
-                                i <- getComponentIdent componentID
-                                bitraverse
-                                    (pure . snd)
-                                    (\ (_, raID) -> getRemoteActorURI =<< getJust raID)
-                                    i
-                            uStart <-
-                                case start of
-                                    Left (E.Value startID) -> do
-                                        encodeRouteHome <- getEncodeRouteHome
-                                        c <-
-                                            case componentIdent of
-                                                Left ci -> hashComponent ci
-                                                Right _ -> error "Delegation-start Grant URI is local, but component found to be remote, impossible"
-                                        s <- encodeKeyHashid startID
-                                        return $ encodeRouteHome $ activityRoute (componentActor c) s
-                                    Right (E.Value remoteActivityID) -> do
-                                        objectID <- remoteActivityIdent <$> getJust remoteActivityID
-                                        o <- getJust objectID
-                                        let luAct = remoteObjectIdent o
-                                        h <- instanceHost <$> getJust (remoteObjectInstance o)
-                                        return $ ObjURI h luAct
-                            ext@(actionExt, _, _, _) <-
-                                prepareExtensionGrant uCollab audCollab componentIdent uStart (min role (componentRole component)) collabEnableID
-                            let recipByKey = LocalActorProject projectID
-                            _luExt <- updateOutboxItem' recipByKey extID actionExt
-                            return (extID, ext)
-
-                        return $ Just (grantID, grant, exts)
 
                     -- In Invite-component mode, only if the Accept author is
                     -- the component, prepare a delegator-Grant
@@ -460,7 +381,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
                             prepareDelegGrant (bimap snd snd ident) enableID includeAuthor
                         let recipByKey = LocalActorProject projectID
                         _luGrant <- updateOutboxItem' recipByKey grantID actionGrant
-                        return (grantID, grant, [])
+                        return (grantID, grant)
 
             return (recipActorID, sieve, maybeGrant)
 
@@ -469,21 +390,17 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
         Just (recipActorID, sieve, maybeGrant) -> do
             let recipByID = LocalActorProject projectID
             forwardActivity authorIdMsig body recipByID recipActorID sieve
-            lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant), exts) -> do
+            lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) ->
                 sendActivity
                     recipByID recipActorID localRecipsGrant
                     remoteRecipsGrant fwdHostsGrant grantID actionGrant
-                for_ exts $ \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) ->
-                    sendActivity
-                        recipByID recipActorID localRecipsExt
-                        remoteRecipsExt fwdHostsExt extID actionExt
             done "Forwarded the Accept and maybe published a Grant"
 
     where
 
     verifyCollabTopic collabID = do
         topic <- lift $ getCollabTopic collabID
-        unless (GrantResourceProject projectID == topic) $
+        unless (LocalActorProject projectID == topic) $
             throwE "Accept object is an Invite/Join for some other resource"
 
     verifyInviteCollabTopic fulfillsID = do
@@ -583,7 +500,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
         audAccepter <- makeAudSenderWithFollowers authorIdMsig
         audApprover <- lift $ makeAudSenderOnly authorIdMsig
         recipHash <- encodeKeyHashid projectID
-        let topicByHash = grantResourceLocalActor $ GrantResourceProject recipHash
+        let topicByHash = LocalActorProject recipHash
 
         senderHash <- bitraverse hashLocalActor pure sender
 
@@ -689,49 +606,6 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
 
         return (action, recipientSet, remoteActors, fwdHosts)
 
-    prepareExtensionGrant uCollab audCollab component uStart role enableID = do
-        encodeRouteHome <- getEncodeRouteHome
-        encodeRouteLocal <- getEncodeRouteLocal
-
-        projectHash <- encodeKeyHashid projectID
-
-        uComponent <-
-            case component of
-                Left c -> do
-                    a <- componentActor <$> hashComponent c
-                    return $ encodeRouteHome $ renderLocalActor a
-                Right u -> pure u
-
-        enableHash <- encodeKeyHashid enableID
-
-        let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
-                collectAudience [audCollab]
-
-            recips = map encodeRouteHome audLocal ++ audRemote
-            action = AP.Action
-                { AP.actionCapability = Nothing
-                , AP.actionSummary    = Nothing
-                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
-                , AP.actionFulfills   = [uStart]
-                , AP.actionSpecific   = AP.GrantActivity AP.Grant
-                    { AP.grantObject    = AP.RXRole role
-                    , AP.grantContext   = uComponent
-                    , AP.grantTarget    = uCollab
-                    , AP.grantResult    =
-                        Just
-                            (encodeRouteLocal $
-                                ProjectCollabLiveR projectHash enableHash
-                            , Nothing
-                            )
-                    , AP.grantStart     = Just now
-                    , AP.grantEnd       = Nothing
-                    , AP.grantAllows    = AP.Invoke
-                    , AP.grantDelegates = Just uStart
-                    }
-                }
-
-        return (action, recipientSet, remoteActors, fwdHosts)
-
 checkExistingComponents
     :: ProjectId -> Either (ComponentBy Entity) RemoteActorId -> ActDBE ()
 checkExistingComponents projectID componentDB = do
@@ -952,7 +826,7 @@ projectCreateMe
     -> ActE (Text, Act (), Next)
 projectCreateMe =
     topicCreateMe
-        projectActor GrantResourceProject
+        projectActor LocalActorProject
         CollabTopicProjectProject CollabTopicProject
 
 projectCreate
@@ -1005,7 +879,7 @@ projectFollow now recipProjectID verse follow = do
 
 -- Meaning: An actor is granting access-to-some-resource to another actor
 -- Behavior:
---      * Verify that:
+--      * Option 1 - Component sending me a delegation-start - Verify that:
 --          * The sender is a component of mine, C
 --          * The Grant's context is C
 --          * The Grant's target is me
@@ -1019,14 +893,37 @@ projectFollow now recipProjectID verse follow = do
 --      * Insert the Grant to my inbox
 --      * Record the delegation in the Component record in DB
 --      * Forward the Grant to my followers
---      * For each person (non-team) collaborator of mine, prepare and send a
+--      * For each person (non-team) collaborator of mine, prepare and send an
---        Grant, and store it in the Componet record in DB:
+--        extension-Grant, and store it in the Componet record in DB:
 --          * Role: The lower among (1) admin (2) the collaborator's role in me
 --          * Resource: C
 --          * Target: The collaborator
 --          * Delegates: The Grant I just got from C
 --          * Result: ProjectCollabLiveR for this collaborator
 --          * Usage: invoke
+--
+--      * Option 2 - Collaborator sending me a delegator-Grant - Verify that:
+--          * The sender is a collaborator of mine, A
+--          * The Grant's context is A
+--          * The Grant's target is me
+--          * The Grant's usage is invoke & role is delegate
+--          * The Grant doesn't specify 'delegates'
+--          * The activity is authorized via a valid direct-Grant I had sent
+--            to A
+--      * Verify I don't yet have a delegator-Grant from A
+--      * Insert the Grant to my inbox
+--      * Record the delegator-Grant in the Collab record in DB
+--      * Forward the Grant to my followers
+--      * For each component of mine C, prepare and send an
+--        extension-Grant to A, and store it in the Componet record in DB:
+--          * Role: The lower among (1) admin (2) the collaborator's role in me
+--          * Resource: C
+--          * Target: A
+--          * Delegates: The start-Grant I have from C
+--          * Result: ProjectCollabLiveR for this collaborator, A
+--          * Usage: invoke
+--
+--      * If neither 1 nor 2, raise an error
 projectGrant
     :: UTCTime
     -> ProjectId
@@ -1055,7 +952,76 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
             _ -> throwE "Capability is remote i.e. definitely not by me"
 
     -- Check grant
-    (role, component) <- checkDelegationStart grant
+    grant' <-
+        Left <$> checkDelegationStart grant <|>
+        Right <$> checkDelegator grant
+
+    case grant' of
+        Left (role, component) -> handleComp capability role component
+        Right collab -> handleCollab capability collab
+
+    where
+
+    checkDelegationStart g = do
+        (role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <-
+            parseGrant' g
+        role' <-
+            case role of
+                AP.RXRole r -> pure r
+                AP.RXDelegator -> throwE "Role is delegator"
+        component <-
+            fromMaybeE
+                (bitraverse actorToComponent Just resource)
+                "Resource is a local project, therefore not a component of mine"
+        case (component, authorIdMsig) of
+            (Left c, Left (a, _, _)) | componentActor c == a -> pure ()
+            (Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure ()
+            _ -> throwE "Author and context aren't the same actor"
+        case recipient of
+            Left (GrantRecipProject' j) | j == projectID -> pure ()
+            _ -> throwE "Target isn't me"
+        for_ mstart $ \ start ->
+            unless (start < now) $ throwE "Start time is in the future"
+        for_ mend $ \ _ ->
+            throwE "End time is specified"
+        unless (usage == AP.GatherAndConvey) $
+            throwE "Usage isn't GatherAndConvey"
+        for_ mdeleg $ \ _ ->
+            throwE "'delegates' is specified"
+        return (role', component)
+
+    checkDelegator g = do
+        (role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <-
+            parseGrant' g
+        case role of
+            AP.RXRole _ -> throwE "Role isn't delegator"
+            AP.RXDelegator -> pure ()
+        collab <-
+            bitraverse
+                (\case
+                    LocalActorPerson p -> pure p
+                    _ -> throwE "Local resource isn't a Person, therefore not a collaborator of mine"
+                )
+                pure
+                resource
+        case (collab, authorIdMsig) of
+            (Left c, Left (a, _, _)) | LocalActorPerson c == a -> pure ()
+            (Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure ()
+            _ -> throwE "Author and context aren't the same actor"
+        case recipient of
+            Left (GrantRecipProject' j) | j == projectID -> pure ()
+            _ -> throwE "Target isn't me"
+        for_ mstart $ \ start ->
+            unless (start < now) $ throwE "Start time is in the future"
+        for_ mend $ \ _ ->
+            throwE "End time is specified"
+        unless (usage == AP.Invoke) $
+            throwE "Usage isn't Invoke"
+        for_ mdeleg $ \ _ ->
+            throwE "'delegates' is specified"
+        return collab
+
+    handleComp capability role component = do
 
         maybeNew <- withDBExcept $ do
 
@@ -1109,44 +1075,44 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
                 -- For each Collab in me, prepare a delegation-extension Grant
                 localCollabs <-
                     lift $
-                E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` recipL) -> do
+                    E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` recipL `E.InnerJoin` deleg) -> do
+                        E.on $ enable E.^. CollabEnableId E.==. deleg E.^. CollabDelegLocalEnable
                         E.on $ enable E.^. CollabEnableCollab E.==. recipL E.^. CollabRecipLocalCollab
                         E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab
                         E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId
                         E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID
                         return
                             ( collab E.^. CollabRole
-                        , recipL E.^. CollabRecipLocalId
                             , recipL E.^. CollabRecipLocalPerson
-                        , enable E.^. CollabEnableId
+                            , deleg
                             )
-            localExtensions <- lift $ for localCollabs $ \ (E.Value role', E.Value recipID, E.Value personID, E.Value enableID') -> do
+                localExtensions <- lift $ for localCollabs $ \ (E.Value role', E.Value personID, Entity delegID (CollabDelegLocal enableID' recipID grantID)) -> do
                     extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
-                insert_ $ ComponentFurtherLocal enableID recipID extID
+                    insert_ $ ComponentFurtherLocal enableID delegID extID
                     ext@(actionExt, _, _, _) <-
-                    prepareExtensionGrant identForCheck (Left personID) (min role role') enableID'
+                        prepareExtensionGrant identForCheck (Left (personID, grantID)) (min role role') enableID'
                     let recipByKey = LocalActorProject projectID
                     _luExt <- updateOutboxItem' recipByKey extID actionExt
                     return (extID, ext)
 
                 remoteCollabs <-
                     lift $
-                E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` recipR) -> do
+                    E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` recipR `E.InnerJoin` deleg) -> do
+                        E.on $ enable E.^. CollabEnableId E.==. deleg E.^. CollabDelegRemoteEnable
                         E.on $ enable E.^. CollabEnableCollab E.==. recipR E.^. CollabRecipRemoteCollab
                         E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab
                         E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId
                         E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID
                         return
                             ( collab E.^. CollabRole
-                        , recipR E.^. CollabRecipRemoteId
                             , recipR E.^. CollabRecipRemoteActor
-                        , enable E.^. CollabEnableId
+                            , deleg
                             )
-            remoteExtensions <- lift $ for remoteCollabs $ \ (E.Value role', E.Value recipID, E.Value raID, E.Value enableID') -> do
+                remoteExtensions <- lift $ for remoteCollabs $ \ (E.Value role', E.Value raID, Entity delegID (CollabDelegRemote enableID' recipID grantID)) -> do
                     extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
-                insert_ $ ComponentFurtherRemote enableID recipID extID
+                    insert_ $ ComponentFurtherRemote enableID delegID extID
                     ext@(actionExt, _, _, _) <-
-                    prepareExtensionGrant identForCheck (Right raID) (min role role') enableID'
+                        prepareExtensionGrant identForCheck (Right (raID, grantID)) (min role role') enableID'
                     let recipByKey = LocalActorProject projectID
                     _luExt <- updateOutboxItem' recipByKey extID actionExt
                     return (extID, ext)
@@ -1163,38 +1129,10 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
                         sendActivity
                             recipByID recipActorID localRecipsExt
                             remoteRecipsExt fwdHostsExt extID actionExt
-            done "Forwarded the Grant and published delegation extensions"
+                done "Forwarded the start-Grant and published delegation extensions"
 
         where
 
-    checkDelegationStart g = do
-        (role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <-
-            parseGrant' g
-        role' <-
-            case role of
-                AP.RXRole r -> pure r
-                AP.RXDelegator -> throwE "Role is delegator"
-        component <-
-            fromMaybeE
-                (bitraverse resourceToComponent Just resource)
-                "Resource is a local project, therefore not a component of mine"
-        case (component, authorIdMsig) of
-            (Left c, Left (a, _, _)) | componentActor c == a -> pure ()
-            (Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure ()
-            _ -> throwE "Author and context aren't the same actor"
-        case recipient of
-            Left (GrantRecipProject' j) | j == projectID -> pure ()
-            _ -> throwE "Target isn't me"
-        for_ mstart $ \ start ->
-            unless (start < now) $ throwE "Start time is in the future"
-        for_ mend $ \ _ ->
-            throwE "End time is specified"
-        unless (usage == AP.GatherAndConvey) $
-            throwE "Usage isn't GatherAndConvey"
-        for_ mdeleg $ \ _ ->
-            throwE "'delegates' is specified"
-        return (role', component)
-
         prepareExtensionGrant component collab role enableID = do
             encodeRouteHome <- getEncodeRouteHome
             encodeRouteLocal <- getEncodeRouteLocal
@@ -1202,18 +1140,24 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
             projectHash <- encodeKeyHashid projectID
             uStart <- lift $ getActivityURI authorIdMsig
 
-        (uCollab, audCollab) <-
+            (uCollab, audCollab, uDeleg) <-
                 case collab of
-                Left personID -> do
+                    Left (personID, itemID) -> do
                         personHash <- encodeKeyHashid personID
+                        itemHash <- encodeKeyHashid itemID
                         return
                             ( encodeRouteHome $ PersonR personHash
                             , AudLocal [LocalActorPerson personHash] []
+                            , encodeRouteHome $
+                                PersonOutboxItemR personHash itemHash
                             )
-                Right raID -> do
+                    Right (raID, ractID) -> do
                         ra <- getJust raID
                         u@(ObjURI h lu) <- getRemoteActorURI ra
-                    return (u, AudRemote h [lu] [])
+                        uAct <- do
+                            ract <- getJust ractID
+                            getRemoteActivityURI ract
+                        return (u, AudRemote h [lu] [], uAct)
 
             uComponent <-
                 case component of
@@ -1231,7 +1175,195 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
 
                 recips = map encodeRouteHome audLocal ++ audRemote
                 action = AP.Action
-                { AP.actionCapability = Nothing
+                    { AP.actionCapability = Just uDeleg
+                    , AP.actionSummary    = Nothing
+                    , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                    , AP.actionFulfills   = [uStart]
+                    , AP.actionSpecific   = AP.GrantActivity AP.Grant
+                        { AP.grantObject    = AP.RXRole role
+                        , AP.grantContext   = uComponent
+                        , AP.grantTarget    = uCollab
+                        , AP.grantResult    =
+                            Just
+                                (encodeRouteLocal $
+                                    ProjectCollabLiveR projectHash enableHash
+                                , Nothing
+                                )
+                        , AP.grantStart     = Just now
+                        , AP.grantEnd       = Nothing
+                        , AP.grantAllows    = AP.Invoke
+                        , AP.grantDelegates = Just uStart
+                        }
+                    }
+
+            return (action, recipientSet, remoteActors, fwdHosts)
+
+    handleCollab capability collab = do
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            (recipActorID, recipActor) <- lift $ do
+                recip <- getJust projectID
+                let actorID = projectActor recip
+                (actorID,) <$> getJust actorID
+
+            -- Find the Collab record from the capability
+            Entity enableID (CollabEnable collabID _) <- do
+                unless (fst capability == LocalActorProject projectID) $
+                    throwE "Capability isn't mine"
+                m <- lift $ getBy $ UniqueCollabEnableGrant $ snd capability
+                fromMaybeE m "I don't have a Collab with this capability"
+            Collab role <- lift $ getJust collabID
+            topic <- lift $ getCollabTopic collabID
+            unless (topic == LocalActorProject projectID) $
+                throwE "Found a Collab for this direct-Grant but it's not mine"
+            recip <- lift $ getCollabRecip collabID
+            recipForCheck <-
+                lift $
+                bitraverse
+                    (pure . collabRecipLocalPerson . entityVal)
+                    (getRemoteActorURI <=< getJust . collabRecipRemoteActor . entityVal)
+                    recip
+            unless (recipForCheck == collab) $
+                throwE "Capability's collaborator and Grant author aren't the same actor"
+
+            -- Verify I don't yet have a delegator-Grant from the collaborator
+            maybeDeleg <-
+                lift $ case bimap entityKey entityKey recip of
+                    Left localID -> (() <$) <$> getBy (UniqueCollabDelegLocalRecip localID)
+                    Right remoteID -> (() <$) <$> getBy (UniqueCollabDelegRemoteRecip remoteID)
+            verifyNothingE maybeDeleg "I already have a delegator-Grant from this collaborator"
+
+            maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
+            for maybeGrantDB $ \ grantDB -> do
+
+                -- Record the delegator-Grant in the Collab record
+                (insertExt, uDeleg) <-
+                    lift $ case (grantDB, bimap entityKey entityKey recip) of
+                        (Left (grantActor, _, grantID), Left localID) -> do
+                            delegID <- insert $ CollabDelegLocal enableID localID grantID
+                            encodeRouteHome <- getEncodeRouteHome
+                            delegR <-
+                                activityRoute
+                                    <$> hashLocalActor grantActor
+                                    <*> encodeKeyHashid grantID
+                            return
+                                (\ enableID furtherID ->
+                                    insert_ $ ComponentFurtherLocal enableID delegID furtherID
+                                , encodeRouteHome delegR
+                                )
+                        (Right (_, _, grantID), Right remoteID) -> do
+                            delegID <- insert $ CollabDelegRemote enableID remoteID grantID
+                            u <- getRemoteActivityURI =<< getJust grantID
+                            return
+                                (\ enableID furtherID ->
+                                    insert_ $ ComponentFurtherRemote enableID delegID furtherID
+                                , u
+                                )
+                        _ -> error "projectGrant impossible 2"
+
+                -- Prepare forwarding of Accept to my followers
+                projectHash <- encodeKeyHashid projectID
+                let sieve = makeRecipientSet [] [LocalStageProjectFollowers projectHash]
+
+                -- For each Component of mine, prepare a delegation-extension
+                -- Grant
+                extensions <- lift $ do
+                    locals <-
+                        fmap (map $ over _1 Left) $
+                        E.select $ E.from $ \ (deleg `E.InnerJoin` local `E.InnerJoin` comp `E.InnerJoin` enable) -> do
+                            E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent
+                            E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId
+                            E.on $ deleg E.^. ComponentDelegateLocalComponent E.==.local E.^. ComponentLocalId
+                            E.where_ $ comp E.^. ComponentProject E.==. E.val projectID
+                            return (deleg E.^. ComponentDelegateLocalGrant, comp, enable)
+                    remotes <-
+                        fmap (map $ over _1 Right) $
+                        E.select $ E.from $ \ (deleg `E.InnerJoin` remote `E.InnerJoin` comp `E.InnerJoin` enable) -> do
+                            E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent
+                            E.on $ remote E.^. ComponentRemoteComponent E.==. comp E.^. ComponentId
+                            E.on $ deleg E.^. ComponentDelegateRemoteComponent E.==.remote E.^. ComponentRemoteId
+                            E.where_ $ comp E.^. ComponentProject E.==. E.val projectID
+                            return (deleg E.^. ComponentDelegateRemoteGrant, comp, enable)
+                    (uCollab, audCollab) <-
+                        case recip of
+                            Left (Entity _ (CollabRecipLocal _ personID)) -> do
+                                personHash <- encodeKeyHashid personID
+                                encodeRouteHome <- getEncodeRouteHome
+                                return
+                                    ( encodeRouteHome $ PersonR personHash
+                                    , AudLocal [LocalActorPerson personHash] []
+                                    )
+                            Right (Entity _ (CollabRecipRemote _ raID)) -> do
+                                ra <- getJust raID
+                                u@(ObjURI h lu) <- getRemoteActorURI ra
+                                return (u, AudRemote h [lu] [])
+                    for (locals ++ remotes) $ \ (start, Entity componentID component, Entity enableID' _) -> do
+                        extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
+                        insertExt enableID' extID
+                        componentIdent <- do
+                            i <- getComponentIdent componentID
+                            bitraverse
+                                (pure . snd)
+                                (\ (_, raID) -> getRemoteActorURI =<< getJust raID)
+                                i
+                        uStart <-
+                            case start of
+                                Left (E.Value startID) -> do
+                                    encodeRouteHome <- getEncodeRouteHome
+                                    c <-
+                                        case componentIdent of
+                                            Left ci -> hashComponent ci
+                                            Right _ -> error "Delegation-start Grant URI is local, but component found to be remote, impossible"
+                                    s <- encodeKeyHashid startID
+                                    return $ encodeRouteHome $ activityRoute (componentActor c) s
+                                Right (E.Value remoteActivityID) -> do
+                                    ra <- getJust remoteActivityID
+                                    getRemoteActivityURI ra
+                        ext@(actionExt, _, _, _) <-
+                            prepareExtensionGrant uCollab audCollab uDeleg componentIdent uStart (min role (componentRole component)) enableID
+                        let recipByKey = LocalActorProject projectID
+                        _luExt <- updateOutboxItem' recipByKey extID actionExt
+                        return (extID, ext)
+
+                return (recipActorID, sieve, extensions)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (recipActorID, sieve, extensions) -> do
+                let recipByID = LocalActorProject projectID
+                forwardActivity authorIdMsig body recipByID recipActorID sieve
+                lift $ for_ extensions $
+                    \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) ->
+                        sendActivity
+                            recipByID recipActorID localRecipsExt
+                            remoteRecipsExt fwdHostsExt extID actionExt
+                done "Forwarded the delegator-Grant, updated DB and published delegation extensions"
+
+        where
+
+        prepareExtensionGrant uCollab audCollab uDeleg component uStart role enableID = do
+            encodeRouteHome <- getEncodeRouteHome
+            encodeRouteLocal <- getEncodeRouteLocal
+
+            projectHash <- encodeKeyHashid projectID
+
+            uComponent <-
+                case component of
+                    Left c -> do
+                        a <- componentActor <$> hashComponent c
+                        return $ encodeRouteHome $ renderLocalActor a
+                    Right u -> pure u
+
+            enableHash <- encodeKeyHashid enableID
+
+            let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                    collectAudience [audCollab]
+
+                recips = map encodeRouteHome audLocal ++ audRemote
+                action = AP.Action
+                    { AP.actionCapability = Just uDeleg
                     , AP.actionSummary    = Nothing
                     , AP.actionAudience   = AP.Audience recips [] [] [] [] []
                     , AP.actionFulfills   = [uStart]
@@ -1311,7 +1443,7 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
         (role, resourceOrComps, recipientOrComp) <- parseInvite author invite
         mode <-
             case resourceOrComps of
-                Left (Left (GrantResourceProject j)) | j == projectID ->
+                Left (Left (LocalActorProject j)) | j == projectID ->
                     Left <$>
                         bitraverse
                             (\case
@@ -1363,7 +1495,7 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
 
         -- Verify the specified capability gives relevant access
         verifyCapability'
-            capability authorIdMsig (GrantResourceProject projectID) AP.RoleAdmin
+            capability authorIdMsig (LocalActorProject projectID) AP.RoleAdmin
 
         case invitedDB of
 
@@ -1538,7 +1670,7 @@ projectJoin
     -> ActE (Text, Act (), Next)
 projectJoin =
     topicJoin
-        projectActor GrantResourceProject
+        projectActor LocalActorProject
         CollabTopicProjectProject CollabTopicProjectCollab CollabTopicProject
 
 -- Meaning: An actor rejected something
@@ -1564,7 +1696,7 @@ projectReject
     -> Verse
     -> AP.Reject URIMode
     -> ActE (Text, Act (), Next)
-projectReject = topicReject projectActor GrantResourceProject
+projectReject = topicReject projectActor LocalActorProject
 
 -- Meaning: An actor A is removing actor B from a resource
 -- Behavior:
@@ -1585,7 +1717,7 @@ projectRemove
     -> ActE (Text, Act (), Next)
 projectRemove =
     topicRemove
-        projectActor GrantResourceProject
+        projectActor LocalActorProject
         CollabTopicProjectProject CollabTopicProjectCollab
 
 -- Meaning: An actor is undoing some previous action

src/Vervis/Client.hs

@@ -1120,7 +1120,7 @@ invite personID uRecipient uResourceCollabs role = do
             resource
     resourceDB <-
         bitraverse
-            hashGrantResource
+            VR.hashLocalActor
             (\ u@(ObjURI h lu) -> do
                 instanceID <-
                     lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
@@ -1158,16 +1158,7 @@ invite personID uRecipient uResourceCollabs role = do
 
     let audResource =
             case resourceDB of
-                Left (GrantResourceRepo r) ->
+                Left la -> AudLocal [la] [localActorFollowers la]
-                    AudLocal [LocalActorRepo r] [LocalStageRepoFollowers r]
-                Left (GrantResourceDeck d) ->
-                    AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d]
-                Left (GrantResourceLoom l) ->
-                    AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l]
-                Left (GrantResourceProject l) ->
-                    AudLocal [LocalActorProject l] [LocalStageProjectFollowers l]
-                Left (GrantResourceGroup l) ->
-                    AudLocal [LocalActorGroup l] [LocalStageGroupFollowers l]
                 Right (remoteActor, ObjURI h lu) ->
                     AudRemote h
                         [lu]
@@ -1237,7 +1228,7 @@ remove personID uRecipient uResourceCollabs = do
     -- managing actor & followers collection
     resourceDB <-
         bitraverse
-            hashGrantResource
+            VR.hashLocalActor
             (\ u@(ObjURI h lu) -> do
                 instanceID <-
                     lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
@@ -1275,16 +1266,7 @@ remove personID uRecipient uResourceCollabs = do
 
     let audResource =
             case resourceDB of
-                Left (GrantResourceRepo r) ->
+                Left la -> AudLocal [la] [localActorFollowers la]
-                    AudLocal [LocalActorRepo r] [LocalStageRepoFollowers r]
-                Left (GrantResourceDeck d) ->
-                    AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d]
-                Left (GrantResourceLoom l) ->
-                    AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l]
-                Left (GrantResourceProject l) ->
-                    AudLocal [LocalActorProject l] [LocalStageProjectFollowers l]
-                Left (GrantResourceGroup l) ->
-                    AudLocal [LocalActorGroup l] [LocalStageGroupFollowers l]
                 Right (remoteActor, ObjURI h lu) ->
                     AudRemote h
                         [lu]

src/Vervis/Data/Collab.hs

@@ -33,26 +33,12 @@ module Vervis.Data.Collab
 
     , grantResourceActorID
 
-    , GrantResourceBy (..)
-    , unhashGrantResourcePure
-    , unhashGrantResource
-    , unhashGrantResourceE
-    , unhashGrantResource'
-    , unhashGrantResourceE'
-    , unhashGrantResource404
-    , hashGrantResource
-    , hashGrantResource'
-    , getGrantResource
-    , getGrantResource404
-
-    , grantResourceLocalActor
-
     , ComponentBy (..)
     , parseComponent
     , hashComponent
     , unhashComponentE
     , componentActor
-    , resourceToComponent
+    , actorToComponent
 
     , GrantRecipBy' (..)
     , hashGrantRecip'
@@ -96,18 +82,11 @@ import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 
-parseGrantResource (RepoR r) = Just $ GrantResourceRepo r
+parseGrantResourceCollabs (RepoCollabsR r) = Just $ LocalActorRepo r
-parseGrantResource (DeckR d) = Just $ GrantResourceDeck d
+parseGrantResourceCollabs (DeckCollabsR d) = Just $ LocalActorDeck d
-parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
+parseGrantResourceCollabs (LoomCollabsR l) = Just $ LocalActorLoom l
-parseGrantResource (ProjectR l) = Just $ GrantResourceProject l
+parseGrantResourceCollabs (ProjectCollabsR l) = Just $ LocalActorProject l
-parseGrantResource (GroupR l) = Just $ GrantResourceGroup l
+parseGrantResourceCollabs (GroupMembersR l) = Just $ LocalActorGroup l
-parseGrantResource _         = Nothing
-
-parseGrantResourceCollabs (RepoCollabsR r) = Just $ GrantResourceRepo r
-parseGrantResourceCollabs (DeckCollabsR d) = Just $ GrantResourceDeck d
-parseGrantResourceCollabs (LoomCollabsR l) = Just $ GrantResourceLoom l
-parseGrantResourceCollabs (ProjectCollabsR l) = Just $ GrantResourceProject l
-parseGrantResourceCollabs (GroupMembersR l) = Just $ GrantResourceGroup l
 parseGrantResourceCollabs _         = Nothing
 
 data GrantRecipBy f = GrantRecipPerson (f Person)
@@ -144,7 +123,7 @@ verifyRole = pure
 
 parseTopic
     :: StageRoute Env ~ Route App
-    => FedURI -> ActE (Either (GrantResourceBy Key) FedURI)
+    => FedURI -> ActE (Either (LocalActorBy Key) FedURI)
 parseTopic u = do
     t <- parseTopic' u
     bitraverse
@@ -158,7 +137,7 @@ parseTopic u = do
 parseTopic'
     :: StageRoute Env ~ Route App
     => FedURI
-    -> ActE (Either (Either (GrantResourceBy Key) ProjectId) FedURI)
+    -> ActE (Either (Either (LocalActorBy Key) ProjectId) FedURI)
 parseTopic' u = do
     routeOrRemote <- parseFedURI u
     bitraverse
@@ -170,7 +149,7 @@ parseTopic' u = do
                     fromMaybeE
                         (parseGrantResourceCollabs route)
                         "Not a shared resource collabs route"
-                unhashGrantResourceE'
+                unhashLocalActorE
                     resourceHash
                     "Contains invalid hashid"
         )
@@ -242,7 +221,7 @@ parseInvite
     -> AP.Invite URIMode
     -> ActE
         ( AP.Role
-        , Either (Either (GrantResourceBy Key) ProjectId) FedURI
+        , Either (Either (LocalActorBy Key) ProjectId) FedURI
         , Either (Either (GrantRecipBy Key) (ComponentBy Key)) FedURI
         )
 parseInvite sender (AP.Invite instrument object target) =
@@ -254,7 +233,7 @@ parseInvite sender (AP.Invite instrument object target) =
 parseJoin
     :: StageRoute Env ~ Route App
     => AP.Join URIMode
-    -> ActE (AP.Role, Either (GrantResourceBy Key) FedURI)
+    -> ActE (AP.Role, Either (LocalActorBy Key) FedURI)
 parseJoin (AP.Join instrument object) =
     (,) <$> verifyRole instrument
         <*> nameExceptT "Join object" (parseTopic object)
@@ -264,7 +243,7 @@ parseGrant
     -> AP.Grant URIMode
     -> ActE
         ( AP.RoleExt
-        , Either (GrantResourceBy Key) LocalURI
+        , Either (LocalActorBy Key) LocalURI
         , Either (GrantRecipBy Key) FedURI
         , Maybe (LocalURI, Maybe Int)
         , Maybe UTCTime
@@ -298,13 +277,7 @@ parseGrant h (AP.Grant object context target mresult mstart mend allows deleg) =
                     fromMaybeE
                         (decodeRouteLocal lu)
                         "Grant context isn't a valid route"
-                resourceHash <-
+                parseLocalActorE' route
-                    fromMaybeE
-                        (parseGrantResource route)
-                        "Grant context isn't a shared resource route"
-                unhashGrantResourceE'
-                    resourceHash
-                    "Grant resource contains invalid hashid"
             else pure $ Right lu
     parseTarget u@(ObjURI h lu) = do
         hl <- hostIsLocal h
@@ -327,7 +300,7 @@ parseGrant'
     :: AP.Grant URIMode
     -> ActE
         ( AP.RoleExt
-        , Either (GrantResourceBy Key) FedURI
+        , Either (LocalActorBy Key) FedURI
         , Either (GrantRecipBy' Key) FedURI
         , Maybe (LocalURI, Maybe Int)
         , Maybe UTCTime
@@ -358,13 +331,7 @@ parseGrant' (AP.Grant object context target mresult mstart mend allows deleg) =
                     fromMaybeE
                         (decodeRouteLocal lu)
                         "Grant context isn't a valid route"
-                resourceHash <-
+                parseLocalActorE' route
-                    fromMaybeE
-                        (parseGrantResource route)
-                        "Grant context isn't a shared resource route"
-                unhashGrantResourceE'
-                    resourceHash
-                    "Grant resource contains invalid hashid"
             else pure $ Right u
     parseTarget u@(ObjURI h lu) = do
         hl <- hostIsLocal h
@@ -397,7 +364,7 @@ parseRemove
     => Either (LocalActorBy Key) FedURI
     -> AP.Remove URIMode
     -> ActE
-        ( Either (Either (GrantResourceBy Key) ProjectId) FedURI
+        ( Either (Either (LocalActorBy Key) ProjectId) FedURI
         , Either (Either (GrantRecipBy Key) (ComponentBy Key)) FedURI
         )
 parseRemove sender (AP.Remove object origin) =
@@ -453,104 +420,13 @@ parseAdd sender (AP.Add object target role) = do
             pure
             routeOrRemote
 
-grantResourceActorID :: GrantResourceBy Identity -> ActorId
+grantResourceActorID :: LocalActorBy Identity -> ActorId
-grantResourceActorID (GrantResourceRepo (Identity r)) = repoActor r
+grantResourceActorID (LocalActorPerson (Identity p)) = personActor p
-grantResourceActorID (GrantResourceDeck (Identity d)) = deckActor d
+grantResourceActorID (LocalActorRepo (Identity r)) = repoActor r
-grantResourceActorID (GrantResourceLoom (Identity l)) = loomActor l
+grantResourceActorID (LocalActorDeck (Identity d)) = deckActor d
-grantResourceActorID (GrantResourceProject (Identity j)) = projectActor j
+grantResourceActorID (LocalActorLoom (Identity l)) = loomActor l
-grantResourceActorID (GrantResourceGroup (Identity g)) = groupActor g
+grantResourceActorID (LocalActorProject (Identity j)) = projectActor j
-
+grantResourceActorID (LocalActorGroup (Identity g)) = groupActor g
-data GrantResourceBy f
-    = GrantResourceRepo (f Repo)
-    | GrantResourceDeck (f Deck)
-    | GrantResourceLoom (f Loom)
-    | GrantResourceProject (f Project)
-    | GrantResourceGroup (f Group)
-    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
-    f (GrantResourceProject l) =
-        GrantResourceProject <$> decodeKeyHashidPure ctx l
-    f (GrantResourceGroup l) =
-        GrantResourceGroup <$> 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 (GrantResourceProject k) =
-    GrantResourceProject <$> encodeKeyHashid k
-hashGrantResource (GrantResourceGroup k) =
-    GrantResourceGroup <$> encodeKeyHashid k
-
-hashGrantResource' (GrantResourceRepo k) =
-    GrantResourceRepo <$> WAP.encodeKeyHashid k
-hashGrantResource' (GrantResourceDeck k) =
-    GrantResourceDeck <$> WAP.encodeKeyHashid k
-hashGrantResource' (GrantResourceLoom k) =
-    GrantResourceLoom <$> WAP.encodeKeyHashid k
-hashGrantResource' (GrantResourceProject k) =
-    GrantResourceProject <$> WAP.encodeKeyHashid k
-hashGrantResource' (GrantResourceGroup k) =
-    GrantResourceGroup <$> 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
-getGrantResource (GrantResourceProject k) e =
-    GrantResourceProject <$> getEntityE k e
-getGrantResource (GrantResourceGroup k) e =
-    GrantResourceGroup <$> 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
-    getGrantResourceEntity (GrantResourceProject k) =
-        fmap GrantResourceProject <$> getEntity k
-    getGrantResourceEntity (GrantResourceGroup k) =
-        fmap GrantResourceGroup <$> getEntity k
-
-grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f
-grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r
-grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d
-grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l
-grantResourceLocalActor (GrantResourceProject l) = LocalActorProject l
-grantResourceLocalActor (GrantResourceGroup l) = LocalActorGroup l
 
 data ComponentBy f
     = ComponentRepo (f Repo)
@@ -588,12 +464,13 @@ componentActor (ComponentRepo r) = LocalActorRepo r
 componentActor (ComponentDeck d) = LocalActorDeck d
 componentActor (ComponentLoom l) = LocalActorLoom l
 
-resourceToComponent = \case
+actorToComponent = \case
-    GrantResourceRepo k -> Just $ ComponentRepo k
+    LocalActorPerson _ -> Nothing
-    GrantResourceDeck k -> Just $ ComponentDeck k
+    LocalActorRepo k -> Just $ ComponentRepo k
-    GrantResourceLoom k -> Just $ ComponentLoom k
+    LocalActorDeck k -> Just $ ComponentDeck k
-    GrantResourceProject _ -> Nothing
+    LocalActorLoom k -> Just $ ComponentLoom k
-    GrantResourceGroup _ -> Nothing
+    LocalActorProject _ -> Nothing
+    LocalActorGroup _ -> Nothing
 
 data GrantRecipBy' f
     = GrantRecipPerson' (f Person)

src/Vervis/Data/Ticket.hs

@@ -37,7 +37,6 @@ module Vervis.Data.Ticket
     , unhashWorkItemE
     , unhashWorkItem404
 
-    , workItemResource
     , workItemActor
     , workItemFollowers
     , workItemRoute
@@ -351,9 +350,6 @@ unhashWorkItem404 actor = maybe notFound return =<< unhashWorkItem actor
         ctx <- asksSite siteHashidsContext
         return $ unhashWorkItemPure ctx byHash
 
-workItemResource (WorkItemTicket deck _) = GrantResourceDeck deck
-workItemResource (WorkItemCloth loom _) = GrantResourceLoom loom
-
 workItemActor (WorkItemTicket deck _) = LocalActorDeck deck
 workItemActor (WorkItemCloth loom _) = LocalActorLoom loom
 

src/Vervis/Migration.hs

@@ -3066,6 +3066,59 @@ changes hLocal ctx =
                 outboxID <- actor553Outbox <$> getJust actorID
                 itemID <- insert $ OutboxItem553 outboxID doc defaultTime
                 insert_ $ CollabDelegLocal553 enableID recipID itemID
+      -- 554
+    , addFieldRefRequired''
+        "ComponentFurtherLocal"
+        (do collabID <- insert $ Collab554 RoleVisit
+            outboxID <- insert Outbox554
+            let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
+            itemID <- insert $ OutboxItem554 outboxID doc defaultTime
+            enableID <- insert $ CollabEnable554 collabID itemID
+            personID <- do
+                mp <- selectFirst [] [Asc Person554Id]
+                entityKey <$> maybe (error "No people") return mp
+            recipID <- insert $ CollabRecipLocal554 collabID personID
+            insertEntity $ CollabDelegLocal554 enableID recipID itemID
+        )
+        (Just $ \ (Entity cdlidTemp cdlTemp) -> do
+            l <- selectList [] []
+            for_ l $ \ (Entity cflid (ComponentFurtherLocal554 _ recipID _ _)) -> do
+                mk <- getKeyBy $ UniqueCollabDelegLocalRecip554 recipID
+                case mk of
+                    Nothing -> error "Found ComponentFurtherLocal whose CollabRecipLocal doesn't have a CollabDelegLocal, previous migration should have created it"
+                    Just k -> update cflid [ComponentFurtherLocal554CollabNew =. k]
+
+            delete cdlidTemp
+            let CollabDelegLocal554 enableID recipID itemID = cdlTemp
+            delete recipID
+            collabID <- collabEnable554Collab <$> getJust enableID
+            delete enableID
+            outboxID <- outboxItem554Outbox <$> getJust itemID
+            delete itemID
+            delete outboxID
+            delete collabID
+        )
+        "collabNew"
+        "CollabDelegLocal"
+      -- 555
+    , addFieldRefRequiredEmpty
+        "ComponentFurtherRemote" "collabNew" "CollabDelegRemote"
+      -- 556
+    , removeUnique' "ComponentFurtherLocal" ""
+      -- 557
+    , removeField "ComponentFurtherLocal" "collab"
+      -- 558
+    , renameField "ComponentFurtherLocal" "collabNew" "collab"
+      -- 559
+    , addUnique' "ComponentFurtherLocal" "" ["component", "collab"]
+      -- 560
+    , removeUnique' "ComponentFurtherRemote" ""
+      -- 561
+    , removeField "ComponentFurtherRemote" "collab"
+      -- 562
+    , renameField "ComponentFurtherRemote" "collabNew" "collab"
+      -- 563
+    , addUnique' "ComponentFurtherRemote" "" ["component", "collab"]
     ]
 
 migrateDB

src/Vervis/Migration/Model.hs

@@ -534,3 +534,6 @@ makeEntitiesMigration "549"
 
 makeEntitiesMigration "553"
     $(modelFile "migrations/553_2023-11-21_collab_deleg.model")
+
+makeEntitiesMigration "554"
+    $(modelFile "migrations/554_2023-11-21_further_local_deleg.model")

src/Vervis/Persist/Actor.hs

@@ -17,8 +17,12 @@ module Vervis.Persist.Actor
     ( getLocalActor
     , getLocalActorEnt
     , getLocalActorEntity
+    , getLocalActorEntityE
+    , getLocalActorEntity404
     , verifyLocalActivityExistsInDB
+    , getRemoteObjectURI
     , getRemoteActorURI
+    , getRemoteActivityURI
     , insertActor
     , updateOutboxItem
     , updateOutboxItem'
@@ -39,6 +43,7 @@ import Data.Text (Text)
 import Data.Traversable
 import Database.Persist
 import Database.Persist.Sql
+import Yesod.Core.Handler
 
 import qualified Data.Text as T
 import qualified Database.Esqueleto as E
@@ -110,6 +115,14 @@ getLocalActorEntity (LocalActorLoom l) =
 getLocalActorEntity (LocalActorProject r) =
     fmap (LocalActorProject . Entity r) <$> get r
 
+getLocalActorEntityE a e = do
+    m <- lift $ getLocalActorEntity a
+    case m of
+        Nothing -> throwE e
+        Just a' -> return a'
+
+getLocalActorEntity404 = maybe notFound return <=< getLocalActorEntity
+
 verifyLocalActivityExistsInDB
     :: MonadIO m
     => LocalActorBy Key
@@ -125,14 +138,21 @@ verifyLocalActivityExistsInDB actorByKey outboxItemID = do
     unless (itemActorByKey == actorByKey) $
         throwE "Actor-in-URI and Actor-owning-the-outbox-item-in-DB mismatch"
 
-getRemoteActorURI actor = do
+getRemoteObjectURI object = do
-    object <- getJust $ remoteActorIdent actor
     inztance <- getJust $ remoteObjectInstance object
     return $
         ObjURI
             (instanceHost inztance)
             (remoteObjectIdent object)
 
+getRemoteActorURI actor = do
+    object <- getJust $ remoteActorIdent actor
+    getRemoteObjectURI object
+
+getRemoteActivityURI act = do
+    object <- getJust $ remoteActivityIdent act
+    getRemoteObjectURI object
+
 insertActor now name desc mby = do
     ibid <- insert Inbox
     obid <- insert Outbox

src/Vervis/Persist/Collab.hs

@@ -16,6 +16,7 @@
 module Vervis.Persist.Collab
     ( getCollabTopic
     , getCollabTopic'
+    , getCollabRecip
     , getStemIdent
     , getStemProject
     , getGrantRecip
@@ -70,11 +71,11 @@ import Vervis.Model
 import Vervis.Persist.Actor
 
 getCollabTopic
-    :: MonadIO m => CollabId -> ReaderT SqlBackend m (GrantResourceBy Key)
+    :: MonadIO m => CollabId -> ReaderT SqlBackend m (LocalActorBy Key)
 getCollabTopic = fmap snd . getCollabTopic'
 
 getCollabTopic'
-    :: MonadIO m => CollabId -> ReaderT SqlBackend m (ReaderT SqlBackend m (), GrantResourceBy Key)
+    :: MonadIO m => CollabId -> ReaderT SqlBackend m (ReaderT SqlBackend m (), LocalActorBy Key)
 getCollabTopic' collabID = do
     maybeRepo <- getBy $ UniqueCollabTopicRepo collabID
     maybeDeck <- getBy $ UniqueCollabTopicDeck collabID
@@ -85,17 +86,29 @@ getCollabTopic' collabID = do
         case (maybeRepo, maybeDeck, maybeLoom, maybeProject, maybeGroup) of
             (Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic"
             (Just (Entity k r), Nothing, Nothing, Nothing, Nothing) ->
-                (delete k, GrantResourceRepo $ collabTopicRepoRepo r)
+                (delete k, LocalActorRepo $ collabTopicRepoRepo r)
             (Nothing, Just (Entity k d), Nothing, Nothing, Nothing) ->
-                (delete k, GrantResourceDeck $ collabTopicDeckDeck d)
+                (delete k, LocalActorDeck $ collabTopicDeckDeck d)
             (Nothing, Nothing, Just (Entity k l), Nothing, Nothing) ->
-                (delete k, GrantResourceLoom $ collabTopicLoomLoom l)
+                (delete k, LocalActorLoom $ collabTopicLoomLoom l)
             (Nothing, Nothing, Nothing, Just (Entity k l), Nothing) ->
-                (delete k, GrantResourceProject $ collabTopicProjectProject l)
+                (delete k, LocalActorProject $ collabTopicProjectProject l)
             (Nothing, Nothing, Nothing, Nothing, Just (Entity k l)) ->
-                (delete k, GrantResourceGroup $ collabTopicGroupGroup l)
+                (delete k, LocalActorGroup $ collabTopicGroupGroup l)
             _ -> error "Found Collab with multiple topics"
 
+getCollabRecip
+    :: MonadIO m
+    => CollabId
+    -> ReaderT SqlBackend m
+        (Either (Entity CollabRecipLocal) (Entity CollabRecipRemote))
+getCollabRecip collabID =
+    requireEitherAlt
+        (getBy $ UniqueCollabRecipLocal collabID)
+        (getBy $ UniqueCollabRecipRemote collabID)
+        "Collab without recip"
+        "Collab with both local and remote recip"
+
 getStemIdent :: MonadIO m => StemId -> ReaderT SqlBackend m (ComponentBy Key)
 getStemIdent stemID = do
     maybeRepo <- getValBy $ UniqueStemIdentRepo stemID
@@ -288,7 +301,7 @@ verifyCapability
     :: MonadIO m
     => (LocalActorBy Key, OutboxItemId)
     -> Either PersonId RemoteActorId
-    -> GrantResourceBy Key
+    -> LocalActorBy Key
     -> AP.Role
     -> ExceptT Text (ReaderT SqlBackend m) ()
 verifyCapability (capActor, capItem) actor resource requiredRole = do
@@ -320,7 +333,7 @@ verifyCapability (capActor, capItem) actor resource requiredRole = do
     topic <- lift $ getCollabTopic collabID
 
     -- Verify that topic is indeed the sender of the Grant
-    unless (grantResourceLocalActor topic == capActor) $
+    unless (topic == capActor) $
         error "Grant sender isn't the topic"
 
     -- Verify the topic matches the resource specified
@@ -338,7 +351,7 @@ verifyCapability'
     -> Either
         (LocalActorBy Key, ActorId, OutboxItemId)
         (RemoteAuthor, LocalURI, Maybe ByteString)
-    -> GrantResourceBy Key
+    -> LocalActorBy Key
     -> AP.Role
     -> ExceptT Text (ReaderT SqlBackend m) ()
 verifyCapability' cap actor resource role = do

src/Vervis/Persist/Ticket.hs

@@ -179,7 +179,7 @@ checkApplyDB actor capID (repoID, maybeBranch) (loomID, clothID, bundleID) = do
         case capID of
             Left (capActor, _, capItem) -> return (capActor, capItem)
             Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local loom"
-    verifyCapability capability actor (GrantResourceLoom loomID) AP.RoleWrite
+    verifyCapability capability actor (LocalActorLoom loomID) AP.RoleWrite
 
     -- Get the patches from DB, verify VCS match just in case
     diffs <- do

src/Vervis/Recipient.hs

@@ -770,28 +770,6 @@ localRecipSieve' sieve allowPeople allowOthers routes = RecipientRoutes
                 then Nothing
                 else Just (rkhid, merged)
 
-actorIsAddressed :: RecipientRoutes -> LocalActor -> Bool
-actorIsAddressed recips = isJust . verify
-    where
-    verify (LocalActorPerson p) = do
-        routes <- lookup p $ recipPeople recips
-        guard $ routePerson routes
-    verify (LocalActorGroup g) = do
-        routes <- lookup g $ recipGroups recips
-        guard $ routeGroup routes
-    verify (LocalActorRepo r) = do
-        routes <- lookup r $ recipRepos recips
-        guard $ routeRepo routes
-    verify (LocalActorDeck d) = do
-        routes <- lookup d $ recipDecks recips
-        guard $ routeDeck $ familyDeck routes
-    verify (LocalActorLoom l) = do
-        routes <- lookup l $ recipLooms recips
-        guard $ routeLoom $ familyLoom routes
-    verify (LocalActorProject j) = do
-        routes <- lookup j $ recipProjects recips
-        guard $ routeProject routes
-
 data ParsedAudience u = ParsedAudience
     { paudLocalRecips  :: RecipientRoutes
     , paudRemoteActors :: [(Authority u, NonEmpty LocalURI)]

src/Vervis/Web/Collab.hs

@@ -91,15 +91,14 @@ verifyCapability''
     -> Either
         (LocalActorBy Key, ActorId, OutboxItemId)
         (RemoteAuthor, LocalURI, Maybe ByteString)
-    -> GrantResourceBy Key
+    -> LocalActorBy Key
     -> AP.Role
     -> ActE ()
 verifyCapability'' uCap recipientActor resource requiredRole = do
     manager <- asksEnv envHttpManager
     encodeRouteHome <- getEncodeRouteHome
     uResource <-
-        encodeRouteHome . VR.renderLocalActor <$>
+        encodeRouteHome . VR.renderLocalActor <$> hashLocalActor resource
-            hashLocalActor (grantResourceLocalActor resource)
     now <- liftIO getCurrentTime
     grants <- traverseGrants manager uResource now
     unless (checkRole grants) $
@@ -220,7 +219,7 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
                             -- Find the local topic, on which this Collab gives access
                             topic <- lift $ getCollabTopic collabID
                             -- Verify that topic is indeed the sender of the Grant
-                            unless (grantResourceLocalActor topic == capActor) $
+                            unless (topic == capActor) $
                                 error "Grant sender isn't the topic"
                             -- Verify the topic matches the resource specified
                             unless (topic == resource) $
@@ -242,7 +241,7 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
                             unless (componentActor topic == capActor) $
                                 error "Grant sender isn't the Stem ident"
                             -- Verify the topic matches the resource specified
-                            unless (componentActor topic == grantResourceLocalActor resource) $
+                            unless (componentActor topic == resource) $
                                 throwE "Capability topic is some other local resource"
 
                     return $ (u, activity, grant, role, targetIsProject, targetIsTeam) : l
@@ -250,7 +249,7 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
                 Just uParent -> nameExceptT "Extension-Grant" $ do
                     case cap of
                         Left (actor, _, _)
-                            | grantResourceLocalActor resource == actor ->
+                            | resource == actor ->
                                 throwE "Grant.delegates specified but Grant's actor is me"
                         _ -> return ()
                     (luResult, _) <- fromMaybeE (AP.grantResult grant) "Grant.result not specified"

th/models

@@ -903,7 +903,7 @@ ComponentDelegateRemote
 -- direct collaborator
 ComponentFurtherLocal
     component ComponentEnableId
-    collab    CollabRecipLocalId
+    collab    CollabDelegLocalId
     grant     OutboxItemId
 
     UniqueComponentFurtherLocal      component collab
@@ -913,7 +913,7 @@ ComponentFurtherLocal
 -- direct collaborator
 ComponentFurtherRemote
     component ComponentEnableId
-    collab    CollabRecipRemoteId
+    collab    CollabDelegRemoteId
     grant     OutboxItemId
 
     UniqueComponentFurtherRemote      component collab