diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 9c72b28ee..65cd221b8 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -107,6 +107,8 @@ QualificationActUnblock: Entzug aufheben QualificationActRenew: Qualifikation regulär verlängern QualificationActGrant: Qualifikation vergeben QualificationActGrantWarning: Diese Funktion ist nur für seltene Ausnahmefälle vorgesehen! Ein Entzug wird ggf. aufgehoben. +QualificationActStartELearning: E‑Learning für gültige Inhaber (neu) starten +QualificationActStartELearningStatus l@QualificationShorthand n@Int m@Int: E‑Learning #{l} für #{n}/#{m} Teilnehmer (neu) gestartet. Hinweis: Es kann länger dauern, bis das LMS tatsächlich startet. QualificationStatusBlock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert LmsInactive: Aktuell kein E‑Learning aktiv @@ -120,7 +122,7 @@ LmsActReset: E‑Learning Fehlversuche zurücksetzen und entsperren LmsActResetInfo: E‑Learning Login, Passwort und Fortschritt bleiben unverändert, eine neue Benachrichtigung ist nicht notwendig. Nur möglich für bereits gesperrte Lerner. Es kann bis zu 2 Stunden dauern, bis das LMS die Anfrage umgesetzt hat. LmsActResetFeedback n@Int m@Int: Für #{n}/#{m} E‑Learning Nutzer wurden alle Fehlversuche zurückgesetzt. LmsActRestart: E‑Learning komplett neu starten -LmsActRestartWarning: Das vorhandene E‑Learning wird komplett gelöscht! Für Inhaber einer gültigen Fahrlizenz werden später Benutzer und Passwort neu vergeben und es sollte eine neue Benachrichtigung versendet werden. Hinweis: Es kann mehrere Stunden dauern, bis das LMS diese Anfrage umgesetzt hat. +LmsActRestartWarning: Das vorhandene E‑Learning wird komplett gelöscht! Für Inhaber einer gültigen Lizenz werden später Benutzer und Passwort neu vergeben und es sollte eine neue Benachrichtigung versendet werden. Hinweis: Es kann mehrere Stunden dauern, bis das LMS diese Anfrage umgesetzt hat. LmsActRestartFeedback n@Int m@Int: #{n}/#{m} E‑Learning Nutzer wurden komplett neu gestartet mit neuem Login und Passwort. LmsActRestartExtend: Gültig bis ggf. erhöhen für die nächsten # Tage LmsActRestartUnblock: Entzug ggf. aufheben diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 3779c22a0..9cdc5ad36 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -107,6 +107,8 @@ QualificationActUnblock: Clear revocation QualificationActRenew: Renew qualification QualificationActGrant: Grant qualification QualificationActGrantWarning: Use with caution in rare exceptional cases only! Any revocation will be undone. +QualificationActStartELearning: Manually (re)start e‑learning for valid qualification holders +QualificationActStartELearningStatus l n m: E‑learning #{l} (re)started for #{n}/#{m} users. Note: It may take a while, until the e‑learning is activated. QualificationStatusBlock l n m: #{n}/#{m} #{l} revoked QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated LmsInactive: Currently no active e‑learning diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 08ed399d8..a67a35c21 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -14,7 +14,7 @@ module Handler.Qualification import Import --- import Jobs +import Jobs import Handler.Utils import Handler.Utils.Users import Handler.Utils.LMS @@ -55,7 +55,7 @@ getQualificationAllR = do type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64) resultAllQualification :: Lens' AllQualificationTableData Qualification -resultAllQualification = _dbrOutput . _1 . _entityVal +resultAllQualification = _dbrOutput . _1 . _entityVal resultAllQualificationActive :: Lens' AllQualificationTableData Word64 resultAllQualificationActive = _dbrOutput . _2 . _unValue @@ -65,53 +65,53 @@ resultAllQualificationTotal = _dbrOutput . _3 . _unValue mkQualificationAllTable :: Bool -> DB (Any, Widget) -mkQualificationAllTable isAdmin = do - svs <- getSupervisees +mkQualificationAllTable isAdmin = do + svs <- getSupervisees now <- liftIO getCurrentTime - let + let resultDBTable = DBTable{..} where - dbtSQLQuery quali = do - let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId + dbtSQLQuery quali = do + let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId Ex.&&. (E.val isAdmin E.||. quser Ex.^. QualificationUserUser `Ex.in_` E.vals svs) - cusers = Ex.subSelectCount $ do + cusers = Ex.subSelectCount $ do quser <- Ex.from $ Ex.table @QualificationUser - Ex.where_ $ filterSvs quser - cactive = Ex.subSelectCount $ do + Ex.where_ $ filterSvs quser + cactive = Ex.subSelectCount $ do quser <- Ex.from $ Ex.table @QualificationUser Ex.where_ $ filterSvs quser Ex.&&. validQualification now quser - return (quali, cactive, cusers) + return (quali, cactive, cusers) dbtRowKey = (Ex.^. QualificationId) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat [ colSchool $ resultAllQualification . _qualificationSchool - , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> - let qsh = qualificationShorthand quali in + , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> + let qsh = qualificationShorthand quali in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qsh - , sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) -> + , sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) -> let qsh = qualificationShorthand quali - qnm = qualificationName quali + qnm = qualificationName quali in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) -> maybeCell (qualificationDescription quali) markupCellLargeModal - , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ + , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration) , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $ foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin) , sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $ - foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder) + foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder) , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) - , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip) + , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip) $ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification) - , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) + , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) $ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char - , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip) + , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip) $ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) -> tickmarkCell $ isJust mbSapId , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) - $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n - , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal - ] + $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n + , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal + ] dbtSorting = mconcat [ sortSchool $ to (E.^. QualificationSchool) @@ -133,7 +133,7 @@ mkQualificationAllTable isAdmin = do dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtIdent :: Text - dbtIdent = "qualification-overview" + dbtIdent = "qualification-overview" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] @@ -145,7 +145,7 @@ mkQualificationAllTable isAdmin = do -- getQualificationEditR, postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html --- getQualificationEditR = postQualificationEditR +-- getQualificationEditR = postQualificationEditR -- postQualificationEditR = error "TODO" data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. @@ -156,7 +156,7 @@ data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. , qtcValidUntil :: Day , qtcLastRefresh :: Day , qtcBlockStatus :: Maybe Bool - , qtcBlockFrom :: Maybe UTCTime + , qtcBlockFrom :: Maybe UTCTime , qtcScheduleRenewal:: Bool , qtcLmsStatusTxt :: Maybe Text , qtcLmsStatusDay :: Maybe UTCTime @@ -173,7 +173,7 @@ qtcExample = QualificationTableCsv , qtcValidUntil = compDay , qtcLastRefresh = compDay , qtcBlockStatus = Nothing - , qtcBlockFrom = Nothing + , qtcBlockFrom = Nothing , qtcScheduleRenewal= True , qtcLmsStatusTxt = Just "Success" , qtcLmsStatusDay = Just compTime @@ -211,7 +211,7 @@ instance CsvColumnsExplained QualificationTableCsv where , ('qtcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom) , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip) , ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus) - , ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay) + , ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay) ] @@ -266,15 +266,16 @@ instance HasQualificationUser QualificationTableData where -- hasQualificationUserBlock = resultQualBlock -data QualificationTableAction - = QualificationActExpire +data QualificationTableAction + = QualificationActExpire | QualificationActUnexpire | QualificationActBlockSupervisor | QualificationActBlock | QualificationActUnblock | QualificationActRenew | QualificationActGrant - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + | QualificationActStartELearning + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe QualificationTableAction instance Finite QualificationTableAction @@ -289,15 +290,16 @@ isAdminAct QualificationActBlockSupervisor = False isAdminAct _ = True -} -data QualificationTableActionData - = QualificationActExpireData - | QualificationActUnexpireData +data QualificationTableActionData + = QualificationActExpireData + | QualificationActUnexpireData | QualificationActBlockSupervisorData - | QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool } - | QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool} - | QualificationActRenewData { qualTableActChangeReason :: Text} - | QualificationActGrantData { qualTableActGrantUntil :: Day } - deriving (Eq, Ord, Show, Generic) + | QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool } + | QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool } + | QualificationActRenewData { qualTableActChangeReason :: Text } + | QualificationActGrantData { qualTableActGrantUntil :: Day } + | QualificationActStartELearningData -- { qualTableActELearnUntil :: Maybe Day } + deriving (Eq, Ord, Show, Generic) isExpiryAct :: QualificationTableActionData -> Bool isExpiryAct QualificationActExpireData = True @@ -335,14 +337,14 @@ qualificationTableQuery :: UTCTime -> QualificationId -> (_ -> E.SqlExpr (E.Valu ) qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps - -- + -- E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId E.&&. qualBlock `isLatestBlockBefore` E.val now 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, which does not work E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser - E.where_ $ fltr qualUser - E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) + E.where_ $ fltr qualUser + E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) return (qualUser, user, lmsUser, qualBlock) @@ -352,15 +354,15 @@ mkQualificationTable :: ) => Bool -> Entity Qualification - -> Map QualificationTableAction (AForm Handler QualificationTableActionData) + -> Map QualificationTableAction (AForm Handler QualificationTableActionData) -> (Map CompanyId Company -> cols) -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData)) -> DB (FormResult (QualificationTableActionData, Set UserId), Widget) mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do svs <- getSupervisees - now <- liftIO getCurrentTime - -- lookup all companies - cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do + now <- liftIO getCurrentTime + -- lookup all companies + cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do cmps <- selectList [] [] -- [Asc CompanyShorthand] return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps let @@ -390,7 +392,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) - , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay) + , single ("lms-status-plus",SortColumnNullsInv $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay) , E.joinV (queryLmsUser row E.?. LmsUserNotified) , queryLmsUser row E.?. LmsUserStarted]) , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) @@ -405,7 +407,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> - E.from $ \usrAvs -> -- do + E.from $ \usrAvs -> -- do E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )) @@ -415,14 +417,14 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria ) , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> - E.from $ \(usrComp `E.InnerJoin` comp) -> do + E.from $ \(usrComp `E.InnerJoin` comp) -> do let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId testcrit = maybe testname testnumber $ readMay $ CI.original criterion E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit - ) + ) , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> if | Just renewal <- mbRenewal @@ -441,7 +443,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) , fltrAVSCardNosUI mPrev - , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) + , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) , if isNothing mbRenewal then mempty else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) @@ -466,31 +468,31 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do <*> (view resultCompanyUser >>= getCompanies) <*> (view resultCompanyUser >>= getCompanyNos) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) - <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) + <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not) - <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom) + <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom) <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal) <*> getStatusPlusTxt <*> getStatusPlusDay - getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of + getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of [] -> pure Nothing somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) - getStatusPlusTxt = - (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case + getStatusPlusTxt = + (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case Just LmsBlocked{} -> return $ Just "Failed" Just LmsExpired{} -> return $ Just "Expired" Just LmsSuccess{} -> return $ Just "Success" Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $ preview (resultLmsUser . _entityVal . _lmsUserStarted) - getStatusPlusDay = - (join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case + getStatusPlusDay = + (join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case lsd@(Just _) -> return lsd Nothing -> preview (resultLmsUser . _entityVal . _lmsUserStarted) - + dbtCsvDecode = Nothing - dbtExtraReps = [] + dbtExtraReps = [] dbtParams = DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Nothing @@ -518,7 +520,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html getQualificationR = postQualificationR -postQualificationR sid qsh = do +postQualificationR sid qsh = do isAdmin <- hasReadAccessTo AdminR msgGrantWarning <- messageIconI Warning IconWarning MsgQualificationActGrantWarning msgUnexpire <- messageIconI Info IconWarning MsgQualificationActUnexpireWarning @@ -533,13 +535,13 @@ postQualificationR sid qsh = do }} <- getBy404 $ SchoolQualificationShort sid qsh -- Block copied to Handler/Qualifications TODO: refactor - let getBlockReasons unblk = Ex.select $ do - (quser :& qblock) <- Ex.from $ Ex.table @QualificationUser + let getBlockReasons unblk = Ex.select $ do + (quser :& qblock) <- Ex.from $ Ex.table @QualificationUser `Ex.innerJoin` Ex.table @QualificationUserBlock `Ex.on` (\(quser :& qblock) -> quser Ex.^. QualificationUserId Ex.==. qblock Ex.^. QualificationUserBlockQualificationUser) Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. Ex.val qid Ex.&&. unblk (qblock Ex.^. QualificationUserBlockUnblock) - Ex.groupBy (qblock Ex.^. QualificationUserBlockReason) + Ex.groupBy (qblock Ex.^. QualificationUserBlockReason) let countRows' :: Ex.SqlExpr (Ex.Value Int64) = Ex.countRows Ex.orderBy [Ex.desc countRows'] Ex.limit 7 @@ -553,67 +555,82 @@ postQualificationR sid qsh = do acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) acts = mconcat $ [ singletonMap QualificationActExpire $ pure QualificationActExpireData - , singletonMap QualificationActUnexpire $ QualificationActUnexpireData - <$ aformMessage msgUnexpire - ] ++ bool + , singletonMap QualificationActUnexpire $ QualificationActUnexpireData + <$ aformMessage msgUnexpire + ] ++ bool -- nonAdmin actions, ie. Supervisor - [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] + [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- Admin-only actions [ singletonMap QualificationActUnblock $ QualificationActUnblockData <$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) - , singletonMap QualificationActBlock $ QualificationActBlockData + , singletonMap QualificationActBlock $ QualificationActBlockData <$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False) , singletonMap QualificationActRenew $ QualificationActRenewData <$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationRenewReason) Nothing - , singletonMap QualificationActGrant $ QualificationActGrantData + , singletonMap QualificationActGrant $ QualificationActGrantData <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry <* aformMessage msgGrantWarning + , singletonMap QualificationActStartELearning $ pure QualificationActStartELearningData + -- <$> aopt dayField (fslI MsgQualificationReduceValidUntil) Nothing ] isAdmin linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh) - linkUserName = bool ForProfileR ForProfileDataR isAdmin + linkUserName = bool ForProfileR ForProfileDataR isAdmin colChoices cmpMap = mconcat [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , colUserNameModalHdr MsgLmsUser linkUserName - , colUserEmail + , colUserEmail , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) -> let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps - , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap + , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap ] in intercalate spacerCell cs , guardMonoid isAdmin $ colUserMatriclenr isAdmin -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d - , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d + , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil)) - , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> + , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths)) $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusCell isAdmin linkLmsUser) lu - -- QualificationUserLastNotified is about notification on actual validity changes. If a user's licence is about to expire and renewed before expiry via e-learning, this value does not change. + -- QualificationUserLastNotified is about notification on actual validity changes. If a user's licence is about to expire and renewed before expiry via e-learning, this value does not change. -- NOTE: If this column is reinstatiated, header and tooltip were already updated to avoid any confusion! - -- , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified & cellTooltip MsgTableQualificationLastNotifiedTooltip) + -- , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified & cellTooltip MsgTableQualificationLastNotifiedTooltip) -- $ \( view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d ] psValidator = def & defaultSorting [SortDescBy "last-refresh"] tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator return (tbl, qent) - + formResult lmsRes $ \case (QualificationActRenewData renewReason, selectedUsers) | isAdmin -> do - noks <- runDB $ renewValidQualificationUsers qid (canonical $ Just $ Left renewReason) Nothing $ Set.toList selectedUsers + noks <- runDB $ renewValidQualificationUsers qid (canonical $ Just $ Left renewReason) Nothing $ Set.toList selectedUsers addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks reloadKeepGetParams $ QualificationR sid qsh - (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do + (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do runDB . forM_ selectedUsers $ upsertQualificationUser qid now grantValidday Nothing "Admin" addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers reloadKeepGetParams $ QualificationR sid qsh - (action, selectedUsers) | isExpiryAct action -> do + (QualificationActStartELearningData, Set.toList -> selectedUsers) | isAdmin -> do + -- whenIsJust mbExpDay $ \expDay -> + -- when expDay > nowaday $ + -- -- updateWhere [QualificationUserQualification ==. qid, QualificationUserUser <-. selectedUsers, QualificationUserValidUntil >. expDay] [QualificationUserValidUntil =. expDay] -- DO NOT USE: no audit + -- NOTE: if needed, create function Handler.Utils.Qualification.updateQualificationUser qid QualificationChangeReason -> Day -> [UserId] -> DB Int + validQualHolderEnts <- runDB $ selectValidQualifications qid selectedUsers now + let validQualHolders = view (_entityVal . _qualificationUserUser) <$> validQualHolderEnts + jobs <- forM validQualHolders $ queueJob . JobLmsEnqueueUser qid + let nrTodo = length selectedUsers + nrEnqueued = length $ catMaybes jobs + addMessageI (bool Warning Success $ nrEnqueued > 0 && nrEnqueued == nrTodo) $ MsgQualificationActStartELearningStatus qsh nrEnqueued nrTodo + -- transaction audit identical to automatic start, performed by JobLmsEnqueueUser + reloadKeepGetParams $ QualificationR sid qsh + (action, selectedUsers) | isExpiryAct action -> do let isUnexpire = action == QualificationActUnexpireData upd <- runDB $ do forM_ selectedUsers $ \uid -> audit TransactionQualificationUserScheduleRenewal @@ -628,18 +645,18 @@ postQualificationR sid qsh = do msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire addMessageI msgKind msgVal reloadKeepGetParams $ QualificationR sid qsh - (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do + (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do let selUserIds = Set.toList selectedUsers - (unblock, reason) = case action of - QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany) + (unblock, reason) = case action of + QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany) QualificationActBlockData{..} -> (False, Left qualTableActBlockReason) QualificationActUnblockData{..} -> (True , Left qualTableActBlockReason) _ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks - notify = case action of + notify = case action of QualificationActBlockData{qualTableActNotify} -> qualTableActNotify _ -> False - - oks <- runDB $ do + + oks <- runDB $ do when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds] qualificationUserBlocking qid selUserIds unblock Nothing reason notify let nrq = length selectedUsers diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 947bc2a15..e3feec877 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -30,9 +30,9 @@ statusQualificationBlock s = statusHtml (bool Error Success s) $ iconQualificati -- needs refactoring, probbably no longer helpful mkQualificationBlocked :: QualificationStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQualificationUser = QualificationUserBlock{..} - where - qualificationUserBlockReason = tshow reason - qualificationUserBlockUnblock = False + where + qualificationUserBlockReason = tshow reason + qualificationUserBlockUnblock = False qualificationUserBlockBlocker = Nothing -- somewhat dangerous, if not used with latest effective block @@ -54,7 +54,7 @@ quserToNotify cutoff quser qblock = -- either recently become invalid with no pr E.&&. quser E.^. QualificationUserValidUntil E.>. E.day (quser E.^. QualificationUserLastNotified) E.&&. E.not_ (E.isFalse (qblock E.?. QualificationUserBlockUnblock)) -- not currently blocked ) E.||. ( -- was recently blocked - E.isFalse (qblock E.?. QualificationUserBlockUnblock) + E.isFalse (qblock E.?. QualificationUserBlockUnblock) E.&&. qblock E.?. QualificationUserBlockFrom E.>. E.just (quser E.^. QualificationUserLastNotified) )) @@ -73,8 +73,8 @@ isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. Qualificatio -- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_` quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) -quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do - qualUserBlock <- E.from $ E.table @QualificationUserBlock +quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do + qualUserBlock <- E.from $ E.table @QualificationUserBlock E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock) E.&&. (qualUserBlock E.^. QualificationUserBlockFrom E.<=. cutoff) E.&&. checkQualUserId (qualUserBlock E.^. QualificationUserBlockQualificationUser) @@ -87,11 +87,11 @@ quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists ) whenIsJust mbBlockCondition (E.where_ . ($ qualUserBlock)) --- | Test whether a QualificationUser was blocked/unblocked at a given day; negCond: True:isBlocked False:isUnblocked +-- | Test whether a QualificationUser was blocked/unblocked at a given day; negCond: True:isBlocked False:isUnblocked quserBlock :: Bool -> UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool) quserBlock negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.==. (qualUser E.^. QualificationUserId)) Nothing --- | Variant of `isBlocked` for outer joins +-- | Variant of `isBlocked` for outer joins quserBlock' :: Bool -> UTCTime -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool) quserBlock' negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.=?. (qualUser E.?. QualificationUserId)) Nothing @@ -112,15 +112,15 @@ validQualification' cutoff qualUser = E.&&. quserBlock' False cutoff qualUser -- selectValidQualifications :: QualificationId -> [UserId] -> UTCTime -> DB [Entity QualificationUser] -selectValidQualifications :: +selectValidQualifications :: ( MonadIO m , BackendCompatible SqlBackend backend , PersistQueryRead backend , PersistUniqueRead backend ) => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser] -selectValidQualifications qid uids cutoff = +selectValidQualifications qid uids cutoff = -- cutoff <- utctDay <$> liftIO getCurrentTime - E.select $ do + E.select $ do qUser <- E.from $ E.table @QualificationUser E.where_ $ (qUser E.^. QualificationUserQualification E.==. E.val qid) E.&&. qUser E.^. QualificationUserUser `E.in_` E.valList uids @@ -142,7 +142,7 @@ upsertQualificationUser qualificationUserQualification startTime qualificationU let qualificationUserLastRefresh = utctDay startTime Entity quid _ <- upsert QualificationUser - { qualificationUserFirstHeld = qualificationUserLastRefresh + { qualificationUserFirstHeld = qualificationUserLastRefresh , qualificationUserScheduleRenewal = fromMaybe True mbScheduleRenewal , qualificationUserLastNotified = utctDayMidnight qualificationUserLastRefresh , .. @@ -151,7 +151,7 @@ upsertQualificationUser qualificationUserQualification startTime qualificationU [ QualificationUserScheduleRenewal =. scheduleRenewal | Just scheduleRenewal <- [mbScheduleRenewal] ] ++ [ QualificationUserValidUntil =. qualificationUserValidUntil - , QualificationUserLastRefresh =. qualificationUserLastRefresh + , QualificationUserLastRefresh =. qualificationUserLastRefresh ] ) authUsr <- liftHandler maybeAuthId @@ -166,8 +166,8 @@ upsertQualificationUser qualificationUserQualification startTime qualificationU } -- | Renew an existing valid qualification, ignoring all blocks otherwise --- renewValidQualificationUsers :: QualificationId -> Maybe UTCTime -> [UserId] -> DB Int -- not general enough for use in YesodJobDB -renewValidQualificationUsers :: +-- renewValidQualificationUsers :: QualificationId -> Maybe QualificationChangeReason -> Maybe UTCTime -> [UserId] -> DB Int -- not general enough for use in YesodJobDB +renewValidQualificationUsers :: ( AuthId (HandlerSite m) ~ Key User , IsPersistBackend (YesodPersistBackend (HandlerSite m)) , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend @@ -178,7 +178,7 @@ renewValidQualificationUsers :: , YesodAuthPersist (HandlerSite m) , HasAppSettings (HandlerSite m) , MonadHandler m - , MonadCatch m + , MonadCatch m ) => QualificationId -> Maybe QualificationChangeReason -> Maybe UTCTime -> [UserId] -> ReaderT (YesodPersistBackend (HandlerSite m)) m Int renewValidQualificationUsers qid reason renewalTime uids = -- The following short code snippet suffices in principle, but would not allow audit log entries. Are these still needed? @@ -186,14 +186,14 @@ renewValidQualificationUsers qid reason renewalTime uids = -- E.set qu [ QualificationUserValidUntil E.+=. E.interval (CalendarDiffDays 2 0) ] -- TODO: for Testing only -- E.where_ $ (qu E.^. QualificationUserQualification E.==. E.val qid ) -- E.&&. (qu E.^. QualificationUserUser `E.in_` E.valList uids) - get qid >>= \case + get qid >>= \case Just Qualification{qualificationValidDuration=Just renewalMonths} -> do cutoff <- maybe (liftIO getCurrentTime) return renewalTime quEntsAll <- selectValidQualifications qid uids cutoff let cutoffday = utctDay cutoff maxValidTo = addGregorianMonthsRollOver (toInteger $ renewalMonths `div` 2) cutoffday quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll - forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do + forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do let newValidTo = computeNewValidDate renewalMonths qualificationUserValidUntil update quId [ QualificationUserValidUntil =. newValidTo , QualificationUserLastRefresh =. cutoffday @@ -210,7 +210,7 @@ renewValidQualificationUsers qid reason renewalTime uids = _ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc. -- | Block or unblock some users for a given reason, but only if they are not already blocked (essential assumption that is actually used) -qualificationUserBlocking :: +qualificationUserBlocking :: ( AuthId (HandlerSite m) ~ Key User , IsPersistBackend (YesodPersistBackend (HandlerSite m)) , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend @@ -228,10 +228,10 @@ qualificationUserBlocking qid uids unblock mbBlockTime (qualificationChangeReaso $logInfoS "BLOCK" $ Text.intercalate " - " [tshow qid, tshow uids, tshow unblock, tshow mbBlockTime, tshow reason, tshow notify] authUsr <- liftHandler maybeAuthId now <- liftIO getCurrentTime - let blockTime = fromMaybe now mbBlockTime - -- -- Code would work, but problematic + let blockTime = fromMaybe now mbBlockTime + -- -- Code would work, but problematic -- oks <- E.insertSelectCount . E.from $ \qualificationUser -> do - -- E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid + -- E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid -- E.&&. qualificationUser E.^. QualificationUserUser E.in_ E.valList uid -- E.&&. quserBlock unblock blockTime qualificationUser -- only unblock blocked qualification and vice versa -- return $ QualificationUserBlock @@ -242,7 +242,7 @@ qualificationUserBlocking qid uids unblock mbBlockTime (qualificationChangeReaso -- E.<&> E.val authUsr toChange <- E.select $ do qualUser <- E.from $ E.table @QualificationUser - E.where_ $ qualUser E.^. QualificationUserQualification E.==. E.val qid + E.where_ $ qualUser E.^. QualificationUserQualification E.==. E.val qid E.&&. qualUser E.^. QualificationUserUser `E.in_` E.valList uids E.&&. quserBlock unblock blockTime qualUser -- only unblock blocked qualification and vice versa return (qualUser E.^. QualificationUserId, qualUser E.^. QualificationUserUser) @@ -262,7 +262,7 @@ qualificationUserBlocking qid uids unblock mbBlockTime (qualificationChangeReaso } return $ fromIntegral $ length newBlocks -qualificationUserUnblockByReason :: +qualificationUserUnblockByReason :: ( AuthId (HandlerSite m) ~ Key User , IsPersistBackend (YesodPersistBackend (HandlerSite m)) , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend @@ -277,11 +277,11 @@ qualificationUserUnblockByReason :: , Num n ) => QualificationId -> [UserId] -> Maybe UTCTime -> QualificationChangeReason -> QualificationChangeReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationChangeReasonText -> reason) undo_reason notify = do - cutoff <- maybe (liftIO getCurrentTime) return mbUnblockTime + cutoff <- maybe (liftIO getCurrentTime) return mbUnblockTime toUnblock <- E.select $ do quser <- E.from $ E.table @QualificationUser E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.&&. quser E.^. QualificationUserUser `E.in_` E.valList uids E.&&. quserBlockAux True (E.val cutoff) (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason)) return $ quser E.^. QualificationUserUser - qualificationUserBlocking qid (E.unValue <$> toUnblock) True mbUnblockTime undo_reason notify + qualificationUserBlocking qid (E.unValue <$> toUnblock) True mbUnblockTime undo_reason notify diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index b2440e73e..63e6d454b 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -129,7 +129,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act qprefix = fst <$> Text.uncons (Text.toLower qshort) identsInUseVs <- E.select $ do lui <- E.from $ - ( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser ) ) -- no filter by Qid, since LmsIdents must be unique across all + ( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser ) ) -- no filter by qid, since LmsIdents must be unique across all `E.union_` ( (E.^. LmsReportIdent) <$> E.from (E.table @LmsReport ) ) -- V2 E.orderBy [E.asc lui] @@ -152,20 +152,20 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act , lmsUserEnded = Nothing , lmsUserResetTries = False , lmsUserLocked = True -- initially display locked, since it is not yet available until the first feedback - } + } -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser)) startLmsUser = do - lpw <- randomLMSpw + lpw <- randomLMSpw maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse) -- runMaybeT $ do -- lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse -- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid getBy uniqLmsUse >>= \case - Just Entity{entityVal=LmsUser{..}} - | isNothing lmsUserEnded, isNothing lmsUserStatus || lmsUserStatus == Just LmsSuccess -> do + Just Entity{entityVal=LmsUser{..}} + | isNothing lmsUserEnded, isNothing lmsUserStatus || lmsUserStatus == Just LmsSuccess -> do uuid :: CryptoUUIDUser <- encrypt uid $logErrorS "LMS" $ "Generating fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> " due to LMS still existing!" - other -> do + other -> do when (isJust other) $ deleteBy uniqLmsUse untilJustMaxM maxLmsUserIdentRetries startLmsUser >>= \case Nothing -> do @@ -211,7 +211,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act E.where_ $ E.isNothing (luser E.^. LmsUserStatus) E.&&. luser E.^. LmsUserQualification E.==. E.val qid E.&&. (luser E.^. LmsUserId) `E.in_` E.valList expiredLearners - let dequeueInfo = "Blocked qualification holders " <> tshow nrBlocked <> " out of expired lms users " <> tshow nrExpired <> " for qualification " <> qshort + let dequeueInfo = "Blocked qualification holders " <> tshow nrBlocked <> " out of expired lms users " <> tshow nrExpired <> " for qualification " <> qshort $logInfoS "LMS" dequeueInfo when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index c0c2097db..ac6419dfa 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -8,13 +8,13 @@ Description: Types for Learning Management System Interface operated by Know how -} module Model.Types.Lms - ( module Model.Types.Lms + ( module Model.Types.Lms ) where import Import.NoModel -- import qualified Data.Map as Map -- import Data.Map ((!)) -import Database.Persist.Sql +import Database.Persist.Sql import qualified Database.Esqueleto.Experimental as E import qualified Data.Csv as Csv import qualified Data.Time.Format as Time @@ -28,19 +28,19 @@ instance E.SqlString LmsIdent makeLenses_ ''LmsIdent deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 + { constructorTagModifier = camelToPathPiece' 1 , fieldLabelModifier = camelToPathPiece' 2 - , omitNothingFields = True - } ''LmsIdent + , omitNothingFields = True + } ''LmsIdent -- TODO: Is this a good idea? An ordinary Enum and a separate Day column in the DB would be better, e.g. allowing use of insertSelect in Jobs.Handler.LMS? -- ...also see similar type QualificationBlocked data LmsStatus = LmsExpired - | LmsBlocked + | LmsBlocked | LmsSuccess - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, NFData, Universe, Finite) + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, NFData, Universe, Finite) --- embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3) -- moved to src/Foundation.hs +-- embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3) -- moved to src/Foundation.I18n deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor @@ -59,22 +59,22 @@ instance Csv.ToField LmsStatus where data QualificationStandardReason = QualificationRenewELearningBy LmsIdent | QualificationBlockFailedELearningBy LmsIdent - | QualificationBlockFailedELearning + | QualificationBlockFailedELearning | QualificationBlockReturnedByCompany | QualificationBlockExpired - + -- deriving (Eq, Ord, Enum, Bounded, Universe, Finite) instance Show QualificationStandardReason where show (QualificationRenewELearningBy lid) = "E-Learning bestanden für " <> show lid show (QualificationBlockFailedELearningBy lid) = "E-Learning durchgefallen für " <> show lid - show QualificationBlockFailedELearning = "E-Learning durchgefallen" + show QualificationBlockFailedELearning = "E-Learning durchgefallen" show QualificationBlockReturnedByCompany = "Rückgabe Firma" show QualificationBlockExpired = "Abgelaufen" - + {- qualificationBlockedReasonText :: QualificationStandardReason -> Text -qualificationBlockedReasonText = +qualificationBlockedReasonText = let dictionary :: Map.Map QualificationStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF] in (dictionary !) -- cannot fail due to universeF @@ -95,13 +95,13 @@ newtype LmsBool = LmsBool { lms2bool :: Bool } _lmsBool :: Iso' Bool LmsBool _lmsBool = iso LmsBool lms2bool -instance Csv.ToField LmsBool where +instance Csv.ToField LmsBool where toField (LmsBool False) = "0" toField (LmsBool True ) = "1" - -instance Csv.FromField LmsBool where + +instance Csv.FromField LmsBool where parseField "0" = pure $ LmsBool False - parseField "1" = pure $ LmsBool True + parseField "1" = pure $ LmsBool True parseField _ = mempty -- | Only to be used in LMS interface communicating user status @@ -110,18 +110,18 @@ data LmsState = LmsFailed | LmsOpen | LmsPassed instance Csv.ToField LmsState where toField LmsFailed = "0" - toField LmsOpen = "1" + toField LmsOpen = "1" toField LmsPassed = "2" instance Csv.FromField LmsState where parseField "0" = pure LmsFailed parseField "1" = pure LmsOpen parseField "2" = pure LmsPassed - parseField _ = mempty + parseField _ = mempty deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor - , fieldLabelModifier = camelToPathPiece' 1 + , fieldLabelModifier = camelToPathPiece' 1 , sumEncoding = UntaggedValue } ''LmsState derivePersistFieldJSON ''LmsState @@ -132,21 +132,21 @@ nullaryPathPiece ''LmsState $ camelToPathPiece' 1 newtype LmsDay = LmsDay { lms2day :: Day } deriving (Eq, Ord, Read, Show, Generic) -_lmsDay :: Iso' Day LmsDay +_lmsDay :: Iso' Day LmsDay _lmsDay = iso LmsDay lms2day -- | Format for day for LMS interface -lmsDayFormat :: String +lmsDayFormat :: String lmsDayFormat = "%d-%m-%Y" -- fixed in LMS interface desctiption, due defaultTimeLocale, should not use named entities like weekdays or month names -instance Csv.ToField LmsDay where +instance Csv.ToField LmsDay where toField (LmsDay d) = Csv.toField $ Time.formatTime Time.defaultTimeLocale lmsDayFormat d -- TimeLocale should not matter since format string does not use names; getTimeLocale requires MonadHandler -instance Csv.FromField LmsDay where +instance Csv.FromField LmsDay where -- parseField = fmap LmsDay . parseLmsDay <=< Csv.parseField -- where parseLmsDay = Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat - parseField i = do - s <- Csv.parseField i + parseField i = do + s <- Csv.parseField i d <- Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat s <|> iso8601ParseM s -- Know-How AG considers supplying iso8601 dates in the future return $ LmsDay d @@ -155,21 +155,21 @@ instance Csv.FromField LmsDay where newtype LmsTimestamp = LmsTimestamp { lms2timestamp :: UTCTime } deriving (Eq, Ord, Read, Show, Generic) -_lmsTimestamp :: Iso' UTCTime LmsTimestamp +_lmsTimestamp :: Iso' UTCTime LmsTimestamp _lmsTimestamp = iso LmsTimestamp lms2timestamp -- | Format for day for LMS interface -lmsTimestampFormat :: String +lmsTimestampFormat :: String lmsTimestampFormat = "%d-%m-%Y %T" -- fixed in LMS interface desctiption, due defaultTimeLocale, should not use named entities like weekdays or month names -instance Csv.ToField LmsTimestamp where +instance Csv.ToField LmsTimestamp where toField (LmsTimestamp d) = Csv.toField $ Time.formatTime Time.defaultTimeLocale lmsTimestampFormat d -- TimeLocale should not matter since format string does not use names; getTimeLocale requires MonadHandler -instance Csv.FromField LmsTimestamp where +instance Csv.FromField LmsTimestamp where -- parseField = fmap LmsDay . parseLmsDay <=< Csv.parseField -- where parseLmsDay = Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat - parseField i = do - s <- Csv.parseField i + parseField i = do + s <- Csv.parseField i d <- Time.parseTimeM True Time.defaultTimeLocale lmsTimestampFormat s <|> (utctDayMidnight <$> Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat s) <|> iso8601ParseM s -- Know-How AG considers supplying iso8601 dates in the future