Merge branch 'fradrive/localmaster'

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)

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)

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"

src/Foundation/Yesod/Auth.hs

@@ -260,11 +260,11 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
       | otherwise
         -> throwM CampusUserInvalidIdent
 
-    userEmail <- if -- TODO: refactor
+    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)
+      | 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)
          -> 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 =  [
+      userUpdate =  
-                    -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
+        [ UserLastAuthentication      =. Just now  | isLogin ] ++
-                      UserFirstName               =. userFirstName
+        [ UserEmail                   =. userEmail | validEmail' userEmail ] ++
-                    , UserSurname                 =. userSurname
+        [
-                    , UserEmail                   =. userEmail
+        -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
-                    , UserLastLdapSynchronisation =. Just now
+          UserFirstName               =. userFirstName
-                    , UserLdapPrimaryKey          =. userLdapPrimaryKey
+        , UserSurname                 =. userSurname                    
-                    , UserMobile                  =. userMobile
+        , UserLastLdapSynchronisation =. Just now
-                    , UserTelephone               =. userTelephone
+        , UserLdapPrimaryKey          =. userLdapPrimaryKey
-                    , UserCompanyPersonalNumber   =. userCompanyPersonalNumber
+        , UserMobile                  =. userMobile
-                    , UserCompanyDepartment       =. userCompanyDepartment
+        , UserTelephone               =. userTelephone
-                    ] ++
+        , UserCompanyPersonalNumber   =. userCompanyPersonalNumber
-                    [ UserLastAuthentication =. Just now  | isLogin ]
+        , UserCompanyDepartment       =. userCompanyDepartment
+        ]
     return (newUser, userUpdate)
 
   where

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
@@ -87,7 +88,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 +103,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
@@ -136,23 +156,41 @@ postAdminAvsR = do
               Right (AvsResponsePerson pns) -> return $ Just [whamlet|
                   <ul>
                     $forall p <- pns                       
-                      <li>#{tshow p}
+                      <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
                 |]
       mbPerson <- formResultMaybe presult procFormPerson
 
       ((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}|]
               Right (AvsResponseStatus pns) -> return $ Just [whamlet|
                   <ul>
                     $forall p <- pns 
-                      <li>#{tshow p}
+                      <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
                 |]
       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 AvsDataContact{..} <- pns 
+                      <li>
+                        <ul>
+                          <li>AvsId: #{tshow avsContactPersonID}
+                          <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
+                          <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactFirmInfo))}
+                |]
+      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 +297,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
+            personForm  = wrapFormHere pwidget  penctype
-            statusForm = wrapFormHere swidget  senctype
+            statusForm  = wrapFormHere swidget  senctype
-            crUsrForm  = wrapFormHere crUsrWgt crUsrEnctype
+            contactForm = wrapFormHere cwidget  cenctype
-            getLicForm = wrapFormHere getLicWgt getLicEnctype
+            crUsrForm   = wrapFormHere crUsrWgt crUsrEnctype
-            setLicForm = wrapFormHere setLicWgt setLicEnctype
+            getLicForm  = wrapFormHere getLicWgt getLicEnctype
+            setLicForm  = wrapFormHere setLicWgt setLicEnctype
         -- TODO: use i18nWidgetFile instead if this is to become permanent
         $(widgetFile "avs")
 
@@ -393,7 +432,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
 
@@ -409,9 +448,9 @@ getProblemAvsSynchR = do
                     { qualificationBlockedDay     = nowaday
                     , qualificationBlockedReason  = licenceTableChangeFDriveReason
                     }                     
-        if | oks < 0              -> addMessageI Error   $ MsgRevokeFraDriveLicencesError alic
+        if | oks < 0                      -> addMessageI Error   $ MsgRevokeFraDriveLicencesError alic
-           | oks == length apids  -> addMessageI Success $ MsgRevokeFraDriveLicences      alic oks
+           | oks > 0, oks == length apids -> addMessageI Success $ MsgRevokeFraDriveLicences      alic oks
-           | otherwise            -> addMessageI Warning $ MsgRevokeFraDriveLicences      alic oks
+           | otherwise                    -> addMessageI Warning $ MsgRevokeFraDriveLicences      alic oks
         redirect ProblemAvsSynchR -- must be outside runDB 
 
       procRes _alic (LicenceTableGrantFDriveData{..}, apids ) = do
@@ -420,7 +459,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

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

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

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

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
@@ -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)
@@ -462,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)
   

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]

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

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

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
@@ -98,21 +105,17 @@ userMailT uid mAct = do
               $else
                 _{MsgMailSupervisorNoCopy}
           |]
-        mailtoAddr = userAddress supervisor
+    (mailOk, mailtoAddr) <- userAddressError supervisor -- ensures a valid email, logs error and sends to support otherwise 
-    if validEmail $ addressEmail mailtoAddr
+
-      then 
+    mailT ctx $ do      
-        mailT ctx $ do
+      _mailTo .= pure mailtoAddr 
-          -- TODO: ensure that the Email is VALID HERE!
+      mAct
-          _mailTo .= pure mailtoAddr 
+      if uid==svr
-          mAct
+        then when (length receivers > 1) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors
-          if uid==svr
+        else do
-            then when (length receivers > 1) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors
+          mapSubject ("[SUPERVISOR] " <>)
-            else do
+          addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email
-              mapSubject ("[SUPERVISOR] " <>)
+      unless mailOk $ mapSubject ("[ERROR]" <>)
-              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
@@ -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"
+    -- failedSubject <- lookupMailHeader "Subject"
-    unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr <> " with subject " <> tshow failedSubject)
+    -- unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr <> " with subject " <> tshow failedSubject)
     _mailTo .= pure mailtoAddr
+    unless mailOk $ mapSubject ("[ERROR]" <>)
     mAct
-{- Problematic due to return type a      
-  if validEmail $ addressEmail mailtoAddr
-    then mailT ctx $ do
-      _mailTo .= pure mailtoAddr
-      mAct
-    else 
-      -- failedSubject <- lookupMailHeader "Subject"        
-      $logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAdd -- <> " with subject " <> tshow failedSubject
--}      
-
-
 
 addFileDB :: ( MonadMail m
              , HandlerSite m ~ UniWorX

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)
+lmsStatusCell ls = iconCell (lmsStatusIcon ls) <> spacerCell <> dayCell (lmsStatusDay ls)
-  where 
-    ic | isLmsSuccess ls = IconOK
-       | otherwise       = IconNotOK
 
 lmsStatusPlusCell :: IsDBTable m a => LmsUser -> DBCell m a
 lmsStatusPlusCell LmsUser{lmsUserStatus=Just lStat} = lmsStatusCell lStat

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

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
+      return . forM_ (Map.toList deadWorkers) $ \(jobAsync, _result) -> do
-        case result of
+        -- TOO MUCH LOGGING
-          Right () -> $logInfoS "JobPoolManager" [st|Job-Executor #{showWorkerId (jobWorkerName oldState jobAsync)} terminated|]
+        -- case result of
-          Left e   -> $logErrorS "JobPoolManager" [st|Job-Executer #{showWorkerId (jobWorkerName oldState jobAsync)} crashed: #{tshow e}|]
+        --   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

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

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          :: 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  
+  , 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

src/Model/Types/Lms.hs

@@ -35,6 +35,7 @@ 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 }
+               | 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 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

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 AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus :<|> AVSPersonContact :<|> AVSGetRampLicences :<|> AVSSetRampLicences)
-type AVSPersonSearch    = "PersonSearch" :> ReqBody '[JSON] AvsQueryPerson :> Post '[JSON] AvsResponsePerson
+type AVSPersonSearch    = "PersonSearch"            :> ReqBody '[JSON] AvsQueryPerson       :> Post '[JSON] AvsResponsePerson
-type AVSPersonStatus    = "PersonStatus" :> ReqBody '[JSON] AvsQueryStatus :> Post '[JSON] AvsResponseStatus
+type AVSPersonStatus    = "PersonStatus"            :> ReqBody '[JSON] AvsQueryStatus       :> Post '[JSON] AvsResponseStatus
-type AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryGetLicences :> Post '[JSON] AvsResponseGetLicences
+type AVSPersonContact   = "InfoPersonContact"       :> ReqBody '[JSON] AvsQueryContact      :> Post '[JSON] AvsResponseContact
-type AVSSetRampLicences = "RampDrivingLicence"     :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences
+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     $ 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
     }
@@ -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!

src/Utils/Form.hs

@@ -301,6 +301,7 @@ data FormIdentifier
   | FIDLmsLetter
   | FIDAvsQueryPerson
   | FIDAvsQueryStatus
+  | FIDAvsQueryContact
   | FIDAvsCreateUser
   | FIDAvsQueryLicenceDiffs
   | FIDAvsQueryLicence

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

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