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

fix(avs): fix rare avs update bug involving values optional in avs but compulsory in user entity

Browse Source
This commit is contained in:
Steffen Jost 2024-06-17 17:50:41 +02:00
parent cf019e6daa
commit a6d0105903
5 changed files with 143 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Data/CaseInsensitive/Instances.hs
View File

@ -128,4 +128,4 @@ instance Swagger.ToSchema s => Swagger.ToSchema (CI s) where
instance (CI.FoldCase s, Binary s) => Binary (CI s) where instance (CI.FoldCase s, Binary s) => Binary (CI s) where
get = CI.mk <$> Binary.get get = CI.mk <$> Binary.get
put = Binary.put . CI.original put = Binary.put . CI.original

5
src/Handler/Profile.hs
View File

@ -21,6 +21,7 @@ module Handler.Profile
import Import import Import
import Handler.Utils import Handler.Utils
import Handler.Utils.AvsUpdate
import Handler.Utils.Avs import Handler.Utils.Avs
import Handler.Utils.Profile import Handler.Utils.Profile
import Handler.Utils.Users import Handler.Utils.Users
@ -592,7 +593,9 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid) avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid)
let usrAutomatic :: forall t . EntityField User t -> Widget 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 (actualPrefersPostal, (actualPostAddress, postalAutomatic), (actualDisplayEmail, emailAutomatic)) <- getPostalPreferenceAndAddress' usrEnt
functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] [] 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 lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do

70
src/Handler/Utils/Avs.hs
View File

@ -4,8 +4,6 @@
{-# LANGUAGE TypeApplications, ExistentialQuantification #-} {-# LANGUAGE TypeApplications, ExistentialQuantification #-}
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
-- Module for functions directly related to the AVS interface, -- Module for functions directly related to the AVS interface,
-- for utilities dealing with FraDrive Qualification types see Handler.Utils.Qualification -- for utilities dealing with FraDrive Qualification types see Handler.Utils.Qualification
-- NOTE: Several ifdef DEVELOPMENT used, so UNSET DEVELOPMENT and build before comitting. -- NOTE: Several ifdef DEVELOPMENT used, so UNSET DEVELOPMENT and build before comitting.
@ -30,8 +28,7 @@ module Handler.Utils.Avs
, AvsPersonIdMapPersonCard , AvsPersonIdMapPersonCard
-- CR3 -- CR3
, SomeAvsQuery(..) , SomeAvsQuery(..)
, queryAvsCardNo, queryAvsCardNos , queryAvsCardNo, queryAvsCardNos
, userPersonUpd
) where ) where
import Import import Import
@ -58,6 +55,7 @@ import Handler.Utils.Users
import Handler.Utils.Company import Handler.Utils.Company
import Handler.Utils.Qualification import Handler.Utils.Qualification
import Handler.Utils.Memcached import Handler.Utils.Memcached
import Handler.Utils.AvsUpdate
import Database.Esqueleto.Experimental ((:&)(..)) import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma 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) import Servant.Client.Core.ClientError (ClientError)
-------------------- --------------------
-- AVS Exceptions -- -- AVS Exceptions --
-------------------- --------------------
@ -324,39 +321,6 @@ updateAvsUserByIds' apids = do
catchAll (runDB updateAvsUserByADC') errHandler 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 -> DB (Maybe (AvsPersonId, UserId))
updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMaybeT $ do updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMaybeT $ do
@ -391,25 +355,25 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa
[ CheckUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just [ CheckUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just
] ]
let per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo) $ catMaybes let per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo) $ catMaybes
[ userPersonUpd UserFirstName [ getUserPersonUpd UserFirstName
, userPersonUpd UserSurname , getUserPersonUpd UserSurname
, userPersonUpd UserDisplayName , getUserPersonUpd UserDisplayName
, userPersonUpd UserBirthday , getUserPersonUpd UserBirthday
, userPersonUpd UserMobile , getUserPersonUpd UserMobile
, userPersonUpd UserMatrikelnummer , getUserPersonUpd UserMatrikelnummer
-- , userPersonUpd UserCompanyPersonalNumber -- needs special treatment, see ldap_ups above -- , getUserPersonUpd UserCompanyPersonalNumber -- needs special treatment, see ldap_ups above
] ]
apiEmail = _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI apiEmail = _avsInfoPersonEMail . _Just . from _CI
afiEmail = _avsFirmPrimaryEmail . to (fromMaybe mempty) . from _CI afiEmail = _avsFirmPrimaryEmail . _Just . from _CI
em_p_up = mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo $ CheckUpdate UserDisplayEmail apiEmail -- Maybe im AvsInfo, aber nicht im User em_p_up = mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo $ CheckUpdateOpt 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. 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 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 | 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 $ CheckUpdate UserDisplayEmail apiEmail = mkUpdate' usr newAvsPersonInfo Nothing $ CheckUpdateOpt UserDisplayEmail apiEmail
| isJust em_f_up -- Update FirmEmail | isJust em_f_up -- Update FirmEmail
= em_f_up = em_f_up
| isJust em_p_up, mempty == newAvsPersonInfo ^. apiEmail -- Was PersonalEmai, but this is no longer the case; update to FirmEmail, if possible | 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 $ CheckUpdate UserDisplayEmail afiEmail = mkUpdate' usr newAvsFirmInfo Nothing $ CheckUpdateOpt UserDisplayEmail afiEmail
| otherwise -- Maybe update PersonalEmail | otherwise -- Maybe update PersonalEmail
= em_p_up = 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, 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
View 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

54
src/Utils/DB.hs
View File

@ -8,6 +8,7 @@ module Utils.DB where
import ClassyPrelude.Yesod hiding (addMessageI) import ClassyPrelude.Yesod hiding (addMessageI)
import qualified Data.Monoid as Monoid (First())
import qualified Data.List as List import qualified Data.List as List
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
@ -25,6 +26,8 @@ import Database.Persist.Sql (runSqlConn) -- , updateWhereCount)
import GHC.Stack (HasCallStack, CallStack, callStack) import GHC.Stack (HasCallStack, CallStack, callStack)
-- import Language.Haskell.TH.Lift
-- import Control.Monad.Fix (MonadFix) -- import Control.Monad.Fix (MonadFix)
-- import Control.Monad.Fail (MonadFail) -- 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 -- 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 :: PersistEntity record => record -> Maybe iraw -> CheckUpdate record iraw -> Bool
mayUpdate ent (Just old) (CheckUpdate up l) mayUpdate ent (Just old) (CheckUpdate up l)
| let oldval = old ^. 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 = oldval == entval
mayUpdate _ _ _ = False mayUpdate _ _ _ = False
@ -354,6 +369,13 @@ mkUpdate ent new (Just old) (CheckUpdate up l)
, newval /= entval , newval /= entval
, oldval == entval , oldval == entval
= Just (up =. newval) = 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 mkUpdate _ _ _ _ = Nothing
-- | Like `mkUpdate` but performs the update even if there was no old value to check if the value had been edited -- | 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 , let entval = ent ^. fieldLensVal up
, newval /= entval , newval /= entval
= Just (up =. newval) = 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 mkUpdateDirect _ _ _ = Nothing
-- | Unconditionally update a record through ChecUpdate -- | Unconditionally update a record through CheckUpdate
updateRecord :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> record 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 let newval = new ^. l
lensRec = fieldLensVal up lensRec = fieldLensVal up
in ent & lensRec .~ newval 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 -- | 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' :: 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 = do
newval_exists <- exists [up ==. newval] newval_exists <- exists [up ==. newval]
return $ toMaybe (not newval_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) mkUpdateCheckUnique' ent new (Just old) (CheckUpdate up l)
| let newval = new ^. l | let newval = new ^. l
, let oldval = old ^. l , let oldval = old ^. l
@ -397,4 +436,13 @@ mkUpdateCheckUnique' ent new (Just old) (CheckUpdate up l)
= do = do
newval_exists <- exists [up ==. newval] newval_exists <- exists [up ==. newval]
return $ toMaybe (not newval_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 mkUpdateCheckUnique' _ _ _ _ = return Nothing