From a6d0105903caba0eb47715eeb217ea2c53d99e23 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 17 Jun 2024 17:50:41 +0200 Subject: [PATCH] fix(avs): fix rare avs update bug involving values optional in avs but compulsory in user entity --- src/Data/CaseInsensitive/Instances.hs | 2 +- src/Handler/Profile.hs | 5 +- src/Handler/Utils/Avs.hs | 70 +++++++-------------------- src/Handler/Utils/AvsUpdate.hs | 70 +++++++++++++++++++++++++++ src/Utils/DB.hs | 54 +++++++++++++++++++-- 5 files changed, 143 insertions(+), 58 deletions(-) create mode 100644 src/Handler/Utils/AvsUpdate.hs diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index b7c3dfa59..d373b942a 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -128,4 +128,4 @@ instance Swagger.ToSchema s => Swagger.ToSchema (CI s) where instance (CI.FoldCase s, Binary s) => Binary (CI s) where get = CI.mk <$> Binary.get - put = Binary.put . CI.original + put = Binary.put . CI.original \ No newline at end of file diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 34f01e82c..d23dce687 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -21,6 +21,7 @@ module Handler.Profile import Import import Handler.Utils +import Handler.Utils.AvsUpdate import Handler.Utils.Avs import Handler.Utils.Profile import Handler.Utils.Users @@ -592,7 +593,9 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do now <- liftIO getCurrentTime avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid) let usrAutomatic :: forall t . EntityField User t -> Widget - usrAutomatic upd = updateAutomatic $ maybe False (mayUpdate usrVal (avsId ^? _Just . _userAvsLastPersonInfo . _Just)) $ userPersonUpd upd + usrAutomatic upd = updateAutomatic $ maybe False (mayUpdate usrVal (avsId ^? _Just . _userAvsLastPersonInfo . _Just)) $ getUserPersonUpd upd + -- usrAutomatic upd = updateAutomatic $ maybe False (mayUpdate usrVal avsId) $ getUserAvsUpd upd + (actualPrefersPostal, (actualPostAddress, postalAutomatic), (actualDisplayEmail, emailAutomatic)) <- getPostalPreferenceAndAddress' usrEnt functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] [] lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 049a9e111..1668a2af6 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -4,8 +4,6 @@ {-# LANGUAGE TypeApplications, ExistentialQuantification #-} -{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} - -- Module for functions directly related to the AVS interface, -- for utilities dealing with FraDrive Qualification types see Handler.Utils.Qualification -- NOTE: Several ifdef DEVELOPMENT used, so UNSET DEVELOPMENT and build before comitting. @@ -30,8 +28,7 @@ module Handler.Utils.Avs , AvsPersonIdMapPersonCard -- CR3 , SomeAvsQuery(..) - , queryAvsCardNo, queryAvsCardNos - , userPersonUpd + , queryAvsCardNo, queryAvsCardNos ) where import Import @@ -58,6 +55,7 @@ import Handler.Utils.Users import Handler.Utils.Company import Handler.Utils.Qualification import Handler.Utils.Memcached +import Handler.Utils.AvsUpdate import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma @@ -67,7 +65,6 @@ import qualified Database.Esqueleto.PostgreSQL as E import Servant.Client.Core.ClientError (ClientError) - -------------------- -- AVS Exceptions -- -------------------- @@ -324,39 +321,6 @@ updateAvsUserByIds' apids = do catchAll (runDB updateAvsUserByADC') errHandler -userPersonUpd :: EntityField User t -> Maybe (CheckUpdate User AvsPersonInfo) -userPersonUpd = flip Map.lookup dict . persistFieldDef - where - dict = Map.fromList -- EntityField has no Eq instance, but FieldDef does. Is is only unique within a single Table, but we need to fix the Table type anyway - [ (persistFieldDef UserFirstName , CheckUpdate UserFirstName _avsInfoFirstName) - , (persistFieldDef UserSurname , CheckUpdate UserSurname _avsInfoLastName) - , (persistFieldDef UserDisplayName , CheckUpdate UserDisplayName _avsInfoDisplayName) - , (persistFieldDef UserBirthday , CheckUpdate UserBirthday _avsInfoDateOfBirth) - , (persistFieldDef UserMobile , CheckUpdate UserMobile _avsInfoPersonMobilePhoneNo) - , (persistFieldDef UserMatrikelnummer , CheckUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just) -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just` - , (persistFieldDef UserCompanyPersonalNumber , CheckUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just) -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups above - , (persistFieldDef UserLdapPrimaryKey , CheckUpdate UserLdapPrimaryKey $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just) - , (persistFieldDef UserDisplayEmail , CheckUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI) - ] - --- more general than userPersonUpd, starting at UserAvs instead of AvsPersonInfo --- usrAvsUpd :: EntityField User t -> Maybe (CheckUpdate User UserAvs) --- usrAvsUpd = flip Map.lookup dict . persistFieldDef --- where --- dict = Map.fromList --- [ (persistFieldDef UserFirstName , CheckUpdate UserFirstName $ _userAvsLastPersonInfo . _Just . _avsInfoFirstName) --- , (persistFieldDef UserSurname , CheckUpdate UserSurname $ _userAvsLastPersonInfo . _Just . _avsInfoLastName) --- , (persistFieldDef UserDisplayName , CheckUpdate UserDisplayName $ _userAvsLastPersonInfo . _Just . _avsInfoDisplayName) --- -- , (persistFieldDef UserBirthday , CheckUpdate UserBirthday $ _userAvsLastPersonInfo . _Just . _avsInfoDateOfBirth) -- no SemiGroup for Day --- , (persistFieldDef UserMobile , CheckUpdate UserMobile $ _userAvsLastPersonInfo . _Just . _avsInfoPersonMobilePhoneNo) --- , (persistFieldDef UserMatrikelnummer , CheckUpdate UserMatrikelnummer $ _userAvsLastPersonInfo . _Just . _avsInfoPersonNo . re _Just) -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just` --- , (persistFieldDef UserCompanyPersonalNumber , CheckUpdate UserCompanyPersonalNumber $ _userAvsLastPersonInfo . _Just . _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just) -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups above --- , (persistFieldDef UserLdapPrimaryKey , CheckUpdate UserLdapPrimaryKey $ _userAvsLastPersonInfo . _Just . _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just) --- , (persistFieldDef UserDisplayEmail , CheckUpdate UserDisplayEmail $ _userAvsLastPersonInfo . _Just . _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI) --- , (persistFieldDef UserPinPassword , CheckUpdate UserPinPassword $ _userAvsLastCardNo . _Just . to avsFullCardNo2pin . re _Just) --- , (persistFieldDef UserPostAddress , CheckUpdate UserPostAddress $ _userAvsLastFirmInfo . _Just . _avsFirmPostAddress) --- ] - updateAvsUserByADC :: AvsDataContact -> DB (Maybe (AvsPersonId, UserId)) updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMaybeT $ do @@ -391,25 +355,25 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa [ CheckUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just ] let per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo) $ catMaybes - [ userPersonUpd UserFirstName - , userPersonUpd UserSurname - , userPersonUpd UserDisplayName - , userPersonUpd UserBirthday - , userPersonUpd UserMobile - , userPersonUpd UserMatrikelnummer - -- , userPersonUpd UserCompanyPersonalNumber -- needs special treatment, see ldap_ups above + [ getUserPersonUpd UserFirstName + , getUserPersonUpd UserSurname + , getUserPersonUpd UserDisplayName + , getUserPersonUpd UserBirthday + , getUserPersonUpd UserMobile + , getUserPersonUpd UserMatrikelnummer + -- , getUserPersonUpd UserCompanyPersonalNumber -- needs special treatment, see ldap_ups above ] - apiEmail = _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI - afiEmail = _avsFirmPrimaryEmail . to (fromMaybe mempty) . from _CI - em_p_up = mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo $ CheckUpdate UserDisplayEmail apiEmail -- Maybe im AvsInfo, aber nicht im User - em_f_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ CheckUpdate UserDisplayEmail afiEmail -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen. + apiEmail = _avsInfoPersonEMail . _Just . from _CI + afiEmail = _avsFirmPrimaryEmail . _Just . from _CI + em_p_up = mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo $ CheckUpdateOpt UserDisplayEmail apiEmail -- Maybe im AvsInfo, aber nicht im User + em_f_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ CheckUpdateOpt UserDisplayEmail afiEmail -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen. eml_up -- Ensure that only one email update is produced; there is no Eq instance for the Update type - | isJust em_f_up, mempty == newAvsFirmInfo ^. afiEmail -- Was some FirmEmail, but this is no longer the case; update to PersonalEmail, if possible - = mkUpdate' usr newAvsPersonInfo Nothing $ CheckUpdate UserDisplayEmail apiEmail + | isJust em_f_up, isNothing (newAvsFirmInfo ^? afiEmail) -- Was some FirmEmail, but this is no longer the case; update to PersonalEmail, if possible + = mkUpdate' usr newAvsPersonInfo Nothing $ CheckUpdateOpt UserDisplayEmail apiEmail | isJust em_f_up -- Update FirmEmail = em_f_up - | isJust em_p_up, mempty == newAvsPersonInfo ^. apiEmail -- Was PersonalEmai, but this is no longer the case; update to FirmEmail, if possible - = mkUpdate' usr newAvsFirmInfo Nothing $ CheckUpdate UserDisplayEmail afiEmail + | isJust em_p_up, isNothing (newAvsPersonInfo ^? apiEmail) -- Was PersonalEmai, but this is no longer the case; update to FirmEmail, if possible + = mkUpdate' usr newAvsFirmInfo Nothing $ CheckUpdateOpt UserDisplayEmail afiEmail | otherwise -- Maybe update PersonalEmail = em_p_up frm_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ -- Legacy, if company postal is stored in user; should no longer be true for new users, diff --git a/src/Handler/Utils/AvsUpdate.hs b/src/Handler/Utils/AvsUpdate.hs new file mode 100644 index 000000000..f94fe1a1d --- /dev/null +++ b/src/Handler/Utils/AvsUpdate.hs @@ -0,0 +1,70 @@ +-- SPDX-FileCopyrightText: 2024 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later +{-# OPTIONS_GHC -fno-warn-unused-top-binds -fno-warn-orphans #-} + +-- Module for Template Haskell functions to be executed at compile time +-- to allow safe static partial functions + +module Handler.Utils.AvsUpdate + ( getUserPersonUpd + , getUserAvsUpd + ) where + + +import Import + +-- import Language.Haskell.TH.Lift +-- import Language.Haskell.TH.Syntax + +-- import Utils.Avs + +deriving instance Lift (EntityField User typ) + +-- instance Lift (CheckUpdate record iraw) where +-- -- liftTyped :: forall (m :: Type -> Type). Quote m => t -> Code m t +-- lift = $(makeLift ''CheckUpdate) + +-- No Lift instance for lenses: +-- type Getting r s a = (a -> Const r a) -> s -> Const r s +-- deriving instance Lift (Getting typ AvsPersonInfo typ) +-- deriving instance Lift (Getting (First typ) AvsPersonInfo typ) +-- deriving instance Lift (CheckUpdate User AvsPersonInfo) + +-- mkUsrPerUpd upd = getUserPersonUpd $$(liftTyped upd) + +-- maybe use a TypeFamily? +getUserPersonUpd :: EntityField User t -> Maybe (CheckUpdate User AvsPersonInfo) +getUserPersonUpd UserFirstName = Just $ CheckUpdate UserFirstName _avsInfoFirstName +getUserPersonUpd UserSurname = Just $ CheckUpdate UserSurname _avsInfoLastName +getUserPersonUpd UserDisplayName = Just $ CheckUpdate UserDisplayName _avsInfoDisplayName +getUserPersonUpd UserBirthday = Just $ CheckUpdate UserBirthday _avsInfoDateOfBirth +getUserPersonUpd UserMobile = Just $ CheckUpdate UserMobile _avsInfoPersonMobilePhoneNo +getUserPersonUpd UserMatrikelnummer = Just $ CheckUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just +getUserPersonUpd UserCompanyPersonalNumber = Just $ CheckUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov +getUserPersonUpd UserLdapPrimaryKey = Just $ CheckUpdate UserLdapPrimaryKey $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just +getUserPersonUpd UserDisplayEmail = Just $ CheckUpdateOpt UserDisplayEmail $ _avsInfoPersonEMail . _Just . from _CI +getUserPersonUpd _ = Nothing -- error "Handler.Utils.AvsUpdate.getPersonUserUpd received unknown argument. This should only occur at compile time." + + +-- -- more general than userPersonUpd, starting at UserAvs instead of AvsPersonInfo +getUserAvsUpd :: EntityField User t -> Maybe (CheckUpdate User UserAvs) +getUserAvsUpd UserPinPassword = Just $ CheckUpdateOpt UserPinPassword $ _userAvsLastCardNo . _Just . to avsFullCardNo2pin . re _Just +getUserAvsUpd UserPostAddress = Just $ CheckUpdateOpt UserPostAddress $ _userAvsLastFirmInfo . _Just . _avsFirmPostAddress +getUserAvsUpd UserFirstName = Just $ CheckUpdateOpt UserFirstName $ _userAvsLastPersonInfo . _Just . _avsInfoFirstName +getUserAvsUpd UserSurname = Just $ CheckUpdateOpt UserSurname $ _userAvsLastPersonInfo . _Just . _avsInfoLastName +getUserAvsUpd UserDisplayName = Just $ CheckUpdateOpt UserDisplayName $ _userAvsLastPersonInfo . _Just . _avsInfoDisplayName +getUserAvsUpd UserBirthday = Just $ CheckUpdateOpt UserBirthday $ _userAvsLastPersonInfo . _Just . _avsInfoDateOfBirth +getUserAvsUpd UserMobile = Just $ CheckUpdateOpt UserMobile $ _userAvsLastPersonInfo . _Just . _avsInfoPersonMobilePhoneNo +getUserAvsUpd UserMatrikelnummer = Just $ CheckUpdateOpt UserMatrikelnummer $ _userAvsLastPersonInfo . _Just . _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just +getUserAvsUpd UserCompanyPersonalNumber = Just $ CheckUpdateOpt UserCompanyPersonalNumber $ _userAvsLastPersonInfo . _Just . _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov +getUserAvsUpd UserLdapPrimaryKey = Just $ CheckUpdateOpt UserLdapPrimaryKey $ _userAvsLastPersonInfo . _Just . _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just +getUserAvsUpd UserDisplayEmail = Just $ CheckUpdateOpt UserDisplayEmail $ _userAvsLastPersonInfo . _Just . _avsInfoPersonEMail . _Just . from _CI +{- Type system does not manage: +getUserAvsUpd ent + -- | Just (CheckUpdate _ pl) <- getUserPersonUpd ent + -- = Just $ CheckUpdateOpt ent $ _userAvsLastPersonInfo . _Just . pl + | Just (CheckUpdateOpt _ pl) <- getUserPersonUpd ent + = Just $ CheckUpdateOpt ent $ _userAvsLastPersonInfo . _Just . pl +-} +getUserAvsUpd _ = Nothing \ No newline at end of file diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index cfd41c530..bc6e8d284 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -8,6 +8,7 @@ module Utils.DB where import ClassyPrelude.Yesod hiding (addMessageI) +import qualified Data.Monoid as Monoid (First()) import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Set as Set @@ -25,6 +26,8 @@ import Database.Persist.Sql (runSqlConn) -- , updateWhereCount) import GHC.Stack (HasCallStack, CallStack, callStack) +-- import Language.Haskell.TH.Lift + -- import Control.Monad.Fix (MonadFix) -- import Control.Monad.Fail (MonadFail) @@ -335,12 +338,24 @@ instance WithRunDB backend m (ReaderT backend m) where -- A datatype for a specific heterogeneous list to compute DB updates, consisting of a persistent record field and a fitting lens -data CheckUpdate record iraw = forall typ. (Eq typ, PersistField typ) => CheckUpdate (EntityField record typ) (Getting typ iraw typ) -- A persistent record field and fitting getting +data CheckUpdate record iraw = + forall typ. (Eq typ, PersistField typ) => + CheckUpdate (EntityField record typ) (Getting typ iraw typ) -- A persistent record field and fitting getting (also use for typ ~ Maybe typ') + | forall typ. (Eq typ, PersistField typ) => + CheckUpdateOpt (EntityField record typ) (Getting (Monoid.First typ) iraw typ) -- Special case, when `typ` is optional for the lens, but not optional in DB. + +-- deriving instance Lift (CheckUpdate record iraw) -- not possible +-- instance Lift (CheckUpdate record iraw) where +-- lift = $(makeLift ''CheckUpdate) mayUpdate :: PersistEntity record => record -> Maybe iraw -> CheckUpdate record iraw -> Bool mayUpdate ent (Just old) (CheckUpdate up l) | let oldval = old ^. l - , let entval = ent ^. fieldLensVal up + , let entval = ent ^. fieldLensVal up + = oldval == entval +mayUpdate ent (Just old) (CheckUpdateOpt up l) + | Just oldval <- old ^? l + , let entval = ent ^. fieldLensVal up = oldval == entval mayUpdate _ _ _ = False @@ -354,6 +369,13 @@ mkUpdate ent new (Just old) (CheckUpdate up l) , newval /= entval , oldval == entval = Just (up =. newval) +mkUpdate ent new (Just old) (CheckUpdateOpt up l) + | Just newval <- new ^? l + , Just oldval <- old ^? l + , let entval = ent ^. fieldLensVal up + , newval /= entval + , oldval == entval + = Just (up =. newval) mkUpdate _ _ _ _ = Nothing -- | Like `mkUpdate` but performs the update even if there was no old value to check if the value had been edited @@ -367,14 +389,24 @@ mkUpdateDirect ent new (CheckUpdate up l) , let entval = ent ^. fieldLensVal up , newval /= entval = Just (up =. newval) +mkUpdateDirect ent new (CheckUpdateOpt up l) + | Just newval <- new ^? l + , let entval = ent ^. fieldLensVal up + , newval /= entval + = Just (up =. newval) mkUpdateDirect _ _ _ = Nothing --- | Unconditionally update a record through ChecUpdate +-- | Unconditionally update a record through CheckUpdate updateRecord :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> record updateRecord ent new (CheckUpdate up l) = let newval = new ^. l lensRec = fieldLensVal up in ent & lensRec .~ newval +updateRecord ent new (CheckUpdateOpt up l) + | Just newval <- new ^? l + = ent & fieldLensVal up .~ newval + | otherwise + = ent -- | like mkUpdate' but only returns the update if the new value would be unique -- mkUpdateCheckUnique' :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> DB (Maybe (Update record)) @@ -388,6 +420,13 @@ mkUpdateCheckUnique' ent new Nothing (CheckUpdate up l) = do newval_exists <- exists [up ==. newval] return $ toMaybe (not newval_exists) (up =. newval) +mkUpdateCheckUnique' ent new Nothing (CheckUpdateOpt up l) + | Just newval <- new ^? l + , let entval = ent ^. fieldLensVal up + , newval /= entval + = do + newval_exists <- exists [up ==. newval] + return $ toMaybe (not newval_exists) (up =. newval) mkUpdateCheckUnique' ent new (Just old) (CheckUpdate up l) | let newval = new ^. l , let oldval = old ^. l @@ -397,4 +436,13 @@ mkUpdateCheckUnique' ent new (Just old) (CheckUpdate up l) = do newval_exists <- exists [up ==. newval] return $ toMaybe (not newval_exists) (up =. newval) +mkUpdateCheckUnique' ent new (Just old) (CheckUpdateOpt up l) + | Just newval <- new ^? l + , Just oldval <- old ^? l + , let entval = ent ^. fieldLensVal up + , newval /= entval + , oldval == entval + = do + newval_exists <- exists [up ==. newval] + return $ toMaybe (not newval_exists) (up =. newval) mkUpdateCheckUnique' _ _ _ _ = return Nothing