From bd539358bdbaadd496501918b2a66ce13ecf82ab Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 15 Sep 2022 18:44:53 +0200 Subject: [PATCH] refactor(lms): send user notifications only after lms acknowleged e-learning --- .../categories/qualification/de-de-formal.msg | 2 + .../categories/qualification/en-eu.msg | 2 + models/lms.model | 1 + src/Handler/LMS.hs | 13 +- src/Jobs/Handler/LMS.hs | 188 +++++++++--------- .../Handler/SendNotification/Qualification.hs | 6 +- test/Database/Fill.hs | 174 ++++++++-------- 7 files changed, 201 insertions(+), 185 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index bf0630997..1706eeef9 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -23,12 +23,14 @@ TableLmsDelete: Löschen? TableLmsStaff: Interner Mitarbeiter? TableLmsStarted: Begonnen TableLmsReceived: Letzte Rückmeldung +TableLmsNotified: Versand Benachrichtigung TableLmsEnded: Beended TableLmsStatus: Status E-Lernen TableLmsSuccess: Bestanden TableLmsFailed: Gesperrt FilterLmsValid: Aktuell gültig FilterLmsRenewal: Erneuerung anstehend +FilterLmsNotified: Benachrichtigt CsvColumnLmsIdent: E-Lernen Identifikator, einzigartig pro Qualifikation und Teilnehmer CsvColumnLmsPin: PIN des E-Lernen Zugangs CsvColumnLmsResetPin: Wird die PIN bei der nächsten Synchronisation zurückgesetzt? diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 9ac082788..6d89b424b 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -23,12 +23,14 @@ TableLmsDelete: Delete? TableLmsStaff: Staff? TableLmsStarted: Started TableLmsReceived: Last update +TableLmsNotified: Notification sent TableLmsEnded: Ended TableLmsStatus: Status e-learning TableLmsSuccess: Completed TableLmsFailed: Blocked FilterLmsValid: Currently valid FilterLmsRenewal: Renewal due +FilterLmsNotified: Notified CsvColumnLmsIdent: E-learning identifier, unique for each qualification and user CsvColumnLmsPin: PIN for e-learning access CsvColumnLmsResetPin: Will the e-learning PIN be reset upon next synchronisation? diff --git a/models/lms.model b/models/lms.model index 986ee5d27..18466434b 100644 --- a/models/lms.model +++ b/models/lms.model @@ -100,6 +100,7 @@ LmsUser --toDelete encoded by Handler.Utils.LMS.lmsUserToDelete started UTCTime default=now() received UTCTime Maybe -- last acknowledgement by LMS + notified UTCTime Maybe -- last notified by FRADrive ended UTCTime Maybe -- ident was deleted from LMS -- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this? UniqueLmsIdent ident -- idents must be unique accross all qualifications, since idents are global within LMS! diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 292388fca..75284be67 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -343,6 +343,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted)) , single ("lms-datepin" , SortColumn $ queryLmsUser >>> (E.?. LmsUserDatePin)) , single ("lms-received", SortColumn $ queryLmsUser >>> (E.?. LmsUserReceived)) + , single ("lms-notified", SortColumn $ queryLmsUser >>> (E.?. LmsUserNotified)) , single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded)) ] dbtFilter = mconcat @@ -356,12 +357,19 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday | otherwise -> E.true ) + , single ("lms-notified", FilterColumn $ \(view (to queryLmsUser) -> luser) criterion -> + case getLast criterion of + Just True -> E.isJust $ luser E.?. LmsUserNotified + Just False -> E.isNothing $ luser E.?. LmsUserNotified + Nothing -> E.true + ) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev - , prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) + , prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) -- , prismAForm (singletonFilter "lms-status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus) - , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) + , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) + , prismAForm (singletonFilter "lms-notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified) , if isNothing mbRenewal then mempty else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) ] @@ -446,6 +454,7 @@ postLmsR sid qsh = do , sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d , sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(preview $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> foldMap dateTimeCell d , sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d + , sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \(preview $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d , sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(preview $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell $ join d ] where diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index a23ca6467..37eae1275 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -1,15 +1,15 @@ {-# LANGUAGE TypeApplications #-} -module Jobs.Handler.LMS +module Jobs.Handler.LMS ( dispatchJobLmsQualificationsEnqueue , dispatchJobLmsQualificationsDequeue , dispatchJobLmsEnqueue, dispatchJobLmsEnqueueUser , dispatchJobLmsDequeue , dispatchJobLmsResults , dispatchJobLmsUserlist - ) where + ) where -import Import +import Import import Jobs.Queue -- import Jobs.Handler.Intervals.Utils @@ -23,198 +23,196 @@ import Handler.Utils.LMS (randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries) dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX -dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic act - where - act :: YesodJobDB UniWorX () - act = do - qids <- E.select $ do - q <- E.from $ E.table @Qualification - E.where_ $ E.isJust (q E.^. QualificationRefreshWithin) - -- E.&&. q E.^. QualificationElearningStart -- checked later, since we need to send out notifications regardless - pure $ q E.^. QualificationId - forM_ qids $ \(E.unValue -> qid) -> - queueDBJob $ JobLmsEnqueue qid +dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue + +dispatchJobLmsQualificationsDequeue :: JobHandler UniWorX +dispatchJobLmsQualificationsDequeue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsDequeue + +-- execute given job for all qualifications that allow refreshs +fetchRefreshQualifications :: (QualificationId -> Job) -> YesodJobDB UniWorX () +fetchRefreshQualifications qidJob = do + qids <- E.select $ do + q <- E.from $ E.table @Qualification + E.where_ $ E.isJust (q E.^. QualificationRefreshWithin) + pure $ q E.^. QualificationId + forM_ qids $ \(E.unValue -> qid) -> + queueDBJob $ qidJob qid --- | enlist expiring qualification holders to e-learning +-- | enlist expiring qualification holders to e-learning -- NOTE: getting rid of QualificationId parameter and using a DB-join fails, since addGregorianDurationClip cannot be performed within DB dispatchJobLmsEnqueue :: QualificationId -> JobHandler UniWorX dispatchJobLmsEnqueue qid = JobHandlerAtomic act - where + where -- act :: YesodJobDB UniWorX () act = do - $logInfoS "lms" $ "Start e-learning users for qualification " <> tshow qid <> "." + $logInfoS "lms" $ "Notifying about exipiring qualification " <> tshow qid <> "." quali <- getJust qid -- may throw an error, aborting the job - now <- liftIO getCurrentTime - case qualificationRefreshWithin quali of - Nothing -> return () -- no automatic scheduling for this qid + now <- liftIO getCurrentTime + case qualificationRefreshWithin quali of + Nothing -> return () -- no automatic scheduling for this qid (Just renewalPeriod) -> do let now_day = utctDay now renewalDate = addGregorianDurationClip renewalPeriod now_day renewalUsers <- E.select $ do - quser <- E.from $ E.table @QualificationUser - E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid + quser <- E.from $ E.table @QualificationUser + E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate E.&&. E.notExists (do luser <- E.from $ E.table @LmsUser - E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid + E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser ) pure quser - let usr_job :: Entity QualificationUser -> Job - usr_job quser = - let uid = quser ^. _entityVal . _qualificationUserUser + let usr_job :: Entity QualificationUser -> Job + usr_job quser = + let uid = quser ^. _entityVal . _qualificationUserUser uex = quser ^. _entityVal . _qualificationUserValidUntil in if qualificationElearningStart quali then JobLmsEnqueueUser { jQualification = qid, jUser = uid } - else JobSendNotification { jRecipient = uid, jNotification = + else JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationExpiry { nQualification = qid, nExpiry = uex } } forM_ renewalUsers (queueDBJob . usr_job) - case qualificationAuditDuration quali of + case qualificationAuditDuration quali of Nothing -> return () -- no automatic removal - (Just auditDuration) -> + (Just auditDuration) -> let deleteDate = addMonths auditDuration now in deleteWhere [LmsUserQualification ==. qid, LmsUserEnded !=. Nothing, LmsUserEnded >. Just deleteDate] dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX -dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act - where +dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act + where act :: YesodJobDB UniWorX () - act = do + act = do now <- liftIO getCurrentTime let mkLmsUser lid lpin = LmsUser { lmsUserQualification = qid - , lmsUserUser = uid - , lmsUserIdent = lid - , lmsUserPin = lpin - , lmsUserResetPin = False + , lmsUserUser = uid + , lmsUserIdent = lid + , lmsUserPin = lpin + , lmsUserResetPin = False , lmsUserDatePin = now , lmsUserStatus = Nothing - , lmsUserStarted = now + , lmsUserStarted = now , lmsUserReceived = Nothing - , lmsUserEnded = Nothing + , lmsUserNotified = Nothing + , lmsUserEnded = Nothing } -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser)) startLmsUser = E.insertUniqueEntity =<< (mkLmsUser <$> randomLMSIdent <*> randomLMSpw) inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser - case inserted of + case inserted of Nothing -> $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uid " <> tshow uid <> " and qid " <> tshow qid <> "!" - (Just _) -> queueDBJob JobSendNotification { jRecipient = uid, jNotification = - NotificationQualificationRenewal { nQualification = qid } - } + (Just _) -> return () -- lmsUser started, but not yet notified -dispatchJobLmsQualificationsDequeue :: JobHandler UniWorX -dispatchJobLmsQualificationsDequeue = JobHandlerAtomic act - where - act :: YesodJobDB UniWorX () - act = do - qids <- E.select $ do - q <- E.from $ E.table @Qualification - E.where_ $ E.isJust (q E.^. QualificationRefreshWithin) - -- E.&&. q E.^. QualificationElearningStart -- checked later, since we need to send out notifications regardless - pure $ q E.^. QualificationId - forM_ qids $ \(E.unValue -> qid) -> - queueDBJob $ JobLmsEnqueue qid - +-- process all received input and renew qualifications dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX dispatchJobLmsDequeue qid = JobHandlerAtomic act - -- wenn bestanden: qualification verlängern + -- wenn bestanden: qualification verlängern -- wenn Aufbewahrungszeit abgelaufen: LmsIdent löschen (verhindert verfrühten neustart) - where + where act = do - $logInfoS "lms" $ "Process e-learning results for qualification " <> tshow qid <> "." + $logInfoS "lms" $ "Processing e-learning results for qualification " <> tshow qid <> "." quali <- getJust qid -- may throw an error, aborting the job - case qualificationRefreshWithin quali of - Nothing -> return () -- no automatic scheduling for this qid + case qualificationRefreshWithin quali of + Nothing -> return () -- no automatic scheduling for this qid (usually job is not scheduled for these qualifications, see above) (Just renewalPeriod) -> do now_day <- utctDay <$> liftIO getCurrentTime let renewalDate = addGregorianDurationClip renewalPeriod now_day - - -- CONTINUE HERE: + + -- CONTINUE HERE: TODO -- select users that need renewal due to success - -- delete users after audit period has expired + -- delete users after audit period has expired!!! renewalUsers <- E.select $ do (quser E.:& luser) <- E.from $ E.table @QualificationUser `E.innerJoin` E.table @LmsUser `E.on` (\(quser E.:& luser) -> quser E.^. QualificationUserUser E.==. luser E.^. LmsUserUser E.&&. quser E.^. QualificationUserQualification E.==. luser E.^. LmsUserQualification ) - E.where_ $ E.val qid E.==. quser E.^. QualificationUserQualification - E.&&. E.val qid E.==. luser E.^. LmsUserQualification + E.where_ $ E.val qid E.==. quser E.^. QualificationUserQualification + E.&&. E.val qid E.==. luser E.^. LmsUserQualification E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day -- still valid E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate -- due to renewal - E.&&. E.isJust (luser E.^. LmsUserStatus) -- TODO: should check for success -- result already known + E.&&. E.isJust (luser E.^. LmsUserStatus) -- TODO: should check for success -- result already known pure (quser, luser) - let usr_job (quser, luser) = + let usr_job (quser, luser) = let vold = quser ^. _entityVal . _qualificationUserValidUntil - pmonth = fromMonths $ fromMaybe 0 $ qualificationValidDuration quali -- TODO: decide how to deal with qualification that have infinite validity?! + pmonth = fromMonths $ fromMaybe 0 $ qualificationValidDuration quali -- TODO: decide how to deal with qualifications that have infinite validity?! vnew = addGregorianDurationClip pmonth vold lmsstatus = luser ^. _entityVal . _lmsUserStatus - in case lmsstatus of - Just (LmsSuccess refreshDay) -> update (quser ^. _entityKey) [QualificationUserValidUntil =. vnew, QualificationUserLastRefresh =. refreshDay] + in case lmsstatus of + Just (LmsSuccess refreshDay) -> update (quser ^. _entityKey) [QualificationUserValidUntil =. vnew, QualificationUserLastRefresh =. refreshDay] _ -> return () forM_ renewalUsers usr_job +-- just processes received input, but does not affect any exisitng qualifications yet dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX -dispatchJobLmsResults qid = JobHandlerAtomic act +dispatchJobLmsResults qid = JobHandlerAtomic act where -- act :: YesodJobDB UniWorX () act = hoist lift $ do now <- liftIO getCurrentTime -- result :: [(Entity LmsUser, Entity LmsResult)] - results <- E.select $ do - (luser E.:& lresult) <- E.from $ - E.table @LmsUser `E.innerJoin` E.table @LmsResult - `E.on` (\(luser E.:& lresult) -> luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent + results <- E.select $ do + (luser E.:& lresult) <- E.from $ + E.table @LmsUser `E.innerJoin` E.table @LmsResult + `E.on` (\(luser E.:& lresult) -> luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification) E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners return (luser, lresult) - forM_ results $ \(Entity luid luser, Entity lrid lresult) -> do + forM_ results $ \(Entity luid luser, Entity lrid lresult) -> do -- three separate DB operations per result is not so nice. All within one transaction though. - let lreceived = lmsResultTimestamp lresult - newStatus = lmsResultSuccess lresult & LmsSuccess + let lreceived = lmsResultTimestamp lresult + newStatus = lmsResultSuccess lresult & LmsSuccess oldStatus = lmsUserStatus luser saneDate = lmsResultSuccess lresult `inBetween` (utctDay $ lmsUserStarted luser, utctDay now) -- always log success, since this is only transmitted once - if saneDate - then + if saneDate + then update luid [ LmsUserStatus =. (oldStatus <> Just newStatus) - , LmsUserReceived =. Just lreceived + , LmsUserReceived =. Just lreceived ] - else + else $logErrorS "LmsResult" [st|LMS success with insane date #{tshow (lmsResultSuccess lresult)} received|] insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lreceived now - delete lrid + delete lrid $logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|] + +-- just processes received input, but does not affect any exisitng qualifications yet dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX -dispatchJobLmsUserlist qid = JobHandlerAtomic act +dispatchJobLmsUserlist qid = JobHandlerAtomic act where - -- act :: YesodJobDB UniWorX () - act = hoist lift $ do + act :: YesodJobDB UniWorX () + act = do now <- liftIO getCurrentTime -- result :: [(Entity LmsUser, Entity LmsUserlist)] - results <- E.select $ do - (luser E.:& lulist) <- E.from $ + results <- E.select $ do + (luser E.:& lulist) <- E.from $ E.table @LmsUser `E.leftJoin` E.table @LmsUserlist - `E.on` (\(luser E.:& lulist) -> luser E.^. LmsUserIdent E.=?. lulist E.?. LmsUserlistIdent + `E.on` (\(luser E.:& lulist) -> luser E.^. LmsUserIdent E.=?. lulist E.?. LmsUserlistIdent E.&&. luser E.^. LmsUserQualification E.=?. lulist E.?. LmsUserlistQualification) E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners return (luser, lulist) - forM_ results $ \case - (Entity luid luser, Nothing) - | isJust $ lmsUserReceived luser - , isNothing $ lmsUserEnded luser -> + forM_ results $ \case + (Entity luid luser, Nothing) + | isJust $ lmsUserReceived luser -- mark all unreported users as ended + , isNothing $ lmsUserEnded luser -> update luid [LmsUserEnded =. Just now] - | otherwise -> return () -- likely not yet started + | otherwise -> return () -- users likely not yet started - (Entity luid luser, Just (Entity lulid lulist)) -> do + (Entity luid luser, Just (Entity lulid lulist)) -> do + when (isNothing $ lmsUserNotified luser) $ -- notify users that lms is available + queueDBJob JobSendNotification + { jRecipient = lmsUserUser luser + , jNotification = NotificationQualificationRenewal { nQualification = qid } + } let lReceived = lmsUserlistTimestamp lulist isBlocked = lmsUserlistFailed lulist newStatus = LmsBlocked $ utctDay lReceived diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 5a963e4c8..f5e08f55c 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -49,7 +49,7 @@ dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = use -- NOTE: qualificationRenewal expects that LmsUser already exists for recipient dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Handler () dispatchNotificationQualificationRenewal nQualification jRecipient = do - (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}, Entity _ LmsUser{..}) <- runDB $ (,,,) + (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}, Entity luid LmsUser{..}) <- runDB $ (,,,) <$> getJust jRecipient <*> getJust nQualification <*> getJustBy (UniqueQualificationUser nQualification jRecipient) @@ -120,5 +120,9 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do editNotifications <- mkEditNotifications jRecipient addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet") + -- if we reach the end, mark the user as notified + -- TODO: defer this until the print job is marked as sent? + runDB $ + update luid [ LmsUserNotified =. Just now] \ No newline at end of file diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 61f80af29..bc556fb46 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -37,13 +37,13 @@ import Data.List (foldl) import System.Directory (getModificationTime, doesDirectoryExist) import System.FilePath.Glob (glob) -{- Needed for File Tests only +{- Needed for File Tests only import qualified Data.Conduit.Combinators as C import Paths_uniworx (getDataFileName) testdataFile :: MonadIO m => FilePath -> m FilePath testdataFile = liftIO . getDataFileName . ("testdata" ) - + insertFile :: ( HasFileReference fRef, PersistRecordBackend fRef SqlBackend ) => FileReferenceResidual fRef -> FilePath -> DB (Key fRef) insertFile residual fileTitle = do filepath <- testdataFile fileTitle @@ -60,25 +60,25 @@ fillDb = do let insert' :: (PersistRecordBackend r (YesodPersistBackend UniWorX), AtLeastOneUniqueKey r) => r -> YesodDB UniWorX (Key r) insert' = fmap (either entityKey id) . insertBy - - addBDays = addBusinessDays Fraport -- holiday area to use - n_day n = addBDays n $ utctDay now + + addBDays = addBusinessDays Fraport -- holiday area to use + n_day n = addBDays n $ utctDay now n_day' n = now { utctDay = n_day n } currentTerm = TermIdentifier . fst3 . toGregorian $ utctDay now - -- (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm + -- (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm nextTerm n = toEnum . (+n) $ fromEnum currentTerm - termTime :: TermIdentifier -- ^ Term - -> TermDay -- ^ Relative to which day? + termTime :: TermIdentifier -- ^ Term + -> TermDay -- ^ Relative to which day? -> Integer -- ^ Week offset from TermDayStart/End of Term (shuld be negative for TermDayEnd) -> Maybe WeekDay -- ^ Move to weekday -> (Day -> UTCTime) -- ^ Add time to day -> UTCTime termTime gTid gTD weekOffset mbWeekDay = ($ tDay) - where - gDay = addDays (7* weekOffset) $ guessDay gTid gTD - tDay = maybe gDay (`firstDayOfWeekOnAfter` gDay) mbWeekDay - + where + gDay = addDays (7* weekOffset) $ guessDay gTid gTD + tDay = maybe gDay (`firstDayOfWeekOnAfter` gDay) mbWeekDay + gkleen <- insert User { userIdent = "G.Kleen@campus.lmu.de" , userAuthentication = AuthLDAP @@ -107,9 +107,9 @@ fillDb = do , userCsvOptions = def { csvFormat = csvPreset # CsvPresetRFC } , userSex = Just SexMale , userShowSex = userDefaultShowSex - , userTelephone = Nothing - , userMobile = Nothing - , userCompanyPersonalNumber = Nothing + , userTelephone = Nothing + , userMobile = Nothing + , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing @@ -145,9 +145,9 @@ fillDb = do , userCsvOptions = def { csvFormat = csvPreset # CsvPresetExcel } , userSex = Just SexMale , userShowSex = userDefaultShowSex - , userMobile = Nothing - , userTelephone = Nothing - , userCompanyPersonalNumber = Nothing + , userMobile = Nothing + , userTelephone = Nothing + , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing @@ -227,9 +227,9 @@ fillDb = do , userCsvOptions = def , userSex = Just SexMale , userShowSex = userDefaultShowSex - , userTelephone = Nothing - , userMobile = Nothing - , userCompanyPersonalNumber = Nothing + , userTelephone = Nothing + , userMobile = Nothing + , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing @@ -265,9 +265,9 @@ fillDb = do , userCsvOptions = def , userSex = Just SexNotApplicable , userShowSex = userDefaultShowSex - , userTelephone = Nothing - , userMobile = Nothing - , userCompanyPersonalNumber = Nothing + , userTelephone = Nothing + , userMobile = Nothing + , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing @@ -303,9 +303,9 @@ fillDb = do , userCsvOptions = def , userSex = Just SexFemale , userShowSex = userDefaultShowSex - , userTelephone = Nothing - , userMobile = Nothing - , userCompanyPersonalNumber = Nothing + , userTelephone = Nothing + , userMobile = Nothing + , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing @@ -341,9 +341,9 @@ fillDb = do , userCsvOptions = def , userSex = Just SexMale , userShowSex = userDefaultShowSex - , userTelephone = Nothing - , userMobile = Nothing - , userCompanyPersonalNumber = Nothing + , userTelephone = Nothing + , userMobile = Nothing + , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing @@ -409,9 +409,9 @@ fillDb = do , userCsvOptions = def , userSex = Nothing , userShowSex = userDefaultShowSex - , userTelephone = Nothing - , userMobile = Nothing - , userCompanyPersonalNumber = Nothing + , userTelephone = Nothing + , userMobile = Nothing + , userCompanyPersonalNumber = Nothing , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing @@ -426,7 +426,7 @@ fillDb = do Nothing -> repack [st|#{firstName}.#{userSurname}@example.invalid|] matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int) manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel - + let tmin = -1 tmax = 2 trange = [tmin..tmax] @@ -434,21 +434,21 @@ fillDb = do dmax = guessDay (nextTerm tmax) TermDayEnd hdys = foldl (<>) mempty $ [bankHolidaysAreaSet Fraport y | y <- [getYear dmin..getYear dmax]] terms <- forM trange $ \nr -> do - let tid = nextTerm nr - tk = TermKey tid + let tid = nextTerm nr + tk = TermKey tid tStart = guessDay tid TermDayStart tEnd = guessDay tid TermDayEnd - term = Term { termName = tid + term = Term { termName = tid , termStart = tStart , termEnd = tEnd - , termHolidays = toList $ Set.filter (\d -> tStart <= d && d <= tEnd) hdys + , termHolidays = toList $ Set.filter (\d -> tStart <= d && d <= tEnd) hdys , termLectureStart = guessDay tid TermDayLectureStart , termLectureEnd = guessDay tid TermDayLectureEnd } - repsert tk term + repsert tk term insert_ $ TermActive tk (toMidnight $ termStart term) (Just . beforeMidnight $ termEnd term) Nothing return tk - + ifiAuthorshipStatement <- insertAuthorshipStatement I18n { i18nFallback = htmlToStoredMarkup [shamlet| @@ -501,8 +501,8 @@ fillDb = do let f_descr = Just $ htmlToStoredMarkup [shamlet|

Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|] let r_descr = Just $ htmlToStoredMarkup [shamlet|

Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|] - let l_descr = Just $ htmlToStoredMarkup [shamlet|

für unhabilitierte|] - qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True + let l_descr = Just $ htmlToStoredMarkup [shamlet|

für unhabilitierte|] + qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 2 3) False qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing True void . insert' $ QualificationUser jost qid_f (n_day 9) (n_day $ -1) (n_day $ -22) -- TODO: better dates! @@ -516,17 +516,17 @@ fillDb = do void . insert' $ QualificationUser fhamann qid_r (n_day $ -3) (n_day $ -1) (n_day $ -2) void . insert' $ QualificationUser svaupel qid_l (n_day 1) (n_day $ -1) (n_day $ -2) void . insert' $ QualificationUser gkleen qid_l (n_day 9) (n_day $ -1) (n_day $ -7) - void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (n_day (-1)) now - void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) now - void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now - void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now - void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True now - void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now - void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing now Nothing Nothing - void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1) now (Just now) Nothing - void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just $ LmsBlocked $ utctDay now) now (Just now) Nothing - void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just $ LmsSuccess $ n_day (-2)) now Nothing Nothing - void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just $ LmsBlocked $ n_day (-1)) now (Just $ n_day' (-2)) (Just $ n_day' (-1)) + void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (n_day (-1)) now + void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) now + void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now + void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now + void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True now + void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now + void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing now Nothing Nothing Nothing + void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1) now (Just now) Nothing Nothing + void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just $ LmsBlocked $ utctDay now) now (Just now) Nothing Nothing + void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just $ LmsSuccess $ n_day (-2)) now Nothing (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)) (Just $ n_day' (-2)) (Just $ n_day' (-1)) void . insert $ PrintJob "TestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing (Just svaupel) Nothing (Just qid_f) void . insert $ PrintJob "TestJob2" "job2" "No Text herein." (n_day' (-1)) Nothing (Just jost) (Just svaupel) Nothing (Just qid_f) @@ -535,7 +535,7 @@ fillDb = do void . insert $ PrintJob "TestJob5" "job5" "No Text herein." (n_day' (-4)) Nothing (Just jost) (Just svaupel) Nothing (Just qid_r) void . insert $ PrintJob "TestJob6" "job6" "No Text herein." (n_day' (-4)) Nothing (Just svaupel) Nothing Nothing (Just qid_r) void . insert $ PrintJob "TestJob7" "job7" "No Text herein." (n_day' (-4)) Nothing (Just svaupel) Nothing Nothing Nothing - + let examLabels = Map.fromList @@ -718,19 +718,19 @@ fillDb = do now True Nothing - - + + -- Fahrschule F forM_ terms $ \tk -> do - let tid = unTermKey tk - jtt = (((Just .) .) .) . termTime tid + let tid = unTermKey tk + jtt = (((Just .) .) .) . termTime tid firstDay = utctDay $ termTime tid TermDayLectureStart 0 Nothing toMidnight secondDay = utctDay $ termTime tid TermDayLectureStart 1 Nothing toMidnight - weekDay = dayOfWeek firstDay + weekDay = dayOfWeek firstDay -- thirdDay = utctDay $ termTime tid TermDayLectureStart 2 Nothing toMidnight capacity = Just 8 - mkName = CI.mk - do + mkName = CI.mk + do c <- insert' Course { courseName = mkName "Vorfeldführerschein" , courseDescription = Just $ htmlToStoredMarkup [shamlet| @@ -739,7 +739,7 @@ fillDb = do

Benötigte Unterlagen
    -
  • Sehtest, +
  • Sehtest, bitte vorab hochladen!
  • Regulärer Führerschein, Bitte mitbringen. @@ -753,7 +753,7 @@ fillDb = do , courseVisibleTo = jtt TermDayEnd 0 Nothing beforeMidnight , courseRegisterFrom = jtt TermDayStart 0 Nothing toMidnight , courseRegisterTo = jtt TermDayLectureStart (-1) Nothing toMidnight - , courseDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight + , courseDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight , courseRegisterSecret = Nothing , courseMaterialFree = True , courseApplicationsRequired = False @@ -784,44 +784,44 @@ fillDb = do , sheetAuthorshipStatementMode = SheetAuthorshipStatementModeExam , sheetAuthorshipStatementExam = Nothing , sheetAuthorshipStatement = Nothing - } - -- TODO: Maybe split into to Tutorials with + } + -- TODO: Maybe split into to Tutorials with -- occurrencesSchedule = Set.fromList [ ScheduleWeekly { scheduleDayOfWeek = weekDay, scheduleStart = TimeOfDay 8 30 0, scheduleEnd = TimeOfDay 16 0 0} ] - tut1 <- insert Tutorial + tut1 <- insert Tutorial { tutorialName = mkName "Theorieschulung" , tutorialCourse = c , tutorialType = "Schulung" , tutorialCapacity = capacity - , tutorialRoom = Just $ case weekDay of + , tutorialRoom = Just $ case weekDay of Monday -> "A380" Tuesday -> "B747" Wednesday -> "MD11" Thursday -> "A380" - _ -> "B777" + _ -> "B777" , tutorialRoomHidden = False , tutorialTime = Occurrences - { occurrencesScheduled = Set.empty - , occurrencesExceptions = Set.fromList - [ ExceptOccur + { occurrencesScheduled = Set.empty + , occurrencesExceptions = Set.fromList + [ ExceptOccur { exceptDay = firstDay - , exceptStart = TimeOfDay 8 30 0 - , exceptEnd = TimeOfDay 16 0 0 + , exceptStart = TimeOfDay 8 30 0 + , exceptEnd = TimeOfDay 16 0 0 } , ExceptOccur { exceptDay = secondDay - , exceptStart = TimeOfDay 9 0 0 - , exceptEnd = TimeOfDay 16 0 0 + , exceptStart = TimeOfDay 9 0 0 + , exceptEnd = TimeOfDay 16 0 0 } - ] + ] } , tutorialRegGroup = Just "schulung" , tutorialRegisterFrom = jtt TermDayStart 0 Nothing toMidnight , tutorialRegisterTo = jtt TermDayLectureStart (-1) Nothing toMidnight - , tutorialDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight + , tutorialDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight , tutorialLastChanged = now , tutorialTutorControlled = True } - insert_ $ Tutor tut1 jost + insert_ $ Tutor tut1 jost void . insert' $ Exam { examCourse = c , examName = mkName "Theorieprüfung" @@ -832,9 +832,9 @@ fillDb = do , examVisibleFrom = jtt TermDayStart 0 Nothing toMidnight , examRegisterFrom = jtt TermDayStart 0 Nothing toMidnight , examRegisterTo = jtt TermDayLectureStart (-1) Nothing toMidnight - , examDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight + , examDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight , examPublishOccurrenceAssignments = Nothing - , examStart = Just $ toTimeOfDay 16 0 0 secondDay + , examStart = Just $ toTimeOfDay 16 0 0 secondDay , examEnd = Just $ toTimeOfDay 16 30 0 secondDay , examFinished = Nothing , examPartsFrom = Nothing @@ -851,7 +851,7 @@ fillDb = do , examStaff = Just "Jost" , examAuthorshipStatement = Nothing } - + testMsg <- insert SystemMessage { systemMessageNewsOnly = False , systemMessageFrom = Just now @@ -912,7 +912,7 @@ fillDb = do , systemMessageCreated = now , systemMessageLastChanged = now , systemMessageLastUnhide = now - } + } void $ insert SystemMessage { systemMessageNewsOnly = True , systemMessageFrom = Just now @@ -929,7 +929,7 @@ fillDb = do , systemMessageLastUnhide = now } - {- + {- aSeedFunc <- liftIO $ getRandomBytes 40 funAlloc <- insert' Allocation { allocationName = "Funktionale Zentralanmeldung" @@ -940,10 +940,10 @@ fillDb = do , allocationDescription = Nothing , allocationStaffDescription = Nothing , allocationStaffRegisterFrom = Just now - , allocationStaffRegisterTo = Just $ 300 `addUTCTime` now + , allocationStaffRegisterTo = Just $ 300 `addUTCTime` now , allocationStaffAllocationFrom = Just $ 300 `addUTCTime` now , allocationStaffAllocationTo = Just $ 900 `addUTCTime` now - , allocationRegisterFrom = Just $ 300 `addUTCTime` now + , allocationRegisterFrom = Just $ 300 `addUTCTime` now , allocationRegisterTo = Just $ 600 `addUTCTime` now , allocationRegisterByStaffFrom = Nothing , allocationRegisterByStaffTo = Nothing @@ -953,7 +953,7 @@ fillDb = do } insert_ $ AllocationCourse funAlloc pmo 100 Nothing Nothing insert_ $ AllocationCourse funAlloc ffp 2 (Just $ 2300 `addUTCTime` now) Nothing - + void . insertMany $ map (\(u, pState) -> CourseParticipant ffp u now (Just funAlloc) pState) [ (svaupel, CourseParticipantInactive False) , (jost, CourseParticipantActive) @@ -977,7 +977,7 @@ fillDb = do Just User{ userMatrikelnummer = Just matr } -> return . pure $ Csv.Only matr _other -> return mempty - + liftIO . handle (\(_ :: IOException) -> return ()) $ do haveTestdata <- doesDirectoryExist "testdata" LBS.writeFile (bool id ("testdata" ) haveTestdata "bigAlloc_numeric.csv") $ Csv.encode numericPriorities