fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into fradrive/api-avs

Browse Source
This commit is contained in:
Steffen Jost 2022-12-01 10:53:15 +01:00
commit 2c35bd85d1
20 changed files with 236 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
CHANGELOG.md
View File

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

4
messages/uniworx/categories/settings/personal_settings/de-de-formal.msg
View File

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

4
messages/uniworx/categories/settings/personal_settings/en-eu.msg
View File

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

2
nix/docker/demo-version.json
View File

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

2
nix/docker/version.json
View File

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

2
package-lock.json generated
View File

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

2
package.json
View File

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

2
package.yaml
View File

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

123
src/Handler/Admin/Avs.hs
View File

@ -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|<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 ->
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|<h2>Success:</h2> Licence #{tshow lic}|]
(Right Nothing) ->
return $ Just [whamlet|<h2>Warning:</h2> 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|
<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 ->
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|<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
(Right True) ->
case res of
(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")

21
src/Handler/Profile.hs
View File

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

6
src/Handler/Users/Add.hs
View File

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

24
src/Handler/Utils/Avs.hs
View File

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

5
src/Handler/Utils/Widgets.hs
View File

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

52
src/Model/Types/Avs.hs
View File

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

17
src/Utils.hs
View File

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

10
src/Utils/Avs.hs
View File

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

2
src/Utils/Icon.hs
View File

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

13
templates/profileData.hamlet
View File

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

17
test/Database/Fill.hs
View File

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

4
test/Utils/TypesSpec.hs
View File

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