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

Merge branch 'fradrive/localmaster' into fradrive/course-qualifications

Browse Source
This commit is contained in:
Steffen Jost 2023-03-16 13:58:57 +00:00
commit d2020866a8
34 changed files with 372 additions and 121 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
CHANGELOG.md
View File

@ -2,6 +2,13 @@
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.0.27](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.0.26...v27.0.27) (2023-03-06)
### Bug Fixes
* **lms:** transmit renewed pins to lms ([be3fb39](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/be3fb39171c1eb5d015ae006286bed747055a7a6))
## [27.0.26](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.0.25...v27.0.26) (2023-03-01)

6
config/settings.yml
View File

@ -24,9 +24,9 @@ mail-from:
email: "_env:MAILFROM_EMAIL:uniworx@localhost"
mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost"
mail-use-replyto-instead-sender: "_env:MAIL_USES_REPLYTO:true"
#mail-reroute-to:
# name: "_env:MAIL_REROUTE_TO_NAME:Steffen Jost"
# email: "_env:MAIL_REROUTE_TO_EMAL:jost@tcs.ifi.lmu.de"
mail-reroute-to:
name: "_env:MAIL_REROUTE_TO_NAME:"
email: "_env:MAIL_REROUTE_TO_EMAIL:"
#mail-verp:
# separator: "_env:VERP_SEPARATOR:+"
# prefix: "_env:VERP_PREFIX:bounce"

5
messages/uniworx/categories/avs/de-de-formal.msg
View File

@ -22,10 +22,11 @@ AvsImportAmbiguous n@Int: Import für #{show n} uneindeutige AVS IDs fehlgeschla
AvsImportUnknowns n@Int: Import für #{show n} unbekannte AVS IDs fehlgeschlagen
AvsSetLicences alic@AvsLicence n@Int m@Int: _{alic} im AVS gesetzt: #{show n}/#{show m}
SetFraDriveLicences q@String n@Int: #{q} in FRADrive gewährt für #{show n} Benutzer
RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} in FRADrive zum Vortag beendet für #{show n} Fahrer
RevokeFraDriveLicencesError alic@AvsLicence: Entzug der _{alic} Lizenzen komplett fehlgeschlagen
RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} in FRADrive entzogen für #{show n} Fahrer
RevokeUnknownLicencesOk: AVS Fahrberechtigungen unbekannter Fahrer wurden gesperrt
RevokeUnknownLicencesFail: Nicht alle AVS Fahrberechtigungen unbekannter Fahrer konnten entzogen werden, siehe Log für Details
AvsCommunicationError: AVS Schnittstelle lieferte einen unerwarteten Fehler.
LicenceTableChangeAvs: Im AVS ändern
LicenceTableGrantFDrive: In FRADrive erteilen
LicenceTableRevokeFDrive: In FRADrive zum Vortag entziehen
LicenceTableRevokeFDrive: In FRADrive entziehen

5
messages/uniworx/categories/avs/en-eu.msg
View File

@ -22,10 +22,11 @@ AvsImportAmbiguous n@Int: Import failed for #{show n} ambiguous AVS Ids
AvsImportUnknowns n@Int: Import failed for #{show n} unknown AVS Ids
AvsSetLicences alic n m: _{alic} set in AVS: #{show n}/#{show m}
SetFraDriveLicences q@String n@Int: #{q} granted in FRADrive for #{show n} users
RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} now ended yesterday in FRADrive for #{show n} drivers
RevokeFraDriveLicencesError alic@AvsLicence: Revoking licences _{alic} failed entirely
RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} revoked in FRADrive for #{show n} drivers
RevokeUnknownLicencesOk: AVS driving licences of unknown drivers revoked
RevokeUnknownLicencesFail: Not all AVS driving licences of unknown drivers could be revoked, see log for details
AvsCommunicationError: AVS interface returned an unexpected error.
LicenceTableChangeAvs: Change in AVS
LicenceTableGrantFDrive: Grant in FRADrive
LicenceTableRevokeFDrive: Revoke yesterday in FRADrive
LicenceTableRevokeFDrive: Revoke in FRADrive

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

@ -20,13 +20,14 @@ TableQualificationSapExportTooltip: Wird die Qualifikation an das SAP übermitte
LmsQualificationValidUntil: Gültig bis
TableQualificationLastRefresh: Zuletzt erneuert
TableQualificationFirstHeld: Erstmalig
TableQualificationBlockedDue: Suspendiert
TableQualificationBlockedDue: Entzogen
TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst?
TableQualificationBlockedTooltipSimple: Wann wurde die Qualifikation aus besonderem Grund wiederrufen?
TableQualificationNoRenewal: Storniert
TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch gültig sein.
TableQualificationNoRenewal: Auslaufend
TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch weiterhin gültig sein.
QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus
QualificationUserNone: Für diese Person sind keine Qualifikationen registriert.
QualificationBlockReason: Entzugsbegründung
LmsUser: Inhaber
TableLmsEmail: E-Mail
TableLmsIdent: LMS Identifikation
@ -70,10 +71,15 @@ MailSubjectQualificationExpired qname@Text: Qualifikation #{qname} ist ab sofort
MailBodyQualificationRenewal qname@Text: Sie müssen die Qualifikation #{qname} demnächst durch einen E-Learning Kurs erneuern, siehe Anhang.
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: Qualifikation ohne Benachrichtigung auslaufen lassen
QualificationActUnexpire: Benachrichtigung bei anstehender Erneuerung senden
QualificationActExpire: Auslaufend markieren - keine Benachrichtigung zur Erneuerung senden
QualificationActUnexpire: Auslaufend aufheben - kostenpflichtige Benachrichtigung bei anstehender Erneuerung senden
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 aufheben, mit sofortiger Wirkung
QualificationActBlock: Entziehen
QualificationActUnblock: Entzug löschen
QualificationStatusBlock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen
QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert
LmsRenewalInstructions: Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF dem von Ihnen in FRADrive hinterlegten PDF-Passwort verschlüsselt. Falls kein PDF-Passwort manuell hinterlegt wurde, ist das PDF-Passwort Ihre 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

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

@ -20,13 +20,14 @@ TableQualificationSapExportTooltip: Is this qualification transmitted to SAP? On
LmsQualificationValidUntil: Valid until
TableQualificationLastRefresh: Last renewed
TableQualificationFirstHeld: First held
TableQualificationBlockedDue: Suspended
TableQualificationBlockedDue: Revoked
TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended?
TableQualificationBlockedTooltipSimple: When was this qualification revoked due to extraordinary reasons?
TableQualificationNoRenewal: Canceled
TableQualificationNoRenewal: Discontinued
TableQualificationNoRenewalTooltip: No renewal notifications will be send for this qualification upon expiry. The qualification may still be valid.
QualificationUserNoRenewal: Expires without further notification
QualificationUserNone: No registered qualifications for this person.
QualificationBlockReason: Reason for revoking
LmsUser: Licensee
TableLmsEmail: Email
TableLmsIdent: LMS Identifier
@ -70,10 +71,15 @@ MailSubjectQualificationExpired qname: Qualification #{qname} is no longer valid
MailBodyQualificationRenewal qname: You will soon need to renew qualification #{qname} by completing an e-learning course. For details see attachment.
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: Qualification shall expire silently
QualificationActUnexpire: Notify upon due renewal
QualificationActExpire: Discontinue - qualification expires silently
QualificationActUnexpire: Continue - send a possibly fee-paying notification upon due renewal
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, effective immediately
QualificationActBlock: Revoke
QualificationActUnblock: Clear revocation
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 your chosen FRADrive PDF-Password. If you have not yet chosen a PDF-Password yet, then the password is your Fraport id card number, inkluding 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

1
messages/uniworx/utils/utils/de-de-formal.msg
View File

@ -77,6 +77,7 @@ MultiUserFieldExplanationAnyUser: Dieses Eingabefeld sucht in den Adressen aller
MultiUserFieldInvitationExplanation: An Adressen, die so keinem Uni2work-Benutzer/keiner Uni2work-Benutzerin zugeordnet werden können, wird eine Einladung per E-Mail versandt.
MultiUserFieldInvitationExplanationAlways: Es wird an alle Adressen, die Sie hier angeben, eine Einladung per E-Mail versandt.
AmbiguousEmail: E-Mail-Adresse nicht eindeutig
InvalidEmailAddress: E-Mail-Adresse ist ungültig
UtilExamResultGrade: Note
UtilExamResultPass: Bestanden/Nicht Bestanden
UtilExamResultNoShow: Nicht erschienen

1
messages/uniworx/utils/utils/en-eu.msg
View File

@ -77,6 +77,7 @@ MultiUserFieldExplanationAnyUser: This input searches through the addresses of a
MultiUserFieldInvitationExplanation: For addresses, which are not found in this way, an invitation will be sent via email.
MultiUserFieldInvitationExplanationAlways: An invitation will be sent via email to all addresses you enter here.
AmbiguousEmail: Email address is ambiguous
InvalidEmailAddress: Email address is invalid
UtilExamResultGrade: Grade
UtilExamResultPass: Passed/Failed
UtilExamResultNoShow: Not present

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

@ -1,3 +1,3 @@
{
"version": "27.0.26"
"version": "27.0.27"
}

2
nix/docker/version.json
View File

@ -1,3 +1,3 @@
{
"version": "27.0.26"
"version": "27.0.27"
}

2
package-lock.json generated
View File

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

2
package.json
View File

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

2
package.yaml
View File

@ -1,5 +1,5 @@
name: uniworx
version: 27.0.26
version: 27.0.27
dependencies:
- base
- yesod

22
src/Audit/Types.hs
View File

@ -197,20 +197,24 @@ data Transaction
, transactionNote :: Maybe Text
, transactionReceived :: UTCTime -- when was the csv file received?
}
| TransactionQualificationUserEdit
{ transactionQualificationUser :: QualificationUserId
, transactionQualification :: QualificationId
, transactionUser :: UserId -- qualification holder that is updated
| TransactionQualificationUserEdit -- Note that a renewal always entails unblocking as well!
{ transactionUser :: UserId -- qualification holder that is updated
, transactionQualificationUser :: QualificationUserId
, transactionQualification :: QualificationId
, transactionQualificationValidUntil :: Day
, transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration)
}
| TransactionQualificationUserDelete
{ transactionQualificationUser :: QualificationUserId
, transactionQualification :: QualificationId
, transactionUser :: UserId
{ transactionUser :: UserId
, transactionQualificationUser :: QualificationUserId
, transactionQualification :: QualificationId
}
| TransactionQualificationUserBlocking
{ transactionUser :: UserId -- qualification holder that is updated
-- , transactionQualificationUser :: QualificationUserId -- not neccessary due to UniqueQualificationUser
, transactionQualification :: QualificationId
, transactionQualificationBlock :: Maybe QualificationBlocked -- Nothing indicates unblocking
}
deriving (Eq, Ord, Read, Show, Generic)
deriveJSON defaultOptions

22
src/Handler/Admin.hs
View File

@ -23,6 +23,7 @@ import qualified Database.Esqueleto.Utils as E
import Handler.Utils.DateTime
import Handler.Utils.Avs
import Handler.Utils.Widgets
import Handler.Utils.Users
import Handler.Admin.Test as Handler.Admin
import Handler.Admin.ErrorMessage as Handler.Admin
@ -83,7 +84,7 @@ getAdminProblemsR = do
getProblemUnreachableR :: Handler Html
getProblemUnreachableR = do
unreachables <- runDB $ E.select retrieveUnreachableUsers
unreachables <- runDB retrieveUnreachableUsers'
siteLayoutMsg MsgProblemsUnreachableHeading $ do
setTitleI MsgProblemsUnreachableHeading
[whamlet|
@ -92,7 +93,7 @@ getProblemUnreachableR = do
<ul>
$forall usr <- unreachables
<li>
^{linkUserWidget ForProfileR usr}
^{linkUserWidget ForProfileR usr} (#{usr ^. _userDisplayEmail} / #{usr ^. _userEmail})
|]
getProblemFbutNoR :: Handler Html
@ -147,9 +148,24 @@ retrieveUnreachableUsers = do
user <- E.from $ E.table @User
E.where_ $ E.isNothing (user E.^. UserPostAddress)
E.&&. E.isNothing (user E.^. UserCompanyDepartment)
E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
E.&&. E.not_ ((user E.^. UserDisplayEmail) `E.like` E.val "%@%.%")
E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
return user
retrieveUnreachableUsers' :: DB [Entity User]
retrieveUnreachableUsers' = do
obviousUnreachable <- E.select retrieveUnreachableUsers
emailUsers <- E.select $ do
user <- E.from $ E.table @User
E.where_ $ E.isNothing (user E.^. UserPostAddress)
E.&&. E.isNothing (user E.^. UserCompanyDepartment)
E.&&. ( ((user E.^. UserDisplayEmail) `E.like` E.val "%@%.%")
E.||. ((user E.^. UserEmail) `E.like` E.val "%@%.%"))
pure user
let hasInvalidEmail = isNothing . getEmailAddress . entityVal
invaldEmail = filter hasInvalidEmail emailUsers
return $ obviousUnreachable ++ invaldEmail
allDriversHaveAvsId :: Day -> DB Bool
-- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId
allDriversHaveAvsId = E.selectNotExists . retrieveDriversWithoutAvsId

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

@ -309,11 +309,15 @@ nullaryPathPiece ''LicenceTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''LicenceTableAction id
data LicenceTableActionData = LicenceTableChangeAvsData
| LicenceTableRevokeFDriveData --TODO: add { licenceTableChangeFDriveQId :: QualificationId to avoid lookup later
| LicenceTableGrantFDriveData { licenceTableChangeFDriveQId :: QualificationId
, licenceTableChangeFDriveEnd :: Day
, licenceTableChangeFDriveRenew :: Maybe Bool
}
| LicenceTableRevokeFDriveData
{ licenceTableChangeFDriveQId :: QualificationId
, licenceTableChangeFDriveReason :: Text
}
| LicenceTableGrantFDriveData
{ licenceTableChangeFDriveQId :: QualificationId
, licenceTableChangeFDriveEnd :: Day
, licenceTableChangeFDriveRenew :: Maybe Bool
}
deriving (Eq, Ord, Read, Show, Generic)
@ -393,19 +397,26 @@ getProblemAvsSynchR = do
addMessageI mkind $ MsgAvsSetLicences aLic oks no_req
redirect ProblemAvsSynchR -- reload to update all tables
procRes alic (LicenceTableRevokeFDriveData, apids) = do
nups <- runDB $ do
procRes alic (LicenceTableRevokeFDriveData{..}, apids) = do
oks <- runDB $ do
qId <- getKeyBy404 $ UniqueQualificationAvsLicence $ Just alic
selectedUsers <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
forM_ selectedUsers $ upsertQualificationUser qId nowaday (pred nowaday) Nothing
return $ length selectedUsers
addMessageI Success $ MsgRevokeFraDriveLicences alic nups
if qId /= licenceTableChangeFDriveQId
then return (-1)
else do
uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
qualificationUserBlocking licenceTableChangeFDriveQId uids $
Just $ QualificationBlocked
{ qualificationBlockedDay = nowaday
, qualificationBlockedReason = licenceTableChangeFDriveReason
}
if | oks < 0 -> addMessageI Error $ MsgRevokeFraDriveLicencesError alic
| oks == length apids -> addMessageI Success $ MsgRevokeFraDriveLicences alic oks
| otherwise -> addMessageI Warning $ MsgRevokeFraDriveLicences alic oks
redirect ProblemAvsSynchR -- must be outside runDB
procRes _alic (LicenceTableGrantFDriveData{..}, apids ) = do
(n, Qualification{qualificationShorthand}) <- runDB $ do
uas <- selectList [UserAvsPersonId <-. Set.toList apids] []
let uids = view _userAvsUser <$> uas
uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
-- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG
forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew
(length uids,) <$> get404 licenceTableChangeFDriveQId
@ -547,7 +558,9 @@ mkLicenceTable dbtIdent aLic apids = do
acts = mconcat
[ singletonMap LicenceTableChangeAvs $ pure LicenceTableChangeAvsData
, if aLic == AvsNoLicence
then singletonMap LicenceTableRevokeFDrive $ pure LicenceTableRevokeFDriveData
then singletonMap LicenceTableRevokeFDrive $ LicenceTableRevokeFDriveData
<$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
<*> apreq textField (fslI MsgQualificationBlockReason) Nothing
else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData
<$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
<*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?!
@ -570,7 +583,7 @@ mkLicenceTable dbtIdent aLic apids = do
dbtCsvDecode = Nothing
dbtExtraReps = []
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
validator = def -- & defaultSorting [SortDescBy "column-label"]
validator = def & defaultSorting [SortAscBy "user-name"]
postprocess :: FormResult (First LicenceTableActionData, DBFormResult AvsPersonId Bool LicenceTableData) -- == DBFormResult (Map AvsPersonId (LicenceTableData, Bool -> Bool))
-> FormResult ( LicenceTableActionData, Set AvsPersonId)
postprocess inp = do

24
src/Handler/LMS.hs
View File

@ -395,7 +395,12 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
, 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 ( "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
E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyName)
)
]
dbtFilter = mconcat
[ single $ fltrUserNameEmail queryUser
@ -514,6 +519,16 @@ postLmsR sid qsh = do
[ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is"
, colUserNameModalHdr MsgLmsUser AdminUserR
, colUserEmail
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view $ resultUser . _entityKey -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
let companies = intersperse (text2markup ", ") $
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
icnSuper = text2markup " " <> icon IconSupervisor
pure $ toWgt $ mconcat companies
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
@ -608,8 +623,10 @@ postLmsR sid qsh = do
-- intended to be viewed primarily in a modal, vie lmsStatusPlusCell'
getLmsUserR :: CryptoUUIDUser -> Handler Html
getLmsUserR uuid = do
getLmsUserR uuid = do
uid <- decrypt uuid
now <- liftIO getCurrentTime
let nowaday = utctDay now
(user@User{userDisplayName}, quals) <- runDB $ do
usr <- get404 uid
qs <- Ex.select $ do
@ -625,7 +642,8 @@ getLmsUserR uuid = do
)
Ex.where_ $ E.isJust (qualUsr E.?. QualificationUserUser)
E.||. E.isJust ( lmsUsr E.?. LmsUserUser)
pure (qual, qualUsr, lmsUsr)
Ex.orderBy [Ex.asc $ qual E.^. QualificationShorthand]
pure (qual, qualUsr, lmsUsr, validQualification' nowaday qualUsr)
return (usr,qs)
let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|]

2
src/Handler/PrintCenter.hs
View File

@ -279,7 +279,7 @@ mkPJTable = do
(First (Just act), jobMap) <- inp
let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
return (act, jobSet)
psValidator = def & defaultSorting [SortAscBy "created"]
psValidator = def & defaultSorting [SortDescBy "created"]
-- & defaultFilter (singletonMap "acknowledged" [toPathPiece False]) -- TODO: sorting with Nothing restores this filter
over _1 postprocess <$> dbTable psValidator DBTable{..}

7
src/Handler/Profile.hs
View File

@ -357,6 +357,10 @@ validateSettings User{..} = do
userDisplayName == userDisplayName' || -- unchanged or valid (invalid displayNames delivered by LDAP are preserved)
validDisplayName userTitle userFirstName userSurname userDisplayName'
userDisplayEmail' <- use _stgDisplayEmail
guardValidation MsgInvalidEmailAddress $
not (validEmail' userDisplayEmail')
userPostAddress' <- use _stgPostAddress
let postalNotSet = isNothing userPostAddress'
postalIsValid = validPostAddress userPostAddress'
@ -445,7 +449,7 @@ serveProfileR (uid, user@User{..}) = do
now <- liftIO getCurrentTime
runDBJobs $ do
update uid $
[ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ] ++ -- SJ asks: what does this line achieve?
[ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ] ++ -- Note that DisplayEmail changes must be confirmed, see 472
[ UserPostLastUpdate =. Just now | userPostAddress /= stgPostAddress ] ++
[ UserDisplayName =. stgDisplayName
, UserMaxFavourites =. stgMaxFavourites
@ -617,6 +621,7 @@ makeProfileData (Entity uid User{..}) = do
mCRoute <- getCurrentRoute
showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID)
tooltipAvsPersNo <- messageI Info MsgAvsPersonNoNotId
tooltipInvalidEmail <- messageI Error MsgInvalidEmailAddress
let profileRemarks = $(i18nWidgetFile "profile-remarks")
return $(widgetFile "profileData")

92
src/Handler/Qualification.hs
View File

@ -73,7 +73,7 @@ getSupervisees = do
mkQualificationAllTable :: DB (Any, Widget)
mkQualificationAllTable = do
svs <- getSupervisees
now <- liftIO getCurrentTime
now <- liftIO getCurrentTime
let
resultDBTable = DBTable{..}
where
@ -236,7 +236,12 @@ instance HasEntity QualificationTableData User where
instance HasUser QualificationTableData where
hasUser = resultUser . _entityVal
data QualificationTableAction = QualificationActExpire | QualificationActUnexpire
data QualificationTableAction
= QualificationActExpire
| QualificationActUnexpire
| QualificationActBlockSupervisor
| QualificationActBlock
| QualificationActUnblock
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe QualificationTableAction
@ -245,12 +250,24 @@ nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''QualificationTableAction id
-- Not yet needed, since there is no additional data for now:
data QualificationTableActionData = QualificationActExpireData | QualificationActUnexpireData
data QualificationTableActionData
= QualificationActExpireData
| QualificationActUnexpireData
| QualificationActBlockSupervisorData
| QualificationActBlockData { qualTableActBlockReason :: Text}
| QualificationActUnblockData
deriving (Eq, Ord, Read, Show, Generic)
isExpiryAct :: QualificationTableActionData -> Bool -- const true, but this may change in the future
isExpiryAct :: QualificationTableActionData -> Bool
isExpiryAct QualificationActExpireData = True
isExpiryAct QualificationActUnexpireData = True
isExpiryAct _ = False
isBlockAct :: QualificationTableActionData -> Bool
isBlockAct QualificationActBlockSupervisorData = True
isBlockAct QualificationActBlockData{} = True
isBlockAct QualificationActUnblockData = True
isBlockAct _ = False
qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr
-> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
@ -300,6 +317,13 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
-- , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
, single ("lms-status-plus",SortColumn $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}"
, queryLmsUser row E.?. LmsUserStarted])
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
, 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
E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyName)
)
]
dbtFilter = mconcat
[ single $ fltrUserNameEmail queryUser
@ -323,7 +347,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
, Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
| otherwise -> E.true
)
)
]
dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
@ -400,19 +424,36 @@ postQualificationR sid qsh = do
((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh
let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
acts = mconcat
acts = mconcat $
[ singletonMap QualificationActExpire $ pure QualificationActExpireData
, singletonMap QualificationActUnexpire $ pure QualificationActUnexpireData
]
linkLmsUser = toMaybe isAdmin LmsUserR
] ++ bool
[ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- nonAdmin Supervisor
[ singletonMap QualificationActUnblock $ pure QualificationActUnblockData
, singletonMap QualificationActBlock $ QualificationActBlockData
<$> apreq textField (fslI MsgQualificationBlockReason) Nothing
] isAdmin
linkLmsUser = toMaybe isAdmin LmsUserR
linkUserName = bool ForProfileR ForProfileDataR isAdmin
blockedDueCell = bool qualificationBlockedCellNoReason qualificationBlockedCell isAdmin
colChoices = mconcat
[ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
, colUserNameModalHdr MsgLmsUser ForProfileR
, colUserNameModalHdr MsgLmsUser linkUserName
, colUserEmail
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view $ resultUser . _entityKey -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
let companies = intersperse (text2markup ", ") $
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
icnSuper = text2markup " " <> icon IconSupervisor
pure $ toWgt $ mconcat companies
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
, sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltipSimple
) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCellNoReason b
) $ \( 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)
@ -425,18 +466,39 @@ postQualificationR sid qsh = do
tbl <- mkQualificationTable 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 for now
(action, selectedUsers) | isExpiryAct action -> do
formResult lmsRes $ \case
(action, selectedUsers) | isExpiryAct action -> do
let isUnexpire = action == QualificationActUnexpireData
upd <- runDB $ updateWhereCount
upd <- runDB $ updateWhereCount
[QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers]
[QualificationUserScheduleRenewal =. isUnexpire]
let msgKind = if upd > 0 then Success else Warning
msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
addMessageI msgKind msgVal
redirect currentRoute
_ -> return ()
(action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do
now <- liftIO getCurrentTime
let nowaday = utctDay now
qubr = case action of
QualificationActUnblockData -> Nothing
QualificationActBlockSupervisorData -> Just $ mkQualificationBlocked QualificationBlockReturnedByCompany nowaday
QualificationActBlockData{..} -> Just $ QualificationBlocked
{ qualificationBlockedDay = nowaday
, qualificationBlockedReason = qualTableActBlockReason
}
_ -> error "Handle.Qualification.isBlockAct returned non-block action"
oks <- runDB $ qualificationUserBlocking qid (Set.toList selectedUsers) qubr
let nrq = length selectedUsers
warnLevel = if
| oks < 0 -> Error
| oks == nrq -> Success
| otherwise -> Warning
fbmsg = if
| isNothing qubr -> MsgQualificationStatusUnblock
| otherwise -> MsgQualificationStatusBlock
addMessageI warnLevel $ fbmsg qsh oks nrq
redirect currentRoute
_ -> addMessageI Error MsgUnauthorized
let heading = citext2widget $ qualificationName quali
siteLayout heading $ do

47
src/Handler/Utils/Mail.hs
View File

@ -16,7 +16,7 @@ import Handler.Utils.Pandoc
import Handler.Utils.Files
import Handler.Utils.Widgets (nameHtml') -- TODO: how to use name widget here?
import Handler.Utils.Users (getReceivers)
import Handler.Utils.Profile (pickValidEmail)
import Handler.Utils.Profile
import qualified Data.CaseInsensitive as CI
@ -42,13 +42,13 @@ addRecipientsDB uFilter = runConduit $ transPipe (liftHandler . runDB) (selectSo
userAddressFrom :: User -> Address
-- ^ Format an e-mail address suitable for usage in a @From@-header
--
-- Uses `userDisplayEmail`
-- Uses `userDisplayEmail` only
userAddressFrom User{userDisplayEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userDisplayEmail
userAddress :: User -> Address
-- ^ Format an e-mail address suitable for usage as a recipient
--
-- Like userAddressFrom and no longer uses `userEmail`, since unlike Uni2work, userEmail from LDAP is untrustworthy.
-- Like userAddressFrom, but prefers `userDisplayEmail` (if valid) and otherwise uses `userEmail`. Unlike Uni2work, userEmail from LDAP is untrustworthy.
userAddress User{userEmail, userDisplayEmail, userDisplayName}
= Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail
@ -98,15 +98,21 @@ userMailT uid mAct = do
$else
_{MsgMailSupervisorNoCopy}
|]
mailT ctx $ do
_mailTo .= pure (userAddress supervisor)
mAct
if uid==svr
then when (2 <= length receivers) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors
else do
mapSubject ("[SUPERVISOR] " <>)
addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email
mailtoAddr = userAddress supervisor
if validEmail $ addressEmail mailtoAddr
then
mailT ctx $ do
-- TODO: ensure that the Email is VALID HERE!
_mailTo .= pure mailtoAddr
mAct
if uid==svr
then when (length receivers > 1) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors
else do
mapSubject ("[SUPERVISOR] " <>)
addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email
else -- do
-- failedSubject <- lookupMailHeader "Subject"
$logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr -- <> " with subject " <> tshow failedSubject
-- | like userMailT, but always sends a single mail to the given UserId, ignoring supervisors
userMailTdirect :: ( MonadHandler m
@ -131,9 +137,22 @@ userMailTdirect uid mAct = do
SelFormatTime -> userTimeFormat
, mcCsvOptions = userCsvOptions
}
mailtoAddr = userAddress user
mailT ctx $ do
_mailTo .= pure (userAddress user)
mAct
failedSubject <- lookupMailHeader "Subject"
unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr <> " with subject " <> tshow failedSubject)
_mailTo .= pure mailtoAddr
mAct
{- Problematic due to return type a
if validEmail $ addressEmail mailtoAddr
then mailT ctx $ do
_mailTo .= pure mailtoAddr
mAct
else
-- failedSubject <- lookupMailHeader "Subject"
$logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAdd -- <> " with subject " <> tshow failedSubject
-}
addFileDB :: ( MonadMail m

26
src/Handler/Utils/Profile.hs
View File

@ -9,7 +9,8 @@ module Handler.Utils.Profile
, validDisplayName
, fixDisplayName
, validPostAddress
, validEmail, validEmail', pickValidEmail
, validEmail, validEmail'
, pickValidEmail, pickValidEmail'
) where
import Import.NoFoundation
@ -79,14 +80,27 @@ validPostAddress (Just StoredMarkup {markupInput = addr})
= True
validPostAddress _ = False
-- also see `Handler.Utils.Users.getEmailAddress` for Tests accepting User Type
validEmail :: Email -> Bool -- Email = Text
validEmail = Email.isValid . encodeUtf8
validEmail email = validRFC5322 && not invalidFraport
where
validRFC5322 = Email.isValid $ encodeUtf8 email
invalidFraport = case Text.stripSuffix "@fraport.de" email of
Just fralogin -> all isDigit $ drop 1 fralogin
Nothing -> False
validEmail' :: UserEmail -> Bool -- UserEmail = CI Text
validEmail' = Email.isValid . encodeUtf8 . CI.original
validEmail' = validEmail . CI.original
-- | returns first argument, if it is a valid email address; returns second argument untested otherwise; convenience function
pickValidEmail :: UserEmail -> UserEmail -> UserEmail
pickValidEmail x y
| validEmail' x = x
| otherwise = y
pickValidEmail x y
| validEmail' x = x
| otherwise = y
-- | returns first valid email address or none if none are valid
pickValidEmail' :: UserEmail -> UserEmail -> Maybe UserEmail
pickValidEmail' x y
| validEmail' x = Just x
| validEmail' y = Just y
| otherwise = Nothing

39
src/Handler/Utils/Qualification.hs
View File

@ -10,6 +10,7 @@ module Handler.Utils.Qualification
import Import
-- import Data.Time.Calendar (CalendarDiffDays(..))
import Database.Persist.Sql (updateWhereCount)
import qualified Database.Esqueleto.Experimental as E -- might need TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils as E
@ -100,4 +101,40 @@ renewValidQualificationUsers qid uids =
, transactionQualificationScheduleRenewal = Nothing
}
return $ length quEnts
_ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.
_ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.
-- qualificationUserBlocking :: QualificationId -> [UserId] -> Maybe QualificationBlocked -> DB Int64
qualificationUserBlocking ::
( AuthId (HandlerSite m) ~ Key User
, IsPersistBackend (YesodPersistBackend (HandlerSite m))
, BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
, BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
, PersistQueryWrite (YesodPersistBackend (HandlerSite m))
, PersistUniqueWrite (YesodPersistBackend (HandlerSite m))
, HasInstanceID (HandlerSite m) InstanceId
, YesodAuthPersist (HandlerSite m)
, HasAppSettings (HandlerSite m)
, MonadHandler m
, MonadCatch m
, Num n
) => QualificationId -> [UserId] -> Maybe QualificationBlocked -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
qualificationUserBlocking qid uids qb = do
oks <- updateWhereCount -- prevents storage of transactionQualificatioUser
( [ QualificationUserBlockedDue !=. Nothing | isNothing qb -- only unblock blocked qualification; allow overwrite for existing blocks
] ++
[ QualificationUserQualification ==. qid
, QualificationUserUser <-. uids
]
)
[ QualificationUserBlockedDue =. qb
]
forM_ uids $ \uid -> do
audit TransactionQualificationUserBlocking
{ -- transactionQualificationUser = quid
transactionQualification = qid
, transactionUser = uid
, transactionQualificationBlock = qb
}
return $ fromIntegral oks

14
src/Handler/Utils/Users.hs
View File

@ -14,6 +14,7 @@ module Handler.Utils.Users
, UserAssimilateException(..), UserAssimilateExceptionReason(..)
, assimilateUser
, userPrefersEmail, userPrefersLetter
, getEmailAddress
, getPostalAddress, getPostalPreferenceAndAddress
, abbrvName
, getReceivers
@ -71,13 +72,16 @@ userPrefersEmail = not . userPrefersLetter
-- | result (True, Nothing) indicates that neither userEmail nor userPostAddress is known
getPostalPreferenceAndAddress :: User -> (Bool, Maybe [Text])
getPostalPreferenceAndAddress usr@User{..} =
getPostalPreferenceAndAddress usr@User{userPrefersPostal} =
((userPrefersPostal && postPossible) || not emailPossible, pa)
-- (((userPrefersPostal || isNothing userPinPassword) && postPossible) || not emailPossible, pa) -- ignore email/post preference if no pinPassword is set
where
emailPossible = validEmail' userEmail
postPossible = isJust pa
where
pa = getPostalAddress usr
postPossible = isJust pa
emailPossible = isJust $ getEmailAddress usr
getEmailAddress :: User -> Maybe UserEmail
getEmailAddress User{userDisplayEmail, userEmail} = pickValidEmail' userDisplayEmail userEmail
getPostalAddress :: User -> Maybe [Text]
getPostalAddress User{..}
@ -89,7 +93,7 @@ getPostalAddress User{..}
| otherwise
= Nothing
-- | DEPRECATED, use Handler.Utils.Avs.updateReceivers instead
-- | Consider using Handler.Utils.Avs.updateReceivers instead
-- Return Entity User and all Supervisors with rerouteNotifications as well as
-- a boolean indicating if the user is own supervisor with rerouteNotifications
getReceivers :: UserId -> DB (Entity User, [Entity User], Bool)

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

@ -28,13 +28,11 @@ import qualified Data.Set as Set
import qualified Data.Time.Zones as TZ
import Handler.Utils.DateTime
import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries)
import Handler.Utils.Qualification
import qualified Data.CaseInsensitive as CI
blockedByElearning :: Text
blockedByElearning = "E-Learning durchgefallen"
dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX
dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue
@ -219,7 +217,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
, QualificationUserLastRefresh =. lmsResultSuccess
]
-- WORKAROUND LMS-Bug: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
when (Just blockedByElearning == qUsr ^? _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) $
when (Just (qualificationBlockedReasonText QualificationBlockFailedELearning) == qUsr ^? _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) $
update quid [ QualificationUserBlockedDue =. Nothing ]
update luid [ LmsUserStatus =. Just newStatus
, LmsUserReceived =. Just lmsResultTimestamp
@ -295,9 +293,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
, transactionReceived = lReceived
}
update luid [LmsUserStatus =. (oldStatus <> Just newStatus)]
updateBy (UniqueQualificationUser qid (lmsUserUser luser))
[QualificationUserBlockedDue =. Just (QualificationBlocked { qualificationBlockedDay = blockedDay
, qualificationBlockedReason = blockedByElearning } )]
void $ qualificationUserBlocking qid [lmsUserUser luser] $ Just $ mkQualificationBlocked QualificationBlockFailedELearning blockedDay
queueDBJob JobSendNotification
{ jRecipient = lmsUserUser luser
, jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = blockedDay }

6
src/Jobs/Handler/QueueNotification.hs
View File

@ -15,7 +15,7 @@ import Jobs.Queue
import qualified Data.Set as Set
import Handler.Utils.Profile (validEmail')
import Handler.Utils.Profile (pickValidEmail')
import Handler.Utils.ExamOffice.Exam
import Handler.Utils.ExamOffice.ExternalExam
@ -26,8 +26,8 @@ dispatchJobQueueNotification :: Notification -> JobHandler UniWorX
dispatchJobQueueNotification jNotification = JobHandlerAtomic $
runConduit $ yield jNotification
.| transPipe (hoist lift) determineNotificationCandidates
.| C.filterM (\(notification', override, Entity _ User{userNotificationSettings,userEmail}) ->
and2M (return $ validEmail' userEmail) $
.| C.filterM (\(notification', override, Entity _ User{userNotificationSettings,userDisplayEmail,userEmail}) ->
and2M (return $ isJust $ pickValidEmail' userDisplayEmail userEmail) $
or2M (return override) $ notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification'))
.| C.map (\(notification', _, Entity uid _) -> JobSendNotification uid notification')
.| sinkDBJobs

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

@ -11,6 +11,8 @@ module Model.Types.Lms
) where
import Import.NoModel
import qualified Data.Map as Map
import Data.Map ((!))
import Database.Persist.Sql
import qualified Database.Esqueleto.Experimental as E
import qualified Data.Csv as Csv
@ -87,6 +89,25 @@ instance Csv.ToField QualificationBlocked where
-- instance ToMessage QualificationBlocked where -- no longer used
-- toMessage QualificationBlocked{..} = qualificationBlockedReason
data QualificationBlockStandardReason
= QualificationBlockFailedELearning
| QualificationBlockReturnedByCompany
deriving (Eq, Ord, Enum, Bounded, Universe, Finite)
instance Show QualificationBlockStandardReason where
show QualificationBlockFailedELearning = "E-Learning durchgefallen"
show QualificationBlockReturnedByCompany = "Zurückgebeben durch Firma"
qualificationBlockedReasonText :: QualificationBlockStandardReason -> Text
qualificationBlockedReasonText =
let dictionary :: Map.Map QualificationBlockStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF]
in (dictionary !) -- cannot fail due to universeF
mkQualificationBlocked :: QualificationBlockStandardReason -> Day -> QualificationBlocked
mkQualificationBlocked reason qualificationBlockedDay = QualificationBlocked{..}
where
qualificationBlockedReason = qualificationBlockedReasonText reason
-- | LMS interface requires Bool to be encoded by 0 or 1 only
newtype LmsBool = LmsBool { lms2bool :: Bool }
deriving (Eq, Ord, Read, Show, Generic)

2
src/Settings.hs
View File

@ -657,7 +657,7 @@ instance FromJSON AppSettings where
appMailVerp <- fromMaybe VerpNone . join <$> (o .:? "mail-verp" <|> pure Nothing)
appMailRetainSent <- o .: "mail-retain-sent"
appMailSupport <- o .: "mail-support"
appMailRerouteTo <- o .:? "mail-reroute-to"
appMailRerouteTo <- join <$> (o .:? "mail-reroute-to" <|> pure Nothing)
appJobWorkers <- o .: "job-workers"
appJobFlushInterval <- o .:? "job-flush-interval"

2
start.sh
View File

@ -29,6 +29,8 @@ export RIBBON=${RIBBON:-${__HOST:-localhost}}
export APPROOT=${APPROOT:-http://localhost:$((${PORT_OFFSET:-0} + 3000))}
export AVSPASS=${AVSPASS:-nopasswordset}
export PATH=${PATH:/home/jost/projects/fradrive}
export MAIL_REROUTE_TO_NAME='Steffen Jost'
export MAIL_REROUTE_TO_EMAIL=jost@tcs.ifi.lmu.de
unset HOST
move-back() {

4
templates/letter/din5008.latex
View File

@ -148,8 +148,8 @@ $endif$
$endif$
\begin{textblock}{65}(142,21)%hpos,vpos
\textcolor{white!0}{:::$paper$:::$printid$:::}%
\end{textblock}
\textcolor{white!0}{\_\_\_$paper$\_\_\_$printid$\_\_\_}%
\end{textblock}
$body$

4
templates/letter/din5008with_pin.latex
View File

@ -148,11 +148,11 @@ $endif$
$endif$
\begin{textblock}{65}(142,21)%hpos,vpos
\textcolor{white!0}{:::$paper$:::$printid$:::}%
\textcolor{white!0}{\_\_\_$paper$\_\_\_$printid$\_\_\_}%
\end{textblock}
\begin{textblock}{65}(84,232)%hpos,vpos
\textcolor{black!39}{
\begin{labeling}{Password:}
\begin{labeling}{Password:}%Achtung! Die Position des Logins muss sprachunabhängig immer an der gleichen Position sein, sonst kannn die Rückmeldung der Druckerei den Ident nicht mehr identifizieren!
$if(is-de)$
\item[Benutzer:] \texttt{$login$}
\item[Passwort:] \texttt{$pin$}

7
templates/lms-user.hamlet
View File

@ -7,11 +7,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
$if null quals
_{MsgQualificationUserNone}
$else
$forall (Entity _ quali, mbQualUsr, mbLmsUsr) <- quals
$forall (Entity _ quali, mbQualUsr, mbLmsUsr, validity) <- quals
<section>
<div .container>
<h2>
#{qualificationShorthand quali} - #{qualificationName quali} - #{qualificationSchool quali}
#{qualificationShorthand quali} - #{qualificationName quali} (#{qualificationSchool quali}) &nbsp; #{boolSymbol (E.unValue validity)}
<div .container>
<dl .deflist>
$maybe (Entity _ qualUsr) <- mbQualUsr
@ -41,7 +41,8 @@ $else
<dd .deflist__dd >
<span .email>
#{lmsUserPin lmsUsr}
\ ^{formatTimeW SelFormatDateTime (lmsUserDatePin lmsUsr)}
<br>
^{formatTimeW SelFormatDateTime (lmsUserDatePin lmsUsr)}
$if lmsUserResetPin lmsUsr
\ #{icon IconReset}
$maybe ts <- lmsUserReceived lmsUsr

8
templates/profileData.hamlet
View File

@ -56,12 +56,16 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<dt .deflist__dt>
_{MsgUserDisplayEmail}
<dd .deflist__dd .email>
#{userDisplayEmail}
#{mailtoHtml userDisplayEmail}
$if not (validEmail' userDisplayEmail)
\ ^{messageTooltip tooltipInvalidEmail}
$if userEmail /= userDisplayEmail
<dt .deflist__dt>
_{MsgUserSystemEmail}
<dd .deflist__dd>
#{mailtoHtml userEmail}
#{userEmail}
$if not (validEmail' userEmail)
\ ^{messageTooltip tooltipInvalidEmail}
<dt .deflist__dt>
_{MsgAdminUserPinPassword}
<dd .deflist__dd>

26
test/Database/Fill.hs
View File

@ -164,7 +164,7 @@ fillDb = do
, userLastAuthentication = Nothing
, userTokensIssuedAfter = Nothing
, userMatrikelnummer = Nothing
, userEmail = "jost@tcs.ifi.lmu.de"
, userEmail = "e12345@fraport.de"
, userDisplayEmail = "jost@tcs.ifi.lmu.de"
, userDisplayName = "Steffen Jost"
, userSurname = "Jost"
@ -172,7 +172,7 @@ fillDb = do
, userTitle = Just "Dr."
, userMaxFavourites = 14
, userMaxFavouriteTerms = 4
, userTheme = ThemeSkyLove
, userTheme = ThemeMossGreen
, userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat
@ -386,14 +386,14 @@ fillDb = do
= foldMap tshow cs : toMatrikel rest
| otherwise
= []
manyUser (firstName, middleName, userSurname) (Just -> userMatrikelnummer) = User
manyUser (firstName, middleName, userSurname) userMatrikelnummer' = User
{ userIdent
, userAuthentication = AuthLDAP
, userLastAuthentication = Nothing
, userTokensIssuedAfter = Nothing
, userMatrikelnummer
, userEmail = userIdent
, userDisplayEmail = userIdent
, userMatrikelnummer = Just userMatrikelnummer'
, userEmail = userEmail'
, userDisplayEmail = userDisplayEmail'
, userDisplayName = case middleName of
Just middleName' -> [st|#{firstName} #{middleName'} #{userSurname}|]
Nothing -> [st|#{firstName} #{userSurname}|]
@ -433,6 +433,18 @@ fillDb = do
userIdent = fromString $ case middleName of
Just middleName' -> repack [st|#{firstName}.#{middleName'}.#{userSurname}@example.invalid|]
Nothing -> repack [st|#{firstName}.#{userSurname}@example.invalid|]
userEmail' :: CI Text
userEmail' = CI.mk $ case firstName of
"James" -> userIdent
"John" -> userIdent
--"Elizabeth" -> "AVSID:" <> userMatrikelnummer'
_ -> "E" <> userMatrikelnummer' <> "@fraport.de"
userDisplayEmail' :: CI Text
userDisplayEmail' = CI.mk $ case userSurname of
"Walker" -> "AVSNO:" <> userMatrikelnummer'
"Clark" -> "E" <> userMatrikelnummer' <> "@fraport.de"
_ -> userIdent
matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int)
manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel
matUsers <- selectList [UserMatrikelnummer !=. Nothing] []
@ -562,7 +574,7 @@ fillDb = do
void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) Nothing False
void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) Nothing True
void . insert' $ QualificationUser sbarth qid_f (n_day 400) (n_day $ -40) (n_day $ -1200) Nothing True
void . insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) Nothing False
void . insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) (Just $ QualificationBlocked (n_day $ -7) "Some long explanation for the block!") False
void . insert' $ QualificationUser tinaTester qid_r (n_day 3) (n_day $ -60) (n_day $ -250) Nothing False
void . insert' $ QualificationUser gkleen qid_r (n_day $ -7) (n_day $ -2) (n_day $ -9) Nothing True
void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) Nothing False