From 6ca02875c27f62606d2df2219bd10533ed634764 Mon Sep 17 00:00:00 2001
From: Steffen Jost <S.Jost@Fraport.de>
Date: Thu, 23 Mar 2023 16:53:31 +0000
Subject: [PATCH 01/11] chore(avs): implement InfoPersonContact query and test

---
 src/Handler/Admin/Avs.hs |  48 ++++++++++++---
 src/Model/Types/Avs.hs   | 122 ++++++++++++++++++++++++++++++++++++++-
 src/Utils/Avs.hs         |  20 +++++--
 src/Utils/Form.hs        |   1 +
 templates/avs.hamlet     |  14 ++++-
 5 files changed, 187 insertions(+), 18 deletions(-)

diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs
index 3cb709b6f..886ffa010 100644
--- a/src/Handler/Admin/Avs.hs
+++ b/src/Handler/Admin/Avs.hs
@@ -87,7 +87,7 @@ validateAvsQueryPerson = do
 makeAvsStatusForm :: Maybe AvsQueryStatus -> Form AvsQueryStatus
 makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateAvsQueryStatus $ \html ->
   flip (renderAForm FormStandard) html $
-     parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl)
+    parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl)
   where
     parseAvsIds :: Text -> AvsQueryStatus
     parseAvsIds txt = AvsQueryStatus $ Set.fromList ids
@@ -102,6 +102,25 @@ validateAvsQueryStatus = do
   AvsQueryStatus ids <- State.get
   guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)
 
+makeAvsContactForm :: Maybe AvsQueryContact -> Form AvsQueryContact
+makeAvsContactForm tmpl = identifyForm FIDAvsQueryContact . validateForm validateAvsQueryContact $ \html ->
+  flip (renderAForm FormStandard) html $
+    parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl) -- consider using cfAnySeparatedSet here
+  where
+    parseAvsIds :: Text -> AvsQueryContact
+    parseAvsIds txt = AvsQueryContact $ Set.fromList ids
+      where        
+        nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt
+        ids = catMaybes $ fmap AvsObjPersonId . readMay <$> nonemptys
+    unparseAvsIds :: AvsQueryContact -> Text
+    unparseAvsIds (AvsQueryContact ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids
+
+validateAvsQueryContact :: FormValidator AvsQueryContact Handler ()
+validateAvsQueryContact = do
+  AvsQueryContact ids <- State.get
+  guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)
+
+
 avsLicenceOptions :: OptionList AvsLicence
 avsLicenceOptions = mkOptionList
   [ Option
@@ -142,7 +161,7 @@ postAdminAvsR = do
 
       ((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
       let procFormStatus fr = do
-            addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
+            addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr)
             res <- avsQueryStatus fr
             case res of
               Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
@@ -153,6 +172,20 @@ postAdminAvsR = do
                 |]
       mbStatus <- formResultMaybe sresult procFormStatus
 
+      ((cresult, cwidget), cenctype) <- runFormPost $ makeAvsContactForm Nothing
+      let procFormContact fr = do
+            addMessage Info $ text2Html $ "Contact Query: " <> tshow (toJSON fr)
+            res <- avsQueryContact fr
+            case res of
+              Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
+              Right (AvsResponseContact pns) -> return $ Just [whamlet|
+                  <ul>
+                    $forall p <- pns 
+                      <li>#{tshow p}
+                |]
+      mbContact <- formResultMaybe cresult procFormContact
+
+
       ((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
         flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing
       let procFormCrUsr fr = do
@@ -259,11 +292,12 @@ postAdminAvsR = do
       siteLayoutMsg MsgMenuAvs $ do
         setTitleI MsgMenuAvs
         let wrapFormHere fw fe = wrapForm fw def { formAction = Just $ SomeRoute actionUrl, formEncoding = fe }
-            personForm = wrapFormHere pwidget  penctype
-            statusForm = wrapFormHere swidget  senctype
-            crUsrForm  = wrapFormHere crUsrWgt crUsrEnctype
-            getLicForm = wrapFormHere getLicWgt getLicEnctype
-            setLicForm = wrapFormHere setLicWgt setLicEnctype
+            personForm  = wrapFormHere pwidget  penctype
+            statusForm  = wrapFormHere swidget  senctype
+            contactForm = wrapFormHere cwidget  cenctype
+            crUsrForm   = wrapFormHere crUsrWgt crUsrEnctype
+            getLicForm  = wrapFormHere getLicWgt getLicEnctype
+            setLicForm  = wrapFormHere setLicWgt setLicEnctype
         -- TODO: use i18nWidgetFile instead if this is to become permanent
         $(widgetFile "avs")
 
diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs
index 96d39bdc4..59cabb982 100644
--- a/src/Model/Types/Avs.hs
+++ b/src/Model/Types/Avs.hs
@@ -249,7 +249,8 @@ instance ToJSON AvsLicence where
 instance FromJSON AvsLicence where
   parseJSON (Number n)  | n == 1 = pure AvsLicenceVorfeld   -- ordered by occurrence, n==1 is most common case
                         | n == 2 = pure AvsLicenceRollfeld
-                        | n == 0 = pure AvsNoLicence        -- n==0 never received from AVS, only sent to AVS                        
+                        | n == 0 = pure AvsNoLicence
+                        -- | n ==(-1) = pure AvsNoLicenceGuest -- InfoContact may send -1 for Guest unable to obtain a licence
 #ifdef DEVELOPMENT
   parseJSON invalid = prependFailure "parsing AvsLicence failed, " $ fail $ "expected Int value being 0, 1 or 2. Found " ++ show invalid
 #else
@@ -345,7 +346,7 @@ instance Canonical AvsDataPersonCard where
 
 -- TODO: use canonical in FromJSON/ToJSON instances for consistency
 instance FromJSON AvsDataPersonCard where
-  parseJSON = withObject "AvsDataPersonCard" $ \v -> AvsDataPersonCard
+  parseJSON = withObject "AvsDataPersonCard" $ \v -> AvsDataPersonCard    -- NOTE: String "AvsDataPersonCard" is only used in error messages when parsing fails
     <$> ((v .: "Valid") <&> sloppyBool)
     <*> v .:? "ValidTo"
     <*> v .:? "IssueDate"
@@ -401,7 +402,7 @@ data AvsDataPerson = AvsDataPerson
       { avsPersonFirstName          :: Text                         -- WARNING: name stored as is, but AVS does contain weird whitespaces
       , avsPersonLastName           :: Text                         -- WARNING: name stored as is, but AVS does contain weird whitespaces
       , avsPersonInternalPersonalNo :: Maybe AvsInternalPersonalNo  -- Fraport Personalnummer
-      , avsPersonPersonNo           :: Int                          -- AVS Personennummer, Bedeutung ist unklar
+      , avsPersonPersonNo           :: Int                          -- AVS Personennummer, in menschlicher Kommunikation verwendet
       , avsPersonPersonID           :: AvsPersonId                  -- Eindeutige PersonenID, wichtig für die Schnittstelle!
       , avsPersonPersonCards        :: Set AvsDataPersonCard
       }
@@ -475,6 +476,108 @@ deriveJSON defaultOptions
   , rejectUnknownFields = False  
   } ''AvsLicenceResponse
 
+data AvsPersonInfo = AvsPersonInfo 
+  { avsInfoPersonNo             :: Text -- Int                  -- AVS Personennummer, zum Gebrauch in menschlicher Kommunikation
+  , avsInfoFirstName            :: Text                         -- WARNING: name stored as is, but AVS does contain weird whitespaces
+  , avsInfoLastName             :: Text                         -- WARNING: name stored as is, but AVS does contain weird whitespaces
+  , avsInfoRampLicence          :: AvsLicence                   -- unlike other queries, may return -1 for guest unable to hold a licence; currently not distinquished from no licence
+  , avsInfoDateOfBirth          :: Maybe Day
+  , avsInfoPersonEMail          :: Maybe Text
+  , avsInfoPersonMobilePhoneNo  :: Maybe Text  
+  , avsInfoInternalPersonalNo   :: Maybe AvsInternalPersonalNo  -- Fraport Personalnummer
+  } deriving (Eq, Ord, Show, Generic)
+
+makeLenses_ ''AvsPersonInfo
+
+instance FromJSON AvsPersonInfo where
+  parseJSON = withObject "AvsPersonInfo" $ \o -> AvsPersonInfo
+    <$> o .:   "PersonsNo"                                      -- NOTE: PersonsNo, not PersonNo as elsewhere
+    <*> o .:   "FirstName"
+    <*> o .:   "LastName"
+    <*> o .:   "RampLicence"
+    <*> o .:?  "DateOfBirth"
+    <*> o .:?! "PersonEMail"
+    <*> o .:?! "PersonMobilePhoneNo"
+    <*> o .:?! "InternalPersonalNo"
+
+
+instance ToJSON AvsPersonInfo where
+  toJSON AvsPersonInfo{..} = object $ catMaybes
+    [ ("DateOfBirth"         .=) <$> avsInfoDateOfBirth         
+    , ("PersonEMail"         .=) <$> avsInfoPersonEMail         & canonical
+    , ("PersonMobilePhoneNo" .=) <$> avsInfoPersonMobilePhoneNo & canonical 
+    , ("InternalPersonalNo"  .=) <$> avsInfoInternalPersonalNo  & canonical
+    ] <>
+    [ "PersonsNo"   .= avsInfoPersonNo 
+    , "FirstName"   .= avsInfoFirstName
+    , "LastName"    .= avsInfoLastName
+    , "RampLicence" .= avsInfoRampLicence
+    ]
+-- derivePersistFieldJSON ''AvsPersonInfo
+
+
+data AvsFirmInfo = AvsFirmInfo 
+  { avsFirmFirm             :: Text
+  , avsFirmFirmNo           :: Int
+  , avsFirmAbbreviation     :: Text -- enthält manchmal Leerzeichen!
+  , avsFirmZIPCode          :: Maybe Text
+  , avsFirmCity             :: Maybe Text
+  , avsFirmCountry          :: Maybe Text
+  , avsFirmStreetANDHouseNo :: Maybe Text
+  , avsFirmEMail            :: Maybe Text
+  , avsFirmEMailSuperior    :: Maybe Text
+  } deriving (Eq, Ord, Show, Generic)
+
+makeLenses_ ''AvsFirmInfo
+
+instance FromJSON AvsFirmInfo where
+  parseJSON = withObject "AvsFirmInfo" $ \o -> AvsFirmInfo
+    <$> o .:   "Firm"
+    <*> o .:   "FirmNo"
+    <*> o .:   "Abbreviation"
+    <*> o .:?! "ZIPCode"
+    <*> o .:?! "City"
+    <*> o .:?! "Country"
+    <*> o .:?! "StreetANDHouseNo"
+    <*> o .:?! "EMail"
+    <*> o .:?! "EMailSuperior"
+
+instance ToJSON AvsFirmInfo where
+  toJSON AvsFirmInfo{..} = object $ catMaybes
+    [ ("ZIPCode"          .=) <$> avsFirmZIPCode          & canonical
+    , ("City"             .=) <$> avsFirmCity             & canonical 
+    , ("Country"          .=) <$> avsFirmCountry          & canonical
+    , ("StreetANDHouseNo" .=) <$> avsFirmStreetANDHouseNo & canonical
+    , ("EMail"            .=) <$> avsFirmEMail            & canonical 
+    , ("EMailSuperior"    .=) <$> avsFirmEMailSuperior    & canonical
+    ] <>
+    [ "Firm"          .= avsFirmFirm
+    , "FirmNo"        .= avsFirmFirmNo
+    , "Abbreviation"  .= avsFirmAbbreviation
+    ]
+-- derivePersistFieldJSON ''AvsFirmInfo
+
+
+data AvsDataContact = AvsDataContact
+  { avsContactPersonID    :: AvsPersonId
+  , avsContactPersonInfo  :: AvsPersonInfo
+  , avsContactFirmInfo    :: AvsFirmInfo 
+  } deriving (Eq, Ord, Show, Generic)
+
+makeLenses_ ''AvsDataContact
+
+-- instance Canonical AvsDataContact where
+--   canonical = over _avsContactPersonInfo canonical
+--             . over _avsContactFirmInfo   canonical
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = dropCamel 2
+  , tagSingleConstructors = False
+  , rejectUnknownFields = False
+  } ''AvsDataContact
+
+
+
 
 --------------
 -- Responses --
@@ -498,6 +601,15 @@ deriveJSON defaultOptions
   , rejectUnknownFields = False
   } ''AvsResponsePerson
 
+newtype AvsResponseContact = AvsResponseContact (Set AvsDataContact)
+  deriving (Eq, Ord, Show, Generic)
+deriveJSON defaultOptions
+  { fieldLabelModifier = dropCamel 2
+  , omitNothingFields = True
+  , tagSingleConstructors = False
+  , rejectUnknownFields = False
+  } ''AvsResponseContact
+
 newtype AvsResponseGetLicences = AvsResponseGetLicences (Set AvsPersonLicence)
   deriving (Eq, Ord, Show, Generic)
 deriveJSON defaultOptions
@@ -548,6 +660,10 @@ newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId)
   deriving (Eq, Ord, Show, Generic)
 deriveJSON defaultOptions ''AvsQueryStatus
 
+newtype AvsQueryContact = AvsQueryContact (Set AvsObjPersonId) -- note the difference to AvsQueryStatus, which receives a list of id, whereas here we sent a list of single-field object 
+  deriving (Eq, Ord, Show, Generic)
+deriveJSON defaultOptions ''AvsQueryContact
+
 newtype AvsQueryGetLicences = AvsQueryGetLicences AvsObjPersonId -- this should have been a set, but the specification was implemented differently
   deriving (Eq, Ord, Show, Generic)
 deriveJSON defaultOptions ''AvsQueryGetLicences
diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs
index 560aa49ad..71e90c910 100644
--- a/src/Utils/Avs.hs
+++ b/src/Utils/Avs.hs
@@ -24,11 +24,12 @@ import Model.Types.Avs
 -------------
 -- AVS API --
 -------------
-type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus :<|> AVSGetRampLicences :<|> AVSSetRampLicences)
-type AVSPersonSearch    = "PersonSearch" :> ReqBody '[JSON] AvsQueryPerson :> Post '[JSON] AvsResponsePerson
-type AVSPersonStatus    = "PersonStatus" :> ReqBody '[JSON] AvsQueryStatus :> Post '[JSON] AvsResponseStatus
-type AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryGetLicences :> Post '[JSON] AvsResponseGetLicences
-type AVSSetRampLicences = "RampDrivingLicence"     :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences
+type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus :<|> AVSPersonContact :<|> AVSGetRampLicences :<|> AVSSetRampLicences)
+type AVSPersonSearch    = "PersonSearch"            :> ReqBody '[JSON] AvsQueryPerson       :> Post '[JSON] AvsResponsePerson
+type AVSPersonStatus    = "PersonStatus"            :> ReqBody '[JSON] AvsQueryStatus       :> Post '[JSON] AvsResponseStatus
+type AVSPersonContact   = "InfoPersonContact"       :> ReqBody '[JSON] AvsQueryContact      :> Post '[JSON] AvsResponseContact
+type AVSGetRampLicences = "RampDrivingLicenceInfo"  :> ReqBody '[JSON] AvsQueryGetLicences  :> Post '[JSON] AvsResponseGetLicences
+type AVSSetRampLicences = "RampDrivingLicence"      :> ReqBody '[JSON] AvsQuerySetLicences  :> Post '[JSON] AvsResponseSetLicences
 
 avsMaxSetLicenceAtOnce :: Int
 avsMaxSetLicenceAtOnce = 99   -- maximum input set size for avsQuerySetLicences as enforced by AVS
@@ -49,6 +50,7 @@ data AvsQuery where
 data AvsQuery = AvsQuery
   { avsQueryPerson         :: forall m. MonadIO m => AvsQueryPerson      -> m (Either ClientError AvsResponsePerson)
   , avsQueryStatus         :: forall m. MonadIO m => AvsQueryStatus      -> m (Either ClientError AvsResponseStatus)
+  , avsQueryContact        :: forall m. MonadIO m => AvsQueryContact     -> m (Either ClientError AvsResponseContact)
   , avsQuerySetLicences    :: forall m. MonadIO m => AvsQuerySetLicences -> m (Either ClientError AvsResponseSetLicences)
   -- , avsQueryGetLicences    :: forall m. MonadIO m => AvsQueryGetLicences -> m (Either ClientError AvsResponseGetLicences) -- not supported by VSM
   , avsQueryGetAllLicences :: forall m. MonadIO m =>                        m (Either ClientError AvsResponseGetLicences)
@@ -66,6 +68,7 @@ mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
 mkAvsQuery _ _ _ = AvsQuery
     { avsQueryPerson          = \_ -> return . Right $ AvsResponsePerson      mempty
     , avsQueryStatus          = \_ -> return . Right $ AvsResponseStatus      mempty
+    , avsQueryContact         = \_ -> return . Right $ AvsResponseContact     mempty
     , avsQuerySetLicences     = \_ -> return . Right $ AvsResponseSetLicences mempty
     , avsQueryGetAllLicences  =       return . Right $ AvsResponseGetLicences mempty
     }
@@ -73,12 +76,17 @@ mkAvsQuery _ _ _ = AvsQuery
 mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
     { avsQueryPerson      = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson      q)  cliEnv
     , avsQueryStatus      = \q -> liftIO $                     runClientM (rawQueryStatus      q)  cliEnv
+    , avsQueryContact     = \q -> liftIO $                     runClientM (rawQueryContact     q)  cliEnv
     , avsQuerySetLicences = \q -> liftIO $                     runClientM (rawQuerySetLicences q)  cliEnv
     -- , avsQueryGetLicences = \q -> liftIO $                     runClientM (rawQueryGetLicences q)  cliEnv
     , avsQueryGetAllLicences =    liftIO $                     runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv
     }
   where
-    (rawQueryPerson :<|> rawQueryStatus :<|> rawQueryGetLicences :<|> rawQuerySetLicences) = client avsApi basicAuth
+    (       rawQueryPerson 
+      :<|>  rawQueryStatus 
+      :<|>  rawQueryContact
+      :<|>  rawQueryGetLicences 
+      :<|>  rawQuerySetLicences )  = client avsApi basicAuth
     catch404toEmpty :: Either ClientError AvsResponsePerson -> Either ClientError AvsResponsePerson
     catch404toEmpty (Left (FailureResponse (requestPath -> (base, _path)) (statusCode . responseStatusCode -> 404)))
       | baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database!
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index 5b7096749..9ad82b29f 100644
--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@@ -301,6 +301,7 @@ data FormIdentifier
   | FIDLmsLetter
   | FIDAvsQueryPerson
   | FIDAvsQueryStatus
+  | FIDAvsQueryContact
   | FIDAvsCreateUser
   | FIDAvsQueryLicenceDiffs
   | FIDAvsQueryLicence
diff --git a/templates/avs.hamlet b/templates/avs.hamlet
index 5d4bd6bf8..b9dadd9b8 100644
--- a/templates/avs.hamlet
+++ b/templates/avs.hamlet
@@ -38,7 +38,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 <section>
   <p> 
-    Person search:
+    Person Search:
     ^{personForm}
   $maybe answer <- mbPerson
     <p>
@@ -47,12 +47,22 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 <section>
   <p> 
-    Person status:
+    Person Status:
     ^{statusForm}
   $maybe answer <- mbStatus
     <p>
       Unverarbeitete Antwort: #
       ^{answer}
 
+<section>
+  <p> 
+    Info Person Contact:
+    ^{contactForm}
+  $maybe answer <- mbContact
+    <p>
+      Unverarbeitete Antwort: #
+      ^{answer}
+
+
 <section> 
   ^{modal "AVS Konfiguration" (Right avsWgt)}
\ No newline at end of file

From b563e13ed4a2762fcc2921eb2d6c23216dcb37e5 Mon Sep 17 00:00:00 2001
From: Steffen Jost <S.Jost@Fraport.de>
Date: Thu, 23 Mar 2023 16:54:35 +0000
Subject: [PATCH 02/11] chore(lpr): adjust email reroute message to stop
 printing too

---
 messages/uniworx/categories/admin/de-de-formal.msg | 2 +-
 messages/uniworx/categories/admin/en-eu.msg        | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg
index 3d6a62ccc..5b905fbf1 100644
--- a/messages/uniworx/categories/admin/de-de-formal.msg
+++ b/messages/uniworx/categories/admin/de-de-formal.msg
@@ -43,7 +43,7 @@ StudySubTermsChildKey: Kind
 StudySubTermsChildName: Kindname
 MailTestFormEmail: E-Mail-Adresse
 MailTestFormLanguages: Spracheinstellungen
-MailRerouteTo dev@Address: Alle Emails werden nicht an die eigentlichen Empfänger versendet, sondern umgeleitet zu _{dev}
+MailRerouteTo dev@Address: Alle Emails werden nicht an die eigentlichen Empfänger versendet, sondern umgeleitet zu _{dev}. Druckaufträge werden generiert, aber nicht zum tatsächlichen Druck gesendet.
 TestDownload: Download-Test
 BearerTokenUsageWarning: Mit diesem Interface können quesi beliebige Rechte als Tokens kodiert und somit ohne wesentliche weitere Beschränkung frei übertragen werden. Benutzen Sie dieses Interface nur, wenn Sie von einem erfahrenen Entwickler/einer erfahrenen Entwicklerin über die Auswirkungen des konkreten Tokens, dass sie ausstellen möchten, beraten wurden!
 BearerTokenAuthorityGroups: Token-Authorität (Gruppen)
diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg
index 7b0ad7057..f320c1a3d 100644
--- a/messages/uniworx/categories/admin/en-eu.msg
+++ b/messages/uniworx/categories/admin/en-eu.msg
@@ -43,7 +43,7 @@ StudySubTermsChildKey: Child
 StudySubTermsChildName: Child-Name
 MailTestFormEmail: Email address
 MailTestFormLanguages: Language settings
-MailRerouteTo dev: All email will not be sent to the intended recipients, but rerouted to _{dev}
+MailRerouteTo dev: All email will not be sent to the intended recipients, but rerouted to _{dev}. Printjobs are executed within FRADrive only, they are not sent for actual printing.
 TestDownload: Download test
 BearerTokenUsageWarning: Using this interface you are able to encode essentially arbitrary permissions into bearer tokens. This allows you to freely hand permissions off arbitrarily and without relevant restrictions. Only use this interface if you have discussed the consequences of the specific token, that you want to issue, with an experienced developer!
 BearerTokenAuthorityGroups: Authority (groups)

From 2622d24f03b91dbb530e9192e7d93b9d354bb9d7 Mon Sep 17 00:00:00 2001
From: Steffen Jost <S.Jost@Fraport.de>
Date: Thu, 23 Mar 2023 16:55:10 +0000
Subject: [PATCH 03/11] chore(tutorial): adjust default day for new tutorials

---
 src/Handler/Course/ParticipantInvite.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs
index 9678711dd..e129b9d53 100644
--- a/src/Handler/Course/ParticipantInvite.hs
+++ b/src/Handler/Course/ParticipantInvite.hs
@@ -121,7 +121,7 @@ getCAddUserR,  postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler
 getCAddUserR = postCAddUserR
 postCAddUserR tid ssh csh = do 
   today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
-  postTAddUserR tid ssh csh (CI.mk $ tshow $ succ today)  -- Don't use user date display setting, so that tutorial default names conform to all users
+  postTAddUserR tid ssh csh (CI.mk $ tshow today)  -- Don't use user date display setting, so that tutorial default names conform to all users
 
 
 getTAddUserR,  postTAddUserR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html

From 9c8b09a6337090b1d33851113e7404ce5888dbac Mon Sep 17 00:00:00 2001
From: Steffen Jost <S.Jost@Fraport.de>
Date: Fri, 24 Mar 2023 16:11:48 +0000
Subject: [PATCH 04/11] chore(userlist): allow sorting by admin role or system
 function

---
 src/Handler/Users.hs | 18 +++++++++++++++---
 src/Jobs.hs          |  9 +++++----
 2 files changed, 20 insertions(+), 7 deletions(-)

diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs
index 605b49f3d..29f3d71f3 100644
--- a/src/Handler/Users.hs
+++ b/src/Handler/Users.hs
@@ -132,7 +132,7 @@ postUsersR = do
       , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
       , sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation
       , flip foldMap universeF $ \function ->
-          sortable Nothing (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
+          sortable (Just $ SortingKey $ CI.mk $ toPathPiece function) (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
             schools <- liftHandler . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
               E.on $ school E.^. SchoolId E.==. userFunction E.^. UserFunctionSchool
               E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
@@ -145,7 +145,7 @@ postUsersR = do
                 $forall (E.Value sh) <- schools
                   <li>#{sh}
               |]
-      , sortable Nothing (i18nCell MsgUserSystemFunctions) $ \DBRow{ dbrOutput = Entity uid _ } ->
+      , sortable (Just "system-function") (i18nCell MsgUserSystemFunctions) $ \DBRow{ dbrOutput = Entity uid _ } ->
           let getFunctions = fmap (map $ userSystemFunctionFunction . entityVal) . liftHandler . runDB $ selectList [ UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False ] [ Asc UserSystemFunctionFunction ]
            in listCell' getFunctions i18nCell
       , sortable Nothing (mempty & cellAttrs <>~ pure ("hide-columns--hider-label", mr MsgTableActionsHead)) $ \inp@DBRow{ dbrOutput = Entity uid _ } -> FormCell
@@ -201,7 +201,14 @@ postUsersR = do
       , dbtRowKey = (E.^. UserId)
       , dbtColonnade
       , dbtProj      = dbtProjId
-      , dbtSorting   = Map.fromList
+      , dbtSorting   = Map.fromList $
+          [ ( SortingKey $ CI.mk $ toPathPiece function
+            , SortColumn $ \user -> E.subSelect $ E.from $ \uf -> do 
+                E.where_ $ uf E.^. UserFunctionUser     E.==. user E.^. UserId
+                    E.&&.  uf E.^. UserFunctionFunction E.==. E.val function
+                return (uf E.^. UserFunctionSchool)
+            ) | function <- universeF
+          ] ++
           [ ( "name"
             , SortColumn $ \user -> user E.^. UserSurname
             )
@@ -234,6 +241,11 @@ postUsersR = do
                 E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
                 return (usrSpvr E.^. UserDisplayName)
             )
+          , ( "system-function"
+            , SortColumn $ \user -> E.subSelect $ E.from $ \usf -> do 
+                E.where_ $ usf E.^. UserSystemFunctionUser     E.==. user E.^. UserId
+                return   $ usf E.^. UserSystemFunctionFunction            
+            )
           ]
       , dbtFilter    = Map.fromList -- OverloadedLists does not work with the templates
           [ ( "user-search", FilterColumn $ \user (criteria :: Set.Set Text) ->
diff --git a/src/Jobs.hs b/src/Jobs.hs
index ae2000aa9..7dcc4d81a 100644
--- a/src/Jobs.hs
+++ b/src/Jobs.hs
@@ -246,10 +246,11 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc ->
         { jobWorkers = jobWorkers oldState `Map.withoutKeys` Map.keysSet deadWorkers
         }
       guard . not $ Map.null deadWorkers
-      return . forM_ (Map.toList deadWorkers) $ \(jobAsync, result) -> do
-        case result of
-          Right () -> $logInfoS "JobPoolManager" [st|Job-Executor #{showWorkerId (jobWorkerName oldState jobAsync)} terminated|]
-          Left e   -> $logErrorS "JobPoolManager" [st|Job-Executer #{showWorkerId (jobWorkerName oldState jobAsync)} crashed: #{tshow e}|]
+      return . forM_ (Map.toList deadWorkers) $ \(jobAsync, _result) -> do
+        -- TOO MUCH LOGGING
+        -- case result of
+        --   Right () -> $logInfoS "JobPoolManager" [st|Job-Executor #{showWorkerId (jobWorkerName oldState jobAsync)} terminated|]
+        --   Left e   -> $logErrorS "JobPoolManager" [st|Job-Executer #{showWorkerId (jobWorkerName oldState jobAsync)} crashed: #{tshow e}|]
         void . lift . allocateLinkedAsync $
           let go = do
                 next <- evalRandTIO . mapRandT (liftIO . atomically) . runMaybeT $ do

From 3664c1988c69e4891992180fdc4fae1747aa8fdc Mon Sep 17 00:00:00 2001
From: Steffen Jost <S.Jost@Fraport.de>
Date: Fri, 24 Mar 2023 17:30:37 +0000
Subject: [PATCH 05/11] chore(tutorial): actions on 0 users are marked as
 warning

---
 src/Handler/Admin/Avs.hs      | 16 +++++++++-------
 src/Handler/Tutorial/Users.hs |  4 ++--
 2 files changed, 11 insertions(+), 9 deletions(-)

diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs
index 886ffa010..1c0af28fd 100644
--- a/src/Handler/Admin/Avs.hs
+++ b/src/Handler/Admin/Avs.hs
@@ -15,6 +15,7 @@ module Handler.Admin.Avs
 import Import
 import qualified Control.Monad.State.Class as State
 -- import Data.Aeson (encode)
+import qualified Data.Aeson.Encode.Pretty as Pretty
 import qualified Data.Text as Text
 import qualified Data.CaseInsensitive as CI
 import qualified Data.Set  as Set
@@ -181,7 +182,7 @@ postAdminAvsR = do
               Right (AvsResponseContact pns) -> return $ Just [whamlet|
                   <ul>
                     $forall p <- pns 
-                      <li>#{tshow p}
+                      <li>#{Pretty.encodePretty (toJSON p)}
                 |]
       mbContact <- formResultMaybe cresult procFormContact
 
@@ -427,7 +428,7 @@ getProblemAvsSynchR = do
       procRes aLic (LicenceTableChangeAvsData       , apids) = do 
         oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids
         let no_req = Set.size apids
-            mkind = if oks < no_req then Warning else Success
+            mkind = if oks < no_req || no_req < 0 then Warning else Success
         addMessageI mkind $ MsgAvsSetLicences aLic oks no_req                  
         redirect ProblemAvsSynchR -- reload to update all tables
 
@@ -442,10 +443,11 @@ getProblemAvsSynchR = do
                     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
+                    }
+        let lReq = length apids                        
+        if | oks < 0                 -> addMessageI Error   $ MsgRevokeFraDriveLicencesError alic
+           | oks == lreq && lreq > 0 -> addMessageI Success $ MsgRevokeFraDriveLicences      alic oks
+           | otherwise               -> addMessageI Warning $ MsgRevokeFraDriveLicences      alic oks
         redirect ProblemAvsSynchR -- must be outside runDB 
 
       procRes _alic (LicenceTableGrantFDriveData{..}, apids ) = do
@@ -454,7 +456,7 @@ getProblemAvsSynchR = do
           -- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG
           forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew
           (length uids,) <$> get404 licenceTableChangeFDriveQId
-        addMessageI Success $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n
+        addMessageI (bool Success Warning $ null apids) $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n
         redirect ProblemAvsSynchR -- must be outside runDB 
       
   formResult tres2      $ procRes AvsLicenceRollfeld
diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs
index f3438d599..32cc780c3 100644
--- a/src/Handler/Tutorial/Users.hs
+++ b/src/Handler/Tutorial/Users.hs
@@ -130,12 +130,12 @@ postTUsersR tid ssh csh tutn = do
         -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
         today <- utctDay <$> liftIO getCurrentTime
         runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing
-        addMessageI Success . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
+        addMessageI  (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
         redirect $ CTutorialR tid ssh csh tutn TUsersR
     (TutorialUserRenewQualificationData{..}, selectedUsers)
       | tuQualification `Set.member` courseQids -> do
         noks <- runDB $ renewValidQualificationUsers tuQualification $ Set.toList selectedUsers      
-        addMessageI (if noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
+        addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
         redirect $ CTutorialR tid ssh csh tutn TUsersR
     (TutorialUserSendMailData{}, selectedUsers) -> do
         cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]

From db9ffa18302bf56649466ed78b5040f3c46e5e09 Mon Sep 17 00:00:00 2001
From: Steffen Jost <S.Jost@Fraport.de>
Date: Fri, 24 Mar 2023 17:32:28 +0000
Subject: [PATCH 06/11] fix(lms): mark expired learners as ended with status
 expired

---
 src/Handler/Qualification.hs     |  1 +
 src/Handler/Utils/LMS.hs         |  8 ++++++--
 src/Handler/Utils/Table/Cells.hs |  7 ++-----
 src/Jobs/Handler/LMS.hs          | 27 +++++++++++++++++++++++----
 src/Model/Types/Lms.hs           | 10 ++++++++--
 src/Utils/Icon.hs                |  2 ++
 6 files changed, 42 insertions(+), 13 deletions(-)

diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs
index e75457de9..d6308e771 100644
--- a/src/Handler/Qualification.hs
+++ b/src/Handler/Qualification.hs
@@ -380,6 +380,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
         getStatusPlusTxt = 
           (join . preview (resultLmsUser  . _entityVal . _lmsUserStatus)) >>= \case 
             Just LmsBlocked{} -> return $ Just "Failed"
+            Just LmsExpired{} -> return $ Just "Expired"
             Just LmsSuccess{} -> return $ Just "Success"
             Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $
               preview (resultLmsUser  . _entityVal . _lmsUserStarted)
diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs
index 7a9483779..05c410486 100644
--- a/src/Handler/Utils/LMS.hs
+++ b/src/Handler/Utils/LMS.hs
@@ -20,7 +20,7 @@ module Handler.Utils.LMS
   , lmsDeletionDate
   , lmsUserToDelete, _lmsUserToDelete
   , lmsUserToDeleteExpr
-  , lmsUserStatusWidget
+  , lmsStatusIcon, lmsUserStatusWidget
   , randomLMSIdent, randomLMSIdentBut
   , randomLMSpw, maxLmsUserIdentRetries
   ) where
@@ -164,12 +164,16 @@ randomLMSpw = randomText extra lengthPassword
   where
     extra = "+=!?" -- you cannot distinguish ;: and ., in printed letters
 
+lmsStatusIcon :: LmsStatus -> Icon
+lmsStatusIcon LmsSuccess{} = IconOK
+lmsStatusIcon LmsExpired{} = IconExpired
+lmsStatusIcon _other       = IconNotOK
 
 lmsUserStatusWidget :: LmsUser -> Widget
 lmsUserStatusWidget LmsUser{lmsUserStatus=Just lStat} = 
   [whamlet|$newline never
     ^{formatTimeW SelFormatDate (lmsStatusDay lStat)} 
-    \ ^{boolSymbol (isLmsSuccess lStat)} 
+    \ ^{icon (lmsStatusIcon lStat)} 
   |]
 lmsUserStatusWidget LmsUser{lmsUserStarted} = 
   [whamlet|$newline never
diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs
index b01fa44f9..374f92844 100644
--- a/src/Handler/Utils/Table/Cells.hs
+++ b/src/Handler/Utils/Table/Cells.hs
@@ -12,7 +12,7 @@ import Handler.Utils.Table.Pagination
 import Handler.Utils.DateTime
 import Handler.Utils.Widgets
 import Handler.Utils.Occurrences
-import Handler.Utils.LMS (lmsUserStatusWidget)
+import Handler.Utils.LMS (lmsUserStatusWidget, lmsStatusIcon)
 
 type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles !
 
@@ -347,10 +347,7 @@ cryptoidCell :: (IsDBTable m a, PathPiece cid) => cid -> DBCell m a
 cryptoidCell = addCellClass ("cryptoid" :: Text) . textCell . toPathPiece
 
 lmsStatusCell :: IsDBTable m a => LmsStatus -> DBCell m a
-lmsStatusCell ls = iconCell ic <> spacerCell <> dayCell (lmsStatusDay ls)
-  where 
-    ic | isLmsSuccess ls = IconOK
-       | otherwise       = IconNotOK
+lmsStatusCell ls = iconCell (lmsStatusIcon ls) <> spacerCell <> dayCell (lmsStatusDay ls)
 
 lmsStatusPlusCell :: IsDBTable m a => LmsUser -> DBCell m a
 lmsStatusPlusCell LmsUser{lmsUserStatus=Just lStat} = lmsStatusCell lStat
diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs
index cc5b17ff2..1368ba81b 100644
--- a/src/Jobs/Handler/LMS.hs
+++ b/src/Jobs/Handler/LMS.hs
@@ -77,6 +77,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
                           luser <- E.from $ E.table @LmsUser
                           E.where_ $  luser E.^. LmsUserQualification E.==. E.val qid
                                 E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
+                                E.&&. E.isNothing (luser E.^. LmsUserEnded)
                         )
             pure quser
           let usr_job :: Entity QualificationUser -> Job
@@ -131,7 +132,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
         (Just _) -> return () -- lmsUser started, but not yet notified
 
 
--- purge LmsIdent adter QualificationAuditDuration expired
+-- purge LmsIdent after QualificationAuditDuration expired
 dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX
 dispatchJobLmsDequeue qid = JobHandlerAtomic act
   where
@@ -140,19 +141,37 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
       let qshort = CI.original $ qualificationShorthand quali
       $logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort
       now <- liftIO getCurrentTime
+      let nowaday = utctDay now      
+      -- end users that expired by doing nothing
+      expiredLearners <- E.select $ do 
+          (quser :& luser) <- E.from $
+            E.table @QualificationUser 
+            `E.innerJoin` E.table @LmsUser
+            `E.on` (\(quser :& luser) ->
+                              luser E.^. LmsUserUser           E.==. quser   E.^. QualificationUserUser
+                        E.&&. luser E.^. LmsUserQualification  E.==. quser   E.^. QualificationUserQualification)
+          E.where_ $ E.isNothing (luser E.^. LmsUserStatus)
+              E.&&.  E.isNothing (luser E.^. LmsUserEnded)
+              E.&&.  E.not_ (validQualification nowaday quser)
+          pure (luser E.^. LmsUserId)      
+      nrExpired <- E.updateCount $ \luser -> do
+        E.set luser [LmsUserStatus E.=. E.justVal (LmsExpired nowaday)]
+        E.where_ $ (luser E.^. LmsUserId) `E.in_` E.valList (E.unValue <$> expiredLearners)
+      $logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort
       -- TODO: notify expired used 
-          -- let nowaday = utctDay now
-          -- forM_ (E.unValue . snd <$> delusersVals) $ \uid ->
+          -- 
+          -- forM_ expiredLearners $ \uid ->
           --   queueDBJob JobSendNotification
           --     { jRecipient    = uid
           --     , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = nowaday }
           --     }
+
       -- purge outdated LmsUsers
       case qualificationAuditDuration quali of
         Nothing -> return () -- no automatic removal
         (Just auditDuration) -> do
           let auditCutoff = addDiffDaysRollOver (fromMonths $ negate auditDuration) now
-          $logInfoS "LMS" $ "Audit Cuttoff at " <> tshow auditCutoff <> " for Audit Duration " <> tshow auditDuration
+          $logInfoS "LMS" $ "Audit Cuttoff at " <> tshow auditCutoff <> " for Audit Duration " <> tshow auditDuration <> " for qualification " <> qshort
           delusersVals <- E.select $ do
             luser <- E.from $ E.table @LmsUser
             E.where_ $  luser E.^. LmsUserQualification E.==. E.val qid
diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs
index 279173b65..3563d252c 100644
--- a/src/Model/Types/Lms.hs
+++ b/src/Model/Types/Lms.hs
@@ -34,7 +34,8 @@ deriveJSON defaultOptions
 
 -- TODO: Is this a good idea? An ordinary Enum and a separate Day column in the DB would be better, e.g. allowing use of insertSelect in Jobs.Handler.LMS?
 -- ...also see similar type QualificationBlocked
-data LmsStatus = LmsBlocked { lmsStatusDay :: Day } 
+data LmsStatus = LmsBlocked { lmsStatusDay :: Day }
+               | LmsExpired { lmsStatusDay :: Day }
                | LmsSuccess { lmsStatusDay :: Day }
   deriving (Eq, Read, Show, Generic, NFData)
 
@@ -43,7 +44,11 @@ instance Ord LmsStatus where
     | daycmp <- compare (lmsStatusDay a) (lmsStatusDay b)
     , daycmp /= EQ = daycmp    
   compare LmsSuccess{} LmsBlocked{} = GT
-  compare LmsBlocked{} LmsSuccess{} = LT 
+  compare LmsSuccess{} LmsExpired{} = GT
+  compare LmsBlocked{} LmsSuccess{} = LT
+  compare LmsExpired{} LmsSuccess{} = LT 
+  compare LmsBlocked{} LmsExpired{} = GT
+  compare LmsExpired{} LmsBlocked{} = LT 
   compare _            _            = EQ 
 
 isLmsSuccess :: LmsStatus -> Bool 
@@ -66,6 +71,7 @@ derivePersistFieldJSON ''LmsStatus
 
 instance Csv.ToField LmsStatus where
   toField (LmsBlocked d) = "Failure: " <> Csv.toField d
+  toField (LmsExpired d) = "Expired: " <> Csv.toField d
   toField (LmsSuccess d) = "Success: " <> Csv.toField d
 
 data QualificationBlocked = QualificationBlocked { qualificationBlockedDay    :: Day
diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs
index 41ae7e335..ce035510f 100644
--- a/src/Utils/Icon.hs
+++ b/src/Utils/Icon.hs
@@ -107,6 +107,7 @@ data Icon
   | IconAt
   | IconSupervisor
   | IconWaitingForUser
+  | IconExpired
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
   deriving anyclass (Universe, Finite, NFData)
 
@@ -192,6 +193,7 @@ iconText = \case
     IconAt                      -> "at"
     IconSupervisor              -> "head-side" -- must be notably different to user
     IconWaitingForUser          -> "user-cog"  -- Waiting on a user to do something
+    IconExpired                 -> "hourglass-end"
 
 nullaryPathPiece ''Icon $ camelToPathPiece' 1
 deriveLift ''Icon

From 3b0f27d4f2efd3b184e150cf7c836a9e52d95b91 Mon Sep 17 00:00:00 2001
From: Steffen Jost <S.Jost@Fraport.de>
Date: Fri, 24 Mar 2023 18:06:55 +0000
Subject: [PATCH 07/11] chore(avs): improve print of avs test interface

---
 src/Handler/Admin/Avs.hs | 23 +++++++++++++----------
 src/Model/Types/Avs.hs   |  2 +-
 src/Utils/Avs.hs         |  2 +-
 3 files changed, 15 insertions(+), 12 deletions(-)

diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs
index 1c0af28fd..5d3c66a36 100644
--- a/src/Handler/Admin/Avs.hs
+++ b/src/Handler/Admin/Avs.hs
@@ -155,8 +155,8 @@ postAdminAvsR = do
               Left  err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
               Right (AvsResponsePerson pns) -> return $ Just [whamlet|
                   <ul>
-                    $forall p <- pns 
-                      <li>#{tshow p}
+                    $forall p <- pns                       
+                      <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
                 |]
       mbPerson <- formResultMaybe presult procFormPerson
 
@@ -169,7 +169,7 @@ postAdminAvsR = do
               Right (AvsResponseStatus pns) -> return $ Just [whamlet|
                   <ul>
                     $forall p <- pns 
-                      <li>#{tshow p}
+                      <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
                 |]
       mbStatus <- formResultMaybe sresult procFormStatus
 
@@ -181,8 +181,12 @@ postAdminAvsR = do
               Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
               Right (AvsResponseContact pns) -> return $ Just [whamlet|
                   <ul>
-                    $forall p <- pns 
-                      <li>#{Pretty.encodePretty (toJSON p)}
+                    $forall AvsDataContact{..} <- pns 
+                      <li>
+                        <ul>
+                          <li>AvsId: #{tshow avsContactPersonID}
+                          <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
+                          <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactFirmInfo))}
                 |]
       mbContact <- formResultMaybe cresult procFormContact
 
@@ -443,11 +447,10 @@ getProblemAvsSynchR = do
                     Just $ QualificationBlocked 
                     { qualificationBlockedDay     = nowaday
                     , qualificationBlockedReason  = licenceTableChangeFDriveReason
-                    }
-        let lReq = length apids                        
-        if | oks < 0                 -> addMessageI Error   $ MsgRevokeFraDriveLicencesError alic
-           | oks == lreq && lreq > 0 -> addMessageI Success $ MsgRevokeFraDriveLicences      alic oks
-           | otherwise               -> addMessageI Warning $ MsgRevokeFraDriveLicences      alic oks
+                    }                     
+        if | oks < 0                      -> addMessageI Error   $ MsgRevokeFraDriveLicencesError alic
+           | oks > 0, 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
diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs
index 59cabb982..64161ee41 100644
--- a/src/Model/Types/Avs.hs
+++ b/src/Model/Types/Avs.hs
@@ -480,7 +480,7 @@ data AvsPersonInfo = AvsPersonInfo
   { avsInfoPersonNo             :: Text -- Int                  -- AVS Personennummer, zum Gebrauch in menschlicher Kommunikation
   , avsInfoFirstName            :: Text                         -- WARNING: name stored as is, but AVS does contain weird whitespaces
   , avsInfoLastName             :: Text                         -- WARNING: name stored as is, but AVS does contain weird whitespaces
-  , avsInfoRampLicence          :: AvsLicence                   -- unlike other queries, may return -1 for guest unable to hold a licence; currently not distinquished from no licence
+  , avsInfoRampLicence          :: Int  -- AvsLicence           -- unlike other queries, may return -1 for guest unable to hold a licence; currently not distinquished from no licence
   , avsInfoDateOfBirth          :: Maybe Day
   , avsInfoPersonEMail          :: Maybe Text
   , avsInfoPersonMobilePhoneNo  :: Maybe Text  
diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs
index 71e90c910..e1c3bc4f9 100644
--- a/src/Utils/Avs.hs
+++ b/src/Utils/Avs.hs
@@ -68,7 +68,7 @@ mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
 mkAvsQuery _ _ _ = AvsQuery
     { avsQueryPerson          = \_ -> return . Right $ AvsResponsePerson      mempty
     , avsQueryStatus          = \_ -> return . Right $ AvsResponseStatus      mempty
-    , avsQueryContact         = \_ -> return . Right $ AvsResponseContact     mempty
+    , avsQueryContact         = \_ -> return . Right $ AvsResponseContact     $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "AVSNO:123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing)
     , avsQuerySetLicences     = \_ -> return . Right $ AvsResponseSetLicences mempty
     , avsQueryGetAllLicences  =       return . Right $ AvsResponseGetLicences mempty
     }

From 88a85bb5b63470a0fb117a67cbf8c597c96f6904 Mon Sep 17 00:00:00 2001
From: Steffen Jost <S.Jost@Fraport.de>
Date: Mon, 27 Mar 2023 14:33:45 +0000
Subject: [PATCH 08/11] fix(email): reenable ldap logins with invalid email
 addresses (missing mail field problem)

---
 src/Foundation/Yesod/Auth.hs | 35 ++++++++++++-----------
 src/Handler/Utils/Mail.hs    | 55 ++++++++++++++++--------------------
 2 files changed, 42 insertions(+), 48 deletions(-)

diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index 70a8abfb9..aaa04294d 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -260,11 +260,11 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
       | otherwise
         -> throwM CampusUserInvalidIdent
 
-    userEmail <- if -- TODO: refactor
-      -- | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
-      --   -> return $ CI.mk userEmail
-      | userEmail : _ <- mapMaybe (assertM validEmail . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
+    userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E<number@fraport.de` here, too strong! Make Email-Field optional!
+      | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
          -> return $ CI.mk userEmail
+      -- | userEmail : _ <- mapMaybe (assertM validEmail . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) -- TOO STRONG, see above!
+      --    -> return $ CI.mk userEmail
       | otherwise
         -> throwM CampusUserInvalidEmail
         
@@ -306,19 +306,20 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
         , userPrefersPostal           = userDefaultPrefersPostal
         , ..
         }
-      userUpdate =  [
-                    -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
-                      UserFirstName               =. userFirstName
-                    , UserSurname                 =. userSurname
-                    , UserEmail                   =. userEmail
-                    , UserLastLdapSynchronisation =. Just now
-                    , UserLdapPrimaryKey          =. userLdapPrimaryKey
-                    , UserMobile                  =. userMobile
-                    , UserTelephone               =. userTelephone
-                    , UserCompanyPersonalNumber   =. userCompanyPersonalNumber
-                    , UserCompanyDepartment       =. userCompanyDepartment
-                    ] ++
-                    [ UserLastAuthentication =. Just now  | isLogin ]
+      userUpdate =  
+        [ UserLastAuthentication      =. Just now  | isLogin ] ++
+        [ UserEmail                   =. userEmail | validEmail' userEmail ] ++
+        [
+        -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
+          UserFirstName               =. userFirstName
+        , UserSurname                 =. userSurname                    
+        , UserLastLdapSynchronisation =. Just now
+        , UserLdapPrimaryKey          =. userLdapPrimaryKey
+        , UserMobile                  =. userMobile
+        , UserTelephone               =. userTelephone
+        , UserCompanyPersonalNumber   =. userCompanyPersonalNumber
+        , UserCompanyDepartment       =. userCompanyDepartment
+        ]
     return (newUser, userUpdate)
 
   where
diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs
index f90ffd604..bda5fe032 100644
--- a/src/Handler/Utils/Mail.hs
+++ b/src/Handler/Utils/Mail.hs
@@ -52,6 +52,13 @@ userAddress :: User -> Address
 userAddress User{userEmail, userDisplayEmail, userDisplayName}
   = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail
 
+userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX) => User -> m (Bool, Address)
+userAddressError User{userEmail, userDisplayEmail, userDisplayName} 
+  | Just okEmail <- pickValidEmail' userDisplayEmail userEmail = pure (True, Address (Just userDisplayName) $ CI.original okEmail)
+  | otherwise = do
+      $logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow userDisplayEmail <> " Sent to support instead." -- <> " with subject " <> tshow failedSubject
+      (True,) <$> getsYesod (view _appMailSupport)
+
 -- | Send an email to the given UserId or to all registered Supervisor with rerouteNotifications == True
 userMailT :: ( MonadHandler m
              , HandlerSite m ~ UniWorX
@@ -59,7 +66,7 @@ userMailT :: ( MonadHandler m
              , MonadUnliftIO m
              ) => UserId -> MailT m () -> m ()
 userMailT uid mAct = do
-  (underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers uid
+  (underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers uid  
   let undername = underling ^. _userDisplayName -- nameHtml' underling
       undermail = CI.original $ pickValidEmail (underling ^. _userDisplayEmail) (underling ^. _userEmail)
       infoSupervised :: Hamlet.HtmlUrlI18n UniWorXSendMessage (Route UniWorX) = [ihamlet|            
@@ -98,21 +105,17 @@ userMailT uid mAct = do
               $else
                 _{MsgMailSupervisorNoCopy}
           |]
-        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
+    (mailOk, mailtoAddr) <- userAddressError supervisor -- ensures a valid email, logs error and sends to support otherwise 
+
+    mailT ctx $ do      
+      _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
+      unless mailOk $ mapSubject ("[ERROR]" <>)
 
 -- | like userMailT, but always sends a single mail to the given UserId, ignoring supervisors
 userMailTdirect :: ( MonadHandler m
@@ -137,23 +140,13 @@ userMailTdirect uid mAct = do
           SelFormatTime -> userTimeFormat
       , mcCsvOptions = userCsvOptions
       }
-    mailtoAddr = userAddress user 
+  (mailOk, mailtoAddr) <- userAddressError user -- ensures a valid email, logs error and sends to support otherwise 
   mailT ctx $ do
-    failedSubject <- lookupMailHeader "Subject"
-    unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr <> " with subject " <> tshow failedSubject)
+    -- failedSubject <- lookupMailHeader "Subject"
+    -- unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr <> " with subject " <> tshow failedSubject)
     _mailTo .= pure mailtoAddr
-    mAct  
-{- Problematic due to return type a      
-  if validEmail $ addressEmail mailtoAddr
-    then mailT ctx $ do
-      _mailTo .= pure mailtoAddr
-      mAct
-    else 
-      -- failedSubject <- lookupMailHeader "Subject"        
-      $logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAdd -- <> " with subject " <> tshow failedSubject
--}      
-
-
+    unless mailOk $ mapSubject ("[ERROR]" <>)
+    mAct
 
 addFileDB :: ( MonadMail m
              , HandlerSite m ~ UniWorX

From d8a601b970682bbd554627832a164f163c354a62 Mon Sep 17 00:00:00 2001
From: Steffen Jost <S.Jost@Fraport.de>
Date: Mon, 27 Mar 2023 14:42:25 +0000
Subject: [PATCH 09/11] chore(lms): fix default sorting for qualifications and
 sort optional columns always with nulls last

---
 src/Handler/LMS.hs                    | 2 +-
 src/Handler/Qualification.hs          | 6 +++---
 src/Handler/Utils/Table/Pagination.hs | 6 +++++-
 3 files changed, 9 insertions(+), 5 deletions(-)

diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs
index c8cb5aaa9..f4a43fc61 100644
--- a/src/Handler/LMS.hs
+++ b/src/Handler/LMS.hs
@@ -385,7 +385,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
       , single ("valid-until"   , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil))
       , single ("last-refresh"  , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
       , single ("first-held"    , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
-      , single ("blocked-due"   , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
+      , single ("blocked-due"   , SortColumnNeverNull$ queryQualUser >>> (E.^. QualificationUserBlockedDue))
       , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))      
       , single ("lms-ident"     , SortColumnNullsInv $ queryLmsUser  >>> (E.?. LmsUserIdent))
       , single ("lms-pin"       , SortColumnNullsInv $ queryLmsUser  >>> (E.?. LmsUserPin))
diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs
index d6308e771..bdea7efb9 100644
--- a/src/Handler/Qualification.hs
+++ b/src/Handler/Qualification.hs
@@ -312,10 +312,10 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
       , single $ sortUserEmail    queryUser      
       , single ("valid-until"   , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
       , single ("last-refresh"  , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))      
-      , single ("blocked-due"   , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
+      , single ("blocked-due"   , SortColumnNeverNull $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
       -- , single ("lms-started"   , SortColumn $ queryLmsUser  >>> (E.?. LmsUserStarted))
       -- , single ("lms-status"    , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
-      , single ("lms-status-plus",SortColumn $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}"
+      , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}"
                                                                   , queryLmsUser row E.?. LmsUserStarted])
       , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))                                                                        
       , single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
@@ -463,7 +463,7 @@ postQualificationR sid qsh = do
           , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltip (MsgTableLmsStatusTooltip auditMonths))
                                                                                        $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusPlusCell' linkLmsUser) lu                                                                                       
           ]
-        psValidator = def & defaultSorting [SortDescBy "blocked-due", SortDescBy "valid-until"]
+        psValidator = def & defaultSorting [SortDescBy "last-refresh"]
     tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
     return (tbl, qent)
   
diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index 9b5a6a2e8..9f29e12f4 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@@ -163,6 +163,7 @@ data SomeExprValue = forall a. PersistField a => SomeExprValue { getSomeExprValu
   
 data SortColumn t r' = forall a. PersistField a => SortColumn           { getSortColumn :: t -> E.SqlExpr (E.Value a) }
                      | forall a. PersistField a => SortColumnNullsInv   { getSortColumn :: t -> E.SqlExpr (E.Value a) }
+                     | forall a. PersistField a => SortColumnNeverNull  { getSortColumn :: t -> E.SqlExpr (E.Value a) }
                      | SortColumns { getSortColumns :: t -> [SomeExprValue] }
                      | SortProjected { sortProjected :: r' -> r' -> Ordering }
 
@@ -182,10 +183,13 @@ sqlSortDirection (SortColumn  e ) = Just $ \case
 sqlSortDirection (SortColumnNullsInv e ) = Just $ \case
   SortAsc  -> pure . E.ascNullsFirst  . e
   SortDesc -> pure . E.descNullsLast . e
+sqlSortDirection (SortColumnNeverNull e ) = Just $ \case
+  SortAsc  -> pure . E.asc . e
+  SortDesc -> pure . E.descNullsLast . e
 sqlSortDirection (SortColumns es) = Just $ \case
   SortAsc  -> fmap (\(SomeExprValue v) -> E.asc  v) . es
   SortDesc -> fmap (\(SomeExprValue v) -> E.desc v) . es
-sqlSortDirection  _               = Nothing
+sqlSortDirection _ = Nothing
 
 sortDirectionProjected :: SortColumn t r' -> r' -> r' -> Ordering
 sortDirectionProjected SortProjected{..} = sortProjected

From f29055a91be6d089658168964644836b22a5926b Mon Sep 17 00:00:00 2001
From: Steffen Jost <S.Jost@Fraport.de>
Date: Mon, 27 Mar 2023 15:00:43 +0000
Subject: [PATCH 10/11] chore(login): remove obselete search for lmu logins

---
 src/Auth/LDAP.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs
index 18478bb34..329bb0a29 100644
--- a/src/Auth/LDAP.hs
+++ b/src/Auth/LDAP.hs
@@ -61,7 +61,7 @@ findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM
       , ldapUserPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@fraport.de|]
       ] ++
       [ ldapUserEmail'        Ldap.:= Text.encodeUtf8 ident'
-      | ident' <- [ident, [st|#{ident}@lmu.de|], [st|#{ident}@fraport.de|]]
+      | ident' <- [ident, [st|#{ident}@fraport.de|]]
       , ldapUserEmail' <- toList ldapUserEmail
       -- ] ++
       -- [ ldapUserDisplayName   Ldap.:= Text.encodeUtf8 ident  -- for Fraport, userDisplayName has the pattern "Surname, Firstnames"

From d48d922a9ce2f0ab5390439a711ac2c660b8378e Mon Sep 17 00:00:00 2001
From: Steffen Jost <S.Jost@Fraport.de>
Date: Mon, 27 Mar 2023 15:12:55 +0000
Subject: [PATCH 11/11] chore(print): change default sorting order for print
 center

---
 src/Handler/PrintCenter.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs
index 93c03c4a4..1ee47ea0b 100644
--- a/src/Handler/PrintCenter.hs
+++ b/src/Handler/PrintCenter.hs
@@ -248,7 +248,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 [SortDescBy "created"]
+    psValidator = def & defaultSorting [SortDescBy "acknowledged", SortDescBy "created"]
                       -- & defaultFilter (singletonMap "acknowledged" [toPathPiece False]) -- TODO: sorting with Nothing restores this filter
   over _1 postprocess <$> dbTable psValidator DBTable{..}