From d1fa01fcc5125c4adee8849f9c944884926f78ad Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 2 Aug 2024 16:13:09 +0200 Subject: [PATCH] fix(avs): towards #117 update if current value is Nothing even if oldval == newval MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Damit sollten zumindest die ganzen NULL Fälle bein einem neuen Update erledigt sein. Unklar, wo diese aber herkamen. --- src/Handler/Utils/AvsUpdate.hs | 14 ++--- src/Utils/DB.hs | 95 +++++++++++++++++++++++----------- 2 files changed, 73 insertions(+), 36 deletions(-) diff --git a/src/Handler/Utils/AvsUpdate.hs b/src/Handler/Utils/AvsUpdate.hs index a468d4392..cf0ff1abe 100644 --- a/src/Handler/Utils/AvsUpdate.hs +++ b/src/Handler/Utils/AvsUpdate.hs @@ -67,11 +67,11 @@ instance MkCheckUpdate CU_AvsPersonInfo_User where mkCheckUpdate CU_API_UserFirstName = CheckUpdate UserFirstName _avsInfoFirstName mkCheckUpdate CU_API_UserSurname = CheckUpdate UserSurname _avsInfoLastName mkCheckUpdate CU_API_UserDisplayName = CheckUpdate UserDisplayName _avsInfoDisplayName - mkCheckUpdate CU_API_UserBirthday = CheckUpdate UserBirthday _avsInfoDateOfBirth - mkCheckUpdate CU_API_UserMobile = CheckUpdate UserMobile _avsInfoPersonMobilePhoneNo - 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_UserBirthday = CheckUpdateMay UserBirthday _avsInfoDateOfBirth + mkCheckUpdate CU_API_UserMobile = CheckUpdateMay UserMobile _avsInfoPersonMobilePhoneNo + mkCheckUpdate CU_API_UserMatrikelnummer = CheckUpdateMay UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just + mkCheckUpdate CU_API_UserCompanyPersonalNumber = CheckUpdateMay UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov + mkCheckUpdate CU_API_UserLdapPrimaryKey = CheckUpdateMay 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 data CU_AvsDataContcat_User @@ -82,7 +82,7 @@ data CU_AvsDataContcat_User 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_UserPostAddress = CheckUpdateMay UserPostAddress _avsContactPrimaryPostAddress mkCheckUpdate CU_ADC_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsContactPrimaryEmail . _Just . from _CI data CU_AvsFirmInfo_User @@ -94,7 +94,7 @@ data CU_AvsFirmInfo_User 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_UserPostAddress = CheckUpdateMay UserPostAddress _avsFirmPostAddress -- mkCheckUpdate CU_AFI_UserEmail = CheckUpdateOpt UserEmail $ _avsFirmEMailSuperior . _Just . from _CI -- in rare cases, firm superior email is used as fallback here; but UserEmail must be unique! -- mkCheckUpdate CU_AFI_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsFirmPrimaryEmail . _Just . from _CI -- Maybe im AvsInfo, aber nicht im User, daher Opt diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 3470b2427..7cf9dc8a9 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -43,14 +43,14 @@ getField = view . fieldLensVal -- | Obtain a lens from an EntityField fieldLensVal :: PersistEntity record => EntityField record typ -> Lens' record typ fieldLensVal f = entityLens . fieldLens f - where + where entityLens :: Lens' record (Entity record) entityLens = lens getVal setVal getVal :: record -> Entity record getVal = Entity (error "fieldLensVal unexpectectly required an entity key") -- this is safe, since the lens is only used locally setVal :: record -> Entity record -> record setVal _ = entityVal - + emptyOrIn :: PersistField typ => E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool) @@ -115,16 +115,16 @@ existsKey404 = bool notFound (return ()) <=< existsKey -- | given filter criteria like `selectList` this function returns Just if and only if there is precisely one result -- getByPeseudoUnique -getByFilter :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m) +getByFilter :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m) => [Filter record] -> ReaderT backend m (Maybe (Entity record)) -getByFilter crit = - selectList crit [LimitTo 2] <&> \case +getByFilter crit = + selectList crit [LimitTo 2] <&> \case [singleEntity] -> Just singleEntity _ -> Nothing -- not existing or not unique -getKeyByFilter :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m) +getKeyByFilter :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m) => [Filter record] -> ReaderT backend m (Maybe (Key record)) -getKeyByFilter crit = +getKeyByFilter crit = selectKeysList crit [LimitTo 2] <&> \case [singleKey] -> Just singleKey _ -> Nothing -- not existing or not unique @@ -142,9 +142,9 @@ updateGetEntity k = fmap (Entity k) . updateGet k -- | insert or replace a record based on a single uniqueness constraint -- this function was meant to be supplied with the uniqueness constraint, but it would be unsafe if the uniqueness constraint would not match the supplied record -replaceBy :: (PersistUniqueWrite backend, MonadIO m, OnlyOneUniqueKey record, PersistEntityBackend record ~ BaseBackend backend) +replaceBy :: (PersistUniqueWrite backend, MonadIO m, OnlyOneUniqueKey record, PersistEntityBackend record ~ BaseBackend backend) => record -> ReaderT backend m () -replaceBy r = do +replaceBy r = do u <- onlyUnique r deleteBy u insert_ r @@ -189,15 +189,15 @@ replaceEntity Entity{..} = replace entityKey entityVal -- * Unique denotes old record -- * Changes to fields involved in uniqueness work, but may throw an error if updated record already exists --- | Safe version of upsertBy which does nothing if the new or updated record would violate a uniqueness constraint +-- | Safe version of upsertBy which does nothing if the new or updated record would violate a uniqueness constraint upsertBySafe :: ( MonadIO m , PersistEntity record , PersistUniqueWrite backend , PersistEntityBackend record ~ BaseBackend backend - ) + ) => Unique record -> record -> (record -> record) -> ReaderT backend m (Maybe (Key record)) upsertBySafe uniq newr upd = maybeM (insertUnique newr) do_upd (getBy uniq) - where + where do_upd Entity{entityKey = oid, entityVal = oldr} = do delete oid insertUnique $ upd oldr @@ -263,13 +263,13 @@ instance WithRunDB backend m (ReaderT backend m) where useRunDB = id -- Could be used at Handler.Admin.postAdminProblemsR, but not yet elsewhere, thus inlined for now, as it may be too special: --- updateWithMessage +-- updateWithMessage -- :: ( YesodPersist site, PersistEntity val, BackendCompatible SqlBackend (YesodPersistBackend site), PersistEntityBackend val ~ SqlBackend -- , Num a, Ord a, RenderMessage site msg, RedirectUrl site (url,[(Text,Text)])) -- => url -- where to redirect, if changes were mage -- -> [Filter val] -- update filter -- -> [Update val] -- actual update --- -> a -- expected updates +-- -> a -- expected updates -- -> (a -> msg) -- message to add with number of actual changes -- -> HandlerFor site () -- updateWithMessage route flt upd no_req msg = do @@ -290,7 +290,7 @@ instance WithRunDB backend m (ReaderT backend m) where -- DBRunner site -- -> DBRunner' (YesodPersistBackend site) (HandlerFor site) -- fromDBRunner' DBRunner{..} = DBRunner' runDBRunner - + -- toDBRunner :: forall site. -- DBRunner' (YesodPersistBackend site) (HandlerFor site) -- -> DBRunner site @@ -332,27 +332,34 @@ instance WithRunDB backend m (ReaderT backend m) where -- void . atomically $ tryPutTMVar runnerTMVar runner -- return runner -- getRunnerNoLock = maybe getRunner return =<< atomically (tryReadTMVar runnerTMVar) - + -- runCachedDBRunnerUsing act getRunnerNoLock -- 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) => +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) => + | forall typ. (Eq typ, PersistField typ) => + CheckUpdateMay (EntityField record (Maybe typ)) (Getting (Maybe typ) iraw (Maybe typ)) -- Special case, when `typ` is optional everywhere, forces update of Nothing to Just values + | 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, seee Handler.Utils.AvsUpdate for a workaround -- instance Lift (CheckUpdate record iraw) where -- lift = $(makeLift ''CheckUpdate) +-- | checks if an update would be performed, if a new different value would be presented. Should agree with `mkUpdate` familiy of functions 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 - = oldval == entval + = oldval == entval +mayUpdate ent (Just old) (CheckUpdateMay up l) + | let oldval = old ^. l + , let entval = ent ^. fieldLensVal up + = isNothing entval || oldval == entval mayUpdate ent (Just old) (CheckUpdateOpt up l) | Just oldval <- old ^? l , let entval = ent ^. fieldLensVal up @@ -369,6 +376,12 @@ mkUpdate ent new (Just old) (CheckUpdate up l) , newval /= entval , oldval == entval = Just (up =. newval) +mkUpdate ent new (Just old) (CheckUpdateMay up l) + | let newval = new ^. l + , let oldval = old ^. l + , let entval = ent ^. fieldLensVal up + , (isNothing entval && isJust newval) || (newval /= entval && oldval == entval) + = Just (up =. newval) mkUpdate ent new (Just old) (CheckUpdateOpt up l) | Just newval <- new ^? l , Just oldval <- old ^? l @@ -383,12 +396,18 @@ mkUpdate' :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate mkUpdate' ent new Nothing = mkUpdateDirect ent new mkUpdate' ent new just = mkUpdate ent new just +-- | Like `mkUpdate` but performs the update without comparison to a previous older value, whenever current entity value and new value are different mkUpdateDirect :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> Maybe (Update record) mkUpdateDirect ent new (CheckUpdate up l) | let newval = new ^. l , let entval = ent ^. fieldLensVal up , newval /= entval = Just (up =. newval) +mkUpdateDirect ent new (CheckUpdateMay up l) + | let newval = new ^. 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 @@ -398,33 +417,43 @@ mkUpdateDirect _ _ _ = Nothing -- | Unconditionally update a record through CheckUpdate updateRecord :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> record -updateRecord ent new (CheckUpdate up l) = +updateRecord ent new (CheckUpdate up l) = + let newval = new ^. l + lensRec = fieldLensVal up + in ent & lensRec .~ newval +updateRecord ent new (CheckUpdateMay up l) = let newval = new ^. l lensRec = fieldLensVal up in ent & lensRec .~ newval updateRecord ent new (CheckUpdateOpt up l) - | Just newval <- new ^? l + | Just newval <- new ^? l = ent & fieldLensVal up .~ newval | otherwise - = ent + = 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)) -mkUpdateCheckUnique' :: (MonadIO m, PersistQueryRead backend, PersistEntity record, PersistEntityBackend record ~ BaseBackend backend) +mkUpdateCheckUnique' :: (MonadIO m, PersistQueryRead backend, PersistEntity record, PersistEntityBackend record ~ BaseBackend backend) => record -> a -> Maybe a -> CheckUpdate record a -> ReaderT backend m (Maybe (Update record)) - mkUpdateCheckUnique' ent new Nothing (CheckUpdate up l) | let newval = new ^. l , let entval = ent ^. fieldLensVal up , newval /= entval - = do + = do + newval_exists <- exists [up ==. newval] + return $ toMaybe (not newval_exists) (up =. newval) +mkUpdateCheckUnique' ent new Nothing (CheckUpdateMay up l) + | let 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 Nothing (CheckUpdateOpt up l) | Just newval <- new ^? l , let entval = ent ^. fieldLensVal up , newval /= entval - = do + = do newval_exists <- exists [up ==. newval] return $ toMaybe (not newval_exists) (up =. newval) mkUpdateCheckUnique' ent new (Just old) (CheckUpdate up l) @@ -433,7 +462,15 @@ mkUpdateCheckUnique' ent new (Just old) (CheckUpdate up l) , let entval = ent ^. fieldLensVal up , newval /= entval , oldval == entval - = do + = do + newval_exists <- exists [up ==. newval] + return $ toMaybe (not newval_exists) (up =. newval) +mkUpdateCheckUnique' ent new (Just old) (CheckUpdateMay up l) + | let newval = new ^. l + , let oldval = old ^. l + , let entval = ent ^. fieldLensVal up + , (isNothing entval && isJust newval) || (newval /= entval && oldval == entval) + = do newval_exists <- exists [up ==. newval] return $ toMaybe (not newval_exists) (up =. newval) mkUpdateCheckUnique' ent new (Just old) (CheckUpdateOpt up l) @@ -442,7 +479,7 @@ mkUpdateCheckUnique' ent new (Just old) (CheckUpdateOpt up l) , let entval = ent ^. fieldLensVal up , newval /= entval , oldval == entval - = do + = do newval_exists <- exists [up ==. newval] return $ toMaybe (not newval_exists) (up =. newval) mkUpdateCheckUnique' _ _ _ _ = return Nothing