diff --git a/CHANGELOG.md b/CHANGELOG.md
index b1b83f02c..1b344ce5d 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -2,6 +2,13 @@
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
+## [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)
diff --git a/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg b/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg
index 06b915786..147d89ded 100644
--- a/messages/uniworx/categories/settings/personal_settings/de-de-formal.msg
+++ b/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
\ No newline at end of file
diff --git a/messages/uniworx/categories/settings/personal_settings/en-eu.msg b/messages/uniworx/categories/settings/personal_settings/en-eu.msg
index e39556769..cc3c63c19 100644
--- a/messages/uniworx/categories/settings/personal_settings/en-eu.msg
+++ b/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
\ No newline at end of file
diff --git a/nix/docker/demo-version.json b/nix/docker/demo-version.json
index d44322bc1..c24d415e3 100644
--- a/nix/docker/demo-version.json
+++ b/nix/docker/demo-version.json
@@ -1,3 +1,3 @@
{
- "version": "26.6.2"
+ "version": "26.6.3"
}
diff --git a/nix/docker/version.json b/nix/docker/version.json
index d44322bc1..c24d415e3 100644
--- a/nix/docker/version.json
+++ b/nix/docker/version.json
@@ -1,3 +1,3 @@
{
- "version": "26.6.2"
+ "version": "26.6.3"
}
diff --git a/package-lock.json b/package-lock.json
index 13ff6a7f5..9df0c2462 100644
--- a/package-lock.json
+++ b/package-lock.json
@@ -1,6 +1,6 @@
{
"name": "uni2work",
- "version": "26.6.2",
+ "version": "26.6.3",
"lockfileVersion": 1,
"requires": true,
"dependencies": {
diff --git a/package.json b/package.json
index 941b8a803..a22d00fa0 100644
--- a/package.json
+++ b/package.json
@@ -1,6 +1,6 @@
{
"name": "uni2work",
- "version": "26.6.2",
+ "version": "26.6.3",
"description": "",
"keywords": [],
"author": "",
diff --git a/package.yaml b/package.yaml
index 7c89d013f..f715bedb6 100644
--- a/package.yaml
+++ b/package.yaml
@@ -1,5 +1,5 @@
name: uniworx
-version: 26.6.2
+version: 26.6.3
dependencies:
- base
- yesod
diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs
index b438803cd..9bff17398 100644
--- a/src/Handler/Admin/Avs.hs
+++ b/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 ->
- flip (renderAForm FormStandard) html $ AvsQueryPerson
+makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html ->
+ 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 textField (fslI MsgAvsVersionNo) (avsPersonQueryVersionNo <$> tmpl)
+ <*> aopt avsInternalPersonalNoField
+ (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
- nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt
+ where
+ nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt
ids = catMaybes $ readMay <$> nonemptys
- unparseAvsIds :: AvsQueryStatus -> Text
- unparseAvsIds (AvsQueryStatus ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids
+ unparseAvsIds :: AvsQueryStatus -> Text
+ 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
- [ Option
+avsLicenceOptions = mkOptionList
+ [ 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
- Left err -> return . Just $ tshow err
+ case res of
+ 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
- Left err -> return . Just $ tshow err
- Right jsn -> return . Just $ tshow jsn
+ case res of
+ Left err -> return . Just $ tshow err
+ 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
- (Right (Just uid)) -> do
+ case res of
+ (Right (Just uid)) -> do
uuid :: CryptoUUIDUser <- encrypt uid
return $ Just [whamlet|
Success:
User created or updated.|]
(Right Nothing) ->
@@ -122,27 +130,46 @@ postAdminAvsR = do
return $ Just [whamlet|Error:
#{msg}|]
mbCrUser <- formResultMaybe crUsrRes procFormCrUsr
- ((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html ->
- flip (renderAForm FormStandard) html $ areq intField (fslI MsgAvsPersonId) Nothing
- let procFormGetLic fr = do
- res <- try $ getLicenceByAvsId $ AvsPersonId fr
- case res of
- (Right (Just lic)) ->
- return $ Just [whamlet|Success:
Licence #{tshow lic}|]
- (Right Nothing) ->
- return $ Just [whamlet|Warning:
User not found.|]
- (Left e) -> do
- let msg = tshow (e :: SomeException)
+ ((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html ->
+ flip (renderAForm FormStandard) html $ (,,) <$> aopt intField (fslI $ text2message "Min AvsPersonId") Nothing
+ <*> aopt intField (fslI $ text2message "Max AvsPersonId") Nothing
+ <*> aopt (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) Nothing
+ let procFormGetLic fr = do
+ res <- avsQueryGetAllLicences
+ case res of
+ (Right (AvsResponseGetLicences lics)) -> do
+ let flics = Set.toList $ Set.filter lfltr lics
+ lfltr = case fr of -- not pretty, but it'll do
+ (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|
+ Success:
+
+ $forall AvsPersonLicence{..} <- flics
+ - #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
+ |]
+
+ (Left err) -> do
+ let msg = tshow err
return $ Just [whamlet|
Error:
#{msg}|]
mbGetLic <- formResultMaybe getLicRes procFormGetLic
- ((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html ->
- flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing
+ ((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html ->
+ flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing
<*> areq (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) (Just AvsLicenceVorfeld)
- let procFormSetLic (aid, lic) = do
- res <- try $ setLicenceAvs (AvsPersonId aid) lic
- case res of
- (Right True) ->
+ let procFormSetLic (aid, lic) = do
+ let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = AvsPersonId aid }
+ addMessage Info $ text2Html $ "See log for detailed errors. Query: " <> tshow (toJSON $ AvsQuerySetLicences req)
+ res <- try $ setLicencesAvs req
+ case res of
+ (Right True) ->
return $ Just [whamlet|Success:
Licence #{tshow (licence2char lic)} set for #{tshow aid}.|]
(Right False) ->
return $ Just [whamlet|Error:
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
- (Right True) ->
+ case res of
+ (Right True) ->
return $ Just [whamlet|Success:
Licences sychronized.|]
(Right False) ->
return $ Just [whamlet|Error:
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")
diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index 8e30ae3e4..17d39add3 100644
--- a/src/Handler/Profile.hs
+++ b/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
diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs
index d267bd85d..1553c9de9 100644
--- a/src/Handler/Users/Add.hs
+++ b/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)
-instance Universe AuthenticationKind
-instance Finite AuthenticationKind
+ deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable, Universe, Finite)
+--instance Universe AuthenticationKind
+--instance Finite AuthenticationKind
embedRenderMessage ''UniWorX ''AuthenticationKind id
nullaryPathPiece ''AuthenticationKind $ camelToPathPiece' 2
diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs
index b83f16a4e..9c4dec62d 100644
--- a/src/Handler/Utils/Avs.hs
+++ b/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
- candidates <- selectKeysList [UserCompanyPersonalNumber ==. avsPersonInternalPersonalNo] []
+ | Just (avsInternalPersonalNo -> persNo) <- canonical avsPersonInternalPersonalNo -> do
+ 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
diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs
index 9e375da20..52d205d30 100644
--- a/src/Handler/Utils/Widgets.hs
+++ b/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
diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs
index 2eb1210dc..9b20eaee7 100644
--- a/src/Model/Types/Avs.hs
+++ b/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
diff --git a/src/Utils.hs b/src/Utils.hs
index 8a92fe520..e8eedbadb 100644
--- a/src/Utils.hs
+++ b/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
--- canonical (Just t) = Just $ canonical t
--- canonical other = other
+{-
+instance {-# OVERLAPPABLE #-} (Canonical mono, MonoFoldable mono, Eq mono) => Canonical (Maybe mono) where
+ canonical r@(Just t) = let c = canonical t
+ 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
diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs
index dfd2d7c04..3606bb2c0 100644
--- a/src/Utils/Avs.hs
+++ b/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
diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs
index 948afe9de..8dd017bb8 100644
--- a/src/Utils/Icon.hs
+++ b/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
diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet
index 1255bb71e..17d4f05fc 100644
--- a/templates/profileData.hamlet
+++ b/templates/profileData.hamlet
@@ -68,6 +68,19 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
_{MsgCompanyPersonalNumber}
-
#{companyPersonalNumber}
+ $if not $ null companies
+
-
+ _{MsgCompany}
+
-
+ ^{toWgt (mconcat companies)}
+ $if not $ null supervisors
+
- _{MsgProfileSupervisor}
+
-
+ ^{mconcat supervisors}
+ $if not $ null supervisees
+
- _{MsgProfileSupervisee}
+
-
+ ^{mconcat supervisees}
$if showAdminInfo
-
_{MsgUserCreated}
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs
index eb636861d..6f7a305a5 100644
--- a/test/Database/Fill.hs
+++ b/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
diff --git a/test/Utils/TypesSpec.hs b/test/Utils/TypesSpec.hs
index f5dfafb0f..80bd07ac2 100644
--- a/test/Utils/TypesSpec.hs
+++ b/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