Write recipient filtering utility function

src/Data/List/Local.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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

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) =
+    sieve = [(shrAuthor, LocalSharerRelatedSet (LocalSharerDirectSet False True) [] [])]
-        ( 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
     fromRR (RemoteRecipient raid luA luI msince) = (raid, luA, luI, msince)
 
 data RemoteRecipient = RemoteRecipient

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')

vervis.cabal

@@ -348,6 +348,7 @@ library
                      , SVGFonts
                      , template-haskell
                      , text
+                     , these
                      , time
                      , time-interval
                      , time-interval-aeson