diff --git a/models/users.model b/models/users.model index b23fe85b2..02f5f8af9 100644 --- a/models/users.model +++ b/models/users.model @@ -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 diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 9180ed5f4..44c7bd6f0 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -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 diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index debe9c26d..18388afb4 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -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 diff --git a/src/Utils.hs b/src/Utils.hs index 77c6bf59a..7e83ba5c9 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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