fix(lms): prevent duplicated LmsIdents and Letter sending
This commit is contained in:
Steffen Jost
parent
11fb129f2e
commit
1731d22ba5
@ -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
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user