chore(occurrences): add datatype LessonTime for dealing timetable intervals

src/Handler/LMS.hs

@@ -436,7 +436,7 @@ mkLmsTable :: ( Functor h, ToSortable h
 mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
   now <- liftIO getCurrentTime
   -- lookup all companies
-  cmpMap <- memcachedBy (Just . Right $ 15 * diffMinute) ("CompanyDictionary"::Text) $ do
+  cmpMap <- memcachedBy (Just . Right $ 30 * diffMinute) ("CompanyDictionary"::Text) $ do
     cmps <- selectList [] [] -- [Asc CompanyShorthand]
     return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
   let

src/Handler/Qualification.hs

@@ -363,7 +363,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
   svs <- getSupervisees
   now <- liftIO getCurrentTime
   -- lookup all companies
-  cmpMap <- memcachedBy (Just . Right $ 15 * diffMinute) ("CompanyDictionary"::Text) $ do
+  cmpMap <- memcachedBy (Just . Right $ 30 * diffMinute) ("CompanyDictionary"::Text) $ do
     cmps <- selectList [] [] -- [Asc CompanyShorthand]
     return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
   let

src/Handler/School/DayTasks.hs

@@ -81,14 +81,14 @@ getDayTutorials ssh dlimit@(dstart, dend )
       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 "memcached" $ "***DEBUG*****CACHE*****" <> tshow (ssh,dlimit) <> "***************" -- DEBUG ONLY
+      return (trm, tut, E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue dstart))
     return $ mapMaybe checkCandidate candidates
   where
     period = Set.fromAscList [dstart..dend]
 
-    checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}})
-      | not $ Set.null $ Set.intersection period $ occurrencesCompute trm occ
+    checkCandidate (_, Entity{entityKey=tutId}, E.unValue -> True) = Just tutId -- 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

src/Handler/Utils/Files.hs

@@ -30,6 +30,7 @@ import qualified Database.Esqueleto.Utils as E
 import System.FilePath (normalise, makeValid)
 import Data.List (dropWhileEnd)
 
+{-# ANN module ("HLint: ignore Redundant bracket" :: String) #-}
 
 
 data SourceFilesException

src/Handler/Utils/Occurrences.hs

@@ -3,8 +3,10 @@
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 module Handler.Utils.Occurrences
-  ( occurrencesWidget
-  , occurrencesCompute
+  ( LessonTime(..)
+  , occurringLessons
+  , occurrencesWidget
+  , occurrencesCompute, occurrencesCompute'
   , occurrencesBounds
   , occurrencesAddBusinessDays
   ) where
@@ -19,6 +21,52 @@ import Utils.Occurrences
 import Handler.Utils.DateTime
 
 
+
+
+----------------
+-- LessonTime --
+----------------
+--
+-- Model time intervals to compute lecture/tutorial lessons more intuitively
+--
+
+data LessonTime = LessonTime { lessonStart, lessonEnd :: LocalTime }
+  deriving (Eq, Ord, Read, Show, Generic) -- BEWARE: Ord instance might not be intuitive, but needed for Set
+
+occurringLessons :: Term -> Occurrences -> Set LessonTime
+occurringLessons t Occurrences{..} = Set.union exceptOcc $ Set.filter isExcept scheduledLessons
+  where
+    scheduledLessons      = occurrenceScheduleToLessons t `foldMap` occurrencesScheduled
+    (exceptOcc, exceptNo) = occurrenceExceptionToLessons  occurrencesExceptions
+    isExcept LessonTime{lessonStart} = Set.member lessonStart exceptNo
+
+occurrenceScheduleToLessons :: Term -> OccurrenceSchedule -> Set LessonTime
+occurrenceScheduleToLessons Term{..} =
+  let setHolidays = Set.fromList termHolidays
+  in \ScheduleWeekly{..} ->
+        let occDays = daysOfWeekBetween (termLectureStart, termLectureEnd) scheduleDayOfWeek \\ setHolidays
+            toLesson d = LessonTime { lessonStart = LocalTime d scheduleStart
+                                    , lessonEnd   = LocalTime d scheduleEnd
+                                    }
+        in Set.map toLesson occDays
+
+occurrenceExceptionToLessons :: Set OccurrenceException -> (Set LessonTime, Set LocalTime)
+occurrenceExceptionToLessons = Set.foldr aux mempty
+  where
+    aux ExceptOccur{..} (oc,no) =
+      let t = LessonTime  { lessonStart = LocalTime exceptDay exceptStart
+                          , lessonEnd   = LocalTime exceptDay exceptEnd
+                          }
+      in (Set.insert t oc,no)
+    aux ExceptNoOccur{..} (oc,no) =
+      (oc, Set.insert exceptTime no)
+
+
+-----------------
+-- Occurrences --
+-----------------
+
+
 occurrencesWidget :: JSONB Occurrences -> Widget
 occurrencesWidget (normalizeOccurrences . unJSONB -> Occurrences{..}) = do
   let occurrencesScheduled' = flip map (Set.toList occurrencesScheduled) $ \case
@@ -36,7 +84,12 @@ occurrencesWidget (normalizeOccurrences . unJSONB -> Occurrences{..}) = do
           $(widgetFile "widgets/occurrence/cell/except-no-occur")
   $(widgetFile "widgets/occurrence/cell")
 
--- | Get all occurrences during a term, excluding term holidays from the regular schedule, but not from exceptins
+-- | More precise verison of `occurrencesCompute`, which accounts for TimeOfDay as well
+occurrencesCompute' :: Term -> Occurrences -> Set Day
+occurrencesCompute' trm occ = Set.map (localDay . lessonStart) $ occurringLessons trm occ
+
+-- | Get all occurrences during a term, excluding term holidays from the regular schedule, but not from exceptions
+--   Beware: code currently ignores TimeOfDay, see Model.Types.DateTime.LessonTime for a start to address this if needed
 occurrencesCompute :: Term -> Occurrences -> Set Day
 occurrencesCompute Term{..} Occurrences{..} = ((scdDays \\ Set.fromList termHolidays) <> plsDays) \\ excDays
   where

src/Utils/Files.hs

@@ -48,6 +48,7 @@ import System.IO.Unsafe
 
 import Data.Typeable (eqT)
 
+{-# ANN module ("HLint: ignore Redundant bracket" :: String) #-}
 
 sinkFileDB :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX)
            => Bool -- ^ Replace? Use only in serializable transaction
@@ -63,9 +64,9 @@ sinkFileDB doReplace fileContentContent = do
         observeSunkChunk StorageDB $ olength fileContentChunkContent
 
         tellM $ Set.singleton <$> insert FileChunkLock{ fileChunkLockHash = fileContentChunkHash, .. }
-  
+
         existsChunk <- lift $ exists [FileContentChunkHash ==. fileContentChunkHash]
-      
+
         let setContentBased = updateWhere [FileContentChunkHash ==. fileContentChunkHash] [FileContentChunkContentBased =. fileContentChunkContentBased]
         if | existsChunk -> lift   setContentBased
            | otherwise   -> lift . handleIfSql isUniqueConstraintViolation (const setContentBased) $
@@ -98,7 +99,7 @@ sinkFileDB doReplace fileContentContent = do
      | otherwise -> do
          deleteWhere [ FileContentEntryHash ==. fileContentHash ]
          insertEntries
-    
+
 
   return fileContentHash
   where fileContentChunkContentBased = True
@@ -163,18 +164,18 @@ sinkMinio content = do
           , Minio.dstObject = dstName
           }
     uploadExists <- handleIf minioIsDoesNotExist (const $ return False) $ True <$ Minio.statObject uploadBucket dstName Minio.defaultGetObjectOptions
-    unless uploadExists $ 
+    unless uploadExists $
       Minio.copyObject copyDst copySrc
     release removeObject
     return $ _sinkMinioRet # contentHash
-  
+
 sinkFileMinio :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m)
               => ConduitT () ByteString m ()
               -> MaybeT m FileContentReference
 -- ^ Cannot deal with zero length uploads
 sinkFileMinio = sinkMinio @FileContentReference
 
-  
+
 sinkFiles :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => ConduitT (File (SqlPersistT m)) FileReference (SqlPersistT m) ()
 sinkFiles = C.mapM sinkFile
 

templates/tutorial-participants.hamlet

@@ -15,4 +15,5 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
         $forall (Entity _ usr) <- tutors
           <li>
             ^{userEmailWidget usr}
-^{participantTable}
+<section>            
+  ^{participantTable}