Merge branch 'fradrive/cr3'
This commit is contained in:
commit
d83cb66c8b
@ -15,7 +15,7 @@ WeekDay: Wochentag
|
||||
LdapIdentificationOrEmail: Fraport AG-Kennung / E-Mail-Adresse
|
||||
Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"}
|
||||
Days num@Int64: #{num} #{pluralDE num "Tag" "Tage"}
|
||||
NoAutomaticUpdateTip: Dieser Wert wurde manuell editiert und wird daher nicht mehr automatisch aktualisiert.
|
||||
NoAutomaticUpdateTip: Dieser Wert wurde manuell editiert und wird daher nicht mehr automatisch durch as AVS aktualisiert.
|
||||
|
||||
ClusterVolatileQuickActionsEnabled: Schnellzugriffsmenü aktiv
|
||||
|
||||
|
||||
@ -15,7 +15,7 @@ WeekDay: Day of the week
|
||||
LdapIdentificationOrEmail: Fraport AG-Kennung / email address
|
||||
Months num: #{num} #{pluralEN num "Month" "Months"}
|
||||
Days num: #{num} #{pluralEN num "Day" "Days"}
|
||||
NoAutomaticUpdateTip: This value receives no automatic updates, since it has been edited manually.
|
||||
NoAutomaticUpdateTip: This particular value receives no automatic AVS updates, since it has been edited manually.
|
||||
|
||||
ClusterVolatileQuickActionsEnabled: Quick actions enabled
|
||||
|
||||
|
||||
@ -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
|
||||
@ -588,9 +589,13 @@ getForProfileDataR cID = do
|
||||
dataWidget
|
||||
|
||||
makeProfileData :: Entity User -> DB Widget
|
||||
makeProfileData usrEnt@(Entity uid User{..}) = do
|
||||
now <- liftIO getCurrentTime
|
||||
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
|
||||
|
||||
(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,7 +28,7 @@ module Handler.Utils.Avs
|
||||
, AvsPersonIdMapPersonCard
|
||||
-- CR3
|
||||
, SomeAvsQuery(..)
|
||||
, queryAvsCardNo, queryAvsCardNos
|
||||
, queryAvsCardNo, queryAvsCardNos
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -57,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
|
||||
@ -66,7 +65,6 @@ import qualified Database.Esqueleto.PostgreSQL as E
|
||||
import Servant.Client.Core.ClientError (ClientError)
|
||||
|
||||
|
||||
|
||||
--------------------
|
||||
-- AVS Exceptions --
|
||||
--------------------
|
||||
@ -323,6 +321,7 @@ updateAvsUserByIds' apids = do
|
||||
catchAll (runDB updateAvsUserByADC') errHandler
|
||||
|
||||
|
||||
|
||||
updateAvsUserByADC :: AvsDataContact -> DB (Maybe (AvsPersonId, UserId))
|
||||
updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMaybeT $ do
|
||||
(Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid
|
||||
@ -355,26 +354,26 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa
|
||||
( CheckUpdate UserLdapPrimaryKey $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just)
|
||||
[ CheckUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just
|
||||
]
|
||||
let per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo)
|
||||
[ CheckUpdate UserFirstName _avsInfoFirstName
|
||||
, CheckUpdate UserSurname _avsInfoLastName
|
||||
, CheckUpdate UserDisplayName _avsInfoDisplayName
|
||||
, CheckUpdate UserBirthday _avsInfoDateOfBirth
|
||||
, CheckUpdate UserMobile _avsInfoPersonMobilePhoneNo
|
||||
, CheckUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just`
|
||||
-- , CheckUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups above
|
||||
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
|
||||
]
|
||||
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
|
||||
@ -86,9 +86,9 @@ mkAvsQuery _ _ _ = AvsQuery
|
||||
fakePerson :: AvsQueryPerson -> AvsResponsePerson
|
||||
fakePerson =
|
||||
let
|
||||
sarah = Set.singleton $ AvsDataPerson "Sarah" "Vaupel" Nothing 2 (AvsPersonId 2) mempty
|
||||
stephan = Set.singleton $ AvsDataPerson "Stephan" "Barth" Nothing 4 (AvsPersonId 4) mempty
|
||||
steffen = Set.singleton $ AvsDataPerson "Steffen" "Jost" (Just $ mkAvsInternalPersonalNo "47138") 12345678 (AvsPersonId 12345678) mempty
|
||||
sarah = Set.singleton $ AvsDataPerson "Sarah" "Vaupel" Nothing 2 (AvsPersonId 2) mempty
|
||||
stephan = Set.singleton $ AvsDataPerson "Stephan" "Barth" Nothing 4 (AvsPersonId 4) mempty
|
||||
steffen = Set.singleton $ AvsDataPerson "Steffen" "Jost" (Just $ mkAvsInternalPersonalNo "47138") 12345678 (AvsPersonId 12345678) mempty
|
||||
sumpfi1 = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 12345678) mempty
|
||||
sumpfi2 = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 604387) mempty
|
||||
sumpfi3 = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 604591) mempty
|
||||
@ -112,7 +112,7 @@ mkAvsQuery _ _ _ = AvsQuery
|
||||
]
|
||||
fakeStatus _ = AvsResponseStatus mempty
|
||||
fakeContact :: AvsQueryContact -> AvsResponseContact
|
||||
fakeContact (AvsQueryContact (Set.toList -> ((AvsObjPersonId api):_))) = AvsResponseContact $ Set.singleton $ AvsDataContact api (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Fraport AG" 7 "Fraport" Nothing Nothing Nothing Nothing Nothing Nothing Nothing)
|
||||
fakeContact (AvsQueryContact (Set.toList -> ((AvsObjPersonId api):_))) = AvsResponseContact $ Set.singleton $ AvsDataContact api (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing (Just "jost@tcs.ifi.lmu.de") Nothing) (AvsFirmInfo "Fraport AG" 7 "Fraport" Nothing Nothing Nothing Nothing Nothing Nothing Nothing)
|
||||
fakeContact _ = AvsResponseContact mempty
|
||||
#else
|
||||
mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
|
||||
|
||||
@ -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,8 +338,26 @@ 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
|
||||
= oldval == entval
|
||||
mayUpdate ent (Just old) (CheckUpdateOpt up l)
|
||||
| Just oldval <- old ^? l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
= 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,
|
||||
-- an update is returned, if the current value is identical to the old value, which changed in the new raw data
|
||||
@ -348,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
|
||||
@ -361,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))
|
||||
@ -382,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
|
||||
@ -391,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
|
||||
|
||||
@ -10,7 +10,7 @@ import Import
|
||||
import Text.Hamlet
|
||||
|
||||
-- import Data.Char as Char
|
||||
-- import qualified Data.Text as Text
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Data.FileEmbed (embedFile)
|
||||
@ -19,6 +19,40 @@ import Utils.Print.Letters
|
||||
import Handler.Utils.Widgets (nameHtml) -- , nameHtml')
|
||||
|
||||
|
||||
defaultNotice :: Lang -> Text -> Text -> Text -> [Text]
|
||||
defaultNotice l qualName qualShort newExpire
|
||||
| isDe l
|
||||
= [ [st|Ein Zertifikat für Ihre Unterlagen kann nur direkt nach dem erfolgreichen Test erstellt werden. Das Zertifikat wird auf die Benutzerkennung ausgestellt. Zusammen mit diesem Schreiben können Sie Ihrem Arbeitgeber zeigen, dass Sie bestanden haben. Bei erfolgreichem Abschluss der Schulung verlängert sich das Ablaufdatum automatisch auf den #{newExpire}. Wir empfehlen die Schulung zeitnah durchzuführen. Sollte bis zum Ablaufdatum das E-Learning nicht erfolgreich abgeschlossen sein oder der Test nach 5 Versuchen nicht bestanden werden, muss zur Wiedererlangung der Fahrberechtigung „#{qualShort}“ ein Grundkurs #{qualName} bei der Fahrerausbildung absolviert werden.|]
|
||||
, "Benötigen Sie die Fahrberechtigung nicht mehr, informieren Sie bitte die Fahrerausbildung."
|
||||
, "(Please contact us if you prefer letters in English.)"
|
||||
]
|
||||
|
||||
| otherwise
|
||||
= [ [st|A certificate for your records can only be generated immediately after a successful test. The certificate will be issued for the user login. The certificate and this letter may then prove that you have passed. Upon successful completion of the training, the expiry date will automatically be extended until #{newExpire}. We recommend completing the training as soon as possible. The licence irrevocably expires, if the e-learning is not successfully completed by the expiry date or after 5 failed attempts. In this case, regaining licence "#{qualShort}" requires the completing of a normal training course #{qualName} again, as if no prior experience existed.|]
|
||||
, "Please inform us, if this driving licence is no longer required."
|
||||
, "(Kontaktieren Sie uns bitte, um zukünftige Briefe von uns in deutscher Sprache zu erhalten.)"
|
||||
]
|
||||
|
||||
|
||||
qualificationText :: Lang -> Text -> Text -> (Text, Text, Text)
|
||||
qualificationText l qName@(Text.stripSuffix "führerschein" -> Just qPrefix) qShort
|
||||
| isDe l
|
||||
= (qPrefix, qPrefix <> "fahrberechtigung", qName)
|
||||
| qShort == "F"
|
||||
= ("apron", "apron driving licence", "apron driving licence")
|
||||
| qShort == "R"
|
||||
= ("maneuvering area", "maneuvering area driving licence", "maneuvering area driving licence")
|
||||
| otherwise
|
||||
= (qPrefix, qPrefix <> " driving licence", qName)
|
||||
qualificationText l _qName "GSS"
|
||||
| isDe l
|
||||
= ("Gabelstapler", "Fahrberechtigung Gabelstapler", "Gabelstaplerführerschein")
|
||||
| otherwise
|
||||
= ("Forklift", "forklift driving licence", "forklift driving licence")
|
||||
qualificationText _l qName qShort
|
||||
= (qShort, qName, qName)
|
||||
|
||||
|
||||
data LetterRenewQualification = LetterRenewQualification
|
||||
{ lmsLogin :: LmsIdent
|
||||
, lmsPin :: Text
|
||||
@ -62,6 +96,7 @@ instance MDLetter LetterRenewQualification where
|
||||
let LetterRenewQualificationData{..} = letterRenewalQualificationFData l
|
||||
isSupervised = rcvrId /= qualHolderID
|
||||
newExpire = addDays (fromIntegral $ fromMaybe 0 qualDuration) qualExpiry
|
||||
(qArea, qFormal, qLicence) = qualificationText lang qualName qualShort
|
||||
in mkMeta $
|
||||
guardMonoid isSupervised
|
||||
[ toMeta "supervisor" userDisplayName
|
||||
@ -80,13 +115,13 @@ instance MDLetter LetterRenewQualification where
|
||||
, mbMeta "validduration" (show <$> qualDuration)
|
||||
, toMeta "url-text" lmsUrl
|
||||
, toMeta "url" lmsUrlLogin
|
||||
, toMeta "notice" [ [st|Ein Zertifikat für Ihre Unterlagen kann nur direkt nach dem erfolgreichen Test erstellt werden. Das Zertifikat wird auf die Benutzerkennung ausgestellt. Zusammen mit diesem Schreiben können Sie Ihrem Arbeitgeber zeigen, dass Sie bestanden haben. Bei erfolgreichem Abschluss der Schulung verlängert sich das Ablaufdatum automatisch auf den #{format SelFormatDate newExpire}. Wir empfehlen die Schulung zeitnah durchzuführen. Sollte bis zum Ablaufdatum das E-Learning nicht erfolgreich abgeschlossen sein oder der Test nach 5 Versuchen nicht bestanden werden, muss zur Wiedererlangung der Fahrberechtigung „#{qualShort}“ ein Grundkurs #{qualName} bei der Fahrerausbildung absolviert werden.|]
|
||||
, "Benötigen Sie die Fahrberechtigung nicht mehr, informieren Sie bitte die Fahrerausbildung."::Text
|
||||
, "(Please contact us if you prefer letters in English.)"
|
||||
]
|
||||
, toMeta "notice" $ defaultNotice lang qualName qualShort $ format SelFormatDate newExpire
|
||||
, toMeta "de-subject" [st|Verlängerung Fahrberechtigung „#{qualShort}“ (#{qualName})|]
|
||||
, toMeta "en-subject" [st|Renewal of driving licence „#{qualShort}“ (#{qualName})|]
|
||||
] -- TODO use [st|some simple text with interpolation|]
|
||||
, toMeta "qarea" qArea
|
||||
, toMeta "qformal" qFormal
|
||||
, toMeta "qlicence" qLicence
|
||||
] -- NOTE: use [st|some simple text with interpolation|]
|
||||
|
||||
getPJId LetterRenewQualification{..} =
|
||||
PrintJobIdentification
|
||||
|
||||
@ -21,6 +21,9 @@ encludes:
|
||||
hyperrefoptions: hidelinks
|
||||
|
||||
### Metadaten, welche automatisch ersetzt werden:
|
||||
qarea: 'Vorfeld'
|
||||
qformal: 'Vorfeldfahrberechtigung'
|
||||
qlicence: 'Vorfeldführerschein'
|
||||
url-text: 'drive.fraport.de'
|
||||
url: 'https://drive.fraport.de'
|
||||
date: 11.11.1111
|
||||
|
||||
@ -30,12 +30,12 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<dd .deflist__dd>
|
||||
^{formatTimeW SelFormatDateTime (view _userAvsLastSynch avs)}
|
||||
<dt .deflist__dt>
|
||||
_{MsgNameSet}
|
||||
_{MsgNameSet} ^{usrAutomatic UserDisplayName}
|
||||
<dd .deflist__dd>
|
||||
^{nameWidget userDisplayName userSurname}
|
||||
$maybe matnr <- userMatrikelnummer
|
||||
<dt .deflist__dt>
|
||||
_{MsgTableMatrikelNr}
|
||||
_{MsgTableMatrikelNr} ^{usrAutomatic 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}
|
||||
_{MsgTableBirthday} ^{usrAutomatic 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}
|
||||
_{MsgUserMobile} ^{usrAutomatic 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}
|
||||
_{MsgCompanyPersonalNumber} ^{usrAutomatic UserCompanyPersonalNumber}
|
||||
<dd .deflist__dd>
|
||||
#{companyPersonalNumber}
|
||||
$maybe compWgt <- companies
|
||||
|
||||
Reference in New Issue
Block a user