chore(daily): properly implement note suggestion caching and invalidation
This commit is contained in:
parent
2af3ffb73a
commit
5e3118f33f
@ -9,6 +9,7 @@
|
||||
|
||||
module Handler.School.DayTasks
|
||||
( getSchoolDayR, postSchoolDayR
|
||||
, getSchoolDayCheckR
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -71,15 +72,18 @@ getDayTutorials ssh d = E.unValue <<$>> E.select (do
|
||||
)
|
||||
-}
|
||||
|
||||
-- Datatype to be used for memcaching occurrences
|
||||
data OccurrenceCacheKey = OccurrenceCacheKeyTutorials SchoolId (Day,Day)
|
||||
-- Datatype to be used as key for memcaching DayTask related stuff; note that newtype-CacheKeys are optimized away, so multiple constructors are advisable
|
||||
data DailyCacheKeys
|
||||
= CacheKeyTutorialOccurrences SchoolId (Day,Day)
|
||||
| CacheKeySuggsParticipantNote SchoolId TutorialId
|
||||
| CacheKeySuggsAttendanceNote SchoolId TutorialId
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
deriving anyclass (Hashable, Binary)
|
||||
deriving anyclass (Hashable, Binary, NFData)
|
||||
|
||||
getDayTutorials :: SchoolId -> (Day,Day) -> DB [TutorialId]
|
||||
getDayTutorials ssh dlimit@(dstart, dend )
|
||||
| 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
|
||||
(trm :& crs :& tut) <- E.from $ E.table @Term
|
||||
`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 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
|
||||
let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
|
||||
(tpn, prio) <- E.from $
|
||||
@ -351,7 +355,7 @@ suggsParticipantNote sid cid tid = do
|
||||
|
||||
suggsAttendanceNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text)
|
||||
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
|
||||
let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
|
||||
(tpn, prio) <- E.from $
|
||||
@ -608,7 +612,7 @@ mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case
|
||||
-- return (act, jobSet)
|
||||
psValidator = def & defaultSorting [SortAscBy "user-name", SortAscBy "course", SortAscBy "tutorial"]
|
||||
-- over _1 postprocess <$> dbTable psValidator DBTable{..}
|
||||
(over _2 Just) <$> dbTable psValidator DBTable{..}
|
||||
over _2 Just <$> dbTable psValidator DBTable{..}
|
||||
|
||||
|
||||
getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html
|
||||
@ -628,29 +632,32 @@ postSchoolDayR ssh nd = do
|
||||
(fmap unFormResult -> tableRes, tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd
|
||||
-- logInfoS "****DailyTable****" $ tshow tableRes
|
||||
formResult tableRes $ \resMap -> do
|
||||
runDB $ do
|
||||
forM_ (Map.toList resMap) $ \(tpid, DailyFormData{..}) -> do
|
||||
-- logDebugS "TableForm" (tshow dfd)
|
||||
TutorialParticipant{..} <- get404 tpid -- needed anyway to find the ParticipantDay/UserDay updated
|
||||
when ( tutorialParticipantDrivingPermit /= dailyFormDrivingPermit
|
||||
|| tutorialParticipantEyeExam /= dailyFormEyeExam
|
||||
|| tutorialParticipantNote /= dailyFormParticipantNote) $
|
||||
update tpid [ TutorialParticipantDrivingPermit =. dailyFormDrivingPermit
|
||||
, TutorialParticipantEyeExam =. dailyFormEyeExam
|
||||
, TutorialParticipantNote =. dailyFormParticipantNote
|
||||
]
|
||||
let tpdUq = UniqueTutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd
|
||||
if not dailyFormAttendance && isNothing (canonical dailyFormAttendanceNote)
|
||||
then deleteBy tpdUq
|
||||
else upsertBy_ tpdUq (TutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd dailyFormAttendance dailyFormAttendanceNote)
|
||||
[ TutorialParticipantDayAttendance =. dailyFormAttendance
|
||||
, TutorialParticipantDayNote =. dailyFormAttendanceNote
|
||||
]
|
||||
let udUq = UniqueUserDay tutorialParticipantUser nd
|
||||
updateUserDay = if dailyFormParkingToken
|
||||
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
|
||||
updateUserDay udUq [ UserDayParkingToken =. dailyFormParkingToken]
|
||||
tuts <- runDB $ forM (Map.toList resMap) $ \(tpid, DailyFormData{..}) -> do
|
||||
-- logDebugS "TableForm" (tshow dfd)
|
||||
TutorialParticipant{..} <- get404 tpid -- needed anyway to find the ParticipantDay/UserDay updated
|
||||
when ( tutorialParticipantDrivingPermit /= dailyFormDrivingPermit
|
||||
|| tutorialParticipantEyeExam /= dailyFormEyeExam
|
||||
|| tutorialParticipantNote /= dailyFormParticipantNote) $
|
||||
update tpid [ TutorialParticipantDrivingPermit =. dailyFormDrivingPermit
|
||||
, TutorialParticipantEyeExam =. dailyFormEyeExam
|
||||
, TutorialParticipantNote =. dailyFormParticipantNote
|
||||
]
|
||||
let tpdUq = UniqueTutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd
|
||||
if not dailyFormAttendance && isNothing (canonical dailyFormAttendanceNote)
|
||||
then deleteBy tpdUq
|
||||
else upsertBy_ tpdUq (TutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd dailyFormAttendance dailyFormAttendanceNote)
|
||||
[ TutorialParticipantDayAttendance =. dailyFormAttendance
|
||||
, TutorialParticipantDayNote =. dailyFormAttendanceNote
|
||||
]
|
||||
let udUq = UniqueUserDay tutorialParticipantUser nd
|
||||
updateUserDay = if dailyFormParkingToken
|
||||
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
|
||||
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.
|
||||
addMessageI Success $ MsgTutorialParticipantsDayEdits dday
|
||||
redirect $ SchoolR ssh $ SchoolDayR nd
|
||||
@ -659,3 +666,11 @@ postSchoolDayR ssh nd = do
|
||||
setTitleI (MsgMenuSchoolDay ssh dday)
|
||||
$(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.|]
|
||||
Loading…
Reference in New Issue
Block a user