chore(daily): add proper btn for consistency check

2024-11-27 17:56:16 +01:00 · 2024-11-27 17:56:16 +01:00 · ce164f308f
commit ce164f308f
parent 8ffa8ef852
3 changed files with 51 additions and 44 deletions
--- 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
--- 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
  <section>
-    ^{tbl}
+    <p>
+      ^{tbl}
+    <p>
+      ^{consistencyBtn}
  <section .profile>
    <h3>Hinweise zu den Formularspalten
    <dl .deflist.profile-dl>
--- 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 <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>