C2S: Implement acceptC, allowing people to accept Grants given to them

src/Vervis/API.hs

@@ -17,7 +17,8 @@
 {-# LANGUAGE DeriveGeneric #-}
 
 module Vervis.API
-    ( addBundleC
+    ( acceptC
+    , addBundleC
     , applyC
     , noteC
     , createNoteC
@@ -135,6 +136,318 @@ import Vervis.Query
 import Vervis.Ticket
 import Vervis.WorkItem
 
+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
+
+verifyRemoteAddressed
+    :: Monad m => [(Host, NonEmpty LocalURI)] -> FedURI -> ExceptT Text m ()
+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
+
+acceptC
+    :: Entity Person
+    -> Actor
+    -> Maybe TextHtml
+    -> Audience URIMode
+    -> Accept URIMode
+    -> ExceptT Text Handler OutboxItemId
+acceptC (Entity pidUser personUser) senderActor summary audience accept = do
+
+    -- Check input
+    acceptee <- parseAccept accept
+    ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
+        mrecips <- parseAudience audience
+        recips <- fromMaybeE mrecips "Accept with no recipients"
+        checkFederation $ paudRemoteActors recips
+        return recips
+
+    now <- liftIO getCurrentTime
+    senderHash <- encodeKeyHashid pidUser
+
+    (obiidAccept, deliverHttpAccept, deliverHttpTopicAccept) <- runDBExcept $ do
+
+        -- Find a Collab record for the accepted activity
+        accepteeDB <- do
+            a <- getActivity acceptee
+            fromMaybeE a "Can't find acceptee in DB"
+        (collabID, collabSender) <-
+            case accepteeDB of
+                Left (actor, itemID) -> do
+                    maybeSender <-
+                        lift $ getValBy $ UniqueCollabSenderLocalActivity itemID
+                    (,Left actor) . collabSenderLocalCollab <$>
+                        fromMaybeE maybeSender "No Collab for this local activity"
+                Right remoteActivityID -> do
+                    maybeSender <-
+                        lift $ getValBy $ UniqueCollabSenderRemoteActivity remoteActivityID
+                    CollabSenderRemote collab actorID _ <-
+                        fromMaybeE maybeSender "No Collab for this remote activity"
+                    actor <- lift $ getJust actorID
+                    lift $
+                        (collab,) . Right . (,remoteActorFollowers actor) <$>
+                            getRemoteActorURI' actor
+
+        -- Verify that Accept sender is the Collab recipient
+        recip <-
+            lift $
+            requireEitherAlt
+                (getBy $ UniqueCollabRecipLocal collabID)
+                (getBy $ UniqueCollabRecipRemote collabID)
+                "Found Collab with no recip"
+                "Found Collab with multiple recips"
+        recipID <-
+            case recip of
+                Left (Entity crlid crl)
+                    | collabRecipLocalPerson crl == pidUser -> return crlid
+                _ -> throwE "Accepting a Collab whose recipient is someone else"
+
+        -- Verify the Collab isn't already validated
+        maybeValid <- lift $ getBy $ UniqueCollabTopicAcceptCollab collabID
+        verifyNothingE maybeValid "Collab already Accepted by the topic"
+
+        -- Verify that Grant sender and resource are addressed by the Accept
+        topicActor <- lift $ getCollabTopic collabID
+        bitraverse_
+            (verifyResourceAddressed localRecips)
+            (verifyRemoteAddressed remoteRecips)
+            topicActor
+        bitraverse_
+            (verifySenderAddressed localRecips)
+            (verifyRemoteAddressed remoteRecips . fst)
+            collabSender
+
+        -- Record the Accept on the Collab
+        acceptID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
+        maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID acceptID
+        unless (isNothing maybeAccept) $ do
+            lift $ delete acceptID
+            throwE "This Collab already has an Accept by recip"
+
+        -- Insert the Accept activity to author's outbox
+        docAccept <- lift $ insertAcceptToOutbox senderHash now blinded acceptID
+
+        -- Deliver the Accept activity to local recipients, and schedule
+        -- delivery for unavailable remote recipients
+        remoteRecipsHttpAccept <- do
+            topicHash <- bitraverse hashGrantResource pure topicActor
+            let sieveActors = catMaybes
+                    [ case topicHash of
+                        Left (GrantResourceRepo r) -> Just $ LocalActorRepo r
+                        Left (GrantResourceDeck d) -> Just $ LocalActorDeck d
+                        Left (GrantResourceLoom l) -> Just $ LocalActorLoom l
+                        Right _                    -> Nothing
+                    , case collabSender of
+                        Left actor -> Just actor
+                        Right _    -> Nothing
+                    ]
+                sieveStages = catMaybes
+                    [ Just $ LocalStagePersonFollowers senderHash
+                    , case topicHash of
+                        Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r
+                        Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d
+                        Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l
+                        Right _                    -> Nothing
+                    , case collabSender of
+                        Left actor -> localActorFollowers actor
+                        Right _    -> Nothing
+                    ]
+                sieve = makeRecipientSet sieveActors sieveStages
+            moreRemoteRecips <-
+                lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor personUser) acceptID $
+                    localRecipSieve sieve False localRecips
+            checkFederation moreRemoteRecips
+            lift $ deliverRemoteDB'' fwdHosts acceptID remoteRecips moreRemoteRecips
+
+        -- If resource is local, verify it has received the Accept
+        topicActorLocal <-
+            case topicActor of
+                Left resource ->
+                    Just <$> getGrantResource resource "getGrantResource"
+                Right _ -> pure Nothing
+        for_ topicActorLocal $ \ resource -> do
+            let resourceActorID = grantResourceActor resource
+            verifyActorHasItem resourceActorID acceptID "Local topic didn't receive the Accept"
+
+        -- If Collab sender is local, verify it has received the Accept
+        case collabSender of
+            Left actorHash -> do
+                actor <- unhashLocalActorE actorHash "Can't unhash collab sender"
+                actorID <- do
+                    maybeID <- lift $ getLocalActorID actor
+                    fromMaybeE maybeID "Suddenly can't find collab sender in DB"
+                verifyActorHasItem actorID acceptID "Local Collab sender didn't receive the Accept"
+            Right _ -> pure ()
+
+        -- If resource is local, approve the Collab and deliver an Accept
+        -- We'll refer to the resource's Accept as the "Enable" activity
+        deliverHttpEnable <- for topicActorLocal $ \ resource -> do
+
+            -- Approve the Collab in the DB
+            resourceOutbox <-
+                lift $ actorOutbox <$> getJust (grantResourceActor resource)
+            enableID <- lift $ insertEmptyOutboxItem resourceOutbox now
+            lift $ insert_ $ CollabTopicAccept collabID enableID
+
+            -- Insert the Enable to resource's outbox
+            (docEnable, localRecipsEnable, remoteRecipsEnable, fwdHostsEnable) <-
+                lift $ insertEnableToOutbox senderHash collabSender resource enableID
+
+            -- Deliver the Enable to local recipients, and schedule delivery
+            -- for unavailable remote recipients
+            remoteRecipsHttpEnable <- do
+                moreRemoteRecips <- do
+                    resourceHash <- hashGrantResource $ bmap entityKey resource
+                    lift $ deliverLocal' True (grantResourceLocalActor resourceHash) (grantResourceActor resource) enableID localRecipsEnable
+                checkFederation moreRemoteRecips
+                lift $ deliverRemoteDB'' fwdHostsEnable enableID remoteRecipsEnable moreRemoteRecips
+
+            -- Return instructions for HTTP delivery to remote recipients
+            return $ deliverRemoteHttp' fwdHostsEnable enableID docEnable remoteRecipsHttpEnable
+
+        -- Return instructions for HTTP delivery to remote recipients
+        return
+            ( acceptID
+            , deliverRemoteHttp' fwdHosts acceptID docAccept remoteRecipsHttpAccept
+            , deliverHttpEnable
+            )
+
+    -- Launch asynchronous HTTP delivery of the Grant activity
+    lift $ do
+        forkWorker "acceptC: async HTTP Accept delivery" deliverHttpAccept
+        for_ deliverHttpTopicAccept $
+            forkWorker "acceptC: async HTTP Topic Accept delivery"
+
+    return obiidAccept
+
+    where
+
+    parseAccept (Accept object mresult) = do
+        verifyNothingE mresult "Accept must not contain 'result'"
+        parseActivityURI "Accept object" object
+
+    getRemoteActorURI = getRemoteActorURI' <=< getJust
+
+    getRemoteActorURI' actor = do
+        object <- getJust $ remoteActorIdent actor
+        inztance <- getJust $ remoteObjectInstance object
+        return $
+            ObjURI
+                (instanceHost inztance)
+                (remoteObjectIdent object)
+
+    getCollabTopic collabID = do
+        maybeLocal <- do
+            maybeRepo <- getValBy $ UniqueCollabTopicLocalRepo collabID
+            maybeDeck <- getValBy $ UniqueCollabTopicLocalDeck collabID
+            maybeLoom <- getValBy $ UniqueCollabTopicLocalLoom collabID
+            return $
+                case (maybeRepo, maybeDeck, maybeLoom) of
+                    (Nothing, Nothing, Nothing) -> Nothing
+                    (Just r, Nothing, Nothing) ->
+                        Just $ GrantResourceRepo $ collabTopicLocalRepoRepo r
+                    (Nothing, Just d, Nothing) ->
+                        Just $ GrantResourceDeck $ collabTopicLocalDeckDeck d
+                    (Nothing, Nothing, Just l) ->
+                        Just $ GrantResourceLoom $ collabTopicLocalLoomLoom l
+                    _ -> error "Found Collab with multiple local topics"
+        maybeRemote <- do
+            mr <- getValBy $ UniqueCollabTopicRemote collabID
+            traverse (getRemoteActorURI . collabTopicRemoteActor) mr
+        requireEitherM
+            maybeLocal
+            maybeRemote
+            "Found Collab without topic"
+            "Found Collab with both local and remote topics"
+
+    verifySenderAddressed localRecips actor = do
+        unless (actorIsAddressed localRecips actor) $
+            throwE "Collab sender not addressed"
+
+    insertAcceptToOutbox senderHash now blinded acceptID = do
+        encodeRouteLocal <- getEncodeRouteLocal
+        hLocal <- asksSite siteInstanceHost
+        acceptHash <- encodeKeyHashid acceptID
+        let doc = Doc hLocal Activity
+                { activityId         =
+                    Just $ encodeRouteLocal $
+                        PersonOutboxItemR senderHash acceptHash
+                , activityActor      = encodeRouteLocal $ PersonR senderHash
+                , activityCapability = Nothing
+                , activitySummary    = summary
+                , activityAudience   = blinded
+                , activityFulfills   = []
+                , activitySpecific   = AcceptActivity 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
+
+    grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f
+    grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r
+    grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d
+    grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l
+
+    insertEnableToOutbox recipHash sender topic enableID = do
+        encodeRouteLocal <- getEncodeRouteLocal
+        encodeRouteHome <- getEncodeRouteHome
+        hLocal <- asksSite siteInstanceHost
+
+        topicHash <-
+            grantResourceLocalActor <$> hashGrantResource (bmap entityKey topic)
+        enableHash <- encodeKeyHashid enableID
+
+        let audSender =
+                case sender of
+                    Left actor -> AudLocal [actor] (maybeToList $ localActorFollowers actor)
+                    Right (ObjURI h lu, followers) ->
+                        AudRemote h [lu] (maybeToList followers)
+            audRecip =
+                AudLocal [LocalActorPerson recipHash] [LocalStagePersonFollowers recipHash]
+            audTopic =
+                AudLocal [] (maybeToList $ localActorFollowers topicHash)
+
+            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience [audSender, audRecip, audTopic]
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            doc = Doc hLocal Activity
+                { activityId         = Just $ encodeRouteLocal $ outboxItemRoute topicHash enableHash
+                , activityActor      = encodeRouteLocal $ renderLocalActor topicHash
+                , activityCapability = Nothing
+                , activitySummary    = Nothing
+                , activityAudience   = Audience recips [] [] [] [] []
+                , activityFulfills   = []
+                , activitySpecific   = AcceptActivity Accept
+                    { acceptObject   = acceptObject accept
+                    , acceptResult   = Nothing
+                    }
+                }
+
+        update enableID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+        return (doc, recipientSet, remoteActors, fwdHosts)
+
 addBundleC
     :: Entity Person
     -> Maybe TextHtml
@@ -1641,22 +1954,6 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
     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
 
@@ -1760,29 +2057,8 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
                                         Right (Right Nothing) -> Left ResultNotActor
                                         Right (Right (Just actor)) -> Right $ Right (roid, luManager, actor)
 
-    getGrantResource (GrantResourceRepo k) e =
-        GrantResourceRepo <$> getEntityE k e
-    getGrantResource (GrantResourceDeck k) e =
-        GrantResourceDeck <$> getEntityE k e
-    getGrantResource (GrantResourceLoom k) e =
-        GrantResourceLoom <$> getEntityE k e
-
     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"
@@ -1809,8 +2085,8 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
                         insert_ $ CollabTopicLocalDeck collabID deckID
                     GrantResourceLoom (Entity loomID _) ->
                         insert_ $ CollabTopicLocalLoom collabID loomID
-            Right (remoteID, _, _) ->
+            Right (remoteID, actorID, _) ->
-                insert_ $ CollabTopicRemote collabID remoteID Nothing
+                insert_ $ CollabTopicRemote collabID remoteID actorID Nothing
         insert_ $ CollabSenderLocal collabID grantID
         case recipient of
             Left (GrantRecipPerson (Entity personID _)) ->
@@ -1818,13 +2094,6 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
             Right (remoteActorID, _) ->
                 insert_ $ CollabRecipRemote collabID remoteActorID
 
-    hashGrantResource (GrantResourceRepo k) =
-        GrantResourceRepo <$> encodeKeyHashid k
-    hashGrantResource (GrantResourceDeck k) =
-        GrantResourceDeck <$> encodeKeyHashid k
-    hashGrantResource (GrantResourceLoom k) =
-        GrantResourceLoom <$> encodeKeyHashid k
-
     hashGrantRecip (GrantRecipPerson k) =
         GrantRecipPerson <$> encodeKeyHashid k
 
@@ -1846,11 +2115,6 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
         update grantID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
         return doc
 
-    verifyActorHasItem actorID itemID errorMessage = do
-        inboxID <- lift $ actorInbox <$> getJust actorID
-        maybeItem <- lift $ getBy $ UniqueInboxItemLocal inboxID itemID
-        void $ fromMaybeE maybeItem errorMessage
-
 offerTicketC
     :: Entity Person
     -> Maybe TextHtml

src/Vervis/Access.hs

@@ -62,7 +62,14 @@ module Vervis.Access
     , checkRepoAccess'
     , checkRepoAccess
     , checkProjectAccess
+
     , GrantResourceBy (..)
+    , unhashGrantResourcePure
+    , unhashGrantResource
+    , unhashGrantResourceE
+    , hashGrantResource
+    , getGrantResource
+
     , verifyCapability
     , verifyCapabilityRemote
     )
@@ -79,9 +86,8 @@ import Data.Barbie
 import Data.Foldable
 import Data.Maybe
 import Data.Text (Text)
-import Database.Persist.Class
+import Database.Persist
-import Database.Persist.Sql (SqlBackend)
+import Database.Persist.Sql
-import Database.Persist.Types (Entity (..))
 import GHC.Generics
 
 import qualified Database.Esqueleto as E
@@ -249,6 +255,36 @@ data GrantResourceBy f
 
 deriving instance AllBF Eq f GrantResourceBy => Eq (GrantResourceBy f)
 
+unhashGrantResourcePure ctx = f
+    where
+    f (GrantResourceRepo r) =
+        GrantResourceRepo <$> decodeKeyHashidPure ctx r
+    f (GrantResourceDeck d) =
+        GrantResourceDeck <$> decodeKeyHashidPure ctx d
+    f (GrantResourceLoom l) =
+        GrantResourceLoom <$> decodeKeyHashidPure ctx l
+
+unhashGrantResource resource = do
+    ctx <- asksSite siteHashidsContext
+    return $ unhashGrantResourcePure ctx resource
+
+unhashGrantResourceE resource e =
+    ExceptT $ maybe (Left e) Right <$> unhashGrantResource resource
+
+hashGrantResource (GrantResourceRepo k) =
+    GrantResourceRepo <$> encodeKeyHashid k
+hashGrantResource (GrantResourceDeck k) =
+    GrantResourceDeck <$> encodeKeyHashid k
+hashGrantResource (GrantResourceLoom k) =
+    GrantResourceLoom <$> encodeKeyHashid k
+
+getGrantResource (GrantResourceRepo k) e =
+    GrantResourceRepo <$> getEntityE k e
+getGrantResource (GrantResourceDeck k) e =
+    GrantResourceDeck <$> getEntityE k e
+getGrantResource (GrantResourceLoom k) e =
+    GrantResourceLoom <$> getEntityE k e
+
 verifyCapability
     :: Either (LocalActorBy KeyHashid, OutboxItemId) FedURI
     -> PersonId

src/Vervis/ActivityPub.hs

@@ -36,6 +36,8 @@ module Vervis.ActivityPub
     --, getOutboxActorEntity
     --, actorEntityPath
     , outboxItemRoute
+
+    , verifyActorHasItem
     )
 where
 
@@ -389,3 +391,8 @@ outboxItemRoute (LocalActorGroup g) = GroupOutboxItemR g
 outboxItemRoute (LocalActorRepo r) = RepoOutboxItemR r
 outboxItemRoute (LocalActorDeck d) = DeckOutboxItemR d
 outboxItemRoute (LocalActorLoom l) = LoomOutboxItemR l
+
+verifyActorHasItem actorID itemID errorMessage = do
+    inboxID <- lift $ actorInbox <$> getJust actorID
+    maybeItem <- lift $ getBy $ UniqueInboxItemLocal inboxID itemID
+    void $ fromMaybeE maybeItem errorMessage

src/Vervis/Handler/Person.hs

@@ -164,6 +164,8 @@ postPersonOutboxR personHash = do
 
     handle eperson actorDB (AP.Activity _mid _actorAP mcap summary audience _fulfills specific) =
         case specific of
+            AP.AcceptActivity accept ->
+                acceptC eperson actorDB summary audience accept
             AP.CreateActivity (AP.Create obj mtarget) ->
                 case obj of
                     {-

src/Vervis/Migration.hs

@@ -2432,6 +2432,8 @@ changes hLocal ctx =
                         let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
                         insert $ OutboxItem426 (actor426Outbox actor) doc defaultTime
             insert_ $ CollabTopicAccept426 collabID itemID
+      -- 427
+    , addFieldRefRequiredEmpty "CollabTopicRemote" "actor" "RemoteActor"
     ]
 
 migrateDB

src/Vervis/Recipient.hs

@@ -31,6 +31,9 @@ module Vervis.Recipient
     , LocalStage
     , renderLocalStage
 
+      -- * Related actors and stages
+    , localActorFollowers
+
       -- * Converting between KeyHashid, Key, Identity and Entity
     , hashLocalActorPure
     , getHashLocalActor
@@ -54,6 +57,9 @@ module Vervis.Recipient
     , unhashLocalStageE
     , unhashLocalStage404
 
+      -- * Getting from DB
+    , getLocalActorID
+
       -- * Local recipient set
       -- ** Types
     , TicketRoutes (..)
@@ -69,9 +75,11 @@ module Vervis.Recipient
       -- ** Creating
     , makeRecipientSet
     , actorRecips
-      -- * Filtering
+      -- ** Filtering
     , localRecipSieve
     , localRecipSieve'
+      -- ** Querying
+    , actorIsAddressed
 
       -- * Parsing audience from a received activity
     , ParsedAudience (..)
@@ -88,11 +96,11 @@ import Control.Applicative
 import Control.Monad
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Reader
 import Data.Barbie
 import Data.Bifunctor
 import Data.Either
 import Data.Foldable
-import Data.Functor.Classes
 import Data.List ((\\))
 import Data.List.NonEmpty (NonEmpty, nonEmpty)
 import Data.Maybe
@@ -100,6 +108,8 @@ import Data.Semigroup
 import Data.Text (Text)
 import Data.These
 import Data.Traversable
+import Database.Persist
+import Database.Persist.Sql
 import GHC.Generics
 import Web.Hashids
 import Yesod.Core
@@ -232,6 +242,13 @@ parseLocalRecipient :: Route App -> Maybe (Either LocalActor LocalStage)
 parseLocalRecipient r =
     Left <$> parseLocalActor r <|> Right <$> parseLocalStage r
 
+localActorFollowers :: LocalActorBy f -> Maybe (LocalStageBy f)
+localActorFollowers (LocalActorPerson p) = Just $ LocalStagePersonFollowers p
+localActorFollowers (LocalActorGroup _) = Nothing
+localActorFollowers (LocalActorRepo r) = Just $ LocalStageRepoFollowers r
+localActorFollowers (LocalActorDeck d) = Just $ LocalStageDeckFollowers d
+localActorFollowers (LocalActorLoom l) = Just $ LocalStageLoomFollowers l
+
 -------------------------------------------------------------------------------
 -- Converting between KeyHashid, Key, Identity and Entity
 -------------------------------------------------------------------------------
@@ -392,6 +409,14 @@ unhashLocalStage404
     -> m (LocalStageBy Key)
 unhashLocalStage404 stage = maybe notFound return =<< unhashLocalStage stage
 
+getLocalActorID
+    :: MonadIO m => LocalActorBy Key -> ReaderT SqlBackend m (Maybe ActorId)
+getLocalActorID (LocalActorPerson p) = fmap personActor <$> get p
+getLocalActorID (LocalActorGroup g)  = fmap groupActor <$> get g
+getLocalActorID (LocalActorRepo r)   = fmap repoActor <$> get r
+getLocalActorID (LocalActorDeck d)   = fmap deckActor <$> get d
+getLocalActorID (LocalActorLoom l)   = fmap loomActor <$> get l
+
 -------------------------------------------------------------------------------
 -- Intermediate recipient types
 --
@@ -790,6 +815,25 @@ localRecipSieve' sieve allowPeople allowOthers routes = RecipientRoutes
                     then Nothing
                     else Just (lkhid, LoomFamilyRoutes loom cloths)
 
+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
+
 data ParsedAudience u = ParsedAudience
     { paudLocalRecips  :: RecipientRoutes
     , paudRemoteActors :: [(Authority u, NonEmpty LocalURI)]

th/models

@@ -623,6 +623,7 @@ CollabTopicAccept
 CollabTopicRemote
     collab CollabId
     topic  RemoteObjectId
+    actor  RemoteActorId
     role   LocalURI       Maybe
 
     UniqueCollabTopicRemote collab