fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(daily): properly implement note suggestion caching and invalidation

Browse Source
This commit is contained in:
Steffen Jost 2024-11-27 16:04:34 +01:00
parent 2af3ffb73a
commit 5e3118f33f
1 changed files with 45 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
src/Handler/School/DayTasks.hs
View File

@ -9,6 +9,7 @@
module Handler.School.DayTasks module Handler.School.DayTasks
( getSchoolDayR, postSchoolDayR ( getSchoolDayR, postSchoolDayR
, getSchoolDayCheckR
) where ) where
import Import import Import
@ -71,15 +72,18 @@ getDayTutorials ssh d = E.unValue <<$>> E.select (do
) )
-} -}
-- Datatype to be used for memcaching occurrences -- Datatype to be used as key for memcaching DayTask related stuff; note that newtype-CacheKeys are optimized away, so multiple constructors are advisable
data OccurrenceCacheKey = OccurrenceCacheKeyTutorials SchoolId (Day,Day) data DailyCacheKeys
= CacheKeyTutorialOccurrences SchoolId (Day,Day)
| CacheKeySuggsParticipantNote SchoolId TutorialId
| CacheKeySuggsAttendanceNote SchoolId TutorialId
deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Read, Show, Generic)
deriving anyclass (Hashable, Binary) deriving anyclass (Hashable, Binary, NFData)
getDayTutorials :: SchoolId -> (Day,Day) -> DB [TutorialId] getDayTutorials :: SchoolId -> (Day,Day) -> DB [TutorialId]
getDayTutorials ssh dlimit@(dstart, dend ) getDayTutorials ssh dlimit@(dstart, dend )
| dstart > dend = return mempty | dstart > dend = return mempty
| otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (OccurrenceCacheKeyTutorials ssh dlimit) $ do | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (CacheKeyTutorialOccurrences ssh dlimit) $ do
candidates <- E.select $ do candidates <- E.select $ do
(trm :& crs :& tut) <- E.from $ E.table @Term (trm :& crs :& tut) <- E.from $ E.table @Term
`E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId) `E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId)
@ -300,7 +304,7 @@ colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialN
suggsParticipantNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text) suggsParticipantNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text)
suggsParticipantNote sid cid tid = do suggsParticipantNote sid cid tid = do
ol <- $(memcachedByHere) (Just . Right $ 12 * diffSecond) (sid,cid,tid) $ do -- memcached key good enough? ol <- memcachedBy (Just . Right $ 2 * diffHour) (CacheKeySuggsParticipantNote sid tid) $ do
suggs <- runDB $ E.select $ do suggs <- runDB $ E.select $ do
let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
(tpn, prio) <- E.from $ (tpn, prio) <- E.from $
@ -351,7 +355,7 @@ suggsParticipantNote sid cid tid = do
suggsAttendanceNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text) suggsAttendanceNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text)
suggsAttendanceNote sid cid tid = do suggsAttendanceNote sid cid tid = do
ol <- $(memcachedByHere) (Just . Right $ 12 * diffSecond) (sid,cid,tid) $ do -- memcached key good enough? ol <- memcachedBy (Just . Right $ 2* diffHour) (CacheKeySuggsAttendanceNote sid tid) $ do
suggs <- runDB $ E.select $ do suggs <- runDB $ E.select $ do
let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
(tpn, prio) <- E.from $ (tpn, prio) <- E.from $
@ -608,7 +612,7 @@ mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case
-- return (act, jobSet) -- return (act, jobSet)
psValidator = def & defaultSorting [SortAscBy "user-name", SortAscBy "course", SortAscBy "tutorial"] psValidator = def & defaultSorting [SortAscBy "user-name", SortAscBy "course", SortAscBy "tutorial"]
-- over _1 postprocess <$> dbTable psValidator DBTable{..} -- over _1 postprocess <$> dbTable psValidator DBTable{..}
(over _2 Just) <$> dbTable psValidator DBTable{..} over _2 Just <$> dbTable psValidator DBTable{..}
getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html
@ -628,29 +632,32 @@ postSchoolDayR ssh nd = do
(fmap unFormResult -> tableRes, tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd (fmap unFormResult -> tableRes, tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd
-- logInfoS "****DailyTable****" $ tshow tableRes -- logInfoS "****DailyTable****" $ tshow tableRes
formResult tableRes $ \resMap -> do formResult tableRes $ \resMap -> do
runDB $ do tuts <- runDB $ forM (Map.toList resMap) $ \(tpid, DailyFormData{..}) -> do
forM_ (Map.toList resMap) $ \(tpid, DailyFormData{..}) -> do -- logDebugS "TableForm" (tshow dfd)
-- logDebugS "TableForm" (tshow dfd) TutorialParticipant{..} <- get404 tpid -- needed anyway to find the ParticipantDay/UserDay updated
TutorialParticipant{..} <- get404 tpid -- needed anyway to find the ParticipantDay/UserDay updated when ( tutorialParticipantDrivingPermit /= dailyFormDrivingPermit
when ( tutorialParticipantDrivingPermit /= dailyFormDrivingPermit || tutorialParticipantEyeExam /= dailyFormEyeExam
|| tutorialParticipantEyeExam /= dailyFormEyeExam || tutorialParticipantNote /= dailyFormParticipantNote) $
|| tutorialParticipantNote /= dailyFormParticipantNote) $ update tpid [ TutorialParticipantDrivingPermit =. dailyFormDrivingPermit
update tpid [ TutorialParticipantDrivingPermit =. dailyFormDrivingPermit , TutorialParticipantEyeExam =. dailyFormEyeExam
, TutorialParticipantEyeExam =. dailyFormEyeExam , TutorialParticipantNote =. dailyFormParticipantNote
, TutorialParticipantNote =. dailyFormParticipantNote ]
] let tpdUq = UniqueTutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd
let tpdUq = UniqueTutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd if not dailyFormAttendance && isNothing (canonical dailyFormAttendanceNote)
if not dailyFormAttendance && isNothing (canonical dailyFormAttendanceNote) then deleteBy tpdUq
then deleteBy tpdUq else upsertBy_ tpdUq (TutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd dailyFormAttendance dailyFormAttendanceNote)
else upsertBy_ tpdUq (TutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd dailyFormAttendance dailyFormAttendanceNote) [ TutorialParticipantDayAttendance =. dailyFormAttendance
[ TutorialParticipantDayAttendance =. dailyFormAttendance , TutorialParticipantDayNote =. dailyFormAttendanceNote
, TutorialParticipantDayNote =. dailyFormAttendanceNote ]
] let udUq = UniqueUserDay tutorialParticipantUser nd
let udUq = UniqueUserDay tutorialParticipantUser nd updateUserDay = if dailyFormParkingToken
updateUserDay = if dailyFormParkingToken then flip upsertBy_ (UserDay tutorialParticipantUser nd dailyFormParkingToken) -- upsert if a permit was issued
then flip upsertBy_ (UserDay tutorialParticipantUser nd dailyFormParkingToken) -- upsert if a permit was issued else updateBy -- only update to no permit, if the record exists, but do not create a fresh record with parkingToken==False
else updateBy -- only update to no permit, if the record exists, but do not create a fresh record with parkingToken==False updateUserDay udUq [ UserDayParkingToken =. dailyFormParkingToken]
updateUserDay udUq [ UserDayParkingToken =. dailyFormParkingToken] return $ tutorialParticipantTutorial
forM_ tuts $ \tid -> do
memcachedByInvalidate (CacheKeySuggsParticipantNote ssh tid) $ Proxy @(OptionListCacheable Text)
memcachedByInvalidate (CacheKeySuggsAttendanceNote ssh tid) $ Proxy @(OptionListCacheable Text)
-- audit log? Currently decided against. -- audit log? Currently decided against.
addMessageI Success $ MsgTutorialParticipantsDayEdits dday addMessageI Success $ MsgTutorialParticipantsDayEdits dday
redirect $ SchoolR ssh $ SchoolDayR nd redirect $ SchoolR ssh $ SchoolDayR nd
@ -659,3 +666,11 @@ postSchoolDayR ssh nd = do
setTitleI (MsgMenuSchoolDay ssh dday) setTitleI (MsgMenuSchoolDay ssh dday)
$(i18nWidgetFile "day-view") $(i18nWidgetFile "day-view")
getSchoolDayCheckR :: SchoolId -> Day -> Handler Html
getSchoolDayCheckR ssh nd = do
-- isAdmin <- hasReadAccessTo AdminR
dday <- formatTime SelFormatDate nd
siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do
setTitleI (MsgMenuSchoolDay ssh dday)
[whamlet|TODO: this is just a stub.|]