C2S: Handle recipient grouping in dedicated Vervis.API.Recipient module

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
+        (localsSet, remotes) <- parseRecipients recips
-        let (localsParsed, localsRest) = parseLocalRecipients locals
+        let (hContext, luContext) = f2l uContext
-        unless (null localsRest) $
-            throwE "Note has invalid local recipients"
-        let localsSet = groupLocalRecipients localsParsed
-            (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 (localRecipProject $ localRecipProjectDirect lprSet) $ throwE "Note context's project not addressed"
-            unless (localRecipProjectFollowers lprSet) $ throwE "Note context's project followers 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
+            unless (localRecipTicketTeam ltrSet) $
-                OnlyTicketParticipants -> throwE "Note ticket participants not addressed"
+                throwE "Note ticket team not addressed"
-                OnlyTicketTeam -> throwE "Note ticket team not addressed"
+            unless (localRecipTicketFollowers ltrSet) $
-                BothTicketParticipantsAndTeam -> return ()
+                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

src/Vervis/API/Recipient.hs

@@ -0,0 +1,277 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 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/>.
+ -}
+
+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

vervis.cabal

@@ -116,6 +116,7 @@ library
                        Vervis.ActivityPub
                        Vervis.ActorKey
                        Vervis.API
+                       Vervis.API.Recipient
                        Vervis.Application
                        Vervis.Avatar
                        Vervis.BinaryBody