From 612a931d36fdf81252ac84896f8e30a89cb11216 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 28 Nov 2024 17:04:59 +0100 Subject: [PATCH] chore(daily): towards #2347 by performing AVS queries/updates actual checking of retrieved values is still a todo --- src/Handler/School/DayTasks.hs | 44 ++++++++++++++++++++++-------- src/Handler/Utils/Avs.hs | 3 ++ src/Jobs/Handler/SynchroniseAvs.hs | 6 ++++ src/Jobs/Types.hs | 3 ++ src/Model/Types/Avs.hs | 14 +++++----- 5 files changed, 52 insertions(+), 18 deletions(-) diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 89fce81c9..be7efc3bb 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -6,6 +6,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- TODO during development only {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TODO during development only +{-# OPTIONS_GHC -fno-warn-unused-matches #-} -- TODO during development only module Handler.School.DayTasks ( getSchoolDayR, postSchoolDayR @@ -17,6 +18,7 @@ import Import import Handler.Utils import Handler.Utils.Company import Handler.Utils.Occurrences +import Handler.Utils.Avs import qualified Data.Set as Set import qualified Data.Map as Map @@ -106,7 +108,7 @@ data DailyCacheKeys -- | like the previous version above, but also returns the lessons occurring within the given time frame -- Due to caching, we only use the more informative version, unless experiments with the full DB show otherwise -getDayTutorials :: SchoolId -> (Day,Day) -> DB (Map TutorialId [LessonTime]) +getDayTutorials :: SchoolId -> (Day,Day) -> DB (Map TutorialId (TutorialName, [LessonTime])) getDayTutorials ssh dlimit@(dstart, dend ) | dstart > dend = return mempty | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (CacheKeyTutorialOccurrences ssh dlimit) $ do @@ -121,11 +123,11 @@ getDayTutorials ssh dlimit@(dstart, dend ) -- logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates return $ foldMap checkCandidate candidates where - checkCandidate :: (Entity Term, Entity Tutorial) -> Map TutorialId [LessonTime] - checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}}) + checkCandidate :: (Entity Term, Entity Tutorial) -> Map TutorialId (TutorialName, [LessonTime]) + checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ, tutorialName=tName}}) | let lessons = Set.filter lessonFltr $ occurringLessons trm occ , notNull lessons - = Map.singleton tutId $ Set.toAscList lessons -- due to Set not having a Functor instance, we need mostly need lists anyway + = Map.singleton tutId (tName , Set.toAscList lessons) -- due to Set not having a Functor instance, we need mostly need lists anyway | otherwise = mempty @@ -479,10 +481,10 @@ mkDailyTable isAdmin ssh nd = getDayTutorials ssh (nd,nd) >>= \case = row ^. resultCourse . _entityVal tutName = row ^. resultTutorial . _entityVal . _tutorialName in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName - , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \(view $ resultTutorial . _entityKey -> tutId) -> cellMaybe (lessonTimesCell False) $ Map.lookup tutId tutLessons + , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \(view $ resultTutorial . _entityKey -> tutId) -> cellMaybe (lessonTimesCell False . snd) $ Map.lookup tutId tutLessons , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> tutId) -> -- listInlineCell (nubOrd . concat $ mapMM lessonRoom $ Map.lookup tutId tutLessons) roomReferenceCell - cellMaybe ((`listInlineCell` roomReferenceCell) . nubOrd) $ mapMM lessonRoom $ Map.lookup tutId tutLessons + cellMaybe ((`listInlineCell` roomReferenceCell) . nubOrd) $ mapMM lessonRoom $ snd <$> Map.lookup tutId tutLessons -- , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> _) -> listCell ["A","D","C","B"] textCell -- DEMO: listCell reverses the order, for list-types! listInlineCell is fixed now , sortable Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell -- , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid @@ -665,16 +667,36 @@ postSchoolDayR ssh nd = do -- | Prüft die Teilnehmer der Tagesansicht: AVS online aktualisieren, gültigen Vorfeldausweis prüfen, buchende Firma mit Ausweisnummer aus AVS abgleichen getSchoolDayCheckR :: SchoolId -> Day -> Handler Html getSchoolDayCheckR ssh nd = do + now <- liftIO getCurrentTime + let nowaday = utctDay now -- isAdmin <- hasReadAccessTo AdminR + (tuts, parts_avs) <- runDB $ do + tuts <- Map.keys <$> getDayTutorials ssh (nd,nd) + -- participants <- selectList [TutorialParticipantTutorial <-. tuts] [] + parts_avs <- E.select $ do + (tpa :& avs) <- E.from $ E.table @TutorialParticipant + `E.leftJoin` E.table @UserAvs + `E.on` (\(tpa :& avs) -> tpa E.^. TutorialParticipantUser E.=?. avs E.?. UserAvsUser) + E.where_ $ tpa E.^. TutorialParticipantTutorial `E.in_` E.vals tuts + E.orderBy [E.asc $ tpa E.^. TutorialParticipantTutorial] + return (tpa, avs E.?. UserAvsPersonId) -- , avs E.?. UserAvsNoPerson) + -- additionally queue proper AVS synchs for all users, unless there were already done today + void $ queueAvsUpdateByUID (foldMap (^. _1 . _entityVal . _tutorialParticipantUser . to Set.singleton) parts_avs) (Just nowaday) + return (tuts, parts_avs) + -- avsStats :: Map AvsPersonId AvsDataPerson + avsStats <- catchAVShandler False False True mempty $ lookupAvsUsers $ foldMap (foldMap Set.singleton . E.unValue . snd) parts_avs -- query AVS, but does not affect DB (no update) - -- runDB $ do - -- tuts <- getDayTutorials ssh (nd,nd) - -- TODO CONTINUE HERE + -- gültigen Vorfeldausweis prüfen, buchende Firma mit Ausweisnummer aus AVS abgleichen + -- traverse part_avs sorted by tuts, lookup name and check each person dday <- formatTime SelFormatDate nd siteLayoutMsg MsgMenuSchoolDayCheck $ do setTitleI MsgMenuSchoolDayCheck [whamlet| - TODO: this is just a stub. - _{MsgMenuSchoolDay ssh dday} +

+ TODO: this is just a stub! +

+ _{MsgMenuSchoolDay ssh dday} +

+ #{tshow (Map.size avsStats)} |] \ No newline at end of file diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index b331357e7..338eef719 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -13,6 +13,7 @@ module Handler.Utils.Avs , upsertAvsUserByCard , upsertAvsUserById , updateAvsUserByIds + , updateAvsUserByADC , linktoAvsUserByUIDs , queueAvsUpdateByUID, queueAvsUpdateByAID -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface @@ -29,6 +30,7 @@ module Handler.Utils.Avs -- CR3 , SomeAvsQuery(..) , queryAvsCardNo, queryAvsCardNos + , catchAVShandler ) where import Import @@ -717,6 +719,7 @@ upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi u oldSupId <- getOldId reportAdminProblem $ AdminProblemCompanySuperiorNotFound mbSupEmail cid oldSupId +-- | queue AVS synch for several UserIds, if a day is given, the last synch must be before the date to trigger an update queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> DB Int64 queueAvsUpdateByUID uids = queueAvsUpdateAux (E.table @User) (E.^. UserId) (\usr -> usr E.^. UserId `E.in_` E.vals uids) diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index 67f9a9399..a65ac5f37 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -8,6 +8,7 @@ module Jobs.Handler.SynchroniseAvs -- , dispatchJobSynchroniseAvsUser , dispatchJobSynchroniseAvsQueue , dispatchJobSynchroniseAvsLicences + , dispatchJobSynchroniseByAvsDataContact ) where import Import @@ -185,3 +186,8 @@ dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel when (synchLevel >= 3) $ procLic AvsLicenceVorfeld False $ fltrIds avsLicenceDiffRevokeRollfeld --downgrade Rollfeld -> Vorfeld when (synchLevel >= 4) $ procLic AvsLicenceRollfeld True $ fltrIds avsLicenceDiffGrantRollfeld --grant Rollfeld + +-- | delayed exection of already received contact info +dispatchJobSynchroniseByAvsDataContact :: AvsDataContact -> JobHandler UniWorX +dispatchJobSynchroniseByAvsDataContact adc = + JobHandlerException . runDB . void $ updateAvsUserByADC adc \ No newline at end of file diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index e1eaa1de3..ee48fc99a 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -102,6 +102,9 @@ data Job , jIteration :: Natural , jSynchAfter :: Maybe Day } + | JobSynchroniseByAvsDataContact + { jAvsDataContact :: AvsDataContact + } -- JobSynchroniseAvsUser { jUser :: UserId -- , jSynchAfter :: Maybe Day -- } diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index f0a9540bd..f2fa8032f 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -104,8 +104,8 @@ composeAddress street zipcode city country = toMaybe (notNull compAddr) compAddr ------------------- newtype AvsInternalPersonalNo = AvsInternalPersonalNo { avsInternalPersonalNo :: Text } -- ought to be all digits - deriving (Eq, Ord, Show, Generic) - deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Binary) + deriving (Eq, Ord, Show, Read, Generic) + deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Binary, Hashable) instance E.SqlString AvsInternalPersonalNo -- AvsInternalPersonalNo is an untagged Text with respect to FromJSON/ToJSON, as needed by AVS API @@ -346,7 +346,7 @@ instance FromJSON AvsDataCardColor where parseJSON invalid = prependFailure "parsing AvsDataCardColor failed, " (typeMismatch "String" invalid) -data AvsDataPersonCard = AvsDataPersonCard +data AvsDataPersonCard = AvsDataPersonCard -- returned by AvsQueryPerson and partially by AvsQueryStatus { avsDataValid :: Bool -- card currently valid? Note that AVS encodes booleans as JSON String "true" and "false" and not as JSON booleans , avsDataValidTo :: Maybe Day -- Nothing if returned with AvsResponseStatus , avsDataIssueDate :: Maybe Day -- Nothing if returned with AvsResponseStatus @@ -548,7 +548,7 @@ data AvsPersonInfo = AvsPersonInfo , avsInfoPersonEMail :: Maybe Text , avsInfoPersonMobilePhoneNo :: Maybe Text , avsInfoInternalPersonalNo :: Maybe AvsInternalPersonalNo -- Fraport Personalnummer - } deriving (Eq, Ord, Show, Generic, NFData, Binary) + } deriving (Eq, Ord, Show, Read, Generic, NFData, Binary, Hashable) makeLenses_ ''AvsPersonInfo @@ -594,7 +594,7 @@ data AvsFirmCommunication = AvsFirmCommunication , avsCommunicationCountry :: Maybe Text , avsCommunicationStreetANDHouseNo :: Maybe Text , avsCommunicationEMail :: Maybe Text - } deriving (Eq, Ord, Show, Generic, NFData, Binary) + } deriving (Eq, Ord, Show, Read, Generic, NFData, Binary, Hashable) instance {-# OVERLAPS #-} Canonical (Maybe AvsFirmCommunication) where canonical (Just AvsFirmCommunication{..}) @@ -641,7 +641,7 @@ data AvsFirmInfo = AvsFirmInfo , avsFirmEMail :: Maybe Text , avsFirmEMailSuperior :: Maybe Text , avsFirmCommunication :: Maybe AvsFirmCommunication - } deriving (Eq, Ord, Show, Generic, NFData, Binary) + } deriving (Eq, Ord, Show, Read, Generic, NFData, Binary, Hashable) makeLenses_ ''AvsFirmInfo -- additional convenience lenses: @@ -725,7 +725,7 @@ data AvsDataContact = AvsDataContact { avsContactPersonID :: AvsPersonId , avsContactPersonInfo :: AvsPersonInfo , avsContactFirmInfo :: AvsFirmInfo - } deriving (Eq, Ord, Show, Generic, NFData, Binary) + } deriving (Eq, Ord, Show, Read, Generic, NFData, Binary, Hashable) makeLenses_ ''AvsDataContact