chore(tutorial): WIP templates advancement

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

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

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 
+    -- 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

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

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