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

chore(avs): heterogeneous list working

Browse Source
This commit is contained in:
Steffen Jost 2024-01-12 15:48:54 +01:00
parent 83afdf760f
commit b5340a18a2
4 changed files with 59 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
models/users.model
View File

@ -14,8 +14,8 @@
User json -- Each Uni2work user has a corresponding row in this table; created upon first login.
surname UserSurname -- Display user names always through 'nameWidget displayName surname'
displayName UserDisplayName
displayEmail UserEmail
email UserEmail -- Case-insensitive eMail address, used for sending TODO: make this nullable
displayEmail UserEmail -- Case-insensitive eMail address, used for sending
email UserEmail -- Case-insensitive eMail address, used for identification and fallback for sending TODO: make this nullable
ident UserIdent -- Case-insensitive user-identifier
authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
lastAuthentication UTCTime Maybe -- last login date

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

@ -2,7 +2,7 @@
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeApplications, ExistentialQuantification #-}
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
@ -571,16 +571,22 @@ updateReceivers uid = do
------------------
-- CR3 Functions
updateAvsUserById :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX )
=> AvsPersonId -> m (Maybe UserId)
updateAvsUserById apid = do
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
AvsResponseContact adcs <- throwLeftM . avsQueryContact $ AvsQueryContact $ Set.singleton $ AvsObjPersonId apid
case Set.elems $ Set.filter ((== apid) . avsContactPersonID) adcs of
[] -> throwM AvsPersonSearchEmpty
(_:_:_) -> throwM AvsPersonSearchAmbiguous
[AvsDataContact _apid _avsPersonInfo _avsFirmInfo] -> do
return Nothing -- TODO
-- data CheckAvsUpdate record iavs = forall typ f. (Eq typ, PersistField typ, Functor f) => CheckAvsUpdate ((typ -> f typ) -> iavs -> f iavs) (EntityField record typ) -- A Lens and a User Field; does not work.
data CheckAvsUpdate record iavs = forall typ. (Eq typ, PersistField typ) => CheckAvsUpdate ((typ -> Const typ typ) -> iavs -> Const typ iavs) (EntityField record typ) -- A Lens and a User Field
-- | Compute necessary updates. Given an database record, a new and an old avs response and a pair consisting of a getter from avs response to a value and and EntityField of the same value,
-- an update is returned, if the current value is identical to the old avs value, which changed in the new avs query
mkUpdate :: PersistEntity record => record -> iavs -> iavs -> CheckAvsUpdate record iavs -> Maybe (Update record)
mkUpdate usr npi opi (CheckAvsUpdate la up)
| let newval = npi ^. la
, let oldval = opi ^. la
, let usrval = getField up usr
, oldval /= newval
, oldval == usrval
= Just (up =. newval)
mkUpdate _ _ _ _ = Nothing
updateAvsUserByIds :: Set AvsPersonId -> Handler (Set UserId)
updateAvsUserByIds apids = do
@ -591,23 +597,32 @@ updateAvsUserByIds apids = do
procResp (AvsDataContact apid avsPersonInfo _avsFirmInfo)
| apid `Set.notMember` apids = return mempty -- should not occur, neither should one apid occur multiple times withtin the response (if so, all responses processed here in random order)
| otherwise = runDB $
getBy (UniqueUserAvsId apid) >>= continueJust ( \(Entity _ usravs) ->
let usrId = userAvsUser usravs in
get usrId >>= continueJust ( \usr -> do
let ups = mapMaybe (mkUpdate usr avsPersonInfo $ userAvsLastPersonInfo usravs)
[ (_avsInfoFirstName , UserFirstName )
, (_avsInfoLastName , UserSurname )
, (_avsInfoDisplayName, UserDisplayName)
-- , (_avsInfoDateOfBirth, UserBirthday ) -- not polymorphic enough, needs type annotation
]
update usrId ups
return $ Set.singleton usrId
))
mkUpdate usr npi (Just opi) (la, up)
| let newval = npi ^. la
, let oldval = opi ^. la
, let usrval = getField up usr
, oldval /= newval
, oldval == usrval
= Just (up =. newval)
mkUpdate _ _ _ _ = Nothing
getBy (UniqueUserAvsId apid) >>= foldMapM ( \(Entity _ usravs) ->
continueJust (userAvsLastPersonInfo usravs) ( \oldAvsPersonInfo ->
let usrId = userAvsUser usravs in
get usrId >>= foldMapM ( \usr -> do
let ups = mapMaybe (mkUpdate usr avsPersonInfo oldAvsPersonInfo)
[ CheckAvsUpdate _avsInfoFirstName UserFirstName
, CheckAvsUpdate _avsInfoLastName UserSurname
, CheckAvsUpdate _avsInfoDisplayName UserDisplayName
, CheckAvsUpdate _avsInfoDateOfBirth UserBirthday
, CheckAvsUpdate _avsInfoPersonMobilePhoneNo UserMobile
, CheckAvsUpdate (_avsInfoPersonNo . re _Just) UserMatrikelnummer -- Maybe im User, aber nicht im AvsInfo
, CheckAvsUpdate (_avsInfoPersonEMail . to (fromMaybe mempty) . from _CI) UserDisplayEmail -- Maybe nicht im AvsInfo, aber im AvsInfo
, CheckAvsUpdate (_avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . to Just) UserCompanyPersonalNumber -- Maybe im User und im AvsInfo
]
update usrId ups
return $ Set.singleton usrId
)))
updateAvsUserById :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX )
=> AvsPersonId -> m (Maybe UserId)
updateAvsUserById apid = do
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
AvsResponseContact adcs <- throwLeftM . avsQueryContact $ AvsQueryContact $ Set.singleton $ AvsObjPersonId apid
case Set.elems $ Set.filter ((== apid) . avsContactPersonID) adcs of
[] -> throwM AvsPersonSearchEmpty
(_:_:_) -> throwM AvsPersonSearchAmbiguous
[AvsDataContact _apid _avsPersonInfo _avsFirmInfo] -> do
return Nothing -- TODO

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

@ -94,12 +94,15 @@ mkAvsInternalPersonalNo :: Text -> AvsInternalPersonalNo
mkAvsInternalPersonalNo = AvsInternalPersonalNo . normalizeAvsInternalPersonalNo
instance Canonical AvsInternalPersonalNo where
canonical (AvsInternalPersonalNo ipn) = AvsInternalPersonalNo $ Text.dropWhile (\c -> '0' == c || Char.isSpace c) ipn
canonical (AvsInternalPersonalNo ipn) = AvsInternalPersonalNo $ normalizeAvsInternalPersonalNo ipn
instance FromJSON AvsInternalPersonalNo where
parseJSON x = AvsInternalPersonalNo . normalizeAvsInternalPersonalNo <$> parseJSON x
instance ToJSON AvsInternalPersonalNo where
toJSON (AvsInternalPersonalNo ipn) = toJSON $ normalizeAvsInternalPersonalNo ipn
_avsInternalPersonalNo :: Lens' AvsInternalPersonalNo Text
_avsInternalPersonalNo = lens (normalizeAvsInternalPersonalNo . avsInternalPersonalNo) (const mkAvsInternalPersonalNo)
type instance Element AvsInternalPersonalNo = Char
instance MonoFoldable AvsInternalPersonalNo where
ofoldMap f = ofoldr (mappend . f) mempty . avsInternalPersonalNo

12
src/Utils.hs
View File

@ -900,15 +900,11 @@ filterMaybe c r@(Just x) | c x = r
filterMaybe _ _ = Nothing
-- | also referred to as whenJust and forM_
-- also see `foldMapM` if a Monoid value is to be returned
whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (Just x) f = f x
whenIsJust Nothing _ = return ()
-- | synonym for `flip foldMapM`
continueJust :: (Monoid m, Applicative f) => (a -> f m) -> Maybe a -> f m
continueJust f (Just x) = f x
continueJust _ Nothing = pure mempty
ifMaybeM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argument order as compared to maybeM
ifMaybeM Nothing dft _ = return dft
ifMaybeM (Just x) _ act = act x
@ -1218,6 +1214,12 @@ ofoldl1M _ _ = error "otoList of NonNull is empty"
foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b
foldMapM f = foldrM (\x xs -> (<> xs) <$> f x) mempty
-- | convenient synonym for `flip foldMapM`
continueJust :: (Applicative m, Monoid b) => Maybe a -> (a -> m b) -> m b
continueJust (Just x) f = f x
continueJust Nothing _ = pure mempty
ifoldMapM :: (FoldableWithIndex i f, Monad m, Monoid b) => (i -> a -> m b) -> f a -> m b
ifoldMapM f = ifoldrM (\i x xs -> (<> xs) <$> f i x) mempty