131 lines
7.7 KiB
Haskell
131 lines
7.7 KiB
Haskell
-- SPDX-FileCopyrightText: 2024-2025 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 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
|
|
--
|
|
-- 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)
|
|
-- mkUsrPerUpd upd = getUserPersonUpd $$(liftTyped upd)
|
|
|
|
|
|
{-
|
|
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.
|
|
-}
|
|
|
|
|
|
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 -- use _avsContactPrimaryEmailAddress instead
|
|
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 UserSurname _avsInfoLastName
|
|
mkCheckUpdate CU_API_UserDisplayName = CheckUpdate UserDisplayName _avsInfoDisplayName
|
|
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_AvsDataContact_User
|
|
= CU_ADC_UserPostAddress
|
|
| CU_ADC_UserDisplayEmail
|
|
deriving (Show, Eq)
|
|
|
|
instance MkCheckUpdate CU_AvsDataContact_User where
|
|
type MCU_Rec CU_AvsDataContact_User = User
|
|
type MCU_Raw CU_AvsDataContact_User = AvsDataContact
|
|
mkCheckUpdate CU_ADC_UserPostAddress = CheckUpdateMay UserPostAddress _avsContactPrimaryPostAddress
|
|
mkCheckUpdate CU_ADC_UserDisplayEmail = CheckUpdateOpt UserDisplayEmail $ _avsContactPrimaryEmail . _Just . from _CI
|
|
|
|
data CU_AvsFirmInfo_User
|
|
= CU_AFI_UserPostAddress
|
|
-- CU_AFI_UserEmail -- PROBLEM: UserEmail must be unique!
|
|
-- CU_AFI_UserDisplayEmail -- use _avsContactPrimaryEmailAddress instead
|
|
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 = 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
|
|
|
|
|
|
-- NOTE: Ensure that the lenses between CU_UserAvs_User and CU_AvsPersonInfo_User/CU_AvsFirmInfo_User agree!
|
|
data CU_UserAvs_User -- only used in templates/profileData.hamlet for detection
|
|
= CU_UA_UserPinPassword
|
|
-- CU_UA_UserPostAddress -- use _avsContactPrimaryPostAddress instead
|
|
| 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 -- use _avsContactPrimaryEmail instead
|
|
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
|