chore(daily): add proper btn for consistency check

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
+    forM_ tuts $ \tid -> do
-    --   memcachedByInvalidate (CacheKeySuggsParticipantNote ssh tid) $ Proxy @(OptionListCacheable Text)
+      memcachedByInvalidate (CacheKeySuggsParticipantNote ssh tid) $ Proxy @(OptionListCacheable Text)
-    --   memcachedByInvalidate (CacheKeySuggsAttendanceNote  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

templates/i18n/day-view/de-de-formal.hamlet

@@ -6,7 +6,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 $maybe tbl <- tableDaily
   <section>
-    ^{tbl}
+    <p>
+      ^{tbl}
+    <p>
+      ^{consistencyBtn}
   <section .profile>
     <h3>Hinweise zu den Formularspalten
     <dl .deflist.profile-dl>

templates/i18n/day-view/en-eu.hamlet

@@ -4,9 +4,12 @@ $# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
 $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
-$maybe tbl <- tableDaily
+$maybe tbl <- tableDaily      
   <section>
-    ^{tbl}
+    <p> 
+      ^{tbl}
+    <p>
+      ^{consistencyBtn}      
   <section .profile>
     <h3>Note how form data is saved
     <dl .deflist.profile-dl>