C2S: grantC: Insert Collab records for Grants with remote topics too

src/Vervis/API.hs

@@ -45,6 +45,7 @@ import Crypto.Hash
 import Data.Aeson
 import Data.Barbie
 import Data.Bifunctor
+import Data.Bifoldable
 import Data.Bitraversable
 import Data.ByteString (ByteString)
 import Data.Either
@@ -1472,6 +1473,13 @@ followC (Entity pidSender personSender) summary audience follow@(AP.Follow uObje
 data GrantRecipBy f = GrantRecipPerson (f Person)
     deriving (Generic, FunctorB, TraversableB, ConstraintsB)
 
+data Result
+    = ResultSomeException SomeException
+    | ResultIdMismatch
+    | ResultGetError APGetError
+    | ResultNotActor
+    deriving Show
+
 grantC
     :: Entity Person
     -> Actor
@@ -1483,14 +1491,12 @@ grantC
 grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
 
     -- Check input
-    (resourceK, recipientK) <- parseGrant grant
+    (resource, recipient) <- parseGrant grant
-    let input = adaptGrant resourceK recipientK
     ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
         mrecips <- parseAudience audience
-        recips <- fromMaybeE mrecips "Create TicketTracker with no recipients"
+        recips <- fromMaybeE mrecips "Grant with no recipients"
         checkFederation $ paudRemoteActors recips
         return recips
-    verifyRecipients input localRecips remoteRecips
 
     -- Verify the capability URI is one of:
     --   * Outbox item URI of a local actor, i.e. a local activity
@@ -1498,44 +1504,70 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
     uCap <- fromMaybeE muCap "No capability provided"
     capID <- parseActivityURI "Grant capability" uCap
 
+    -- If resource is remote, HTTP GET it and its managing actor, and insert to
+    -- our DB. If resource is local, find it in our DB.
+    resourceDB <-
+        bitraverse
+            (runDBExcept . flip getGrantResource "Grant context not found in DB")
+            (\ u@(ObjURI h lu) -> do
+                instanceID <-
+                    lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
+                result <-
+                    ExceptT $ first (T.pack . show) <$>
+                        fetchRemoteResource instanceID h lu
+                case result of
+                    Left (Entity actorID actor) ->
+                        return (remoteActorIdent actor, actorID, u)
+                    Right (objectID, luManager, (Entity actorID _)) ->
+                        return (objectID, actorID, ObjURI h luManager)
+            )
+            resource
+
     -- If recipient is remote, HTTP GET it, make sure it's an actor, and insert
-    -- it to our DB
+    -- it to our DB. If recipient is local, find it in our DB.
-    inputHttp <- for input $ \ (resource, recipient) ->
+    recipientDB <-
-        fmap (resource,) $ bifor recipient pure $ \ (ObjURI h lu) -> do
+        bitraverse
-            instanceID <-
+            (runDBExcept . flip getGrantRecip "Grant recipient not found in DB")
-                lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
+            (\ u@(ObjURI h lu) -> do
-            result <-
+                instanceID <-
-                ExceptT $ first (T.pack . displayException) <$>
+                    lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
-                    fetchRemoteActor instanceID h lu
+                result <-
-            case result of
+                    ExceptT $ first (T.pack . displayException) <$>
-                Left Nothing -> throwE "Recipient @id mismatch"
+                        fetchRemoteActor instanceID h lu
-                Left (Just err) -> throwE $ T.pack $ displayException err
+                case result of
-                Right Nothing -> throwE "Recipient isn't an actor"
+                    Left Nothing -> throwE "Recipient @id mismatch"
-                Right (Just actor) -> return $ entityKey actor
+                    Left (Just err) -> throwE $ T.pack $ displayException err
+                    Right Nothing -> throwE "Recipient isn't an actor"
+                    Right (Just actor) -> return (entityKey actor, u)
+            )
+            recipient
+
+    -- Verify that resource and recipient are addressed by the Grant
+    bitraverse_
+        (verifyResourceAddressed localRecips . bmap entityKey)
+        (\ (_, _, u) -> verifyRemoteAddressed remoteRecips u)
+        resourceDB
+    bitraverse_
+        (verifyRecipientAddressed localRecips . bmap entityKey)
+        (verifyRemoteAddressed remoteRecips . snd)
+        recipientDB
 
     now <- liftIO getCurrentTime
     senderHash <- encodeKeyHashid pidUser
 
     (obiidGrant, deliverHttpGrant) <- runDBExcept $ do
 
-        -- Find resource (if local) and recipient (if local) in DB
+        -- If resource is local, verify the specified capability gives relevant
-        inputDB <-
+        -- access. If resource is remote, check the specified capability as
-            for inputHttp $ bitraverse
+        -- much as we can, letting the remote resource say the final word.
-                (flip getGrantResource "Grant context not found in DB")
+        bitraverse_
-                (bitraverse
+            (verifyCapability capID pidUser . bmap entityKey)
-                    (flip getGrantRecip "Grant recipient not found in DB")
+            (verifyCapabilityRemote capID pidUser . (\ (o, _, _) -> o))
-                    pure
+            resourceDB
-                )
-
-        -- If resource is loca, verify the specified capability gives relevant
-        -- access
-        for_ inputDB $ \ (resource, _) ->
-            verifyCapability capID pidUser (bmap entityKey resource)
 
         -- Insert new Collab to DB
         grantID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
-        for_ inputDB $ \ (resource, recipient) ->
+        lift $ insertCollab resourceDB recipientDB grantID
-            lift $ insertCollab resource recipient grantID
 
         -- Insert the Grant activity to author's outbox
         docGrant <- lift $ insertGrantToOutbox senderHash now uCap blinded grantID
@@ -1543,48 +1575,52 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
         -- Deliver the Grant activity to local recipients, and schedule
         -- delivery for unavailable remote recipients
         remoteRecipsHttpGrant <- do
-            resourceH <- bitraverse hashGrantResource pure resourceK
+            resourceHash <- bitraverse hashGrantResource pure resource
-            recipientH <- bitraverse hashGrantRecip pure recipientK
+            recipientHash <- bitraverse hashGrantRecip pure recipient
-            let actors = catMaybes
+            let sieveActors = catMaybes
-                    [ case resourceH of
+                    [ case resourceHash of
                         Left (GrantResourceRepo r) -> Just $ LocalActorRepo r
                         Left (GrantResourceDeck d) -> Just $ LocalActorDeck d
                         Left (GrantResourceLoom l) -> Just $ LocalActorLoom l
                         Right _                    -> Nothing
-                    , case recipientH of
+                    , case recipientHash of
                         Left (GrantRecipPerson p) -> Just $ LocalActorPerson p
                         Right _                   -> Nothing
                     ]
-                stages = catMaybes
+                sieveStages = catMaybes
                     [ Just $ LocalStagePersonFollowers senderHash
-                    , case resourceH of
+                    , case resourceHash of
                         Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r
                         Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d
                         Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l
                         Right _                    -> Nothing
-                    , case recipientH of
+                    , case recipientHash of
                         Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p
                         Right _                   -> Nothing
                     ]
-                sieve = makeRecipientSet actors stages
+                sieve = makeRecipientSet sieveActors sieveStages
             moreRemoteRecips <-
                 lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor personUser) grantID $
                     localRecipSieve sieve False localRecips
             checkFederation moreRemoteRecips
             lift $ deliverRemoteDB'' fwdHosts grantID remoteRecips moreRemoteRecips
 
-        -- For local resource/recipient, verify they've received the Grant
+        -- If resource is local, verify it has received the Grant
-        for_ inputDB $ \ (resource, recipient) -> do
+        case resourceDB of
-            let resourceActorID =
+            Left localResource -> do
-                    case resource of
+                let resourceActorID =
-                        GrantResourceRepo (Entity _ r) -> repoActor r
+                        case localResource of
-                        GrantResourceDeck (Entity _ d) -> deckActor d
+                            GrantResourceRepo (Entity _ r) -> repoActor r
-                        GrantResourceLoom (Entity _ l) -> loomActor l
+                            GrantResourceDeck (Entity _ d) -> deckActor d
-            verifyActorHasItem resourceActorID grantID "Local topic didn't receive the Grant"
+                            GrantResourceLoom (Entity _ l) -> loomActor l
-            case recipient of
+                verifyActorHasItem resourceActorID grantID "Local topic didn't receive the Grant"
-                Left (GrantRecipPerson (Entity _ p)) ->
+            Right _ -> pure ()
-                    verifyActorHasItem (personActor p) grantID "Local recipient didn't receive the Grant"
+
-                Right _ -> return ()
+        -- If recipient is local, verify it has received the grant
+        case recipientDB of
+            Left (GrantRecipPerson (Entity _ p)) ->
+                verifyActorHasItem (personActor p) grantID "Local recipient didn't receive the Grant"
+            Right _ -> pure ()
 
         -- Return instructions for HTTP delivery to remote recipients
         return
@@ -1600,6 +1636,42 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
 
     where
 
+    parseGrantResource (RepoR r) = Just $ GrantResourceRepo r
+    parseGrantResource (DeckR d) = Just $ GrantResourceDeck d
+    parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
+    parseGrantResource _         = Nothing
+
+    unhashGrantResourcePure ctx = f
+        where
+        f (GrantResourceRepo r) =
+            GrantResourceRepo <$> decodeKeyHashidPure ctx r
+        f (GrantResourceDeck d) =
+            GrantResourceDeck <$> decodeKeyHashidPure ctx d
+        f (GrantResourceLoom l) =
+            GrantResourceLoom <$> decodeKeyHashidPure ctx l
+
+    unhashGrantResource resource = do
+        ctx <- asksSite siteHashidsContext
+        return $ unhashGrantResourcePure ctx resource
+
+    unhashGrantResourceE resource e =
+        ExceptT $ maybe (Left e) Right <$> unhashGrantResource resource
+
+    parseGrantRecip (PersonR p) = Just $ GrantRecipPerson p
+    parseGrantRecip _           = Nothing
+
+    unhashGrantRecipPure ctx = f
+        where
+        f (GrantRecipPerson p) =
+            GrantRecipPerson <$> decodeKeyHashidPure ctx p
+
+    unhashGrantRecip resource = do
+        ctx <- asksSite siteHashidsContext
+        return $ unhashGrantRecipPure ctx resource
+
+    unhashGrantRecipE resource e =
+        ExceptT $ maybe (Left e) Right <$> unhashGrantRecip resource
+
     parseGrant
         :: Grant URIMode
         -> ExceptT Text Handler
@@ -1630,24 +1702,6 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
                         resourceHash
                         "Grant resource contains invalid hashid"
                 else pure $ Right u
-            where
-            parseGrantResource (RepoR r) = Just $ GrantResourceRepo r
-            parseGrantResource (DeckR d) = Just $ GrantResourceDeck d
-            parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
-            parseGrantResource _         = Nothing
-            unhashGrantResourcePure ctx = f
-                where
-                f (GrantResourceRepo r) =
-                    GrantResourceRepo <$> decodeKeyHashidPure ctx r
-                f (GrantResourceDeck d) =
-                    GrantResourceDeck <$> decodeKeyHashidPure ctx d
-                f (GrantResourceLoom l) =
-                    GrantResourceLoom <$> decodeKeyHashidPure ctx l
-            unhashGrantResource resource = do
-                ctx <- asksSite siteHashidsContext
-                return $ unhashGrantResourcePure ctx resource
-            unhashGrantResourceE resource e =
-                ExceptT $ maybe (Left e) Right <$> unhashGrantResource resource
         parseTarget u@(ObjURI h lu) = do
             hl <- hostIsLocal h
             if hl
@@ -1669,48 +1723,42 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
                             throwE "Grant sender and recipient are the same Person"
                         _ -> return recipKey
                 else pure $ Right u
-            where
-            parseGrantRecip (PersonR p) = Just $ GrantRecipPerson p
-            parseGrantRecip _           = Nothing
-            unhashGrantRecipPure ctx = f
-                where
-                f (GrantRecipPerson p) =
-                    GrantRecipPerson <$> decodeKeyHashidPure ctx p
-            unhashGrantRecip resource = do
-                ctx <- asksSite siteHashidsContext
-                return $ unhashGrantRecipPure ctx resource
-            unhashGrantRecipE resource e =
-                ExceptT $ maybe (Left e) Right <$> unhashGrantRecip resource
 
-    adaptGrant
+    fetchRemoteResource instanceID host localURI = do
-        :: Either (GrantResourceBy Key) FedURI
+        maybeActor <- runSiteDB $ runMaybeT $ do
-        -> Either (GrantRecipBy Key) FedURI
+            roid <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID localURI
-        -> Maybe (GrantResourceBy Key, Either (GrantRecipBy Key) FedURI)
+            MaybeT $ getBy $ UniqueRemoteActor roid
-    adaptGrant (Right _)       _     = Nothing
+        case maybeActor of
-    adaptGrant (Left resource) recip = Just (resource, recip)
+            Just actor -> return $ Right $ Left actor
-
+            Nothing -> do
-    verifyRecipients input localRecips remoteRecips =
+                manager <- asksSite getHttpManager
-        for_ input $ \ (resourceK, recipientK) -> do
+                errorOrResource <- fetchResource manager host localURI
-            resourceH <- hashGrantResource resourceK
+                case errorOrResource of
-            recipientH <- bitraverse hashGrantRecip pure recipientK
+                    Left maybeError ->
-            fromMaybeE (verifyResource resourceH) "Local resource not addressed"
+                        return $ Left $ maybe ResultIdMismatch ResultGetError maybeError
-            fromMaybeE (verifyRecip recipientH) "Recipient not addressed"
+                    Right resource -> do
-        where
+                        case resource of
-        verifyResource (GrantResourceRepo r) = do
+                            ResourceActor (AP.Actor local detail) -> runSiteDB $ do
-            routes <- lookup r $ recipRepos localRecips
+                                roid <- either entityKey id <$> insertBy' (RemoteObject instanceID localURI)
-            guard $ routeRepo routes
+                                let ra = RemoteActor
-        verifyResource (GrantResourceDeck d) = do
+                                        { remoteActorIdent      = roid
-            routes <- lookup d $ recipDecks localRecips
+                                        , remoteActorName       =
-            guard $ routeDeck $ familyDeck routes
+                                            AP.actorName detail <|> AP.actorUsername detail
-        verifyResource (GrantResourceLoom l) = do
+                                        , remoteActorInbox      = AP.actorInbox local
-            routes <- lookup l $ recipLooms localRecips
+                                        , remoteActorFollowers  = AP.actorFollowers local
-            guard $ routeLoom $ familyLoom routes
+                                        , remoteActorErrorSince = Nothing
-        verifyRecip (Left (GrantRecipPerson p)) = do
+                                        }
-            routes <- lookup p $ recipPeople localRecips
+                                Right . Left . either id id <$> insertByEntity' ra
-            guard $ routePerson routes
+                            ResourceChild luId luManager -> do
-        verifyRecip (Right (ObjURI h lu)) = do
+                                roid <- runSiteDB $ either entityKey id <$> insertBy' (RemoteObject instanceID localURI)
-            lus <- lookup h remoteRecips
+                                result <- fetchRemoteActor instanceID host luManager
-            guard $ lu `elem` lus
+                                return $
+                                    case result of
+                                        Left e -> Left $ ResultSomeException e
+                                        Right (Left Nothing) -> Left ResultIdMismatch
+                                        Right (Left (Just e)) -> Left $ ResultGetError e
+                                        Right (Right Nothing) -> Left ResultNotActor
+                                        Right (Right (Just actor)) -> Right $ Right (roid, luManager, actor)
 
     getGrantResource (GrantResourceRepo k) e =
         GrantResourceRepo <$> getEntityE k e
@@ -1721,20 +1769,53 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
 
     getGrantRecip (GrantRecipPerson k) e = GrantRecipPerson <$> getEntityE k e
 
+    verifyResourceAddressed localRecips resource = do
+        resourceHash <- hashGrantResource resource
+        fromMaybeE (verify resourceHash) "Local resource not addressed"
+        where
+        verify (GrantResourceRepo r) = do
+            routes <- lookup r $ recipRepos localRecips
+            guard $ routeRepo routes
+        verify (GrantResourceDeck d) = do
+            routes <- lookup d $ recipDecks localRecips
+            guard $ routeDeck $ familyDeck routes
+        verify (GrantResourceLoom l) = do
+            routes <- lookup l $ recipLooms localRecips
+            guard $ routeLoom $ familyLoom routes
+
+    verifyRecipientAddressed localRecips recipient = do
+        recipientHash <- hashGrantRecip recipient
+        fromMaybeE (verify recipientHash) "Recipient not addressed"
+        where
+        verify (GrantRecipPerson p) = do
+            routes <- lookup p $ recipPeople localRecips
+            guard $ routePerson routes
+
+    verifyRemoteAddressed remoteRecips u =
+        fromMaybeE (verify u) "Given remote entity not addressed"
+        where
+        verify (ObjURI h lu) = do
+            lus <- lookup h remoteRecips
+            guard $ lu `elem` lus
+
     insertCollab resource recipient grantID = do
         collabID <- insert Collab
         case resource of
-            GrantResourceRepo (Entity repoID _) ->
+            Left local ->
-                insert_ $ CollabTopicLocalRepo collabID repoID
+                case local of
-            GrantResourceDeck (Entity deckID _) ->
+                    GrantResourceRepo (Entity repoID _) ->
-                insert_ $ CollabTopicLocalDeck collabID deckID
+                        insert_ $ CollabTopicLocalRepo collabID repoID
-            GrantResourceLoom (Entity loomID _) ->
+                    GrantResourceDeck (Entity deckID _) ->
-                insert_ $ CollabTopicLocalLoom collabID loomID
+                        insert_ $ CollabTopicLocalDeck collabID deckID
+                    GrantResourceLoom (Entity loomID _) ->
+                        insert_ $ CollabTopicLocalLoom collabID loomID
+            Right (remoteID, _, _) ->
+                insert_ $ CollabTopicRemote collabID remoteID Nothing
         insert_ $ CollabSenderLocal collabID grantID
         case recipient of
             Left (GrantRecipPerson (Entity personID _)) ->
                 insert_ $ CollabRecipLocal collabID personID
-            Right remoteActorID ->
+            Right (remoteActorID, _) ->
                 insert_ $ CollabRecipRemote collabID remoteActorID
 
     hashGrantResource (GrantResourceRepo k) =

src/Vervis/Access.hs

@@ -64,6 +64,7 @@ module Vervis.Access
     , checkProjectAccess
     , GrantResourceBy (..)
     , verifyCapability
+    , verifyCapabilityRemote
     )
 where
 
@@ -313,3 +314,66 @@ verifyCapability capability personID resource = do
     -- Since there are currently no roles, and grants allow only the "Admin"
     -- role that supports every operation, we don't need to check role access
     return ()
+
+verifyCapabilityRemote
+    :: Either (LocalActorBy KeyHashid, OutboxItemId) FedURI
+    -> PersonId
+    -> RemoteObjectId
+    -> ExceptT Text (ReaderT SqlBackend Handler) ()
+verifyCapabilityRemote capability personID resourceID = do
+    -- Find the activity itself by URI in the DB
+    grant <- do
+        mact <- getActivity capability
+        fromMaybeE mact "Capability activity not known to me"
+
+    -- Find the Collab record for that activity
+    cid <-
+        case grant of
+            Left (_actor, obiid) -> do
+                mcsl <- lift $ getValBy $ UniqueCollabSenderLocalActivity obiid
+                collabSenderLocalCollab <$>
+                    fromMaybeE mcsl "Capability is a local activity but no matching capability"
+            Right ractid -> do
+                mcsr <- lift $ getValBy $ UniqueCollabSenderRemoteActivity ractid
+                collabSenderRemoteCollab <$>
+                    fromMaybeE mcsr "Capability is a known remote activity but no matching capability"
+
+    -- Find the recipient of that Collab
+    recipID <- do
+        mcrl <- lift $ getValBy $ UniqueCollabRecipLocal cid
+        crl <- fromMaybeE mcrl "No local recip for capability"
+        mcrr <- lift $ getBy $ UniqueCollabRecipRemote cid
+        for_ mcrr $ \ _ -> error "Both local & remote recip for capability!"
+        return $ collabRecipLocalPerson crl
+
+    -- Verify the recipient is the expected one
+    unless (recipID == personID) $
+        throwE "Collab recipient is some other Person"
+
+    -- Verify the topic isn't local
+    maybeRepo <- lift $ fmap (const ()) <$> getValBy (UniqueCollabTopicLocalRepo cid)
+    maybeDeck <- lift $ fmap (const ()) <$> getValBy (UniqueCollabTopicLocalDeck cid)
+    maybeLoom <- lift $ fmap (const ()) <$> getValBy (UniqueCollabTopicLocalLoom cid)
+    case length $ catMaybes [maybeRepo, maybeDeck, maybeLoom] of
+        0 -> return ()
+        1 -> throwE "Collab is for some other, local topic"
+        _ -> error "Collab with multiple topics"
+
+    -- Find the remote topic, on which this Collab gives access
+    topicID <- do
+        maybeRemote <- lift $ getValBy $ UniqueCollabTopicRemote cid
+        case maybeRemote of
+            Nothing -> error "Collab without topic"
+            Just remote -> return $ collabTopicRemoteTopic remote
+
+    -- Verify the topic matches the resource specified
+    unless (topicID == resourceID) $
+        throwE "Capability topic is some other remote resource"
+
+    -- Verify that the resource has accepted the grant, making it valid
+    maybeAccept <- lift $ getBy $ UniqueCollabTopicAcceptCollab cid
+    _ <- fromMaybeE maybeAccept "Collab not approved by the resource"
+
+    -- Since there are currently no roles, and grants allow only the "Admin"
+    -- role that supports every operation, we don't need to check role access
+    return ()

src/Web/ActivityPub.hs

@@ -42,6 +42,7 @@ module Web.ActivityPub
     , CollectionPageType (..)
     , CollectionPage (..)
     , Recipient (..)
+    , Resource (..)
 
       -- * Content objects
     , Note (..)
@@ -99,6 +100,7 @@ module Web.ActivityPub
     , fetchAPID
     , fetchAPID'
     , fetchRecipient
+    , fetchResource
     , keyListedByActor
     , fetchUnknownKey
     , fetchKnownPersonalKey
@@ -622,6 +624,19 @@ instance ActivityPub Recipient where
     toSeries h (RecipientActor a)      = toSeries h a
     toSeries h (RecipientCollection c) = toSeries h c
 
+data Resource u = ResourceActor (Actor u) | ResourceChild LocalURI LocalURI
+
+instance ActivityPub Resource where
+    jsonldContext _ = [as2Context, secContext, forgeContext]
+    parseObject o =
+        second ResourceActor <$> parseObject o <|> do
+            ObjURI h luId <- o .: "id" <|> o .: "@id"
+            (h,) . ResourceChild luId <$> withAuthorityO h (o .: "managedBy")
+    toSeries h (ResourceActor a) = toSeries h a
+    toSeries h (ResourceChild luId luManager)
+        =  "id"        .= ObjURI h luId
+        <> "managedBy" .= ObjURI h luManager
+
 data Audience u = Audience
     { audienceTo        :: [ObjURI u]
     , audienceBto       :: [ObjURI u]
@@ -1901,6 +1916,12 @@ fetchRecipient m = fetchAPID' m getId
     getId (RecipientActor a)      = actorId $ actorLocal a
     getId (RecipientCollection c) = collectionId c
 
+fetchResource :: (MonadIO m, UriMode u) => Manager -> Authority u -> LocalURI -> m (Either (Maybe APGetError) (Resource u))
+fetchResource m = fetchAPID' m getId
+    where
+    getId (ResourceActor a)      = actorId $ actorLocal a
+    getId (ResourceChild luId _) = luId
+
 fetchAPID :: (MonadIO m, UriMode u, ActivityPub a) => Manager -> (a u -> LocalURI) -> Authority u -> LocalURI -> m (Either String (a u))
 fetchAPID m getId h lu = first showError <$> fetchAPID' m getId h lu
     where

th/models

@@ -620,9 +620,6 @@ CollabTopicAccept
     UniqueCollabTopicAcceptCollab collab
     UniqueCollabTopicAcceptAccept accept
 
--- Do we need this for S2S? Or is this just for the Client, to decide which
--- Grant URI to use as the 'capability'? If latter, look into removing this
--- table...
 CollabTopicRemote
     collab CollabId
     topic  RemoteObjectId