From e0300ba0faa2af57807e3c4e60b819dcaa880f9d Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Wed, 19 Feb 2020 10:59:38 +0000 Subject: [PATCH] Write recipient filtering utility function --- src/Data/List/Local.hs | 21 +++++++++- src/Vervis/ActivityPub.hs | 18 +------- src/Vervis/ActivityPub/Recipient.hs | 65 +++++++++++++++++++++++++++++ vervis.cabal | 1 + 4 files changed, 88 insertions(+), 17 deletions(-) diff --git a/src/Data/List/Local.hs b/src/Data/List/Local.hs index 2a0ce92..e0f8c52 100644 --- a/src/Data/List/Local.hs +++ b/src/Data/List/Local.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019 by fr33domlover . + - Written in 2016, 2018, 2019, 2020 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -22,11 +22,16 @@ module Data.List.Local , groupMapBy , groupMapBy1 , lookupSorted + , sortAlign ) where +import Data.Bifunctor import Data.Function (on) import Data.List.NonEmpty (NonEmpty (..), (<|), toList) +import Data.These + +import qualified Data.List.Ordered as LO -- | Takes a list of pairs and groups them by consecutive ranges with equal -- first element. Returns a list of pairs, where each pair corresponds to one @@ -104,3 +109,17 @@ lookupSorted x ((y, z) : l) = LT -> lookupSorted x l EQ -> Just z GT -> Nothing + +sortAlign :: Ord a => [(a, b)] -> [(a, b)] -> [(a, These b b)] +sortAlign xs ys = orderedAlign (prepare xs) (prepare ys) + where + prepare = LO.nubSortOn' fst + + orderedAlign :: Ord a => [(a, b)] -> [(a, b)] -> [(a, These b b)] + orderedAlign [] ys = map (second That) ys + orderedAlign xs [] = map (second This) xs + orderedAlign xs@((u, w) : us) ys@((v, z) : vs) = + case compare u v of + LT -> (u, This w) : orderedAlign us ys + EQ -> (u, These w z) : orderedAlign us vs + GT -> (v, That z) : orderedAlign xs vs diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index bbeb0c6..102842e 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -715,23 +715,9 @@ deliverLocal , NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime) ) ] -deliverLocal shrAuthor ibidAuthor _fsidAuthor obiid = fmap (map $ second $ NE.map fromRR) . deliverLocal' True shrAuthor ibidAuthor obiid . map (uncurry clearCollections) +deliverLocal shrAuthor ibidAuthor _fsidAuthor obiid = fmap (map $ second $ NE.map fromRR) . deliverLocal' True shrAuthor ibidAuthor obiid . localRecipSieve sieve True where - clearCollections shr (LocalSharerRelatedSet s js rs) = - ( shr - , LocalSharerRelatedSet - (clearSharer shr s) - (map (second clearProject) js) - (map (second clearRepo) rs) - ) - where - clearSharer shr (LocalSharerDirectSet s f) = - let f' = if shr == shrAuthor then f else False - in LocalSharerDirectSet s f' - clearProject (LocalProjectRelatedSet (LocalProjectDirectSet j _t _f) _ts) = - LocalProjectRelatedSet (LocalProjectDirectSet j False False) [] - clearRepo (LocalRepoRelatedSet (LocalRepoDirectSet r _t _f)) = - LocalRepoRelatedSet $ LocalRepoDirectSet r False False + sieve = [(shrAuthor, LocalSharerRelatedSet (LocalSharerDirectSet False True) [] [])] fromRR (RemoteRecipient raid luA luI msince) = (raid, luA, luI, msince) data RemoteRecipient = RemoteRecipient diff --git a/src/Vervis/ActivityPub/Recipient.hs b/src/Vervis/ActivityPub/Recipient.hs index e02a70c..0b564f6 100644 --- a/src/Vervis/ActivityPub/Recipient.hs +++ b/src/Vervis/ActivityPub/Recipient.hs @@ -27,6 +27,7 @@ module Vervis.ActivityPub.Recipient , parseLocalActor , parseAudience , actorRecips + , localRecipSieve ) where @@ -40,6 +41,7 @@ import Data.List ((\\)) import Data.List.NonEmpty (NonEmpty, nonEmpty) import Data.Maybe import Data.Text (Text) +import Data.These import Data.Traversable import qualified Data.List.NonEmpty as NE @@ -52,6 +54,7 @@ import Yesod.FedURI import Yesod.Hashids import Yesod.MonadSite +import Data.List.Local import Data.List.NonEmpty.Local import Vervis.FedURI @@ -392,3 +395,65 @@ actorIsMember (LocalActorRepo shr rp) lrSet = fromMaybe False $ do actorRecips :: LocalActor -> LocalRecipientSet actorRecips = groupLocalRecipients . (: []) . groupedRecipientFromActor + +localRecipSieve + :: LocalRecipientSet -> Bool -> LocalRecipientSet -> LocalRecipientSet +localRecipSieve sieve allowActors = + mapMaybe (uncurry applySharerRelated) . sortAlign sieve + where + onlyActorsJ (LocalProjectRelatedSet (LocalProjectDirectSet j _t _f) _ts) = + LocalProjectRelatedSet (LocalProjectDirectSet j False False) [] + onlyActorsR (LocalRepoRelatedSet (LocalRepoDirectSet r _t _f)) = + LocalRepoRelatedSet $ LocalRepoDirectSet r False False + onlyActorsS (LocalSharerRelatedSet (LocalSharerDirectSet s _f) js rs) = + LocalSharerRelatedSet + (LocalSharerDirectSet s False) + (map (second onlyActorsJ) js) + (map (second onlyActorsR) rs) + + applySharerRelated _ (This _) = Nothing + applySharerRelated shr (That s) = + if allowActors + then Just (shr, onlyActorsS s) + else Nothing + applySharerRelated shr (These (LocalSharerRelatedSet s' j' r') (LocalSharerRelatedSet s j r)) = + Just + ( shr + , LocalSharerRelatedSet + (applySharer s' s) + (mapMaybe (uncurry applyProjectRelated) $ sortAlign j' j) + (mapMaybe (uncurry applyRepoRelated) $ sortAlign r' r) + ) + where + applySharer (LocalSharerDirectSet s' f') (LocalSharerDirectSet s f) = + LocalSharerDirectSet (s && (s' || allowActors)) (f && f') + applyProjectRelated _ (This _) = Nothing + applyProjectRelated prj (That j) = + if allowActors + then Just (prj, onlyActorsJ j) + else Nothing + applyProjectRelated prj (These (LocalProjectRelatedSet j' t') (LocalProjectRelatedSet j t)) = + Just + ( prj + , LocalProjectRelatedSet + (applyProject j' j) + (mapMaybe (uncurry applyTicketRelated) $ sortAlign t' t) + ) + where + applyProject (LocalProjectDirectSet j' t' f') (LocalProjectDirectSet j t f) = + LocalProjectDirectSet (j && (j' || allowActors)) (t && t') (f && f') + applyTicketRelated ltkhid (These t' t) = Just (ltkhid, applyTicket t' t) + where + applyTicket (LocalTicketDirectSet t' f') (LocalTicketDirectSet t f) = + LocalTicketDirectSet (t && t') (f && f') + applyTicketRelated _ _ = Nothing + applyRepoRelated _ (This _) = Nothing + applyRepoRelated rp (That r) = + if allowActors + then Just (rp, onlyActorsR r) + else Nothing + applyRepoRelated rp (These (LocalRepoRelatedSet r') (LocalRepoRelatedSet r)) = + Just (rp, LocalRepoRelatedSet $ applyRepo r' r) + where + applyRepo (LocalRepoDirectSet r' t' f') (LocalRepoDirectSet r t f) = + LocalRepoDirectSet (r && (r' || allowActors)) (t && t') (f && f') diff --git a/vervis.cabal b/vervis.cabal index 41c0f73..d67334d 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -348,6 +348,7 @@ library , SVGFonts , template-haskell , text + , these , time , time-interval , time-interval-aeson