From 97db5caff9e45c666c7c6c24e130d498c9ac6df1 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 29 Nov 2024 16:19:16 +0100 Subject: [PATCH] chore(daily): towards #2347 by caching and sorting results --- src/Handler/School/DayTasks.hs | 59 ++++++++++++++++++++-------------- 1 file changed, 35 insertions(+), 24 deletions(-) diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index f600edc27..522384858 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -79,6 +79,7 @@ data DailyCacheKeys = CacheKeyTutorialOccurrences SchoolId (Day,Day) | CacheKeySuggsParticipantNote SchoolId TutorialId | CacheKeySuggsAttendanceNote SchoolId TutorialId + | CacheKeyTutorialCheckResults SchoolId Day deriving (Eq, Ord, Read, Show, Generic) deriving anyclass (Hashable, Binary, NFData) @@ -352,7 +353,7 @@ suggsParticipantNote sid cid tid = do suggsAttendanceNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text) suggsAttendanceNote sid cid tid = do - ol <- memcachedBy (Just . Right $ 2* diffHour) (CacheKeySuggsAttendanceNote sid tid) $ do + ol <- memcachedBy (Just . Right $ 2 * diffHour) (CacheKeySuggsAttendanceNote sid tid) $ do suggs <- runDB $ E.select $ do let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows (tpn, prio) <- E.from $ @@ -666,25 +667,32 @@ postSchoolDayR ssh nd = do -- | A wrapper for several check results on tutorial participants data DayCheckResult = DayCheckResult - { dcrEyeFitsPermit :: Maybe Bool - , dcrAvsKnown :: Bool - , dcrApronAccess :: Bool - , dcrBookingFirmOk :: Bool + { dcEyeFitsPermit :: Maybe Bool + , dcAvsKnown :: Bool + , dcApronAccess :: Bool + , dcBookingFirmOk :: Bool } deriving (Show, Generic, Binary) +dcIsOk :: DayCheckResult -> Bool +dcIsOk (DayCheckResult (Just True) True True True) = True +dcIsOk _ = False + data DayCheckResults = DayCheckResults - { dcrResults :: Map TutorialParticipantId DayCheckResult - , dcrTimestamp :: UTCTime + { dcrTimestamp :: UTCTime + , dcrResults :: Map TutorialParticipantId DayCheckResult } deriving (Show, Generic, Binary) +type ParticipantCheckData = (Entity TutorialParticipant, (E.Value UserDisplayName, E.Value UserSurname), E.Value (Maybe AvsPersonId), E.Value (Maybe CompanyName)) + + dayCheckParticipant :: Map AvsPersonId AvsDataPerson - -> (Entity TutorialParticipant, (E.Value UserDisplayName, E.Value UserSurname), E.Value (Maybe AvsPersonId), E.Value (Maybe CompanyName)) + -> ParticipantCheckData -> DayCheckResult dayCheckParticipant avsStats (Entity {entityVal=TutorialParticipant{..}}, (E.Value udn, E.Value usn), E.Value mapi, E.Value mcmp) = - let dcrEyeFitsPermit = liftM2 eyeExamFitsDrivingPermit tutorialParticipantEyeExam tutorialParticipantDrivingPermit - (dcrAvsKnown, (dcrApronAccess, dcrBookingFirmOk)) + let dcEyeFitsPermit = liftM2 eyeExamFitsDrivingPermit tutorialParticipantEyeExam tutorialParticipantDrivingPermit + (dcAvsKnown, (dcApronAccess, dcBookingFirmOk)) | Just AvsDataPerson{avsPersonPersonCards = apcs} <- lookupMaybe avsStats mapi = (True , mapBoth getAny $ foldMap (hasApronAccess &&& fitsBooking mcmp) apcs) | otherwise @@ -709,7 +717,7 @@ getSchoolDayCheckR ssh nd = do (tuts, parts_avs) <- runDB $ do tuts <- Map.keys <$> getDayTutorials ssh (nd,nd) -- participants <- selectList [TutorialParticipantTutorial <-. tuts] [] - parts_avs :: [(Entity TutorialParticipant, (E.Value UserDisplayName, E.Value UserSurname), E.Value (Maybe AvsPersonId), E.Value (Maybe CompanyName))] + parts_avs :: [ParticipantCheckData] <- E.select $ do (tpa :& usr :& avs :& cmp) <- E.from $ E.table @TutorialParticipant `E.innerJoin` E.table @User @@ -719,25 +727,28 @@ getSchoolDayCheckR ssh nd = do `E.leftJoin` E.table @Company `E.on` (\(tpa :& _ :& _ :& cmp) -> tpa E.^. TutorialParticipantCompany E.==. cmp E.?. CompanyId) E.where_ $ tpa E.^. TutorialParticipantTutorial `E.in_` E.vals tuts - E.orderBy [E.asc $ tpa E.^. TutorialParticipantTutorial, E.asc $ usr E.^. UserDisplayName] + -- E.orderBy [E.asc $ tpa E.^. TutorialParticipantTutorial, E.asc $ usr E.^. UserDisplayName] -- order no longer needed return (tpa, (usr E.^. UserDisplayName, usr E.^. UserSurname), avs E.?. UserAvsPersonId, cmp E.?. CompanyName) -- 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) - let getApi :: (Entity TutorialParticipant, (E.Value UserDisplayName, E.Value UserSurname), E.Value (Maybe AvsPersonId), E.Value (Maybe CompanyName)) -> Set AvsPersonId + let getApi :: ParticipantCheckData -> Set AvsPersonId getApi = foldMap Set.singleton . E.unValue . view _3 - avsStats :: Map AvsPersonId AvsDataPerson - <- catchAVShandler False False True mempty $ lookupAvsUsers $ foldMap getApi parts_avs -- query AVS, but does not affect DB (no update) - -- let compsUsed :: Set CompanyName = Set.fromList $ foldMap (^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just . to stripCI) avsStats - -- compDict :: Map CompanyName CompanyId <- fmap (Map.fromAscList . fmap $(unValueN 2)) $ runDBRead $ E.select $ do - -- cmp <- E.from $ E.table @Company - -- E.where_ $ cmp E.^. CompanyName `E.in_` E.vals compsUsed - -- E.orderBy [E.asc $ cmp E.^. CompanyName, E.asc $ cmp E.^. CompanyAvsId] - -- return (cmp E.^. CompanyName, cmp E.^. CompanyId) - + avsStats :: Map AvsPersonId AvsDataPerson <- catchAVShandler False False True mempty $ lookupAvsUsers $ foldMap getApi parts_avs -- query AVS, but does not affect DB (no update) -- gültigen Vorfeldausweis prüfen, buchende Firma mit Ausweisnummer aus AVS abgleichen - -- traverse part_avs sorted by tuts, lookup name and check each person - -- dayCheckParticipant parts_avs + let toPartMap :: ParticipantCheckData -> Map TutorialParticipantId DayCheckResult + toPartMap pcd = Map.singleton (pcd ^. _1 . _entityKey) $ dayCheckParticipant avsStats pcd + particpantResults = foldMap toPartMap parts_avs + memcachedBySet (Just . Right $ 2 * diffHour) (CacheKeyTutorialCheckResults ssh nd) $ DayCheckResults now particpantResults + -- the following is only for displaying results neatly + let sortBadParticipant acc pcd = + let tid = pcd ^. _1 . _entityVal . _tutorialParticipantTutorial + pid = pcd ^. _1 . _entityKey + udn = pcd ^. _2 . _1 . _unValue + ok = maybe False dcIsOk $ Map.lookup pid particpantResults + in if ok then acc else Map.insertWith (<>) tid (Map.singleton (udn,pid) pcd) acc + badTutPartMap :: Map TutorialId (Map (UserDisplayName, TutorialParticipantId) ParticipantCheckData) + badTutPartMap = foldl' sortBadParticipant mempty parts_avs dday <- formatTime SelFormatDate nd siteLayoutMsg MsgMenuSchoolDayCheck $ do