From 109f8ce86014fcfd7e4c9d8ac2f028bccd152618 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 22 May 2023 14:36:49 +0000 Subject: [PATCH] chore(tutorial): WIP towards tutorial templates --- models/tutorials.model | 2 +- src/Handler/Course/ParticipantInvite.hs | 82 +++++++++++++++---------- src/Handler/Utils/DateTime.hs | 18 +----- src/Handler/Utils/Occurrences.hs | 41 +++++++++++++ src/Utils/Holidays.hs | 10 +-- 5 files changed, 99 insertions(+), 54 deletions(-) diff --git a/models/tutorials.model b/models/tutorials.model index 76aed3e3a..be27d6a87 100644 --- a/models/tutorials.model +++ b/models/tutorials.model @@ -16,7 +16,7 @@ Tutorial json deregisterUntil UTCTime Maybe lastChanged UTCTime default=now() tutorControlled Bool default=false - -- firstDay UTCTime Maybe -- to be computed from time, but needed for sorting within DB + firstDay Day Maybe -- to be computed from time, but needed for sorting within DB UniqueTutorial course name deriving Generic Tutor diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index b79b6ccac..632da122a 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -291,40 +291,60 @@ upsertNewTutorial cid tutorialName = do tutorialTemplates :: [CI Text] tutorialTemplates = ["Vorlage", "Template"] -upsertNewTutorialTemplate :: CourseId -> TutorialName -> Handler TutorialId -upsertNewTutorialTemplate cid tutorialName = runDB $ do +upsertNewTutorialTemplate :: CourseId -> TutorialName -> Maybe Day -> Handler TutorialId +upsertNewTutorialTemplate cid tutorialName anchorDay = runDB $ do now <- liftIO getCurrentTime - getBy UniqueTutorial cid tutorialName >>= \case - Just (Entity{entityVal=tid}) -> return tid -- no need to update - Nothing -> do + existingTut <- getBy UniqueTutorial cid tutorialName + templateEnt <- selectFirst [TutorialType <-. tutorialTemplates] [Desc TutorialType] + case (existingTut, anchorDay) of + (Just (Entity{entityVal=tid}),_,_) -> return tid -- no need to update, we ignore the anchor day + (Nothing, Just firstDay, Just Entity{entityVal=Tutorial{tutorialFirstDay=Just tmplFirstDay}) -> do Course{..} <- getBy404 cid Term{termLectureStart} <- getBy404 courseTerm - selectFirst [TutorialType <-. tutorialTemplates] [Desc TutorialType] >>= \case - Just (Entity {entityVal=template}) -> do - error "TODO" - Nothing -> do - Entity tutId _ <- upsert - Tutorial - { tutorialCourse = cid - , tutorialType = CI.mk "Schulung" - , tutorialCapacity = Nothing - , tutorialRoom = Nothing - , tutorialRoomHidden = False - , tutorialTime = Occurrences mempty mempty - , tutorialRegGroup = Nothing -- TODO: remove - , tutorialRegisterFrom = Nothing - , tutorialRegisterTo = Nothing - , tutorialDeregisterUntil = Nothing - , tutorialLastChanged = now - , tutorialTutorControlled = False - , .. - } - -- TODO: update should not happen - [ TutorialType =. CI.mk "Schulung" - , TutorialLastChanged =. now - ] - audit $ TransactionTutorialEdit tutId - return tutId + let dayDiff = diffDays firstDay tmplFirstDay + addBusinessDays + Entity tutId _ <- upsert + Tutorial + { tutorialCourse = cid + , tutorialType = CI.mk "Schulung" + , tutorialCapacity = Nothing + , tutorialRoom = Nothing + , tutorialRoomHidden = False + , tutorialTime = Occurrences mempty mempty + , tutorialRegGroup = Nothing -- TODO: remove + , tutorialRegisterFrom = Nothing + , tutorialRegisterTo = Nothing + , tutorialDeregisterUntil = Nothing + , tutorialLastChanged = now + , tutorialTutorControlled = False + , tutorialFirstDay = anchorDay + , .. + } + error "TODO" -- CONTINUE HERE + audit $ TransactionTutorialEdit tutId + return tutId + + _ -> do + Entity tutId _ <- upsert + Tutorial + { tutorialCourse = cid + , tutorialType = CI.mk "Schulung" + , tutorialCapacity = Nothing + , tutorialRoom = Nothing + , tutorialRoomHidden = False + , tutorialTime = Occurrences mempty mempty + , tutorialRegGroup = Nothing -- TODO: remove + , tutorialRegisterFrom = Nothing + , tutorialRegisterTo = Nothing + , tutorialDeregisterUntil = Nothing + , tutorialLastChanged = now + , tutorialTutorControlled = False + , tutorialFirstDay = anchorDay + , .. + } + [ ] -- should alwyas be an insert + audit $ TransactionTutorialEdit tutId + return tutId diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 1dfad401f..cfe920688 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -24,7 +24,7 @@ module Handler.Utils.DateTime , fromDays, fromMonths , weeksToAdd , setYear, getYear - , firstDayOfWeekOnAfter, daysOfWeekBetween, occurrencesBounds + , firstDayOfWeekOnAfter, daysOfWeekBetween , ceilingQuarterHour , formatGregorianW ) where @@ -287,22 +287,6 @@ firstDayOfWeekOnAfter dw d = addDays (toInteger $ dayOfWeekDiff dw $ dayOfWeek d daysOfWeekBetween :: (Day, Day) -> DayOfWeek -> Set Day daysOfWeekBetween (dstart, dend) wday = Set.fromAscList $ takeWhile (dend >=) $ iterate (addDays 7) $ firstDayOfWeekOnAfter wday dstart --- | Get bounds for an Occurrences -occurrencesBounds :: Term -> Occurrences -> (Maybe Day, Maybe Day) -occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupMax occDays) - where - occDays = (scdDays <> plsDays) \\ excDays -- (excDays <> termHolidays term) -- TODO: should holidays be exluded here? Probably not, as they can be added as exceptions already - - scdDays = Set.foldr getOccDays mempty occurrencesScheduled - (plsDays,excDays) = Set.foldr getExcDays mempty occurrencesExceptions - - getExcDays :: OccurrenceException -> (Set Day, Set Day) -> (Set Day, Set Day) - getExcDays ExceptNoOccur{exceptTime} (occ,exc) = (occ, Set.insert (localDay exceptTime) exc) - getExcDays ExceptOccur{exceptDay} (occ,exc) = (Set.insert exceptDay occ, exc) - - getOccDays :: OccurrenceSchedule -> Set Day -> Set Day - getOccDays ScheduleWeekly{scheduleDayOfWeek=wday} = Set.union $ daysOfWeekBetween (termLectureStart,termLectureEnd) wday - addOneWeek :: UTCTime -> UTCTime addOneWeek = addWeeks 1 diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index 2551d57f3..262cad56c 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/src/Handler/Utils/Occurrences.hs @@ -4,12 +4,15 @@ module Handler.Utils.Occurrences ( occurrencesWidget + , occurrencesBounds + , occurrencesAddBusinessDays ) where import Import import qualified Data.Set as Set +import Utils.Holidays (isWeekend) import Utils.Occurrences import Handler.Utils.DateTime @@ -31,3 +34,41 @@ occurrencesWidget (normalizeOccurrences -> Occurrences{..}) = do exceptTime' <- formatTime SelFormatDateTime exceptTime $(widgetFile "widgets/occurrence/cell/except-no-occur") $(widgetFile "widgets/occurrence/cell") + +-- | Get bounds for an Occurrences +occurrencesBounds :: Term -> Occurrences -> (Maybe Day, Maybe Day) +occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupMax occDays) + where + occDays = (scdDays <> plsDays) \\ excDays -- (excDays <> termHolidays term) -- TODO: should holidays be exluded here? Probably not, as they can be added as exceptions already + + scdDays = Set.foldr getOccDays mempty occurrencesScheduled + (plsDays,excDays) = Set.foldr getExcDays mempty occurrencesExceptions + + getExcDays :: OccurrenceException -> (Set Day, Set Day) -> (Set Day, Set Day) + getExcDays ExceptNoOccur{exceptTime} (occ,exc) = (occ, Set.insert (localDay exceptTime) exc) + getExcDays ExceptOccur{exceptDay} (occ,exc) = (Set.insert exceptDay occ, exc) + + getOccDays :: OccurrenceSchedule -> Set Day -> Set Day + getOccDays ScheduleWeekly{scheduleDayOfWeek=wday} = Set.union $ daysOfWeekBetween (termLectureStart,termLectureEnd) wday + +occurrencesAddBusinessDays :: Term -> (Day,Day) -> Occurrences -> Occurrences +occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrences newSchedule newExceptions + where + newSchedule = Set.map switchDayOfWeek occurrencesScheduled + dayDiff = diffDays dayNew dayOld + + switchDayOfWeek :: OccurrenceSchedule -> OccurrenceSchedule + switchDayOfWeek _ | 0 == dayDiff `mod` 7 = id + os{scheduleDayOfWeek=wday} = os{scheduleDayOfWeek= toEnum (dayDiff + fromEnum wday)} + + newExceptions = Set.map advanceExceptions occurrencesExceptions + + advanceExceptions :: OccurrenceException -> OccurrenceException + advanceExceptions ex@ExceptOccur{ exceptDay = ed } = ex{ exceptDay = pushSkip ed } + advanceExceptions ex@ExxceptNoOccur{ exceptTime = et@LocalTime { localDay = ed } } = ex{ exceptDay = et{ localDay = pushSkip ed}} + + pushSkip :: Day -> Day + pushSkip = let weekends = [d | d <- [(min termLectureStart termStart)..(max termEnd termLectureEnd)], isWeekend d] + offDays = Set.fromList $ termHolidays <> weekends + + in \ No newline at end of file diff --git a/src/Utils/Holidays.hs b/src/Utils/Holidays.hs index 649d0f16c..b8ae4fa18 100644 --- a/src/Utils/Holidays.hs +++ b/src/Utils/Holidays.hs @@ -150,11 +150,11 @@ index2year y = result -- | Test for Saturday/Sunday isWeekend :: Day -> Bool isWeekend = isWeekend' . dayOfWeek - where - isWeekend' :: WeekDay -> Bool - isWeekend' Sunday = True - isWeekend' Saturday = True - isWeekend' _ = False + +isWeekend' :: WeekDay -> Bool +isWeekend' Sunday = True +isWeekend' Saturday = True +isWeekend' _ = False -- | Always returns a business day. -- | Saturday/Sunday/Holiday treated like next (n>=0) or previous (n<0) working day