diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 9821c2309..cf8c25a68 100644 --- a/src/Handler/LMS.hs +++ b/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 diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 8ca169696..e5c872494 100644 --- a/src/Handler/Qualification.hs +++ b/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 diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 0dd956333..273427f35 100644 --- a/src/Handler/School/DayTasks.hs +++ b/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 diff --git a/src/Handler/Utils/Files.hs b/src/Handler/Utils/Files.hs index b8a4a8cd2..a9de3f095 100644 --- a/src/Handler/Utils/Files.hs +++ b/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 diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index f5fc0b9fa..e2ddf5964 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/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 diff --git a/src/Utils/Files.hs b/src/Utils/Files.hs index 4358c947b..d49824d7d 100644 --- a/src/Utils/Files.hs +++ b/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 diff --git a/templates/tutorial-participants.hamlet b/templates/tutorial-participants.hamlet index c01779c73..0eae86644 100644 --- a/templates/tutorial-participants.hamlet +++ b/templates/tutorial-participants.hamlet @@ -15,4 +15,5 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later $forall (Entity _ usr) <- tutors
  • ^{userEmailWidget usr} -^{participantTable} +
    + ^{participantTable}