fix(avs): fix rare avs update bug involving values optional in avs but compulsory in user entity
This commit is contained in:
parent
cf019e6daa
commit
a6d0105903
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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,
|
||||
|
||||
70
src/Handler/Utils/AvsUpdate.hs
Normal file
70
src/Handler/Utils/AvsUpdate.hs
Normal file
@ -0,0 +1,70 @@
|
||||
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- 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
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user