diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 6e523eb3f..c22b2eb0c 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -9,6 +9,7 @@ module Database.Esqueleto.Utils ( true, false , vals, justVal, justValList, toValues , isJust, alt + , isNumerical, hasLetter , isInfixOf, hasInfix , isPrefixOf_, hasPrefix_ , strConcat, substring @@ -175,21 +176,28 @@ infixl 4 <~. infixr 2 ~., ~*., !~., !~*. -- | PostgreSQL regular expression match, case sensitive. Works, but may throw SQL error for unblanced parenthesis, etc. Not suitable for dbTable filters -(~.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool) +(~.) :: (E.SqlString s, E.SqlString t) => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value t) -> E.SqlExpr (E.Value Bool) (~.) = E.unsafeSqlBinOp " ~ " -- | PostgreSQL regular expression match, case insensitive. Works, but may throw SQL errors -(~*.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool) +(~*.) :: (E.SqlString s, E.SqlString t) => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value t) -> E.SqlExpr (E.Value Bool) (~*.) = E.unsafeSqlBinOp " ~* " -- | PostgreSQL regular expression does not match, case sensitive. Works, but may throw SQL error for unblanced parenthesis, etc. Not suitable for dbTable filters -(!~.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool) +(!~.) :: (E.SqlString s, E.SqlString t) => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value t) -> E.SqlExpr (E.Value Bool) (!~.) = E.unsafeSqlBinOp " !~ " -- | PostgreSQL regular expression does not match, case insensitive. Works, but may throw SQL errors -(!~*.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool) +(!~*.) :: (E.SqlString s, E.SqlString t) => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value t) -> E.SqlExpr (E.Value Bool) (!~*.) = E.unsafeSqlBinOp " !~* " +-- | PostgreSQL regex test if value contains only numbers +isNumerical :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool) +isNumerical = (~. E.val ("^[0-9]+$"::Text)) + +-- | PostgreSQL regex test if value contains at least one letter +hasLetter :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool) +hasLetter = (~*. E.val ("[a-z]"::Text)) -- | Negation of `isNothing` which is missing isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index 9ee5b200b..293eeea5e 100644 --- a/src/Handler/LMS/Learners.hs +++ b/src/Handler/LMS/Learners.hs @@ -20,6 +20,7 @@ import Handler.Utils.LMS import qualified Data.Map as Map import qualified Data.Csv as Csv +import qualified Data.Char as Char import qualified Data.Text as Text import qualified Data.Conduit.List as C import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma @@ -40,7 +41,7 @@ lmsUserDelete2csv lid = LmsUserTableCsv { csvLUTident = lid , csvLUTpin = "00000000" , csvLUTresetPin = LmsBool False - , csvLUTdelete = LmsBool True + , csvLUTdelete = LmsBool $ isJust $ Text.find Char.isLetter $ getLmsIdent lid -- safety-catch: do not delete LMS Test-users, FRADrive LMS Idents always contain at least one letter , csvLUTstaff = LmsBool False , csvLUTresetTries= LmsBool False , csvLUTlock = LmsBool True @@ -198,6 +199,7 @@ selectOrphans qid now = do $(E.unValueN 2) <<$>> (Ex.select $ do orv <- Ex.from $ Ex.table @LmsOrphan Ex.where_ $ Ex.val qid E.==. orv Ex.^. LmsOrphanQualification + Ex.&&. E.hasLetter (orv Ex.^. LmsOrphanIdent) -- do not delete LMS Test-users, FRADrive LMS Idents always contain at least one letter Ex.&&. Ex.val cutoff_seen_first E.>=. orv Ex.^. LmsOrphanSeenFirst -- has been seen for while Ex.&&. Ex.val cutoff_seen_last E.<=. orv Ex.^. LmsOrphanSeenLast -- was still seen recently Ex.&&. Ex.val cutoff_deleted_last E.>~. orv Ex.^. LmsOrphanDeletedLast -- not already recently deleted diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index dbe30ee91..22083cbc1 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -802,6 +802,7 @@ fillDb = do void . insert' $ LmsOrphan qid_f (LmsIdent "no-del-4") (n_day' (-128)) now (Just now) LmsPassed (Just "no transmit 4") void . insert' $ LmsOrphan qid_f (LmsIdent "do-del-5") (n_day' (-128)) now (Just (n_day' (-100))) LmsPassed (Just "do transmit 5") void . insert' $ LmsOrphan qid_f (LmsIdent "no-del-6") (n_day' ( -5)) now (Just (n_day' ( -3))) LmsFailed (Just "no transmit 6") + void . insert' $ LmsOrphan qid_f (LmsIdent "12345678") (n_day' (-128)) now (Just (n_day' (-100))) LmsPassed (Just "no transmit 7") void . insert $ PrintJob "TestJob1" "AckTestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing Nothing (Just svaupel) Nothing (Just qid_f) Nothing void . insert $ PrintJob "TestJob2" "AckTestJob2" "job2" "No Text herein." (n_day' (-3)) (Just $ n_day' (-1)) (Just jost) (Just svaupel) Nothing Nothing (Just qid_f) (Just $ LmsIdent "ijk")