From ab5e432b77bc083e1c326e624f119c2b307069cf Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 19 Jun 2024 15:10:23 +0200 Subject: [PATCH] refactor(avs): use associated type family to consistently produce CheckUpdate --- src/Handler/Profile.hs | 5 +- src/Handler/Utils/Avs.hs | 40 ++++----- src/Handler/Utils/AvsUpdate.hs | 148 ++++++++++++++++++++++----------- src/Utils/DB.hs | 6 +- templates/profileData.hamlet | 10 +-- 5 files changed, 122 insertions(+), 87 deletions(-) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index d23dce687..0a0985a4e 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -592,9 +592,8 @@ makeProfileData :: Entity User -> DB Widget 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)) $ getUserPersonUpd upd - -- usrAutomatic upd = updateAutomatic $ maybe False (mayUpdate usrVal avsId) $ getUserAvsUpd upd + let usrAutomatic :: CU_UserAvs_User -> Widget + usrAutomatic = updateAutomatic . mayUpdate usrVal avsId . mkCheckUpdate (actualPrefersPostal, (actualPostAddress, postalAutomatic), (actualDisplayEmail, emailAutomatic)) <- getPostalPreferenceAndAddress' usrEnt functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] [] diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 1668a2af6..08cc39029 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -351,33 +351,21 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa | otherwise -> return $ mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo) $ bcons (isJust $ newAvsPersonInfo ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo) - ( CheckUpdate UserLdapPrimaryKey $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just) - [ CheckUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just - ] - let per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo) $ catMaybes - [ getUserPersonUpd UserFirstName - , getUserPersonUpd UserSurname - , getUserPersonUpd UserDisplayName - , getUserPersonUpd UserBirthday - , getUserPersonUpd UserMobile - , getUserPersonUpd UserMatrikelnummer - -- , getUserPersonUpd UserCompanyPersonalNumber -- needs special treatment, see ldap_ups above + (mkCheckUpdate CU_API_UserLdapPrimaryKey) + [mkCheckUpdate CU_API_UserCompanyPersonalNumber] + let per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo . mkCheckUpdate) + [ CU_API_UserFirstName + , CU_API_UserSurname + , CU_API_UserDisplayName + , CU_API_UserBirthday + , CU_API_UserMobile + , CU_API_UserMatrikelnummer + -- , CU_API_UserCompanyPersonalNumber -- needs special treatment, see ldap_ups above ] - 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, 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, 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, - CheckUpdate UserPostAddress _avsFirmPostAddress -- since company address should now be referenced with UserCompany instead + eml_up = let em_p_up = mkUpdate usr newAvsPersonInfo oldAvsPersonInfo $ mkCheckUpdate CU_API_UserDisplayEmail + em_f_up = mkUpdate usr newAvsFirmInfo oldAvsFirmInfo $ mkCheckUpdate CU_AFI_UserDisplayEmail + in em_f_up <|> em_p_up -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen. + frm_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ mkCheckUpdate CU_AFI_UserPostAddress -- Legacy, if company postal is stored in user; should no longer be true for new users, since company address should now be referenced with UserCompany instead pin_up = mkUpdate' usr newAvsCardNo oldAvsCardNo $ -- Maybe update PDF pin to latest card CheckUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just usr_up1 = eml_up `mcons` (frm_up `mcons` (pin_up `mcons` (ldap_ups <> per_ups))) diff --git a/src/Handler/Utils/AvsUpdate.hs b/src/Handler/Utils/AvsUpdate.hs index f94fe1a1d..4d37985d9 100644 --- a/src/Handler/Utils/AvsUpdate.hs +++ b/src/Handler/Utils/AvsUpdate.hs @@ -2,69 +2,117 @@ -- -- 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 +module Handler.Utils.AvsUpdate where import Import +{-# ANN module ("HLint: ignore Use camelCase" :: String) #-} + +-- import Utils.Avs + + +-- FAILED ATTEMPTS AT COMPILE-TIME-CHECKS USING TEMPLATE HASKELL: -- import Language.Haskell.TH.Lift -- import Language.Haskell.TH.Syntax - --- import Utils.Avs - -deriving instance Lift (EntityField User typ) - +-- +-- deriving instance Lift (EntityField User typ) -- possible +-- +-- Lift instances for lenses are not possible: +-- 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) +-- instance Lift (CheckUpdate User i) where +-- -- liftTyped :: forall (m :: Type -> Type). Quote m => t -> Code m t +-- liftTyped (CheckUpdate up l) = [||CheckUpdate up l||] +-- liftTyped (CheckUpdateOpt up l) = [||CheckUpdateOpt up l||] +-- -- 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." + +{- + CheckUpdate is usually a statically known pair between a DB record and a lens. + However, lenses cannot be an instance of Lift for compile time checking (see above). + Hence we encode the statically known pairs through a type family. +-} --- -- 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 +class MkCheckUpdate a where + type MCU_Rec a :: Type + type MCU_Raw a :: Type + mkCheckUpdate :: a -> CheckUpdate (MCU_Rec a) (MCU_Raw a) + +data CU_AvsPersonInfo_User + = CU_API_UserFirstName + | CU_API_UserSurname + | CU_API_UserDisplayName + | CU_API_UserBirthday + | CU_API_UserMobile + | CU_API_UserMatrikelnummer + | CU_API_UserCompanyPersonalNumber + | CU_API_UserLdapPrimaryKey + | CU_API_UserDisplayEmail + deriving (Show, Eq) + +instance MkCheckUpdate CU_AvsPersonInfo_User where + type MCU_Rec CU_AvsPersonInfo_User = User + type MCU_Raw CU_AvsPersonInfo_User = AvsPersonInfo + mkCheckUpdate CU_API_UserFirstName = CheckUpdate UserFirstName _avsInfoFirstName + mkCheckUpdate CU_API_UserSurname = CheckUpdate UserFirstName _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_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsInfoPersonEMail . _Just . from _CI -- Maybe im AvsInfo, aber nicht im User, daher Opt + + +data CU_AvsFirmInfo_User + = CU_AFI_UserPostAddress + | CU_AFI_UserDisplayEmail + deriving (Show, Eq) + +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_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsFirmPrimaryEmail . _Just . from _CI -- Maybe im AvsInfo, aber nicht im User, daher Opt + + +-- NOTE: Ensure that the lenses between CU_UserAvs_User and CU_AvsPersonInfo_User/CU_AvsFirmInfo_User agree! +data CU_UserAvs_User + = CU_UA_UserPinPassword + | CU_UA_UserPostAddress + | CU_UA_UserFirstName + | CU_UA_UserSurname + | CU_UA_UserDisplayName + | CU_UA_UserBirthday + | CU_UA_UserMobile + | CU_UA_UserMatrikelnummer + | CU_UA_UserCompanyPersonalNumber + | CU_UA_UserLdapPrimaryKey + | CU_UA_UserDisplayEmail + deriving (Show, Eq) + +instance MkCheckUpdate CU_UserAvs_User where + type MCU_Rec CU_UserAvs_User = User + type MCU_Raw CU_UserAvs_User = UserAvs + mkCheckUpdate CU_UA_UserPinPassword = CheckUpdateOpt UserPinPassword $ _userAvsLastCardNo . _Just . to avsFullCardNo2pin . re _Just + mkCheckUpdate CU_UA_UserPostAddress = CheckUpdateOpt UserPostAddress $ _userAvsLastFirmInfo . _Just . _avsFirmPostAddress + mkCheckUpdate CU_UA_UserFirstName = CheckUpdateOpt UserFirstName $ _userAvsLastPersonInfo . _Just . _avsInfoFirstName + mkCheckUpdate CU_UA_UserSurname = CheckUpdateOpt UserSurname $ _userAvsLastPersonInfo . _Just . _avsInfoLastName + mkCheckUpdate CU_UA_UserDisplayName = CheckUpdateOpt UserDisplayName $ _userAvsLastPersonInfo . _Just . _avsInfoDisplayName + mkCheckUpdate CU_UA_UserBirthday = CheckUpdateOpt UserBirthday $ _userAvsLastPersonInfo . _Just . _avsInfoDateOfBirth + mkCheckUpdate CU_UA_UserMobile = CheckUpdateOpt UserMobile $ _userAvsLastPersonInfo . _Just . _avsInfoPersonMobilePhoneNo + mkCheckUpdate CU_UA_UserMatrikelnummer = CheckUpdateOpt UserMatrikelnummer $ _userAvsLastPersonInfo . _Just . _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just + mkCheckUpdate CU_UA_UserCompanyPersonalNumber = CheckUpdateOpt UserCompanyPersonalNumber $ _userAvsLastPersonInfo . _Just . _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups abov + mkCheckUpdate CU_UA_UserLdapPrimaryKey = CheckUpdateOpt UserLdapPrimaryKey $ _userAvsLastPersonInfo . _Just . _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just + mkCheckUpdate CU_UA_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _userAvsLastPersonInfo . _Just . _avsInfoPersonEMail . _Just . from _CI diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index bc6e8d284..3470b2427 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -344,7 +344,7 @@ data CheckUpdate record iraw = | 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 +-- deriving instance Lift (CheckUpdate record iraw) -- not possible, seee Handler.Utils.AvsUpdate for a workaround -- instance Lift (CheckUpdate record iraw) where -- lift = $(makeLift ''CheckUpdate) @@ -352,11 +352,11 @@ mayUpdate :: PersistEntity record => record -> Maybe iraw -> CheckUpdate record mayUpdate ent (Just old) (CheckUpdate up l) | let oldval = old ^. l , let entval = ent ^. fieldLensVal up - = oldval == entval + = oldval == entval mayUpdate ent (Just old) (CheckUpdateOpt up l) | Just oldval <- old ^? l , let entval = ent ^. fieldLensVal up - = oldval == entval + = oldval == entval mayUpdate _ _ _ = False -- | Compute necessary updates. Given a database record, the new and old raw data, and a pair consisting of a getter from raw data to a value and an EntityField of the same value, diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 56b4ed279..b12eab167 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -30,12 +30,12 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
^{formatTimeW SelFormatDateTime (view _userAvsLastSynch avs)}
- _{MsgNameSet} ^{usrAutomatic UserDisplayName} + _{MsgNameSet} ^{usrAutomatic CU_UA_UserDisplayName}
^{nameWidget userDisplayName userSurname} $maybe matnr <- userMatrikelnummer
- _{MsgTableMatrikelNr} ^{usrAutomatic UserMatrikelnummer} + _{MsgTableMatrikelNr} ^{usrAutomatic CU_UA_UserMatrikelnummer}
^{modalAccess (text2widget matnr) (text2widget matnr) False (AdminAvsUserR cID)} $maybe sex <- userSex @@ -45,7 +45,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later _{sex} $maybe bday <- userBirthday
- _{MsgTableBirthday} ^{usrAutomatic UserBirthday} + _{MsgTableBirthday} ^{usrAutomatic CU_UA_UserBirthday}
^{formatTimeW SelFormatDate bday}
@@ -96,7 +96,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later #{telephonenr} $maybe mobilenr <- userMobile
- _{MsgUserMobile} ^{usrAutomatic UserMobile} + _{MsgUserMobile} ^{usrAutomatic CU_UA_UserMobile}
#{mobilenr} $maybe companyDepartment <- userCompanyDepartment @@ -106,7 +106,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later #{companyDepartment} $maybe companyPersonalNumber <- userCompanyPersonalNumber
- _{MsgCompanyPersonalNumber} ^{usrAutomatic UserCompanyPersonalNumber} + _{MsgCompanyPersonalNumber} ^{usrAutomatic CU_UA_UserCompanyPersonalNumber}
#{companyPersonalNumber} $maybe compWgt <- companies