From 866e47a06186d12e321c0e9a6ea5f466842371bf Mon Sep 17 00:00:00 2001
From: Steffen Jost <jost@tcs.ifi.lmu.de>
Date: Mon, 6 Mar 2023 19:44:46 +0100
Subject: [PATCH 1/8] chore(release): 27.0.27

---
 CHANGELOG.md                 | 7 +++++++
 nix/docker/demo-version.json | 2 +-
 nix/docker/version.json      | 2 +-
 package-lock.json            | 2 +-
 package.json                 | 2 +-
 package.yaml                 | 2 +-
 6 files changed, 12 insertions(+), 5 deletions(-)

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

From 05832681d398d4d3614ceba4df97c790bea8a517 Mon Sep 17 00:00:00 2001
From: Steffen Jost <S.Jost@Fraport.de>
Date: Thu, 9 Mar 2023 14:32:35 +0000
Subject: [PATCH 2/8] chore(email): dont allow numeric fraport accounts

---
 messages/uniworx/utils/utils/de-de-formal.msg |  1 +
 messages/uniworx/utils/utils/en-eu.msg        |  1 +
 src/Handler/Profile.hs                        |  7 ++++++-
 src/Handler/Utils/Profile.hs                  | 10 ++++++++--
 templates/profileData.hamlet                  |  4 ++++
 test/Database/Fill.hs                         |  2 +-
 6 files changed, 21 insertions(+), 4 deletions(-)

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/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/Utils/Profile.hs b/src/Handler/Utils/Profile.hs
index 23e355232..a018cd7e8 100644
--- a/src/Handler/Utils/Profile.hs
+++ b/src/Handler/Utils/Profile.hs
@@ -80,10 +80,16 @@ validPostAddress (Just StoredMarkup {markupInput = addr})
 validPostAddress _ = False
 
 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
diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet
index 39f593166..82069d56d 100644
--- a/templates/profileData.hamlet
+++ b/templates/profileData.hamlet
@@ -57,11 +57,15 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
         _{MsgUserDisplayEmail}
       <dd .deflist__dd .email>
         #{userDisplayEmail}
+          $if not (validEmail' userDisplayEmail)
+            \ ^{messageTooltip tooltipInvalidEmail}
       $if userEmail /= userDisplayEmail
         <dt .deflist__dt>
           _{MsgUserSystemEmail}
         <dd .deflist__dd>
           #{mailtoHtml userEmail}
+            $if not (validEmail' userEmail)
+            \ ^{messageTooltip tooltipInvalidEmail}
       <dt .deflist__dt>
         _{MsgAdminUserPinPassword}
       <dd .deflist__dd>
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs
index 87f3e38ae..2781dcff3 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"

From f6bed7d0faddd3ad835ea3704fd92b1e48d262f6 Mon Sep 17 00:00:00 2001
From: Steffen Jost <S.Jost@Fraport.de>
Date: Fri, 10 Mar 2023 10:30:07 +0000
Subject: [PATCH 3/8] chore(email): automatic mail reroute for dev environment

---
 config/settings.yml | 6 +++---
 src/Settings.hs     | 2 +-
 start.sh            | 2 ++
 3 files changed, 6 insertions(+), 4 deletions(-)

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

From 3865afbceb69f8941c25c814abf855b4b035201a Mon Sep 17 00:00:00 2001
From: Steffen Jost <S.Jost@Fraport.de>
Date: Fri, 10 Mar 2023 17:56:02 +0000
Subject: [PATCH 4/8] fix(email): ensure sending to valid emails only

---
 src/Handler/Admin.hs                  |  3 +-
 src/Handler/Utils/Mail.hs             | 41 ++++++++++++++++++++-------
 src/Handler/Utils/Profile.hs          | 17 +++++++----
 src/Handler/Utils/Users.hs            | 14 +++++----
 src/Jobs/Handler/QueueNotification.hs |  6 ++--
 templates/profileData.hamlet          |  4 +--
 6 files changed, 58 insertions(+), 27 deletions(-)

diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs
index cadc13683..efa9f37dc 100644
--- a/src/Handler/Admin.hs
+++ b/src/Handler/Admin.hs
@@ -147,7 +147,8 @@ 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 
 
 allDriversHaveAvsId :: Day -> DB Bool
diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs
index 154d7e219..36c6112a1 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
 
@@ -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 
+  unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr)
   mailT ctx $ do
-    _mailTo .= pure (userAddress user)
+    _mailTo .= pure mailtoAddr
     mAct
+  -- TODO: ensure that the Email is VALID HERE!
+  -- if validEmail $ addressEmail mailtoAddr
+  --   then 
+  --     mailT ctx $ do
+  --       _mailTo .= pure mailtoAddr
+  --       mAct
+  --   else do
+  --     -- failedSubject <- lookupMailHeader "Subject"        
+  --     $logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr -- <> " with subject " <> tshow failedSubject
+      
+
 
 
 addFileDB :: ( MonadMail m
diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs
index a018cd7e8..6c8caa9a1 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
@@ -87,12 +88,18 @@ validEmail email = validRFC5322 && not invalidFraport
       Just fralogin -> all isDigit $ drop 1 fralogin
       Nothing       -> False
 
-
 validEmail' :: UserEmail -> Bool -- UserEmail = CI Text
 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/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/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/templates/profileData.hamlet b/templates/profileData.hamlet
index 82069d56d..87dae8ebb 100644
--- a/templates/profileData.hamlet
+++ b/templates/profileData.hamlet
@@ -56,14 +56,14 @@ $# 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>

From 8cc04c8e1158eb98f520e5ef8685d92f8246e5fb Mon Sep 17 00:00:00 2001
From: Steffen Jost <S.Jost@Fraport.de>
Date: Mon, 13 Mar 2023 16:31:08 +0000
Subject: [PATCH 5/8] chore(email): improve email validity checks

---
 src/Handler/Admin.hs         | 19 +++++++++++++++++--
 src/Handler/Utils/Mail.hs    | 30 +++++++++++++++---------------
 src/Handler/Utils/Profile.hs |  1 +
 test/Database/Fill.hs        | 20 ++++++++++++++++----
 4 files changed, 49 insertions(+), 21 deletions(-)

diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs
index efa9f37dc..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
         <ul>
           $forall usr <- unreachables
             <li>
-              ^{linkUserWidget ForProfileR usr}
+              ^{linkUserWidget ForProfileR usr} (#{usr ^. _userDisplayEmail} / #{usr ^. _userEmail})
     |]
 
 getProblemFbutNoR :: Handler Html
@@ -151,6 +152,20 @@ retrieveUnreachableUsers = do
           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/Utils/Mail.hs b/src/Handler/Utils/Mail.hs
index 36c6112a1..f90ffd604 100644
--- a/src/Handler/Utils/Mail.hs
+++ b/src/Handler/Utils/Mail.hs
@@ -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
 
@@ -111,7 +111,7 @@ userMailT uid mAct = do
               mapSubject ("[SUPERVISOR] " <>)
               addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email
       else -- do
-        -- failedSubject <- lookupMailHeader "Subject"        
+        -- 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
@@ -138,20 +138,20 @@ userMailTdirect uid mAct = do
       , mcCsvOptions = userCsvOptions
       }
     mailtoAddr = userAddress user 
-  unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr)
   mailT ctx $ do
+    failedSubject <- lookupMailHeader "Subject"
+    unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr <> " with subject " <> tshow failedSubject)
     _mailTo .= pure mailtoAddr
-    mAct
-  -- TODO: ensure that the Email is VALID HERE!
-  -- if validEmail $ addressEmail mailtoAddr
-  --   then 
-  --     mailT ctx $ do
-  --       _mailTo .= pure mailtoAddr
-  --       mAct
-  --   else do
-  --     -- failedSubject <- lookupMailHeader "Subject"        
-  --     $logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr -- <> " with subject " <> tshow failedSubject
-      
+    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
+-}      
 
 
 
diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs
index 6c8caa9a1..22f7a8098 100644
--- a/src/Handler/Utils/Profile.hs
+++ b/src/Handler/Utils/Profile.hs
@@ -80,6 +80,7 @@ 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 = validRFC5322 && not invalidFraport
   where 
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs
index 2781dcff3..af1cec970 100644
--- a/test/Database/Fill.hs
+++ b/test/Database/Fill.hs
@@ -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] []

From 09c4eb3a7bf2d5811512d83ed9a8e33020088745 Mon Sep 17 00:00:00 2001
From: Steffen Jost <S.Jost@Fraport.de>
Date: Wed, 15 Mar 2023 17:10:32 +0000
Subject: [PATCH 6/8] chore(qualifications): use blocking mechanism (WIP)

---
 .../uniworx/categories/avs/de-de-formal.msg   |  5 ++-
 messages/uniworx/categories/avs/en-eu.msg     |  5 ++-
 .../categories/qualification/de-de-formal.msg | 10 +++--
 .../categories/qualification/en-eu.msg        | 12 ++++--
 src/Audit/Types.hs                            | 22 ++++++----
 src/Handler/Admin/Avs.hs                      | 41 ++++++++++++-------
 src/Handler/Qualification.hs                  | 35 +++++++++++++---
 src/Handler/Utils/Qualification.hs            | 39 +++++++++++++++++-
 src/Jobs/Handler/LMS.hs                       | 10 ++---
 src/Model/Types/Lms.hs                        | 21 ++++++++++
 templates/letter/din5008.latex                |  2 +-
 11 files changed, 153 insertions(+), 49 deletions(-)

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..a26725a9b 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.
 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,13 @@ 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: Stornieren - Qualifikation läuft ohne Benachrichtigung ab
+QualificationActUnexpire: Stornierung aufheben - 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 zurückgeben
+QualificationActBlock: Entziehen
+QualificationActUnblock: Entzug löschen
 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..101ce4b3e 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: Cancelled
 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,13 @@ 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: Cancel - qualification expires silently
+QualificationActUnexpire: Uncancel - notify 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
+QualificationActBlock: Revoke
+QualificationActUnblock: Clear revocation
 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/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/Avs.hs b/src/Handler/Admin/Avs.hs
index 6d2ed633e..27158c208 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?!
diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs
index 6b8ac748d..2aee9284a 100644
--- a/src/Handler/Qualification.hs
+++ b/src/Handler/Qualification.hs
@@ -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)
@@ -400,10 +417,15 @@ 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 
+          [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- nonAdmin Supervisor
+          [ singletonMap QualificationActUnblock         $ pure QualificationActUnblockData
+          , singletonMap QualificationActBlock           $      QualificationActBlockData 
+              <$> apreq textField (fslI MsgQualificationBlockReason) Nothing
+          ] isAdmin
         linkLmsUser = toMaybe isAdmin LmsUserR
         colChoices = mconcat
           [ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
@@ -426,6 +448,7 @@ postQualificationR sid qsh = do
     return (tbl, qent)
   
   formResult lmsRes $ \case
+    -- TODO: continue here
     _ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page for now
     (action, selectedUsers) | isExpiryAct action -> do 
       let isUnexpire = action == QualificationActUnexpireData
@@ -436,7 +459,7 @@ postQualificationR sid qsh = do
           msgVal  = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
       addMessageI msgKind msgVal
       redirect currentRoute
-    _ -> return ()
+    _ -> addMessageI Error MsgUnauthorized -- TODO continue here
 
   let heading = citext2widget $ qualificationName quali
   siteLayout heading $ do
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/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/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/templates/letter/din5008.latex b/templates/letter/din5008.latex
index 9ad2d8280..992dcf871 100644
--- a/templates/letter/din5008.latex
+++ b/templates/letter/din5008.latex
@@ -145,7 +145,7 @@ $endif$
 
         \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$}

From 921e5df9d995f2222c5a785d4e3ad2593c73f35a Mon Sep 17 00:00:00 2001
From: Steffen Jost <S.Jost@Fraport.de>
Date: Thu, 16 Mar 2023 11:47:21 +0000
Subject: [PATCH 7/8] chore(company): show company column for lms and quals,
 show lms blocked reason for admins in quals

---
 src/Handler/Admin/Avs.hs     |  2 +-
 src/Handler/LMS.hs           | 24 +++++++++++++++++++++---
 src/Handler/PrintCenter.hs   |  2 +-
 src/Handler/Qualification.hs | 27 +++++++++++++++++++++++----
 templates/lms-user.hamlet    |  7 ++++---
 test/Database/Fill.hs        |  4 ++--
 6 files changed, 52 insertions(+), 14 deletions(-)

diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs
index 27158c208..e4609bd0a 100644
--- a/src/Handler/Admin/Avs.hs
+++ b/src/Handler/Admin/Avs.hs
@@ -583,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/Qualification.hs b/src/Handler/Qualification.hs
index 2aee9284a..87da7a59b 100644
--- a/src/Handler/Qualification.hs
+++ b/src/Handler/Qualification.hs
@@ -317,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
@@ -340,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
@@ -426,15 +433,27 @@ postQualificationR sid qsh = do
           , singletonMap QualificationActBlock           $      QualificationActBlockData 
               <$> apreq textField (fslI MsgQualificationBlockReason) Nothing
           ] isAdmin
-        linkLmsUser = toMaybe isAdmin LmsUserR
+        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)  
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
     <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
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs
index af1cec970..ef14d37ae 100644
--- a/test/Database/Fill.hs
+++ b/test/Database/Fill.hs
@@ -172,7 +172,7 @@ fillDb = do
     , userTitle = Just "Dr."
     , userMaxFavourites = 14
     , userMaxFavouriteTerms = 4
-    , userTheme = userDefaultTheme
+    , userTheme = ThemeMossGreen
     , userDateTimeFormat = userDefaultDateTimeFormat
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat
@@ -574,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

From 0ccb9a3ffb5a722205d58b0a10cea92f5b017e86 Mon Sep 17 00:00:00 2001
From: Steffen Jost <S.Jost@Fraport.de>
Date: Thu, 16 Mar 2023 12:56:41 +0000
Subject: [PATCH 8/8] chore(qualification): blocking on qualification page
 implemented

---
 .../categories/qualification/de-de-formal.msg | 12 ++++---
 .../categories/qualification/en-eu.msg        | 10 +++---
 src/Handler/Qualification.hs                  | 34 +++++++++++++++----
 3 files changed, 40 insertions(+), 16 deletions(-)

diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg
index a26725a9b..5f9a75830 100644
--- a/messages/uniworx/categories/qualification/de-de-formal.msg
+++ b/messages/uniworx/categories/qualification/de-de-formal.msg
@@ -23,8 +23,8 @@ TableQualificationFirstHeld: Erstmalig
 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
@@ -71,13 +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: Stornieren - Qualifikation läuft ohne Benachrichtigung ab
-QualificationActUnexpire: Stornierung aufheben - 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 zurückgeben
+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 101ce4b3e..c6257832f 100644
--- a/messages/uniworx/categories/qualification/en-eu.msg
+++ b/messages/uniworx/categories/qualification/en-eu.msg
@@ -23,7 +23,7 @@ TableQualificationFirstHeld: First held
 TableQualificationBlockedDue: Revoked
 TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended?
 TableQualificationBlockedTooltipSimple: When was this qualification revoked due to extraordinary reasons?
-TableQualificationNoRenewal: Cancelled
+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.
@@ -71,13 +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: Cancel - qualification expires silently
-QualificationActUnexpire: Uncancel - 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
+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/src/Handler/Qualification.hs b/src/Handler/Qualification.hs
index 87da7a59b..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
@@ -466,19 +466,39 @@ postQualificationR sid qsh = do
     tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
     return (tbl, qent)
   
-  formResult lmsRes $ \case
-    -- TODO: continue here
-    _ | 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
-    _ -> addMessageI Error MsgUnauthorized -- TODO continue here
+    (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