diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 43bc8793c..c48e31169 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -51,6 +51,7 @@ import Jobs.Queue import Utils.Avs import Utils.Users +import Utils.Mail (validEmail) import Handler.Utils.Users import Handler.Utils.Company import Handler.Utils.Qualification @@ -365,11 +366,12 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv , CU_API_UserMatrikelnummer -- , CU_API_UserCompanyPersonalNumber -- needs special treatment, see ldap_ups above ] - eml_up = mkUpdate usr newAvsDataContact oldAvsDataContact $ mkCheckUpdate CU_ADC_UserDisplayEmail -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen. + eml_up1 = mkUpdate usr newAvsDataContact oldAvsDataContact $ mkCheckUpdate CU_ADC_UserDisplayEmail -- DisplayEmail updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen. + eml_up2 = mkUpdate usr newAvsFirmInfo oldAvsFirmInfo $ mkCheckUpdate CU_AFI_UserEmail -- Email update erfolgt nur, wenn hier die SuperiorEmail als Fallback gespeichert wurde 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 - usr_up1 = eml_up `mcons` (frm_up `mcons` (pin_up `mcons` (ldap_ups <> per_ups))) + usr_up1 = catMaybes [eml_up1, eml_up2, frm_up, pin_up] <> ldap_ups <> per_ups avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons` [ UserAvsLastSynch =. now , UserAvsLastSynchError =. Nothing @@ -443,8 +445,9 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef) -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId -- return pst_up - update usrId $ usr_up2 <> usr_up1 -- update user eventually - update uaId avs_ups -- update stored avsinfo for future updates + update usrId usr_up2 -- update user by company switch first (due to possible conflicts with usr_up2) + update usrId usr_up1 -- update user eventually + update uaId avs_ups -- update stored avsinfo for future updates return (apid, usrId) @@ -528,13 +531,14 @@ createAvsUserById muid api = do (Nothing, Nothing) -> do -- create fresh user Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany firmInfo Nothing -- individual runDB, since no need to rollback let pinPass = avsFullCardNo2pin <$> usrCardNo + superiorEmail = filterMaybe validEmail $ adc ^. _avsContactFirmInfo . _avsFirmEMailSuperior newUserData = AddUserData { audTitle = Nothing , audFirstName = cpi ^. _avsInfoFirstName & Text.strip , audSurname = cpi ^. _avsInfoLastName & Text.strip , audDisplayName = cpi ^. _avsInfoDisplayName , audDisplayEmail = adc ^. _avsContactPrimaryEmail . to (fromMaybe mempty) . from _CI - , audEmail = "AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI + , audEmail = maybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI) stripCI superiorEmail , audIdent = "AVSID:" <> ciShow api , audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) internalPersNo , audMatriculation = cpi ^. _avsInfoPersonNo & Just diff --git a/src/Handler/Utils/AvsUpdate.hs b/src/Handler/Utils/AvsUpdate.hs index 5ff7c55fa..6b60c0780 100644 --- a/src/Handler/Utils/AvsUpdate.hs +++ b/src/Handler/Utils/AvsUpdate.hs @@ -87,6 +87,7 @@ instance MkCheckUpdate CU_AvsDataContcat_User where data CU_AvsFirmInfo_User = CU_AFI_UserPostAddress + | CU_AFI_UserEmail -- CU_AFI_UserDisplayEmail -- use _avsContactPrimaryEmailAddress instead deriving (Show, Eq) @@ -94,7 +95,8 @@ 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_UserEmail = CheckUpdateOpt UserEmail $ _avsFirmEMailSuperior . _Just . from _CI -- in rare cases, firm superior email is used as fallback here + -- 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! diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index a5f2f02dc..b60423756 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -163,10 +163,14 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d usrPrefPost = userPrefersPostal usrRec usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal)) (UserPrefersPostal =. companyPrefersPostal newCompany) - usrEmail :: UserEmail = userDisplayEmail usrRec + -- newCmpEmail :: UserEmail = fromMaybe "" $ companyEmail newCompany + usrEmail :: UserEmail = userEmail usrRec + usrDisplayEmail :: UserEmail = userDisplayEmail usrRec avsEmail :: Maybe UserEmail = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPrimaryEmail . _Just . from _CI - usrEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrEmail) (UserDisplayEmail =. "") - usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrEmailUp] + usrDisplayEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrDisplayEmail) (UserDisplayEmail =. "") -- delete DisplayEmail, if equal to AVS Firm Email + supEmail :: Maybe UserEmail = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmEMailSuperior . _Just . from _CI + usrEmailUp = toMaybe (usrPostEmailUpds && supEmail == Just usrEmail) (UserEmail =. "") -- delete UserEmail, if equal to AVS Firm Superior + usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrDisplayEmailUp, usrEmailUp] -- [UserPostAddress =. Nothing, UserPrefersPostal =. companyPrefersPostal newCompany] -- unconditional -- update uid usrUpdate -- repsertSuperiorSupervisor is not called here, since the Superior is indepentent of the actual company association diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index ef9752f0f..636b28291 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -216,7 +216,7 @@ instance PersistFieldSql AvsFullCardNo where parseAvsCardNo :: Text -> Maybe (Either AvsCardNo AvsFullCardNo) parseAvsCardNo = splitDigitsByDot AvsCardNo (AvsFullCardNo . AvsCardNo) -discernAvsCardPersonalNo :: Text -> Maybe (Either AvsInternalPersonalNo AvsFullCardNo) +discernAvsCardPersonalNo :: Text -> Maybe (Either AvsInternalPersonalNo AvsFullCardNo) discernAvsCardPersonalNo = splitDigitsByDot mkAvsInternalPersonalNo (AvsFullCardNo . AvsCardNo) -- | Just implies that argument is a whole number or decimal with one single digit after the point. Helper functions receive digit-parts without dot @@ -227,7 +227,7 @@ splitDigitsByDot fl fr (Text.span Char.isDigit -> (c, pv)) = Just $ Left $ fl c | Just ('.', v) <- Text.uncons pv , Just (Char.isDigit -> True, "") <- Text.uncons v - = Just $ Right $ fr c v + = Just $ Right $ fr c v splitDigitsByDot _ _ _ = Nothing -- The AVS API requires PersonIds sometimes as as mere numbers `AvsPersonId` and sometimes as tagged objects `AvsObjPersonId` @@ -453,7 +453,7 @@ deriveJSON defaultOptions } ''AvsStatusPerson makeLenses_ ''AvsStatusPerson - + data AvsDataPerson = AvsDataPerson { avsPersonFirstName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces @@ -551,7 +551,7 @@ _avsInfoDisplayName :: Lens' AvsPersonInfo Text _avsInfoDisplayName = lens g s where g AvsPersonInfo{avsInfoFirstName, avsInfoLastName} = Text.append avsInfoFirstName $ Text.cons ' ' avsInfoLastName - s api dn = let (Text.strip -> fn, Text.strip -> ln) = Text.breakOnEnd " " dn + s api dn = let (Text.strip -> fn, Text.strip -> ln) = Text.breakOnEnd " " dn in api{avsInfoFirstName = fn, avsInfoLastName = ln} @@ -603,7 +603,7 @@ instance {-# OVERLAPS #-} Canonical (Maybe AvsFirmCommunication) where makeLenses_ ''AvsFirmCommunication _avsCommunicationAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmCommunication (Maybe Text) _avsCommunicationAddress = to mkAddr - where + where mkAddr AvsFirmCommunication{..} = composeAddress avsCommunicationStreetANDHouseNo avsCommunicationZIPCode avsCommunicationCity avsCommunicationCountry instance FromJSON AvsFirmCommunication where @@ -645,7 +645,7 @@ _avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo _avsFirmPostAddress = to mkPost where mkPost afi@AvsFirmInfo{avsFirmFirm} = - let someAddr = afi ^. _avsFirmPostAddressSimple + let someAddr = afi ^. _avsFirmPostAddressSimple prefAddr = plaintextToStoredMarkup . (avsFirmFirm <>) . Text.cons '\n' in prefAddr <$> someAddr @@ -657,27 +657,27 @@ _avsFirmPostAddressSimple = to mkPost mkPost AvsFirmInfo{..} = let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress - in asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr] + in asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr] _avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) _avsFirmPrimaryEmail = to mkEmail where mkEmail afi = - let candidates = catMaybes + let candidates = catMaybes [ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail , afi ^. _avsFirmEMail - , afi ^. _avsFirmEMailSuperior -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email + , 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? -- | Not sure this is useful, since postal is ignored if there is no post address anyway _avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool _avsFirmPrefersPostal = to mkPostPref - where + where mkPostPref afi = isJust (afi ^. _avsFirmPostAddress) || isNothing (afi ^. _avsFirmPrimaryEmail) -- Note _avsFirmAddress is never empty; always includes the company name; consider using user _avsFirmPostAddress instead --- _avsFirmAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Text +-- _avsFirmAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Text -- _avsFirmAddress = to mkAddr -- where -- mkAddr AvsFirmInfo{..} = @@ -726,12 +726,12 @@ makeLenses_ ''AvsDataContact _avsContactPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsDataContact (Maybe Text) _avsContactPrimaryEmail = to mkEmail where - mkEmail adc = + 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 + -- , adc ^. _avsContactFirmInfo . _avsFirmEMailSuperior -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email. Superior email is used as systemEmail only. ] in pickValidEmail candidates -- should we return an invalid email rather than none? @@ -848,15 +848,15 @@ fixAvsQueryPerson AvsQueryPerson{avsPersonQueryVersionNo=Nothing, avsPersonQuery = AvsQueryPerson { avsPersonQueryCardNo = Just acn1 , avsPersonQueryVersionNo = Just avc1 - , avsPersonQueryFirstName = canonical avsPersonQueryFirstName - , avsPersonQueryLastName = canonical avsPersonQueryLastName + , avsPersonQueryFirstName = canonical avsPersonQueryFirstName + , avsPersonQueryLastName = canonical avsPersonQueryLastName , avsPersonQueryInternalPersonalNo = canonical avsPersonQueryInternalPersonalNo } fixAvsQueryPerson AvsQueryPerson{..} = AvsQueryPerson - { avsPersonQueryCardNo = canonical avsPersonQueryCardNo - , avsPersonQueryVersionNo = canonical avsPersonQueryVersionNo - , avsPersonQueryFirstName = canonical avsPersonQueryFirstName - , avsPersonQueryLastName = canonical avsPersonQueryLastName + { avsPersonQueryCardNo = canonical avsPersonQueryCardNo + , avsPersonQueryVersionNo = canonical avsPersonQueryVersionNo + , avsPersonQueryFirstName = canonical avsPersonQueryFirstName + , avsPersonQueryLastName = canonical avsPersonQueryLastName , avsPersonQueryInternalPersonalNo = canonical avsPersonQueryInternalPersonalNo } @@ -878,7 +878,7 @@ deriveJSON defaultOptions ''AvsQueryGetLicences data AvsQueryGetAllLicences = AvsQueryGetAllLicences -- for convenience, encoding AvsQueryGetLicences (AvsObjPersonId avsPersonIdZero) deriving (Eq, Ord, Show, Generic) - + newtype AvsQuerySetLicences = AvsQuerySetLicences (Set AvsPersonLicence) deriving (Eq, Ord, Show, Generic) deriveJSON defaultOptions ''AvsQuerySetLicences diff --git a/src/Utils.hs b/src/Utils.hs index 69b114b01..94baeef10 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -991,6 +991,7 @@ catchIfMPlus :: forall m e a. (MonadPlus m, MonadCatch m, Exception e) => (e -> catchIfMPlus p act = catchIf p act (const mzero) -- | Monadic version of 'fromMaybe' +-- Warning: fromMaybeM [1,2,3] [Nothing, Just 4, Just 5, Nothing] == [1,2,3,4,5,1,2,3] and fromMaybeM [1,2,3] [Just 4] == [4] fromMaybeM :: Monad m => m a -> m (Maybe a) -> m a fromMaybeM act = maybeM act pure