From ce164f308fac7a5b0fecf2a601dcee5a79f893dc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 27 Nov 2024 17:56:16 +0100 Subject: [PATCH] chore(daily): add proper btn for consistency check --- src/Handler/School/DayTasks.hs | 83 +++++++++++---------- templates/i18n/day-view/de-de-formal.hamlet | 5 +- templates/i18n/day-view/en-eu.hamlet | 7 +- 3 files changed, 51 insertions(+), 44 deletions(-) diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 257a0201b..89fce81c9 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -72,7 +72,7 @@ getDayTutorials ssh d = E.unValue <<$>> E.select (do ) -} --- Datatype to be used as key for memcaching DayTask related stuff; note that newtype-CacheKeys are optimized away, so multiple constructors are advisable +-- | 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 @@ -80,41 +80,36 @@ data DailyCacheKeys deriving (Eq, Ord, Read, Show, Generic) deriving anyclass (Hashable, Binary, NFData) -getDayTutorials :: SchoolId -> (Day,Day) -> DB [TutorialId] +-- getDayTutorials :: SchoolId -> (Day,Day) -> DB [TutorialId] +-- getDayTutorials ssh dlimit@(dstart, dend ) +-- | dstart > dend = return mempty +-- | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (CacheKeyTutorialOccurrences ssh dlimit) $ do -- same key is ok, distinguished by return type +-- 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) +-- `E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse) +-- E.where_ $ crs E.^. CourseSchool E.==. E.val ssh +-- E.&&. trm E.^. TermStart E.<=. E.val dend +-- E.&&. trm E.^. TermEnd E.>=. E.val dstart +-- return (trm, tut, E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue dstart)) +-- -- logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates +-- return $ mapMaybe checkCandidate candidates +-- where +-- period = Set.fromAscList [dstart..dend] + +-- checkCandidate (_, Entity{entityKey=tutId}, E.unValue -> True) = Just tutId -- most common case +-- checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}}, _) +-- | not $ Set.null $ Set.intersection period $ occurrencesCompute' trm occ +-- = Just tutId +-- | otherwise +-- = Nothing + +-- | 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 ssh dlimit@(dstart, dend ) | dstart > dend = return mempty | 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) - `E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse) - E.where_ $ crs E.^. CourseSchool E.==. E.val ssh - E.&&. trm E.^. TermStart E.<=. E.val dend - E.&&. trm E.^. TermEnd E.>=. E.val dstart - return (trm, tut, E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue dstart)) - -- logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates - return $ mapMaybe checkCandidate candidates - where - period = Set.fromAscList [dstart..dend] - - checkCandidate (_, Entity{entityKey=tutId}, E.unValue -> True) = Just tutId -- most common case - checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}}, _) - | not $ Set.null $ Set.intersection period $ occurrencesCompute' trm occ - = Just tutId - | otherwise - = Nothing - --- Datatype to be used for memcaching occurrences -data LessonCacheKey = LessonCacheKeyTutorials SchoolId (Day,Day) - deriving (Eq, Ord, Read, Show, Generic) - deriving anyclass (Hashable, Binary) - - --- | like getDayTutorials, but also returns the lessons occurring within the given time frame -getDayTutorials' :: SchoolId -> (Day,Day) -> DB (Map TutorialId [LessonTime]) -getDayTutorials' ssh dlimit@(dstart, dend ) - | dstart > dend = return mempty - | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (LessonCacheKeyTutorials 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) @@ -290,7 +285,7 @@ colParticipantEyeExamField' l = sortable (Just "eye-exam") (i18nCell MsgTutorial -- ) colParticipantNoteField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) -colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ -- (cellAttrs <>~ [("style","width:60%")]) <$> +colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","min-width:12em")]) <$> formCell id (views (resultParticipant . _entityKey) return) (\row mkUnique -> @@ -411,7 +406,7 @@ colAttendanceField dday = sortable (Just "attendance") (i18nCell $ MsgTutorialDa ) colAttendanceNoteField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) -colAttendanceNoteField dday = sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ -- (cellAttrs <>~ [("style","width:10%"), ("style","height:200px")]) <$> +colAttendanceNoteField dday = sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ (cellAttrs <>~ [("style","min-width:12em")]) <$> formCell id (views (resultParticipant . _entityKey) return) (\row mkUnique -> @@ -449,7 +444,7 @@ colParkingField' l dday = sortable (Just "parking") (i18nCell $ MsgTableUserPark ) mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData), Maybe Widget) -mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case +mkDailyTable isAdmin ssh nd = getDayTutorials ssh (nd,nd) >>= \case tutLessons | Map.null tutLessons -> return (FormMissing, Nothing) | otherwise -> do @@ -632,7 +627,7 @@ postSchoolDayR ssh nd = do (fmap unFormResult -> tableRes, tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd -- logInfoS "****DailyTable****" $ tshow tableRes formResult tableRes $ \resMap -> do - _tuts <- runDB $ forM (Map.toList resMap) $ \(tpid, DailyFormData{..}) -> do + 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 @@ -655,21 +650,27 @@ postSchoolDayR ssh nd = do 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 -- TODO reinstate this after test - -- memcachedByInvalidate (CacheKeySuggsParticipantNote ssh tid) $ Proxy @(OptionListCacheable Text) - -- memcachedByInvalidate (CacheKeySuggsAttendanceNote ssh tid) $ Proxy @(OptionListCacheable Text) + 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 siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do + let consistencyBtn = btnModal MsgMenuSchoolDayCheck [BCIsButton, BCDefault] (Left $ SomeRoute $ SchoolR ssh $ SchoolDayCheckR nd) setTitleI (MsgMenuSchoolDay ssh dday) $(i18nWidgetFile "day-view") - +-- | 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 -- isAdmin <- hasReadAccessTo AdminR + + -- runDB $ do + -- tuts <- getDayTutorials ssh (nd,nd) + -- TODO CONTINUE HERE + dday <- formatTime SelFormatDate nd siteLayoutMsg MsgMenuSchoolDayCheck $ do setTitleI MsgMenuSchoolDayCheck diff --git a/templates/i18n/day-view/de-de-formal.hamlet b/templates/i18n/day-view/de-de-formal.hamlet index ce8f630c5..014b9247d 100644 --- a/templates/i18n/day-view/de-de-formal.hamlet +++ b/templates/i18n/day-view/de-de-formal.hamlet @@ -6,7 +6,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later $maybe tbl <- tableDaily
- ^{tbl} +

+ ^{tbl} +

+ ^{consistencyBtn}

Hinweise zu den Formularspalten
diff --git a/templates/i18n/day-view/en-eu.hamlet b/templates/i18n/day-view/en-eu.hamlet index 603b66abc..455d6ba90 100644 --- a/templates/i18n/day-view/en-eu.hamlet +++ b/templates/i18n/day-view/en-eu.hamlet @@ -4,9 +4,12 @@ $# SPDX-FileCopyrightText: 2024 Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later -$maybe tbl <- tableDaily +$maybe tbl <- tableDaily
- ^{tbl} +

+ ^{tbl} +

+ ^{consistencyBtn}

Note how form data is saved