S2S: Invite->Accept->Grant (for Repo, Deck, Loom and Person, not for Group)

Person inbox handler:
    - Invite: Parse and insert to inbox
    - Grant: Parse and insert to inbox

Repo/Deck/Loom inbox handler:
    - Invite: Parse and remember as Collab record in DB for later
    - Accept: Send a Grant (and remember it in DB)

Along with inviteC and acceptC, the Invite->Accept->Grant flow is now fully
federated, yay!

What's missing is UI for actually using it. Coming soon.

src/Vervis/API.hs

@@ -52,6 +52,7 @@ import Data.ByteString (ByteString)
 import Data.Either
 import Data.Foldable
 import Data.Function
+import Data.Functor.Identity
 import Data.List (sort, deleteBy, nub, union, unionBy, partition)
 import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
 import Data.Maybe
@@ -130,6 +131,8 @@ import Vervis.Model.Ident
 import Vervis.Model.Role
 import Vervis.Model.Workflow
 import Vervis.Model.Ticket
+import Vervis.Persist.Actor
+import Vervis.Persist.Collab
 import Vervis.Recipient
 import Vervis.RemoteActorStore
 import Vervis.Settings
@@ -280,7 +283,8 @@ acceptC (Entity senderPersonID senderPerson) senderActor summary audience accept
 
             -- If resource is local, verify it has received the Accept
             resourceByEntity <- getGrantResource resource "getGrantResource"
-            let resourceActorID = grantResourceActor resourceByEntity
+            let resourceActorID =
+                    grantResourceActorID $ bmap (Identity . entityVal) resourceByEntity
             verifyActorHasItem resourceActorID acceptID "Local topic didn't receive the Accept"
 
             -- If Collab sender is local, verify it has received the Accept
@@ -328,34 +332,6 @@ acceptC (Entity senderPersonID senderPerson) senderActor summary audience accept
 
     where
 
-    parseAccept (Accept object mresult) = do
-        verifyNothingE mresult "Accept must not contain 'result'"
-        first (\ (actor, _, item) -> (actor, item)) <$>
-            nameExceptT "Accept object" (parseActivityURI object)
-
-    getRemoteActorURI actor = do
-        object <- getJust $ remoteActorIdent actor
-        inztance <- getJust $ remoteObjectInstance object
-        return $
-            ObjURI
-                (instanceHost inztance)
-                (remoteObjectIdent object)
-
-    getCollabTopic collabID = do
-        maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
-        maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
-        maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
-        return $
-            case (maybeRepo, maybeDeck, maybeLoom) of
-                (Nothing, Nothing, Nothing) -> error "Found Collab without topic"
-                (Just r, Nothing, Nothing) ->
-                    GrantResourceRepo $ collabTopicRepoRepo r
-                (Nothing, Just d, Nothing) ->
-                    GrantResourceDeck $ collabTopicDeckDeck d
-                (Nothing, Nothing, Just l) ->
-                    GrantResourceLoom $ collabTopicLoomLoom l
-                _ -> error "Found Collab with multiple topics"
-
     verifySenderAddressed localRecips actor = do
         actorByHash <- hashLocalActor actor
         unless (actorIsAddressed localRecips actorByHash) $
@@ -379,11 +355,6 @@ acceptC (Entity senderPersonID senderPerson) senderActor summary audience accept
         update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
         return doc
 
-    grantResourceActor :: GrantResourceBy Entity -> ActorId
-    grantResourceActor (GrantResourceRepo (Entity _ r)) = repoActor r
-    grantResourceActor (GrantResourceDeck (Entity _ d)) = deckActor d
-    grantResourceActor (GrantResourceLoom (Entity _ l)) = loomActor l
-
     insertGrantToOutbox
         :: KeyHashid Person
         -> Either (LocalActorBy Key, Entity Actor) (FedURI, Maybe LocalURI)
@@ -1794,7 +1765,7 @@ inviteC
 inviteC (Entity senderPersonID senderPerson) senderActor muCap summary audience invite = do
 
     -- Check input
-    (resource, recipient) <- parseInvite (Just senderPersonID) invite
+    (resource, recipient) <- parseInvite (Left senderPersonID) invite
     ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
         mrecips <- parseAudience audience
         recips <- fromMaybeE mrecips "Invite with no recipients"
@@ -1981,8 +1952,6 @@ inviteC (Entity senderPersonID senderPerson) senderActor muCap summary audience
                                         Right (Right Nothing) -> Left ResultNotActor
                                         Right (Right (Just actor)) -> Right $ Right (roid, luManager, actor)
 
-    getGrantRecip (GrantRecipPerson k) e = GrantRecipPerson <$> getEntityE k e
-
     verifyRecipientAddressed localRecips recipient = do
         recipientHash <- hashGrantRecip recipient
         fromMaybeE (verify recipientHash) "Recipient not addressed"

src/Vervis/Access.hs

@@ -67,8 +67,10 @@ module Vervis.Access
     , unhashGrantResourcePure
     , unhashGrantResource
     , unhashGrantResourceE
+    , unhashGrantResource404
     , hashGrantResource
     , getGrantResource
+    , getGrantResource404
 
     , grantResourceLocalActor
 
@@ -85,12 +87,12 @@ import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Reader
 import Data.Barbie
 import Data.Bifunctor
-import Data.Foldable
 import Data.Maybe
 import Data.Text (Text)
 import Database.Persist
 import Database.Persist.Sql
 import GHC.Generics
+import Yesod.Core.Handler
 
 import qualified Database.Esqueleto as E
 
@@ -101,8 +103,6 @@ import Control.Monad.Trans.Except.Local
 import Data.Either.Local
 import Database.Persist.Local
 
-import Vervis.ActivityPub
-import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Role
@@ -285,6 +285,8 @@ unhashGrantResource resource = do
 unhashGrantResourceE resource e =
     ExceptT $ maybe (Left e) Right <$> unhashGrantResource resource
 
+unhashGrantResource404 = maybe notFound return <=< unhashGrantResource
+
 hashGrantResource (GrantResourceRepo k) =
     GrantResourceRepo <$> encodeKeyHashid k
 hashGrantResource (GrantResourceDeck k) =
@@ -299,16 +301,26 @@ getGrantResource (GrantResourceDeck k) e =
 getGrantResource (GrantResourceLoom k) e =
     GrantResourceLoom <$> getEntityE k e
 
+getGrantResource404 = maybe notFound return <=< getGrantResourceEntity
+    where
+    getGrantResourceEntity (GrantResourceRepo k) =
+        fmap GrantResourceRepo <$> getEntity k
+    getGrantResourceEntity (GrantResourceDeck k) =
+        fmap GrantResourceDeck <$> getEntity k
+    getGrantResourceEntity (GrantResourceLoom k) =
+        fmap GrantResourceLoom <$> getEntity k
+
 grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f
 grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r
 grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d
 grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l
 
 verifyCapability
-    :: (LocalActorBy Key, OutboxItemId)
+    :: MonadIO m
+    => (LocalActorBy Key, OutboxItemId)
     -> Either PersonId RemoteActorId
     -> GrantResourceBy Key
-    -> ExceptT Text (ReaderT SqlBackend Handler) ()
+    -> ExceptT Text (ReaderT SqlBackend m) ()
 verifyCapability (capActor, capItem) actor resource = do
 
     -- Find the activity itself by URI in the DB

src/Vervis/Data/Collab.hs

@@ -15,30 +15,41 @@
 
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Vervis.Data.Collab
     ( GrantRecipBy (..)
+
     , parseInvite
     , parseGrant
+    , parseAccept
+
+    , grantResourceActorID
     )
 where
 
+import Control.Monad
 import Control.Monad.Trans.Except
 import Data.Barbie
+import Data.Bifunctor
+import Data.Functor.Identity
 import Data.Text (Text)
 import Database.Persist.Types
 import GHC.Generics
 
 import Network.FedURI
-import Web.ActivityPub
 import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
 import Yesod.MonadSite
 
+import qualified Web.ActivityPub as AP
+
 import Control.Monad.Trans.Except.Local
 
 import Vervis.Access
+import Vervis.Data.Actor
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
@@ -46,6 +57,8 @@ import Vervis.Model
 data GrantRecipBy f = GrantRecipPerson (f Person)
     deriving (Generic, FunctorB, TraversableB, ConstraintsB)
 
+deriving instance AllBF Eq f GrantRecipBy => Eq (GrantRecipBy f)
+
 parseGrantRecip (PersonR p) = Just $ GrantRecipPerson p
 parseGrantRecip _           = Nothing
 
@@ -62,18 +75,18 @@ unhashGrantRecipE resource e =
     ExceptT $ maybe (Left e) Right <$> unhashGrantRecip resource
 
 parseInvite
-    :: Maybe PersonId
-    -> Invite URIMode
+    :: Either PersonId FedURI
+    -> AP.Invite URIMode
     -> ExceptT Text Handler
         ( Either (GrantResourceBy Key) FedURI
         , Either (GrantRecipBy Key) FedURI
         )
-parseInvite maybeSenderID (Invite instrument object target) = do
+parseInvite sender (AP.Invite instrument object target) = do
     verifyRole instrument
     (,) <$> parseTopic target
         <*> parseRecipient object
     where
-    verifyRole (Left RoleAdmin) = pure ()
+    verifyRole (Left AP.RoleAdmin) = pure ()
     verifyRole (Right _) =
         throwE "ForgeFed Admin is the only role allowed currently"
     parseTopic u@(ObjURI h lu) = do
@@ -114,24 +127,26 @@ parseInvite maybeSenderID (Invite instrument object target) = do
                         recipHash
                         "Invite object contains invalid hashid"
                 case recipKey of
-                    GrantRecipPerson p | Just p == maybeSenderID ->
-                        throwE "Invite sender and recipient are the same Person"
+                    GrantRecipPerson p | Left p == sender ->
+                        throwE "Invite local sender and recipient are the same Person"
                     _ -> return recipKey
-            else pure $ Right u
+            else Right <$> do
+                when (Right u == sender) $
+                    throwE "Invite remote sender and recipient are the same actor"
+                return u
 
 parseGrant
-    :: Maybe PersonId
-    -> Grant URIMode
+    :: AP.Grant URIMode
     -> ExceptT Text Handler
         ( Either (GrantResourceBy Key) FedURI
         , Either (GrantRecipBy Key) FedURI
         )
-parseGrant maybeSenderID (Grant object context target) = do
+parseGrant (AP.Grant object context target) = do
     verifyRole object
     (,) <$> parseContext context
         <*> parseTarget target
     where
-    verifyRole (Left RoleAdmin) = pure ()
+    verifyRole (Left AP.RoleAdmin) = pure ()
     verifyRole (Right _) =
         throwE "ForgeFed Admin is the only role allowed currently"
     parseContext u@(ObjURI h lu) = do
@@ -167,12 +182,17 @@ parseGrant maybeSenderID (Grant object context target) = do
                     fromMaybeE
                         (parseGrantRecip route)
                         "Grant target isn't a grant recipient route"
-                recipKey <-
-                    unhashGrantRecipE
-                        recipHash
-                        "Grant target contains invalid hashid"
-                case recipKey of
-                    GrantRecipPerson p | Just p == maybeSenderID ->
-                        throwE "Grant sender and recipient are the same Person"
-                    _ -> return recipKey
+                unhashGrantRecipE
+                    recipHash
+                    "Grant target contains invalid hashid"
             else pure $ Right u
+
+parseAccept (AP.Accept object mresult) = do
+    verifyNothingE mresult "Accept must not contain 'result'"
+    first (\ (actor, _, item) -> (actor, item)) <$>
+        nameExceptT "Accept object" (parseActivityURI object)
+
+grantResourceActorID :: GrantResourceBy Identity -> ActorId
+grantResourceActorID (GrantResourceRepo (Identity r)) = repoActor r
+grantResourceActorID (GrantResourceDeck (Identity d)) = deckActor d
+grantResourceActorID (GrantResourceLoom (Identity l)) = loomActor l

src/Vervis/Federation/Collab.hs

@@ -0,0 +1,636 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2022 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/>.
+ -}
+
+{-# LANGUAGE RankNTypes #-}
+
+module Vervis.Federation.Collab
+    ( personInviteF
+    , topicInviteF
+
+    , repoAcceptF
+    , deckAcceptF
+    , loomAcceptF
+
+    , personGrantF
+    )
+where
+
+import Control.Exception hiding (Handler)
+import Control.Monad
+import Control.Monad.IO.Class
+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)
+import Data.Either
+import Data.Foldable
+import Data.Functor.Identity
+import Data.List.NonEmpty (NonEmpty)
+import Data.Maybe
+import Data.Text (Text)
+import Data.Time.Clock
+import Data.Traversable
+import Database.Persist
+import Database.Persist.Sql
+import Yesod.Persist.Core
+
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text as T
+
+import Database.Persist.JSON
+import Development.PatchMediaType
+import Network.FedURI
+import Yesod.ActivityPub
+import Yesod.FedURI
+import Yesod.Hashids
+import Yesod.MonadSite
+
+import qualified Web.ActivityPub as AP
+
+import Control.Monad.Trans.Except.Local
+import Data.Either.Local
+import Data.Tuple.Local
+import Database.Persist.Local
+import Yesod.Persist.Local
+
+import Vervis.Access
+import Vervis.ActivityPub
+import Vervis.Data.Actor
+import Vervis.Data.Collab
+import Vervis.Delivery
+import Vervis.FedURI
+import Vervis.Federation.Auth
+import Vervis.Federation.Util
+import Vervis.Foundation
+import Vervis.Model
+import Vervis.Persist.Actor
+import Vervis.Persist.Collab
+import Vervis.Recipient
+import Vervis.RemoteActorStore
+
+personInviteF
+    :: UTCTime
+    -> KeyHashid Person
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Invite URIMode
+    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
+personInviteF now recipHash author body mfwd luInvite invite = (,Nothing) <$> do
+
+    -- Check input
+    (resourceAndCap, recipient) <- do
+
+        -- Check the invite-specific data
+        (resource, recip) <-
+            parseInvite (Right $ remoteAuthorURI author) invite
+
+        -- Verify the capability URI is one of:
+        --   * Outbox item URI of a local actor, i.e. a local activity
+        --   * A remote URI
+        capability <- do
+            let muCap = AP.activityCapability $ actbActivity body
+            uCap <- fromMaybeE muCap "No capability provided"
+            nameExceptT "Invite capability" $ parseActivityURI uCap
+
+        -- Verify that capability is either a local activity of a local
+        -- resource, or both resource and capability are of the same remote
+        -- instance
+        (,recip) <$> case (resource, capability) of
+            (Left r, Left (actor, _, item)) -> do
+                unless (grantResourceLocalActor r == actor) $
+                    throwE "Local capability belongs to actor that isn't the resource"
+                return $ Left (r, item)
+            (Left _, Right _) ->
+                throwE "Remote capability obviously doesn't belong to local resource"
+            (Right _, Left _) ->
+                throwE "Local capability obviously doesn't belong to remote resource"
+            (Right (ObjURI h r), Right (ObjURI h' c)) -> do
+                unless (h == h') $
+                    throwE "Capability and resource are on different remote instances"
+                return $ Right (ObjURI h r, c)
+
+    -- Find recipient person in DB, returning 404 if doesn't exist because
+    -- we're in the person's inbox post handler
+    personRecipID <- decodeKeyHashid404 recipHash
+    mhttp <- runDBExcept $ do
+        (personRecip, actorRecip) <- lift $ do
+            p <- get404 personRecipID
+            (p,) <$> getJust (personActor p)
+
+        mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luInvite True
+        for mractid $ \ inviteID -> do
+
+            -- If resource is local, find it in our DB
+            _resourceDB <-
+                bitraverse
+                    (flip getGrantResource "Invite local target not found in DB" . fst)
+                    pure
+                    resourceAndCap
+
+            -- If recipient is local, find it in our DB
+            _recipientDB <-
+                bitraverse
+                    (flip getGrantRecip "Invite local object not found in DB")
+                    pure
+                    recipient
+
+            -- Forward the Invite activity to relevant local stages, and
+            -- schedule delivery for unavailable remote members of them
+            lift $ for mfwd $ \ (localRecips, sig) -> do
+                let inviteeIsRecip =
+                        case recipient of
+                            Left (GrantRecipPerson p) -> p == personRecipID
+                            _ -> False
+                    sieve =
+                        if inviteeIsRecip
+                            then makeRecipientSet [] [LocalStagePersonFollowers recipHash]
+                            else makeRecipientSet [] []
+                remoteRecips <-
+                    insertRemoteActivityToLocalInboxes
+                        False inviteID $
+                            localRecipSieve'
+                                sieve False False localRecips
+                (sig,) <$> deliverRemoteDB_P (actbBL body) inviteID personRecipID sig remoteRecips
+
+    -- Launch asynchronous HTTP forwarding of the Invite activity
+    case mhttp of
+        Nothing -> return "I already have this activity in my inbox, doing nothing"
+        Just mremotesHttpFwd -> do
+            for_ mremotesHttpFwd $ \ (sig, remotes) ->
+                forkWorker "personInviteF inbox-forwarding" $
+                    deliverRemoteHTTP_P now recipHash (actbBL body) sig remotes
+            return $
+                case mremotesHttpFwd of
+                    Nothing -> "Inserted to inbox, no inbox-forwarding to do"
+                    Just _ -> "Inserted to inbox and ran inbox-forwarding of the Invite"
+
+topicInviteF
+    :: UTCTime
+    -> GrantResourceBy KeyHashid
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Invite URIMode
+    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
+topicInviteF now recipByHash author body mfwd luInvite invite = do
+
+    -- Check input
+    uCap <- do
+        let muCap = AP.activityCapability $ actbActivity body
+        fromMaybeE muCap "No capability provided"
+    (resourceAndCap, recipient) <- do
+
+        -- Check the invite-specific data
+        (resource, recip) <-
+            parseInvite (Right $ remoteAuthorURI author) invite
+
+        -- Verify the capability URI is one of:
+        --   * Outbox item URI of a local actor, i.e. a local activity
+        --   * A remote URI
+        capability <- nameExceptT "Invite capability" $ parseActivityURI uCap
+
+        -- Verify that capability is either a local activity of a local
+        -- resource, or both resource and capability are of the same remote
+        -- instance
+        (,recip) <$> case (resource, capability) of
+            (Left r, Left (actor, _, item)) -> do
+                unless (grantResourceLocalActor r == actor) $
+                    throwE "Local capability belongs to actor that isn't the resource"
+                return $ Left (r, item)
+            (Left _, Right _) ->
+                throwE "Remote capability obviously doesn't belong to local resource"
+            (Right _, Left _) ->
+                throwE "Local capability obviously doesn't belong to remote resource"
+            (Right (ObjURI h r), Right (ObjURI h' c)) -> do
+                unless (h == h') $
+                    throwE "Capability and resource are on different remote instances"
+                return $ Right (ObjURI h r, c)
+
+    -- Find recipient topic in DB, returning 404 if doesn't exist because
+    -- we're in the topic's inbox post handler
+    recipByKey <- unhashGrantResource404 recipByHash
+    (_recipByEntity, recipActorID, recipActor) <- lift $ runDB $ do
+        recipE <- getGrantResource404 recipByKey
+        let actorID = grantResourceActorID $ bmap (Identity . entityVal) recipE
+        (recipE, actorID,) <$> getJust actorID
+
+    -- Verify that Invite's topic is me, otherwise I don't need this Invite
+    capability <-
+        case resourceAndCap of
+            Left (resource, item) | resource == recipByKey -> return item
+            _ -> throwE "I'm not the Invite's topic, don't need this Invite"
+
+    return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do
+        mhttp <- do
+            mractid <- lift $ runSiteDB $ insertToInbox now author body (actorInbox recipActor) luInvite False
+            for mractid $ \ inviteID -> do
+
+                -- Verify the specified capability gives relevant access to the
+                -- resource
+                let recipLocalActorByKey = grantResourceLocalActor recipByKey
+                runSiteDBExcept $
+                    verifyCapability
+                        (recipLocalActorByKey, capability)
+                        (Right $ remoteAuthorId author)
+                        recipByKey
+
+                -- If recipient is remote, HTTP GET it, make sure it's an
+                -- actor, and insert it to our DB. If recipient is local, find
+                -- it in our DB.
+                recipientDB <-
+                    bitraverse
+                        (runSiteDBExcept . flip getGrantRecip "Invitee not found in DB")
+                        (\ u@(ObjURI h lu) -> do
+                            instanceID <-
+                                lift $ runSiteDB $ either entityKey id <$> insertBy' (Instance h)
+                            result <-
+                                ExceptT $ first (T.pack . displayException) <$>
+                                    fetchRemoteActor instanceID h lu
+                            case result of
+                                Left Nothing -> throwE "Recipient @id mismatch"
+                                Left (Just err) -> throwE $ T.pack $ displayException err
+                                Right Nothing -> throwE "Recipient isn't an actor"
+                                Right (Just actor) -> return $ entityKey actor
+                        )
+                        recipient
+
+                lift $ runSiteDB $ do
+
+                    -- Insert Collab record to DB
+                    insertCollab recipByKey recipientDB inviteID
+
+                    -- Forward the Invite activity to relevant local stages,
+                    -- and schedule delivery for unavailable remote members of
+                    -- them
+                    for mfwd $ \ (localRecips, sig) -> do
+                        let sieve =
+                                makeRecipientSet [] [localActorFollowers $ grantResourceLocalActor recipByHash]
+                        remoteRecips <-
+                            insertRemoteActivityToLocalInboxes
+                                False inviteID $
+                                    localRecipSieve'
+                                        sieve False False localRecips
+                        case recipByKey of
+                            GrantResourceRepo repoID -> do
+                                repoHash <- encodeKeyHashid repoID
+                                fwds <- deliverRemoteDB_R (actbBL body) inviteID repoID sig remoteRecips
+                                return $ deliverRemoteHTTP_R now repoHash (actbBL body) sig fwds
+                            GrantResourceDeck deckID -> do
+                                deckHash <- encodeKeyHashid deckID
+                                fwds <- deliverRemoteDB_D (actbBL body) inviteID deckID sig remoteRecips
+                                return $ deliverRemoteHTTP_D now deckHash (actbBL body) sig fwds
+                            GrantResourceLoom loomID -> do
+                                loomHash <- encodeKeyHashid loomID
+                                fwds <- deliverRemoteDB_L (actbBL body) inviteID loomID sig remoteRecips
+                                return $ deliverRemoteHTTP_L now loomHash (actbBL body) sig fwds
+
+        -- Launch asynchronous HTTP forwarding of the Invite activity
+        case mhttp of
+            Nothing -> return "I already have this activity in my inbox, doing nothing"
+            Just maybeForward -> do
+                traverse_ (forkWorker "topicInviteF inbox-forwarding") maybeForward
+                return $
+                    case maybeForward of
+                        Nothing -> "Inserted Collab to DB, no inbox-forwarding to do"
+                        Just _ -> "Inserted Collab to DB and ran inbox-forwarding of the Invite"
+
+    where
+
+    insertCollab resource recipient inviteID = do
+        collabID <- insert Collab
+        case resource of
+            GrantResourceRepo repoID ->
+                insert_ $ CollabTopicRepo collabID repoID
+            GrantResourceDeck deckID ->
+                insert_ $ CollabTopicDeck collabID deckID
+            GrantResourceLoom loomID ->
+                insert_ $ CollabTopicLoom collabID loomID
+        insert_ $ CollabFulfillsInviteRemote collabID (remoteAuthorId author) inviteID
+        case recipient of
+            Left (GrantRecipPerson (Entity personID _)) ->
+                insert_ $ CollabRecipLocal collabID personID
+            Right remoteActorID ->
+                insert_ $ CollabRecipRemote collabID remoteActorID
+
+topicAcceptF
+    :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
+    => (topic -> ActorId)
+    -> (forall f. f topic -> GrantResourceBy f)
+    -> (  BL.ByteString
+       -> RemoteActivityId
+       -> Key topic
+       -> ByteString
+       -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
+       -> ReaderT SqlBackend Handler
+            [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))]
+       )
+    -> (  UTCTime
+       -> KeyHashid topic
+       -> BL.ByteString
+       -> ByteString
+       -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))]
+       -> Worker ()
+       )
+    -> UTCTime
+    -> KeyHashid topic
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Accept URIMode
+    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
+topicAcceptF topicActor topicResource deliverRemoteDB deliverRemoteHTTP now recipHash author body mfwd luAccept accept = (,Nothing) <$> do
+
+    -- Check input
+    acceptee <- parseAccept accept
+
+    -- Find recipient topic in DB, returning 404 if doesn't exist because
+    -- we're in the topic's inbox post handler
+    recipKey <- decodeKeyHashid404 recipHash
+    mhttp <- runDBExcept $ do
+        (recipActorID, recipActor) <- lift $ do
+            recip <- get404 recipKey
+            let actorID = topicActor recip
+            (actorID,) <$> getJust actorID
+
+        -- Find the accepted activity in our DB
+        accepteeDB <- do
+            a <- getActivity acceptee
+            fromMaybeE a "Can't find acceptee in DB"
+
+        -- See if the accepted activity is an Invite to a local resource,
+        -- grabbing the Collab record from our DB
+        (collabID, inviteSender) <-
+            case accepteeDB of
+                Left (actorByKey, _actorEntity, itemID) -> do
+                    maybeSender <-
+                        lift $ getValBy $ UniqueCollabFulfillsInviteLocalInvite itemID
+                    (,Left actorByKey) . collabFulfillsInviteLocalCollab <$>
+                        fromMaybeE maybeSender "Accepted local activity isn't an Invite I'm aware of"
+                Right remoteActivityID -> do
+                    maybeSender <-
+                        lift $ getValBy $ UniqueCollabFulfillsInviteRemoteInvite remoteActivityID
+                    CollabFulfillsInviteRemote collab actorID _ <-
+                        fromMaybeE maybeSender "Accepted remote activity isn't an Invite I'm aware of"
+                    actor <- lift $ getJust actorID
+                    sender <- lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor
+                    return (collab, Right sender)
+
+        -- Find the local resource and verify it's me
+        topic <- lift $ getCollabTopic collabID
+        unless (topicResource recipKey == topic) $
+            throwE "Accept object is an Invite for some other resource"
+
+        -- Find the Collab recipient and verify it's the sender of the Accept
+        recipID <- do
+            recip <-
+                lift $
+                requireEitherAlt
+                    (getBy $ UniqueCollabRecipLocal collabID)
+                    (getBy $ UniqueCollabRecipRemote collabID)
+                    "Found Collab with no recip"
+                    "Found Collab with multiple recips"
+            case recip of
+                Right (Entity crrid crr)
+                    | collabRecipRemoteActor crr == remoteAuthorId author -> return crrid
+                _ -> throwE "Accepting an Invite whose recipient is someone else"
+
+        -- Verify the Collab isn't already validated
+        maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID
+        verifyNothingE maybeEnabled "I already sent a Grant for this Invite"
+
+        -- Record the Accept on the Collab
+        mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luAccept False
+        for mractid $ \ acceptID -> do
+            maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID acceptID
+            unless (isNothing maybeAccept) $ do
+                lift $ delete acceptID
+                throwE "This Invite already has an Accept by recip"
+
+            -- Forward the Accept activity to relevant local stages, and
+            -- schedule delivery for unavailable remote members of them
+            maybeRemotesHttpFwdAccept <- lift $ for mfwd $ \ (localRecips, sig) -> do
+                let sieve =
+                        makeRecipientSet [] [localActorFollowers $ grantResourceLocalActor $ topicResource recipHash]
+                remoteRecips <-
+                    insertRemoteActivityToLocalInboxes
+                        False acceptID $
+                            localRecipSieve'
+                                sieve False False localRecips
+                (sig,) <$> deliverRemoteDB (actbBL body) acceptID recipKey sig remoteRecips
+
+            remotesHttpGrant <- lift $ do
+
+                -- Enable the Collab in our DB
+                grantID <- insertEmptyOutboxItem (actorOutbox recipActor) now
+                insert_ $ CollabEnable collabID grantID
+
+                -- Prepare a Grant activity and insert to topic's outbox
+                (docGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant) <-
+                    insertGrantToOutbox inviteSender grantID
+
+                -- Deliver the Grant to local recipients, and schedule delivery
+                -- for unavailable remote recipients
+                (grantID, docGrant, fwdHostsGrant,) <$> do
+                    knownRemoteRecipsGrant <-
+                        deliverLocal'
+                            False
+                            (grantResourceLocalActor $ topicResource recipHash)
+                            recipActorID
+                            grantID
+                            localRecipsGrant
+                    deliverRemoteDB'' fwdHostsGrant grantID remoteRecipsGrant knownRemoteRecipsGrant
+
+            return (maybeRemotesHttpFwdAccept, remotesHttpGrant)
+
+    -- Launch asynchronous HTTP forwarding of the Accept activity
+    case mhttp of
+        Nothing -> return "I already have this activity in my inbox, doing nothing"
+        Just (mremotesHttpFwd, (grantID, docGrant, fwdHostsGrant, recipsGrant)) -> do
+            forkWorker "topicAcceptF Grant HTTP delivery" $
+                deliverRemoteHttp' fwdHostsGrant grantID docGrant recipsGrant
+            case mremotesHttpFwd of
+                Nothing -> return "Sent a Grant, no inbox-forwarding to do"
+                Just (sig, remotes) -> do
+                    forkWorker "topicAcceptF inbox-forwarding" $
+                        deliverRemoteHTTP now recipHash (actbBL body) sig remotes
+                    return "Sent a Grant and ran inbox-forwarding of the Accept"
+
+    where
+
+    insertGrantToOutbox
+        :: Either (LocalActorBy Key) (FedURI, Maybe LocalURI)
+        -> OutboxItemId
+        -> ReaderT SqlBackend Handler
+            ( AP.Doc AP.Activity URIMode
+            , RecipientRoutes
+            , [(Host, NonEmpty LocalURI)]
+            , [Host]
+            )
+    insertGrantToOutbox sender grantID = do
+        encodeRouteLocal <- getEncodeRouteLocal
+        encodeRouteHome <- getEncodeRouteHome
+        hLocal <- asksSite siteInstanceHost
+
+        accepter <- getJust $ remoteAuthorId author
+        let topicByHash = grantResourceLocalActor $ topicResource recipHash
+
+        senderHash <- bitraverse hashLocalActor pure sender
+        grantHash <- encodeKeyHashid grantID
+
+        let audSender =
+                case senderHash of
+                    Left actor -> AudLocal [actor] [localActorFollowers actor]
+                    Right (ObjURI h lu, followers) ->
+                        AudRemote h [lu] (maybeToList followers)
+            audRecip =
+                let ObjURI h lu = remoteAuthorURI author
+                in  AudRemote h [lu] (maybeToList $ remoteActorFollowers accepter)
+            audTopic = AudLocal [] [localActorFollowers topicByHash]
+
+            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience [audSender, audRecip, audTopic]
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            doc = AP.Doc hLocal AP.Activity
+                { AP.activityId         = Just $ encodeRouteLocal $ activityRoute topicByHash grantHash
+                , AP.activityActor      = encodeRouteLocal $ renderLocalActor topicByHash
+                , AP.activityCapability = Nothing
+                , AP.activitySummary    = Nothing
+                , AP.activityAudience   = AP.Audience recips [] [] [] [] []
+                , AP.activityFulfills   = [AP.acceptObject accept]
+                , AP.activitySpecific   = AP.GrantActivity AP.Grant
+                    { AP.grantObject  = Left AP.RoleAdmin
+                    , AP.grantContext = encodeRouteHome $ renderLocalActor topicByHash
+                    , AP.grantTarget  = remoteAuthorURI author
+                    }
+                }
+
+        update grantID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+        return (doc, recipientSet, remoteActors, fwdHosts)
+
+repoAcceptF
+    :: UTCTime
+    -> KeyHashid Repo
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Accept URIMode
+    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
+repoAcceptF =
+    topicAcceptF repoActor GrantResourceRepo deliverRemoteDB_R deliverRemoteHTTP_R
+
+deckAcceptF
+    :: UTCTime
+    -> KeyHashid Deck
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Accept URIMode
+    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
+deckAcceptF =
+    topicAcceptF deckActor GrantResourceDeck deliverRemoteDB_D deliverRemoteHTTP_D
+
+loomAcceptF
+    :: UTCTime
+    -> KeyHashid Loom
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Accept URIMode
+    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
+loomAcceptF =
+    topicAcceptF loomActor GrantResourceLoom deliverRemoteDB_L deliverRemoteHTTP_L
+
+personGrantF
+    :: UTCTime
+    -> KeyHashid Person
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Grant URIMode
+    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
+personGrantF now recipHash author body mfwd luGrant grant = (,Nothing) <$> do
+
+    -- Check input
+    (_remoteResource, recipient) <- do
+        (resource, recip) <- parseGrant grant
+        let u@(ObjURI h _) = remoteAuthorURI author
+        resourceURI <-
+            case resource of
+                Right (ObjURI h' r) | h == h' -> return (u, r)
+                _ -> throwE "Grant resource and Grant author are from different instances"
+        when (recip == Right u) $
+            throwE "Grant sender and target are the same remote actor"
+        return (resourceURI, recip)
+
+    -- Find recipient person in DB, returning 404 if doesn't exist because
+    -- we're in the person's inbox post handler
+    personRecipID <- decodeKeyHashid404 recipHash
+    mhttp <- runDBExcept $ do
+        (personRecip, actorRecip) <- lift $ do
+            p <- get404 personRecipID
+            (p,) <$> getJust (personActor p)
+
+        mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luGrant True
+        for mractid $ \ grantID -> do
+
+            -- If recipient is local, find it in our DB
+            _recipientDB <-
+                bitraverse
+                    (flip getGrantRecip "Grant local target not found in DB")
+                    pure
+                    recipient
+
+            -- Forward the Grant activity to relevant local stages, and
+            -- schedule delivery for unavailable remote members of them
+            lift $ for mfwd $ \ (localRecips, sig) -> do
+                let targetIsRecip =
+                        case recipient of
+                            Left (GrantRecipPerson p) -> p == personRecipID
+                            _ -> False
+                    sieve =
+                        if targetIsRecip
+                            then makeRecipientSet [] [LocalStagePersonFollowers recipHash]
+                            else makeRecipientSet [] []
+                remoteRecips <-
+                    insertRemoteActivityToLocalInboxes
+                        False grantID $
+                            localRecipSieve'
+                                sieve False False localRecips
+                (sig,) <$> deliverRemoteDB_P (actbBL body) grantID personRecipID sig remoteRecips
+
+    -- Launch asynchronous HTTP forwarding of the Invite activity
+    case mhttp of
+        Nothing -> return "I already have this activity in my inbox, doing nothing"
+        Just mremotesHttpFwd -> do
+            for_ mremotesHttpFwd $ \ (sig, remotes) ->
+                forkWorker "personGrantF inbox-forwarding" $
+                    deliverRemoteHTTP_P now recipHash (actbBL body) sig remotes
+            return $
+                case mremotesHttpFwd of
+                    Nothing -> "Inserted to inbox, no inbox-forwarding to do"
+                    Just _ -> "Inserted to inbox and ran inbox-forwarding of the Grant"

src/Vervis/Handler/Deck.hs

@@ -91,8 +91,10 @@ import Data.Paginate.Local
 import Database.Persist.Local
 import Yesod.Persist.Local
 
+import Vervis.Access
 import Vervis.API
 import Vervis.Federation.Auth
+import Vervis.Federation.Collab
 import Vervis.FedURI
 import Vervis.Form.Project
 import Vervis.Foundation
@@ -155,13 +157,17 @@ postDeckInboxR recipDeckHash =
     postInbox $ handleRobotInbox (LocalActorDeck recipDeckHash) handle
     where
     handle
-        :: RemoteAuthor
+        :: UTCTime
+        -> RemoteAuthor
+        -> ActivityBody
         -> Maybe (RecipientRoutes, ByteString)
         -> LocalURI
         -> SpecificActivity URIMode
         -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-    handle _author _mfwd _luActivity specific =
+    handle now author body mfwd luActivity specific =
         case specific of
+            AP.AcceptActivity accept ->
+                deckAcceptF now recipDeckHash author body mfwd luActivity accept
             {-
             CreateActivity (Create obj mtarget) ->
                 case obj of
@@ -172,6 +178,10 @@ postDeckInboxR recipDeckHash =
                     _ -> error "Unsupported create object type for projects"
             FollowActivity follow ->
                 (,Nothing) <$> projectFollowF shrRecip prjRecip now remoteAuthor body mfwd luActivity follow
+            -}
+            AP.InviteActivity invite ->
+                topicInviteF now (GrantResourceDeck recipDeckHash) author body mfwd luActivity invite
+            {-
             OfferActivity (Offer obj target) ->
                 case obj of
                     OfferTicket ticket ->

src/Vervis/Handler/Group.hs

@@ -45,14 +45,12 @@ where
 
 import Control.Monad.Trans.Except
 import Data.Text (Text)
+import Data.Time.Clock
 import Database.Persist
 import Data.ByteString (ByteString)
 import Yesod.Core.Content (TypedContent)
-import Yesod.Core.Handler
 import Yesod.Persist.Core
 
-import qualified Database.Esqueleto as E
-
 import Network.FedURI
 import Yesod.ActivityPub
 import Yesod.FedURI
@@ -64,7 +62,6 @@ import Vervis.Federation.Auth
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
-import Vervis.Model.Group
 import Vervis.Recipient
 import Vervis.Web.Actor
 
@@ -111,12 +108,14 @@ postGroupInboxR recipGroupHash =
     postInbox $ handleRobotInbox (LocalActorGroup recipGroupHash) handle
     where
     handle
-        :: RemoteAuthor
+        :: UTCTime
+        -> RemoteAuthor
+        -> ActivityBody
         -> Maybe (RecipientRoutes, ByteString)
         -> LocalURI
         -> AP.SpecificActivity URIMode
         -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-    handle _author _mfwd _luActivity specific =
+    handle _now _author _body _mfwd _luActivity specific =
         case specific of
             _ -> return ("Unsupported activity type for groups", Nothing)
 

src/Vervis/Handler/Loom.hs

@@ -61,8 +61,10 @@ import Data.Paginate.Local
 import Database.Persist.Local
 import Yesod.Persist.Local
 
+import Vervis.Access
 import Vervis.API
 import Vervis.Federation.Auth
+import Vervis.Federation.Collab
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
@@ -113,13 +115,19 @@ postLoomInboxR recipLoomHash =
     postInbox $ handleRobotInbox (LocalActorLoom recipLoomHash) handle
     where
     handle
-        :: RemoteAuthor
+        :: UTCTime
+        -> RemoteAuthor
+        -> ActivityBody
         -> Maybe (RecipientRoutes, ByteString)
         -> LocalURI
         -> AP.SpecificActivity URIMode
         -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-    handle _author _mfwd _luActivity specific =
+    handle now author body mfwd luActivity specific =
         case specific of
+            AP.AcceptActivity accept ->
+                loomAcceptF now recipLoomHash author body mfwd luActivity accept
+            AP.InviteActivity invite ->
+                topicInviteF now (GrantResourceLoom recipLoomHash) author body mfwd luActivity invite
             _ -> return ("Unsupported activity type for looms", Nothing)
 
 getLoomOutboxR :: KeyHashid Loom -> Handler TypedContent

src/Vervis/Handler/Person.hs

@@ -69,6 +69,7 @@ import Vervis.ActorKey
 import Vervis.API
 import Vervis.Data.Actor
 import Vervis.Federation.Auth
+import Vervis.Federation.Collab
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
@@ -203,6 +204,10 @@ postPersonInboxR recipPersonHash = postInbox handle
             FollowActivity follow ->
                 (,Nothing) <$> sharerFollowF shrRecip now author body mfwd luActivity follow
             -}
+            AP.GrantActivity grant ->
+                personGrantF now recipPersonHash author body mfwd luActivity grant
+            AP.InviteActivity invite ->
+                personInviteF now recipPersonHash author body mfwd luActivity invite
             {-
             OfferActivity (Offer obj target) ->
                 case obj of

src/Vervis/Handler/Repo.hs

@@ -148,8 +148,10 @@ import Yesod.Persist.Local
 import qualified Data.Git.Local as G (createRepo)
 import qualified Darcs.Local.Repository as D (createRepo)
 
+import Vervis.Access
 import Vervis.API
 import Vervis.Federation.Auth
+import Vervis.Federation.Collab
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Path
@@ -215,13 +217,17 @@ postRepoInboxR recipRepoHash =
     postInbox $ handleRobotInbox (LocalActorRepo recipRepoHash) handle
     where
     handle
-        :: RemoteAuthor
+        :: UTCTime
+        -> RemoteAuthor
+        -> ActivityBody
         -> Maybe (RecipientRoutes, ByteString)
         -> LocalURI
         -> AP.SpecificActivity URIMode
         -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-    handle _author _mfwd _luActivity specific =
+    handle now author body mfwd luActivity specific =
         case specific of
+            AP.AcceptActivity accept ->
+                repoAcceptF now recipRepoHash author body mfwd luActivity accept
             {-
             ApplyActivity (AP.Apply uObject uTarget) ->
                 repoApplyF now shrRecip rpRecip remoteAuthor body mfwd luActivity uObject uTarget
@@ -239,6 +245,10 @@ postRepoInboxR recipRepoHash =
                     _ -> error "Unsupported create object type for repos"
             FollowActivity follow ->
                 (,Nothing) <$> repoFollowF shrRecip rpRecip now remoteAuthor body mfwd luActivity follow
+            -}
+            AP.InviteActivity invite ->
+                topicInviteF now (GrantResourceRepo recipRepoHash) author body mfwd luActivity invite
+            {-
             OfferActivity (Offer obj target) ->
                 case obj of
                     OfferTicket ticket ->

src/Vervis/Persist/Actor.hs

@@ -16,6 +16,7 @@
 module Vervis.Persist.Actor
     ( getLocalActor
     , verifyLocalActivityExistsInDB
+    , getRemoteActorURI
     )
 where
 
@@ -28,6 +29,8 @@ import Data.Text (Text)
 import Database.Persist
 import Database.Persist.Sql
 
+import Network.FedURI
+
 import Control.Monad.Trans.Except.Local
 import Database.Persist.Local
 
@@ -66,3 +69,11 @@ verifyLocalActivityExistsInDB actorByKey outboxItemID = do
     itemActorByKey <- lift $ getLocalActor itemActorID
     unless (itemActorByKey == actorByKey) $
         throwE "Actor-in-URI and Actor-owning-the-outbox-item-in-DB mismatch"
+
+getRemoteActorURI actor = do
+    object <- getJust $ remoteActorIdent actor
+    inztance <- getJust $ remoteObjectInstance object
+    return $
+        ObjURI
+            (instanceHost inztance)
+            (remoteObjectIdent object)

src/Vervis/Persist/Collab.hs

@@ -0,0 +1,49 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2022 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/>.
+ -}
+
+module Vervis.Persist.Collab
+    ( getCollabTopic
+    , getGrantRecip
+    )
+where
+
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Reader
+import Database.Persist.Sql
+
+import Database.Persist.Local
+
+import Vervis.Access
+import Vervis.Data.Collab
+import Vervis.Model
+
+getCollabTopic
+    :: MonadIO m => CollabId -> ReaderT SqlBackend m (GrantResourceBy Key)
+getCollabTopic collabID = do
+    maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
+    maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
+    maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
+    return $
+        case (maybeRepo, maybeDeck, maybeLoom) of
+            (Nothing, Nothing, Nothing) -> error "Found Collab without topic"
+            (Just r, Nothing, Nothing) ->
+                GrantResourceRepo $ collabTopicRepoRepo r
+            (Nothing, Just d, Nothing) ->
+                GrantResourceDeck $ collabTopicDeckDeck d
+            (Nothing, Nothing, Just l) ->
+                GrantResourceLoom $ collabTopicLoomLoom l
+            _ -> error "Found Collab with multiple topics"
+
+getGrantRecip (GrantRecipPerson k) e = GrantRecipPerson <$> getEntityE k e

src/Vervis/Web/Actor.hs

@@ -458,7 +458,9 @@ getFollowingCollection here actor hash = do
 
 handleRobotInbox
     :: LocalActorBy KeyHashid
-    -> (  RemoteAuthor
+    -> (  UTCTime
+       -> RemoteAuthor
+       -> ActivityBody
        -> Maybe (RecipientRoutes, ByteString)
        -> LocalURI
        -> SpecificActivity URIMode
@@ -480,4 +482,4 @@ handleRobotInbox recipByHash handleSpecific now auth body = do
         paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients"
     msig <- checkForwarding recipByHash
     let mfwd = (localRecips,) <$> msig
-    handleSpecific remoteAuthor mfwd luActivity (activitySpecific $ actbActivity body)
+    handleSpecific now remoteAuthor body mfwd luActivity (activitySpecific $ actbActivity body)

vervis.cabal

@@ -144,6 +144,7 @@ library
                        Vervis.Discussion
                        --Vervis.Federation
                        Vervis.Federation.Auth
+                       Vervis.Federation.Collab
                        --Vervis.Federation.Discussion
                        --Vervis.Federation.Offer
                        --Vervis.Federation.Push
@@ -206,6 +207,7 @@ library
                        Vervis.Path
 
                        Vervis.Persist.Actor
+                       Vervis.Persist.Collab
 
                        Vervis.Query
                        Vervis.Readme