vervis/src/Vervis/Recipient.hs

{- This file is part of Vervis.
 -
 - Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

-- These are for the Barbie-based generated Eq and Ord instances
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

module Vervis.Recipient
    ( -- * Local actors
      LocalActorBy (..)
    , LocalActor
    , parseLocalActor
    , renderLocalActor

      -- * Local collections of (local and remote) actors
    , LocalStageBy (..)
    , LocalStage
    , renderLocalStage

      -- * Related actors and stages
    , localActorFollowers

      -- * Converting between KeyHashid, Key, Identity and Entity
    , hashLocalActorPure
    , getHashLocalActor
    , hashLocalActor

    , unhashLocalActorPure
    , unhashLocalActor
    , unhashLocalActorF
    , unhashLocalActorM
    , unhashLocalActorE
    , unhashLocalActor404

    , hashLocalStagePure
    , getHashLocalStage
    , hashLocalStage

    , unhashLocalStagePure
    , unhashLocalStage
    , unhashLocalStageF
    , unhashLocalStageM
    , unhashLocalStageE
    , unhashLocalStage404

      -- * Getting from DB
    , getLocalActorID

      -- * Local recipient set
      -- ** Types
    , TicketRoutes (..)
    , ClothRoutes (..)
    , PersonRoutes (..)
    , GroupRoutes (..)
    , RepoRoutes (..)
    , DeckRoutes (..)
    , LoomRoutes (..)
    , DeckFamilyRoutes (..)
    , LoomFamilyRoutes (..)
    , RecipientRoutes (..)
      -- ** Creating
    , makeRecipientSet
    , actorRecips
      -- ** Filtering
    , localRecipSieve
    , localRecipSieve'
      -- ** Querying
    , actorIsAddressed

      -- * Parsing audience from a received activity
    , ParsedAudience (..)
    , concatRecipients
    , parseAudience

      -- * Creating a recipient set, supporting both local and remote recips
    , Aud (..)
    , collectAudience
    )
where

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.List ((\\))
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.Maybe
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

import qualified Control.Monad.Fail as F
import qualified Data.List.NonEmpty as NE
import qualified Data.List.Ordered as LO
import qualified Data.Text as T

import Network.FedURI
import Yesod.ActivityPub
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite

import qualified Web.ActivityPub as AP

import Data.List.Local
import Data.List.NonEmpty.Local

import Vervis.FedURI
import Vervis.Foundation
import Vervis.Model

-------------------------------------------------------------------------------
-- Actor and collection-of-actors types
--
-- These are the 2 kinds of local recipients. This is the starting point for
-- grouping and checking recipient lists: First parse recipient URIs into these
-- types, then you can do any further parsing and grouping.
-------------------------------------------------------------------------------

data LocalActorBy f
    = LocalActorPerson (f Person)
    | LocalActorGroup  (f Group)
    | LocalActorRepo   (f Repo)
    | LocalActorDeck   (f Deck)
    | LocalActorLoom   (f Loom)
    deriving (Generic, FunctorB, ConstraintsB)

deriving instance AllBF Eq f LocalActorBy => Eq (LocalActorBy f)
deriving instance AllBF Ord f LocalActorBy => Ord (LocalActorBy f)

{-
instance (Eq (f Person), Eq (f Group), Eq (f Repo), Eq (f Deck), Eq (f Loom)) => Eq (LocalActorBy f) where
    (==) (LocalActorPerson p) (LocalActorPerson p') = p == p'
    (==) (LocalActorGroup g) (LocalActorGroup g') = g == g'
    (==) (LocalActorRepo r) (LocalActorRepo r') = r == r'
    (==) (LocalActorDeck d) (LocalActorDeck d') = d == d'
    (==) (LocalActorLoom l) (LocalActorLoom l') = l == l'
    (==) _ _ = False

instance (Ord (f Person), Ord (f Group), Ord (f Repo), Ord (f Deck), Ord (f Loom)) => Ord (LocalActorBy f) where
    (<=) (LocalActorPerson p) (LocalActorPerson p') = p <= p'
    (<=) (LocalActorPerson _) _                     = True

    (<=) (LocalActorGroup _) (LocalActorPerson _) = False
    (<=) (LocalActorGroup g) (LocalActorGroup g') = g <= g'
    (<=) (LocalActorGroup _) _                    = True

    (<=) (LocalActorGroup _) (LocalActorPerson _) = False
    (<=) (LocalActorGroup g) (LocalActorGroup g') = g <= g'
    (<=) (LocalActorGroup _) _                    = True
-}

type LocalActor = LocalActorBy KeyHashid

parseLocalActor :: Route App -> Maybe LocalActor
parseLocalActor (PersonR pkhid) = Just $ LocalActorPerson pkhid
parseLocalActor (GroupR gkhid)  = Just $ LocalActorGroup gkhid
parseLocalActor (RepoR rkhid)   = Just $ LocalActorRepo rkhid
parseLocalActor (DeckR dkhid)   = Just $ LocalActorDeck dkhid
parseLocalActor (LoomR lkhid)   = Just $ LocalActorLoom lkhid
parseLocalActor _               = Nothing

renderLocalActor :: LocalActor -> Route App
renderLocalActor (LocalActorPerson pkhid) = PersonR pkhid
renderLocalActor (LocalActorGroup gkhid)  = GroupR gkhid
renderLocalActor (LocalActorRepo rkhid)   = RepoR rkhid
renderLocalActor (LocalActorDeck dkhid)   = DeckR dkhid
renderLocalActor (LocalActorLoom lkhid)   = LoomR lkhid

data LocalStageBy f
    = LocalStagePersonFollowers (f Person)

    | LocalStageGroupFollowers  (f Group)

    | LocalStageRepoFollowers   (f Repo)

    | LocalStageDeckFollowers   (f Deck)
    | LocalStageTicketFollowers (f Deck) (f TicketDeck)

    | LocalStageLoomFollowers   (f Loom)
    | LocalStageClothFollowers  (f Loom) (f TicketLoom)
    deriving (Generic, FunctorB, ConstraintsB)

deriving instance AllBF Eq f LocalStageBy => Eq (LocalStageBy f)
deriving instance AllBF Ord f LocalStageBy => Ord (LocalStageBy f)

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) =
    Just $ LocalStageDeckFollowers dkhid
parseLocalStage (TicketFollowersR dkhid ltkhid) =
    Just $ LocalStageTicketFollowers dkhid ltkhid
parseLocalStage (LoomFollowersR lkhid) =
    Just $ LocalStageLoomFollowers lkhid
parseLocalStage (ClothFollowersR lkhid ltkhid) =
    Just $ LocalStageClothFollowers lkhid ltkhid
parseLocalStage _ = Nothing

renderLocalStage :: LocalStage -> Route App
renderLocalStage (LocalStagePersonFollowers pkhid) =
    PersonFollowersR pkhid
renderLocalStage (LocalStageGroupFollowers gkhid) =
    GroupFollowersR gkhid
renderLocalStage (LocalStageRepoFollowers rkhid) =
    RepoFollowersR rkhid
renderLocalStage (LocalStageDeckFollowers dkhid) =
    DeckFollowersR dkhid
renderLocalStage (LocalStageTicketFollowers dkhid ltkhid) =
    TicketFollowersR dkhid ltkhid
renderLocalStage (LocalStageLoomFollowers lkhid) =
    LoomFollowersR lkhid
renderLocalStage (LocalStageClothFollowers lkhid ltkhid) =
    ClothFollowersR lkhid ltkhid

parseLocalRecipient :: Route App -> Maybe (Either LocalActor LocalStage)
parseLocalRecipient r =
    Left <$> parseLocalActor r <|> Right <$> parseLocalStage r

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

hashLocalActorPure
    :: HashidsContext -> LocalActorBy Key -> LocalActorBy KeyHashid
hashLocalActorPure ctx = f
    where
    f (LocalActorPerson p) = LocalActorPerson $ encodeKeyHashidPure ctx p
    f (LocalActorGroup g)  = LocalActorGroup $ encodeKeyHashidPure ctx g
    f (LocalActorRepo r)   = LocalActorRepo $ encodeKeyHashidPure ctx r
    f (LocalActorDeck d)   = LocalActorDeck $ encodeKeyHashidPure ctx d
    f (LocalActorLoom l)   = LocalActorLoom $ encodeKeyHashidPure ctx l

getHashLocalActor
    :: (MonadSite m, YesodHashids (SiteEnv m))
    => m (LocalActorBy Key -> LocalActorBy KeyHashid)
getHashLocalActor = do
    ctx <- asksSite siteHashidsContext
    return $ hashLocalActorPure ctx

hashLocalActor
    :: (MonadSite m, YesodHashids (SiteEnv m))
    => LocalActorBy Key -> m (LocalActorBy KeyHashid)
hashLocalActor actor = do
    hash <- getHashLocalActor
    return $ hash actor

unhashLocalActorPure
    :: HashidsContext -> LocalActorBy KeyHashid -> Maybe (LocalActorBy Key)
unhashLocalActorPure ctx = f
    where
    f (LocalActorPerson p) = LocalActorPerson <$> decodeKeyHashidPure ctx p
    f (LocalActorGroup g)  = LocalActorGroup <$> decodeKeyHashidPure ctx g
    f (LocalActorRepo r)   = LocalActorRepo <$> decodeKeyHashidPure ctx r
    f (LocalActorDeck d)   = LocalActorDeck <$> decodeKeyHashidPure ctx d
    f (LocalActorLoom l)   = LocalActorLoom <$> decodeKeyHashidPure ctx l

unhashLocalActor
    :: (MonadSite m, YesodHashids (SiteEnv m))
    => LocalActorBy KeyHashid -> m (Maybe (LocalActorBy Key))
unhashLocalActor actor = do
    ctx <- asksSite siteHashidsContext
    return $ unhashLocalActorPure ctx actor

unhashLocalActorF
    :: (F.MonadFail m, MonadSite m, YesodHashids (SiteEnv m))
    => LocalActorBy KeyHashid -> String -> m (LocalActorBy Key)
unhashLocalActorF actor e = maybe (F.fail e) return =<< unhashLocalActor actor

unhashLocalActorM
    :: (MonadSite m, YesodHashids (SiteEnv m))
    => LocalActorBy KeyHashid -> MaybeT m (LocalActorBy Key)
unhashLocalActorM = MaybeT . unhashLocalActor

unhashLocalActorE
    :: (MonadSite m, YesodHashids (SiteEnv m))
    => LocalActorBy KeyHashid -> e -> ExceptT e m (LocalActorBy Key)
unhashLocalActorE actor e =
    ExceptT $ maybe (Left e) Right <$> unhashLocalActor actor

unhashLocalActor404
    :: ( MonadSite m
       , MonadHandler m
       , HandlerSite m ~ SiteEnv m
       , YesodHashids (HandlerSite m)
       )
    => LocalActorBy KeyHashid
    -> m (LocalActorBy Key)
unhashLocalActor404 actor = maybe notFound return =<< unhashLocalActor actor

hashLocalStagePure
    :: HashidsContext -> LocalStageBy Key -> LocalStageBy KeyHashid
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) =
        LocalStageDeckFollowers $ encodeKeyHashidPure ctx d
    f (LocalStageTicketFollowers d t) =
        LocalStageTicketFollowers
            (encodeKeyHashidPure ctx d)
            (encodeKeyHashidPure ctx t)
    f (LocalStageLoomFollowers l) =
        LocalStageLoomFollowers $ encodeKeyHashidPure ctx l
    f (LocalStageClothFollowers l c) =
        LocalStageClothFollowers
            (encodeKeyHashidPure ctx l)
            (encodeKeyHashidPure ctx c)

getHashLocalStage
    :: (MonadSite m, YesodHashids (SiteEnv m))
    => m (LocalStageBy Key -> LocalStageBy KeyHashid)
getHashLocalStage = do
    ctx <- asksSite siteHashidsContext
    return $ hashLocalStagePure ctx

hashLocalStage
    :: (MonadSite m, YesodHashids (SiteEnv m))
    => LocalStageBy Key -> m (LocalStageBy KeyHashid)
hashLocalStage stage = do
    hash <- getHashLocalStage
    return $ hash stage

unhashLocalStagePure
    :: HashidsContext -> LocalStageBy KeyHashid -> Maybe (LocalStageBy Key)
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) =
        LocalStageDeckFollowers <$> decodeKeyHashidPure ctx d
    f (LocalStageTicketFollowers d t) =
        LocalStageTicketFollowers
            <$> decodeKeyHashidPure ctx d
            <*> decodeKeyHashidPure ctx t
    f (LocalStageLoomFollowers l) =
        LocalStageLoomFollowers <$> decodeKeyHashidPure ctx l
    f (LocalStageClothFollowers l c) =
        LocalStageClothFollowers
            <$> decodeKeyHashidPure ctx l
            <*> decodeKeyHashidPure ctx c

unhashLocalStage
    :: (MonadSite m, YesodHashids (SiteEnv m))
    => LocalStageBy KeyHashid -> m (Maybe (LocalStageBy Key))
unhashLocalStage stage = do
    ctx <- asksSite siteHashidsContext
    return $ unhashLocalStagePure ctx stage

unhashLocalStageF
    :: (F.MonadFail m, MonadSite m, YesodHashids (SiteEnv m))
    => LocalStageBy KeyHashid -> String -> m (LocalStageBy Key)
unhashLocalStageF stage e = maybe (F.fail e) return =<< unhashLocalStage stage

unhashLocalStageM
    :: (MonadSite m, YesodHashids (SiteEnv m))
    => LocalStageBy KeyHashid -> MaybeT m (LocalStageBy Key)
unhashLocalStageM = MaybeT . unhashLocalStage

unhashLocalStageE
    :: (MonadSite m, YesodHashids (SiteEnv m))
    => LocalStageBy KeyHashid -> e -> ExceptT e m (LocalStageBy Key)
unhashLocalStageE stage e =
    ExceptT $ maybe (Left e) Right <$> unhashLocalStage stage

unhashLocalStage404
    :: ( MonadSite m
       , MonadHandler m
       , HandlerSite m ~ SiteEnv m
       , YesodHashids (HandlerSite m)
       )
    => LocalStageBy KeyHashid
    -> 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
--
-- These are here just to help with grouping recipients. From this
-- representation it's easy to group recipients into a form that is friendly to
-- the code that fetches the actual recipients from the DB.
-------------------------------------------------------------------------------

data LeafTicket = LeafTicketFollowers deriving (Eq, Ord)

data LeafCloth = LeafClothFollowers deriving (Eq, Ord)

data LeafPerson = LeafPerson | LeafPersonFollowers deriving (Eq, Ord)

data LeafGroup = LeafGroup | LeafGroupFollowers deriving (Eq, Ord)

data LeafRepo = LeafRepo | LeafRepoFollowers deriving (Eq, Ord)

data LeafDeck = LeafDeck | LeafDeckFollowers deriving (Eq, Ord)

data LeafLoom = LeafLoom | LeafLoomFollowers deriving (Eq, Ord)

data PieceDeck
    = PieceDeck LeafDeck
    | PieceTicket (KeyHashid TicketDeck) LeafTicket
    deriving (Eq, Ord)

data PieceLoom
    = PieceLoom LeafLoom
    | PieceCloth (KeyHashid TicketLoom) LeafCloth
    deriving (Eq, Ord)

data LocalRecipient
    = RecipPerson (KeyHashid Person) LeafPerson
    | RecipGroup  (KeyHashid Group)  LeafGroup
    | RecipRepo   (KeyHashid Repo)   LeafRepo
    | RecipDeck   (KeyHashid Deck)   PieceDeck
    | RecipLoom   (KeyHashid Loom)   PieceLoom
    deriving (Eq, Ord)

recipientFromActor :: LocalActor -> LocalRecipient
recipientFromActor (LocalActorPerson pkhid) =
    RecipPerson pkhid LeafPerson
recipientFromActor (LocalActorGroup gkhid) =
    RecipGroup gkhid LeafGroup
recipientFromActor (LocalActorRepo rkhid) =
    RecipRepo rkhid LeafRepo
recipientFromActor (LocalActorDeck dkhid) =
    RecipDeck dkhid $ PieceDeck LeafDeck
recipientFromActor (LocalActorLoom lkhid) =
    RecipLoom lkhid $ PieceLoom LeafLoom

recipientFromStage :: LocalStage -> LocalRecipient
recipientFromStage (LocalStagePersonFollowers pkhid) =
    RecipPerson pkhid LeafPersonFollowers
recipientFromStage (LocalStageGroupFollowers gkhid) =
    RecipGroup gkhid LeafGroupFollowers
recipientFromStage (LocalStageRepoFollowers rkhid) =
    RecipRepo rkhid LeafRepoFollowers
recipientFromStage (LocalStageDeckFollowers dkhid) =
    RecipDeck dkhid $ PieceDeck LeafDeckFollowers
recipientFromStage (LocalStageTicketFollowers dkhid ltkhid) =
    RecipDeck dkhid $ PieceTicket ltkhid LeafTicketFollowers
recipientFromStage (LocalStageLoomFollowers lkhid) =
    RecipLoom lkhid $ PieceLoom LeafLoomFollowers
recipientFromStage (LocalStageClothFollowers lkhid ltkhid) =
    RecipLoom lkhid $ PieceCloth ltkhid LeafClothFollowers

-------------------------------------------------------------------------------
-- Recipient set types
--
-- These types represent a set of recipients grouped by the variable components
-- of their routes. It's convenient to use when looking for the recipients in
-- the DB, and easy to manipulate and check the recipient list in terms of app
-- logic rather than plain lists of routes.
-------------------------------------------------------------------------------

data TicketRoutes = TicketRoutes
    { routeTicketFollowers :: Bool
    }
    deriving Eq

data ClothRoutes = ClothRoutes
    { routeClothFollowers :: Bool
    }
    deriving Eq

data PersonRoutes = PersonRoutes
    { routePerson          :: Bool
    , routePersonFollowers :: Bool
    }
    deriving Eq

data GroupRoutes = GroupRoutes
    { routeGroup          :: Bool
    , routeGroupFollowers :: Bool
    }
    deriving Eq

data RepoRoutes = RepoRoutes
    { routeRepo          :: Bool
    , routeRepoFollowers :: Bool
    }
    deriving Eq

data DeckRoutes = DeckRoutes
    { routeDeck          :: Bool
    , routeDeckFollowers :: Bool
    }
    deriving Eq

data LoomRoutes = LoomRoutes
    { routeLoom          :: Bool
    , routeLoomFollowers :: Bool
    }
    deriving Eq

data DeckFamilyRoutes = DeckFamilyRoutes
    { familyDeck    :: DeckRoutes
    , familyTickets :: [(KeyHashid TicketDeck, TicketRoutes)]
    }
    deriving Eq

data LoomFamilyRoutes = LoomFamilyRoutes
    { familyLoom   :: LoomRoutes
    , familyCloths :: [(KeyHashid TicketLoom, ClothRoutes)]
    }
    deriving Eq

data RecipientRoutes = RecipientRoutes
    { recipPeople :: [(KeyHashid Person, PersonRoutes)]
    , recipGroups :: [(KeyHashid Group , GroupRoutes)]
    , recipRepos  :: [(KeyHashid Repo  , RepoRoutes)]
    , recipDecks  :: [(KeyHashid Deck  , DeckFamilyRoutes)]
    , recipLooms  :: [(KeyHashid Loom  , LoomFamilyRoutes)]
    }
    deriving Eq

groupLocalRecipients :: [LocalRecipient] -> RecipientRoutes
groupLocalRecipients = organize . partitionByActor
    where
    partitionByActor
        :: [LocalRecipient]
        -> ( [(KeyHashid Person, LeafPerson)]
           , [(KeyHashid Group, LeafGroup)]
           , [(KeyHashid Repo, LeafRepo)]
           , [(KeyHashid Deck, PieceDeck)]
           , [(KeyHashid Loom, PieceLoom)]
           )
    partitionByActor = foldl' f ([], [], [], [], [])
        where
        f (p, g, r, d, l) (RecipPerson pkhid pleaf) =
            ((pkhid, pleaf) : p, g, r, d, l)
        f (p, g, r, d, l) (RecipGroup gkhid gleaf) =
            (p, (gkhid, gleaf) : g, r, d, l)
        f (p, g, r, d, l) (RecipRepo rkhid rleaf) =
            (p, g, (rkhid, rleaf) : r, d, l)
        f (p, g, r, d, l) (RecipDeck dkhid dpiece) =
            (p, g, r, (dkhid, dpiece) : d, l)
        f (p, g, r, d, l) (RecipLoom lkhid lpiece) =
            (p, g, r, d, (lkhid, lpiece) : l)

    organize
        :: ( [(KeyHashid Person, LeafPerson)]
           , [(KeyHashid Group, LeafGroup)]
           , [(KeyHashid Repo, LeafRepo)]
           , [(KeyHashid Deck, PieceDeck)]
           , [(KeyHashid Loom, PieceLoom)]
           )
        -> RecipientRoutes
    organize (p, g, r, d, l) = RecipientRoutes
        { recipPeople =
            map (second $ foldr orLP $ PersonRoutes False False) $ groupByKeySort p
        , recipGroups =
            map (second $ foldr orLG $ GroupRoutes False False) $ groupByKeySort g
        , recipRepos =
            map (second $ foldr orLR $ RepoRoutes False False) $ groupByKeySort r
        , recipDecks =
            map (second
                    $ uncurry DeckFamilyRoutes
                    . bimap
                        (foldr orLD $ DeckRoutes False False)
                        ( map (second $  foldr orLT $ TicketRoutes False)
                        . groupByKey
                        )
                    . partitionEithers . NE.toList . NE.map pd2either
                ) $
            groupByKeySort d
        , recipLooms =
            map (second
                    $ uncurry LoomFamilyRoutes
                    . bimap
                        (foldr orLL $ LoomRoutes False False)
                        ( map (second $ foldr orLC $ ClothRoutes False)
                        . groupByKey
                        )
                    . partitionEithers . NE.toList . NE.map pl2either
                ) $
            groupByKeySort l
        }
        where
        groupByKey :: (Foldable f, Eq a) => f (a, b) -> [(a, NonEmpty b)]
        groupByKey = groupWithExtract fst snd

        groupByKeySort :: Ord a => [(a, b)] -> [(a, NonEmpty b)]
        groupByKeySort = groupAllExtract fst snd

        orLP :: LeafPerson -> PersonRoutes -> PersonRoutes
        orLP _                   pr@(PersonRoutes True True) = pr
        orLP LeafPerson          pr@(PersonRoutes _    _)    = pr { routePerson = True }
        orLP LeafPersonFollowers pr@(PersonRoutes _    _)    = pr { routePersonFollowers = True }

        orLG :: LeafGroup -> GroupRoutes -> GroupRoutes
        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
        orLR LeafRepo          rr@(RepoRoutes _    _)    = rr { routeRepo = True }
        orLR LeafRepoFollowers rr@(RepoRoutes _    _)    = rr { routeRepoFollowers = True }

        orLD :: LeafDeck -> DeckRoutes -> DeckRoutes
        orLD _                 dr@(DeckRoutes True True) = dr
        orLD LeafDeck          dr@(DeckRoutes _    _)    = dr { routeDeck = True }
        orLD LeafDeckFollowers dr@(DeckRoutes _    _)    = dr { routeDeckFollowers = True }

        orLL :: LeafLoom -> LoomRoutes -> LoomRoutes
        orLL _                 lr@(LoomRoutes True True) = lr
        orLL LeafLoom          lr@(LoomRoutes _    _)    = lr { routeLoom = True }
        orLL LeafLoomFollowers lr@(LoomRoutes _    _)    = lr { routeLoomFollowers = True }

        orLT :: LeafTicket -> TicketRoutes -> TicketRoutes
        orLT _                   tr@(TicketRoutes True) = tr
        orLT LeafTicketFollowers tr@(TicketRoutes _)    = tr { routeTicketFollowers = True }

        orLC :: LeafCloth -> ClothRoutes -> ClothRoutes
        orLC _                  cr@(ClothRoutes True) = cr
        orLC LeafClothFollowers cr@(ClothRoutes _)    = cr { routeClothFollowers = True }

        pd2either :: PieceDeck -> Either LeafDeck (KeyHashid TicketDeck, LeafTicket)
        pd2either (PieceDeck ld)          = Left ld
        pd2either (PieceTicket ltkhid lt) = Right (ltkhid, lt)

        pl2either :: PieceLoom -> Either LeafLoom (KeyHashid TicketLoom, LeafCloth)
        pl2either (PieceLoom ll)         = Left ll
        pl2either (PieceCloth ltkhid ll) = Right (ltkhid, ll)

-------------------------------------------------------------------------------
-- Parse URIs into a grouped recipient set
-------------------------------------------------------------------------------

makeRecipientSet :: [LocalActor] -> [LocalStage] -> RecipientRoutes
makeRecipientSet actors stages =
    groupLocalRecipients $
        map recipientFromActor actors ++ map recipientFromStage stages

actorRecips :: LocalActor -> RecipientRoutes
actorRecips = groupLocalRecipients . (: []) . recipientFromActor

localRecipSieve
    :: RecipientRoutes -> Bool -> RecipientRoutes -> RecipientRoutes
localRecipSieve sieve allowActors =
    localRecipSieve' sieve allowActors allowActors

localRecipSieve'
    :: RecipientRoutes
    -> Bool
    -> Bool
    -> RecipientRoutes
    -> RecipientRoutes
localRecipSieve' sieve allowPeople allowOthers routes = RecipientRoutes
    { recipPeople = applySieve' applyPerson recipPeople
    , recipGroups = applySieve' applyGroup recipGroups
    , recipRepos  = applySieve' applyRepo recipRepos
    , recipDecks  = applySieve' applyDeck recipDecks
    , recipLooms  = applySieve' applyLoom recipLooms
    }
    where
    applySieve
        :: (  KeyHashid record
           -> These routes routes
           -> Maybe (KeyHashid record, routes)
           )
        -> [(KeyHashid record, routes)]
        -> [(KeyHashid record, routes)]
        -> [(KeyHashid record, routes)]
    applySieve merge sieveList routeList =
        mapMaybe (uncurry merge) $ sortAlign sieveList routeList

    applySieve'
        :: (  KeyHashid record
           -> These routes routes
           -> Maybe (KeyHashid record, routes)
           )
        -> (RecipientRoutes -> [(KeyHashid record, routes)])
        -> [(KeyHashid record, routes)]
    applySieve' merge field = applySieve merge (field sieve) (field routes)

    applyPerson _     (This _) = Nothing
    applyPerson pkhid (That p) =
        if allowPeople && routePerson p
            then Just (pkhid, PersonRoutes True False)
            else Nothing
    applyPerson pkhid (These (PersonRoutes p' pf') (PersonRoutes p pf)) =
        let merged = PersonRoutes (p && (p' || allowPeople)) (pf && pf')
        in  if merged == PersonRoutes False False
                then Nothing
                else Just (pkhid, merged)

    applyGroup _     (This _) = Nothing
    applyGroup gkhid (That g) =
        if allowOthers && routeGroup g
            then Just (gkhid, GroupRoutes True False)
            else Nothing
    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)

    applyRepo _     (This _) = Nothing
    applyRepo rkhid (That r) =
        if allowOthers && routeRepo r
            then Just (rkhid, RepoRoutes True False)
            else Nothing
    applyRepo rkhid (These (RepoRoutes r' rf') (RepoRoutes r rf)) =
        let merged = RepoRoutes (r && (r' || allowOthers)) (rf && rf')
        in  if merged == RepoRoutes False False
                then Nothing
                else Just (rkhid, merged)

    applyDeck _     (This _) = Nothing
    applyDeck dkhid (That d) =
        if allowOthers && routeDeck (familyDeck d)
            then Just (dkhid, DeckFamilyRoutes (DeckRoutes True False) [])
            else Nothing
    applyDeck
        dkhid
        (These
            (DeckFamilyRoutes (DeckRoutes d' df') t')
            (DeckFamilyRoutes (DeckRoutes d  df)  t)
        ) =
            let deck = DeckRoutes (d && (d' || allowOthers)) (df && df')
                tickets = applySieve applyTicket t' t
                    where
                    applyTicket ltkhid (These (TicketRoutes tf') (TicketRoutes tf)) =
                        let merged = TicketRoutes (tf && tf')
                        in  if merged == TicketRoutes False
                                then Nothing
                                else Just (ltkhid, merged)
                    applyTicket _ _ = Nothing
            in  if deck == DeckRoutes False False && null tickets
                    then Nothing
                    else Just (dkhid, DeckFamilyRoutes deck tickets)

    applyLoom _     (This _) = Nothing
    applyLoom lkhid (That d) =
        if allowOthers && routeLoom (familyLoom d)
            then Just (lkhid, LoomFamilyRoutes (LoomRoutes True False) [])
            else Nothing
    applyLoom
        lkhid
        (These
            (LoomFamilyRoutes (LoomRoutes l' lf') c')
            (LoomFamilyRoutes (LoomRoutes l  lf)  c)
        ) =
            let loom = LoomRoutes (l && (l' || allowOthers)) (lf && lf')
                cloths = applySieve applyCloth c' c
                    where
                    applyCloth ltkhid (These (ClothRoutes cf') (ClothRoutes cf)) =
                        let merged = ClothRoutes (cf && cf')
                        in  if merged == ClothRoutes False
                                then Nothing
                                else Just (ltkhid, merged)
                    applyCloth _ _ = Nothing
            in  if loom == LoomRoutes False False && null cloths
                    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)]
    , paudBlinded      :: AP.Audience u
    , paudFwdHosts     :: [Authority u]
    }

concatRecipients :: AP.Audience u -> [ObjURI u]
concatRecipients (AP.Audience to bto cc bcc gen _) =
    concat [to, bto, cc, bcc, gen]

parseRecipients
    :: (MonadSite m, SiteEnv m ~ App)
    => NonEmpty FedURI
    -> ExceptT Text m (RecipientRoutes, [FedURI])
parseRecipients recips = do
    hLocal <- asksSite siteInstanceHost
    let (locals, remotes) = splitRecipients hLocal recips
        (lusInvalid, routesInvalid, localsSet) = parseLocalRecipients locals
    unless (null lusInvalid) $
        throwE $
            "Local recipients are invalid routes: " <>
            T.pack (show $ map (renderObjURI . ObjURI hLocal) lusInvalid)
    unless (null routesInvalid) $ do
        renderUrl <- askUrlRender
        throwE $
            "Local recipients are non-recipient routes: " <>
            T.pack (show $ map renderUrl routesInvalid)
    return (localsSet, remotes)
    where
    splitRecipients :: Host -> NonEmpty FedURI -> ([LocalURI], [FedURI])
    splitRecipients home recips =
        let (local, remote) = NE.partition ((== home) . objUriAuthority) recips
        in  (map objUriLocal local, remote)

    parseLocalRecipients
        :: [LocalURI] -> ([LocalURI], [Route App], RecipientRoutes)
    parseLocalRecipients lus =
        let (lusInvalid, routes) = partitionEithers $ map parseRoute lus
            (routesInvalid, recips) = partitionEithers $ map parseRecip routes
            (actors, stages) = partitionEithers recips
            grouped =
                map recipientFromActor actors ++ map recipientFromStage stages
        in  (lusInvalid, routesInvalid, groupLocalRecipients grouped)
        where
        parseRoute lu =
            case decodeRouteLocal lu of
                Nothing -> Left lu
                Just route -> Right route
        parseRecip route =
            case parseLocalRecipient route of
                Nothing -> Left route
                Just recip -> Right recip

parseAudience
    :: (MonadSite m, SiteEnv m ~ App)
    => AP.Audience URIMode
    -> ExceptT Text m (Maybe (ParsedAudience URIMode))
parseAudience audience = do
    let recips = concatRecipients audience
    for (nonEmpty recips) $ \ recipsNE -> do
        (localsSet, remotes) <- parseRecipients recipsNE
        let remotesGrouped =
                groupByHost $ remotes \\ AP.audienceNonActors audience
            hosts = map fst remotesGrouped
        return ParsedAudience
            { paudLocalRecips  = localsSet
            , paudRemoteActors = remotesGrouped
            , paudBlinded      =
                audience { AP.audienceBto = [], AP.audienceBcc = [] }
            , paudFwdHosts     =
                let nonActorHosts =
                        LO.nubSort $
                            map objUriAuthority $ AP.audienceNonActors audience
                in  LO.isect hosts nonActorHosts
            }
    where
    groupByHost :: [FedURI] -> [(Host, NonEmpty LocalURI)]
    groupByHost = groupAllExtract objUriAuthority objUriLocal

data Aud u
    = AudLocal [LocalActor] [LocalStage]
    | AudRemote (Authority u) [LocalURI] [LocalURI]

collectAudience
    :: Foldable f
    => f (Aud u)
    -> ( RecipientRoutes
       , [(Authority u, NonEmpty LocalURI)]
       , [Authority u]
       , [Route App]
       , [ObjURI u]
       )
collectAudience auds =
    let (locals, remotes) = partitionAudience auds
        (actors, stages) =
            let organize = LO.nubSort . concat
            in  bimap organize organize $ unzip locals
        groupedRemotes =
            let organize = LO.nubSort . sconcat
            in  map (second $ bimap organize organize . NE.unzip) $
                groupAllExtract fst snd remotes
    in  ( makeRecipientSet actors stages
        , mapMaybe (\ (h, (as, _)) -> (h,) <$> nonEmpty as) groupedRemotes
        , [ h | (h, (_, cs)) <- groupedRemotes, not (null cs) ]
        , map renderLocalActor actors ++ map renderLocalStage stages
        , concatMap (\ (h, (as, cs)) -> ObjURI h <$> as ++ cs) groupedRemotes
        )
    where
    partitionAudience = foldl' f ([], [])
        where
        f (ls, rs) (AudLocal as cs)    = ((as, cs) : ls, rs)
        f (ls, rs) (AudRemote h as cs) = (ls           , (h, (as, cs)) : rs)