diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index a10ea6b..922f968 100644 --- a/src/Vervis/API.hs +++ b/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, _, _) -> - insert_ $ CollabTopicRemote collabID remoteID Nothing + Right (remoteID, actorID, _) -> + 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 diff --git a/src/Vervis/Access.hs b/src/Vervis/Access.hs index 521b73c..d036fd1 100644 --- a/src/Vervis/Access.hs +++ b/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.Sql (SqlBackend) -import Database.Persist.Types (Entity (..)) +import Database.Persist +import Database.Persist.Sql 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 diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index 06990b9..0e04e06 100644 --- a/src/Vervis/ActivityPub.hs +++ b/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 diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 84acf3d..76b9344 100644 --- a/src/Vervis/Handler/Person.hs +++ b/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 {- diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 59c8a60..303b3b8 100644 --- a/src/Vervis/Migration.hs +++ b/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 diff --git a/src/Vervis/Recipient.hs b/src/Vervis/Recipient.hs index e0fca2a..983e8b9 100644 --- a/src/Vervis/Recipient.hs +++ b/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)] diff --git a/th/models b/th/models index 497de7c..8bccde0 100644 --- a/th/models +++ b/th/models @@ -623,6 +623,7 @@ CollabTopicAccept CollabTopicRemote collab CollabId topic RemoteObjectId + actor RemoteActorId role LocalURI Maybe UniqueCollabTopicRemote collab