forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Write recipient filtering utility function

Browse source
This commit is contained in:
fr33domlover 2020-02-19 10:59:38 +00:00
parent a53fbcf1c0
commit e0300ba0fa
4 changed files with 88 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

21
src/Data/List/Local.hs
View file

@ -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

18
src/Vervis/ActivityPub.hs
View file

@ -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

65
src/Vervis/ActivityPub/Recipient.hs
View file

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

1
vervis.cabal
View file

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