From c2521df20b6cfe1ac9a59b2c0d6a3a4d1398959a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 23 May 2023 17:28:22 +0200 Subject: [PATCH] chore(tutorial): WIP templates advancement --- src/Handler/Course/ParticipantInvite.hs | 37 +++++++++---------- src/Handler/Tutorial/New.hs | 4 +- src/Handler/Utils/Occurrences.hs | 49 ++++++++++++------------- src/Handler/Utils/Term.hs | 2 +- src/Model/Types/DateTime.hs | 15 ++++++-- 5 files changed, 55 insertions(+), 52 deletions(-) diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 39b0246fe..05757ee86 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -289,37 +289,34 @@ upsertNewTutorial cid tutorialName = do audit $ TransactionTutorialEdit tutId return tutId --- tutorialTemplates :: [CI Text] --- tutorialTemplates = ["Vorlage", "Template"] +tutorialTemplateNames :: Maybe (CI Text) -> [CI Text] +tutorialTemplateNames Nothing = ["Vorlage", "Template"] +tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- ["", Text.cons '_' name]] -{- -upsertNewTutorialTemplate :: CourseId -> TutorialName -> Maybe Day -> Handler TutorialId -upsertNewTutorialTemplate cid tutorialName anchorDay = runDB $ do +upsertNewTutorialTemplate :: CourseId -> TutorialName -> Maybe (CI Text) -> Maybe Day -> Handler TutorialId +upsertNewTutorialTemplate cid newTutorialName newTutorialType anchorDay = runDB $ do now <- liftIO getCurrentTime - existingTut <- getBy $ UniqueTutorial cid tutorialName - templateEnt <- selectFirst [TutorialType <-. tutorialTemplates] [Desc TutorialType] + existingTut <- getBy $ UniqueTutorial cid tutorialName + templateEnt <- selectFirst [TutorialType <-. tutorialTemplateNames newTutorialType] [Desc TutorialType] case (existingTut, anchorDay, templateEnt) of (Just (Entity{entityKey=tid}),_,_) -> return tid -- no need to update, we ignore the anchor day - (Nothing, Just firstDay, Just Entity{entityVal=Tutorial{tutorialFirstDay=Just tmplFirstDay}}) -> do + (Nothing, Just newFirstDay, Just Entity{entityVal=Tutorial{..}}) -> do Course{..} <- get404 cid - Term{termLectureStart} <- get404 courseTerm - let dayDiff = diffDays firstDay tmplFirstDay - -- addBusinessDays + term <- get404 courseTerm + let newTime = occurrencesAddBusinessDays term (tutorialFirstDay, newFirstDay) Entity tutId _ <- upsert Tutorial - { tutorialCourse = cid - , tutorialType = CI.mk "Schulung" - , tutorialCapacity = Nothing - , tutorialRoom = Nothing - , tutorialRoomHidden = False - , tutorialTime = Occurrences mempty mempty - , tutorialRegGroup = Nothing -- TODO: remove + { tutorialCourse = cid + , tutorialType = fromMaybe (CI.mk "Schulung") newTutorialType + , tutorialTime = newTime + , tutorialFirstDay = newFirstDay + , tutorialName = newTutorialName + -- TODO , tutorialRegisterFrom = Nothing , tutorialRegisterTo = Nothing , tutorialDeregisterUntil = Nothing , tutorialLastChanged = now - , tutorialTutorControlled = False - , tutorialFirstDay = anchorDay + , .. } [] -- error "TODO" -- CONTINUE HERE diff --git a/src/Handler/Tutorial/New.hs b/src/Handler/Tutorial/New.hs index cfef01e19..53a11c3c0 100644 --- a/src/Handler/Tutorial/New.hs +++ b/src/Handler/Tutorial/New.hs @@ -20,14 +20,14 @@ import Handler.Tutorial.TutorInvite getCTutorialNewR, postCTutorialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCTutorialNewR = postCTutorialNewR postCTutorialNewR tid ssh csh = do - cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + Entity{entityKey=cid, entityVal=course} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh -- TODO: use getKeyBy404 if was optimized to no longer retrieve the full entity from the DB anyway ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing formResult newTutResult $ \TutorialForm{..} -> do insertRes <- runDBJobs $ do now <- liftIO getCurrentTime - term <- fetchTermByCID cid + term <- get404 $ course ^. CourseTerm insertRes <- insertUnique Tutorial { tutorialName = tfName , tutorialCourse = cid diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index eb3022117..7e8dd5fee 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/src/Handler/Utils/Occurrences.hs @@ -5,14 +5,14 @@ module Handler.Utils.Occurrences ( occurrencesWidget , occurrencesBounds - -- , occurrencesAddBusinessDays + , occurrencesAddBusinessDays ) where import Import import qualified Data.Set as Set --- import Utils.Holidays (isWeekend) +import Utils.Holidays (isWeekend) import Utils.Occurrences import Handler.Utils.DateTime @@ -51,30 +51,29 @@ occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupM 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 +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 --- switchDayOfWeek os@ScheduleWeekly{scheduleDayOfWeek=wday} = os{scheduleDayOfWeek= toEnum (dayDiff + fromEnum wday)} + offDays = Set.fromList $ termHolidays <> weekends + weekends = [d | d <- [(min termLectureStart termStart)..(max termEnd termLectureEnd)], isWeekend d] --- newExceptions = snd $ Set.foldr advanceExceptions (dayDiff,mempty) occurrencesExceptions + switchDayOfWeek :: OccurrenceSchedule -> OccurrenceSchedule + switchDayOfWeek _ | 0 == dayDiff `mod` 7 = id + switchDayOfWeek os@ScheduleWeekly{scheduleDayOfWeek=wday} = os{scheduleDayOfWeek= toEnum (dayDiff + fromEnum wday)} --- advanceExceptions :: OccurrenceException -> (Integer, Set OccurrenceException) -> (Integer, Set OccurrenceException) --- advanceExceptions ex@ExceptOccur{ exceptDay = ed } (offset, acc) = --- | add + newExceptions = snd $ Set.foldr advanceExceptions (dayDiff,mempty) occurrencesExceptions - --- advanceExceptions ex@ExceptOccur{ exceptDay = ed } = ex{ exceptDay = pushSkip ed } --- advanceExceptions ex@ExceptNoOccur{ exceptTime = et@LocalTime { localDay = ed } } = ex{ exceptDay = et{ localDay = pushSkip ed}} - --- pushSkip --- pushSkip :: Day -> Day --- pushSkip = id -- TODO --- -- 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 + -- we assume that instance Ord OccurrenceException is ordered chronologically + advanceExceptions :: OccurrenceException -> (Integer, Set OccurrenceException) -> (Integer, Set OccurrenceException) + advanceExceptions ex (offset, acc) + | ed `Set.notMember` offDays -- skip term-holidays and weekends, unless the original day was a holiday or weekend + , nd `Set.member` offDays + = advanceExceptions ex (succ offset, acc) + | otherwise + = (offset, Set.insert (setDayOfOccurrenceException nd ex) acc) + where + ed = dayOfOccurrenceException ex + nd = addDays offset ed diff --git a/src/Handler/Utils/Term.hs b/src/Handler/Utils/Term.hs index fe3bba7eb..841082745 100644 --- a/src/Handler/Utils/Term.hs +++ b/src/Handler/Utils/Term.hs @@ -69,7 +69,7 @@ fetchTermByCID :: ( MonadHandler m ) => CourseId -> ReaderT backend m Term fetchTermByCID cid = do - termList <- E.select . E.from $ \(course `E.InnerJoin` term) -> do + termList <- E.select . E.distinct . E.from $ \(course `E.InnerJoin` term) -> do E.on $ course E.^. CourseTerm E.==. term E.^. TermId E.where_ $ course E.^. CourseId E.==. E.val cid return term diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index 301a392cc..0771ce901 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -188,15 +188,14 @@ data OccurrenceException = ExceptOccur deriving (Eq, Read, Show, Generic) deriving anyclass (NFData) +-- Handler.Utils.Occurrences.occurrencesAddBusinessDays assumes that OccurrenceException is ordered chronologically instance Ord OccurrenceException where compare ExceptOccur{exceptDay=ad, exceptStart=as, exceptEnd=ae} ExceptOccur{exceptDay=bd, exceptStart=bs, exceptEnd=be} = compare (ad,as,ae) (bd,bs,be) compare ExceptOccur{exceptDay=d, exceptStart=s} ExceptNoOccur{exceptTime=e} - = -- replaceEq GT $ - compare (LocalTime d s) e + = replaceEq LT $ compare (LocalTime d s) e compare ExceptNoOccur{exceptTime=e } ExceptOccur{exceptDay=d, exceptStart=s} - = -- replaceEq LT $ - compare e (LocalTime d s) + = replaceEq GT $ compare e (LocalTime d s) compare ExceptNoOccur{exceptTime=ae } ExceptNoOccur{exceptTime=be } = compare ae be @@ -206,6 +205,14 @@ deriveJSON defaultOptions , sumEncoding = TaggedObject "exception" "for" } ''OccurrenceException +dayOfOccurrenceException :: OccurrenceException -> Day +dayOfOccurrenceException ExceptOccur{exceptDay=d} = d +dayOfOccurrenceException ExceptNoOccur{exceptTime=LocalTime{localDay=d}} = d + +setDayOfOccurrenceException :: Day -> OccurrenceException -> OccurrenceException +setDayOfOccurrenceException d ex@ExceptOccur{} = ex{exceptDay=d} +setDayOfOccurrenceException d ExceptNoOccur{exceptTime=lt} = ExceptNoOccur{exceptTime = lt{localDay=d}} + data Occurrences = Occurrences { occurrencesScheduled :: Set OccurrenceSchedule , occurrencesExceptions :: Set OccurrenceException