From 0eac40457b1b9488d01ada6f8bfc4162da68de1f Mon Sep 17 00:00:00 2001 From: Steffen Date: Thu, 13 Jun 2024 14:51:05 +0200 Subject: [PATCH] chore(avs): add more auto update indicators to profile page --- messages/uniworx/misc/de-de-formal.msg | 2 +- messages/uniworx/misc/en-eu.msg | 2 +- src/Handler/Profile.hs | 6 ++- src/Handler/Utils/Avs.hs | 51 ++++++++++++++++++++++---- src/Utils/Avs.hs | 8 ++-- src/Utils/DB.hs | 6 +++ templates/profileData.hamlet | 10 ++--- 7 files changed, 64 insertions(+), 21 deletions(-) diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index 36db7750e..534ed450c 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index b968ce9c0..cd2073f00 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -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 diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 0515e8daa..34f01e82c 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -588,9 +588,11 @@ 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)) $ userPersonUpd 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 diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 518a6caed..049a9e111 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -31,6 +31,7 @@ module Handler.Utils.Avs -- CR3 , SomeAvsQuery(..) , queryAvsCardNo, queryAvsCardNos + , userPersonUpd ) where import Import @@ -323,6 +324,40 @@ updateAvsUserByIds' apids = do 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 apid newAvsPersonInfo newAvsFirmInfo) = runMaybeT $ do (Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid @@ -355,14 +390,14 @@ 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 + [ userPersonUpd UserFirstName + , userPersonUpd UserSurname + , userPersonUpd UserDisplayName + , userPersonUpd UserBirthday + , userPersonUpd UserMobile + , userPersonUpd UserMatrikelnummer + -- , userPersonUpd UserCompanyPersonalNumber -- needs special treatment, see ldap_ups above ] apiEmail = _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI afiEmail = _avsFirmPrimaryEmail . to (fromMaybe mempty) . from _CI diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 704459f51..1be12ec78 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -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 diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 29b74757d..cfd41c530 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -337,6 +337,12 @@ 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 +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 _ _ _ = 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 diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 29c852786..56b4ed279 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} + _{MsgNameSet} ^{usrAutomatic UserDisplayName}
^{nameWidget userDisplayName userSurname} $maybe matnr <- userMatrikelnummer
- _{MsgTableMatrikelNr} + _{MsgTableMatrikelNr} ^{usrAutomatic 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} + _{MsgTableBirthday} ^{usrAutomatic UserBirthday}
^{formatTimeW SelFormatDate bday}
@@ -96,7 +96,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later #{telephonenr} $maybe mobilenr <- userMobile
- _{MsgUserMobile} + _{MsgUserMobile} ^{usrAutomatic UserMobile}
#{mobilenr} $maybe companyDepartment <- userCompanyDepartment @@ -106,7 +106,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later #{companyDepartment} $maybe companyPersonalNumber <- userCompanyPersonalNumber
- _{MsgCompanyPersonalNumber} + _{MsgCompanyPersonalNumber} ^{usrAutomatic UserCompanyPersonalNumber}
#{companyPersonalNumber} $maybe compWgt <- companies