From 9e6eb9bec6fad5b097ef608f5a9cbb84a0c753ed Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Mon, 29 Aug 2022 21:41:13 +0000 Subject: [PATCH] Support delivery to Group followers collection --- src/Vervis/API.hs | 13 +++++--- src/Vervis/Delivery.hs | 6 ++-- src/Vervis/Recipient.hs | 66 ++++++++++++++++++----------------------- 3 files changed, 41 insertions(+), 44 deletions(-) diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 922f968..a0dc4ba 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -69,7 +69,6 @@ import GHC.Generics import Network.HTTP.Client import Network.HTTP.Types.Header import Network.HTTP.Types.URI -import Network.TLS hiding (SHA256) import Text.Blaze.Html (preEscapedToHtml) import Text.Blaze.Html.Renderer.Text import UnliftIO.Exception (try) @@ -266,7 +265,7 @@ acceptC (Entity pidUser personUser) senderActor summary audience accept = do Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l Right _ -> Nothing , case collabSender of - Left actor -> localActorFollowers actor + Left actor -> Just $ localActorFollowers actor Right _ -> Nothing ] sieve = makeRecipientSet sieveActors sieveStages @@ -420,13 +419,13 @@ acceptC (Entity pidUser personUser) senderActor summary audience accept = do let audSender = case sender of - Left actor -> AudLocal [actor] (maybeToList $ localActorFollowers actor) + Left actor -> AudLocal [actor] [localActorFollowers actor] Right (ObjURI h lu, followers) -> AudRemote h [lu] (maybeToList followers) audRecip = AudLocal [LocalActorPerson recipHash] [LocalStagePersonFollowers recipHash] audTopic = - AudLocal [] (maybeToList $ localActorFollowers topicHash) + AudLocal [] [localActorFollowers topicHash] (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = collectAudience [audSender, audRecip, audTopic] @@ -1602,6 +1601,7 @@ createTicketTrackerC (Entity pidUser personUser) senderActor summary audience tr data Followee = FolloweePerson (KeyHashid Person) + | FolloweeGroup (KeyHashid Group) | FolloweeRepo (KeyHashid Repo) | FolloweeDeck (KeyHashid Deck) | FolloweeLoom (KeyHashid Loom) @@ -1670,6 +1670,7 @@ followC (Entity pidSender personSender) summary audience follow@(AP.Follow uObje return obiidFollow where parseFollowee (PersonR p) = Just $ FolloweePerson p + parseFollowee (GroupR g) = Just $ FolloweeGroup g parseFollowee (RepoR r) = Just $ FolloweeRepo r parseFollowee (DeckR d) = Just $ FolloweeDeck d parseFollowee (LoomR l) = Just $ FolloweeLoom l @@ -1678,6 +1679,7 @@ followC (Entity pidSender personSender) summary audience follow@(AP.Follow uObje parseFollowee _ = Nothing followeeActor (FolloweePerson p) = LocalActorPerson p + followeeActor (FolloweeGroup g) = LocalActorGroup g followeeActor (FolloweeRepo r) = LocalActorRepo r followeeActor (FolloweeDeck d) = LocalActorDeck d followeeActor (FolloweeLoom l) = LocalActorLoom l @@ -1687,6 +1689,9 @@ followC (Entity pidSender personSender) summary audience follow@(AP.Follow uObje getFollowee (FolloweePerson personHash) = do personID <- decodeKeyHashidE personHash "Follow object: No such person hash" (,Nothing,True) . personActor <$> getE personID "Follow object: No such person in DB" + getFollowee (FolloweeGroup groupHash) = do + groupID <- decodeKeyHashidE groupHash "Follow object: No such group hash" + (,Nothing,False) . groupActor <$> getE groupID "Follow object: No such group in DB" getFollowee (FolloweeRepo repoHash) = do repoID <- decodeKeyHashidE repoHash "Follow object: No such repo hash" (,Nothing,False) . repoActor <$> getE repoID "Follow object: No such repo in DB" diff --git a/src/Vervis/Delivery.hs b/src/Vervis/Delivery.hs index b787bbc..5f86493 100644 --- a/src/Vervis/Delivery.hs +++ b/src/Vervis/Delivery.hs @@ -525,9 +525,6 @@ insertActivityToLocalInboxes -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)] insertActivityToLocalInboxes makeInboxItem requireOwner mauthor maidAuthor recips = do - -- Predicate for filtering addressed stages - --allowStage <- getAllowStage - -- Unhash actor and work item hashids people <- unhashKeys $ recipPeople recips groups <- unhashKeys $ recipGroups recips @@ -577,6 +574,8 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor maidAuthor recip -- Grab actor actors whose followers are going to be delivered to let personIDsForFollowers = [ key | (key, routes) <- peopleForStages, routePersonFollowers routes ] + groupIDsForFollowers = + [ key | (key, routes) <- groupsForStages, routeGroupFollowers routes ] repoIDsForFollowers = [ key | (key, routes) <- reposForStages, routeRepoFollowers routes ] deckIDsForFollowers = @@ -617,6 +616,7 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor maidAuthor recip followerSetIDs <- do actorIDs <- concat <$> sequenceA [ selectActorIDs personActor personIDsForFollowers + , selectActorIDs groupActor groupIDsForFollowers , selectActorIDs repoActor repoIDsForFollowers , selectActorIDs deckActor deckIDsForFollowers , selectActorIDs loomActor loomIDsForFollowers diff --git a/src/Vervis/Recipient.hs b/src/Vervis/Recipient.hs index 983e8b9..5e4eb83 100644 --- a/src/Vervis/Recipient.hs +++ b/src/Vervis/Recipient.hs @@ -195,6 +195,8 @@ renderLocalActor (LocalActorLoom lkhid) = LoomR lkhid data LocalStageBy f = LocalStagePersonFollowers (f Person) + | LocalStageGroupFollowers (f Group) + | LocalStageRepoFollowers (f Repo) | LocalStageDeckFollowers (f Deck) @@ -212,6 +214,8 @@ type LocalStage = LocalStageBy KeyHashid parseLocalStage :: Route App -> Maybe LocalStage parseLocalStage (PersonFollowersR pkhid) = Just $ LocalStagePersonFollowers pkhid +parseLocalStage (GroupFollowersR gkhid) = + Just $ LocalStageGroupFollowers gkhid parseLocalStage (RepoFollowersR rkhid) = Just $ LocalStageRepoFollowers rkhid parseLocalStage (DeckFollowersR dkhid) = @@ -227,6 +231,8 @@ parseLocalStage _ = Nothing renderLocalStage :: LocalStage -> Route App renderLocalStage (LocalStagePersonFollowers pkhid) = PersonFollowersR pkhid +renderLocalStage (LocalStageGroupFollowers gkhid) = + GroupFollowersR gkhid renderLocalStage (LocalStageRepoFollowers rkhid) = RepoFollowersR rkhid renderLocalStage (LocalStageDeckFollowers dkhid) = @@ -242,12 +248,12 @@ 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 +localActorFollowers :: LocalActorBy f -> LocalStageBy f +localActorFollowers (LocalActorPerson p) = LocalStagePersonFollowers p +localActorFollowers (LocalActorGroup g) = LocalStageGroupFollowers g +localActorFollowers (LocalActorRepo r) = LocalStageRepoFollowers r +localActorFollowers (LocalActorDeck d) = LocalStageDeckFollowers d +localActorFollowers (LocalActorLoom l) = LocalStageLoomFollowers l ------------------------------------------------------------------------------- -- Converting between KeyHashid, Key, Identity and Entity @@ -326,6 +332,8 @@ hashLocalStagePure ctx = f where f (LocalStagePersonFollowers p) = LocalStagePersonFollowers $ encodeKeyHashidPure ctx p + f (LocalStageGroupFollowers g) = + LocalStageGroupFollowers $ encodeKeyHashidPure ctx g f (LocalStageRepoFollowers r) = LocalStageRepoFollowers $ encodeKeyHashidPure ctx r f (LocalStageDeckFollowers d) = @@ -361,6 +369,8 @@ unhashLocalStagePure ctx = f where f (LocalStagePersonFollowers p) = LocalStagePersonFollowers <$> decodeKeyHashidPure ctx p + f (LocalStageGroupFollowers g) = + LocalStageGroupFollowers <$> decodeKeyHashidPure ctx g f (LocalStageRepoFollowers r) = LocalStageRepoFollowers <$> decodeKeyHashidPure ctx r f (LocalStageDeckFollowers d) = @@ -431,7 +441,7 @@ data LeafCloth = LeafClothFollowers deriving (Eq, Ord) data LeafPerson = LeafPerson | LeafPersonFollowers deriving (Eq, Ord) -data LeafGroup = LeafGroup deriving (Eq, Ord) +data LeafGroup = LeafGroup | LeafGroupFollowers deriving (Eq, Ord) data LeafRepo = LeafRepo | LeafRepoFollowers deriving (Eq, Ord) @@ -472,6 +482,8 @@ recipientFromActor (LocalActorLoom lkhid) = recipientFromStage :: LocalStage -> LocalRecipient recipientFromStage (LocalStagePersonFollowers pkhid) = RecipPerson pkhid LeafPersonFollowers +recipientFromStage (LocalStageGroupFollowers gkhid) = + RecipGroup gkhid LeafGroupFollowers recipientFromStage (LocalStageRepoFollowers rkhid) = RecipRepo rkhid LeafRepoFollowers recipientFromStage (LocalStageDeckFollowers dkhid) = @@ -509,7 +521,8 @@ data PersonRoutes = PersonRoutes deriving Eq data GroupRoutes = GroupRoutes - { routeGroup :: Bool + { routeGroup :: Bool + , routeGroupFollowers :: Bool } deriving Eq @@ -588,7 +601,7 @@ groupLocalRecipients = organize . partitionByActor { recipPeople = map (second $ foldr orLP $ PersonRoutes False False) $ groupByKeySort p , recipGroups = - map (second $ foldr orLG $ GroupRoutes False) $ groupByKeySort g + map (second $ foldr orLG $ GroupRoutes False False) $ groupByKeySort g , recipRepos = map (second $ foldr orLR $ RepoRoutes False False) $ groupByKeySort r , recipDecks = @@ -627,8 +640,9 @@ groupLocalRecipients = organize . partitionByActor orLP LeafPersonFollowers pr@(PersonRoutes _ _) = pr { routePersonFollowers = True } orLG :: LeafGroup -> GroupRoutes -> GroupRoutes - orLG _ gr@(GroupRoutes True) = gr - orLG LeafGroup gr@(GroupRoutes _) = gr { routeGroup = True } + orLG _ gr@(GroupRoutes True True) = gr + orLG LeafGroup gr@(GroupRoutes _ _) = gr { routeGroup = True } + orLG LeafGroupFollowers gr@(GroupRoutes _ _) = gr { routeGroupFollowers = True } orLR :: LeafRepo -> RepoRoutes -> RepoRoutes orLR _ rr@(RepoRoutes True True) = rr @@ -670,28 +684,6 @@ makeRecipientSet actors stages = groupLocalRecipients $ map recipientFromActor actors ++ map recipientFromStage stages -actorIsMember :: LocalActor -> RecipientRoutes -> Bool -actorIsMember (LocalActorPerson pkhid) routes = - case lookup pkhid $ recipPeople routes of - Just p -> routePerson p - Nothing -> False -actorIsMember (LocalActorGroup gkhid) routes = - case lookup gkhid $ recipGroups routes of - Just g -> routeGroup g - Nothing -> False -actorIsMember (LocalActorRepo rkhid) routes = - case lookup rkhid $ recipRepos routes of - Just r -> routeRepo r - Nothing -> False -actorIsMember (LocalActorDeck dkhid) routes = - case lookup dkhid $ recipDecks routes of - Just d -> routeDeck $ familyDeck d - Nothing -> False -actorIsMember (LocalActorLoom lkhid) routes = - case lookup lkhid $ recipLooms routes of - Just l -> routeLoom $ familyLoom l - Nothing -> False - actorRecips :: LocalActor -> RecipientRoutes actorRecips = groupLocalRecipients . (: []) . recipientFromActor @@ -748,11 +740,11 @@ localRecipSieve' sieve allowPeople allowOthers routes = RecipientRoutes applyGroup _ (This _) = Nothing applyGroup gkhid (That g) = if allowOthers && routeGroup g - then Just (gkhid, GroupRoutes True) + then Just (gkhid, GroupRoutes True False) else Nothing - applyGroup gkhid (These (GroupRoutes g') (GroupRoutes g)) = - let merged = GroupRoutes (g && (g' || allowOthers)) - in if merged == GroupRoutes False + applyGroup gkhid (These (GroupRoutes g' gf') (GroupRoutes g gf)) = + let merged = GroupRoutes (g && (g' || allowOthers)) (gf && gf') + in if merged == GroupRoutes False False then Nothing else Just (gkhid, merged)