Merge remote-tracking branch 'upstream/main'

migrations/549_2023-11-21_group_create.model

@@ -0,0 +1,47 @@
+Inbox
+FollowerSet
+
+Actor
+    name      Text
+    desc      Text
+    createdAt UTCTime
+    inbox     InboxId
+    outbox    OutboxId
+    followers FollowerSetId
+    justCreatedBy ActorId Maybe
+
+    UniqueActorInbox     inbox
+    UniqueActorOutbox    outbox
+    UniqueActorFollowers followers
+
+Outbox
+
+OutboxItem
+    outbox    OutboxId
+    activity  PersistJSONObject
+    published UTCTime
+
+Group
+    actor  ActorId
+    create OutboxItemId
+
+    UniqueGroupActor  actor
+    UniqueGroupCreate create
+
+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

migrations/551_2023-11-21_group_collab.model

@@ -0,0 +1,5 @@
+CollabTopicGroup
+    collab CollabId
+    group  GroupId
+
+    UniqueCollabTopicGroup collab

migrations/552_2023-11-21_collab_deleg.model

@@ -0,0 +1,17 @@
+CollabDelegLocal
+    enable CollabEnableId
+    recip  CollabRecipLocalId
+    grant  OutboxItemId
+
+    UniqueCollabDelegLocal      enable
+    UniqueCollabDelegLocalRecip recip
+    UniqueCollabDelegLocalGrant grant
+
+CollabDelegRemote
+    enable CollabEnableId
+    recip  CollabRecipRemoteId
+    grant  RemoteActivityId
+
+    UniqueCollabDelegRemote      enable
+    UniqueCollabDelegRemoteRecip recip
+    UniqueCollabDelegRemoteGrant grant

migrations/553_2023-11-21_collab_deleg.model

@@ -0,0 +1,91 @@
+Inbox
+FollowerSet
+
+Outbox
+
+OutboxItem
+    outbox    OutboxId
+    activity  PersistJSONObject
+    published UTCTime
+
+Actor
+    name      Text
+    desc      Text
+    createdAt UTCTime
+    inbox     InboxId
+    outbox    OutboxId
+    followers FollowerSetId
+    justCreatedBy ActorId Maybe
+
+    UniqueActorInbox     inbox
+    UniqueActorOutbox    outbox
+    UniqueActorFollowers followers
+
+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
+
+Collab
+    role Role
+
+CollabTopicProject
+    collab  CollabId
+    project ProjectId
+
+    UniqueCollabTopicProject collab
+
+Project
+    actor  ActorId
+    create OutboxItemId
+
+    UniqueProjectActor  actor
+    UniqueProjectCreate create
+
+CollabTopicGroup
+    collab CollabId
+    group  GroupId
+
+    UniqueCollabTopicGroup collab
+
+Group
+    actor  ActorId
+    create OutboxItemId
+
+    UniqueGroupActor  actor
+    UniqueGroupCreate create
+
+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

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

migrations/564_2023-11-22_permit.model

@@ -0,0 +1,182 @@
+Permit
+    person PersonId
+    role   Role
+
+-------------------------------- Permit topic --------------------------------
+
+PermitTopicLocal
+    permit PermitId
+
+    UniquePermitTopicLocal permit
+
+PermitTopicRepo
+    permit PermitTopicLocalId
+    repo   RepoId
+
+    UniquePermitTopicRepo permit
+
+PermitTopicDeck
+    permit PermitTopicLocalId
+    deck   DeckId
+
+    UniquePermitTopicDeck permit
+
+PermitTopicLoom
+    permit PermitTopicLocalId
+    loom   LoomId
+
+    UniquePermitTopicLoom permit
+
+PermitTopicProject
+    permit  PermitTopicLocalId
+    project ProjectId
+
+    UniquePermitTopicProject permit
+
+PermitTopicGroup
+    permit PermitTopicLocalId
+    group  GroupId
+
+    UniquePermitTopicGroup permit
+
+PermitTopicRemote
+    permit PermitId
+    actor  RemoteActorId
+
+    UniquePermitTopicRemote permit
+
+------------------------------- Permit reason --------------------------------
+
+PermitFulfillsTopicCreation
+    permit PermitId
+
+    UniquePermitFulfillsTopicCreation permit
+
+PermitFulfillsInvite
+    permit PermitId
+
+    UniquePermitFulfillsInvite permit
+
+PermitFulfillsJoin
+    permit PermitId
+
+    UniquePermitFulfillsJoin permit
+
+-- Person's gesture
+--
+-- Join: Witnesses the initial Join that started the sequence
+-- Invite: Witnesses their approval, seeing the topic's accept, and then
+--         sending their own accept
+-- Create: Records the Create activity that created the topic
+
+PermitPersonGesture
+    permit   PermitId
+    activity OutboxItemId
+
+    UniquePermitPersonGesture         permit
+    UniquePermitPersonGestureActivity activity
+
+-- Topic collaborator's gesture
+--
+-- Join: N/A (it happens but we don't record it)
+-- Invite: Witnesses the initial Invite that started the sequence
+
+PermitTopicGestureLocal
+    fulfills PermitFulfillsInviteId
+    invite   OutboxItemId
+
+    UniquePermitTopicGestureLocal       fulfills
+    UniquePermitTopicGestureLocalInvite invite
+
+PermitTopicGestureRemote
+    fulfills PermitFulfillsInviteId
+    actor    RemoteActorId
+    invite   RemoteActivityId
+
+    UniquePermitTopicGestureRemote       fulfills
+    UniquePermitTopicGestureRemoteInvite invite
+
+-- Topic's accept
+--
+-- Join: N/A
+-- Invite: Witnesses that the topic saw and approved the Invite
+
+PermitTopicAcceptLocal
+    fulfills PermitFulfillsInviteId
+    topic    PermitTopicLocalId
+    accept   OutboxItemId
+
+    UniquePermitTopicAcceptLocal       fulfills
+    UniquePermitTopicAcceptLocalTopic  topic
+    UniquePermitTopicAcceptLocalAccept accept
+
+PermitTopicAcceptRemote
+    fulfills PermitFulfillsInviteId
+    topic    PermitTopicRemoteId
+    accept   RemoteActivityId
+
+    UniquePermitTopicAcceptRemote       fulfills
+    UniquePermitTopicAcceptRemoteTopic  topic
+    UniquePermitTopicAcceptRemoteAccept accept
+
+-------------------------------- Permit enable -------------------------------
+
+-- Topic's grant
+--
+-- Join: Seeing the new-collaborator's Join and existing-collaborator's Accept,
+--       the topic has made the link official and sent a direct-grant
+-- Invite: Seeing existing-collaborator's Invite and new-collaborator's Accept,
+--         the topic has made the link official and sent a direct-grant
+
+PermitTopicEnableLocal
+    permit PermitPersonGestureId
+    topic  PermitTopicLocalId
+    grant  OutboxItemId
+
+    UniquePermitTopicEnableLocal      permit
+    UniquePermitTopicEnableLocalTopic topic
+    UniquePermitTopicEnableLocalGrant grant
+
+PermitTopicEnableRemote
+    permit PermitPersonGestureId
+    topic  PermitTopicRemoteId
+    grant  RemoteActivityId
+
+    UniquePermitTopicEnableRemote      permit
+    UniquePermitTopicEnableRemoteTopic topic
+    UniquePermitTopicEnableRemoteGrant grant
+
+----------------------- Permit delegator+extension ---------------------------
+
+-- This section is only for Project or Team topics
+-- Person sends delegator-Grant, topic starts sending extension-Grants
+
+-- Witnesses that the person used the direct-Grant to send a delegator-Grant to
+-- the topic
+PermitPersonSendDelegator
+    permit PermitPersonGestureId
+    grant  OutboxItemId
+
+    UniquePermitPersonSendDelegator      permit
+    UniquePermitPersonSendDelegatorGrant grant
+
+-- Witnesses extension-Grants that the topic has sent, extending chains from
+-- its components/subprojects or projects/superteams
+
+PermitTopicExtendLocal
+    permit PermitPersonSendDelegatorId
+    topic  PermitTopicEnableLocalId
+    grant  OutboxItemId
+
+    UniquePermitTopicExtendLocal      permit
+    UniquePermitTopicExtendLocalTopic topic
+    UniquePermitTopicExtendLocalGrant grant
+
+PermitTopicExtendRemote
+    permit PermitPersonSendDelegatorId
+    topic  PermitTopicEnableRemoteId
+    grant  RemoteActivityId
+
+    UniquePermitTopicExtendRemote      permit
+    UniquePermitTopicExtendRemoteTopic topic
+    UniquePermitTopicExtendRemoteGrant grant

src/Data/Maybe/Local.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -16,9 +16,12 @@
 module Data.Maybe.Local
     ( partitionMaybes
     , partitionMaybePairs
+    , exactlyOneJust
     )
 where
 
+import Data.Maybe
+
 partitionMaybes :: [(Maybe a, b)] -> ([(a, b)], [b])
 partitionMaybes = foldr f ([], [])
     where
@@ -32,3 +35,10 @@ partitionMaybePairs = foldr f ([], [], [])
     f (Just x,  Nothing) (xs, ys, ps) = (x : xs, ys, ps)
     f (Nothing, Just y)  (xs, ys, ps) = (xs, y : ys, ps)
     f (Just x,  Just y)  (xs, ys, ps) = (xs, ys, (x, y) : ps)
+
+exactlyOneJust :: Monad m => [Maybe a] -> String -> String -> m a
+exactlyOneJust l none multiple =
+    case catMaybes l of
+        [] -> error none
+        [x] -> pure x
+        _ -> error multiple

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,23 +159,8 @@ handleViaActor personID maybeCap localRecips remoteRecips fwdHosts action = do
 
 verifyResourceAddressed
     :: (MonadSite m, YesodHashids (SiteEnv m))
-    => RecipientRoutes -> GrantResourceBy Key -> ExceptT Text m ()
-verifyResourceAddressed localRecips resource = do
-    resourceHash <- hashGrantResource resource
-    fromMaybeE (verify resourceHash) "Local resource not addressed"
-    where
-    verify (GrantResourceRepo r) = do
-        routes <- lookup r $ recipRepos localRecips
-        guard $ routeRepo routes
-    verify (GrantResourceDeck d) = do
-        routes <- lookup d $ recipDecks localRecips
-        guard $ routeDeck $ familyDeck routes
-    verify (GrantResourceLoom l) = do
-        routes <- lookup l $ recipLooms localRecips
-        guard $ routeLoom $ familyLoom routes
-    verify (GrantResourceProject r) = do
-        routes <- lookup r $ recipProjects localRecips
-        guard $ routeProject routes
+    => RecipientRoutes -> LocalActorBy Key -> ExceptT Text m ()
+verifyResourceAddressed localRecips resource = logWarn "Vervis.API verifyResourceAddressed"
 
 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

@@ -18,43 +18,260 @@ module Vervis.Actor.Group
     )
 where
 
+import Control.Applicative
+import Control.Exception.Base
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Logger.CallStack
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Reader
+import Data.Barbie
+import Data.Bifoldable
+import Data.Bifunctor
+import Data.Bitraversable
 import Data.ByteString (ByteString)
+import Data.Either
 import Data.Foldable
+import Data.Maybe
 import Data.Text (Text)
 import Data.Time.Clock
+import Data.Traversable
 import Database.Persist
+import Database.Persist.Sql
+import Optics.Core
 import Yesod.Persist.Core
 
 import qualified Data.Text as T
+import qualified Database.Esqueleto as E
 
 import Control.Concurrent.Actor
 import Network.FedURI
+import Web.Actor
+import Web.Actor.Persist
 import Yesod.MonadSite
 
 import qualified Web.ActivityPub as AP
 
 import Control.Monad.Trans.Except.Local
+import Data.Either.Local
 import Database.Persist.Local
 
+import Vervis.Access
+import Vervis.ActivityPub
 import Vervis.Actor
+import Vervis.Actor.Common
+import Vervis.Actor2
 import Vervis.Cloth
+import Vervis.Data.Actor
+import Vervis.Data.Collab
 import Vervis.Data.Discussion
 import Vervis.FedURI
 import Vervis.Federation.Util
 import Vervis.Foundation
-import Vervis.Model
+import Vervis.Model hiding (groupCreate)
+import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
+import Vervis.RemoteActorStore
+import Vervis.Persist.Actor
+import Vervis.Persist.Collab
 import Vervis.Persist.Discussion
 import Vervis.Ticket
 
+-- Meaning: Someone has created a group with my ID URI
+-- Behavior:
+--     * Verify I'm in a just-been-created state
+--     * Verify my creator and the Create sender are the same actor
+--     * Create an admin Collab record in DB
+--     * Send an admin Grant to the creator
+--     * Get out of the just-been-created state
+groupCreateMe
+    :: UTCTime
+    -> GroupId
+    -> Verse
+    -> ActE (Text, Act (), Next)
+groupCreateMe =
+    topicCreateMe
+        groupActor LocalActorGroup
+        CollabTopicGroupGroup CollabTopicGroup
+
+groupCreate
+    :: UTCTime
+    -> GroupId
+    -> Verse
+    -> AP.Create URIMode
+    -> ActE (Text, Act (), Next)
+groupCreate now groupID verse (AP.Create obj _muTarget) =
+    case obj of
+
+        AP.CreateTeam _ mlocal -> do
+            (h, local) <- fromMaybeE mlocal "No group id provided"
+            let luGroup = AP.actorId local
+            uMe <- do
+                groupHash <- encodeKeyHashid groupID
+                encodeRouteHome <- getEncodeRouteHome
+                return $ encodeRouteHome $ GroupR groupHash
+            unless (uMe == ObjURI h luGroup) $
+                throwE "The created group id isn't me"
+            groupCreateMe now groupID verse
+
+        _ -> throwE "Unsupported Create object for Group"
+
+-- Meaning: An actor is following someone/something
+-- Behavior:
+--      * Verify the target is me
+--      * Record the follow in DB
+--      * Publish and send an Accept to the sender and its followers
+groupFollow
+    :: UTCTime
+    -> GroupId
+    -> Verse
+    -> AP.Follow URIMode
+    -> ActE (Text, Act (), Next)
+groupFollow now recipGroupID verse follow = do
+    recipGroupHash <- encodeKeyHashid recipGroupID
+    actorFollow
+        (\case
+            GroupR d | d == recipGroupHash -> pure ()
+            _ -> throwE "Asking to follow someone else"
+        )
+        groupActor
+        False
+        (\ recipGroupActor () -> pure $ actorFollowers recipGroupActor)
+        (\ _ -> pure $ makeRecipientSet [] [])
+        LocalActorGroup
+        (\ _ -> pure [])
+        now recipGroupID verse follow
+
+-- Meaning: An actor is undoing some previous action
+-- Behavior:
+--      * If they're undoing their Following of me:
+--          * Record it in my DB
+--          * Publish and send an Accept only to the sender
+--      * Otherwise respond with an error
+groupUndo
+    :: UTCTime
+    -> GroupId
+    -> Verse
+    -> AP.Undo URIMode
+    -> ActE (Text, Act (), Next)
+groupUndo now recipGroupID (Verse authorIdMsig body) (AP.Undo uObject) = do
+
+    -- Check input
+    undone <-
+        first (\ (actor, _, item) -> (actor, item)) <$>
+            parseActivityURI' uObject
+
+    -- Verify the capability URI, if provided, is one of:
+    --   * Outbox item URI of a local actor, i.e. a local activity
+    --   * A remote URI
+    maybeCapability <-
+        for (AP.activityCapability $ actbActivity body) $ \ uCap ->
+            nameExceptT "Undo capability" $
+                first (\ (actor, _, item) -> (actor, item)) <$>
+                    parseActivityURI' uCap
+
+    maybeNew <- withDBExcept $ do
+
+        -- Grab me from DB
+        (groupRecip, actorRecip) <- lift $ do
+            p <- getJust recipGroupID
+            (p,) <$> getJust (groupActor p)
+
+        -- Insert the Undo to my inbox
+        mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
+        for mractid $ \ _undoDB -> do
+
+            maybeUndo <- runMaybeT $ do
+
+                -- Find the undone activity in our DB
+                undoneDB <- MaybeT $ getActivity undone
+
+                let followers = actorFollowers actorRecip
+                asum
+                    [ tryUnfollow followers undoneDB authorIdMsig
+                    ]
+
+            (sieve, audience) <-
+                fromMaybeE
+                    maybeUndo
+                    "Undone activity isn't a Follow related to me"
+
+            -- Prepare an Accept activity and insert to group's outbox
+            acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorRecip) now
+            accept@(actionAccept, _, _, _) <- lift $ lift $ prepareAccept audience
+            _luAccept <- lift $ updateOutboxItem' (LocalActorGroup recipGroupID) acceptID actionAccept
+
+            return (groupActor groupRecip, sieve, acceptID, accept)
+
+    case maybeNew of
+        Nothing -> done "I already have this activity in my inbox"
+        Just (actorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
+            forwardActivity
+                authorIdMsig body (LocalActorGroup recipGroupID) actorID sieve
+            lift $ sendActivity
+                (LocalActorGroup recipGroupID) actorID localRecipsAccept
+                remoteRecipsAccept fwdHostsAccept acceptID actionAccept
+            done
+                "Undid the Follow, forwarded the Undo and published Accept"
+
+    where
+
+    tryUnfollow groupFollowersID (Left (_actorByKey, _actorE, outboxItemID)) (Left (_, actorID, _)) = do
+        Entity followID follow <-
+            MaybeT $ lift $ getBy $ UniqueFollowFollow outboxItemID
+        let followerID = followActor follow
+            followerSetID = followTarget follow
+        verifyTargetMe followerSetID
+        unless (followerID == actorID) $
+            lift $ throwE "You're trying to Undo someone else's Follow"
+        lift $ lift $ delete followID
+        audSenderOnly <- lift $ lift $ lift $ makeAudSenderOnly authorIdMsig
+        return (makeRecipientSet [] [], [audSenderOnly])
+        where
+        verifyTargetMe followerSetID = guard $ followerSetID == groupFollowersID
+    tryUnfollow groupFollowersID (Right remoteActivityID) (Right (author, _, _)) = do
+        Entity remoteFollowID remoteFollow <-
+            MaybeT $ lift $ getBy $ UniqueRemoteFollowFollow remoteActivityID
+        let followerID = remoteFollowActor remoteFollow
+            followerSetID = remoteFollowTarget remoteFollow
+        verifyTargetMe followerSetID
+        unless (followerID == remoteAuthorId author) $
+            lift $ throwE "You're trying to Undo someone else's Follow"
+        lift $ lift $ delete remoteFollowID
+        audSenderOnly <- lift $ lift $ lift $ makeAudSenderOnly authorIdMsig
+        return (makeRecipientSet [] [], [audSenderOnly])
+        where
+        verifyTargetMe followerSetID = guard $ followerSetID == groupFollowersID
+    tryUnfollow _ _ _ = mzero
+
+    prepareAccept audience = do
+        encodeRouteHome <- getEncodeRouteHome
+
+        uUndo <- getActivityURI authorIdMsig
+        let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience audience
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            action = AP.Action
+                { AP.actionCapability = Nothing
+                , AP.actionSummary    = Nothing
+                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                , AP.actionFulfills   = []
+                , AP.actionSpecific   = AP.AcceptActivity AP.Accept
+                    { AP.acceptObject   = uUndo
+                    , AP.acceptResult   = Nothing
+                    }
+                }
+
+        return (action, recipientSet, remoteActors, fwdHosts)
+
 groupBehavior :: UTCTime -> GroupId -> VerseExt -> ActE (Text, Act (), Next)
-groupBehavior now groupID (Left _verse@(Verse _authorIdMsig body)) =
+groupBehavior now groupID (Left verse@(Verse _authorIdMsig body)) =
     case AP.activitySpecific $ actbActivity body of
+        AP.CreateActivity create -> groupCreate now groupID verse create
+        AP.FollowActivity follow -> groupFollow now groupID verse follow
+        AP.UndoActivity undo     -> groupUndo now groupID verse undo
         _ -> throwE "Unsupported activity type for Group"
 groupBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Group"
 

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.hs

@@ -19,6 +19,7 @@ module Vervis.Actor.Person
     )
 where
 
+import Control.Applicative
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Logger.CallStack
@@ -26,6 +27,7 @@ import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Reader
+import Data.Barbie
 import Data.Bifunctor
 import Data.Bitraversable
 import Data.ByteString (ByteString)
@@ -273,7 +275,13 @@ personUndo now recipPersonID (Verse authorIdMsig body) (AP.Undo uObject) = do
 -- Meaning: An actor accepted something
 -- Behavior:
 --      * Insert to my inbox
---      * If it's a Follow I sent to them, add to my following list in DB
+--      * If it's on a Follow I sent to them:
+--          * Add to my following list in DB
+--      * If it's on an Invite-for-me to collaborate on a resource:
+--          * Verify I haven't yet seen the resource's accept
+--          * Verify the Accept author is the resource
+--          * Store it in the Permit record in DB
+--          * Forward to my followers
 personAccept
     :: UTCTime
     -> PersonId
@@ -298,13 +306,22 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do
             -- Find the accepted activity in our DB
             accepteeDB <- MaybeT $ getActivity acceptee
 
-            tryFollow (personActor personRecip) accepteeDB acceptDB
+            let recipActorID = personActor personRecip
+            Left <$> tryFollow recipActorID accepteeDB acceptDB <|>
+                Right <$> tryInvite recipActorID accepteeDB acceptDB
 
     case maybeNew of
         Nothing -> done "I already have this activity in my inbox"
-        Just Nothing -> done "Not my Follow; Just inserted to my inbox"
-        Just (Just ()) ->
+        Just Nothing -> done "Not my Follow/Invite; Just inserted to my inbox"
+        Just (Just (Left ())) ->
             done "Recorded this Accept on the Follow request I sent"
+        Just (Just (Right (actorID, sieve))) -> do
+            forwardActivity
+                authorIdMsig body (LocalActorPerson recipPersonID)
+                actorID sieve
+            done
+                "Recorded this Accept on the Invite I've had & \
+                \forwarded to my followers"
 
     where
 
@@ -359,6 +376,56 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do
         -}
     tryFollow _ (Right _) _ = mzero
 
+    tryInvite recipActorID accepteeDB acceptDB = do
+
+        -- Find a PermitFulfillsInvite
+        (permitID, fulfillsID) <-
+            case accepteeDB of
+                Left (actorByKey, _actorEntity, itemID) -> do
+                    PermitTopicGestureLocal fulfillsID _ <-
+                        MaybeT $ lift $ getValBy $ UniquePermitTopicGestureLocalInvite itemID
+                    PermitFulfillsInvite permitID <- lift . lift $ getJust fulfillsID
+                    return (permitID, fulfillsID)
+                Right remoteActivityID -> do
+                    PermitTopicGestureRemote fulfillsID _ _ <-
+                        MaybeT $ lift $ getValBy $ UniquePermitTopicGestureRemoteInvite remoteActivityID
+                    PermitFulfillsInvite permitID <- lift . lift $ getJust fulfillsID
+                    return (permitID, fulfillsID)
+
+        -- Find the local person and verify it's me
+        Permit p _role <- lift . lift $ getJust permitID
+        guard $ p == recipPersonID
+
+        lift $ do
+            -- Find the topic
+            topic <- lift $ getPermitTopic permitID
+
+            -- Verify I haven't seen the topic's accept yet
+            maybeTopicAccept <-
+                lift $ case bimap fst fst topic of
+                    Left localID -> void <$> getBy (UniquePermitTopicAcceptLocalTopic localID)
+                    Right remoteID -> void <$> getBy (UniquePermitTopicAcceptRemoteTopic remoteID)
+            unless (isNothing maybeTopicAccept) $
+                throwE "I've already seen the topic's Accept"
+
+            -- Verify topic is the Accept sender
+            case (bimap snd snd topic, bimap (view _1) (view _1) acceptDB) of
+                (Left la, Left la') | la == la' -> pure ()
+                (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
+                _ -> throwE "Accept sender isn't the Invite topic"
+
+            -- Update the Permit record
+            lift $ case (bimap fst fst topic, bimap (view _3) (view _3) acceptDB)  of
+                (Left localID, Left acceptID) -> insert_ $ PermitTopicAcceptLocal fulfillsID localID acceptID
+                (Right remoteID, Right acceptID) -> insert_ $ PermitTopicAcceptRemote fulfillsID remoteID acceptID
+                _ -> error "personAccept impossible"
+
+            -- Prepare forwarding Accept to my followers
+            recipPersonHash <- encodeKeyHashid recipPersonID
+            let sieve = makeRecipientSet [] [LocalStagePersonFollowers recipPersonHash]
+
+            return (recipActorID, sieve)
+
 -- Meaning: An actor rejected something
 -- Behavior:
 --      * Insert to my inbox
@@ -535,7 +602,17 @@ personAdd now recipPersonID (Verse authorIdMsig body) add = do
 -- Meaning: Someone invited someone to a resource
 -- Behavior:
 --      * Insert to my inbox
---      * If I'm the target, forward the Invite to my followers
+--      * If I'm being invited to the resource's collaborators/members
+--        collection:
+--          * For each Permit record I have for this resource:
+--              * Verify it's not enabled yet, i.e. I'm not already a
+--                collaborator, haven't received a direct-Grant
+--              * Verify it's not in Invite-Accept state, already got the
+--                resource's Accept and waiting for my approval or for the
+--                topic's Grant
+--              * Verify it's not a Join
+--          * Create a Permit record in DB
+--          * Forward the Invite to my followers
 personInvite
     :: UTCTime
     -> PersonId
@@ -545,10 +622,42 @@ personInvite
 personInvite now recipPersonID (Verse authorIdMsig body) invite = do
 
     -- Check input
-    recipientOrComp <- do
+    maybeRoleAndResourceDB <- do
         let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
-        (_role, _resource, target) <- parseInvite author invite
-        return target
+        (role, resource, recip) <- parseInvite author invite
+        let recipIsMe =
+                case recip of
+                    Left (Left (GrantRecipPerson p)) | p == recipPersonID -> True
+                    _ -> False
+        if not recipIsMe
+            then pure Nothing
+            else
+                -- If resource collabs URI is remote, HTTP GET it and its resource and its
+                -- managing actor, and insert to our DB. If resource is local, find it in
+                -- our DB.
+                case resource of
+                    Left r ->
+                        case r of
+                            Left la -> withDBExcept $ Just . (role,) . Left <$> getLocalActorEntityE la "Invite resource not found in DB"
+                            Right _j -> pure Nothing
+                    Right u@(ObjURI h luColl) -> do
+                        manager <- asksEnv envHttpManager
+                        coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
+                        lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
+                        AP.ResourceWithCollections _ mluCollabs _mluComps mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                        if mluCollabs == Just luColl || mluMembers == Just luColl
+                            then Just . (role,) . Right <$> do
+                                instanceID <-
+                                    lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                                result <-
+                                    ExceptT $ first (T.pack . show) <$>
+                                        fetchRemoteResource instanceID h lu
+                                case result of
+                                    Left (Entity actorID actor) ->
+                                        return (remoteActorIdent actor, actorID, u)
+                                    Right (objectID, luManager, (Entity actorID _)) ->
+                                        return (objectID, actorID, ObjURI h luManager)
+                            else pure Nothing
 
     maybeNew <- withDBExcept $ do
 
@@ -558,31 +667,64 @@ personInvite now recipPersonID (Verse authorIdMsig body) invite = do
             (p,) <$> getJust (personActor p)
 
         maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
-        for maybeInviteDB $ \ _inviteDB ->
-            return $ personActor personRecip
+        for maybeInviteDB $ \ inviteDB -> do
+
+            maybePermit <- for maybeRoleAndResourceDB $ \ (role, resourceDB) -> do
+
+                -- Find existing Permit records I have for this topic
+                -- Make sure none are enabled / in Join mode / in Invite-Accept
+                -- mode
+                checkExistingPermits
+                    recipPersonID
+                    (bimap (bmap entityKey) (view _2) resourceDB)
+
+                -- Prepare forwarding Invite to my followers
+                recipPersonHash <- encodeKeyHashid recipPersonID
+                let sieve = makeRecipientSet [] [LocalStagePersonFollowers recipPersonHash]
+
+                -- Insert Permit record to DB
+                insertPermit resourceDB inviteDB role
+
+                return sieve
+
+            return (personActor personRecip, maybePermit)
 
     case maybeNew of
         Nothing -> done "I already have this activity in my inbox"
-        Just actorID -> do
-            let targetIsRecip =
-                    case recipientOrComp of
-                        Left (Left (GrantRecipPerson p)) -> p == recipPersonID
-                        _ -> False
-            if not targetIsRecip
-                then done "I'm not the target; Inserted to inbox"
-                else do
-                    recipHash <- encodeKeyHashid recipPersonID
-                    let sieve =
-                            makeRecipientSet
-                                []
-                                [LocalStagePersonFollowers recipHash]
+        Just (actorID, maybePermit) ->
+            case maybePermit of
+                Nothing -> done "I'm not the target; Inserted to inbox"
+                Just sieve -> do
                     forwardActivity
                         authorIdMsig body (LocalActorPerson recipPersonID)
                         actorID sieve
                     done
-                        "I'm the target; Inserted to inbox; \
+                        "I'm the target; Inserted to inbox; Inserted Permit; \
                         \Forwarded to followers if addressed"
 
+    where
+
+    insertPermit resourceDB inviteDB role = do
+        permitID <- lift $ insert $ Permit recipPersonID role
+        case resourceDB of
+            Left la -> do
+                localID <- lift $ insert $ PermitTopicLocal permitID
+                case bmap entityKey la of
+                    LocalActorPerson _ -> throwE "insertPermit: Person not supported as a PermitTopicLocal type (you can't become a \"collaborator in a person\""
+                    LocalActorRepo r -> lift $ insert_ $ PermitTopicRepo localID r
+                    LocalActorDeck d -> lift $ insert_ $ PermitTopicDeck localID d
+                    LocalActorLoom l -> lift $ insert_ $ PermitTopicLoom localID l
+                    LocalActorProject j -> lift $ insert_ $ PermitTopicProject localID j
+                    LocalActorGroup g -> lift $ insert_ $ PermitTopicGroup localID g
+            Right (_, actorID, _) -> lift $ insert_ $ PermitTopicRemote permitID actorID
+        lift $ do
+            fulfillsID <- insert $ PermitFulfillsInvite permitID
+            case inviteDB of
+                Left (_, _, inviteID) ->
+                    insert_ $ PermitTopicGestureLocal fulfillsID inviteID
+                Right (author, _, inviteID) ->
+                    insert_ $ PermitTopicGestureRemote fulfillsID (remoteAuthorId author) inviteID
+
 -- Meaning: Someone removed someone from a resource
 -- Behavior:
 --      * Insert to my inbox
@@ -663,6 +805,21 @@ personJoin now recipPersonID (Verse authorIdMsig body) join = do
 -- Meaning: An actor published a Grant
 -- Behavior:
 --      * Insert to my inbox
+--
+--      * If it's a direct-Grant that fulfills a Permit I have:
+--          * Verify the Permit isn't already enabled
+--          * Verify the sender is the Permit topic
+--          * Verify the role is identical to what was requested
+--          * Update the Permit record, storing the direct-Grant
+--          * Forward the direct-Grant to my followers
+--          * If topic is a Project or a Team:
+--              * Send a delegator-Grant to the topic
+--              * Update the Permit record, storing the delegator-Grant
+--
+--      * If it's a extension-Grant whose capability is a delegator-Grant from
+--        a Permit I have:
+--          * Verify the sender is the Permit topic
+--          * Update the Permit record, storing the extension-Grant
 personGrant
     :: UTCTime
     -> PersonId
@@ -672,9 +829,18 @@ personGrant
 personGrant now recipPersonID (Verse authorIdMsig body) grant = do
 
     -- Check input
-    target <- do
-        --h <- lift $ objUriAuthority <$> getActorURI authorIdMsig
-        (_role, resource, recip, _mresult, _mstart, _mend, _usage, _mdeleg) <-
+    maybeMine <- do
+        -- Verify the capability URI, if provided, is one of:
+        --   * Outbox item URI of a local actor, i.e. a local activity
+        --   * A remote URI
+        maybeCapability <-
+            for (AP.activityCapability $ actbActivity body) $ \ uCap ->
+                nameExceptT "Grant.capability" $
+                    first (\ (actor, _, item) -> (actor, item)) <$>
+                        parseActivityURI' uCap
+
+        -- Basic sanity checks
+        (role, resource, recip, _mresult, mstart, mend, usage, mdeleg) <-
             parseGrant' grant
         case (recip, authorIdMsig) of
             (Left (GrantRecipPerson' p), Left (LocalActorPerson p', _, _))
@@ -684,28 +850,259 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
                 | uRecip == remoteAuthorURI author ->
                     throwE "Grant sender and target are the same remote actor"
             _ -> pure ()
-        return recip
+        let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
+        case mdeleg of
+            Nothing ->
+                unless (author == resource) $
+                    throwE "Not an extension but resource and actor differ"
+            Just _ ->
+                when (author == resource) $
+                    throwE "Extension but resource and actor are identical"
 
-    maybeGrant <- withDBExcept $ do
+        -- For a direct-Grant, use 'fulfills' to identify the Permit
+        -- For an extension-Grant, use 'capability' for that
+        runMaybeT $ do
+            guard $ usage == AP.Invoke
+            guard $ recip == Left (GrantRecipPerson' recipPersonID)
+            lift $ do
+                for_ mstart $ \ start ->
+                    unless (start <= now) $
+                        throwE "Got a Grant that hasn't started"
+                for_ mend $ \ _ -> throwE "Got a Grant with expiration"
+            if isNothing mdeleg
+                then do
+                    uFulfills <-
+                        case AP.activityFulfills $ actbActivity body of
+                            [] -> mzero
+                            [u] -> pure u
+                            _ -> lift $ throwE "Multiple fulfills"
+                    fulfills <-
+                        lift $
+                        first (\ (actor, _, item) -> (actor, item)) <$>
+                            parseActivityURI' uFulfills
+                    return $ Left (role, fulfills)
+                else do
+                    cap <- lift $ fromMaybeE maybeCapability "Extension-Grant doesn't specify a delegator-Grant capability"
+                    delegatorID <-
+                        case cap of
+                            Left (LocalActorPerson p, itemID) | p == recipPersonID -> pure itemID
+                            _ -> lift $ throwE "Extending access to me using a delegator-Grant capability that isn't mine"
+                    return $ Right delegatorID
+
+    maybeNew <- withDBExcept $ do
 
         -- Grab me from DB
         (personRecip, actorRecip) <- lift $ do
             p <- getJust recipPersonID
             (p,) <$> getJust (personActor p)
 
-        mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
-        for mractid $ \ _grantDB -> return $ personActor personRecip
+        maybePermit <-
+            for maybeMine $
+                bitraverse
+                    (\ (role, fulfills) -> do
 
-    case maybeGrant of
+                        -- Find my Permit record, verify the roles match
+                        fulfillsDB <- do
+                            a <- getActivity fulfills
+                            fromMaybeE a "Can't find fulfills in DB"
+                        (permitID, maybeGestureID) <- do
+                            mp <- runMaybeT $ do
+                                x@(pt, mg) <-
+                                    tryInvite fulfillsDB <|>
+                                    tryJoin fulfillsDB <|>
+                                    tryCreate fulfillsDB
+                                Permit p role' <- lift . lift $ getJust pt
+                                guard $ p == recipPersonID
+                                lift $ unless (role == AP.RXRole role') $
+                                    throwE "Requested and granted roles differ"
+                                return x
+                            fromMaybeE mp "Can't find a PermitFulfills*"
+
+                        -- If Permit fulfills an Invite, verify I've approved
+                        -- it
+                        gestureID <- fromMaybeE maybeGestureID "I'm getting this Grant but I haven't yet approved the Invite"
+
+                        -- Verify the Permit isn't already enabled
+                        topic <- lift $ getPermitTopic permitID
+                        maybeTopicEnable <-
+                            lift $ case bimap fst fst topic of
+                                Left localID -> void <$> getBy (UniquePermitTopicEnableLocalTopic localID)
+                                Right remoteID -> void <$> getBy (UniquePermitTopicEnableRemoteTopic remoteID)
+                        unless (isNothing maybeTopicEnable) $
+                            throwE "I've already received the direct-Grant"
+
+                        -- Verify the Grant sender is the Permit topic
+                        case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of
+                            (Left la, Left la') | la == la' -> pure ()
+                            (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
+                            _ -> throwE "Grant sender isn't the Permit topic"
+
+                        return (gestureID, bimap fst fst topic)
+                    )
+                    (\ delegatorID -> do
+                        Entity sendID (PermitPersonSendDelegator gestureID _) <- do
+                            mp <- lift $ getBy $ UniquePermitPersonSendDelegatorGrant delegatorID
+                            fromMaybeE mp "Extension-Grant.capability: I don't have such a delegator-Grant, can't find a PermitPersonSendDelegator record"
+                        PermitPersonGesture permitID _ <- lift $ getJust gestureID
+
+                        -- Verify the Grant sender is the Permit topic
+                        topic <- lift $ getPermitTopic permitID
+                        case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of
+                            (Left la, Left la') | la == la' -> pure ()
+                            (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
+                            _ -> throwE "Grant sender isn't the Permit topic"
+
+                        return (sendID, bimap fst fst topic)
+                    )
+
+        mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
+        for mractid $ \ grantDB -> do
+
+            for maybePermit $
+                bitraverse
+                    (\ (gestureID, topic) -> lift $ do
+
+                        -- Update the Permit record, storing the direct-Grant
+                        case (topic, grantDB) of
+                            (Left localID, Left (_, _, grantID)) ->
+                                insert_ $ PermitTopicEnableLocal gestureID localID grantID
+                            (Right remoteID, Right (_, _, grantID)) ->
+                                insert_ $ PermitTopicEnableRemote gestureID remoteID grantID
+                            _ -> error "personGrant impossible"
+
+                        -- Prepare forwarding direct-Grant to my followers
+                        recipPersonHash <- encodeKeyHashid recipPersonID
+                        let sieve = makeRecipientSet [] [LocalStagePersonFollowers recipPersonHash]
+
+                         -- Prepapre delegator-Grant and update Permit
+                        needDeleg <-
+                            case grantDB of
+                                Left (la, _, _) ->
+                                    pure $ case la of
+                                        LocalActorProject _ -> True
+                                        LocalActorGroup _ -> True
+                                        _ -> False
+                                Right (author, _, _) -> do
+                                    ra <- getJust $ remoteAuthorId author
+                                    pure $ case remoteActorType ra of
+                                        AP.ActorTypeProject -> True
+                                        AP.ActorTypeTeam -> True
+                                        _ -> False
+                        maybeDeleg <-
+                            if needDeleg
+                                then Just <$> do
+                                    delegID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
+                                    deleg@(actionDeleg, _, _, _) <- prepareDelegGrant
+                                    let recipByKey = LocalActorPerson recipPersonID
+                                    _luDeleg <- updateOutboxItem' recipByKey delegID actionDeleg
+
+                                    insert_ $ PermitPersonSendDelegator gestureID delegID
+
+                                    return (delegID, deleg)
+                                else
+                                    pure Nothing
+
+                        return (personActor personRecip, sieve, maybeDeleg)
+                    )
+                    (\ (sendID, topic) ->
+                        case (topic, grantDB) of
+                            (Left localID, Left (_, _, extID)) -> lift $ do
+                                enableID <- do
+                                    me <- getKeyBy $ UniquePermitTopicEnableLocalTopic localID
+                                    case me of
+                                        Just e -> pure e
+                                        Nothing -> error "Impossible, Permit has the delegator-Grant but no (local) Enable"
+                                insert_ $ PermitTopicExtendLocal sendID enableID extID
+                            (Right remoteID, Right (_, _, extID)) -> lift $ do
+                                enableID <- do
+                                    me <- getKeyBy $ UniquePermitTopicEnableRemoteTopic remoteID
+                                    case me of
+                                        Just e -> pure e
+                                        Nothing -> error "Impossible, Permit has the delegator-Grant but no (remote) Enable"
+                                insert_ $ PermitTopicExtendRemote sendID enableID extID
+                            _ -> error "personGrant impossible 2"
+                    )
+
+    case maybeNew of
         Nothing -> done "I already have this activity in my inbox"
-        Just _actorID -> do
-            let targetIsRecip =
-                    case target of
-                        Left (GrantRecipPerson' p) -> p == recipPersonID
-                        _ -> False
-            if not targetIsRecip
-                then done "I'm not the target; Inserted to inbox"
-                else done "I'm the target; Inserted to inbox"
+        Just Nothing -> done "Inserted Grant to my inbox"
+        Just (Just (Left (recipActorID, sieve, maybeDeleg))) -> do
+            let recipByID = LocalActorPerson recipPersonID
+            forwardActivity authorIdMsig body recipByID recipActorID sieve
+            lift $ for_ maybeDeleg $ \ (delegID, (actionDeleg, localRecipsDeleg, remoteRecipsDeleg, fwdHostsDeleg)) ->
+                sendActivity
+                    recipByID recipActorID localRecipsDeleg
+                    remoteRecipsDeleg fwdHostsDeleg delegID actionDeleg
+            done "Forwarded the direct-Grant, updated Permit, maybe published delegator-Grant"
+        Just (Just (Right ())) ->
+            done "Got an extension-Grant, updated Permit"
+
+    where
+
+    tryInvite fulfillsDB = do
+        fulfillsID <-
+            case fulfillsDB of
+                Left (_actorByKey, _actorEntity, itemID) -> do
+                    PermitTopicGestureLocal fulfillsID _ <-
+                        MaybeT $ lift $ getValBy $ UniquePermitTopicGestureLocalInvite itemID
+                    return fulfillsID
+                Right remoteActivityID -> do
+                    PermitTopicGestureRemote fulfillsID _ _ <-
+                        MaybeT $ lift $ getValBy $ UniquePermitTopicGestureRemoteInvite remoteActivityID
+                    return fulfillsID
+        PermitFulfillsInvite permitID <- lift . lift $ getJust fulfillsID
+        maybeGestureID <- lift . lift $ getKeyBy $ UniquePermitPersonGesture permitID
+        return (permitID, maybeGestureID)
+
+    tryJoin fulfillsDB = do
+        Entity gestureID (PermitPersonGesture permitID _) <-
+            case fulfillsDB of
+                Left (_actorByKey, _actorEntity, itemID) ->
+                    MaybeT $ lift $ getBy $ UniquePermitPersonGestureActivity itemID
+                Right _remoteActivityID -> mzero
+        _ <- MaybeT $ lift $ getBy $ UniquePermitFulfillsJoin permitID
+        return (permitID, Just gestureID)
+
+    tryCreate fulfillsDB = do
+        Entity gestureID (PermitPersonGesture permitID _) <-
+            case fulfillsDB of
+                Left (_actorByKey, _actorEntity, itemID) ->
+                    MaybeT $ lift $ getBy $ UniquePermitPersonGestureActivity itemID
+                Right _remoteActivityID -> mzero
+        _ <- MaybeT $ lift $ getBy $ UniquePermitFulfillsTopicCreation permitID
+        return (permitID, Just gestureID)
+
+    prepareDelegGrant = do
+        encodeRouteHome <- getEncodeRouteHome
+        encodeRouteLocal <- getEncodeRouteLocal
+
+        personHash <- encodeKeyHashid recipPersonID
+        audTopic <- lift $ makeAudSenderOnly authorIdMsig
+        uTopic <- lift $ getActorURI authorIdMsig
+        uDirectGrant <- lift $ getActivityURI authorIdMsig
+
+        let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience [audTopic]
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            action = AP.Action
+                { AP.actionCapability = Just uDirectGrant
+                , AP.actionSummary    = Nothing
+                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                , AP.actionFulfills   = [uDirectGrant]
+                , AP.actionSpecific   = AP.GrantActivity AP.Grant
+                    { AP.grantObject    = AP.RXDelegator
+                    , AP.grantContext   = encodeRouteHome $ PersonR personHash
+                    , AP.grantTarget    = uTopic
+                    , AP.grantResult    = Nothing
+                    , AP.grantStart     = Just now
+                    , AP.grantEnd       = Nothing
+                    , AP.grantAllows    = AP.Invoke
+                    , AP.grantDelegates = Nothing
+                    }
+                }
+
+        return (action, recipientSet, remoteActors, fwdHosts)
 
 -- Meaning: An actor has revoked some previously published Grants
 -- Behavior: Insert to my inbox

src/Vervis/Actor/Person/Client.hs

@@ -54,6 +54,7 @@ import Yesod.MonadSite
 import qualified Web.ActivityPub as AP
 
 import Control.Monad.Trans.Except.Local
+import Data.Either.Local
 import Database.Persist.Local
 
 import Vervis.Access
@@ -61,6 +62,7 @@ import Vervis.ActivityPub
 import Vervis.Actor
 import Vervis.Actor2
 import Vervis.Actor.Deck
+import Vervis.Actor.Group
 import Vervis.Actor.Project
 import Vervis.Cloth
 import Vervis.Data.Actor
@@ -80,23 +82,11 @@ import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectA
 import Vervis.RemoteActorStore
 import Vervis.Ticket
 
-verifyResourceAddressed :: RecipientRoutes -> GrantResourceBy Key -> ActE ()
-verifyResourceAddressed localRecips resource = do
-    resourceHash <- hashGrantResource' resource
-    fromMaybeE (verify resourceHash) "Local resource not addressed"
-    where
-    verify (GrantResourceRepo r) = do
-        routes <- lookup r $ recipRepos localRecips
-        guard $ routeRepo routes
-    verify (GrantResourceDeck d) = do
-        routes <- lookup d $ recipDecks localRecips
-        guard $ routeDeck $ familyDeck routes
-    verify (GrantResourceLoom l) = do
-        routes <- lookup l $ recipLooms localRecips
-        guard $ routeLoom $ familyLoom routes
-    verify (GrantResourceProject r) = do
-        routes <- lookup r $ recipProjects localRecips
-        guard $ routeProject routes
+verifyActorAddressed :: RecipientRoutes -> LocalActorBy Key -> ActE ()
+verifyActorAddressed localRecips resource = do
+    resourceHash <- hashLocalActor resource
+    unless (actorIsAddressed localRecips resourceHash) $
+        throwE "Local resource not addressed"
 
 verifyProjectAddressed localRecips projectID = do
     projectHash <- encodeKeyHashid projectID
@@ -141,6 +131,13 @@ verifyRemoteAddressed remoteRecips u =
 -- Behavior:
 --      * Insert to my inbox
 --      * Deliver without filtering
+--      * If it's an Invite (that I know about) where I'm invited to a project/team/component:
+--          * If I haven't yet seen the topic's approval:
+--              * Respond with error, we want to wait for the approval
+--          * If I saw topic's approval, but not its direct-Grant:
+--              * If I already accepted, raise error
+--              * Otherwise, record the approval in the Permit record in DB
+--          * If I already saw both, respond with error, as Permit is already enabled
 clientAccept
     :: UTCTime
     -> PersonId
@@ -149,6 +146,9 @@ clientAccept
     -> ActE OutboxItemId
 clientAccept now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) accept = do
 
+    -- Check input
+    acceptee <- parseAccept accept
+
     (actorMeID, localRecipsFinal, acceptID) <- withDBExcept $ do
 
         -- Grab me from DB
@@ -156,10 +156,56 @@ clientAccept now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
             p <- getJust personMeID
             (p,) <$> getJust (personActor p)
 
+        -- Find the accepted activity in our DB
+        accepteeDB <- do
+            a <- getActivity acceptee
+            fromMaybeE a "Can't find acceptee in DB"
+
         -- Insert the Accept activity to my outbox
         acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
         _luAccept <- lift $ updateOutboxItem' (LocalActorPerson personMeID) acceptID action
 
+        -- See if the accepted activity is an Invite to a resource, grabbing
+        -- the Permit record from our DB
+        maybePermit <- lift $ runMaybeT $ tryInvite accepteeDB
+
+        for_ maybePermit $ \ (permitID, _fulfillsID) -> do
+
+            -- Find the local person and verify it's me
+            Permit p _role <- lift $ getJust permitID
+            when (p == personMeID) $ do
+
+                -- Find the topic
+                topic <-
+                    lift $
+                    requireEitherAlt
+                        (getKeyBy $ UniquePermitTopicLocal permitID)
+                        (getKeyBy $ UniquePermitTopicRemote permitID)
+                        "Permit without topic"
+                        "Permit with both local and remote topic"
+
+                -- If I haven't seen topic's Accept, raise error
+                maybeTopicAccept <-
+                    lift $ case topic of
+                        Left localID -> void <$> getBy (UniquePermitTopicAcceptLocalTopic localID)
+                        Right remoteID -> void <$> getBy (UniquePermitTopicAcceptRemoteTopic remoteID)
+                when (isNothing maybeTopicAccept) $
+                    throwE "Haven't seen topic's Accept yet, please wait for it"
+
+                -- If I haven't seen the direct-Grant, and haven't already
+                -- accepted, record my accept
+                -- If I've already accepted or seen the direct-Grant, raise an error
+                maybeTopicEnable <-
+                    lift $ case topic of
+                        Left localID -> void <$> getBy (UniquePermitTopicEnableLocalTopic localID)
+                        Right remoteID -> void <$> getBy (UniquePermitTopicEnableRemoteTopic remoteID)
+                if isNothing maybeTopicEnable
+                    then do
+                        maybeInserted <- lift $ insertUnique $ PermitPersonGesture permitID acceptID
+                        when (isNothing maybeInserted) $
+                            throwE "I already Accepted this Invite"
+                    else throwE "I already have a direct-Grant for this Invite"
+
         return
             ( personActor personMe
             , localRecips
@@ -171,6 +217,19 @@ clientAccept now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
         fwdHosts acceptID action
     return acceptID
 
+    where
+
+    tryInvite (Left (actorByKey, _actorEntity, itemID)) = do
+        PermitTopicGestureLocal fulfillsID _ <-
+            MaybeT $ getValBy $ UniquePermitTopicGestureLocalInvite itemID
+        PermitFulfillsInvite permitID <- lift $ getJust fulfillsID
+        return (permitID, fulfillsID)
+    tryInvite (Right remoteActivityID) = do
+        PermitTopicGestureRemote fulfillsID _ _ <-
+            MaybeT $ getValBy $ UniquePermitTopicGestureRemoteInvite remoteActivityID
+        PermitFulfillsInvite permitID <- lift $ getJust fulfillsID
+        return (permitID, fulfillsID)
+
 -- Meaning: The human wants to add component C to project P
 -- Behavior:
 --      * Some basic sanity checks
@@ -207,7 +266,7 @@ clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts a
                 manager <- asksEnv envHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luComps
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ _ mluComps <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                AP.ResourceWithCollections _ _ mluComps _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
                 unless (mluComps == Just luComps) $
                     throwE "Add target isn't a components list"
 
@@ -620,6 +679,163 @@ clientCreateProject now personMeID (ClientMsg maybeCap localRecips remoteRecips
                 }
         return (action, recipientSet, remoteActors, fwdHosts)
 
+-- Meaning: The human wants to create a team
+-- Behavior:
+--      * Create a team on DB
+--      * Launch a team actor
+--      * Record a FollowRequest in DB
+--      * Create and send Create and Follow to it
+clientCreateTeam
+    :: UTCTime
+    -> PersonId
+    -> ClientMsg
+    -> AP.ActorDetail
+    -> ActE OutboxItemId
+clientCreateTeam now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) tracker = do
+
+    -- Check input
+    verifyNothingE maybeCap "Capability not needed"
+    (name, msummary) <- parseTracker tracker
+
+    (actorMeID, localRecipsFinal, createID, actionCreate, followID, follow, groupID) <- lift $ withDB $ do
+
+        -- Grab me from DB
+        (personMe, actorMe) <- do
+            p <- getJust personMeID
+            (p,) <$> getJust (personActor p)
+        let actorMeID = personActor personMe
+
+        -- Insert new team to DB
+        createID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
+        (groupID, projectFollowerSetID) <-
+            insertTeam now name msummary createID actorMeID
+
+        -- Insert the Create activity to my outbox
+        groupHash <- lift $ encodeKeyHashid groupID
+        actionCreate <- lift $ prepareCreate name msummary groupHash
+        luCreate <- updateOutboxItem' (LocalActorPerson personMeID) createID actionCreate
+
+        -- Prepare recipient sieve for sending the Create
+        personMeHash <- lift $ encodeKeyHashid personMeID
+        let sieve =
+                makeRecipientSet
+                    [LocalActorGroup groupHash]
+                    [LocalStagePersonFollowers personMeHash]
+            onlyGroup = GroupRoutes True False
+            addMe' groups = (groupHash, onlyGroup) : groups
+            addMe rs = rs { recipGroups = addMe' $ recipGroups rs }
+
+        -- Insert a follow request, since I'm about to send a Follow
+        followID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
+        insert_ $ FollowRequest actorMeID projectFollowerSetID True followID
+
+        -- Insert a Follow to my outbox
+        follow@(actionFollow, _, _, _) <- lift $ prepareFollow groupID luCreate
+        _luFollow <- updateOutboxItem' (LocalActorPerson personMeID) followID actionFollow
+
+        return
+            ( personActor personMe
+            , localRecipSieve sieve False $ addMe localRecips
+            , createID
+            , actionCreate
+            , followID
+            , follow
+            , groupID
+            )
+
+    -- Spawn new Group actor
+    success <- lift $ launchActor LocalActorGroup groupID
+    unless success $
+        error "Failed to spawn new Group, somehow ID already in Theater"
+
+    -- Send the Create
+    lift $ sendActivity
+        (LocalActorPerson personMeID) actorMeID localRecipsFinal remoteRecips
+        fwdHosts createID actionCreate
+
+    -- Send the Follow
+    let (actionFollow, localRecipsFollow, remoteRecipsFollow, fwdHostsFollow) = follow
+    lift $ sendActivity
+        (LocalActorPerson personMeID) actorMeID localRecipsFollow
+        remoteRecipsFollow fwdHostsFollow followID actionFollow
+
+    return createID
+
+    where
+
+    parseTracker (AP.ActorDetail typ muser mname msummary) = do
+        unless (typ == AP.ActorTypeTeam) $
+            error "clientCreateTeam: Create object isn't a Team"
+        verifyNothingE muser "Team can't have a username"
+        name <- fromMaybeE mname "Team doesn't specify name"
+        return (name, msummary)
+
+    insertTeam now name msummary obiidCreate actorMeID = do
+        ibid <- insert Inbox
+        obid <- insert Outbox
+        fsid <- insert FollowerSet
+        aid <- insert Actor
+            { actorName      = name
+            , actorDesc      = fromMaybe "" msummary
+            , actorCreatedAt = now
+            , actorInbox     = ibid
+            , actorOutbox    = obid
+            , actorFollowers = fsid
+            , actorJustCreatedBy = Just actorMeID
+            }
+        gid <- insert Group
+            { groupActor      = aid
+            , groupCreate     = obiidCreate
+            }
+        return (gid, fsid)
+
+    prepareCreate name msummary groupHash = do
+        encodeRouteLocal <- getEncodeRouteLocal
+        hLocal <- asksEnv stageInstanceHost
+        let ttdetail = AP.ActorDetail
+                { AP.actorType     = AP.ActorTypeTeam
+                , AP.actorUsername = Nothing
+                , AP.actorName     = Just name
+                , AP.actorSummary  = msummary
+                }
+            ttlocal = AP.ActorLocal
+                { AP.actorId         = encodeRouteLocal $ GroupR groupHash
+                , AP.actorInbox      = encodeRouteLocal $ GroupInboxR groupHash
+                , AP.actorOutbox     = Nothing
+                , AP.actorFollowers  = Nothing
+                , AP.actorFollowing  = Nothing
+                , AP.actorPublicKeys = []
+                , AP.actorSshKeys    = []
+                }
+            specific = AP.CreateActivity AP.Create
+                { AP.createObject = AP.CreateTeam ttdetail (Just (hLocal, ttlocal))
+                , AP.createTarget = Nothing
+                }
+        return action { AP.actionSpecific = specific }
+
+    prepareFollow groupID luCreate = do
+        encodeRouteHome <- getEncodeRouteHome
+        h <- asksEnv stageInstanceHost
+        groupHash <- encodeKeyHashid groupID
+
+        let audTopic = AudLocal [LocalActorGroup groupHash] []
+            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience [audTopic]
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            action = AP.Action
+                { AP.actionCapability = Nothing
+                , AP.actionSummary    = Nothing
+                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                , AP.actionFulfills   = [ObjURI h luCreate]
+                , AP.actionSpecific   = AP.FollowActivity AP.Follow
+                    { AP.followObject  = encodeRouteHome $ GroupR groupHash
+                    , AP.followContext = Nothing
+                    , AP.followHide    = False
+                    }
+                }
+        return (action, recipientSet, remoteActors, fwdHosts)
+
 clientCreate
     :: UTCTime
     -> PersonId
@@ -639,6 +855,11 @@ clientCreate now personMeID msg (AP.Create object muTarget) =
             verifyNothingE muTarget "'target' not supported in Create Project"
             clientCreateProject now personMeID msg detail
 
+        AP.CreateTeam detail mlocal -> do
+            verifyNothingE mlocal "Team id must not be provided"
+            verifyNothingE muTarget "'target' not supported in Create Team"
+            clientCreateTeam now personMeID msg detail
+
         _ -> throwE "Unsupported Create object for C2S"
 
 -- Meaning: The human wants to invite someone A to a resource R
@@ -672,15 +893,15 @@ 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
                 manager <- asksEnv envHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ mluCollabs mluComps <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
-                unless (mluCollabs == Just luColl || mluComps == Just luColl) $
+                AP.ResourceWithCollections _ mluCollabs mluComps mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                unless (mluCollabs == Just luColl || mluComps == Just luColl || mluMembers == Just luColl) $
                     throwE "Invite target isn't a collabs/components list"
 
                 instanceID <-
@@ -721,7 +942,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)
@@ -747,12 +968,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
@@ -763,7 +984,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
@@ -783,6 +1004,150 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
         fwdHosts inviteID action
     return inviteID
 
+-- Meaning: The human wants to join a resource R
+-- Behavior:
+--      * Some basic sanity checks
+--          * Parse the Join
+--          * Make sure not joining myself
+--          * Verify that a capability isn't specified
+--          * If resource is local, verify it exists in DB
+--      * Verify the resource R is addressed in the Join
+--      * Insert Join to my outbox
+--
+--      * If R is referred by a collabs/members collection URI:
+--          * For each Permit record I have for this resource:
+--              * Verify it's not enabled yet, i.e. I'm not already a
+--                collaborator, haven't received a direct-Grant
+--              * Verify it's not in Invite-Accept state, already got the
+--                resource's Accept and waiting for my approval or for the
+--                topic's Grant
+--              * Verify it's not a Join
+--          * Create a Permit record in DB
+--
+--      * Asynchrnously deliver to:
+--          * Resource+followers
+--          * My followers
+clientJoin
+    :: UTCTime
+    -> PersonId
+    -> ClientMsg
+    -> AP.Join URIMode
+    -> ActE OutboxItemId
+clientJoin now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) join = do
+
+    -- Check input
+    (role, resource) <- parseJoin join
+    verifyNothingE maybeCap "Capability provided"
+
+    -- If resource collabs URI is remote, HTTP GET it and its resource and its
+    -- managing actor, and insert to our DB. If resource is local, find it in
+    -- our DB.
+    resourceDB <-
+        bitraverse
+            (withDBExcept . flip getLocalActorEntityE "Join resource not found in DB")
+            (\ u@(ObjURI h luColl) -> do
+                manager <- asksEnv envHttpManager
+                coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
+                lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
+                AP.ResourceWithCollections _ mluCollabs mluComps mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                let isCollabs = mluCollabs == Just luColl || mluMembers == Just luColl
+                unless (isCollabs || mluComps == Just luColl) $
+                    throwE "Join resource isn't a collabs/components list"
+
+                instanceID <-
+                    lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                result <-
+                    ExceptT $ first (T.pack . show) <$>
+                        fetchRemoteResource instanceID h lu
+                case result of
+                    Left (Entity actorID actor) ->
+                        return (remoteActorIdent actor, actorID, u, isCollabs)
+                    Right (objectID, luManager, (Entity actorID _)) ->
+                        return (objectID, actorID, ObjURI h luManager, isCollabs)
+            )
+            resource
+
+    -- Verify that resource is addressed by the Join
+    bitraverse_
+        (verifyActorAddressed localRecips . bmap entityKey)
+        (\ (_, _, u, _) -> verifyRemoteAddressed remoteRecips u)
+        resourceDB
+
+    let maybePermit =
+            case resourceDB of
+                Left la -> Just $ Left la
+                Right (_, _, _, False) -> Nothing
+                Right (objectID, actorID, uActor, True) -> Just $ Right (objectID, actorID, uActor)
+
+    (actorMeID, localRecipsFinal, joinID) <- withDBExcept $ do
+
+        -- Grab me from DB
+        (personMe, actorMe) <- lift $ do
+            p <- getJust personMeID
+            (p,) <$> getJust (personActor p)
+
+        -- Insert the Join activity to my outbox
+        joinID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
+        _luJoin <- lift $ updateOutboxItem' (LocalActorPerson personMeID) joinID action
+
+        for_ maybePermit $ \ topicDB -> do
+
+            -- Find existing Permit records I have for this topic
+            -- Make sure none are enabled / in Join mode / in Invite-Accept
+            -- mode
+            checkExistingPermits
+                personMeID
+                (bimap (bmap entityKey) (view _2) topicDB)
+
+            -- Insert Permit record to DB
+            insertPermit topicDB joinID role
+
+        -- Prepare local recipients for Join delivery
+        sieve <- lift $ do
+            resourceHash <- bitraverse hashLocalActor pure resource
+            senderHash <- encodeKeyHashid personMeID
+            let sieveActors = catMaybes
+                    [ case resourceHash of
+                        Left a  -> Just a
+                        Right _ -> Nothing
+                    ]
+                sieveStages = catMaybes
+                    [ Just $ LocalStagePersonFollowers senderHash
+                    , case resourceHash of
+                        Left a  -> Just $ localActorFollowers a
+                        Right _ -> Nothing
+                    ]
+            return $ makeRecipientSet sieveActors sieveStages
+        return
+            ( personActor personMe
+            , localRecipSieve sieve False localRecips
+            , joinID
+            )
+
+    lift $ sendActivity
+        (LocalActorPerson personMeID) actorMeID localRecipsFinal remoteRecips
+        fwdHosts joinID action
+    return joinID
+
+    where
+
+    insertPermit resourceDB joinID role = do
+        permitID <- lift $ insert $ Permit personMeID role
+        case resourceDB of
+            Left la -> do
+                localID <- lift $ insert $ PermitTopicLocal permitID
+                case bmap entityKey la of
+                    LocalActorPerson _ -> throwE "insertPermit: Person not supported as a PermitTopicLocal type (you can't become a \"collaborator in a person\""
+                    LocalActorRepo r -> lift $ insert_ $ PermitTopicRepo localID r
+                    LocalActorDeck d -> lift $ insert_ $ PermitTopicDeck localID d
+                    LocalActorLoom l -> lift $ insert_ $ PermitTopicLoom localID l
+                    LocalActorProject j -> lift $ insert_ $ PermitTopicProject localID j
+                    LocalActorGroup g -> lift $ insert_ $ PermitTopicGroup localID g
+            Right (_, actorID, _) -> lift $ insert_ $ PermitTopicRemote permitID actorID
+        lift $ do
+            insert_ $ PermitFulfillsJoin permitID
+            insert_ $ PermitPersonGesture permitID joinID
+
 -- Meaning: The human wants to open a ticket/MR/dependency
 -- Behavior:
 --      * Basics checks on the provided ticket/MR (dependency not allowed)
@@ -913,8 +1278,8 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
                 manager <- asksEnv envHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ mluCollabs _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
-                unless (mluCollabs == Just luColl) $
+                AP.ResourceWithCollections _ mluCollabs _ mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                unless (mluCollabs == Just luColl || mluMembers == Just luColl) $
                     throwE "Remove origin isn't a collabs list"
                 return $ ObjURI h lu
             )
@@ -922,7 +1287,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'
 
@@ -937,7 +1302,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'
 
@@ -959,15 +1324,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 (GrantResourceDeck d) -> Just $ LocalActorDeck d
-                        Left (GrantResourceLoom l) -> Just $ LocalActorLoom l
-                        Left (GrantResourceProject l) -> Just $ LocalActorProject l
+                        Left a -> Just a
                         Right _                    -> Nothing
                     , case recipientHash of
                         Left (GrantRecipPerson p) -> Just $ LocalActorPerson p
@@ -976,10 +1338,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
                 sieveStages = catMaybes
                     [ Just $ LocalStagePersonFollowers senderHash
                     , case resourceHash of
-                        Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r
-                        Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d
-                        Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l
-                        Left (GrantResourceProject l) -> Just $ LocalStageProjectFollowers l
+                        Left a -> Just $ localActorFollowers a
                         Right _                    -> Nothing
                     , case recipientHash of
                         Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p
@@ -1073,6 +1432,7 @@ clientBehavior now personID msg =
         AP.AddActivity add       -> clientAdd now personID msg add
         AP.CreateActivity create -> clientCreate now personID msg create
         AP.InviteActivity invite -> clientInvite now personID msg invite
+        AP.JoinActivity join     -> clientJoin now personID msg join
         AP.OfferActivity offer   -> clientOffer now personID msg offer
         AP.RemoveActivity remove -> clientRemove now personID msg remove
         AP.ResolveActivity resolve -> clientResolve now personID msg resolve

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
-                    -- Grants
+                    -- In collab mode, prepare a regular Grant
                     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
-
-                        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)
+                        return $ Just (grantID, grant)
 
                     -- 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
---        Grant, and store it in the Componet record in DB:
+--      * For each person (non-team) collaborator of mine, prepare and send an
+--        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,115 +952,13 @@ 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
 
-    maybeNew <- withDBExcept $ do
-
-        -- Grab me from DB
-        (recipActorID, recipActor) <- lift $ do
-            recip <- getJust projectID
-            let actorID = projectActor recip
-            (actorID,) <$> getJust actorID
-
-        -- Find the Component record from the capability
-        Entity enableID (ComponentEnable componentID _) <- do
-            unless (fst capability == LocalActorProject projectID) $
-                throwE "Capability isn't mine"
-            m <- lift $ getBy $ UniqueComponentEnableGrant $ snd capability
-            fromMaybeE m "I don't have a Component with this capability"
-        Component j role' <- lift $ getJust componentID
-        unless (j == projectID) $
-            throwE "Found a Component for this delegator-Grant but it's not mine"
-        unless (role' == role) $
-            throwE "Grant role isn't the same as in the Invite/Add"
-        ident <- lift $ getComponentIdent componentID
-        identForCheck <-
-            lift $
-            bitraverse
-                (pure . snd)
-                (\ (_, raID) -> getRemoteActorURI =<< getJust raID)
-                ident
-        unless (identForCheck == component) $
-            throwE "Capability's component and Grant author aren't the same actor"
-
-        -- Verify I don't yet have a delegation from the component
-        maybeDeleg <-
-            lift $ case bimap fst fst ident of
-                Left localID -> (() <$) <$> getBy (UniqueComponentDelegateLocal localID)
-                Right remoteID -> (() <$) <$> getBy (UniqueComponentDelegateRemote remoteID)
-        verifyNothingE maybeDeleg "I already have a delegation-start Grant from this component"
-
-        maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
-        for maybeGrantDB $ \ grantDB -> do
-
-            -- Record the delegation in DB
-            lift $ case (grantDB, bimap fst fst ident) of
-                (Left (_, _, grantID), Left localID) -> insert_ $ ComponentDelegateLocal localID grantID
-                (Right (_, _, grantID), Right remoteID) -> insert_ $ ComponentDelegateRemote remoteID grantID
-                _ -> error "projectGrant impossible"
-
-            -- Prepare forwarding of Accept to my followers
-            projectHash <- encodeKeyHashid projectID
-            let sieve = makeRecipientSet [] [LocalStageProjectFollowers projectHash]
-
-            -- 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.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
-                        )
-            localExtensions <- lift $ for localCollabs $ \ (E.Value role', E.Value recipID, E.Value personID, E.Value enableID') -> do
-                extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
-                insert_ $ ComponentFurtherLocal enableID recipID extID
-                ext@(actionExt, _, _, _) <-
-                    prepareExtensionGrant identForCheck (Left personID) (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.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
-                        )
-            remoteExtensions <- lift $ for remoteCollabs $ \ (E.Value role', E.Value recipID, E.Value raID, E.Value enableID') -> do
-                extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
-                insert_ $ ComponentFurtherRemote enableID recipID extID
-                ext@(actionExt, _, _, _) <-
-                    prepareExtensionGrant identForCheck (Right raID) (min role role') enableID'
-                let recipByKey = LocalActorProject projectID
-                _luExt <- updateOutboxItem' recipByKey extID actionExt
-                return (extID, ext)
-
-            return (recipActorID, sieve, localExtensions, remoteExtensions)
-
-    case maybeNew of
-        Nothing -> done "I already have this activity in my inbox"
-        Just (recipActorID, sieve, localExts, remoteExts) -> do
-            let recipByID = LocalActorProject projectID
-            forwardActivity authorIdMsig body recipByID recipActorID sieve
-            lift $ for_ (localExts ++ remoteExts) $
-                \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) ->
-                    sendActivity
-                        recipByID recipActorID localRecipsExt
-                        remoteRecipsExt fwdHostsExt extID actionExt
-            done "Forwarded the Grant and published delegation extensions"
+    case grant' of
+        Left (role, component) -> handleComp capability role component
+        Right collab -> handleCollab capability collab
 
     where
 
@@ -1176,7 +971,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
                 AP.RXDelegator -> throwE "Role is delegator"
         component <-
             fromMaybeE
-                (bitraverse resourceToComponent Just resource)
+                (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 ()
@@ -1195,64 +990,401 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
             throwE "'delegates' is specified"
         return (role', component)
 
-    prepareExtensionGrant component collab role enableID = do
-        encodeRouteHome <- getEncodeRouteHome
-        encodeRouteLocal <- getEncodeRouteLocal
+    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
 
-        projectHash <- encodeKeyHashid projectID
-        uStart <- lift $ getActivityURI authorIdMsig
+    handleComp capability role component = do
 
-        (uCollab, audCollab) <-
-            case collab of
-                Left personID -> do
-                    personHash <- encodeKeyHashid personID
-                    return
-                        ( encodeRouteHome $ PersonR personHash
-                        , AudLocal [LocalActorPerson personHash] []
-                        )
-                Right raID -> do
-                    ra <- getJust raID
-                    u@(ObjURI h lu) <- getRemoteActorURI ra
-                    return (u, AudRemote h [lu] [])
+        maybeNew <- withDBExcept $ do
 
-        uComponent <-
-            case component of
-                Left c -> do
-                    a <- componentActor <$> hashComponent c
-                    return $ encodeRouteHome $ renderLocalActor a
-                Right u -> pure u
+            -- Grab me from DB
+            (recipActorID, recipActor) <- lift $ do
+                recip <- getJust projectID
+                let actorID = projectActor recip
+                (actorID,) <$> getJust actorID
 
-        enableHash <- encodeKeyHashid enableID
+            -- Find the Component record from the capability
+            Entity enableID (ComponentEnable componentID _) <- do
+                unless (fst capability == LocalActorProject projectID) $
+                    throwE "Capability isn't mine"
+                m <- lift $ getBy $ UniqueComponentEnableGrant $ snd capability
+                fromMaybeE m "I don't have a Component with this capability"
+            Component j role' <- lift $ getJust componentID
+            unless (j == projectID) $
+                throwE "Found a Component for this delegator-Grant but it's not mine"
+            unless (role' == role) $
+                throwE "Grant role isn't the same as in the Invite/Add"
+            ident <- lift $ getComponentIdent componentID
+            identForCheck <-
+                lift $
+                bitraverse
+                    (pure . snd)
+                    (\ (_, raID) -> getRemoteActorURI =<< getJust raID)
+                    ident
+            unless (identForCheck == component) $
+                throwE "Capability's component and Grant author aren't the same actor"
 
-        let audience = [audCollab]
+            -- Verify I don't yet have a delegation from the component
+            maybeDeleg <-
+                lift $ case bimap fst fst ident of
+                    Left localID -> (() <$) <$> getBy (UniqueComponentDelegateLocal localID)
+                    Right remoteID -> (() <$) <$> getBy (UniqueComponentDelegateRemote remoteID)
+            verifyNothingE maybeDeleg "I already have a delegation-start Grant from this component"
 
-            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
-                collectAudience audience
+            maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
+            for maybeGrantDB $ \ grantDB -> do
 
-            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
+                -- Record the delegation in DB
+                lift $ case (grantDB, bimap fst fst ident) of
+                    (Left (_, _, grantID), Left localID) -> insert_ $ ComponentDelegateLocal localID grantID
+                    (Right (_, _, grantID), Right remoteID) -> insert_ $ ComponentDelegateRemote remoteID grantID
+                    _ -> error "projectGrant impossible"
+
+                -- Prepare forwarding of Accept to my followers
+                projectHash <- encodeKeyHashid projectID
+                let sieve = makeRecipientSet [] [LocalStageProjectFollowers projectHash]
+
+                -- 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 `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.^. CollabRecipLocalPerson
+                            , deleg
                             )
-                    , AP.grantStart     = Just now
-                    , AP.grantEnd       = Nothing
-                    , AP.grantAllows    = AP.Invoke
-                    , AP.grantDelegates = Just uStart
-                    }
-                }
+                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 delegID extID
+                    ext@(actionExt, _, _, _) <-
+                        prepareExtensionGrant identForCheck (Left (personID, grantID)) (min role role') enableID'
+                    let recipByKey = LocalActorProject projectID
+                    _luExt <- updateOutboxItem' recipByKey extID actionExt
+                    return (extID, ext)
 
-        return (action, recipientSet, remoteActors, fwdHosts)
+                remoteCollabs <-
+                    lift $
+                    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.^. CollabRecipRemoteActor
+                            , deleg
+                            )
+                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 delegID extID
+                    ext@(actionExt, _, _, _) <-
+                        prepareExtensionGrant identForCheck (Right (raID, grantID)) (min role role') enableID'
+                    let recipByKey = LocalActorProject projectID
+                    _luExt <- updateOutboxItem' recipByKey extID actionExt
+                    return (extID, ext)
+
+                return (recipActorID, sieve, localExtensions, remoteExtensions)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (recipActorID, sieve, localExts, remoteExts) -> do
+                let recipByID = LocalActorProject projectID
+                forwardActivity authorIdMsig body recipByID recipActorID sieve
+                lift $ for_ (localExts ++ remoteExts) $
+                    \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) ->
+                        sendActivity
+                            recipByID recipActorID localRecipsExt
+                            remoteRecipsExt fwdHostsExt extID actionExt
+                done "Forwarded the start-Grant and published delegation extensions"
+
+        where
+
+        prepareExtensionGrant component collab role enableID = do
+            encodeRouteHome <- getEncodeRouteHome
+            encodeRouteLocal <- getEncodeRouteLocal
+
+            projectHash <- encodeKeyHashid projectID
+            uStart <- lift $ getActivityURI authorIdMsig
+
+            (uCollab, audCollab, uDeleg) <-
+                case collab of
+                    Left (personID, itemID) -> do
+                        personHash <- encodeKeyHashid personID
+                        itemHash <- encodeKeyHashid itemID
+                        return
+                            ( encodeRouteHome $ PersonR personHash
+                            , AudLocal [LocalActorPerson personHash] []
+                            , encodeRouteHome $
+                                PersonOutboxItemR personHash itemHash
+                            )
+                    Right (raID, ractID) -> do
+                        ra <- getJust raID
+                        u@(ObjURI h lu) <- getRemoteActorURI ra
+                        uAct <- do
+                            ract <- getJust ractID
+                            getRemoteActivityURI ract
+                        return (u, AudRemote h [lu] [], uAct)
+
+            uComponent <-
+                case component of
+                    Left c -> do
+                        a <- componentActor <$> hashComponent c
+                        return $ encodeRouteHome $ renderLocalActor a
+                    Right u -> pure u
+
+            enableHash <- encodeKeyHashid enableID
+
+            let audience = [audCollab]
+
+                (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                    collectAudience audience
+
+                recips = map encodeRouteHome audLocal ++ audRemote
+                action = AP.Action
+                    { 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]
+                    , 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)
 
 -- Meaning: An actor A invited actor B to a resource
 -- Behavior:
@@ -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

@@ -38,6 +38,7 @@ module Vervis.Client
     , createLoom
     , createRepo
     , createProject
+    , createGroup
     , invite
     , remove
     , inviteComponent
@@ -1050,6 +1051,27 @@ createProject senderHash name desc = do
 
     return (Nothing, audience, detail)
 
+createGroup
+    :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
+    => KeyHashid Person
+    -> Text
+    -> Text
+    -> m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
+createGroup senderHash name desc = do
+    let audAuthor =
+            AudLocal [] [LocalStagePersonFollowers senderHash]
+
+        audience = [audAuthor]
+
+        detail = AP.ActorDetail
+            { AP.actorType     = AP.ActorTypeTeam
+            , AP.actorUsername = Nothing
+            , AP.actorName     = Just name
+            , AP.actorSummary  = Just desc
+            }
+
+    return (Nothing, audience, detail)
+
 invite
     :: PersonId
     -> FedURI
@@ -1090,15 +1112,15 @@ invite personID uRecipient uResourceCollabs role = do
                 manager <- asksSite appHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ mluCollabs _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
-                unless (mluCollabs == Just luColl) $
+                AP.ResourceWithCollections _ mluCollabs _ mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                unless (mluCollabs == Just luColl || mluMembers == Just luColl) $
                     throwE "Invite target isn't a collabs list"
                 return $ ObjURI h lu
             )
             resource
     resourceDB <-
         bitraverse
-            hashGrantResource
+            VR.hashLocalActor
             (\ u@(ObjURI h lu) -> do
                 instanceID <-
                     lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
@@ -1136,14 +1158,7 @@ invite personID uRecipient uResourceCollabs role = do
 
     let audResource =
             case resourceDB of
-                Left (GrantResourceRepo r) ->
-                    AudLocal [LocalActorRepo r] [LocalStageRepoFollowers r]
-                Left (GrantResourceDeck d) ->
-                    AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d]
-                Left (GrantResourceLoom l) ->
-                    AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l]
-                Left (GrantResourceProject l) ->
-                    AudLocal [LocalActorProject l] [LocalStageProjectFollowers l]
+                Left la -> AudLocal [la] [localActorFollowers la]
                 Right (remoteActor, ObjURI h lu) ->
                     AudRemote h
                         [lu]
@@ -1202,8 +1217,8 @@ remove personID uRecipient uResourceCollabs = do
                 manager <- asksSite appHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ mluCollabs _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
-                unless (mluCollabs == Just luColl) $
+                AP.ResourceWithCollections _ mluCollabs _ mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                unless (mluCollabs == Just luColl || mluMembers == Just luColl) $
                     throwE "Remove origin isn't a collabs list"
                 return $ ObjURI h lu
             )
@@ -1213,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)
@@ -1251,14 +1266,7 @@ remove personID uRecipient uResourceCollabs = do
 
     let audResource =
             case resourceDB of
-                Left (GrantResourceRepo r) ->
-                    AudLocal [LocalActorRepo r] [LocalStageRepoFollowers r]
-                Left (GrantResourceDeck d) ->
-                    AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d]
-                Left (GrantResourceLoom l) ->
-                    AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l]
-                Left (GrantResourceProject l) ->
-                    AudLocal [LocalActorProject l] [LocalStageProjectFollowers l]
+                Left la -> AudLocal [la] [localActorFollowers la]
                 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,16 +82,11 @@ import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 
-parseGrantResource (RepoR r) = Just $ GrantResourceRepo r
-parseGrantResource (DeckR d) = Just $ GrantResourceDeck d
-parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
-parseGrantResource (ProjectR l) = Just $ GrantResourceProject 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 (RepoCollabsR r) = Just $ LocalActorRepo r
+parseGrantResourceCollabs (DeckCollabsR d) = Just $ LocalActorDeck d
+parseGrantResourceCollabs (LoomCollabsR l) = Just $ LocalActorLoom l
+parseGrantResourceCollabs (ProjectCollabsR l) = Just $ LocalActorProject l
+parseGrantResourceCollabs (GroupMembersR l) = Just $ LocalActorGroup l
 parseGrantResourceCollabs _         = Nothing
 
 data GrantRecipBy f = GrantRecipPerson (f Person)
@@ -142,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
@@ -156,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
@@ -168,7 +149,7 @@ parseTopic' u = do
                     fromMaybeE
                         (parseGrantResourceCollabs route)
                         "Not a shared resource collabs route"
-                unhashGrantResourceE'
+                unhashLocalActorE
                     resourceHash
                     "Contains invalid hashid"
         )
@@ -240,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) =
@@ -252,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)
@@ -262,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
@@ -296,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 <-
-                    fromMaybeE
-                        (parseGrantResource route)
-                        "Grant context isn't a shared resource route"
-                unhashGrantResourceE'
-                    resourceHash
-                    "Grant resource contains invalid hashid"
+                parseLocalActorE' route
             else pure $ Right lu
     parseTarget u@(ObjURI h lu) = do
         hl <- hostIsLocal h
@@ -325,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
@@ -356,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 <-
-                    fromMaybeE
-                        (parseGrantResource route)
-                        "Grant context isn't a shared resource route"
-                unhashGrantResourceE'
-                    resourceHash
-                    "Grant resource contains invalid hashid"
+                parseLocalActorE' route
             else pure $ Right u
     parseTarget u@(ObjURI h lu) = do
         hl <- hostIsLocal h
@@ -395,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) =
@@ -451,91 +420,13 @@ parseAdd sender (AP.Add object target role) = do
             pure
             routeOrRemote
 
-grantResourceActorID :: GrantResourceBy Identity -> ActorId
-grantResourceActorID (GrantResourceRepo (Identity r)) = repoActor r
-grantResourceActorID (GrantResourceDeck (Identity d)) = deckActor d
-grantResourceActorID (GrantResourceLoom (Identity l)) = loomActor l
-grantResourceActorID (GrantResourceProject (Identity l)) = projectActor l
-
-data GrantResourceBy f
-    = GrantResourceRepo (f Repo)
-    | GrantResourceDeck (f Deck)
-    | GrantResourceLoom (f Loom)
-    | GrantResourceProject (f Project)
-    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
-
-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' (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
-
-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
-
-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
-
-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
+grantResourceActorID :: LocalActorBy Identity -> ActorId
+grantResourceActorID (LocalActorPerson (Identity p)) = personActor p
+grantResourceActorID (LocalActorRepo (Identity r)) = repoActor r
+grantResourceActorID (LocalActorDeck (Identity d)) = deckActor d
+grantResourceActorID (LocalActorLoom (Identity l)) = loomActor l
+grantResourceActorID (LocalActorProject (Identity j)) = projectActor j
+grantResourceActorID (LocalActorGroup (Identity g)) = groupActor g
 
 data ComponentBy f
     = ComponentRepo (f Repo)
@@ -573,11 +464,13 @@ componentActor (ComponentRepo r) = LocalActorRepo r
 componentActor (ComponentDeck d) = LocalActorDeck d
 componentActor (ComponentLoom l) = LocalActorLoom l
 
-resourceToComponent = \case
-    GrantResourceRepo k -> Just $ ComponentRepo k
-    GrantResourceDeck k -> Just $ ComponentDeck k
-    GrantResourceLoom k -> Just $ ComponentLoom k
-    GrantResourceProject _ -> Nothing
+actorToComponent = \case
+    LocalActorPerson _ -> Nothing
+    LocalActorRepo k -> Just $ ComponentRepo k
+    LocalActorDeck k -> Just $ ComponentDeck k
+    LocalActorLoom k -> Just $ ComponentLoom k
+    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/Form/Tracker.hs

@@ -18,6 +18,8 @@ module Vervis.Form.Tracker
     , newDeckForm
     , NewProject (..)
     , newProjectForm
+    , NewGroup (..)
+    , newGroupForm
     , NewLoom (..)
     , newLoomForm
     , DeckInvite (..)
@@ -73,6 +75,16 @@ newProjectForm = renderDivs $ NewProject
     <$> areq textField "Name*"       Nothing
     <*> areq textField "Description" Nothing
 
+data NewGroup = NewGroup
+    { ngName  :: Text
+    , ngDesc  :: Text
+    }
+
+newGroupForm :: Form NewGroup
+newGroupForm = renderDivs $ NewGroup
+    <$> areq textField "Name*"       Nothing
+    <*> areq textField "Description" Nothing
+
 data NewLoom = NewLoom
     { nlName  :: Text
     , nlDesc  :: Text

src/Vervis/Foundation.hs

@@ -872,6 +872,7 @@ instance YesodBreadcrumbs App where
 
         PersonStampR p k -> ("Stamp #" <> keyHashidText k, Just $ PersonR p)
 
+        GroupNewR            -> ("New Team", Just HomeR)
         GroupR g             -> ("Team &" <> keyHashidText g, Just HomeR)
         GroupInboxR g        -> ("Inbox", Just $ GroupR g)
         GroupOutboxR g       -> ("Outbox", Just $ GroupR g)
@@ -882,6 +883,8 @@ instance YesodBreadcrumbs App where
 
         GroupStampR g k -> ("Stamp #" <> keyHashidText k, Just $ GroupR g)
 
+        GroupMembersR g -> ("Members", Just $ GroupR g)
+
         RepoR r             -> ("Repo ^" <> keyHashidText r, Just HomeR)
         RepoInboxR r        -> ("Inbox", Just $ RepoR r)
         RepoOutboxR r       -> ("Outbox", Just $ RepoR r)

src/Vervis/Handler/Client.hs

@@ -51,6 +51,8 @@ import Control.Applicative
 import Control.Concurrent.STM.TVar
 import Control.Monad
 import Control.Monad.Trans.Except
+import Data.Bifunctor
+import Data.Bitraversable
 import Data.List
 import Data.Text (Text)
 import Data.Time.Clock
@@ -90,14 +92,17 @@ import Yesod.Form.Local
 import Vervis.API
 import Vervis.Client
 import Vervis.Data.Actor
+import Vervis.Data.Collab
 import Vervis.FedURI
 import Vervis.Form.Ticket
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
+import Vervis.Persist.Collab
 import Vervis.Recipient
 import Vervis.Settings
 import Vervis.Web.Actor
+import Vervis.Widget.Tracker
 
 -- | Account verification email resend form
 getResendVerifyEmailR :: Handler Html
@@ -125,7 +130,7 @@ getHomeR = do
     where
     personalOverview :: Entity Person -> Handler Html
     personalOverview (Entity pid _person) = do
-        (repos, decks, looms, projects) <- runDB $ (,,,)
+        (repos, decks, looms, projects, groups) <- runDB $ (,,,,)
             <$> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` repo `E.InnerJoin` actor) -> do
                     E.on $ repo E.^. RepoActor E.==. actor E.^. ActorId
                     E.on $ topic E.^. CollabTopicRepoRepo E.==. repo E.^. RepoId
@@ -166,10 +171,21 @@ getHomeR = do
                     E.orderBy [E.asc $ project E.^. ProjectId]
                     return (project, actor, collab)
                 )
+            <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` group `E.InnerJoin` actor) -> do
+                    E.on $ group E.^. GroupActor E.==. actor E.^. ActorId
+                    E.on $ topic E.^. CollabTopicGroupGroup E.==. group E.^. GroupId
+                    E.on $ topic E.^. CollabTopicGroupCollab E.==. enable E.^. CollabEnableCollab
+                    E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicGroupCollab
+                    E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId
+                    E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid
+                    E.orderBy [E.asc $ group E.^. GroupId]
+                    return (group, actor, collab)
+                )
         hashRepo <- getEncodeKeyHashid
         hashDeck <- getEncodeKeyHashid
         hashLoom <- getEncodeKeyHashid
         hashProject <- getEncodeKeyHashid
+        hashGroup <- getEncodeKeyHashid
         defaultLayout $(widgetFile "personal-overview")
 
 getBrowseR :: Handler Html
@@ -201,10 +217,37 @@ getBrowseR = do
                     E.orderBy [E.asc $ loom E.^. LoomId]
                     return (loom, actor)
                 )
-            <*> (E.select $ E.from $ \ (project `E.InnerJoin` actor) -> do
-                    E.on $ project E.^. ProjectActor E.==. actor E.^. ActorId
-                    E.orderBy [E.asc $ project E.^. ProjectId]
-                    return (project, actor)
+            <*> (do js <-
+                        E.select $ E.from $ \ (project `E.InnerJoin` actor) -> do
+                            E.on $ project E.^. ProjectActor E.==. actor E.^. ActorId
+                            E.orderBy [E.asc $ project E.^. ProjectId]
+                            return (project, actor)
+                    for js $ \ (j@(Entity projectID _), jactor) -> do
+                        cs <-
+                            E.select $ E.from $ \ (comp `E.InnerJoin` enable) -> do
+                                E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent
+                                E.where_ $ comp E.^. ComponentProject E.==. E.val projectID
+                                return comp
+                        cs' <- for cs $ \ (Entity cid _) -> do
+                            byKeyOrRaid <- bimap snd snd <$> getComponentIdent cid
+                            bitraverse
+                                (\ byKey -> do
+                                    actorID <-
+                                        case byKey of
+                                            ComponentRepo k -> repoActor <$> getJust k
+                                            ComponentDeck k -> deckActor <$> getJust k
+                                            ComponentLoom k -> loomActor <$> getJust k
+                                    actor <- getJust actorID
+                                    return (byKey, actor)
+                                )
+                                (\ remoteActorID -> do
+                                    remoteActor <- getJust remoteActorID
+                                    remoteObject <- getJust $ remoteActorIdent remoteActor
+                                    inztance <- getJust $ remoteObjectInstance remoteObject
+                                    return (inztance, remoteObject, remoteActor)
+                                )
+                                byKeyOrRaid
+                        return (j, jactor, cs')
                 )
         {-
         now <- liftIO getCurrentTime

src/Vervis/Handler/Group.hs

@@ -14,7 +14,10 @@
  -}
 
 module Vervis.Handler.Group
-    ( getGroupR
+    ( getGroupNewR
+    , postGroupNewR
+
+    , getGroupR
     , getGroupInboxR
     , postGroupInboxR
     , getGroupOutboxR
@@ -24,7 +27,7 @@ module Vervis.Handler.Group
 
     , getGroupStampR
 
-
+    , getGroupMembersR
 
 
 
@@ -33,9 +36,6 @@ module Vervis.Handler.Group
 
     {-
     , getGroupsR
-    , postGroupsR
-    , getGroupNewR
-    , getGroupMembersR
     , postGroupMembersR
     , getGroupMemberNewR
     , getGroupMemberR
@@ -45,16 +45,37 @@ module Vervis.Handler.Group
     )
 where
 
+import Control.Applicative
+import Control.Monad
 import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
+import Data.Aeson
+import Data.Bifunctor
+import Data.Bitraversable
+import Data.ByteString (ByteString)
+import Data.Default.Class
+import Data.Foldable
+import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import Data.Time.Clock
+import Data.Traversable
 import Database.Persist
-import Data.ByteString (ByteString)
+import Network.HTTP.Types.Method
+import Text.Blaze.Html (Html)
+import Yesod.Auth (requireAuth)
 import Yesod.Core
-import Yesod.Core.Content (TypedContent)
-import Yesod.Persist.Core
+import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound)
+import Yesod.Form.Functions (runFormPost, runFormGet)
+import Yesod.Form.Types (FormResult (..))
+import Yesod.Persist.Core (runDB, get404, getBy404)
 
+import qualified Data.ByteString.Lazy as BL
+import qualified Database.Esqueleto as E
+
+import Database.Persist.JSON
+import Development.PatchMediaType
 import Network.FedURI
+import Web.ActivityPub hiding (Project (..), Repo (..), Actor (..), ActorDetail (..), ActorLocal (..))
 import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
@@ -62,13 +83,72 @@ import Yesod.MonadSite
 
 import qualified Web.ActivityPub as AP
 
+import Control.Monad.Trans.Except.Local
+import Data.Either.Local
+import Data.Paginate.Local
+import Database.Persist.Local
+import Yesod.Form.Local
+import Yesod.Persist.Local
+
+import Vervis.Access
+import Vervis.API
+import Vervis.Data.Collab
 import Vervis.Federation.Auth
+import Vervis.Federation.Collab
+import Vervis.Federation.Discussion
+import Vervis.Federation.Offer
+import Vervis.Federation.Ticket
 import Vervis.FedURI
+import Vervis.Form.Ticket
+import Vervis.Form.Tracker
 import Vervis.Foundation
 import Vervis.Model
+import Vervis.Paginate
+import Vervis.Persist.Actor
+import Vervis.Persist.Collab
 import Vervis.Recipient
 import Vervis.Settings
+import Vervis.Ticket
+import Vervis.TicketFilter
+import Vervis.Time
 import Vervis.Web.Actor
+import Vervis.Widget
+import Vervis.Widget.Person
+import Vervis.Widget.Ticket
+import Vervis.Widget.Tracker
+
+import qualified Vervis.Client as C
+
+getGroupNewR :: Handler Html
+getGroupNewR = do
+    ((_result, widget), enctype) <- runFormPost newGroupForm
+    defaultLayout $(widgetFile "group/new")
+
+postGroupNewR :: Handler Html
+postGroupNewR = do
+    NewGroup name desc <- runFormPostRedirect GroupNewR newGroupForm
+
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+    (maybeSummary, audience, detail) <- C.createGroup personHash name desc
+    (localRecips, remoteRecips, fwdHosts, action) <-
+        C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateTeam detail Nothing) Nothing
+    result <-
+        runExceptT $
+        handleViaActor personID Nothing localRecips remoteRecips fwdHosts action
+
+    case result of
+        Left e -> do
+            setMessage $ toHtml e
+            redirect GroupNewR
+        Right createID -> do
+            maybeGroupID <- runDB $ getKeyBy $ UniqueGroupCreate createID
+            case maybeGroupID of
+                Nothing -> error "Can't find the newly created group"
+                Just groupID -> do
+                    groupHash <- encodeKeyHashid groupID
+                    setMessage "New group created"
+                    redirect $ GroupR groupHash
 
 getGroupR :: KeyHashid Group -> Handler TypedContent
 getGroupR groupHash = do
@@ -85,7 +165,7 @@ getGroupR groupHash = do
     perActor <- asksSite $ appPerActorKeys . appSettings
 
     let route mk = encodeRouteLocal $ mk groupHash
-        groupAP = AP.Actor
+        actorAP = AP.Actor
             { AP.actorLocal = AP.ActorLocal
                 { AP.actorId         = route GroupR
                 , AP.actorInbox      = route GroupInboxR
@@ -100,16 +180,20 @@ getGroupR groupHash = do
                 , AP.actorSshKeys    = []
                 }
             , AP.actorDetail = AP.ActorDetail
-                { AP.actorType       = AP.ActorTypeOther "Group"
+                { AP.actorType       = AP.ActorTypeTeam
                 , AP.actorUsername   = Nothing
                 , AP.actorName       = Just $ actorName actor
                 , AP.actorSummary    = Just $ actorDesc actor
                 }
             }
+        groupAP = AP.Team
+            { AP.teamActor    = actorAP
+            , AP.teamChildren = []
+            , AP.teamParents  = []
+            , AP.teamMembers  = encodeRouteLocal $ GroupMembersR groupHash
+            }
 
-    provideHtmlAndAP groupAP $ redirectToPrettyJSON here
-    where
-    here = GroupR groupHash
+    provideHtmlAndAP groupAP $(widgetFile "group/one")
 
 getGroupInboxR :: KeyHashid Group -> Handler TypedContent
 getGroupInboxR = getInbox GroupInboxR groupActor
@@ -136,7 +220,76 @@ getGroupMessageR _ _ = notFound
 getGroupStampR :: KeyHashid Group -> KeyHashid SigKey -> Handler TypedContent
 getGroupStampR = servePerActorKey groupActor LocalActorGroup
 
-
+getGroupMembersR :: KeyHashid Group -> Handler TypedContent
+getGroupMembersR groupHash = do
+    groupID <- decodeKeyHashid404 groupHash
+    members <- runDB $ do
+        _group <- get404 groupID
+        grants <-
+            getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID
+        for grants $ \ (role, actor, _ct, time) ->
+            (role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor
+    h <- asksSite siteInstanceHost
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    hashPerson <- getEncodeKeyHashid
+    let makeItem (role, time, i) = AP.Relationship
+            { AP.relationshipId           = Nothing
+            , AP.relationshipExtraTypes   = []
+            , AP.relationshipSubject      = encodeRouteHome $ GroupR groupHash
+            , AP.relationshipProperty     = Left AP.RelHasMember
+            , AP.relationshipObject       =
+                case i of
+                    Left personID -> encodeRouteHome $ PersonR $ hashPerson personID
+                    Right u -> u
+            , AP.relationshipAttributedTo = encodeRouteLocal $ GroupR groupHash
+            , AP.relationshipPublished    = Just time
+            , AP.relationshipUpdated      = Nothing
+            , AP.relationshipInstrument   = Just role
+            }
+        membersAP = AP.Collection
+            { AP.collectionId         = encodeRouteLocal $ GroupMembersR groupHash
+            , AP.collectionType       = CollectionTypeUnordered
+            , AP.collectionTotalItems = Just $ length members
+            , AP.collectionCurrent    = Nothing
+            , AP.collectionFirst      = Nothing
+            , AP.collectionLast       = Nothing
+            , AP.collectionItems      = map (Doc h . makeItem) members
+            , AP.collectionContext    =
+                Just $ encodeRouteLocal $ GroupR groupHash
+            }
+    provideHtmlAndAP membersAP $ getHtml groupID
+    where
+    getHtml groupID = do
+        (group, actor, members, invites, joins) <- handlerToWidget $ runDB $ do
+            group <- get404 groupID
+            actor <- getJust $ groupActor group
+            members <- do
+                grants <-
+                    getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID
+                for grants $ \ (role, actor, ct, time) ->
+                    (,role,ct,time) <$> getPersonWidgetInfo actor
+            invites <- do
+                invites' <-
+                    getTopicInvites CollabTopicGroupCollab CollabTopicGroupGroup groupID
+                for invites' $ \ (inviter, recip, time, role) -> (,,,)
+                    <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter)
+                    <*> getPersonWidgetInfo recip
+                    <*> pure time
+                    <*> pure role
+            joins <- do
+                joins' <-
+                    getTopicJoins CollabTopicGroupCollab CollabTopicGroupGroup groupID
+                for joins' $ \ (recip, time, role) ->
+                    (,time,role) <$> getPersonWidgetInfo recip
+            return (group, actor, members, invites, joins)
+        $(widgetFile "group/members")
+        where
+        grabPerson actorID = do
+            actorByKey <- getLocalActor actorID
+            case actorByKey of
+                LocalActorPerson personID -> return personID
+                _ -> error "Surprise, local inviter actor isn't a Person"
 
 
 
@@ -165,62 +318,6 @@ getGroupsR = do
         return sharer
     defaultLayout $(widgetFile "group/list")
 
-postGroupsR :: Handler Html
-postGroupsR = do
-    ((result, widget), enctype) <- runFormPost newGroupForm
-    case result of
-        FormSuccess ng -> do
-            now <- liftIO getCurrentTime
-            pid <- requireAuthId
-            runDB $ do
-                let sharer = Sharer
-                        { sharerIdent   = ngIdent ng
-                        , sharerName    = ngName ng
-                        , sharerCreated = now
-                        }
-                sid <- insert sharer
-                let group = Group
-                        { groupIdent = sid
-                        }
-                gid <- insert group
-                let member = GroupMember
-                        { groupMemberPerson = pid
-                        , groupMemberGroup  = gid
-                        , groupMemberRole   = GRAdmin
-                        , groupMemberJoined = now
-                        }
-                insert_ member
-            redirect $ SharerR $ ngIdent ng
-        FormMissing -> do
-            setMessage "Field(s) missing"
-            defaultLayout $(widgetFile "group/new")
-        FormFailure _l -> do
-            setMessage "Group creation failed, see errors below"
-            defaultLayout $(widgetFile "group/new")
-
-getGroupNewR :: Handler Html
-getGroupNewR = do
-    ((_result, widget), enctype) <- runFormPost newGroupForm
-    defaultLayout $(widgetFile "group/new")
-
-getGroupMembersR :: ShrIdent -> Handler Html
-getGroupMembersR shar = do
-    (group, members) <- runDB $ do
-        Entity sid s <- getBy404 $ UniqueSharer shar
-        Entity gid _g <- getBy404 $ UniqueGroup sid
-        ms <- select $ from $ \ (member, person, sharer) -> do
-            where_ $
-                member ^. GroupMemberGroup  E.==. val gid            &&.
-                member ^. GroupMemberPerson E.==. person ^. PersonId &&.
-                person ^. PersonIdent       E.==. sharer ^. SharerId
-            orderBy
-                [ asc $ member ^. GroupMemberRole
-                , asc $ sharer ^. SharerIdent
-                ]
-            return sharer
-        return (s, ms)
-    defaultLayout $(widgetFile "group/member/list")
-
 getgid :: ShrIdent -> AppDB GroupId
 getgid shar = do
     Entity s _ <- getBy404 $ UniqueSharer shar

src/Vervis/Migration.hs

@@ -3021,6 +3021,106 @@ changes hLocal ctx =
         "OutboxItem"
       -- 548
     , addUnique' "CollabFulfillsInvite" "Accept" ["accept"]
+      -- 549
+    , addFieldRefRequired''
+        "Group"
+        (do obid <- insert Outbox549
+            let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
+            insertEntity $ OutboxItem549 obid doc defaultTime
+        )
+        (Just $ \ (Entity obiidTemp obiTemp) -> do
+            let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
+            gs <- selectKeysList ([] :: [Filter Group549]) []
+            for_ gs $ \ gid -> do
+                obid <- do
+                    mp <- selectFirst [] [Asc Person549Id]
+                    p <- entityVal <$> maybe (error "No people") return mp
+                    a <- getJust $ person549Actor p
+                    return $ actor549Outbox a
+                obiid <- insert $ OutboxItem549 obid doc defaultTime
+                update gid [Group549Create =. obiid]
+
+            delete obiidTemp
+            delete $ outboxItem549Outbox obiTemp
+        )
+        "create"
+        "OutboxItem"
+      -- 550
+    , addUnique' "Group" "Create" ["create"]
+      -- 551
+    , addEntities model_551_group_collab
+      -- 552
+    , addEntities model_552_collab_deleg
+      -- 553
+    , unchecked $ lift $ do
+        collabIDs <-
+            liftA2 (++)
+                (map (collabTopicProject553Collab . entityVal) <$> selectList [] [])
+                (map (collabTopicGroup553Collab . entityVal) <$> selectList [] [])
+        let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
+        for_ collabIDs $ \ collabID -> do
+            e <- getKeyBy $ UniqueCollabEnable553 collabID
+            r <- getBy $ UniqueCollabRecipLocal553 collabID
+            for_ e $ \ enableID -> for_ r $ \ (Entity recipID (CollabRecipLocal553 _ personID)) -> do
+                actorID <- person553Actor <$> getJust personID
+                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"]
+      -- 564
+    , addEntities model_564_permit
     ]
 
 migrateDB

src/Vervis/Migration/Entities.hs

@@ -64,6 +64,9 @@ module Vervis.Migration.Entities
     , model_531_follow_request
     , model_541_project
     , model_542_component
+    , model_551_group_collab
+    , model_552_collab_deleg
+    , model_564_permit
     )
 where
 
@@ -248,3 +251,12 @@ model_541_project = $(schema "541_2023-06-26_project")
 
 model_542_component :: [Entity SqlBackend]
 model_542_component = $(schema "542_2023-06-26_component")
+
+model_551_group_collab :: [Entity SqlBackend]
+model_551_group_collab = $(schema "551_2023-11-21_group_collab")
+
+model_552_collab_deleg :: [Entity SqlBackend]
+model_552_collab_deleg = $(schema "552_2023-11-21_collab_deleg")
+
+model_564_permit :: [Entity SqlBackend]
+model_564_permit = $(schema "564_2023-11-22_permit")

src/Vervis/Migration/Model.hs

@@ -528,3 +528,12 @@ makeEntitiesMigration "527"
 
 makeEntitiesMigration "547"
     $(modelFile "migrations/547_2023-06-28_invite_accept.model")
+
+makeEntitiesMigration "549"
+    $(modelFile "migrations/549_2023-11-21_group_create.model")
+
+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
-    object <- getJust $ remoteActorIdent actor
+getRemoteObjectURI object = do
     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,8 @@
 module Vervis.Persist.Collab
     ( getCollabTopic
     , getCollabTopic'
+    , getCollabRecip
+    , getPermitTopic
     , getStemIdent
     , getStemProject
     , getGrantRecip
@@ -32,6 +34,7 @@ module Vervis.Persist.Collab
     , getComponentIdent
 
     , checkExistingStems
+    , checkExistingPermits
     )
 where
 
@@ -62,6 +65,7 @@ import qualified Web.ActivityPub as AP
 
 import Control.Monad.Trans.Except.Local
 import Data.Either.Local
+import Data.Maybe.Local
 import Database.Persist.Local
 
 import Vervis.Actor
@@ -70,45 +74,84 @@ import Vervis.Model
 import Vervis.Persist.Actor
 
 getCollabTopic
-    :: MonadIO m => CollabId -> ReaderT SqlBackend m (GrantResourceBy Key)
-getCollabTopic collabID = do
-    maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
-    maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
-    maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
-    maybeProject <- getValBy $ UniqueCollabTopicProject collabID
-    return $
-        case (maybeRepo, maybeDeck, maybeLoom, maybeProject) of
-            (Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic"
-            (Just r, Nothing, Nothing, Nothing) ->
-                GrantResourceRepo $ collabTopicRepoRepo r
-            (Nothing, Just d, Nothing, Nothing) ->
-                GrantResourceDeck $ collabTopicDeckDeck d
-            (Nothing, Nothing, Just l, Nothing) ->
-                GrantResourceLoom $ collabTopicLoomLoom l
-            (Nothing, Nothing, Nothing, Just l) ->
-                GrantResourceProject $ collabTopicProjectProject l
-            _ -> error "Found Collab with multiple topics"
+    :: 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
     maybeLoom <- getBy $ UniqueCollabTopicLoom collabID
     maybeProject <- getBy $ UniqueCollabTopicProject collabID
+    maybeGroup <- getBy $ UniqueCollabTopicGroup collabID
     return $
-        case (maybeRepo, maybeDeck, maybeLoom, maybeProject) of
-            (Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic"
-            (Just (Entity k r), Nothing, Nothing, Nothing) ->
-                (delete k, GrantResourceRepo $ collabTopicRepoRepo r)
-            (Nothing, Just (Entity k d), Nothing, Nothing) ->
-                (delete k, GrantResourceDeck $ collabTopicDeckDeck d)
-            (Nothing, Nothing, Just (Entity k l), Nothing) ->
-                (delete k, GrantResourceLoom $ collabTopicLoomLoom l)
-            (Nothing, Nothing, Nothing, Just (Entity k l)) ->
-                (delete k, GrantResourceProject $ collabTopicProjectProject l)
+        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, LocalActorRepo $ collabTopicRepoRepo r)
+            (Nothing, Just (Entity k d), Nothing, Nothing, Nothing) ->
+                (delete k, LocalActorDeck $ collabTopicDeckDeck d)
+            (Nothing, Nothing, Just (Entity k l), Nothing, Nothing) ->
+                (delete k, LocalActorLoom $ collabTopicLoomLoom l)
+            (Nothing, Nothing, Nothing, Just (Entity k l), Nothing) ->
+                (delete k, LocalActorProject $ collabTopicProjectProject l)
+            (Nothing, Nothing, Nothing, Nothing, Just (Entity k 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"
+
+getPermitTopic
+    :: MonadIO m
+    => PermitId
+    -> ReaderT SqlBackend m
+        (Either
+            (PermitTopicLocalId, LocalActorBy Key)
+            (PermitTopicRemoteId, RemoteActorId)
+        )
+getPermitTopic permitID = do
+    topic <-
+        requireEitherAlt
+            (getKeyBy $ UniquePermitTopicLocal permitID)
+            (getBy $ UniquePermitTopicRemote permitID)
+            "Permit without topic"
+            "Permit with both local and remote topic"
+    bitraverse
+        (\ localID -> (localID,) <$> do
+            options <-
+                sequence
+                    [ fmap (LocalActorRepo . permitTopicRepoRepo) <$>
+                        getValBy (UniquePermitTopicRepo localID)
+                    , fmap (LocalActorDeck . permitTopicDeckDeck) <$>
+                        getValBy (UniquePermitTopicDeck localID)
+                    , fmap (LocalActorLoom . permitTopicLoomLoom) <$>
+                        getValBy (UniquePermitTopicLoom localID)
+                    , fmap (LocalActorProject . permitTopicProjectProject) <$>
+                        getValBy (UniquePermitTopicProject localID)
+                    , fmap (LocalActorGroup . permitTopicGroupGroup) <$>
+                        getValBy (UniquePermitTopicGroup localID)
+                    ]
+            exactlyOneJust
+                options
+                "Found Permit without topic"
+                "Found Permit with multiple topics"
+        )
+        (\ (Entity topicID (PermitTopicRemote _ actorID)) ->
+            return (topicID, actorID)
+        )
+        topic
+
 getStemIdent :: MonadIO m => StemId -> ReaderT SqlBackend m (ComponentBy Key)
 getStemIdent stemID = do
     maybeRepo <- getValBy $ UniqueStemIdentRepo stemID
@@ -301,7 +344,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
@@ -333,7 +376,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
@@ -351,7 +394,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
@@ -508,3 +551,127 @@ checkExistingStems componentByID projectDB = do
                 const () <$> MaybeT (getBy $ UniqueStemProjectAcceptLocalProject localID)
             Right remoteID ->
                 const () <$> MaybeT (getBy $ UniqueStemProjectAcceptRemoteProject remoteID)
+
+checkExistingPermits
+    :: PersonId -> Either (LocalActorBy Key) RemoteActorId -> ActDBE ()
+checkExistingPermits personID topicDB = do
+
+    -- Find existing Permit records I have for this topic
+    permitIDs <- lift $ getExistingPermits topicDB
+
+    -- Grab all the enabled ones, make sure none are enabled, and even if
+    -- any are enabled, make sure there's at most one (otherwise it's a
+    -- bug)
+    byEnabled <-
+        lift $ for permitIDs $ \ (_, permit) ->
+            isJust <$> runMaybeT (tryPermitEnabled permit)
+    case length $ filter id byEnabled of
+        0 -> return ()
+        1 -> throwE "I already have a PermitTopicEnable* for this topic"
+        _ -> error "Multiple PermitTopicEnable* for a topic"
+
+    -- Verify none of the Permit records are already in Join or
+    -- Invite-and-Accept state
+    anyStarted <-
+        lift $ runMaybeT $ asum $
+            map (\ (permitID, topic) ->
+                    tryPermitJoin permitID <|>
+                    tryPermitInviteAccept permitID topic
+                )
+                permitIDs
+    unless (isNothing anyStarted) $
+        throwE
+            "One of the Permit records is already in Join or Invite-Accept \
+            \state"
+
+    where
+
+    getExistingPermits (Left (LocalActorPerson _)) = pure []
+    getExistingPermits (Left (LocalActorRepo repoID)) =
+        fmap (map $ bimap E.unValue (Left . E.unValue)) $
+        E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do
+            E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicRepoPermit
+            E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit
+            E.where_ $
+                permit E.^. PermitPerson E.==. E.val personID E.&&.
+                topic E.^. PermitTopicRepoRepo E.==. E.val repoID
+            return
+                ( permit E.^. PermitId
+                , local E.^. PermitTopicLocalId
+                )
+    getExistingPermits (Left (LocalActorDeck deckID)) =
+        fmap (map $ bimap E.unValue (Left . E.unValue)) $
+        E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do
+            E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicDeckPermit
+            E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit
+            E.where_ $
+                permit E.^. PermitPerson E.==. E.val personID E.&&.
+                topic E.^. PermitTopicDeckDeck E.==. E.val deckID
+            return
+                ( permit E.^. PermitId
+                , local E.^. PermitTopicLocalId
+                )
+    getExistingPermits (Left (LocalActorLoom loomID)) =
+        fmap (map $ bimap E.unValue (Left . E.unValue)) $
+        E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do
+            E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicLoomPermit
+            E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit
+            E.where_ $
+                permit E.^. PermitPerson E.==. E.val personID E.&&.
+                topic E.^. PermitTopicLoomLoom E.==. E.val loomID
+            return
+                ( permit E.^. PermitId
+                , local E.^. PermitTopicLocalId
+                )
+    getExistingPermits (Left (LocalActorProject projectID)) =
+        fmap (map $ bimap E.unValue (Left . E.unValue)) $
+        E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do
+            E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicProjectPermit
+            E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit
+            E.where_ $
+                permit E.^. PermitPerson E.==. E.val personID E.&&.
+                topic E.^. PermitTopicProjectProject E.==. E.val projectID
+            return
+                ( permit E.^. PermitId
+                , local E.^. PermitTopicLocalId
+                )
+    getExistingPermits (Left (LocalActorGroup groupID)) =
+        fmap (map $ bimap E.unValue (Left . E.unValue)) $
+        E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do
+            E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicGroupPermit
+            E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit
+            E.where_ $
+                permit E.^. PermitPerson E.==. E.val personID E.&&.
+                topic E.^. PermitTopicGroupGroup E.==. E.val groupID
+            return
+                ( permit E.^. PermitId
+                , local E.^. PermitTopicLocalId
+                )
+    getExistingPermits (Right remoteActorID) =
+        fmap (map $ bimap E.unValue (Right . E.unValue)) $
+        E.select $ E.from $ \ (permit `E.InnerJoin` remote) -> do
+            E.on $ permit E.^. PermitId E.==. remote E.^. PermitTopicRemotePermit
+            E.where_ $
+                permit E.^. PermitPerson E.==. E.val personID E.&&.
+                remote E.^. PermitTopicRemoteActor E.==. E.val remoteActorID
+            return
+                ( permit E.^. PermitId
+                , remote E.^. PermitTopicRemoteId
+                )
+
+    tryPermitEnabled (Left localID) =
+        const () <$> MaybeT (getBy $ UniquePermitTopicEnableLocalTopic localID)
+    tryPermitEnabled (Right remoteID) =
+        const () <$> MaybeT (getBy $ UniquePermitTopicEnableRemoteTopic remoteID)
+
+    tryPermitJoin permitID = do
+        _ <- MaybeT $ getBy $ UniquePermitFulfillsJoin permitID
+        pure ()
+
+    tryPermitInviteAccept permitID topic = do
+        _fulfillsID <- MaybeT $ getKeyBy $ UniquePermitFulfillsInvite permitID
+        case topic of
+            Left localID ->
+                const () <$> MaybeT (getBy $ UniquePermitTopicAcceptLocalTopic localID)
+            Right remoteID ->
+                const () <$> MaybeT (getBy $ UniquePermitTopicAcceptRemoteTopic remoteID)

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 <$>
-            hashLocalActor (grantResourceLocalActor resource)
+        encodeRouteHome . VR.renderLocalActor <$> hashLocalActor 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"

src/Vervis/Widget.hs

@@ -46,6 +46,7 @@ breadcrumbsW = do
 revisionW :: WidgetFor site ()
 revisionW =
     let rev = $gitDescribe :: Text
+        hash = $gitHash :: Text
         address = "^rjQ3E@vervis.peers.community" :: Text
         link = "https://vervis.peers.community/repos/rjQ3E" :: Text
         changes = $gitCommitCount :: Text

src/Vervis/Widget/Tracker.hs

@@ -19,6 +19,7 @@ module Vervis.Widget.Tracker
     , projectNavW
     , componentLinkFedW
     , projectLinkFedW
+    , groupNavW
     )
 where
 
@@ -50,6 +51,11 @@ projectNavW (Entity projectID project) actor = do
     projectHash <- encodeKeyHashid projectID
     $(widgetFile "project/widget/nav")
 
+groupNavW :: Entity Group -> Actor -> Widget
+groupNavW (Entity groupID group) actor = do
+    groupHash <- encodeKeyHashid groupID
+    $(widgetFile "group/nav")
+
 componentLinkW :: ComponentBy Key -> Actor -> Widget
 componentLinkW (ComponentRepo k) actor = do
     h <- encodeKeyHashid k

src/Web/ActivityPub.hs

@@ -51,6 +51,7 @@ module Web.ActivityPub
     , Resource (..)
     , ResourceWithCollections (..)
     , Project (..)
+    , Team (..)
 
       -- * Content objects
     , Note (..)
@@ -859,6 +860,7 @@ data ResourceWithCollections u = ResourceWithCollections
     { rwcResource   :: Resource u
     , rwcCollabs    :: Maybe LocalURI
     , rwcComponents :: Maybe LocalURI
+    , rwcMembers    :: Maybe LocalURI
     }
 
 instance ActivityPub ResourceWithCollections where
@@ -868,10 +870,12 @@ instance ActivityPub ResourceWithCollections where
         fmap (h,) $ ResourceWithCollections r
             <$> withAuthorityMaybeO h (o .:? "collaborators")
             <*> withAuthorityMaybeO h (o .:? "components")
-    toSeries h (ResourceWithCollections r collabs comps)
+            <*> withAuthorityMaybeO h (o .:? "members")
+    toSeries h (ResourceWithCollections r collabs comps members)
         =  toSeries h r
         <> "collaborators" .=? (ObjURI h <$> collabs)
         <> "components"    .=? (ObjURI h <$> comps)
+        <> "members"       .=? (ObjURI h <$> members)
 
 data Project u = Project
     { projectActor      :: Actor u
@@ -917,6 +921,44 @@ instance ActivityPub Project where
         <> "components"     .= ObjURI h components
         <> "collaborators"  .= ObjURI h collabs
 
+data Team u = Team
+    { teamActor    :: Actor u
+    , teamChildren :: [ObjURI u]
+    , teamParents  :: [ObjURI u]
+    , teamMembers  :: LocalURI
+    }
+
+instance ActivityPub Team where
+    jsonldContext _ = [as2Context, secContext, forgeContext]
+    parseObject o = do
+        (h, a) <- parseObject o
+        unless (actorType (actorDetail a) == ActorTypeTeam) $
+            fail "Actor type isn't Team"
+        fmap (h,) $
+            Team a
+                <$> (do c <- o .: "subteams"
+                        typ <- c .: "type"
+                        unless (typ == ("Collection" :: Text)) $
+                            fail "subteams.type isn't Collection"
+                        items <- c .: "items"
+                        mtotal <- c .:? "totalItems"
+                        for_ mtotal $ \ total ->
+                            unless (length items == total) $
+                                fail "Incorrect totalItems"
+                        return items
+                    )
+                <*> o .:? "context" .!= []
+                <*> withAuthorityO h (o .: "members")
+    toSeries h (Team actor children parents members)
+        =  toSeries h actor
+        <> "subteams" `pair` pairs
+            (  "type"       .= ("Collection" :: Text)
+            <> "items"      .= children
+            <> "totalItems" .= length children
+            )
+        <> "context"        .= parents
+        <> "members"        .= ObjURI h members
+
 data Audience u = Audience
     { audienceTo        :: [ObjURI u]
     , audienceBto       :: [ObjURI u]
@@ -1077,7 +1119,9 @@ instance ActivityPub Note where
         <> "content"      .=  content
         <> "mediaType"    .=  ("text/html" :: Text)
 
-data RelationshipProperty = RelDependsOn | RelHasCollab deriving Eq
+data RelationshipProperty =
+    RelDependsOn | RelHasCollab | RelHasMember
+    deriving Eq
 
 instance FromJSON RelationshipProperty where
     parseJSON = withText "RelationshipProperty" parse
@@ -1085,6 +1129,7 @@ instance FromJSON RelationshipProperty where
         parse t
             | t == "dependsOn" = pure RelDependsOn
             | t == "hasCollaborator" = pure RelHasCollab
+            | t == "hasMember" = pure RelHasMember
             | otherwise = fail $ "Unrecognized relationship: " ++ T.unpack t
 
 instance ToJSON RelationshipProperty where
@@ -1093,6 +1138,7 @@ instance ToJSON RelationshipProperty where
         toEncoding $ case at of
             RelDependsOn -> "dependsOn" :: Text
             RelHasCollab -> "hasCollaborator"
+            RelHasMember -> "hasMember"
 
 data Relationship u = Relationship
     { relationshipId           :: Maybe (ObjURI u)
@@ -1788,6 +1834,7 @@ data CreateObject u
     | CreateRepository ActorDetail VersionControlSystem (Maybe (Authority u, ActorLocal u))
     | CreatePatchTracker ActorDetail (NonEmpty (ObjURI u)) (Maybe (Authority u, ActorLocal u))
     | CreateProject ActorDetail (Maybe (Authority u, ActorLocal u))
+    | CreateTeam ActorDetail (Maybe (Authority u, ActorLocal u))
 
 parseCreateObject :: UriMode u => Object -> Parser (CreateObject u)
 parseCreateObject o
@@ -1815,6 +1862,11 @@ parseCreateObject o
                 fail "type isn't Project"
             ml <- parseActorLocal o
             return $ CreateProject d ml
+    <|> do  d <- parseActorDetail o
+            unless (actorType d == ActorTypeTeam) $
+                fail "type isn't Team"
+            ml <- parseActorLocal o
+            return $ CreateTeam d ml
 
 encodeCreateObject :: UriMode u => CreateObject u -> Series
 encodeCreateObject (CreateNote h note) = toSeries h note
@@ -1831,6 +1883,8 @@ encodeCreateObject (CreatePatchTracker d repos ml)
     <> maybe mempty (uncurry encodeActorLocal) ml
 encodeCreateObject (CreateProject d ml) =
     encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml
+encodeCreateObject (CreateTeam d ml) =
+    encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml
 
 data Create u = Create
     { createObject :: CreateObject u
@@ -1851,6 +1905,7 @@ parseCreate o a luActor = do
         CreateRepository _ _ _ -> return ()
         CreatePatchTracker _ _ _ -> return ()
         CreateProject _ _ -> return ()
+        CreateTeam _ _ -> return ()
     Create obj <$> o .:? "target"
 
 encodeCreate :: UriMode u => Create u -> Series

templates/browse.hamlet

@@ -56,7 +56,11 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 <h2>Projects
 
 <ul>
-  $forall (Entity projectID _, Entity _ actor) <- projects
+  $forall (Entity projectID _, Entity _ actor, components) <- projects
     <li>
       <a href=@{ProjectR $ hashProject projectID}>
         \$#{keyHashidText $ hashProject projectID} #{actorName actor}
+      <ul>
+        $forall c <- components
+          <li>
+            ^{componentLinkFedW c}

templates/group/member/list.hamlet

@@ -1,27 +0,0 @@
-$# This file is part of Vervis.
-$#
-$# Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
-$#
-$# ♡ Copying is an act of love. Please copy, reuse and share.
-$#
-$# The author(s) have dedicated all copyright and related and neighboring
-$# rights to this software to the public domain worldwide. This software is
-$# distributed without any warranty.
-$#
-$# You should have received a copy of the CC0 Public Domain Dedication along
-$# with this software. If not, see
-$# <http://creativecommons.org/publicdomain/zero/1.0/>.
-
-<h2>
-  #{fromMaybe (shr2text $ sharerIdent group) $ sharerName group}
-
-<p>
-  Created on #{showDate $ sharerCreated group}.
-
-<p>
-  Members:
-
-<ul>
-  $forall Entity _sid s <- members
-    <li>
-      ^{sharerLinkW s}

templates/group/members.hamlet

@@ -0,0 +1,59 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016, 2019, 2023 by fr33domlover <fr33domlover@riseup.net>.
+$#
+$# ♡ Copying is an act of love. Please copy, reuse and share.
+$#
+$# The author(s) have dedicated all copyright and related and neighboring
+$# rights to this software to the public domain worldwide. This software is
+$# distributed without any warranty.
+$#
+$# You should have received a copy of the CC0 Public Domain Dedication along
+$# with this software. If not, see
+$# <http://creativecommons.org/publicdomain/zero/1.0/>.
+
+^{groupNavW (Entity groupID group) actor}
+
+<h2>Members
+
+<table>
+  <tr>
+    <th>Role
+    <th>Member
+    <th>Since
+  $forall (person, role, ctID, since) <- members
+    <tr>
+      <td>#{show role}
+      <td>^{personLinkFedW person}
+      <td>#{showDate since}
+      $#<td>^{buttonW POST "Remove" (GroupRemoveR groupHash ctID)}
+
+<h2>Invites
+
+<table>
+  <tr>
+    <th>Inviter
+    <th>Invitee
+    <th>Role
+    <th>Time
+  $forall (inviter, invitee, time, role) <- invites
+    <tr>
+      <td>^{personLinkFedW inviter}
+      <td>^{personLinkFedW invitee}
+      <td>#{show role}
+      <td>#{showDate time}
+
+$#<a href=@{ProjectInviteR projectHash}>Invite…
+
+<h2>Joins
+
+<table>
+  <tr>
+    <th>Joiner
+    <th>Role
+    <th>Time
+  $forall (joiner, time, role) <- joins
+    <tr>
+      <td>^{personLinkFedW joiner}
+      <td>#{show role}
+      <td>#{showDate time}

templates/group/nav.hamlet

@@ -0,0 +1,34 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
+$#
+$# ♡ Copying is an act of love. Please copy, reuse and share.
+$#
+$# The author(s) have dedicated all copyright and related and neighboring
+$# rights to this software to the public domain worldwide. This software is
+$# distributed without any warranty.
+$#
+$# You should have received a copy of the CC0 Public Domain Dedication along
+$# with this software. If not, see
+$# <http://creativecommons.org/publicdomain/zero/1.0/>.
+
+<div>
+  <span>
+    [[ 🏗
+    <a href=@{GroupR groupHash}>
+      &#{keyHashidText groupHash} #{actorName actor}
+    ]] ::
+  <span>
+    <a href=@{GroupInboxR groupHash}>
+      [📥 Inbox]
+  <span>
+    <a href=@{GroupOutboxR groupHash}>
+      [📤 Outbox]
+  <span>
+    <a href=@{GroupFollowersR groupHash}>
+      [🐤 Followers]
+  <span>
+    <a href=@{GroupMembersR groupHash}>
+      [🤝 Members]
+  <span>
+    [✏ Edit]

templates/group/new.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2023 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -12,7 +12,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
 $# with this software. If not, see
 $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
-<form method=POST action=@{GroupsR} enctype=#{enctype}>
+<form method=POST action=@{GroupNewR} enctype=#{enctype}>
   ^{widget}
   <div class="submit">
-    <input type="submit">
+      <input type="submit">

templates/group/one.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2023 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -12,5 +12,4 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
 $# with this software. If not, see
 $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
-<p>
-  <a href=@{GroupMembersR shar}>Members
+^{groupNavW (Entity groupID group) actor}

templates/personal-overview.hamlet

@@ -25,17 +25,26 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
     <a href=@{KeysR}>
       SSH key settings
   <li>
-    <a href=@{RepoNewR}>
-      Create a new repository
-  <li>
-    <a href=@{DeckNewR}>
-      Create a new ticket tracker
-  <li>
-    <a href=@{LoomNewR}>
-      Create a new patch tracker
-  <li>
-    <a href=@{ProjectNewR}>
-      Create a new project
+    Create a new…
+    <ul>
+      <li>
+        <a href=@{ProjectNewR}>
+          project
+      <li>
+        <a href=@{GroupNewR}>
+          team
+      <li>
+        component:
+        <ul>
+          <li>
+            <a href=@{RepoNewR}>
+              repository
+          <li>
+            <a href=@{DeckNewR}>
+              ticket tracker
+          <li>
+            <a href=@{LoomNewR}>
+              patch tracker
   <li>
     <a href=@{PublishOfferMergeR}>
       Open a merge request
@@ -57,7 +66,14 @@ $#       Comment on a ticket or merge request
 
 <h2>Your teams
 
-<p>You aren't a member of any teams at the moment.
+<ul>
+  $forall (Entity groupID _, Entity _ actor, Entity _ (Collab role)) <- groups
+    <li>
+      [
+      #{show role}
+      ]
+      <a href=@{GroupR $ hashGroup groupID}>
+        &#{keyHashidText $ hashGroup groupID} #{actorName actor}
 
 <h2>Your repos
 

templates/widget/revision.hamlet

@@ -14,6 +14,12 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
 <a href="#{link}">
   #{address}
+<a href="https://codeberg.org/ForgeFed/Vervis">
+  (mirror)
 » #
 
-#{rev} (total: #{changes} patches)
+<a href="#{link}/commits/#{hash}">
+  #{rev}
+<a href="https://codeberg.org/ForgeFed/Vervis/commit/#{hash}">
+  (mirror)
+(total: #{changes} commits)

th/models

@@ -270,9 +270,11 @@ SshKey
     UniqueSshKey person ident
 
 Group
-    actor ActorId
+    actor  ActorId
+    create OutboxItemId
 
-    UniqueGroupActor actor
+    UniqueGroupActor  actor
+    UniqueGroupCreate create
 
 GroupMember
     person PersonId
@@ -575,7 +577,7 @@ RemoteMessage
 
 
 ------------------------------------------------------------------------------
--- Collaborators
+-- Collaborators, from resource perspective
 ------------------------------------------------------------------------------
 
 Collab
@@ -674,12 +676,11 @@ CollabTopicProject
 
     UniqueCollabTopicProject collab
 
-CollabEnable
+CollabTopicGroup
     collab CollabId
-    grant  OutboxItemId
+    group  GroupId
 
-    UniqueCollabEnable      collab
-    UniqueCollabEnableGrant grant
+    UniqueCollabTopicGroup collab
 
 -------------------------------- Collab recipient ----------------------------
 
@@ -713,6 +714,225 @@ CollabRecipRemoteAccept
     UniqueCollabRecipRemoteAcceptInvite invite
     UniqueCollabRecipRemoteAcceptAccept accept
 
+-------------------------------- Collab enable -------------------------------
+
+CollabEnable
+    collab CollabId
+    grant  OutboxItemId
+
+    UniqueCollabEnable      collab
+    UniqueCollabEnableGrant grant
+
+-- Component: N/A
+-- Project/Team: Witnesses that using the above Grant, the collaborator has
+-- sent me a delegator-Grant, which I can now use to extend chains to them
+
+CollabDelegLocal
+    enable CollabEnableId
+    recip  CollabRecipLocalId
+    grant  OutboxItemId
+
+    UniqueCollabDelegLocal      enable
+    UniqueCollabDelegLocalRecip recip
+    UniqueCollabDelegLocalGrant grant
+
+CollabDelegRemote
+    enable CollabEnableId
+    recip  CollabRecipRemoteId
+    grant  RemoteActivityId
+
+    UniqueCollabDelegRemote      enable
+    UniqueCollabDelegRemoteRecip recip
+    UniqueCollabDelegRemoteGrant grant
+
+------------------------------------------------------------------------------
+-- Collaborators, from person perspective
+------------------------------------------------------------------------------
+
+Permit
+    person PersonId
+    role   Role
+
+-------------------------------- Permit topic --------------------------------
+
+PermitTopicLocal
+    permit PermitId
+
+    UniquePermitTopicLocal permit
+
+PermitTopicRepo
+    permit PermitTopicLocalId
+    repo   RepoId
+
+    UniquePermitTopicRepo permit
+
+PermitTopicDeck
+    permit PermitTopicLocalId
+    deck   DeckId
+
+    UniquePermitTopicDeck permit
+
+PermitTopicLoom
+    permit PermitTopicLocalId
+    loom   LoomId
+
+    UniquePermitTopicLoom permit
+
+PermitTopicProject
+    permit  PermitTopicLocalId
+    project ProjectId
+
+    UniquePermitTopicProject permit
+
+PermitTopicGroup
+    permit PermitTopicLocalId
+    group  GroupId
+
+    UniquePermitTopicGroup permit
+
+PermitTopicRemote
+    permit PermitId
+    actor  RemoteActorId
+
+    UniquePermitTopicRemote permit
+
+------------------------------- Permit reason --------------------------------
+
+PermitFulfillsTopicCreation
+    permit PermitId
+
+    UniquePermitFulfillsTopicCreation permit
+
+PermitFulfillsInvite
+    permit PermitId
+
+    UniquePermitFulfillsInvite permit
+
+PermitFulfillsJoin
+    permit PermitId
+
+    UniquePermitFulfillsJoin permit
+
+-- Person's gesture
+--
+-- Join: Witnesses the initial Join that started the sequence
+-- Invite: Witnesses their approval, seeing the topic's accept, and then
+--         sending their own accept
+-- Create: Records the Create activity that created the topic
+
+PermitPersonGesture
+    permit   PermitId
+    activity OutboxItemId
+
+    UniquePermitPersonGesture         permit
+    UniquePermitPersonGestureActivity activity
+
+-- Topic collaborator's gesture
+--
+-- Join: N/A (it happens but we don't record it)
+-- Invite: Witnesses the initial Invite that started the sequence
+
+PermitTopicGestureLocal
+    fulfills PermitFulfillsInviteId
+    invite   OutboxItemId
+
+    UniquePermitTopicGestureLocal       fulfills
+    UniquePermitTopicGestureLocalInvite invite
+
+PermitTopicGestureRemote
+    fulfills PermitFulfillsInviteId
+    actor    RemoteActorId
+    invite   RemoteActivityId
+
+    UniquePermitTopicGestureRemote       fulfills
+    UniquePermitTopicGestureRemoteInvite invite
+
+-- Topic's accept
+--
+-- Join: N/A
+-- Invite: Witnesses that the topic saw and approved the Invite
+
+PermitTopicAcceptLocal
+    fulfills PermitFulfillsInviteId
+    topic    PermitTopicLocalId
+    accept   OutboxItemId
+
+    UniquePermitTopicAcceptLocal       fulfills
+    UniquePermitTopicAcceptLocalTopic  topic
+    UniquePermitTopicAcceptLocalAccept accept
+
+PermitTopicAcceptRemote
+    fulfills PermitFulfillsInviteId
+    topic    PermitTopicRemoteId
+    accept   RemoteActivityId
+
+    UniquePermitTopicAcceptRemote       fulfills
+    UniquePermitTopicAcceptRemoteTopic  topic
+    UniquePermitTopicAcceptRemoteAccept accept
+
+-------------------------------- Permit enable -------------------------------
+
+-- Topic's grant
+--
+-- Join: Seeing the new-collaborator's Join and existing-collaborator's Accept,
+--       the topic has made the link official and sent a direct-grant
+-- Invite: Seeing existing-collaborator's Invite and new-collaborator's Accept,
+--         the topic has made the link official and sent a direct-grant
+-- Create: Upon being created, topic has sent its creator an admin-Grant
+
+PermitTopicEnableLocal
+    permit PermitPersonGestureId
+    topic  PermitTopicLocalId
+    grant  OutboxItemId
+
+    UniquePermitTopicEnableLocal      permit
+    UniquePermitTopicEnableLocalTopic topic
+    UniquePermitTopicEnableLocalGrant grant
+
+PermitTopicEnableRemote
+    permit PermitPersonGestureId
+    topic  PermitTopicRemoteId
+    grant  RemoteActivityId
+
+    UniquePermitTopicEnableRemote      permit
+    UniquePermitTopicEnableRemoteTopic topic
+    UniquePermitTopicEnableRemoteGrant grant
+
+----------------------- Permit delegator+extension ---------------------------
+
+-- This section is only for Project or Team topics
+-- Person sends delegator-Grant, topic starts sending extension-Grants
+
+-- Witnesses that the person used the direct-Grant to send a delegator-Grant to
+-- the topic
+PermitPersonSendDelegator
+    permit PermitPersonGestureId
+    grant  OutboxItemId
+
+    UniquePermitPersonSendDelegator      permit
+    UniquePermitPersonSendDelegatorGrant grant
+
+-- Witnesses extension-Grants that the topic has sent, extending chains from
+-- its components/subprojects or projects/superteams
+
+PermitTopicExtendLocal
+    permit PermitPersonSendDelegatorId
+    topic  PermitTopicEnableLocalId
+    grant  OutboxItemId
+
+    UniquePermitTopicExtendLocal      permit
+    UniquePermitTopicExtendLocalTopic topic
+    UniquePermitTopicExtendLocalGrant grant
+
+PermitTopicExtendRemote
+    permit PermitPersonSendDelegatorId
+    topic  PermitTopicEnableRemoteId
+    grant  RemoteActivityId
+
+    UniquePermitTopicExtendRemote      permit
+    UniquePermitTopicExtendRemoteTopic topic
+    UniquePermitTopicExtendRemoteGrant grant
+
 ------------------------------------------------------------------------------
 -- Components, from project perspective
 ------------------------------------------------------------------------------
@@ -871,7 +1091,7 @@ ComponentDelegateRemote
 -- direct collaborator
 ComponentFurtherLocal
     component ComponentEnableId
-    collab    CollabRecipLocalId
+    collab    CollabDelegLocalId
     grant     OutboxItemId
 
     UniqueComponentFurtherLocal      component collab
@@ -881,7 +1101,7 @@ ComponentFurtherLocal
 -- direct collaborator
 ComponentFurtherRemote
     component ComponentEnableId
-    collab    CollabRecipRemoteId
+    collab    CollabDelegRemoteId
     grant     OutboxItemId
 
     UniqueComponentFurtherRemote      component collab

th/routes

@@ -156,6 +156,8 @@
 
 ---- Group ------------------------------------------------------------------
 
+/new-group                                              GroupNewR        GET POST
+
 /groups/#GroupKeyHashid                                 GroupR           GET
 /groups/#GroupKeyHashid/inbox                           GroupInboxR      GET POST
 /groups/#GroupKeyHashid/outbox                          GroupOutboxR     GET
@@ -166,6 +168,8 @@
 
 /groups/#GroupKeyHashid/stamps/#SigKeyKeyHashid         GroupStampR      GET
 
+/groups/#GroupKeyHashid/members                         GroupMembersR    GET
+
 ---- Repo --------------------------------------------------------------------
 
 /repos/#RepoKeyHashid                             RepoR              GET