refactor(lms): send user notifications only after lms acknowleged e-learning
This commit is contained in:
Steffen Jost
parent
4419245e17
commit
bd539358bd
@ -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?
|
||||
|
||||
@ -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?
|
||||
|
||||
@ -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!
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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]
|
||||
|
||||
|
||||
@ -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|<p>Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|]
|
||||
let r_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|]
|
||||
let l_descr = Just $ htmlToStoredMarkup [shamlet|<p>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|<p>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
|
||||
<section>
|
||||
<h3>Benötigte Unterlagen
|
||||
<ul>
|
||||
<li>Sehtest,
|
||||
<li>Sehtest,
|
||||
<i>bitte vorab hochladen!
|
||||
<li>Regulärer Führerschein,
|
||||
<i>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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user