diff --git a/models/lms.model b/models/lms.model index 4b0469d31..7ee6b9da4 100644 --- a/models/lms.model +++ b/models/lms.model @@ -117,7 +117,7 @@ LmsUser datePin UTCTime default=now() -- time pin was created status LmsStatus Maybe -- Nothing=open, LmsSuccess, LmsBlocked or LmsExpired; status should never change unless isNothing; isJust indicates lms is finished and user shall be deleted from LMS --toDelete encoded by Handler.Utils.LMS.lmsUserToDelete - statusDay Day Maybe -- date of status change; should be isJust iff isJust status; modelling as a separate table too bothersome, unlike qualification block + statusDay Day Maybe -- date of status change; should be isJust iff isJust status; modelling as a separate table too bothersome, unlike qualification block started UTCTime default=now() received UTCTime Maybe -- last acknowledgement by LMS notified UTCTime Maybe -- last notified by FRADrive diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index 0741a408d..98761461c 100644 --- a/src/Handler/LMS/Learners.hs +++ b/src/Handler/LMS/Learners.hs @@ -40,9 +40,9 @@ lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv , csvLUTpin = lmsUserPin , csvLUTresetPin = LmsBool lmsUserResetPin , csvLUTdelete = LmsBool (lmsUserToDelete cutoff lu) - , csvLUTstaff = LmsBool False - , csvLUTresetTries= LmsBool False -- TODO -- wie wird das festgelegt? Als Attribut in der DB? - , csvLUTlock = LmsBool False -- TODO -- kann dies rein aus der Zeit berechnet werden? + , csvLUTstaff = LmsBool (lmsUserStaff lu) + , csvLUTresetTries= LmsBool (lmsUserToResetTries lu) -- TODO: verify this works as intended! + , csvLUTlock = LmsBool (lmsUserToLock lu) } -- csv without headers @@ -110,9 +110,9 @@ mkUserTable _sid qsh qid = do ) $ \(view $ _dbrOutput . _entityVal . _lmsUserPin -> pin ) -> textCell pin , sortable (Just csvLmsResetPin) (i18nCell MsgTableLmsResetPin) $ \(view $ _dbrOutput . _entityVal . _lmsUserResetPin -> reset) -> ifIconCell reset IconReset , sortable (Just csvLmsDelete) (i18nCell MsgTableLmsDelete) $ \(view $ _dbrOutput . _entityVal . _lmsUserToDelete cutoff -> del ) -> ifIconCell del IconRemoveUser - , sortable Nothing (i18nCell MsgTableLmsStaff) $ const mempty - , sortable Nothing (i18nCell MsgTableLmsResetTries) $ const mempty -- TODO - , sortable Nothing (i18nCell MsgTableLmsLock) $ const mempty -- TODO + , sortable Nothing (i18nCell MsgTableLmsStaff) $ \(view $ _dbrOutput . _entityVal -> lu) -> iconBoolCell (lmsUserStaff lu) + , sortable Nothing (i18nCell MsgTableLmsResetTries) $ \(view $ _dbrOutput . _entityVal -> lu) -> iconBoolCell (lmsUserToResetTries lu) + , sortable Nothing (i18nCell MsgTableLmsLock) $ \(view $ _dbrOutput . _entityVal -> lu) -> ifIconCell (lmsUserToLock lu) IconLocked ] dbtSorting = Map.fromList [ (csvLmsIdent , SortColumn (E.^. LmsUserIdent)) @@ -144,9 +144,9 @@ mkUserTable _sid qsh qid = do <*> view (_dbrOutput . _entityVal . _lmsUserPin) <*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool) <*> view (_dbrOutput . _entityVal . _lmsUserToDelete cutoff . _lmsBool) - <*> const (LmsBool False) - <*> const (LmsBool False) -- TODO - <*> const (LmsBool False) -- TODO + <*> view (_dbrOutput . _entityVal . to lmsUserStaff . _lmsBool) + <*> view (_dbrOutput . _entityVal . to lmsUserToResetTries . _lmsBool) + <*> view (_dbrOutput . _entityVal . to lmsUserToLock . _lmsBool) dbtCsvDecode = Nothing dbtExtraReps = [] diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index f8de8e5de..42a2c2dc7 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -25,6 +25,9 @@ module Handler.Utils.LMS , lmsDeletionDate , lmsUserToDelete, _lmsUserToDelete , lmsUserToDeleteExpr + , lmsUserToResetTries + , lmsUserToLock + , lmsUserStaff , lmsStatusInfoCell , lmsStatusIcon, lmsUserStatusWidget , randomLMSIdent, randomLMSIdentBut @@ -149,6 +152,16 @@ lmsUserToDelete _ _ = False _lmsUserToDelete :: Day -> Getter LmsUser Bool _lmsUserToDelete cutoff = to $ lmsUserToDelete cutoff + +lmsUserToResetTries :: LmsUser -> Bool +lmsUserToResetTries LmsUser{..} = lmsUserResetTries && lmsUserLocked && lmsUserStatus == Just LmsBlocked -- only reset blocked learners + +lmsUserToLock :: LmsUser -> Bool +lmsUserToLock LmsUser{..} = lmsUserLocked && not (lmsUserResetTries && isNothing lmsUserStatus) + +lmsUserStaff :: LmsUser -> Bool +lmsUserStaff = const False -- legacy, currently ignored + -- random generation of LmsIdentifiers, maybe this should be in Model.Types.Lms since length specifications are type-y? lengthIdent :: Int diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 07f6a6b62..01c2bbb14 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -318,6 +318,10 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.&&. lreport E.^. LmsReportQualification E.==. E.val qid E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock) ) + -- TODO: implement tries-reset here: + -- if | LmsUserResetTries && LmsReportStatus = LmsOpen => LmsUserStatus =. Nothing + -- | LmsUserResetTries && LmsUserStatus == Nothing && not LmsReportLock => LmsUserResetTries =. False + -- TODO: check whether this works too: -- let updateReceivedLocked' lockstatus = E.update $ \luser -> do -- attempt to use 'from'-clause in update as per PostgreSQL -- E.set luser [ LmsUserReceived E.=. E.justVal now