fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' of gitlab.uniworx.de:fradrive/fradrive

Browse Source
This commit is contained in:
Sarah Vaupel 2023-05-15 16:14:19 +00:00
commit 6fb608936d
23 changed files with 178 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.mailmap
View File

@ -2,7 +2,8 @@ Gregor Kleen <gregor@kleen.consulting> <gregor.kleen@ifi.lmu.de>
Gregor Kleen <gregor@kleen.consulting> <kleen@cip.ifi.lmu.de>
Gregor Kleen <gregor@kleen.consulting> <gkleen@yggdrasil.li>
Felix Hamann <felix.hamann@campus.lmu.de> <felix.hamann@satellytes.com>
Steffen Jost <jost@tcs.ifi.lmu.de> <jost@tcs.ifi.lmu.de>
Steffen Jost <s.jost@fraport.de> <jost@tcs.ifi.lmu.de>
Steffen Jost <s.jost@fraport.de> <jost@cip.ifi.lmu.de>
Sarah Vaupel <vaupel.sarah@campus.lmu.de> <vaupel@cip.ifi.lmu.de>
Sarah Vaupel <vaupel.sarah@campus.lmu.de> Sarah Vaupel <>
Winnie Ros <winnie.ros@campus.lmu.de> <ros@cip.ifi.lmu.de>

2
CHANGELOG.md
View File

@ -2,6 +2,8 @@
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
## [27.4.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.2...v27.4.3) (2023-05-12)
## [27.4.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.1...v27.4.2) (2023-05-09)
## [27.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.0...v27.4.1) (2023-05-08)

31
messages/uniworx/categories/qualification/de-de-formal.msg
View File

@ -35,11 +35,11 @@ QualificationExpired: Ungültig seit
LmsUser: Inhaber
LmsURL: Link E‑Learning
TableLmsEmail: E‑Mail
TableLmsIdent: LMS Identifikation
TableLmsIdent: E-Learnung Benutzer
TableLmsElearning: E‑Learning
TableLmsPin: E‑Learning Pin
TableLmsResetPin: Pin zurücksetzen?
TableLmsDatePin: Pin erstellt
TableLmsPin: E‑Learning Passwort
TableLmsResetPin: E-Learning Passwort zurücksetzen?
TableLmsDatePin: E-Learning Passwort erstellt
TableLmsDelete: Löschen?
TableLmsStaff: Interner Mitarbeiter?
TableLmsStarted: Begonnen
@ -61,8 +61,8 @@ FilterLmsValid: Aktuell gültig
FilterLmsRenewal: Erneuerung anstehend
FilterLmsNotified: Benachrichtigt
CsvColumnLmsIdent: E‑Learning Identifikator, einzigartig pro Qualifikation und Teilnehmer
CsvColumnLmsPin: PIN des E#{nonBreakableDash}Learning Zugangs
CsvColumnLmsResetPin: Wird die PIN bei der nächsten Synchronisation zurückgesetzt?
CsvColumnLmsPin: Passwort E#{nonBreakableDash}Learning Zugang
CsvColumnLmsResetPin: Wird das E-Learning Passwort bei der nächsten Synchronisation zurückgesetzt?
CsvColumnLmsDelete: Wird der Identifikator in der E‑Learning Plattform bei der nächsten Synchronisation gelöscht?
CsvColumnLmsStaff: Handelt es sich um einen internen Mitarbeiter? (Aus historischen Gründen, wird momentan ignoriert.)
CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme (UTC)
@ -82,24 +82,31 @@ MailBodyQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst
MailBodyQualificationExpiry: Diese Qualifikation läuft bald ab. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen dann nicht länger ausgeübt werden!
MailBodyQualificationExpired: Diese Qualifikation is nun abgelaufen. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen ab sofort nicht länger ausgeübt werden! Es ist möglich, dass die Qualifikation vorzeit ungültig wurde, z.B. wegen erfolgloser Teilnahme an einem verpflichtendem E‑Learning.
QualificationActExpire: Auslaufend markieren - keine Benachrichtigung zur Erneuerung senden
QualificationActUnexpire: Auslaufend aufheben - kostenpflichtige Benachrichtigung bei anstehender Erneuerung senden
QualificationActUnexpire: Auslaufend aufheben - zur Erneuerung benachrichtigen
QualificationActUnexpireWarning: Benachrichtigungen bei anstehender Erneuerung können kostenpflichtig sein!
QualificationSetExpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E‑Learning abgeschaltet für #{n} #{pluralDE n "Person" "Personen"}
QualificationSetUnexpire n@Int64: Benachrichtigung bei anstehender Erneuerung und E‑Learning aktiviert für #{n} #{pluralDE n "Person" "Personen"}
QualificationActBlockSupervisor: Dauerhaft entziehen und Ansprechpartner entfernen, mit sofortiger Wirkung
QualificationActBlock: Entziehen
QualificationActUnblock: Entzug löschen
QualificationActGrant: Qualifikation vergeben
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.
QualificationStatusBlock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen
QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert
LmsRenewalInstructions: Weitere Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF mit dem im FRADrive hinterlegten PDF-Passwort des Prüflings verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort die Flughafen Ausweisnummer, inklusive Punkt und der Ziffer danach.
LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E‑Learning verlängert werden.
LmsActNotify: Benachrichtigung E‑Learning erneut per Post oder E-Mail versenden
LmsActRenewPin: Neue zufällige E‑Learning PIN zuweisen
LmsActRenewNotify: Neue zufällige E‑Learning PIN zuweisen und Benachrichtigung per Post oder E-Mail versenden
LmsActRenewPin: Neues zufällige E‑Learning Passwort zuweisen
LmsActRenewNotify: Neue zufällige E‑Learning Passwort zuweisen und Benachrichtigung per Post oder E-Mail versenden
LmsActRestart: E-Learning neu starten
LmsActRestartWarning: Das vorhandene E-Learning wird sofort komplett gelöscht! Für Inhaber einer gültigen Fahrlizenz werden später Benutzer und Passwort neu vergeben und es wird eine neue Benachrichtigung versendet werden.
LmsActRestartFeedback n@Int m@Int: #{n}/#{m} E-Learning wurden neu gestartet.
LmsActRestartExtend: Gültig bis ggf. erhöhen für die nächsten # Tage
LmsActRestartUnblock: Entzug ggf. aufheben
LmsStatusNotificationSent: Anmeldedaten wurden an Prüfling oder Ansprechpartner per Post oder E#{nonBreakableDash}Mail versendet; E#{nonBreakableDash}Learning ist derzeit offen
LmsNotificationSend n@Int: E‑Learning Benachrichtigungen an #{n} #{pluralDE n "Prüfling" "Prüflinge"} werden per Post oder E-Mail versendet.
LmsPinRenewal n@Int: E‑Learning Pin ausgetauscht für #{n} #{pluralDE n "Prüfling" "Prüflinge"}.
LmsPinRenewal n@Int: E‑Learning Passwort ausgetauscht für #{n} #{pluralDE n "Prüfling" "Prüflinge"}.
LmsActionFailed n@Int: Aktion nicht durchgeführt für #{n} #{pluralDE n "Person" "Personen"}, da diese derzeit nicht an einer Prüfung teilnehmen.
LmsStarted: E‑Learning eröffnet
LmsAutomaticQueuing n@Natural: Die folgenden Funktionen werden normalerweise einmal pro Tag um #{show n} Uhr ausgeführt.

31
messages/uniworx/categories/qualification/en-eu.msg
View File

@ -35,11 +35,11 @@ QualificationExpired: Expired on
LmsUser: Licensee
LmsURL: Link E-learning
TableLmsEmail: Email
TableLmsIdent: LMS Identifier
TableLmsPin: E‑learning pin
TableLmsIdent: E-learning user
TableLmsPin: E‑learning password
TableLmsElearning: E‑learning
TableLmsResetPin: Reset pin?
TableLmsDatePin: Pin created
TableLmsResetPin: Reset E-learning password?
TableLmsDatePin: E-learning password created
TableLmsDelete: Delete?
TableLmsStaff: Staff?
TableLmsStarted: Started
@ -61,8 +61,8 @@ FilterLmsValid: Currently valid
FilterLmsRenewal: Renewal due
FilterLmsNotified: Notified
CsvColumnLmsIdent: E#{nonBreakableDash}learning identifier, unique for each qualification and user
CsvColumnLmsPin: PIN for e#{nonBreakableDash}learning access
CsvColumnLmsResetPin: Will the e#{nonBreakableDash}learning PIN be reset upon next synchronisation?
CsvColumnLmsPin: Password e#{nonBreakableDash}learning access
CsvColumnLmsResetPin: Will the e#{nonBreakableDash}learning password be reset upon next synchronisation?
CsvColumnLmsDelete: Will the identifier be deleted from the E-learning platfrom upon next synchronisation?
CsvColumnLmsStaff: Is the user an internal staff member? (Legacy, currently ignored)
CsvColumnLmsSuccess: Timestamp of successful completion (UTC)
@ -82,24 +82,31 @@ MailBodyQualificationRenewal qname: The qualification #{qname} must be renewed s
MailBodyQualificationExpiry: This qualification expires soon. You may then no longer execute any duties that require this qualification as a precondition!
MailBodyQualificationExpired: This qualification is now expired. You may no longer execute any duties that require this qualification as a precondition! It is possible that the qualification expired prematurely, e.g. due to a failed compulsory e‑learning.
QualificationActExpire: Discontinue - qualification expires silently
QualificationActUnexpire: Continue - send a possibly fee-paying notification upon due renewal
QualificationActUnexpire: Continue - notify for renwals
QualificationActUnexpireWarning: Renewal notification may incur a fee!
QualificationSetExpire n: Expiry notification and e‑learning deactivated for #{n} #{pluralENs n "person"}
QualificationSetUnexpire n: Expiry notification and e‑learning activated for #{n} #{pluralENs n "person"}
QualificationActBlockSupervisor: Waive permanently and remove all supervisiors, effective immediately
QualificationActBlock: Revoke
QualificationActUnblock: Clear revocation
QualificationActGrant: Grant qualification
QualificationActRenew: Renew qualification
QualificationActGrant: Grant qualification
QualificationActGrantWarning: Use with caution in rare exceptional cases only! Any revocation will be undone.
QualificationStatusBlock l n m: #{n}/#{m} #{l} revoked
QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated
LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with the FRADrive PDF-password of the examinee. If no PDF-password had been chosen yet, then the password is the Fraport id card number of the examinee, including the punctuation mark and the digit thereafter.
LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through E-learning only.
LmsActNotify: Resend e‑learning notification by post or email
LmsActRenewPin: Randomly replace e‑learning PIN
LmsActRenewNotify: Randomly replace e‑learning PIN and re-send notification by post or email
LmsStatusNotificationSent: E-learning pin has been sent to examinee or supervisor by letter post or by email; e‑learning is currently open
LmsActRenewPin: Randomly replace e‑learning password
LmsActRenewNotify: Randomly replace e‑learning password and re-send notification by post or email
LmsActRestart: Restart e-learning
LmsActRestartWarning: The existing e-learning will be erased immediately! For drivers with a valid licence, user and password will later be generated anew and a notification will be queued as usual.
LmsActRestartExtend: Ensure validity for the next # days
LmsActRestartUnblock: Undo any revocations
LmsActRestartFeedback n@Int m@Int: #{n}/#{m} e-learnings were restarted.
LmsStatusNotificationSent: E-learning password has been sent to examinee or supervisor by letter post or by email; e‑learning is currently open
LmsNotificationSend n: E-learning notifications will be sent to #{n} #{pluralENs n "examinee"} by letter post or by email.
LmsPinRenewal n: E-learning pin replaced randomly for #{n} #{pluralENs n "examinee"}.
LmsPinRenewal n: E-learning password replaced randomly for #{n} #{pluralENs n "examinee"}.
LmsActionFailed n: No action for #{n} #{pluralENs n "person"}, since there was no ongoing examination.
LmsStarted: E-learning open since
LmsAutomaticQueuing n@Natural: The following functions are executed daily at #{show n} o'clock.

2
models/company.model
View File

@ -13,7 +13,7 @@ Company
UniqueCompanyName name
UniqueCompanyShorthand shorthand
-- UniqueCompanyAvsId avsId -- should be the case, unclear if enforcing works here, since we cannot query avs by company id
Primary shorthand -- newtype Key Company = CompanyKey { unSchoolKey :: CompanyShorthand }
Primary shorthand -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand }
deriving Ord Eq Show Generic Binary
-- TODO: a way to populate this table (manually)

2
nix/docker/demo-version.json
View File

@ -1,3 +1,3 @@
{
"version": "27.4.2"
"version": "27.4.3"
}

2
nix/docker/version.json
View File

@ -1,3 +1,3 @@
{
"version": "27.4.2"
"version": "27.4.3"
}

2
package-lock.json generated
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "27.4.2",
"version": "27.4.3",
"lockfileVersion": 1,
"requires": true,
"dependencies": {

2
package.json
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "27.4.2",
"version": "27.4.3",
"description": "",
"keywords": [],
"author": "",

2
package.yaml
View File

@ -1,5 +1,5 @@
name: uniworx
version: 27.4.2
version: 27.4.3
dependencies:
- base
- yesod

2
routes
View File

@ -279,9 +279,11 @@
/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST
/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST !development
/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS
/lms/#SchoolId/#QualificationShorthand/ident/#LmsIdent LmsIdentR GET -- redirect to LmsR with filter-parameter
/lmsuser/#CryptoUUIDUser LmsUserR GET
/api ApiDocsR GET !free
/swagger SwaggerR GET !free
/swagger.json SwaggerJsonR GET !free

1
src/Foundation/Navigation.hs
View File

@ -185,6 +185,7 @@ breadcrumb (LmsUserlistDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Jus
breadcrumb (LmsResultR ssh qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsR ssh qsh
breadcrumb (LmsResultUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh
breadcrumb (LmsResultDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -- never displayed
breadcrumb (LmsIdentR ssh qsh _ ) = breadcrumb $ LmsR ssh qsh -- just a redirect
breadcrumb (LmsUserR _) = i18nCrumb MsgMenuLmsUser $ Just LmsAllR
-- breadcrumb (LmsFakeR ssh qsh) = i18nCrumb MsgMenuLmsFake $ Just $ LmsR ssh qsh -- TODO: remove in production

2
src/Handler/Admin/Avs.hs
View File

@ -605,7 +605,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
then singletonMap LicenceTableRevokeFDrive $ LicenceTableRevokeFDriveData
<$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
<*> apreq textField (fslI MsgQualificationBlockReason) Nothing
<*> apreq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData
<$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid

123
src/Handler/LMS.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2023 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -10,6 +10,7 @@ module Handler.LMS
( getLmsAllR , postLmsAllR
, getLmsSchoolR
, getLmsR , postLmsR
, getLmsIdentR
, getLmsEditR , postLmsEditR
, getLmsUsersR , getLmsUsersDirectR
, getLmsUserlistR , postLmsUserlistR
@ -41,6 +42,7 @@ import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.PostgreSQL as E
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
import Database.Persist.Sql (deleteWhereCount)
import Handler.LMS.Users as Handler.LMS
import Handler.LMS.Userlist as Handler.LMS
@ -316,6 +318,7 @@ instance HasUser LmsTableData where
data LmsTableAction = LmsActNotify
| LmsActRenewNotify
| LmsActRenewPin
| LmsActRestart
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe LmsTableAction
@ -326,18 +329,22 @@ embedRenderMessage ''UniWorX ''LmsTableAction id
-- Not yet needed, since there is no additional data for now:
data LmsTableActionData = LmsActNotifyData
| LmsActRenewNotifyData
| LmsActRenewPinData -- no longer used
| LmsActRenewPinData -- no longer used
| LmsActRestartData
{ lmsActRestartExtend :: Maybe Integer
, lmsActRestartUnblock :: Maybe Bool
}
deriving (Eq, Ord, Read, Show, Generic)
isNotifyAct :: LmsTableActionData -> Bool
isNotifyAct LmsActNotifyData = True
isNotifyAct LmsActRenewNotifyData = True
isNotifyAct LmsActRenewPinData = False
isNotifyAct _ = False
isRenewPinAct :: LmsTableActionData -> Bool
isRenewPinAct LmsActNotifyData = False
isRenewPinAct LmsActRenewNotifyData = True
isRenewPinAct LmsActRenewPinData = True
isRenewPinAct _ = False
lmsTableQuery :: QualificationId -> LmsTableExpr
-> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
@ -378,14 +385,14 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
now <- liftIO getCurrentTime
-- lookup all companies
cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
cmps <- selectList [] [Asc CompanyId]
return $ Map.fromAscList $ fmap (\c -> (entityKey c, entityVal c)) cmps
cmps <- selectList [] [] -- [Asc CompanyShorthand]
return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
let
nowaday = utctDay now
-- mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
dbtIdent :: Text
dbtIdent = "qualification"
dbtIdent = "lms"
dbtSQLQuery = lmsTableQuery qid
dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, printAcks) -> do
@ -401,14 +408,14 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
, single ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
, single ("blocked-due" , SortColumnNeverNull$ queryQualUser >>> (E.^. QualificationUserBlockedDue))
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
, single ("lms-ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent))
, single ("lms-pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin))
, single ("lms-status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatus))
, single ("lms-started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted))
, single ("lms-datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin))
, single ("lms-received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived))
, single ("lms-notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date
, single ("lms-ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded))
, single ("ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent))
, single ("pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin))
, single ("status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatus))
, single ("started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted))
, single ("datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin))
, single ("received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived))
, single ("notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date
, single ("ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded))
, single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
@ -418,8 +425,8 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
]
dbtFilter = mconcat
[ single $ fltrUserNameEmail queryUser
, single ("lms-ident" , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent))
-- , single ("lms-status" , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB
, single ("ident" , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent))
-- , single ("status" , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB
-- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday))
-- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
@ -428,7 +435,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
-- E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
-- | otherwise -> E.true
-- )
, single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified)))
, single ("notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified)))
, single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion ->
E.from $ \usrAvs -> -- do
E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId
@ -461,10 +468,10 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
, prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
, prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo)
, prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
, prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
, prismAForm (singletonFilter "ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
, 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)
-- , prismAForm (singletonFilter "lms-status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus)
, prismAForm (singletonFilter "notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified)
-- , prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus)
-- , if isNothing mbRenewal then mempty
-- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
]
@ -538,7 +545,8 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsR = postLmsR
postLmsR sid qsh = do
isAdmin <- hasReadAccessTo AdminR
isAdmin <- hasReadAccessTo AdminR
msgRestartWarning <- messageIconI Warning IconWarning MsgLmsActRestartWarning
((lmsRes, lmsTable), Entity qid quali) <- runDB $ do
qent <- getBy404 $ SchoolQualificationShort sid qsh
let acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
@ -546,6 +554,11 @@ postLmsR sid qsh = do
[ singletonMap LmsActNotify $ pure LmsActNotifyData
, singletonMap LmsActRenewNotify $ pure LmsActRenewNotifyData
-- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData
, singletonMap LmsActRestart $ LmsActRestartData
<$> aopt intField (fslI MsgLmsActRestartExtend) Nothing
<*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing
-- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing
<* aformMessage msgRestartWarning
]
-- lmsStatusLink = toMaybe isAdmin LmsUserR
colChoices cmpMap = mconcat
@ -556,7 +569,7 @@ postLmsR sid qsh = do
let icnSuper = text2markup " " <> icon IconSupervisor
cs = [ (cmpName, cmpSpr)
| Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
, let cmpName = maybe cmpId companyName $ Map.lookup cmpId cmpMap
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
]
companies = intercalate (text2markup ", ") $
(\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs
@ -569,15 +582,16 @@ postLmsR sid qsh = do
) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
, sortable (Just "lms-ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid
, sortable (Just "lms-pin") (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)]
, sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid
, sortable (Just "pin") (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)]
) $ \(view $ resultLmsUser . _entityVal . _lmsUserPin -> pin) -> textCell pin
, sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(view $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell status
, sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(view $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> dateTimeCell d
, sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(view $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> dateTimeCell d
, sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(view $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell d
--, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \(view $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d
, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified & cellTooltip MsgTableLmsNotifiedTooltip) $ \row ->
, sortable (Just "status") (i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin $ qent ^. _entityVal . _qualificationAuditDuration))
$ \(view $ resultLmsUser . _entityVal -> lmsUserVal) -> lmsStatusCell isAdmin Nothing lmsUserVal
, sortable (Just "started") (i18nLms MsgTableLmsStarted) $ \(view $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> dateTimeCell d
, sortable (Just "datepin") (i18nLms MsgTableLmsDatePin) $ \(view $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> dateTimeCell d
, sortable (Just "received") (i18nLms MsgTableLmsReceived) $ \(view $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell d
--, sortable (Just "notified") (i18nLms MsgTableLmsNotified) $ \(view $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d
, sortable (Just "notified") (i18nLms MsgTableLmsNotified & cellTooltip MsgTableLmsNotifiedTooltip) $ \row ->
-- 4 Cases:
-- - No notification: LmsUserNotified == Nothing
-- - Email sent : LmsUserNotified == Just _ && PrintJobId == Nothing
@ -617,19 +631,52 @@ postLmsR sid qsh = do
in if notNotified
then mempty
else cIcon <> spacerCell <> cDate <> cAckDates
-- , sortable (Just "lms-notified-alternative") (i18nLms MsgTableLmsNotified) $ \(preview resultPrintAck -> d) -> textCell (show d)
, sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(view $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell d
-- , sortable (Just "notified-alternative") (i18nLms MsgTableLmsNotified) $ \(preview resultPrintAck -> d) -> textCell (show d)
, sortable (Just "ended") (i18nLms MsgTableLmsEnded) $ \(view $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell d
]
where
-- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg
psValidator = def & defaultSorting [SortDescBy "lms-started", SortDescBy "lms-status"]
psValidator = def & defaultSorting [SortDescBy "started", SortDescBy "status"]
tbl <- mkLmsTable isAdmin qent acts colChoices psValidator
return (tbl, qent)
formResult lmsRes $ \case
_ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page
(action, selectedUsers) -> do -- | isRenewPinAct action || isNotifyAct action -> do
(LmsActRestartData{..}, selectedUsers) -> do
let usersList = Set.toList selectedUsers
delUsers <- runDB $ do
when (lmsActRestartUnblock == Just True) $ do
unblockUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList
[ QualificationUserQualification ==. qid
, QualificationUserUser <-. usersList
, QualificationUserBlockedDue !=. Nothing
] []
void $ qualificationUserBlocking qid unblockUsers False Nothing
whenIsJust lmsActRestartExtend $ \extDays -> do
now <- liftIO getCurrentTime
let nowaday = utctDay now
cutoff = addDays extDays nowaday
shortUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList
[ QualificationUserQualification ==. qid
, QualificationUserUser <-. usersList
, QualificationUserBlockedDue ==. Nothing
, QualificationUserValidUntil <. cutoff
] []
forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing
fromIntegral <$> deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList]
runDBJobs $ forM_ selectedUsers $ \uid ->
queueDBJob $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
let numUsers = length selectedUsers
mStatus = bool Success Warning $ delUsers < numUsers
addMessageI mStatus $ MsgLmsActRestartFeedback delUsers numUsers
reloadKeepGetParams $ LmsR sid qsh
(action, selectedUsers) | isRenewPinAct action || isNotifyAct action -> do
now <- liftIO getCurrentTime
numExaminees <- runDBJobs $ do
okUsers <- selectList [LmsUserUser <-. Set.toList selectedUsers, LmsUserQualification ==. qid] []
@ -646,14 +693,18 @@ postLmsR sid qsh = do
when (isNotifyAct action) $ addMessageI Success $ MsgLmsNotificationSend numExaminees
when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected
reloadKeepGetParams $ LmsR sid qsh
_ -> addMessageI Error MsgUnauthorized -- should not happen
let heading = citext2widget $ "LMS " <> qualificationName quali
siteLayout heading $ do
setTitle $ toHtml $ "LMS " <> unSchoolKey sid <> "-" <> qsh
$(widgetFile "lms")
-- redirect to a specific lms user
getLmsIdentR :: SchoolId -> QualificationShorthand -> LmsIdent -> Handler Html
getLmsIdentR sid qid ident = redirect (LmsR sid qid, [("lms-ident", toPathPiece ident)])
-- intended to be viewed primarily in a modal, wie lmsStatusPlusCell
-- intended to be viewed primarily in a modal, wie lmsStatusCell
getLmsUserR :: CryptoUUIDUser -> Handler Html
getLmsUserR uuid = do
uid <- decrypt uuid

25
src/Handler/Qualification.hs
View File

@ -314,8 +314,8 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
now <- liftIO getCurrentTime
-- lookup all companies
cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
cmps <- selectList [] [Asc CompanyId]
return $ Map.fromAscList $ fmap (\c -> (entityKey c, entityVal c)) cmps
cmps <- selectList [] [] -- [Asc CompanyShorthand]
return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
let
nowaday = utctDay now
mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
@ -342,8 +342,6 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
, single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
, single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified))
, single ("blocked-due" , SortColumnNeverNull $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
-- , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted))
-- , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
, single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}"
, queryLmsUser row E.?. LmsUserStarted])
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
@ -470,7 +468,9 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html
getQualificationR = postQualificationR
postQualificationR sid qsh = do
isAdmin <- hasReadAccessTo AdminR
isAdmin <- hasReadAccessTo AdminR
msgGrantWarning <- messageIconI Warning IconWarning MsgQualificationActGrantWarning
msgUnexpire <- messageIconI Info IconWarning MsgQualificationActUnexpireWarning
now <- liftIO getCurrentTime
let nowaday = utctDay now
((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
@ -483,7 +483,8 @@ postQualificationR sid qsh = do
acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
acts = mconcat $
[ singletonMap QualificationActExpire $ pure QualificationActExpireData
, singletonMap QualificationActUnexpire $ pure QualificationActUnexpireData
, singletonMap QualificationActUnexpire $ QualificationActUnexpireData
<$ aformMessage msgUnexpire
] ++ bool
[ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- nonAdmin actions, ie. Supervisor
[ singletonMap QualificationActUnblock $ pure QualificationActUnblockData -- Admin-only actions
@ -491,8 +492,9 @@ postQualificationR sid qsh = do
<$> apreq textField (fslI MsgQualificationBlockReason) Nothing
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
, singletonMap QualificationActRenew $ pure QualificationActRenewData
, singletonMap QualificationActGrant
(QualificationActGrantData <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry)
, singletonMap QualificationActGrant $ QualificationActGrantData
<$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
<* aformMessage msgGrantWarning
] isAdmin
linkLmsUser = toMaybe isAdmin LmsUserR
linkUserName = bool ForProfileR ForProfileDataR isAdmin
@ -505,7 +507,7 @@ postQualificationR sid qsh = do
let icnSuper = text2markup " " <> icon IconSupervisor
cs = [ (cmpName, cmpSpr)
| Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
, let cmpName = maybe cmpId companyName $ Map.lookup cmpId cmpMap
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
]
companies = intercalate (text2markup ", ") $
(\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs
@ -517,11 +519,8 @@ postQualificationR sid qsh = do
) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> blockedDueCell b
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
-- , sortable (Just "lms-started") (i18nCell MsgTableLmsElearning <> spacerCell <> i18nCell MsgTableLmsStarted)
-- $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d
-- , sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status
, sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths))
$ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusPlusCell linkLmsUser) lu
$ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusCell isAdmin linkLmsUser) lu
, sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified) $ \( view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d
]
psValidator = def & defaultSorting [SortDescBy "last-refresh"]

17
src/Handler/Utils/Table/Cells.hs
View File

@ -13,7 +13,7 @@ import Handler.Utils.Table.Pagination
import Handler.Utils.DateTime
import Handler.Utils.Widgets
import Handler.Utils.Occurrences
import Handler.Utils.LMS (lmsUserStatusWidget, lmsStatusIcon)
import Handler.Utils.LMS (lmsUserStatusWidget)
type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles !
@ -364,18 +364,11 @@ roomReferenceCell = cell . roomReferenceWidget
cryptoidCell :: (IsDBTable m a, PathPiece cid) => cid -> DBCell m a
cryptoidCell = addCellClass ("cryptoid" :: Text) . textCell . toPathPiece
lmsStatusCell :: IsDBTable m a => LmsStatus -> DBCell m a
lmsStatusCell ls = iconCell (lmsStatusIcon ls) <> spacerCell <> dayCell (lmsStatusDay ls)
-- lmsStatusPlusCell :: IsDBTable m a => LmsUser -> DBCell m a
-- lmsStatusPlusCell LmsUser{lmsUserStatus=Just lStat} = lmsStatusCell lStat
-- lmsStatusPlusCell LmsUser{lmsUserStarted} = iconCell IconWaitingForUser <> spacerCell <> dateCell lmsUserStarted
lmsStatusPlusCell :: IsDBTable m a => Maybe (CryptoUUIDUser -> Route UniWorX) -> LmsUser -> DBCell m a
lmsStatusPlusCell Nothing lu = wgtCell $ lmsUserStatusWidget False lu
lmsStatusPlusCell (Just toLink) lu = cell $ do
lmsStatusCell :: IsDBTable m a => Bool -> Maybe (CryptoUUIDUser -> Route UniWorX) -> LmsUser -> DBCell m a
lmsStatusCell extendedInfo Nothing lu = wgtCell $ lmsUserStatusWidget extendedInfo lu
lmsStatusCell extendedInfo (Just toLink) lu = cell $ do
uuid <- liftHandler $ encrypt $ lu ^. _lmsUserUser
modal (lmsUserStatusWidget True lu) (Left $ SomeRoute $ toLink uuid)
modal (lmsUserStatusWidget extendedInfo lu) (Left $ SomeRoute $ toLink uuid)
qualificationBlockedCellNoReason :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a
qualificationBlockedCellNoReason Nothing = mempty

8
src/Jobs/Handler/LMS.hs
View File

@ -231,19 +231,19 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
-- three separate DB operations per result is not so nice. All within one transaction though.
let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted
saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay)
&& qualificationUserLastRefresh <= utctDay lmsUserStarted
-- && qualificationUserLastRefresh <= utctDay lmsUserStarted NOTE: not always true due to manual intervention; also renewValidQualificationUsers prevents double renewals anyway
newStatus = Just $ LmsSuccess lmsResultSuccess
-- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
note <- if saneDate && replaceLmsStatus lmsUserStatus newStatus
then do
_ok <- renewValidQualificationUsers qid [qualificationUserUser] -- ignores possible blocks
-- when (ok==1) $ update luid -- we end lms regardless of wether a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings
-- WORKAROUND LMS-Bug [supposedly fixed now, but isnt]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
-- _ok <- qualificationUserUnblockByReason qid [qualificationUserUser] (qualificationBlockedReasonText QualificationBlockFailedELearning) -- affects audit log
when (Just (qualificationBlockedReasonText QualificationBlockFailedELearning) == qualificationUserBlockedDue ^? _Just . _qualificationBlockedReason) $
update quid [ QualificationUserBlockedDue =. Nothing ]
_ok <- renewValidQualificationUsers qid [qualificationUserUser] -- ignores possible blocks
-- when (ok==1) $ update luid -- we end lms regardless of whether or not a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings
update luid
[ LmsUserStatus =. newStatus
, LmsUserReceived =. Just lmsResultTimestamp

2
src/Model/Types/Lms.hs
View File

@ -22,7 +22,7 @@ import Utils.Lens.TH
newtype LmsIdent = LmsIdent { getLmsIdent :: Text }
deriving (Eq, Ord, Read, Show, Generic)
deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField)
deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Hashable)
instance E.SqlString LmsIdent
makeLenses_ ''LmsIdent

1
src/Utils.hs
View File

@ -870,6 +870,7 @@ deepAlt altFst _ = altFst
maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m
maybeEmpty = flip foldMap
-- | also referred to as whenJust
whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (Just x) f = f x
whenIsJust Nothing _ = return ()

10
src/Utils/Form.hs
View File

@ -108,6 +108,13 @@ noField = Field{..}
fieldView _ _ _ _ _ = mempty
fieldEnctype = UrlEncoded
-- | Field to inject comments into forms, also see aformMessage
commentField :: (Monad m, RenderMessage (HandlerSite m) a) => a -> Field m ()
commentField msg = Field {..}
where
fieldParse _ _ = return $ Right $ Just ()
fieldView _ _ _ _ _ = msg2widget msg
fieldEnctype = UrlEncoded
--------------------
-- Field Settings --
@ -1667,8 +1674,7 @@ mpreq :: (RenderMessage site (ValueRequired site), HandlerSite m ~ site, MonadHa
-- ^ Pseudo required
--
-- `FieldView` has `fvRequired` set to `True` and @FormSuccess Nothing@ is cast to `FormFailure`.
-- Otherwise acts exactly like `mopt` without a default value and like `mreq` with a given default value
mpreq f fs mx@(Just _) = mreq f fs mx -- This shortcut hides the invalid no-answer option if a default is provided
-- Otherwise acts exactly like `mopt`. Note that a shortcut to mreq for isJust mx does create problems mit checkBoxField
mpreq f fs@FieldSettings{..} mx = do
mr <- getMessageRender
(res, fv') <- mpreq' f fs $ Just <$> mx

4
templates/letter/fraport_renewal.md
View File

@ -72,6 +72,7 @@ $if(supervisor)$
$else$
Dazu bitte die Anmeldedaten aus dem geschützen Sichtfenster weiter unten verwenden.
$endif$
Die Durchführung des Lernprogramms und des Abschlusstests dauert etwa 2 bis 2,5 h.
Fahrberechtigungsinhaber
@ -112,7 +113,8 @@ $if(supervisor)$
below confidentially to the examinee.
$else$
Please use the login data from the protected area below.
$endif$
$endif$
Reserve 2--2.5h for the entire e-learning, including the exam.
Examinee

5
templates/lms-user.hamlet
View File

@ -36,7 +36,10 @@ $else
<dt .deflist__dt>_{MsgTableLmsStatus}
<dd .deflist__dd>^{lmsUserStatusWidget True lmsUsr}
<dt .deflist__dt>_{MsgTableLmsIdent}
<dd .deflist__dd .email>#{getLmsIdent (lmsUserIdent lmsUsr)}
<dd .deflist__dd>
<a href=@{LmsIdentR (qualificationSchool quali) (qualificationShorthand quali) (lmsUserIdent lmsUsr)}>
<span .email>
#{getLmsIdent (lmsUserIdent lmsUsr)}
<dt .deflist__dt>_{MsgTableLmsPin}
<dd .deflist__dd >
<span .email>

1
test/Model/TypesSpec.hs
View File

@ -406,6 +406,7 @@ instance Arbitrary SheetAuthorshipStatementMode where
instance Arbitrary LmsStatus where
arbitrary = genericArbitrary
deriving newtype instance Arbitrary LmsIdent
spec :: Spec
spec = do