chore(daily): show rooms for tutorial lessons

src/Handler/School/DayTasks.hs

@@ -76,7 +76,7 @@ data OccurrenceCacheKey = OccurrenceCacheKeyTutorials SchoolId (Day,Day)
 getDayTutorials :: SchoolId -> (Day,Day) -> DB [TutorialId]
 getDayTutorials ssh dlimit@(dstart, dend )
   | dstart > dend = return mempty
-  | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 9 * diffDay) (OccurrenceCacheKeyTutorials ssh dlimit) $ do
+  | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (OccurrenceCacheKeyTutorials 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)
@@ -97,6 +97,40 @@ getDayTutorials ssh dlimit@(dstart, dend )
       | 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)
+          `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)
+    -- logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates
+    return $ foldMap checkCandidate candidates
+  where
+    checkCandidate :: (Entity Term, Entity Tutorial) -> Map TutorialId [LessonTime]
+    checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}})
+      | let lessons = Set.filter lessonFltr $ occurringLessons trm occ
+      , notNull lessons
+        = Map.singleton tutId $ Set.toAscList lessons -- due to Set not having a Functor instance, we need mostly need lists anyway
+      | otherwise
+        = mempty
+
+    lessonFltr :: LessonTime -> Bool
+    lessonFltr LessonTime{..} = dstart <= localDay lessonStart
+                            &&  dend   >= localDay lessonEnd
+
 
 type DailyTableExpr =
   (                     E.SqlExpr (Entity Course)
@@ -178,15 +212,16 @@ instance HasUser DailyTableData where
 
 mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget)
 mkDailyTable isAdmin ssh nd = do
-  tuts <- getDayTutorials ssh (nd,nd)
+  tutLessons <- getDayTutorials' ssh (nd,nd)
   let
+    tutIds = Map.keys tutLessons
     dbtSQLQuery :: DailyTableExpr -> DailyTableOutput
     dbtSQLQuery  (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr `E.LeftOuterJoin` avs) = do
       EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId
       EL.on $ tut E.^. TutorialId     E.==. tpu E.^. TutorialParticipantTutorial
       EL.on $ usr E.^. UserId         E.==. tpu E.^. TutorialParticipantUser
       EL.on $ usr E.^. UserId         E.=?. avs E.?. UserAvsUser
-      E.where_ $ tut E.^. TutorialId `E.in_` E.valList tuts
+      E.where_ $ tut E.^. TutorialId `E.in_` E.valList tutIds
       let associatedQualifications = E.subSelectMaybe . EL.from $ \cq -> do
             E.where_ $ cq E.^. CourseQualificationCourse E.==. crs E.^. CourseId
             let cqQual  = cq E.^. CourseQualificationQualification
@@ -200,9 +235,14 @@ mkDailyTable isAdmin ssh nd = do
         sortable (Just "course")    (i18nCell MsgFilterCourse)     $ \(view $ resultCourse . _entityVal -> c) -> courseCell c
       , sortable (Just "tutorial")  (i18nCell MsgCourseTutorial)   $ \row ->
           let Course{courseTerm=tid, courseSchool=cssh, courseShorthand=csh}
-                      = row ^. resultCourse . _entityVal
+                      = row ^. resultCourse   . _entityVal
               tutName = row ^. resultTutorial . _entityVal . _tutorialName
           in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName
+      , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \(view $ resultTutorial . _entityKey -> tutId) -> cellMaybe (lessonTimesCell False) $ Map.lookup tutId tutLessons
+      , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> tutId) ->
+          -- listInlineCell (foldMap (fmap lessonRoom) $ Map.lookup tutId tutLessons) $ cellMaybe roomReferenceCell
+          -- listInlineCell (concat $ mapMM lessonRoom $ Map.lookup tutId tutLessons) roomReferenceCell
+          cellMaybe (`listInlineCell` roomReferenceCell) $ mapMM lessonRoom $ Map.lookup tutId tutLessons
       , sortable Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell
       , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid
       , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid

src/Handler/Utils/Occurrences.hs

@@ -4,6 +4,7 @@
 
 module Handler.Utils.Occurrences
   ( LessonTime(..)
+  , lessonTimeWidget, lessonTimesWidget
   , occurringLessons
   , occurrencesWidget
   , occurrencesCompute, occurrencesCompute'
@@ -31,8 +32,8 @@ import Handler.Utils.Widgets (roomReferenceWidget)
 -- Model time intervals to compute lecture/tutorial lessons more intuitively
 --
 
-data LessonTime = LessonTime { lessonStart, lessonEnd :: LocalTime }
+data LessonTime = LessonTime { lessonStart, lessonEnd :: LocalTime, lessonRoom :: Maybe RoomReference }
-  deriving (Eq, Ord, Read, Show, Generic) -- BEWARE: Ord instance might not be intuitive, but needed for Set
+  deriving (Eq, Ord, Show, Generic, Binary) -- BEWARE: Ord instance might not be intuitive, but needed for Set
 
 occurringLessons :: Term -> Occurrences -> Set LessonTime
 occurringLessons term Occurrences{..} = Set.union exceptOcc $ Set.filter isExcept scheduledLessons
@@ -48,6 +49,7 @@ occurrenceScheduleToLessons Term{..} =
         let occDays = daysOfWeekBetween (termLectureStart, termLectureEnd) scheduleDayOfWeek \\ setHolidays
             toLesson d = LessonTime { lessonStart = LocalTime d scheduleStart
                                     , lessonEnd   = LocalTime d scheduleEnd
+                                    , lessonRoom  = scheduleRoom
                                     }
         in Set.map toLesson occDays
 
@@ -57,11 +59,23 @@ occurrenceExceptionToLessons = Set.foldr aux mempty
     aux ExceptOccur{..} (oc,no) =
       let t = LessonTime  { lessonStart = LocalTime exceptDay exceptStart
                           , lessonEnd   = LocalTime exceptDay exceptEnd
+                          , lessonRoom  = exceptRoom
                           }
       in (Set.insert t oc,no)
     aux ExceptNoOccur{..} (oc,no) =
       (oc, Set.insert exceptTime no)
 
+lessonTimeWidget :: Bool -> LessonTime -> Widget
+lessonTimeWidget roomHidden LessonTime{..} = do
+  lStart <- formatTime SelFormatTime lessonStart
+  lEnd   <- formatTime SelFormatTime lessonEnd
+  $(widgetFile "widgets/lesson/single")
+
+lessonTimesWidget :: (Traversable t, MonoFoldable (t Widget)) => Bool -> t LessonTime -> Widget
+lessonTimesWidget roomHidden lessonsSet = do
+  let lessons = lessonTimeWidget roomHidden <$> lessonsSet
+  $(widgetFile "widgets/lesson/set")
+
 
 -----------------
 -- Occurrences --

src/Handler/Utils/Table/Cells.hs

@@ -510,11 +510,14 @@ correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a
 correctorLoadCell sc =
   i18nCell $ sheetCorrectorLoad sc
 
+lessonTimesCell :: IsDBTable m a => Bool -> [LessonTime] -> DBCell m a
+lessonTimesCell roomHidden lessons = cell $ lessonTimesWidget roomHidden lessons
+
 occurrencesCell :: IsDBTable m a => Bool -> JSONB Occurrences -> DBCell m a
 occurrencesCell roomHidden occs = cell $ occurrencesWidget roomHidden occs
 
 roomReferenceCell :: IsDBTable m a => RoomReference -> DBCell m a
-roomReferenceCell = cell . roomReferenceWidget
+roomReferenceCell = cell . roomReferenceShortWidget
 
 cryptoidCell :: (IsDBTable m a, PathPiece cid) => cid -> DBCell m a
 cryptoidCell = addCellClass ("cryptoid" :: Text) . textCell . toPathPiece

src/Handler/Utils/Widgets.hs

@@ -299,6 +299,13 @@ roomReferenceWidget RoomReferenceLink{..}   = $(widgetFile "widgets/room-referen
     linkText = uriToString id roomRefLink mempty
     instrModal = modal (i18n MsgRoomReferenceLinkInstructions) $ Right $(widgetFile "widgets/room-reference/link-instructions-modal")
 
+roomReferenceShortWidget :: RoomReference -> Widget
+roomReferenceShortWidget RoomReferenceSimple{..} = text2widget roomRefText
+roomReferenceShortWidget RoomReferenceLink{..}   = $(widgetFile "widgets/room-reference/link")
+  where
+    linkText = uriToString id roomRefLink mempty
+    instrModal = modal (i18n MsgRoomReferenceLinkInstructions) $ Right $(widgetFile "widgets/room-reference/link-instructions-modal")
+
 
 ----------
 -- JSON --

src/Model/Types/DateTime.hs

@@ -170,7 +170,7 @@ data OccurrenceSchedule = ScheduleWeekly
                           , scheduleEnd       :: TimeOfDay
                           , scheduleRoom      :: Maybe RoomReference
                           }
-  deriving (Eq, Ord, Show, Generic)
+  deriving (Eq, Ord, Show, Generic,Binary)
   deriving anyclass (NFData)
 
 deriveJSON defaultOptions
@@ -189,7 +189,7 @@ data OccurrenceException = ExceptOccur
                         | ExceptNoOccur
                           { exceptTime  :: LocalTime
                           }
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show, Generic,Binary)
   deriving anyclass (NFData)
 
 -- Handler.Utils.Occurrences.occurrencesAddBusinessDays assumes that OccurrenceException is ordered chronologically
@@ -221,7 +221,7 @@ data Occurrences = Occurrences
   { occurrencesScheduled  :: Set OccurrenceSchedule
   , occurrencesExceptions :: Set OccurrenceException
   }
-  deriving (Eq, Ord, Show, Generic)
+  deriving (Eq, Ord, Show, Generic, Binary)
   deriving anyclass (NFData)
 
 deriveJSON defaultOptions

src/Model/Types/Room.hs

@@ -19,7 +19,7 @@ data RoomReference
     { roomRefLink :: URI
     , roomRefInstructions :: Maybe StoredMarkup
     }
-  deriving (Eq, Ord, Show, Generic)
+  deriving (Eq, Ord, Show, Generic, Binary)
   deriving anyclass (NFData)
 
 deriveJSON defaultOptions

src/Network/URI/Instances.hs

@@ -18,6 +18,7 @@ import Data.Swagger
 import Data.Swagger.Internal.Schema
 
 import Data.Proxy
+import Data.Binary
 
 import Servant.Docs
 
@@ -28,6 +29,8 @@ import Control.Monad.Fail (MonadFail(..))
 import Database.Persist
 import Database.Persist.Sql
 
+deriving instance Binary URIAuth
+deriving instance Binary URI
 
 instance ToHttpApiData URI where
   toQueryParam = pack . ($ mempty) . uriToString id
@@ -54,7 +57,7 @@ instance Aeson.FromJSON URI where
   parseJSON = Aeson.withText "URI" $ maybe (fail "Could not parse URI") return . parseURIReference . unpack
 
 instance PersistField URI where
-  toPersistValue = PersistText . pack . ($ mempty) . uriToString id 
+  toPersistValue = PersistText . pack . ($ mempty) . uriToString id
   fromPersistValue (PersistText t) = maybe (Left "Could not parse URI") return . parseURIReference $ unpack t
   fromPersistValue v = Left $ "Failed to parse Haskell type `URI`; expected text from database but received: " <> tshow v <> "."
 instance PersistFieldSql URI where

src/Utils/Avs.hs

@@ -86,7 +86,7 @@ mkAvsQuery _ _ _ = AvsQuery
     fakePerson :: AvsQueryPerson -> AvsResponsePerson
     fakePerson =
       let
-        sarah    = Set.singleton $ AvsDataPerson "Sarah"   "Vaupel"  Nothing            2 (AvsPersonId        2) mempty
+        sarah    = Set.singleton $ AvsDataPerson "Sarah"   "Vaupel"  Nothing            2 (AvsPersonId        2) $ Set.singleton $ AvsDataPersonCard True Nothing Nothing AvsCardColorRot mempty Nothing Nothing Nothing Nothing (AvsCardNo "424242") "8"
         stephan  = Set.singleton $ AvsDataPerson "Stephan" "Barth"   Nothing            4 (AvsPersonId        4) mempty
         steffen  = Set.singleton $ AvsDataPerson "Steffen" "Jost" (Just $ mkAvsInternalPersonalNo "47138") 12345678 (AvsPersonId 12345678) mempty
         sumpfi1  = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 12345678) mempty

src/Utils/Lens.hs

@@ -93,6 +93,10 @@ _Integral = iso fromIntegral fromIntegral
 _not :: Iso' Bool Bool
 _not = iso not not
 
+instance Wrapped (JSONB a) where
+  type Unwrapped (JSONB a) = a
+  _Wrapped' = iso unJSONB JSONB
+
 -----------------------------------
 -- Lens Definitions for our Types
 

templates/exam-show.hamlet

@@ -86,7 +86,7 @@ $maybe desc <- examDescription
         ^{notificationPersonalIdentification}
     $maybe room <- examRoom
       <dt .deflist__dt>_{MsgExamRoom}
-      <dd .deflist__dd>^{roomReferenceWidget room}
+      <dd .deflist__dd>^{roomReferenceShortWidget room}
     $if examTimes
       <dt .deflist__dt>_{MsgTableExamTime}
       <dd .deflist__dd>
@@ -243,7 +243,7 @@ $if not (null occurrences)
                   $if showRoom
                     <td .table__td>
                       $maybe room <- examOccurrenceRoom
-                        ^{roomReferenceWidget room}
+                        ^{roomReferenceShortWidget room}
                       $nothing
                         _{MsgExamOccurrenceRoomIsUnset}
                   $else

templates/widgets/lesson/set.hamlet

@@ -0,0 +1,11 @@
+$newline never
+
+$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
+$#
+$# SPDX-License-Identifier: AGPL-3.0-or-later
+
+$if not (null lessons)
+  <ul .list--iconless>
+    $forall lsn <- lessons
+      <li>
+        ^{lsn}

templates/widgets/lesson/single.hamlet

@@ -0,0 +1,9 @@
+$newline never
+
+$# SPDX-FileCopyrightText: 20 24 Steffen Jost <s.jost@fraport.de>
+$#
+$# SPDX-License-Identifier: AGPL-3.0-or-later
+
+#{lStart}–#{lEnd}
+$if not roomHidden
+  \ ^{foldMap roomReferenceWidget lessonRoom}

templates/widgets/occurrence/cell/except-occur.hamlet

@@ -4,9 +4,9 @@ $# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
 $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
-$if not (null occurrencesScheduled')
+$if null occurrencesScheduled'
-  _{MsgExceptionKindOccur} #{exceptStart'}–#{exceptEnd'} 
-  $if not roomHidden
-    ^{foldMap roomReferenceWidget exceptRoom}
-$else
   #{exceptStart'}–#{exceptEnd'}
+$else
+  _{MsgExceptionKindOccur} #{exceptStart'}–#{exceptEnd'} 
+$if not roomHidden
+  \ ^{foldMap roomReferenceWidget exceptRoom}

test/Database/Fill.hs

@@ -744,8 +744,8 @@ fillDb = do
   for_ [jost] $ \uid ->
     void . insert' $ UserSchool uid avn False
   void . insert' $ UserAvs (AvsPersonId 12345678) jost        87654321  (n_day' $ -12) (Just "Some Message here") Nothing Nothing Nothing
-  void . insert' $ UserAvs (AvsPersonId 2)        svaupel     2         (n_day' $ -22) Nothing Nothing Nothing (readAvsFullCardNo "12345.6")
+  void . insert' $ UserAvs (AvsPersonId 99)       svaupel     99        (n_day' $ -22) Nothing Nothing Nothing (readAvsFullCardNo "444444.4")
-  void . insert' $ UserAvs (AvsPersonId 3)        gkleen      3         (n_day' $ -32) Nothing Nothing Nothing Nothing
+  void . insert' $ UserAvs (AvsPersonId 3)        gkleen      3         (n_day' $ -32) Nothing Nothing Nothing (readAvsFullCardNo "5555.5")
   void . insert' $ UserAvs (AvsPersonId 4)        sbarth      4         now            Nothing Nothing Nothing Nothing
   void . insert' $ UserAvs (AvsPersonId 5)        fhamann     5         now            (Just "another message from avs synch") Nothing Nothing (readAvsFullCardNo "77777.7")
   void . insert' $ UserAvs (AvsPersonId 77)       tinaTester  77        now            Nothing Nothing Nothing Nothing
@@ -1102,13 +1102,13 @@ fillDb = do
                     { exceptDay   = nTimes 8 succ secondDay
                     , exceptStart = TimeOfDay  9  0  0
                     , exceptEnd   = TimeOfDay 16  0  0
-                    , exceptRoom  = Just $ RoomReferenceSimple "B747"
+                    , exceptRoom  = Nothing
                     }
                 , ExceptOccur
                     { exceptDay   = nowaday
                     , exceptStart = TimeOfDay  9  10  0
                     , exceptEnd   = TimeOfDay 16  10  0
-                    , exceptRoom  = Nothing
+                    , exceptRoom  = Just $ RoomReferenceSimple "B747"
                     }
                 ]
             }