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

refactor(avs): use associated type family to consistently produce CheckUpdate

Browse Source
This commit is contained in:
Steffen Jost 2024-06-19 15:10:23 +02:00
parent a6d0105903
commit ab5e432b77
5 changed files with 122 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
src/Handler/Profile.hs
View File

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

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

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

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

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

6
src/Utils/DB.hs
View File

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

10
templates/profileData.hamlet
View File

@ -30,12 +30,12 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<dd .deflist__dd>
^{formatTimeW SelFormatDateTime (view _userAvsLastSynch avs)}
<dt .deflist__dt>
_{MsgNameSet} ^{usrAutomatic UserDisplayName}
_{MsgNameSet} ^{usrAutomatic CU_UA_UserDisplayName}
<dd .deflist__dd>
^{nameWidget userDisplayName userSurname}
$maybe matnr <- userMatrikelnummer
<dt .deflist__dt>
_{MsgTableMatrikelNr} ^{usrAutomatic UserMatrikelnummer}
_{MsgTableMatrikelNr} ^{usrAutomatic CU_UA_UserMatrikelnummer}
<dd .deflist__dd>
^{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
<dt .deflist__dt>
_{MsgTableBirthday} ^{usrAutomatic UserBirthday}
_{MsgTableBirthday} ^{usrAutomatic CU_UA_UserBirthday}
<dd .deflist__dd>
^{formatTimeW SelFormatDate bday}
<dt .deflist__dt>
@ -96,7 +96,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
#{telephonenr}
$maybe mobilenr <- userMobile
<dt .deflist__dt>
_{MsgUserMobile} ^{usrAutomatic UserMobile}
_{MsgUserMobile} ^{usrAutomatic CU_UA_UserMobile}
<dd .deflist__dd>
#{mobilenr}
$maybe companyDepartment <- userCompanyDepartment
@ -106,7 +106,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
#{companyDepartment}
$maybe companyPersonalNumber <- userCompanyPersonalNumber
<dt .deflist__dt>
_{MsgCompanyPersonalNumber} ^{usrAutomatic UserCompanyPersonalNumber}
_{MsgCompanyPersonalNumber} ^{usrAutomatic CU_UA_UserCompanyPersonalNumber}
<dd .deflist__dd>
#{companyPersonalNumber}
$maybe compWgt <- companies