diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 1e8ecfe7e..63f41363e 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -347,7 +347,7 @@ mkExactFilterMaybeLast' lensexists lenslike row criterias -- | generic filter creation for dbTable -- Given a lens-like function, make filter searching for needles in String-like elements -- (Keep Set here to ensure that there are no duplicates) -mkContainsFilter :: E.SqlString a +mkContainsFilter :: (E.SqlString a, Ord a) => (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element -> t -- ^ query row -> Set.Set a -- ^ needle collection @@ -355,7 +355,7 @@ mkContainsFilter :: E.SqlString a mkContainsFilter = mkContainsFilterWith id -- | like `mkContainsFilter` but allows for conversion; convenient in conjunction with `anyFilter` and `allFilter` -mkContainsFilterWith :: E.SqlString b +mkContainsFilterWith :: (E.SqlString b, Ord a) => (a -> b) -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element -> t -- ^ query row @@ -363,7 +363,7 @@ mkContainsFilterWith :: E.SqlString b -> E.SqlExpr (E.Value Bool) mkContainsFilterWith cast lenslike row criterias | Set.null criterias = true - | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias) + | otherwise = any (hasInfix (lenslike row) . E.val . cast) criterias -- | like `mkContainsFilterWith` but allows conversion to produce multiple needles mkContainsFilterWithSet :: (E.SqlString b, Ord b, Ord a) @@ -374,7 +374,7 @@ mkContainsFilterWithSet :: (E.SqlString b, Ord b, Ord a) -> E.SqlExpr (E.Value Bool) mkContainsFilterWithSet cast lenslike row criterias | Set.null criterias = true - | otherwise = any (hasInfix $ lenslike row) (E.val <$> Set.toList (foldMap cast criterias)) + | otherwise = any (hasInfix (lenslike row) . E.val) (foldMap cast criterias) -- | like `mkContainsFilterWithSet` but fixed to comma separated Texts mkContainsFilterWithComma :: (E.SqlString b, Ord b) @@ -385,7 +385,7 @@ mkContainsFilterWithComma :: (E.SqlString b, Ord b) -> E.SqlExpr (E.Value Bool) mkContainsFilterWithComma cast lenslike row (foldMap commaSeparatedText -> criterias) | Set.null criterias = true - | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias) + | otherwise = any (hasInfix (lenslike row) . E.val . cast) criterias -- | like `mkContainsFilterWithComma` but enforced the existence of all Texts prefixed with + mkContainsFilterWithCommaPlus :: (E.SqlString b, Ord b) @@ -401,8 +401,8 @@ mkContainsFilterWithCommaPlus cast lenslike row (foldMap commaSeparatedText -> c | 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) + cond_compulsory = all (hasInfix (lenslike row) . E.val . cast) compulsories + cond_optional = any (hasInfix (lenslike row) . E.val . cast) alternatives mkDayFilter :: (t -> E.SqlExpr (E.Value UTCTime)) -- ^ getter from query to searched element -> t -- ^ query row @@ -447,7 +447,7 @@ mkExistsFilterWithComma :: PathPiece a -> E.SqlExpr (E.Value Bool) mkExistsFilterWithComma cast query row (foldMap commaSeparatedText -> criterias) | Set.null criterias = true - | otherwise = any (E.exists . query row) (cast <$> Set.toList criterias) + | otherwise = any (E.exists . query row . cast) criterias -- | Combine several filters, using logical or diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 104dbc7b2..bb24e8102 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -416,16 +416,15 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do -- E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId -- E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId -- E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo) - -- ) - -- , single ("avs-card" , FilterColumnIO $ \(queryUser -> user) (criterion :: [Text]) -> const (return E.true :: IO (E.SqlExpr (E.Value Bool))) -- putStrLn "******** IT WORKS *****************" + -- ) , single ("avs-card" , FilterColumnHandler $ \(criteria :: [Text]) -> case criteria of [] -> return (const E.true) :: Handler (QualificationTableExpr -> E.SqlExpr (E.Value Bool)) xs -> do - apids <- queryAvsCardNos $ mapMaybe parseAvsCardNo xs -- $ foldMap cfAnySeparatedSet xs TODO + let crds = mapMaybe parseAvsCardNo $ foldMap anySeparatedText xs + apids <- queryAvsCardNos crds if null apids - then - -- addMessageI ??? + then return (const E.false) else return $ \(queryUser-> user) -> @@ -463,7 +462,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do [ fltrUserNameEmailHdrUI MsgLmsUser mPrev , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) - , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo) -- & cfAnySeparatedSet + , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo & setTooltip MsgTableFilterComma) , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) , if isNothing mbRenewal then mempty diff --git a/src/Utils.hs b/src/Utils.hs index 54338f381..af114c216 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -526,6 +526,12 @@ textUnlines = Text.intercalate $ Text.singleton '\n' commaSeparatedText :: Text -> Set Text commaSeparatedText = Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.split (==',') +-- also see Utils.Form.cfAnySeparatedSet +anySeparatedText :: Text -> Set Text +anySeparatedText = Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.split anySeparator + where anySeparator :: Char -> Bool + anySeparator c = Char.isSeparator c || c == ',' || c == ';' + ----------- -- Fixed --