diff --git a/CHANGELOG.md b/CHANGELOG.md
index 9c31d1659..7060e4202 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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)
diff --git a/config/settings.yml b/config/settings.yml
index 5d0702621..1f547b1dc 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -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"
diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg
index 7a63ec25d..33f266aed 100644
--- a/messages/uniworx/categories/avs/de-de-formal.msg
+++ b/messages/uniworx/categories/avs/de-de-formal.msg
@@ -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
\ No newline at end of file
+LicenceTableRevokeFDrive: In FRADrive entziehen
\ No newline at end of file
diff --git a/messages/uniworx/categories/avs/en-eu.msg b/messages/uniworx/categories/avs/en-eu.msg
index 91efb95f9..cadb045af 100644
--- a/messages/uniworx/categories/avs/en-eu.msg
+++ b/messages/uniworx/categories/avs/en-eu.msg
@@ -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
diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg
index e99f42ec6..5f9a75830 100644
--- a/messages/uniworx/categories/qualification/de-de-formal.msg
+++ b/messages/uniworx/categories/qualification/de-de-formal.msg
@@ -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
diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg
index 729511c76..c6257832f 100644
--- a/messages/uniworx/categories/qualification/en-eu.msg
+++ b/messages/uniworx/categories/qualification/en-eu.msg
@@ -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
diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg
index a36ce9848..31cccdcbd 100644
--- a/messages/uniworx/utils/utils/de-de-formal.msg
+++ b/messages/uniworx/utils/utils/de-de-formal.msg
@@ -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
diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg
index f2af64e05..9dfe75299 100644
--- a/messages/uniworx/utils/utils/en-eu.msg
+++ b/messages/uniworx/utils/utils/en-eu.msg
@@ -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
diff --git a/nix/docker/demo-version.json b/nix/docker/demo-version.json
index 74ce22309..6e0bc286a 100644
--- a/nix/docker/demo-version.json
+++ b/nix/docker/demo-version.json
@@ -1,3 +1,3 @@
{
- "version": "27.0.26"
+ "version": "27.0.27"
}
diff --git a/nix/docker/version.json b/nix/docker/version.json
index 74ce22309..6e0bc286a 100644
--- a/nix/docker/version.json
+++ b/nix/docker/version.json
@@ -1,3 +1,3 @@
{
- "version": "27.0.26"
+ "version": "27.0.27"
}
diff --git a/package-lock.json b/package-lock.json
index d30e39bd6..2a7e9bfe6 100644
--- a/package-lock.json
+++ b/package-lock.json
@@ -1,6 +1,6 @@
{
"name": "uni2work",
- "version": "27.0.26",
+ "version": "27.0.27",
"lockfileVersion": 1,
"requires": true,
"dependencies": {
diff --git a/package.json b/package.json
index 946fa07c4..dc0136659 100644
--- a/package.json
+++ b/package.json
@@ -1,6 +1,6 @@
{
"name": "uni2work",
- "version": "27.0.26",
+ "version": "27.0.27",
"description": "",
"keywords": [],
"author": "",
diff --git a/package.yaml b/package.yaml
index d058a49cd..8f8291151 100644
--- a/package.yaml
+++ b/package.yaml
@@ -1,5 +1,5 @@
name: uniworx
-version: 27.0.26
+version: 27.0.27
dependencies:
- base
- yesod
diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs
index 1299a11ef..195f1d878 100644
--- a/src/Audit/Types.hs
+++ b/src/Audit/Types.hs
@@ -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
diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs
index cadc13683..9749f3004 100644
--- a/src/Handler/Admin.hs
+++ b/src/Handler/Admin.hs
@@ -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
$forall usr <- unreachables
-
- ^{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
diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs
index 6d2ed633e..e4609bd0a 100644
--- a/src/Handler/Admin/Avs.hs
+++ b/src/Handler/Admin/Avs.hs
@@ -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
diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs
index e32257e53..c8cb5aaa9 100644
--- a/src/Handler/LMS.hs
+++ b/src/Handler/LMS.hs
@@ -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}|]
diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs
index f3b89f378..9c0475259 100644
--- a/src/Handler/PrintCenter.hs
+++ b/src/Handler/PrintCenter.hs
@@ -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{..}
diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index 93c2b9ff8..9bc7efeb7 100644
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@@ -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")
diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs
index 6b8ac748d..e75457de9 100644
--- a/src/Handler/Qualification.hs
+++ b/src/Handler/Qualification.hs
@@ -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
diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs
index 154d7e219..f90ffd604 100644
--- a/src/Handler/Utils/Mail.hs
+++ b/src/Handler/Utils/Mail.hs
@@ -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
diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs
index 23e355232..22f7a8098 100644
--- a/src/Handler/Utils/Profile.hs
+++ b/src/Handler/Utils/Profile.hs
@@ -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
\ No newline at end of file
+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
\ No newline at end of file
diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs
index ecb1236f4..1e8302ecf 100644
--- a/src/Handler/Utils/Qualification.hs
+++ b/src/Handler/Utils/Qualification.hs
@@ -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.
\ No newline at end of file
+ _ -> 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
\ No newline at end of file
diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index b211bc34c..512291970 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -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)
diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs
index 74e22651f..a860c8d6a 100644
--- a/src/Jobs/Handler/LMS.hs
+++ b/src/Jobs/Handler/LMS.hs
@@ -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 }
diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs
index fc12a3921..db91f4640 100644
--- a/src/Jobs/Handler/QueueNotification.hs
+++ b/src/Jobs/Handler/QueueNotification.hs
@@ -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
diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs
index db6f263ca..a191f248b 100644
--- a/src/Model/Types/Lms.hs
+++ b/src/Model/Types/Lms.hs
@@ -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)
diff --git a/src/Settings.hs b/src/Settings.hs
index d32833521..2d5ab05de 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -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"
diff --git a/start.sh b/start.sh
index 47701a357..f5c21989f 100755
--- a/start.sh
+++ b/start.sh
@@ -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() {
diff --git a/templates/letter/din5008.latex b/templates/letter/din5008.latex
index 1660f2d11..9bf447aaf 100644
--- a/templates/letter/din5008.latex
+++ b/templates/letter/din5008.latex
@@ -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$
diff --git a/templates/letter/din5008with_pin.latex b/templates/letter/din5008with_pin.latex
index c22e1c5c2..2ef693b87 100644
--- a/templates/letter/din5008with_pin.latex
+++ b/templates/letter/din5008with_pin.latex
@@ -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$}
diff --git a/templates/lms-user.hamlet b/templates/lms-user.hamlet
index 13b3c0375..6108b47c1 100644
--- a/templates/lms-user.hamlet
+++ b/templates/lms-user.hamlet
@@ -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
- #{qualificationShorthand quali} - #{qualificationName quali} - #{qualificationSchool quali}
+ #{qualificationShorthand quali} - #{qualificationName quali} (#{qualificationSchool quali}) #{boolSymbol (E.unValue validity)}
$maybe (Entity _ qualUsr) <- mbQualUsr
@@ -41,7 +41,8 @@ $else
-
#{lmsUserPin lmsUsr}
- \ ^{formatTimeW SelFormatDateTime (lmsUserDatePin lmsUsr)}
+
+ ^{formatTimeW SelFormatDateTime (lmsUserDatePin lmsUsr)}
$if lmsUserResetPin lmsUsr
\ #{icon IconReset}
$maybe ts <- lmsUserReceived lmsUsr
diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet
index 39f593166..87dae8ebb 100644
--- a/templates/profileData.hamlet
+++ b/templates/profileData.hamlet
@@ -56,12 +56,16 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
-
_{MsgUserDisplayEmail}
-
- #{userDisplayEmail}
+ #{mailtoHtml userDisplayEmail}
+ $if not (validEmail' userDisplayEmail)
+ \ ^{messageTooltip tooltipInvalidEmail}
$if userEmail /= userDisplayEmail
-
_{MsgUserSystemEmail}
-
- #{mailtoHtml userEmail}
+ #{userEmail}
+ $if not (validEmail' userEmail)
+ \ ^{messageTooltip tooltipInvalidEmail}
-
_{MsgAdminUserPinPassword}
-
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs
index 995ae5f48..3934e7d5e 100644
--- a/test/Database/Fill.hs
+++ b/test/Database/Fill.hs
@@ -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