From bf53c639e73d480b093e5f501df3fd4d0539fdda Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 6 Sep 2023 15:58:18 +0000 Subject: [PATCH] chore(table): allow compulsory multi filter criteria --- .../utils/table_column/de-de-formal.msg | 4 +++- messages/uniworx/utils/table_column/en-eu.msg | 4 +++- src/Database/Esqueleto/Utils.hs | 24 ++++++++++++++++--- src/Handler/LMS.hs | 2 +- src/Handler/LMS/Learners.hs | 6 ++--- src/Handler/LMS/Report.hs | 6 ++--- src/Handler/PrintCenter.hs | 24 +++++++++---------- src/Handler/Utils/Table/Columns.hs | 16 ++++++------- src/Utils/Set.hs | 1 + 9 files changed, 55 insertions(+), 32 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 16d43de61..fdf42b885 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -85,4 +85,6 @@ TableJobLockTime: Bearbeitung seit TableJobLockInstance: Bearbeiter TableJobCreationInstance: Ersteller ActJobDelete: Job entfernen -TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} Jobs entfernt \ No newline at end of file +TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} Jobs entfernt +TableFilterComma: Es können mehrere alternative Suchkriterien mit Komma getrennt angegeben werden, wovon mindestens eines erfüllt werden muss. +TableFilterCommaPlus: Mehrere alternative Suchkriterien mit Komma trennen. Mindestens ein Suchkriterium muss erfüllt werden, zusätzlich zu allen Suchkriterien mit vorangestelltem Plus-Symbol. \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 17fbfe79a..b4fe83d34 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -85,4 +85,6 @@ TableJobLockTime: Lock time TableJobLockInstance: Worker TableJobCreationInstance: Creator ActJobDelete: Delete job -TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} queued jobs deleted \ No newline at end of file +TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} queued jobs deleted +TableFilterComma: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled. +TableFilterCommaPlus: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled in addition to all criteria preceded by a plus symbol. \ No newline at end of file diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 1bb146c21..b2e077453 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -21,7 +21,8 @@ module Database.Esqueleto.Utils , mkExactFilter, mkExactFilterWith , mkExactFilterLast, mkExactFilterLastWith , mkExactFilterMaybeLast - , mkContainsFilter, mkContainsFilterWith, mkContainsFilterWithSet, mkContainsFilterWithComma + , mkContainsFilter, mkContainsFilterWith + , mkContainsFilterWithSet, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus , mkDayFilter, mkDayFilterFrom, mkDayFilterTo , mkExistsFilter , anyFilter, allFilter @@ -62,6 +63,7 @@ import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Internal.Internal as E import Database.Esqueleto.Utils.TH +import qualified Data.Text as Text import qualified Data.Text.Lazy as Lazy (Text) import qualified Data.ByteString.Lazy as Lazy (ByteString) @@ -350,10 +352,26 @@ mkContainsFilterWithComma :: (E.SqlString b, Ord b) -> t -- ^ query row -> Set.Set Text -- ^ needle collection -> E.SqlExpr (E.Value Bool) -mkContainsFilterWithComma cast lenslike row criterias +mkContainsFilterWithComma cast lenslike row (concatMapSet commaSeparatedText -> criterias) | Set.null criterias = true - | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList (concatMapSet commaSeparatedText criterias)) + | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias) +-- | like `mkContainsFilterWithComma` but enforced the existence of all Texts prefixed with + +mkContainsFilterWithCommaPlus :: (E.SqlString b, Ord b) + => (Text -> b) + -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element + -> t -- ^ query row + -> Set.Set Text -- ^ needle collection + -> E.SqlExpr (E.Value Bool) +mkContainsFilterWithCommaPlus cast lenslike row (concatMapSet commaSeparatedText -> criterias) + | Set.null criterias = true + | Set.null compulsories = cond_optional + | Set.null alternatives = cond_compulsory + | otherwise = cond_compulsory E.&&. cond_optional + where + (Set.mapMonotonic (Text.stripStart . Text.drop 1) -> compulsories, alternatives) = Set.partition (Text.isPrefixOf "+") criterias + cond_compulsory = all (hasInfix $ lenslike row) (E.val . cast <$> Set.toList compulsories) + cond_optional = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList alternatives) mkDayFilter :: (t -> E.SqlExpr (E.Value UTCTime)) -- ^ getter from query to searched element -> t -- ^ query row diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 6a580c03a..2e7b27b3c 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -476,7 +476,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser - , single ("ident" , FilterColumn . E.mkContainsFilterWithComma LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent)) + , single ("ident" , FilterColumn . E.mkContainsFilterWithCommaPlus LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent)) , single ("status" , FilterColumn . E.mkExactFilterMaybeLast $ views (to queryLmsUser) (E.^. LmsUserStatus)) -- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil))) , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index 2fd7f167c..2e97eb655 100644 --- a/src/Handler/LMS/Learners.hs +++ b/src/Handler/LMS/Learners.hs @@ -124,11 +124,11 @@ mkUserTable _sid qsh qid = do , (csvLmsLock , SortColumn lmsUserToLockExpr) ] dbtFilter = Map.fromList - [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWithComma LmsIdent (E.^. LmsUserIdent )) - , (csvLmsResetPin , FilterColumn $ E.mkExactFilterLast (E.^. LmsUserResetPin)) + [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWithCommaPlus LmsIdent (E.^. LmsUserIdent )) + , (csvLmsResetPin , FilterColumn $ E.mkExactFilterLast (E.^. LmsUserResetPin)) ] dbtFilterUI = \mPrev -> mconcat - [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) + [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus) , prismAForm (singletonFilter csvLmsResetPin . maybePrism _PathPiece) mPrev $ aopt (hoistField lift (boolField . Just $ SomeMessage MsgBoolIrrelevant)) (fslI MsgTableLmsResetPin) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } diff --git a/src/Handler/LMS/Report.hs b/src/Handler/LMS/Report.hs index 060859d5b..eb3964e40 100644 --- a/src/Handler/LMS/Report.hs +++ b/src/Handler/LMS/Report.hs @@ -120,11 +120,11 @@ mkReportTable sid qsh qid = do , (csvLmsTimestamp, SortColumn (E.^. LmsReportTimestamp)) ] dbtFilter = Map.fromList - [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWithComma LmsIdent (E.^. LmsReportIdent)) - , (csvLmsDate , FilterColumn $ E.mkExactFilter (E.^. LmsReportDate)) + [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWithCommaPlus LmsIdent (E.^. LmsReportIdent)) + , (csvLmsDate , FilterColumn $ E.mkExactFilter (E.^. LmsReportDate)) ] dbtFilterUI = \mPrev -> mconcat - [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) + [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus) , prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableLmsDate) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 0bdbf0c48..083d8572d 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -223,32 +223,32 @@ mkPJTable = do , single ("lmsid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobLmsUser)) ] dbtFilter = mconcat - [ single ("name" , FilterColumn . E.mkContainsFilterWithComma id $ views (to queryPrintJob) (E.^. PrintJobName)) - , single ("apcid" , FilterColumn . E.mkContainsFilterWithComma id $ views (to queryPrintJob) (E.^. PrintJobApcIdent)) + [ single ("name" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryPrintJob) (E.^. PrintJobName)) + , single ("apcid" , FilterColumn . E.mkContainsFilterWithComma id $ views (to queryPrintJob) (E.^. PrintJobApcIdent)) , single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) , single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) --, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) - , single ("recipient" , FilterColumn . E.mkContainsFilterWithComma Just $ views (to queryRecipient) (E.?. UserDisplayName)) - , single ("sender" , FilterColumn . E.mkContainsFilterWithComma Just $ views (to querySender) (E.?. UserDisplayName)) - , single ("course" , FilterColumn . E.mkContainsFilterWithComma (Just . CI.mk) $ views (to queryCourse) (E.?. CourseName)) - , single ("qualification", FilterColumn . E.mkContainsFilterWithComma (Just . CI.mk) $ views (to queryQualification) (E.?. QualificationName)) - , single ("lmsid" , FilterColumn . E.mkContainsFilterWithComma (Just . LmsIdent) $ views (to queryPrintJob) (E.^. PrintJobLmsUser)) + , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName)) + , single ("sender" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySender) (E.?. UserDisplayName)) + , single ("course" , FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryCourse) (E.?. CourseName)) + , single ("qualification", FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryQualification) (E.?. QualificationName)) + , single ("lmsid" , FilterColumn . E.mkContainsFilterWithCommaPlus (Just . LmsIdent) $ views (to queryPrintJob) (E.^. PrintJobLmsUser)) , single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged))) ] dbtFilterUI mPrev = mconcat - [ prismAForm (singletonFilter "name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName) + [ prismAForm (singletonFilter "name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName & setTooltip MsgTableFilterCommaPlus) , prismAForm (singletonFilter "filename" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobFilename) , prismAForm (singletonFilter "created" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) --, prismAForm (singletonFilter "created" . maybePrism _PathPiece) mPrev ((,) <$> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) -- <*> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) -- ) - , prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient) - , prismAForm (singletonFilter "sender" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintSender) + , prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus) + , prismAForm (singletonFilter "sender" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintSender & setTooltip MsgTableFilterCommaPlus) , prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintCourse) , prismAForm (singletonFilter "qualification". maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintQualification) - , prismAForm (singletonFilter "lmsid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintLmsUser) - , prismAForm (singletonFilter "apcid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobApcAcknowledge) + , prismAForm (singletonFilter "lmsid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintLmsUser & setTooltip MsgTableFilterCommaPlus) + , prismAForm (singletonFilter "apcid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobApcAcknowledge & setTooltip MsgTableFilterComma) , prismAForm (singletonFilter "acknowledged" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgPrintJobAcknowledged) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout} diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index d3141e88b..280becf18 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -10,7 +10,7 @@ import Import hiding (link) import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E hiding ((->.)) -import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, mkContainsFilterWithComma, anyFilter) +import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus, anyFilter) --import Database.Esqueleto.Experimental ((:&)(..)) --import qualified Database.Esqueleto.Experimental as Ex @@ -399,9 +399,9 @@ fltrUserNameEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t fs) fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter - [ mkContainsFilterWithComma id $ queryUser >>> (E.^. UserDisplayName) - , mkContainsFilterWithComma id $ queryUser >>> (E.^. UserSurname) - , mkContainsFilterWithComma CI.mk $ queryUser >>> (E.^. UserDisplayEmail) + [ mkContainsFilterWithCommaPlus id $ queryUser >>> (E.^. UserDisplayName) + , mkContainsFilterWithCommaPlus id $ queryUser >>> (E.^. UserSurname) + , mkContainsFilterWithCommaPlus CI.mk $ queryUser >>> (E.^. UserDisplayEmail) ] ) @@ -420,7 +420,7 @@ fltrUserNameEmailUI = fltrUserNameEmailHdrUI MsgTableCourseMembers fltrUserNameEmailHdrUI :: (RenderMessage UniWorX msg) => msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrUserNameEmailHdrUI msg mPrev = - prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI msg) + prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI msg & setTooltip MsgTableFilterCommaPlus) ------------------- -- Matriculation -- @@ -436,7 +436,7 @@ sortUserMatriculation :: OpticSortColumn (Maybe UserMatriculation) sortUserMatriculation queryMatriculation = singletonMap "user-matriculation" . SortColumn $ view queryMatriculation fltrUserMatriculation :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value (Maybe UserMatriculation))) -fltrUserMatriculation queryMatriculation = singletonMap "user-matriculation" . FilterColumn . mkContainsFilterWith Just $ view queryMatriculation +fltrUserMatriculation queryMatriculation = singletonMap "user-matriculation" . FilterColumn . mkContainsFilterWithComma Just $ view queryMatriculation fltrUserMatriculationUI :: DBFilterUI fltrUserMatriculationUI mPrev = prismAForm (singletonFilter "user-matriculation") mPrev $ aopt textField (fslI MsgTableUserMatriculation) @@ -453,11 +453,11 @@ fltrUserMatriclenr :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bo ) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t fs) -fltrUserMatriclenr queryUser = ("user-matriclenumber", FilterColumn . mkContainsFilterWith Just $ queryUser >>> (E.^. UserMatrikelnummer)) +fltrUserMatriclenr queryUser = ("user-matriclenumber", FilterColumn . mkContainsFilterWithComma Just $ queryUser >>> (E.^. UserMatrikelnummer)) fltrUserMatriclenrUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrUserMatriclenrUI mPrev = - prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgTableMatrikelNr) + prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgTableMatrikelNr & setTooltip MsgTableFilterComma) ---------------- diff --git a/src/Utils/Set.hs b/src/Utils/Set.hs index 996ff1651..7fb14cdfa 100644 --- a/src/Utils/Set.hs +++ b/src/Utils/Set.hs @@ -58,6 +58,7 @@ setMapMaybe f = Set.fromList . mapMaybe f . Set.toList concatMapSet :: Ord b => (a -> Set b) -> Set a -> Set b concatMapSet f = Set.foldl ((. f) . (<>)) mempty +-- concatMapSet f = foldMap f --- requires Ord a as well -- | Symmetric difference of two sets. setSymmDiff :: Ord a => Set a -> Set a -> Set a