fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(avs): towards #117 update if current value is Nothing even if oldval == newval

Browse Source 
Damit sollten zumindest die ganzen NULL Fälle bein einem neuen Update erledigt sein. Unklar, wo diese aber herkamen.
This commit is contained in:
Steffen Jost 2024-08-02 16:13:09 +02:00
parent ec02767552
commit d1fa01fcc5
2 changed files with 73 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
src/Handler/Utils/AvsUpdate.hs
View File

@ -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

95
src/Utils/DB.hs
View File

@ -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