From 1731d22ba56045fd1c636e2897748faa735053e6 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 30 Sep 2022 18:21:55 +0200 Subject: [PATCH] fix(lms): prevent duplicated LmsIdents and Letter sending --- models/print.model | 3 ++- src/Database/Esqueleto/Utils.hs | 9 ++++++++- src/Handler/LMS.hs | 19 +++++++++++-------- src/Handler/Utils/LMS.hs | 11 ++++++++++- src/Jobs/Handler/LMS.hs | 22 ++++++++++++++++++---- src/Utils/Print.hs | 1 + test/Database/Fill.hs | 6 ++++-- 7 files changed, 54 insertions(+), 17 deletions(-) diff --git a/models/print.model b/models/print.model index 201256662..6737f7002 100644 --- a/models/print.model +++ b/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 \ No newline at end of file diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 455076082..228179f9c 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/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) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 5830b030a..6d533ee8a 100644 --- a/src/Handler/LMS.hs +++ b/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.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser - E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause - E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser - E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification - return (qualUser, user, lmsUser, printJob) + -- E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting + E.on $ lmsUser E.?. LmsUserId E.=?. printJob E.?. PrintJobLmsUser + E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser + E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause + E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser + 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 diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 7556085ca..f04c18097 100644 --- a/src/Handler/Utils/LMS.hs +++ b/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 diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 61b9b1477..36e39274c 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/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 @@ -83,9 +85,19 @@ dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act where act :: YesodJobDB UniWorX () - act = do + 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 diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 4eb168247..f9004d264 100644 --- a/src/Utils/Print.hs +++ b/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) diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 07f419054..5d94587e6 100644 --- a/test/Database/Fill.hs +++ b/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