fix(lms): prevent duplicated LmsIdents and Letter sending

models/print.model

@@ -8,5 +8,6 @@ PrintJob
   sender        UserId Maybe          OnDeleteSetNull OnUpdateCascade   -- senders and associations are optional
   course        CourseId Maybe        OnDeleteCascade OnUpdateCascade
   qualification QualificationId Maybe OnDeleteCascade OnUpdateCascade
-  lmsUser       LmsUserId       Maybe OnDeleteCascade OnUpdateCascade   -- allows tracking if recipient has been notified
+  lmsUser       LmsUserId       Maybe OnDeleteCascade OnUpdateCascade   -- allows tracking if recipient has been notified; must be unique
+  -- UniquePrintJobLmsUser lmsUser
   deriving Generic

src/Database/Esqueleto/Utils.hs

@@ -26,6 +26,7 @@ module Database.Esqueleto.Utils
   , maybe, maybe2, maybeEq, guardMaybe, unsafeCoalesce
   , bool
   , max, min
+  , greatest
   , abs
   , SqlProject(..)
   , (->.), (#>>.)
@@ -323,7 +324,6 @@ orderByOrd = orderByList $ List.sort universeF
 orderByEnum :: (Enum a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
 orderByEnum = orderByList $ List.sortOn fromEnum universeF
 
-
 lower :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s)
 lower = E.unsafeSqlFunction "LOWER"
 
@@ -423,6 +423,7 @@ bool onFalse onTrue val = E.case_
   ]
   (E.else_ onFalse)
 
+-- called see greatest and least within postgresql
 max, min :: PersistField a
          => E.SqlExpr (E.Value a)
          -> E.SqlExpr (E.Value a)
@@ -430,6 +431,12 @@ max, min :: PersistField a
 max a b = bool a b $ b E.>. a
 min a b = bool a b $ b E.<. a
 
+
+greatest :: PersistField a => (E.SqlExpr (E.Value a), E.SqlExpr (E.Value a)) -> E.SqlExpr (E.Value a)
+greatest = E.unsafeSqlFunction "GREATEST" . E.toArgList
+
+
+
 abs :: (PersistField a, Num a)
     => E.SqlExpr (E.Value a)
     -> E.SqlExpr (E.Value a)

src/Handler/LMS.hs

@@ -315,12 +315,13 @@ lmsTableQuery :: QualificationId -> LmsTableExpr -> E.SqlQuery ( E.SqlExpr (Enti
                                                                , E.SqlExpr (Maybe (Entity PrintJob))
                                                                )
 lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` printJob) = do
-  E.on $ lmsUser E.?. LmsUserId E.=?. printJob E.?. PrintJobLmsUser  
+    -- E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting
-  E.on $ user E.^. UserId E.=?. lmsUser  E.?. LmsUserUser
+    E.on $ lmsUser E.?. LmsUserId E.=?. printJob E.?. PrintJobLmsUser  
-          E.&&. E.val qid E.=?. lmsUser  E.?. LmsUserQualification            -- NOTE: condition was once erroneously placed in where-clause
+    E.on $ user E.^. UserId E.=?. lmsUser  E.?. LmsUserUser
-  E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
+            E.&&. E.val qid E.=?. lmsUser  E.?. LmsUserQualification            -- NOTE: condition was once erroneously placed in where-clause
-  E.where_ $    E.val qid E.==. qualUser E.^. QualificationUserQualification
+    E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser  
-  return (qualUser, user, lmsUser, printJob)
+    E.where_ $    E.val qid E.==. qualUser E.^. QualificationUserQualification      
+    return (qualUser, user, lmsUser, printJob)
 
 
 mkLmsTable :: forall h p cols act act'.
@@ -361,7 +362,8 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
       , single ("lms-datepin" , SortColumn $ queryLmsUser  >>> (E.?. LmsUserDatePin))
       , single ("lms-received", SortColumn $ queryLmsUser  >>> (E.?. LmsUserReceived))
       --, single ("lms-notified", SortColumn $ queryLmsUser  >>> (E.?. LmsUserNotified))
-      , single ("lms-notified", SortColumn $ \row -> E.coalesce [queryPrintJob row E.?. PrintJobAcknowledged, queryLmsUser row E.?. LmsUserNotified])
+      , single ("lms-notified", SortColumn $ \row -> E.coalesce [queryPrintJob row E.?. PrintJobAcknowledged, queryLmsUser row E.?. LmsUserNotified])    -- prefer printJob acknowledgement date, if it exists
+      -- , single ("lms-notified", SortColumn $ \row -> E.greatest (queryPrintJob row E.?. PrintJobAcknowledged, queryLmsUser row E.?. LmsUserNotified)) -- bad idea, since resending increase notifyDate but just schedules yet another print job
       , single ("lms-ended"   , SortColumn $ queryLmsUser  >>> (E.?. LmsUserEnded))
       ]
     dbtFilter = mconcat
@@ -490,7 +492,8 @@ postLmsR sid qsh = do
               --   - Letter sent    : LmsUserNotified == Just _  && PrintJobId == Just _ && PrintJobAcknowledged == Just _
               let notifyDate  = join $ row ^? resultLmsUser  . _entityVal . _lmsUserNotified
                   letterDate  = join $ row ^? resultPrintJob . _entityVal . _printJobAcknowledged
-                  letterSent  = isJust (row ^? resultPrintJob . _entityKey) -- note the difference to letterDate! 
+                  -- letterSent  = isJust (row ^? resultPrintJob . _entityKey) && (isNothing letterDate || letterDate > notifyDate) -- bad idea, since a resending increase notifyDay but just reschedules a print job
+                  letterSent  = isJust (row ^? resultPrintJob . _entityKey)    -- note the difference to letterDate! 
                   notNotified = isNothing notifyDate
                   cIcon       = iconFixedCell $ iconLetterOrEmail letterSent
                   cDate       = if letterSent

src/Handler/Utils/LMS.hs

@@ -15,7 +15,8 @@ module Handler.Utils.LMS
   , csvFilenameLmsResult
   , lmsUserToDelete, _lmsUserToDelete
   , lmsUserToDeleteExpr
-  , randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries
+  , randomLMSIdent, randomLMSIdentBut
+  , randomLMSpw, maxLmsUserIdentRetries
   ) where
 
 -- general utils for LMS Interface Handlers
@@ -25,6 +26,7 @@ import Handler.Utils
 import Handler.Utils.Csv
 import Data.Csv (HasHeader(..), FromRecord)
 
+import qualified Data.Set as Set  (notMember)
 import qualified Database.Esqueleto.Legacy as E
 
 import Control.Monad.Random.Class (uniform)
@@ -134,6 +136,13 @@ randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range
 randomLMSIdent :: MonadIO m => m LmsIdent
 randomLMSIdent = LmsIdent <$> randomText [] lengthIdent
 
+randomLMSIdentBut :: MonadIO m => Set LmsIdent -> m (Maybe LmsIdent)
+randomLMSIdentBut banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk
+  where     
+    getIdentOk = do 
+      l <- randomLMSIdent
+      return $ toMaybe (Set.notMember l banList) l
+
 randomLMSpw :: MonadIO m => m Text
 randomLMSpw = randomText extra lengthPassword
   where

src/Jobs/Handler/LMS.hs

@@ -18,8 +18,10 @@ import qualified Database.Esqueleto.Experimental as E
 -- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant
 import qualified Database.Esqueleto.Utils as E
 
+import qualified Data.Set as Set
+
 import Handler.Utils.DateTime 
-import Handler.Utils.LMS (randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries)
+import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries)
 
 import qualified Data.CaseInsensitive as CI
 
@@ -84,8 +86,18 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
   where
     act :: YesodJobDB UniWorX ()
     act = do      
+      identsInUseVs <- E.select $ do 
+        lui <- E.from $
+          ( (E.^. LmsUserlistIdent) <$> E.from (E.table @LmsUserlist) )
+          `E.union_` 
+          ( (E.^. LmsResultIdent)   <$> E.from (E.table @LmsResult) )
+          `E.union_` 
+          ( (E.^. LmsUserIdent)     <$> E.from (E.table @LmsUser) )
+        E.orderBy [E.asc lui]
+        pure lui
       now <- liftIO getCurrentTime
-      let mkLmsUser lid lpin = LmsUser
+      let identsInUse = Set.fromList (E.unValue <$> identsInUseVs)
+          mkLmsUser lpin lid = LmsUser
             { lmsUserQualification = qid
             , lmsUserUser          = uid
             , lmsUserIdent         = lid
@@ -99,7 +111,9 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
             , lmsUserEnded         = Nothing
             }
           -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser))
-          startLmsUser = E.insertUniqueEntity =<< (mkLmsUser <$> randomLMSIdent <*> randomLMSpw)
+          startLmsUser = do 
+            pw <- randomLMSpw
+            maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser pw) (randomLMSIdentBut identsInUse)
       inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
       case inserted of
         Nothing  -> do

src/Utils/Print.hs

@@ -284,6 +284,7 @@ sendLetter printJobName pdf (printJobRecipient, printJobSender) printJobCourse p
       return $ Left err
     Right ok -> do      
       printJobCreated <- liftIO getCurrentTime
+      updateWhere [PrintJobLmsUser ==. printJobLmsUser] [PrintJobLmsUser =. Nothing] -- only one printJob per LmsUser is allowed, since otherwise the qualification table contains double rows
       insert_ PrintJob {..}
       return $ Right (ok, printJobFilename)
 

test/Database/Fill.hs

@@ -523,7 +523,7 @@ fillDb = do
   void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True  now
   void . insert' $ LmsUserlist qid_f (LmsIdent "ijk"    ) False now
   lujost   <- insert' $ LmsUser qid_f jost        (LmsIdent "ijk"    ) "123" False now Nothing                           now Nothing    (Just $ n_day' (-7)) (Just $ n_day' (-5))
-  luvaupel <- insert' $ LmsUser qid_f svaupel     (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1)     now (Just now) Nothing Nothing
+  luvaupel <- insert' $ LmsUser qid_f svaupel     (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1)     now (Just now) (Just $ n_day' 0) Nothing
   void .      insert' $ LmsUser qid_f gkleen      (LmsIdent "hijklmn") "@#!" True  now (Just $ LmsBlocked $ utctDay now) now (Just now) (Just $ n_day' (-1)) Nothing
   lutina <-   insert' $ LmsUser qid_f tinaTester  (LmsIdent "qwvu")  "45678" True  now (Just $ LmsSuccess $ n_day (-2))  now (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing
   void .      insert' $ LmsUser qid_f maxMuster   (LmsIdent "xyz")  "a1b2c3" False now (Just $ LmsBlocked $ n_day (-1))  now (Just $ n_day' (-2)) Nothing Nothing
@@ -535,7 +535,9 @@ fillDb = do
   void . insert $ PrintJob "TestJob4" "job4" "No Text herein." (n_day' (-2)) Nothing (Just jost)    Nothing         Nothing Nothing      Nothing
   void . insert $ PrintJob "TestJob5" "job5" "No Text herein." (n_day' (-4)) Nothing (Just jost)    (Just svaupel)  Nothing (Just qid_r) (Just lutina)
   void . insert $ PrintJob "TestJob6" "job6" "No Text herein." (n_day' (-4)) Nothing (Just svaupel) Nothing         Nothing (Just qid_r) Nothing
-  void . insert $ PrintJob "TestJob7" "job7" "No Text herein." (n_day' (-4)) (Just $ n_day' (-2)) (Just svaupel) Nothing         Nothing Nothing      (Just luvaupel)
+  void . insert $ PrintJob "TestJob7" "job7" "No Text herein." (n_day' (-4)) (Just $ n_day' (-8)) (Just svaupel) Nothing         Nothing Nothing      (Just luvaupel)
+  void . insert $ PrintJob "TestJob8" "job8" "No Text herein." (n_day' (-2)) (Just $ n_day' (-6)) (Just svaupel) Nothing         Nothing Nothing      (Just luvaupel)
+  void . insert $ PrintJob "TestJob8" "job8" "No Text herein." (n_day' (-1)) Nothing              (Just svaupel) Nothing         Nothing Nothing      (Just luvaupel)
 
 
   let