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

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)
 
 

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: 
+mail-reroute-to: 
-#  name:         "_env:MAIL_REROUTE_TO_NAME:Steffen Jost"
+ name:         "_env:MAIL_REROUTE_TO_NAME:"
-#  email:        "_env:MAIL_REROUTE_TO_EMAL:jost@tcs.ifi.lmu.de"
+ email:        "_env:MAIL_REROUTE_TO_EMAIL:"
 #mail-verp:
 #  separator:    "_env:VERP_SEPARATOR:+"
 #  prefix:       "_env:VERP_PREFIX:bounce"

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
+LicenceTableRevokeFDrive: In FRADrive entziehen

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

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
+TableQualificationNoRenewal: Auslaufend
-TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch gültig sein.
+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
+QualificationActExpire: Auslaufend markieren - keine Benachrichtigung zur Erneuerung senden
-QualificationActUnexpire: Benachrichtigung bei anstehender 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

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
+QualificationActExpire: Discontinue - qualification expires silently
-QualificationActUnexpire: Notify upon due renewal
+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

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

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

nix/docker/demo-version.json

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

nix/docker/version.json

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

package-lock.json

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

package.json

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

package.yaml

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

src/Audit/Types.hs

@@ -197,20 +197,24 @@ data Transaction
     , transactionNote          :: Maybe Text
     , transactionReceived      :: UTCTime -- when was the csv file received?
     }
-
+  | TransactionQualificationUserEdit  -- Note that a renewal always entails unblocking as well!
-  | TransactionQualificationUserEdit
+    { transactionUser                         :: UserId                 -- qualification holder that is updated
-    { transactionQualificationUser            :: QualificationUserId
+    , transactionQualificationUser            :: QualificationUserId
-    , transactionQualification                :: QualificationId
+    , transactionQualification                :: QualificationId    
-    , transactionUser                         :: UserId                 -- qualification holder that is updated
     , transactionQualificationValidUntil      :: Day
     , transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration)
     }
   | TransactionQualificationUserDelete
-    { transactionQualificationUser :: QualificationUserId
+    { transactionUser               :: UserId
-    , transactionQualification     :: QualificationId
+    , transactionQualificationUser  :: QualificationUserId
-    , transactionUser              :: UserId
+    , 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

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
         <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

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
+                            |  LicenceTableRevokeFDriveData 
-                            |  LicenceTableGrantFDriveData { licenceTableChangeFDriveQId    :: QualificationId
+                              { licenceTableChangeFDriveQId     :: QualificationId
-                                                           , licenceTableChangeFDriveEnd    :: Day
+                              , licenceTableChangeFDriveReason  :: Text
-                                                           , licenceTableChangeFDriveRenew  :: Maybe Bool
+                              }
-                                                           }
+                            |  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 
+      procRes alic (LicenceTableRevokeFDriveData{..}, apids) = do 
-        nups <- runDB $ do
+        oks <- runDB $ do
           qId <- getKeyBy404 $ UniqueQualificationAvsLicence $ Just alic
-          selectedUsers <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
+          if qId /= licenceTableChangeFDriveQId 
-          forM_ selectedUsers $ upsertQualificationUser qId nowaday (pred nowaday) Nothing
+            then return (-1)
-          return $ length selectedUsers
+            else do
-        addMessageI Success $ MsgRevokeFraDriveLicences alic nups
+              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] []
+          uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []          
-          let uids = view _userAvsUser <$> uas
           -- 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 

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}|]  

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{..}
 

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")

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          
-          ]
+          ] ++ bool 
-        linkLmsUser = toMaybe isAdmin LmsUserR
+          [ 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
+  formResult lmsRes $ \case    
-    _ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page for now
+    (action, selectedUsers) | isExpiryAct action -> do
-    (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

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
+        mailtoAddr = userAddress supervisor
-      _mailTo .= pure (userAddress supervisor)
+    if validEmail $ addressEmail mailtoAddr
-      mAct
+      then 
-      if uid==svr
+        mailT ctx $ do
-        then when (2 <= length receivers) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors
+          -- TODO: ensure that the Email is VALID HERE!
-        else do
+          _mailTo .= pure mailtoAddr 
-          mapSubject ("[SUPERVISOR] " <>)
+          mAct
-          addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email
+          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)
+    failedSubject <- lookupMailHeader "Subject"
-    mAct
+    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

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 
+pickValidEmail x y
-  | validEmail' x = x 
+  | validEmail' x = x
-  | otherwise     = y
+  | 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

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.
+    _ -> 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

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    
+  where        
-    emailPossible = validEmail' userEmail
-    postPossible  = isJust pa
     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)

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)) 
+            void $ qualificationUserBlocking qid [lmsUserUser luser] $ Just $ mkQualificationBlocked QualificationBlockFailedELearning blockedDay                                                                        
-              [QualificationUserBlockedDue =. Just (QualificationBlocked { qualificationBlockedDay = blockedDay
-                                                                         , qualificationBlockedReason = blockedByElearning } )]
             queueDBJob JobSendNotification
               { jRecipient    = lmsUserUser luser
               , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = blockedDay }

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}) -> 
+            .| C.filterM (\(notification', override, Entity _ User{userNotificationSettings,userDisplayEmail,userEmail}) -> 
-                and2M (return $ validEmail' 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

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)

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"

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() {

templates/letter/din5008.latex

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

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$}

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
     <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

templates/profileData.hamlet

@@ -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>

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
+      , userMatrikelnummer = Just userMatrikelnummer'
-      , userEmail = userIdent
+      , userEmail        = userEmail'
-      , userDisplayEmail = userIdent
+      , 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