From e4fa1ddd6873910bef82d569fe16aca936efc567 Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 25 Jun 2024 15:54:55 +0200 Subject: [PATCH] fix(avs): priority for picking primary email demote superior --- src/Handler/Users.hs | 4 +++- src/Handler/Utils/Avs.hs | 15 ++++++++------- src/Handler/Utils/AvsUpdate.hs | 26 ++++++++++++++++++-------- src/Model/Types/Avs.hs | 22 +++++++++++++++++++++- 4 files changed, 50 insertions(+), 17 deletions(-) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index eedad2369..a335c6923 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -494,7 +494,7 @@ nullaryPathPiece ''UserAssimilateButton $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''UserAssimilateButton id -data ThisUserAction = ThisUserLdapSync | ThisUserAvsSync +data ThisUserAction = ThisUserLdapSync | ThisUserAvsSync -- ThisUserHijack would make sense, but this 'btn' should not always be visible deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -521,6 +521,8 @@ postAdminUserR uuid = do n <- runDB $ queueAvsUpdateByUID (Set.singleton uid) Nothing addMessageI Success $ MsgSynchroniseAvsUserQueued $ fromIntegral n redirectKeepGetParams $ AdminUserR uuid + -- ThisUserHijack -> do + -- redirect $ AdminHijackUserR uuid let thisUserActWgt = wrapForm thisUserActWgt' def { formSubmit = FormNoSubmit , formAction = Just $ SomeRoute $ AdminUserR uuid diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 598b82509..eb7d42d8d 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -323,14 +323,17 @@ updateAvsUserByIds' apids = do updateAvsUserByADC :: AvsDataContact -> DB (Maybe (AvsPersonId, UserId)) -updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMaybeT $ do +updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMaybeT $ do (Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid let usrId = userAvsUser usravs usr <- MaybeT $ get usrId lift $ do -- maybeT no longer needed from here onwards - let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- Nothing is ok here - oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here - oldAvsCardNo = userAvsLastCardNo usravs & fmap Just + let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- Nothing is ok here + oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here + oldAvsCardNo = userAvsLastCardNo usravs & fmap Just + oldAvsDataContact = case (oldAvsPersonInfo, oldAvsFirmInfo) of + (Just oapi, Just oafi) -> Just $ AvsDataContact apid oapi oafi + _ -> Nothing newAvsCardNo <- queryAvsFullCardNo apid -- Nothing os ok here, does not throw now <- liftIO getCurrentTime mbLdapExpire <- getsYesod $ views appSettings appSynchroniseLdapUsersExpire @@ -362,9 +365,7 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa , CU_API_UserMatrikelnummer -- , CU_API_UserCompanyPersonalNumber -- needs special treatment, see ldap_ups above ] - eml_up = let em_p_up = mkUpdate usr newAvsPersonInfo oldAvsPersonInfo $ mkCheckUpdate CU_API_UserDisplayEmail - em_f_up = mkUpdate usr newAvsFirmInfo oldAvsFirmInfo $ mkCheckUpdate CU_AFI_UserDisplayEmail - in em_f_up <|> em_p_up -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen. + eml_up = mkUpdate usr newAvsDataContact oldAvsDataContact $ mkCheckUpdate CU_ADC_UserDisplayEmail -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen. frm_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ mkCheckUpdate CU_AFI_UserPostAddress -- Legacy, if company postal is stored in user; should no longer be true for new users, since company address should now be referenced with UserCompany instead pin_up = mkUpdate' usr newAvsCardNo oldAvsCardNo $ -- Maybe update PDF pin to latest card CheckUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just diff --git a/src/Handler/Utils/AvsUpdate.hs b/src/Handler/Utils/AvsUpdate.hs index e328b794d..9a9ef7fed 100644 --- a/src/Handler/Utils/AvsUpdate.hs +++ b/src/Handler/Utils/AvsUpdate.hs @@ -58,7 +58,7 @@ data CU_AvsPersonInfo_User | CU_API_UserMatrikelnummer | CU_API_UserCompanyPersonalNumber | CU_API_UserLdapPrimaryKey - | CU_API_UserDisplayEmail + -- | CU_API_UserDisplayEmail -- use _avsContactPrimaryEmailAddress instead deriving (Show, Eq) instance MkCheckUpdate CU_AvsPersonInfo_User where @@ -72,25 +72,35 @@ instance MkCheckUpdate CU_AvsPersonInfo_User where mkCheckUpdate CU_API_UserMatrikelnummer = CheckUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just mkCheckUpdate CU_API_UserCompanyPersonalNumber = CheckUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov mkCheckUpdate CU_API_UserLdapPrimaryKey = CheckUpdate UserLdapPrimaryKey $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just - mkCheckUpdate CU_API_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsInfoPersonEMail . _Just . from _CI -- Maybe im AvsInfo, aber nicht im User, daher Opt + -- mkCheckUpdate CU_API_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsInfoPersonEMail . _Just . from _CI -- Maybe im AvsInfo, aber nicht im User, daher Opt +data CU_AvsDataContcat_User + = CU_ADC_UserPostAddress + | CU_ADC_UserDisplayEmail + deriving (Show, Eq) + +instance MkCheckUpdate CU_AvsDataContcat_User where + type MCU_Rec CU_AvsDataContcat_User = User + type MCU_Raw CU_AvsDataContcat_User = AvsDataContact + mkCheckUpdate CU_ADC_UserPostAddress = CheckUpdate UserPostAddress _avsContactPrimaryPostAddress + mkCheckUpdate CU_ADC_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsContactPrimaryEmail . _Just . from _CI data CU_AvsFirmInfo_User = CU_AFI_UserPostAddress - | CU_AFI_UserDisplayEmail + -- | CU_AFI_UserDisplayEmail -- use _avsContactPrimaryEmailAddress instead deriving (Show, Eq) instance MkCheckUpdate CU_AvsFirmInfo_User where type MCU_Rec CU_AvsFirmInfo_User = User type MCU_Raw CU_AvsFirmInfo_User = AvsFirmInfo mkCheckUpdate CU_AFI_UserPostAddress = CheckUpdate UserPostAddress _avsFirmPostAddress - mkCheckUpdate CU_AFI_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsFirmPrimaryEmail . _Just . from _CI -- Maybe im AvsInfo, aber nicht im User, daher Opt + -- mkCheckUpdate CU_AFI_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsFirmPrimaryEmail . _Just . from _CI -- Maybe im AvsInfo, aber nicht im User, daher Opt -- NOTE: Ensure that the lenses between CU_UserAvs_User and CU_AvsPersonInfo_User/CU_AvsFirmInfo_User agree! data CU_UserAvs_User = CU_UA_UserPinPassword - | CU_UA_UserPostAddress + -- | CU_UA_UserPostAddress -- use _avsContactPrimaryPostAddress instead | CU_UA_UserFirstName | CU_UA_UserSurname | CU_UA_UserDisplayName @@ -99,14 +109,14 @@ data CU_UserAvs_User | CU_UA_UserMatrikelnummer | CU_UA_UserCompanyPersonalNumber | CU_UA_UserLdapPrimaryKey - | CU_UA_UserDisplayEmail + -- | CU_UA_UserDisplayEmail -- use _avsContactPrimaryEmailAddress instead deriving (Show, Eq) instance MkCheckUpdate CU_UserAvs_User where type MCU_Rec CU_UserAvs_User = User type MCU_Raw CU_UserAvs_User = UserAvs mkCheckUpdate CU_UA_UserPinPassword = CheckUpdateOpt UserPinPassword $ _userAvsLastCardNo . _Just . to avsFullCardNo2pin . re _Just - mkCheckUpdate CU_UA_UserPostAddress = CheckUpdateOpt UserPostAddress $ _userAvsLastFirmInfo . _Just . _avsFirmPostAddress + -- mkCheckUpdate CU_UA_UserPostAddress = CheckUpdateOpt UserPostAddress $ _userAvsLastFirmInfo . _Just . _avsFirmPostAddress mkCheckUpdate CU_UA_UserFirstName = CheckUpdateOpt UserFirstName $ _userAvsLastPersonInfo . _Just . _avsInfoFirstName mkCheckUpdate CU_UA_UserSurname = CheckUpdateOpt UserSurname $ _userAvsLastPersonInfo . _Just . _avsInfoLastName mkCheckUpdate CU_UA_UserDisplayName = CheckUpdateOpt UserDisplayName $ _userAvsLastPersonInfo . _Just . _avsInfoDisplayName @@ -115,4 +125,4 @@ instance MkCheckUpdate CU_UserAvs_User where mkCheckUpdate CU_UA_UserMatrikelnummer = CheckUpdateOpt UserMatrikelnummer $ _userAvsLastPersonInfo . _Just . _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just mkCheckUpdate CU_UA_UserCompanyPersonalNumber = CheckUpdateOpt UserCompanyPersonalNumber $ _userAvsLastPersonInfo . _Just . _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov mkCheckUpdate CU_UA_UserLdapPrimaryKey = CheckUpdateOpt UserLdapPrimaryKey $ _userAvsLastPersonInfo . _Just . _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just - mkCheckUpdate CU_UA_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _userAvsLastPersonInfo . _Just . _avsInfoPersonEMail . _Just . from _CI + -- mkCheckUpdate CU_UA_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _userAvsLastPersonInfo . _Just . _avsInfoPersonEMail . _Just . from _CI diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 9a7a032ed..5e6abd2ed 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -641,6 +641,7 @@ makeLenses_ ''AvsFirmInfo -- additional convenience lenses: _avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup) +-- _avsFirmPostAddress :: Getter AvsFirmInfo (Maybe StoredMarkup) _avsFirmPostAddress = to mkPost where mkPost afi@AvsFirmInfo{avsFirmFirm} = @@ -650,6 +651,7 @@ _avsFirmPostAddress = to mkPost -- | company post address without company name, better suited for comparisons _avsFirmPostAddressSimple :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) +-- _avsFirmPostAddressSimple :: Getter AvsFirmInfo (Maybe Text) _avsFirmPostAddressSimple = to mkPost where mkPost AvsFirmInfo{..} = @@ -663,8 +665,8 @@ _avsFirmPrimaryEmail = to mkEmail mkEmail afi = let candidates = catMaybes [ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail - , afi ^. _avsFirmEMailSuperior -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email , afi ^. _avsFirmEMail + , afi ^. _avsFirmEMailSuperior -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email ] in pickValidEmail candidates -- should we return an invalid email rather than none? @@ -721,6 +723,24 @@ data AvsDataContact = AvsDataContact makeLenses_ ''AvsDataContact +_avsContactPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsDataContact (Maybe Text) +_avsContactPrimaryEmail = to mkEmail + where + mkEmail adc = + let candidates = catMaybes + [ adc ^. _avsContactFirmInfo . _avsFirmCommunication . _Just . _avsCommunicationEMail + , adc ^. _avsContactFirmInfo . _avsFirmEMail + , adc ^. _avsContactPersonInfo . _avsInfoPersonEMail + , adc ^. _avsContactFirmInfo . _avsFirmEMailSuperior -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email + ] + in pickValidEmail candidates -- should we return an invalid email rather than none? + +-- _avsContactPrimaryPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsDataContact (Maybe StoredMarkup) +-- _avsContactPrimaryPostAddress :: (Functor f, Contravariant f) => (Maybe StoredMarkup -> f (Maybe StoredMarkup)) -> AvsDataContact -> f AvsDataContact +_avsContactPrimaryPostAddress :: Getter AvsDataContact (Maybe StoredMarkup) +_avsContactPrimaryPostAddress = _avsContactFirmInfo . _avsFirmPostAddress + + -- instance Canonical AvsDataContact where -- canonical = over _avsContactPersonInfo canonical -- . over _avsContactFirmInfo canonical