fix(lms): do not delete orphans with all numerical idents

lms idents with all numerical idents are used for testing and thus should not be deleted, even if orphaned

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)

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

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")