chore(daily): towards #2347 by caching and sorting results
This commit is contained in:
parent
9d4dde069c
commit
97db5caff9
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user