diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 364b7c6..3b00726 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -93,6 +93,7 @@ import Yesod.Persist.Local import Vervis.ActivityPub import Vervis.ActorKey +import Vervis.API.Recipient import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident @@ -104,41 +105,6 @@ data Recip | RecipURA (Entity UnfetchedRemoteActor) | RecipRC (Entity RemoteCollection) -data LocalTicketRecipient = LocalTicketParticipants | LocalTicketTeam - deriving (Eq, Ord) - -data LocalProjectRecipient - = LocalProject - | LocalProjectFollowers - | LocalTicketRelated Int LocalTicketRecipient - deriving (Eq, Ord) - -data LocalSharerRecipient - = LocalSharer - | LocalProjectRelated PrjIdent LocalProjectRecipient - deriving (Eq, Ord) - -data LocalRecipient = LocalSharerRelated ShrIdent LocalSharerRecipient - deriving (Eq, Ord) - -data LocalTicketRelatedSet - = OnlyTicketParticipants - | OnlyTicketTeam - | BothTicketParticipantsAndTeam - -data LocalProjectRelatedSet = LocalProjectRelatedSet - { localRecipProject :: Bool - , localRecipProjectFollowers :: Bool - , localRecipTicketRelated :: [(Int, LocalTicketRelatedSet)] - } - -data LocalSharerRelatedSet = LocalSharerRelatedSet - { localRecipSharer :: Bool - , localRecipProjectRelated :: [(PrjIdent, LocalProjectRelatedSet)] - } - -type LocalRecipientSet = [(ShrIdent, LocalSharerRelatedSet)] - parseComment :: LocalURI -> ExceptT Text Handler (ShrIdent, LocalMessageId) parseComment luParent = do route <- case decodeRouteLocal luParent of @@ -257,12 +223,8 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source , [FedURI] ) parseRecipsContextParent recips uContext muParent = do - (locals, remotes) <- lift $ splitRecipients recips - let (localsParsed, localsRest) = parseLocalRecipients locals - unless (null localsRest) $ - throwE "Note has invalid local recipients" - let localsSet = groupLocalRecipients localsParsed - (hContext, luContext) = f2l uContext + (localsSet, remotes) <- parseRecipients recips + let (hContext, luContext) = f2l uContext parent <- parseParent uContext muParent local <- hostIsLocal hContext let remotes' = remotes L.\\ audienceNonActors aud @@ -275,82 +237,6 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source shrs <- verifyOnlySharers localsSet return (parent, shrs, Nothing, remotes') where - -- First step: Split into remote and local: - splitRecipients :: NonEmpty FedURI -> Handler ([LocalURI], [FedURI]) - splitRecipients recips = do - home <- getsYesod $ appInstanceHost . appSettings - let (local, remote) = NE.partition ((== home) . furiHost) recips - return (map (snd . f2l) local, remote) - - -- Parse the local recipients - parseLocalRecipients :: [LocalURI] -> ([LocalRecipient], [Either LocalURI (Route App)]) - parseLocalRecipients = swap . partitionEithers . map decide - where - parseLocalRecipient (SharerR shr) = Just $ LocalSharerRelated shr LocalSharer - parseLocalRecipient (ProjectR shr prj) = - Just $ LocalSharerRelated shr $ LocalProjectRelated prj LocalProject - parseLocalRecipient (ProjectFollowersR shr prj) = - Just $ LocalSharerRelated shr $ LocalProjectRelated prj LocalProjectFollowers - parseLocalRecipient (TicketParticipantsR shr prj num) = - Just $ LocalSharerRelated shr $ LocalProjectRelated prj $ LocalTicketRelated num LocalTicketParticipants - parseLocalRecipient (TicketTeamR shr prj num) = - Just $ LocalSharerRelated shr $ LocalProjectRelated prj $ LocalTicketRelated num LocalTicketTeam - parseLocalRecipient _ = Nothing - decide lu = - case decodeRouteLocal lu of - Nothing -> Left $ Left lu - Just route -> - case parseLocalRecipient route of - Nothing -> Left $ Right route - Just lr -> Right lr - - -- Group local recipients - groupLocalRecipients :: [LocalRecipient] -> LocalRecipientSet - groupLocalRecipients - = map - ( second - $ uncurry LocalSharerRelatedSet - . bimap - (not . null) - ( map - ( second - $ uncurry localProjectRelatedSet - . bimap - ( bimap (not . null) (not . null) - . partition id - ) - ( map (second ltrs2ltrs) - . groupWithExtract fst snd - ) - . partitionEithers - . NE.toList - ) - . groupWithExtract fst (lpr2e . snd) - ) - . partitionEithers - . NE.toList - ) - . groupWithExtract - (\ (LocalSharerRelated shr _) -> shr) - (\ (LocalSharerRelated _ lsr) -> lsr2e lsr) - . sort - where - lsr2e LocalSharer = Left () - lsr2e (LocalProjectRelated prj lpr) = Right (prj, lpr) - lpr2e LocalProject = Left False - lpr2e LocalProjectFollowers = Left True - lpr2e (LocalTicketRelated num ltr) = Right (num, ltr) - ltrs2ltrs (LocalTicketParticipants :| l) = - if LocalTicketTeam `elem` l - then BothTicketParticipantsAndTeam - else OnlyTicketParticipants - ltrs2ltrs (LocalTicketTeam :| l) = - if LocalTicketParticipants `elem` l - then BothTicketParticipantsAndTeam - else OnlyTicketTeam - localProjectRelatedSet (f, j) t = - LocalProjectRelatedSet j f t - parseParent :: FedURI -> Maybe FedURI -> ExceptT Text Handler (Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI))) parseParent _ Nothing = return Nothing parseParent uContext (Just uParent) = @@ -373,7 +259,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source _ -> throwE "Local context isn't a ticket route" atMostSharer :: e -> (ShrIdent, LocalSharerRelatedSet) -> ExceptT e Handler (Maybe ShrIdent) - atMostSharer _ (shr, LocalSharerRelatedSet s []) = return $ if s then Just shr else Nothing + atMostSharer _ (shr, LocalSharerRelatedSet s []) = return $ if localRecipSharer s then Just shr else Nothing atMostSharer e (_ , LocalSharerRelatedSet _ _ ) = throwE e verifyTicketRecipients :: (ShrIdent, PrjIdent, Int) -> LocalRecipientSet -> ExceptT Text Handler [ShrIdent] @@ -381,16 +267,16 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source lsrSet <- fromMaybeE (lookupSorted shr recips) "Note with local context: No required recipients" (prj', lprSet) <- verifySingleton (localRecipProjectRelated lsrSet) "Note project-related recipient sets" unless (prj == prj') $ throwE "Note project recipients mismatch context's project" - unless (localRecipProject lprSet) $ throwE "Note context's project not addressed" - unless (localRecipProjectFollowers lprSet) $ throwE "Note context's project followers not addressed" + unless (localRecipProject $ localRecipProjectDirect lprSet) $ throwE "Note context's project not addressed" + unless (localRecipProjectFollowers $ localRecipProjectDirect lprSet) $ throwE "Note context's project followers not addressed" (num', ltrSet) <- verifySingleton (localRecipTicketRelated lprSet) "Note ticket-related recipient sets" unless (num == num') $ throwE "Note project recipients mismatch context's ticket number" - case ltrSet of - OnlyTicketParticipants -> throwE "Note ticket participants not addressed" - OnlyTicketTeam -> throwE "Note ticket team not addressed" - BothTicketParticipantsAndTeam -> return () + unless (localRecipTicketTeam ltrSet) $ + throwE "Note ticket team not addressed" + unless (localRecipTicketFollowers ltrSet) $ + throwE "Note ticket participants not addressed" let rest = deleteBy ((==) `on` fst) (shr, lsrSet) recips - orig = if localRecipSharer lsrSet then Just shr else Nothing + orig = if localRecipSharer $ localRecipSharerDirect lsrSet then Just shr else Nothing catMaybes . (orig :) <$> traverse (atMostSharer "Note with unrelated non-sharer recipients") rest where verifySingleton :: Monad m => [a] -> Text -> ExceptT Text m a diff --git a/src/Vervis/API/Recipient.hs b/src/Vervis/API/Recipient.hs new file mode 100644 index 0000000..95a522c --- /dev/null +++ b/src/Vervis/API/Recipient.hs @@ -0,0 +1,277 @@ +{- This file is part of Vervis. + - + - Written in 2019 by fr33domlover . + - + - ♡ 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 + - . + -} + +module Vervis.API.Recipient + ( LocalTicketDirectSet (..) + , LocalProjectDirectSet (..) + , LocalProjectRelatedSet (..) + , LocalSharerDirectSet (..) + , LocalSharerRelatedSet (..) + , LocalRecipientSet + , parseRecipients + ) +where + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans.Except +import Data.Bifunctor +import Data.Either +import Data.Foldable +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) + +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T + +import Network.FedURI +import Yesod.ActivityPub +import Yesod.FedURI +import Yesod.MonadSite + +import Data.List.NonEmpty.Local + +import Vervis.Foundation +import Vervis.Model.Ident + +------------------------------------------------------------------------------- +-- Actor and collection-of-persons 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 LocalActor + = LocalActorSharer ShrIdent + | LocalActorProject ShrIdent PrjIdent + +parseLocalActor :: Route App -> Maybe LocalActor +parseLocalActor (SharerR shr) = Just $ LocalActorSharer shr +parseLocalActor (ProjectR shr prj) = Just $ LocalActorProject shr prj +parseLocalActor _ = Nothing + +data LocalPersonCollection + = LocalPersonCollectionProjectTeam ShrIdent PrjIdent + | LocalPersonCollectionProjectFollowers ShrIdent PrjIdent + | LocalPersonCollectionTicketTeam ShrIdent PrjIdent Int + | LocalPersonCollectionTicketFollowers ShrIdent PrjIdent Int + +parseLocalPersonCollection + :: Route App -> Maybe LocalPersonCollection +parseLocalPersonCollection (ProjectTeamR shr prj) = + Just $ LocalPersonCollectionProjectTeam shr prj +parseLocalPersonCollection (ProjectFollowersR shr prj) = + Just $ LocalPersonCollectionProjectFollowers shr prj +parseLocalPersonCollection (TicketTeamR shr prj num) = + Just $ LocalPersonCollectionTicketTeam shr prj num +parseLocalPersonCollection (TicketParticipantsR shr prj num) = + Just $ LocalPersonCollectionTicketFollowers shr prj num +parseLocalPersonCollection _ = Nothing + +parseLocalRecipient + :: Route App -> Maybe (Either LocalActor LocalPersonCollection) +parseLocalRecipient r = + Left <$> parseLocalActor r <|> Right <$> parseLocalPersonCollection r + +------------------------------------------------------------------------------- +-- 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 LocalTicketRecipientDirect = LocalTicketTeam | LocalTicketFollowers + deriving (Eq, Ord) + +data LocalProjectRecipientDirect + = LocalProject + | LocalProjectTeam + | LocalProjectFollowers + deriving (Eq, Ord) + +data LocalProjectRecipient + = LocalProjectDirect LocalProjectRecipientDirect + | LocalTicketRelated Int LocalTicketRecipientDirect + deriving (Eq, Ord) + +data LocalSharerRecipientDirect + = LocalSharer + deriving (Eq, Ord) + +data LocalSharerRecipient + = LocalSharerDirect LocalSharerRecipientDirect + | LocalProjectRelated PrjIdent LocalProjectRecipient + deriving (Eq, Ord) + +data LocalGroupedRecipient = LocalSharerRelated ShrIdent LocalSharerRecipient + deriving (Eq, Ord) + +groupedRecipientFromActor :: LocalActor -> LocalGroupedRecipient +groupedRecipientFromActor (LocalActorSharer shr) = + LocalSharerRelated shr $ LocalSharerDirect LocalSharer +groupedRecipientFromActor (LocalActorProject shr prj) = + LocalSharerRelated shr $ LocalProjectRelated prj $ + LocalProjectDirect LocalProject + +groupedRecipientFromCollection + :: LocalPersonCollection -> LocalGroupedRecipient +groupedRecipientFromCollection + (LocalPersonCollectionProjectTeam shr prj) = + LocalSharerRelated shr $ LocalProjectRelated prj $ + LocalProjectDirect LocalProjectTeam +groupedRecipientFromCollection + (LocalPersonCollectionProjectFollowers shr prj) = + LocalSharerRelated shr $ LocalProjectRelated prj $ + LocalProjectDirect LocalProjectFollowers +groupedRecipientFromCollection + (LocalPersonCollectionTicketTeam shr prj num) = + LocalSharerRelated shr $ LocalProjectRelated prj $ + LocalTicketRelated num LocalTicketTeam +groupedRecipientFromCollection + (LocalPersonCollectionTicketFollowers shr prj num) = + LocalSharerRelated shr $ LocalProjectRelated prj $ + LocalTicketRelated num LocalTicketFollowers + +------------------------------------------------------------------------------- +-- 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 LocalTicketDirectSet = LocalTicketDirectSet + { localRecipTicketTeam :: Bool + , localRecipTicketFollowers :: Bool + } + +data LocalProjectDirectSet = LocalProjectDirectSet + { localRecipProject :: Bool + , localRecipProjectTeam :: Bool + , localRecipProjectFollowers :: Bool + } + +data LocalProjectRelatedSet = LocalProjectRelatedSet + { localRecipProjectDirect :: LocalProjectDirectSet + , localRecipTicketRelated :: [(Int, LocalTicketDirectSet)] + } + +data LocalSharerDirectSet = LocalSharerDirectSet + { localRecipSharer :: Bool + } + +data LocalSharerRelatedSet = LocalSharerRelatedSet + { localRecipSharerDirect :: LocalSharerDirectSet + , localRecipProjectRelated :: [(PrjIdent, LocalProjectRelatedSet)] + } + +type LocalRecipientSet = [(ShrIdent, LocalSharerRelatedSet)] + +groupLocalRecipients :: [LocalGroupedRecipient] -> LocalRecipientSet +groupLocalRecipients + = map (second lsr2set) + . groupAllExtract + (\ (LocalSharerRelated shr _) -> shr) + (\ (LocalSharerRelated _ lsr) -> lsr) + where + lsr2set = uncurry mk . partitionEithers . map lsr2e . NE.toList + where + lsr2e (LocalSharerDirect d) = Left d + lsr2e (LocalProjectRelated prj lpr) = Right (prj, lpr) + mk ds ts = + LocalSharerRelatedSet + (lsrs2set ds) + (map (second lpr2set) $ groupWithExtract fst snd ts) + where + lsrs2set = foldl' f initial + where + initial = LocalSharerDirectSet False + f s LocalSharer = s { localRecipSharer = True } + lpr2set = uncurry mk . partitionEithers . map lpr2e . NE.toList + where + lpr2e (LocalProjectDirect d) = Left d + lpr2e (LocalTicketRelated num ltrs) = Right (num, ltrs) + mk ds ts = + LocalProjectRelatedSet + (lprs2set ds) + (map (second ltrs2set) $ groupWithExtract fst snd ts) + where + lprs2set = foldl' f initial + where + initial = LocalProjectDirectSet False False False + f s LocalProject = + s { localRecipProject = True } + f s LocalProjectTeam = + s { localRecipProjectTeam = True } + f s LocalProjectFollowers = + s { localRecipProjectFollowers = True } + ltrs2set = foldl' f initial + where + initial = LocalTicketDirectSet False False + f s LocalTicketTeam = + s { localRecipTicketTeam = True } + f s LocalTicketFollowers = + s { localRecipTicketFollowers = True } + +------------------------------------------------------------------------------- +-- Parse URIs into a grouped recipient set +------------------------------------------------------------------------------- + +parseRecipients + :: (MonadSite m, SiteEnv m ~ App) + => NonEmpty FedURI + -> ExceptT Text m (LocalRecipientSet, [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 (renderFedURI . l2f 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 :: Text -> NonEmpty FedURI -> ([LocalURI], [FedURI]) + splitRecipients home recips = + let (local, remote) = NE.partition ((== home) . furiHost) recips + in (map (snd . f2l) local, remote) + + parseLocalRecipients + :: [LocalURI] -> ([LocalURI], [Route App], LocalRecipientSet) + parseLocalRecipients lus = + let (lusInvalid, routes) = partitionEithers $ map parseRoute lus + (routesInvalid, recips) = partitionEithers $ map parseRecip routes + (actors, collections) = partitionEithers recips + grouped = + map groupedRecipientFromActor actors ++ + map groupedRecipientFromCollection collections + 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 diff --git a/vervis.cabal b/vervis.cabal index 013b5ff..14aa24c 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -116,6 +116,7 @@ library Vervis.ActivityPub Vervis.ActorKey Vervis.API + Vervis.API.Recipient Vervis.Application Vervis.Avatar Vervis.BinaryBody