Merge branch 'master' into fradrive/api-avs

CHANGELOG.md

@@ -2,6 +2,13 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
+## [26.6.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.6.2...v26.6.3) (2022-11-30)
+
+
+### Bug Fixes
+
+* **avs:** normalize internal personal numbers between LDAP and AVS ([b20008d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b20008d3bcb730ff76a76ce2928364e6ce9e7c35))
+
 ## [26.6.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.6.1...v26.6.2) (2022-11-29)
 
 ## [26.6.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.6.0...v26.6.1) (2022-11-28)

messages/uniworx/categories/settings/personal_settings/de-de-formal.msg

@@ -27,7 +27,11 @@ ProfileCorrectorRemark: Die oberhalb angezeigte Tabelle zeigt nur prinzipielle E
 ProfileCorrections: Auflistung aller zugewiesenen Korrekturen
 Remarks: Hinweise
 
+ProfileSupervisor: Übergeordnete Ansprechpartner
+ProfileSupervisee: Ist Ansprechpartner für
+
 UserTelephone: Telefon
 UserMobile: Mobiltelefon
+Company: Firmenzugehörigkeit
 CompanyPersonalNumber: Personalnummer (nur Fraport AG)
 CompanyDepartment: Abteilung

messages/uniworx/categories/settings/personal_settings/en-eu.msg

@@ -27,7 +27,11 @@ ProfileCorrectorRemark: The table above only shows registration as a corrector i
 ProfileCorrections: List of all assigned corrections
 Remarks: Remarks
 
+ProfileSupervisor: Supervised by
+ProfileSupervisee: Supervises
+
 UserTelephone: Phone
 UserMobile: Mobile
+Company: Company affilitaion
 CompanyPersonalNumber: Personnel number (Fraport AG only)
 CompanyDepartment: Department

nix/docker/demo-version.json

@@ -1,3 +1,3 @@
 {
-  "version": "26.6.2"
+  "version": "26.6.3"
 }

nix/docker/version.json

@@ -1,3 +1,3 @@
 {
-  "version": "26.6.2"
+  "version": "26.6.3"
 }

package-lock.json

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

package.json

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

package.yaml

@@ -1,5 +1,5 @@
 name: uniworx
-version: 26.6.2
+version: 26.6.3
 dependencies:
   - base
   - yesod

src/Handler/Admin/Avs.hs

@@ -4,7 +4,7 @@
 
 module Handler.Admin.Avs
   ( getAdminAvsR
-  , postAdminAvsR  
+  , postAdminAvsR
   ) where
 
 import Import
@@ -28,24 +28,29 @@ nullaryPathPiece ''ButtonAvsTest camelToPathPiece
 
 instance Button UniWorX ButtonAvsTest where
   btnLabel    BtnCheckLicences = "Check all licences" -- could be msg
-  btnClasses  BtnCheckLicences = [BCIsButton, BCPrimary]  
+  btnClasses  BtnCheckLicences = [BCIsButton, BCPrimary]
 -- END Button
 
 
 avsCardNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m AvsCardNo
 avsCardNoField = convertField AvsCardNo avsCardNo textField
 
+avsInternalPersonalNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m AvsInternalPersonalNo
+avsInternalPersonalNoField = convertField (canonical . AvsInternalPersonalNo) avsInternalPersonalNo textField
+
 makeAvsPersonForm :: Maybe AvsQueryPerson -> Form AvsQueryPerson
-makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html -> 
+makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html ->
-  flip (renderAForm FormStandard) html $ AvsQueryPerson 
+  flip (renderAForm FormStandard) html $ AvsQueryPerson
     <$> aopt avsCardNoField (fslI MsgAvsCardNo)             (avsPersonQueryCardNo              <$> tmpl)
+    <*> aopt textField      (fslI MsgAvsVersionNo)          (avsPersonQueryVersionNo           <$> tmpl)
     <*> aopt textField      (fslI MsgAvsFirstName)          (avsPersonQueryFirstName           <$> tmpl)
     <*> aopt textField      (fslI MsgAvsLastName)           (avsPersonQueryLastName            <$> tmpl)
-    <*> aopt textField      (fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo  <$> tmpl)
+    <*> aopt avsInternalPersonalNoField 
-    <*> aopt textField      (fslI MsgAvsVersionNo)          (avsPersonQueryVersionNo           <$> tmpl)
+                            (fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo  <$> tmpl)
+    
 
 validateAvsQueryPerson :: FormValidator AvsQueryPerson Handler ()
-validateAvsQueryPerson = do 
+validateAvsQueryPerson = do
   AvsQueryPerson{..} <- State.get
   guardValidation MsgAvsQueryEmpty $
     is _Just avsPersonQueryCardNo             ||
@@ -55,31 +60,31 @@ validateAvsQueryPerson = do
     is _Just avsPersonQueryVersionNo
 
 makeAvsStatusForm :: Maybe AvsQueryStatus -> Form AvsQueryStatus
-makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateAvsQueryStatus $ \html -> 
+makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateAvsQueryStatus $ \html ->
   flip (renderAForm FormStandard) html $
      parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl)
   where
     parseAvsIds :: Text -> AvsQueryStatus
     parseAvsIds txt = AvsQueryStatus $ Set.fromList ids
-      where         
+      where
-        nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt 
+        nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt
         ids = catMaybes $ readMay <$> nonemptys
-    unparseAvsIds :: AvsQueryStatus -> Text 
+    unparseAvsIds :: AvsQueryStatus -> Text
-    unparseAvsIds (AvsQueryStatus ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids 
+    unparseAvsIds (AvsQueryStatus ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids
 
 validateAvsQueryStatus :: FormValidator AvsQueryStatus Handler ()
-validateAvsQueryStatus = do 
+validateAvsQueryStatus = do
   AvsQueryStatus ids <- State.get
   guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)
 
 
 avsLicenceOptions :: OptionList AvsLicence
-avsLicenceOptions = mkOptionList 
+avsLicenceOptions = mkOptionList
-  [ Option 
+  [ Option
     { optionDisplay       = Text.singleton $ licence2char l
     , optionInternalValue = l
     , optionExternalValue = toJsonText l
-    }  
+    }
   | l <- universeF
   ]
 
@@ -92,27 +97,30 @@ postAdminAvsR = do
     Just AvsQuery{..} -> do
       ((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
 
-      let procFormPerson fr = do 
+      let procFormPerson fr = do
+            addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
             res <- avsQueryPerson fr
-            case res of 
+            case res of
-              Left err -> return . Just $ tshow err
+              Left  err -> return . Just $ tshow err
               Right jsn -> return . Just $ tshow jsn
       mbPerson <- formResultMaybe presult procFormPerson
 
       ((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
-      let procFormStatus fr = do 
+      let procFormStatus fr = do
+            addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
             res <- avsQueryStatus fr
-            case res of 
+            case res of
-              Left err -> return . Just $ tshow err 
+              Left err -> return . Just $ tshow err
-              Right jsn -> return . Just $ tshow jsn         
+              Right jsn -> return . Just $ tshow jsn
       mbStatus <- formResultMaybe sresult procFormStatus
 
-      ((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html -> 
+      ((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
         flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing
-      let procFormCrUsr fr = do 
+      let procFormCrUsr fr = do
+            -- addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
             res <- try $ upsertAvsUser fr
-            case res of 
+            case res of
-              (Right (Just uid)) -> do 
+              (Right (Just uid)) -> do
                 uuid :: CryptoUUIDUser <- encrypt uid
                 return $ Just [whamlet|<h2>Success:</h2> <a href=@{ForProfileR uuid}>User created or updated.|]
               (Right Nothing) ->
@@ -122,27 +130,46 @@ postAdminAvsR = do
                 return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
       mbCrUser <- formResultMaybe crUsrRes procFormCrUsr
 
-      ((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html -> 
+      ((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html ->
-        flip (renderAForm FormStandard) html $ areq intField (fslI MsgAvsPersonId) Nothing
+        flip (renderAForm FormStandard) html $ (,,) <$> aopt intField (fslI $ text2message "Min AvsPersonId") Nothing
-      let procFormGetLic fr = do 
+                                                    <*> aopt intField (fslI $ text2message "Max AvsPersonId") Nothing         
-            res <- try $ getLicenceByAvsId $ AvsPersonId fr
+                                                    <*> aopt (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) Nothing
-            case res of 
+      let procFormGetLic fr = do
-              (Right (Just lic)) -> 
+            res <- avsQueryGetAllLicences
-                return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow lic}|]
+            case res of
-              (Right Nothing) ->
+              (Right (AvsResponseGetLicences lics)) -> do                 
-                return $ Just [whamlet|<h2>Warning:</h2> User not found.|]
+                let flics = Set.toList $ Set.filter lfltr lics
-              (Left e) -> do
+                    lfltr = case fr of -- not pretty, but it'll do
-                let msg = tshow (e :: SomeException)
+                      (Just idmin, Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID `inBetween` (AvsPersonId idmin, AvsPersonId idmax))
+                      (Just idmin, Nothing,    Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmin) 
+                      (Nothing   , Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmax) 
+                      (Nothing   , Nothing,    Just lic) -> \AvsPersonLicence{..} ->  avsLicenceRampLicence == lic
+                      (Just idmin, Just idmax, Nothing ) -> (`inBetween` (AvsPersonId idmin, AvsPersonId idmax)) . avsLicencePersonID
+                      (Just idmin, Nothing,    Nothing ) -> (== AvsPersonId idmin) . avsLicencePersonID
+                      (Nothing   , Just idmax, Nothing ) -> (== AvsPersonId idmax) . avsLicencePersonID
+                      (Nothing   , Nothing,    Nothing ) -> const True
+                addMessage Info $ text2Html $ "Query returned " <> tshow (length flics) <> " licences."
+                return $ Just [whamlet|
+                    <h2>Success:</h2> 
+                    <ul>
+                      $forall AvsPersonLicence{..} <- flics
+                        <li> #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
+                  |]
+              
+              (Left err) -> do
+                let msg = tshow err
                 return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
       mbGetLic <- formResultMaybe getLicRes procFormGetLic
 
-      ((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html -> 
+      ((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html ->
-        flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing 
+        flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing
                                                    <*> areq (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) (Just AvsLicenceVorfeld)
-      let procFormSetLic (aid, lic) = do 
+      let procFormSetLic (aid, lic) = do
-            res <- try $ setLicenceAvs (AvsPersonId aid) lic
+            let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = AvsPersonId aid }
-            case res of 
+            addMessage Info $ text2Html $ "See log for detailed errors. Query: " <> tshow (toJSON $ AvsQuerySetLicences req)
-              (Right True) -> 
+            res <- try $ setLicencesAvs req
+            case res of
+              (Right True) ->
                 return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow (licence2char lic)} set for #{tshow aid}.|]
               (Right False) ->
                 return $ Just [whamlet|<h2>Error:</h2> Licence could not be set for #{tshow aid}.|]
@@ -153,10 +180,10 @@ postAdminAvsR = do
 
 
       ((qryLicRes, qryLicWgt), qryLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicenceDiffs (buttonForm :: Form ButtonAvsTest)
-      let procFormQryLic BtnCheckLicences = do 
+      let procFormQryLic BtnCheckLicences = do
             res <- try checkLicences
-            case res of 
+            case res of
-              (Right True) -> 
+              (Right True) ->
                 return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
               (Right False) ->
                 return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
@@ -176,4 +203,4 @@ postAdminAvsR = do
             setLicForm = wrapFormHere setLicWgt setLicEnctype
             qryLicForm = wrapForm     qryLicWgt def { formAction = Just $ SomeRoute actionUrl, formEncoding = qryLicEnctype, formSubmit = FormNoSubmit }
         -- TODO: use i18nWidgetFile instead if this is to become permanent
-        $(widgetFile "avs")  
+        $(widgetFile "avs")

src/Handler/Profile.hs

@@ -664,6 +664,27 @@ makeProfileData (Entity uid User{..}) = do
       E.on $ studyfeat E.^. StudyFeaturesField    E.==. studyterms  E.^. StudyTermsId
       E.on $ studyfeat E.^. StudyFeaturesDegree   E.==. studydegree E.^. StudyDegreeId
       return  (studyfeat, studydegree, studyterms)
+  companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
+      E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
+      E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
+      return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
+  let companies = intersperse (text2markup ", ") $ 
+        (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
+      icnSuper = text2markup " " <> icon IconSupervisor
+  supervisors' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
+      E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
+      E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
+      return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
+  let supervisors = intersperse (text2widget ", ") $ 
+        (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
+      icnReroute = text2widget " " <> toWgt (icon IconLetter)
+  supervisees' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
+      E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid
+      E.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId
+      return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
+  let supervisees = intersperse (text2widget ", ") $ 
+        (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisees'
+      -- icnReroute = text2widget " " <> toWgt (icon IconLetter)
   --Tables
   (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
   enrolledCoursesTable <- mkEnrolledCoursesTable      uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum

src/Handler/Users/Add.hs

@@ -36,9 +36,9 @@ data AdminUserForm = AdminUserForm
   }
 
 data AuthenticationKind = AuthKindLDAP | AuthKindPWHash | AuthKindNoLogin
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable, Universe, Finite)
-instance Universe AuthenticationKind
+--instance Universe AuthenticationKind
-instance Finite AuthenticationKind
+--instance Finite AuthenticationKind
 embedRenderMessage ''UniWorX ''AuthenticationKind id
 nullaryPathPiece ''AuthenticationKind $ camelToPathPiece' 2
 

src/Handler/Utils/Avs.hs

@@ -7,7 +7,7 @@
 
 module Handler.Utils.Avs
   ( upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
-  , getLicence, getLicenceDB, getLicenceByAvsId
+  -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
   , setLicence, setLicenceAvs, setLicencesAvs
   , checkLicences
   , lookupAvsUser, lookupAvsUsers
@@ -67,6 +67,7 @@ instance Exception AvsException
 
 -}
 
+{- AVS interface only allows collecting all licences at once, thus getLicence should be avoided, see getLicenceByAvsId including a workaround 
 -- Do we need this?
 -- getLicence :: UserId -> Handler (Maybe AvsLicence) -- with runDB
 getLicence :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, WithRunDB SqlReadBackend (HandlerFor UniWorX) m ) => UserId -> m (Maybe AvsLicence)
@@ -85,14 +86,15 @@ getLicenceDB uid = do
   let ulicence = Set.lookupMax $ Set.filter ((userAvsPersonId ==) . avsLicencePersonID) licences
   return (avsLicenceRampLicence <$> ulicence)
 
-getLicenceByAvsId :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) =>
-                      AvsPersonId -> m (Maybe AvsLicence)
-getLicenceByAvsId aid = do
-  AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ liftHandler $ getsYesod $ view _appAvsQuery
-  AvsResponseGetLicences licences <- throwLeftM $ avsQueryGetLicences $ AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId aid
-  let ulicence = Set.lookupMax $ Set.filter ((aid ==) . avsLicencePersonID) licences
-  return (avsLicenceRampLicence <$> ulicence)
 
+-- | Should be avoided, since all licences must be requested at once.
+getLicenceByAvsId :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) =>
+                      Set AvsPersonId -> m (Set AvsPersonLicence)
+getLicenceByAvsId aids = do
+  AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ liftHandler $ getsYesod $ view _appAvsQuery
+  AvsResponseGetLicences licences <- throwLeftM avsQueryGetAllLicences
+  return $ Set.filter (\x -> avsLicencePersonID x `Set.member` aids) licences
+-}
 
 -- setLicence :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => UserId -> AvsLicence -> m Bool
 setLicence :: (PersistUniqueRead backend, MonadThrow m,
@@ -256,8 +258,8 @@ upsertAvsUserById api = do
     mbuid <- getBy (UniqueUserAvsId api)
     case (mbuid, mbapd) of
       (Nothing, Just AvsDataPerson{..})                         -- FRADriver User does not exist yet, but found in AVS and has Internal Personal Number
-        | Just persNo <- avsPersonInternalPersonalNo -> do
+        | Just (avsInternalPersonalNo -> persNo) <- canonical avsPersonInternalPersonalNo -> do
-            candidates <- selectKeysList [UserCompanyPersonalNumber ==. avsPersonInternalPersonalNo] []
+            candidates <- selectKeysList [UserCompanyPersonalNumber ==. Just persNo] []
             case candidates of
               [uid] -> insertUniqueEntity $ UserAvs api uid
               (_:_) -> throwM AvsUserAmbiguous
@@ -288,7 +290,7 @@ upsertAvsUserById api = do
             , aufSex = Nothing
             , aufMobile = Nothing
             , aufTelephone = Nothing
-            , aufFPersonalNumber = avsPersonInternalPersonalNo
+            , aufFPersonalNumber = avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo
             , aufFDepartment = Nothing
             , aufPostAddress = userFirmAddr
             , aufPrefersPostal = isJust firmAddress

src/Handler/Utils/Widgets.hs

@@ -59,6 +59,11 @@ nameWidget displayName surname = toWidget $ nameHtml displayName surname
 userWidget :: HasUser c => c -> Widget
 userWidget x = nameWidget (x ^. _userDisplayName) (x ^._userSurname)
 
+linkUserWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> Entity User -> Widget
+linkUserWidget lnk (Entity uid usr) = do 
+  uuid <- encrypt uid
+  simpleLink (userWidget usr) (lnk uuid)
+
 -- | toWidget-Version of @nameEmailHtml@, for convenience
 nameEmailWidget :: UserEmail -- ^ userEmail
                 -> Text    -- ^ userDisplayName

src/Model/Types/Avs.hs

@@ -81,7 +81,53 @@ instance FromJSON SloppyBool where
 -- AVS Datatypes --
 -------------------
 
-type AvsInternalPersonalNo = Text -- ought to be all digits, type synonym for clarity/documentation within types
+newtype AvsInternalPersonalNo = AvsInternalPersonalNo { avsInternalPersonalNo :: Text }  -- ought to be all digits
+  deriving (Eq, Ord, Show, Generic, Typeable)
+  deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField) 
+instance E.SqlString AvsInternalPersonalNo
+-- AvsInternalPersonalNo is an untagged Text with respect to FromJSON/ToJSON, as needed by AVS API
+normalizeAvsInternalPersonalNo :: Text -> Text
+normalizeAvsInternalPersonalNo = Text.dropWhile (\c -> '0' == c || Char.isSpace c)
+instance Canonical AvsInternalPersonalNo where 
+  canonical (AvsInternalPersonalNo ipn) = AvsInternalPersonalNo $ Text.dropWhile (\c -> '0' == c || Char.isSpace c) ipn
+instance FromJSON AvsInternalPersonalNo where
+  parseJSON x = AvsInternalPersonalNo . normalizeAvsInternalPersonalNo <$> parseJSON x
+instance ToJSON AvsInternalPersonalNo where
+  toJSON (AvsInternalPersonalNo ipn) = toJSON $ normalizeAvsInternalPersonalNo ipn
+
+type instance Element AvsInternalPersonalNo = Char 
+instance MonoFoldable AvsInternalPersonalNo where
+  ofoldMap f = ofoldr (mappend . f) mempty . avsInternalPersonalNo
+  ofoldr x y = Text.foldr x y . avsInternalPersonalNo 
+  ofoldl' x y = Text.foldl' x y . avsInternalPersonalNo 
+  otoList = Text.unpack . avsInternalPersonalNo
+  oall x = Text.all x . avsInternalPersonalNo   
+  oany x = Text.any x . avsInternalPersonalNo 
+  onull = Text.null . avsInternalPersonalNo
+  olength = Text.length . avsInternalPersonalNo
+  ofoldr1Ex  x = Text.foldr1  x . avsInternalPersonalNo
+  ofoldl1Ex' x = Text.foldl1' x . avsInternalPersonalNo
+  headEx = Text.head . avsInternalPersonalNo
+  lastEx = Text.last . avsInternalPersonalNo
+  {-# INLINE ofoldMap #-}
+  {-# INLINE ofoldr #-}
+  {-# INLINE ofoldl' #-}
+  {-# INLINE otoList #-}
+  {-# INLINE oall #-}
+  {-# INLINE oany #-}
+  {-# INLINE onull #-}
+  {-# INLINE olength #-}
+  {-# INLINE ofoldr1Ex #-}
+  {-# INLINE ofoldl1Ex' #-}
+  {-# INLINE headEx #-}
+  {-# INLINE lastEx #-}
+
+{-
+instance {-# OVERLAPS #-} Canonical (Maybe AvsInternalPersonalNo) where 
+  canonical (Just aipn) | ipn@(AvsInternalPersonalNo pn) <- canonical aipn, not (null pn) = Just ipn 
+  canonical _ = Nothing
+-}
+
 
 -- CompleteCardNo = xxxxxxxx.y 
 -- where x is an 8 digit AvsCardNo prefixed by zeros, see normalizeAvsCardNo
@@ -117,7 +163,7 @@ readAvsFullCardNo _ = Nothing
 discernAvsCardPersonalNo :: Text -> Maybe (Either AvsFullCardNo AvsInternalPersonalNo) -- Just implies it is a whole number or decimal with one digit after the point
 discernAvsCardPersonalNo (Text.span Char.isDigit -> (c, pv))
   | Text.null pv 
-    = Just $ Right c
+    = Just $ Right $ AvsInternalPersonalNo c
   | not $ Text.null c
   , Just ('.', v) <- Text.uncons pv
   , Just (Char.isDigit -> True, "") <- Text.uncons v
@@ -470,7 +516,7 @@ newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId)
   deriving (Eq, Ord, Show, Generic, Typeable)
 deriveJSON defaultOptions ''AvsQueryStatus
 
-newtype AvsQueryGetLicences = AvsQueryGetLicences (Set AvsObjPersonId)
+newtype AvsQueryGetLicences = AvsQueryGetLicences AvsObjPersonId -- this should have been a set, but the specification was implemented differently
   deriving (Eq, Ord, Show, Generic, Typeable)
 deriveJSON defaultOptions ''AvsQueryGetLicences
 

src/Utils.hs

@@ -363,6 +363,9 @@ toWgt :: ToMarkup a
 toWgt = toWidget . toHtml
 
 -- Convenience Functions to avoid type signatures:
+text2markup :: Text -> Markup
+text2markup t = [shamlet|#{t}|]
+
 text2widget :: Text -> WidgetFor site ()
 text2widget t = [whamlet|#{t}|]
 
@@ -1876,14 +1879,18 @@ makePrisms ''ExitCase
 class Canonical a where 
   canonical :: a -> a
 
-instance MonoFoldable mono => Canonical (Maybe mono) where
+
+instance {-# OVERLAPPABLE #-} MonoFoldable mono => Canonical (Maybe mono) where
   canonical (Just t) | null t = Nothing
   canonical other = other
 
--- instance (Canonical mono, MonoFoldable mono) => Canonical (Maybe mono) where
+{-
---   canonical (Just t) | null t = Nothing
+instance {-# OVERLAPPABLE #-} (Canonical mono, MonoFoldable mono, Eq mono) => Canonical (Maybe mono) where
---   canonical (Just t) = Just $ canonical t
+  canonical r@(Just t) = let c = canonical t 
---   canonical other = other
+                         in if null c then Nothing else 
+                              if t==c then r else Just c
+  canonical other = other
+-}
 
 -- this instance is more of a convenient abuse of the class (expand to Foldable)
 instance (Ord a, Canonical a) => Canonical (Set a) where

src/Utils/Avs.hs

@@ -45,15 +45,15 @@ data AvsQuery = AvsQuery
   { avsQueryPerson         :: forall m. MonadIO m => AvsQueryPerson      -> m (Either ClientError AvsResponsePerson)
   , avsQueryStatus         :: forall m. MonadIO m => AvsQueryStatus      -> m (Either ClientError AvsResponseStatus)
   , avsQuerySetLicences    :: forall m. MonadIO m => AvsQuerySetLicences -> m (Either ClientError AvsResponseSetLicences)
-  , avsQueryGetLicences    :: forall m. MonadIO m => AvsQueryGetLicences -> m (Either ClientError AvsResponseGetLicences)
+  -- , avsQueryGetLicences    :: forall m. MonadIO m => AvsQueryGetLicences -> m (Either ClientError AvsResponseGetLicences) -- not supported by VSM
   , avsQueryGetAllLicences :: forall m. MonadIO m =>                        m (Either ClientError AvsResponseGetLicences)
   }
 
 makeLenses_ ''AvsQuery
 
--- | To query all active licences, a special argument must be prepared
+-- | To query all active licences, a special constant argument must be prepared
 avsQueryAllLicences :: AvsQueryGetLicences
-avsQueryAllLicences = AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId $ AvsPersonId 0
+avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId $ AvsPersonId 0
 
 
 mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
@@ -61,7 +61,7 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
     { avsQueryPerson      = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson      q)  cliEnv
     , avsQueryStatus      = \q -> liftIO $                     runClientM (rawQueryStatus      q)  cliEnv
     , avsQuerySetLicences = \q -> liftIO $                     runClientM (rawQuerySetLicences q)  cliEnv
-    , avsQueryGetLicences = \q -> liftIO $                     runClientM (rawQueryGetLicences q)  cliEnv
+    -- , avsQueryGetLicences = \q -> liftIO $                     runClientM (rawQueryGetLicences q)  cliEnv
     , avsQueryGetAllLicences =    liftIO $                     runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv
     }
   where
@@ -157,7 +157,7 @@ mergeAvsDataPerson = Map.unionWithKey merger
       in AvsDataPerson
         { avsPersonFirstName          = pickBy' Text.length avsPersonFirstName
         , avsPersonLastName           = pickBy' Text.length avsPersonLastName
-        , avsPersonInternalPersonalNo = pickBy' (Text.length . fromMaybe mempty) avsPersonInternalPersonalNo
+        , avsPersonInternalPersonalNo = pickBy' (maybe 0 length) avsPersonInternalPersonalNo
         , avsPersonPersonNo           = pickBy' id avsPersonPersonNo
         , avsPersonPersonID           = api -- keys must be identical due to call with insertWithKey
         , avsPersonPersonCards        = (Set.union `on` avsPersonPersonCards) pa pb

src/Utils/Icon.hs

@@ -112,6 +112,7 @@ data Icon
   | IconPrintCenter
   | IconLetter
   | IconAt
+  | IconSupervisor
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
   deriving anyclass (Universe, Finite, NFData)
 
@@ -203,6 +204,7 @@ iconText = \case
     IconPrintCenter             -> "mail-bulk" -- From fontawesome v6 onwards: "envelope-bulk"
     IconLetter                  -> "mail-bulk" -- Problem "envelope" already used for email as well
     IconAt                      -> "at"
+    IconSupervisor              -> "head-side" -- must be notably different to user
 
 nullaryPathPiece ''Icon $ camelToPathPiece' 1
 deriveLift ''Icon

templates/profileData.hamlet

@@ -68,6 +68,19 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
           _{MsgCompanyPersonalNumber}
         <dd .deflist__dd>
           #{companyPersonalNumber}          
+      $if not $ null companies
+        <dt .deflist__dt>
+          _{MsgCompany}
+        <dd .deflist__dd>
+          ^{toWgt (mconcat companies)}     
+      $if not $ null supervisors
+        <dt .deflist__dt>_{MsgProfileSupervisor}
+        <dd .deflist__dd>
+          ^{mconcat supervisors}
+      $if not $ null supervisees
+        <dt .deflist__dt>_{MsgProfileSupervisee}
+        <dd .deflist__dd>
+          ^{mconcat supervisees}
       $if showAdminInfo
         <dt .deflist__dt>
           _{MsgUserCreated}

test/Database/Fill.hs

@@ -478,11 +478,22 @@ fillDb = do
             I am aware that violations in the form plagiarism or collaboration with third parties will lead to expulsion from the course.
         |]
     }
-  _fraportAg <- insert' $ Company "Fraport AG"                                          "Fraport"
+  fraportAg  <- insert' $ Company "Fraport AG"                                          "Fraport"
   _fraGround <- insert' $ Company "Fraport Ground Handling Professionals GmbH"          "FraGround"
-  _nice      <- insert' $ Company "N*ICE Aircraft Services & Support GmbH"              "N*ICE"
+  nice       <- insert' $ Company "N*ICE Aircraft Services & Support GmbH"              "N*ICE"
   _ffacil    <- insert' $ Company "Fraport Facility Services GmbH"                      "GCS"
-  _bpol      <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main"  "BPol"
+  bpol       <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main"  "BPol"
+  void . insert' $ UserCompany jost    fraportAg    True
+  void . insert' $ UserCompany svaupel nice         True
+  void . insert' $ UserCompany gkleen  nice         False
+  void . insert' $ UserCompany fhamann bpol         False
+  void . insert' $ UserSupervisor jost gkleen       True
+  void . insert' $ UserSupervisor jost svaupel      False
+  void . insert' $ UserSupervisor jost sbarth       False
+  void . insert' $ UserSupervisor jost tinaTester   True
+  void . insert' $ UserSupervisor svaupel gkleen    False
+  void . insert' $ UserSupervisor svaupel fhamann   True
+  void . insert' $ UserSupervisor sbarth tinaTester True
   ifi <- insert' $ School "Institut für Informatik" "IfI" (Just $ 14 * nominalDay) (Just $ 10 * nominalDay) True (ExamModeDNF predDNFFalse) (ExamCloseOnFinished True) SchoolAuthorshipStatementModeOptional (Just ifiAuthorshipStatement) True SchoolAuthorshipStatementModeRequired (Just ifiAuthorshipStatement) False
   mi  <- insert' $ School "Institut für Mathematik" "MI" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) SchoolAuthorshipStatementModeNone Nothing True SchoolAuthorshipStatementModeOptional Nothing True
   avn <- insert' $ School "Fahrerausbildung" "FA" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) SchoolAuthorshipStatementModeNone Nothing True SchoolAuthorshipStatementModeOptional Nothing True

test/Utils/TypesSpec.hs

@@ -14,6 +14,10 @@ instance Arbitrary SloppyBool where
   arbitrary = SloppyBool <$> arbitrary
   shrink (SloppyBool x) = SloppyBool <$> shrink x
 
+instance Arbitrary AvsInternalPersonalNo where 
+  arbitrary = canonical . AvsInternalPersonalNo <$> arbitrary
+  shrink (AvsInternalPersonalNo x) = canonical . AvsInternalPersonalNo <$> shrink x
+
 instance Arbitrary AvsPersonId where 
   arbitrary = AvsPersonId <$> arbitrary
   shrink (AvsPersonId x) = AvsPersonId <$> shrink x