chore(tutorial): WIP towards tutorial templates

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

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 :: CourseId -> TutorialName -> Maybe Day -> Handler TutorialId
-upsertNewTutorialTemplate cid tutorialName = runDB $ do
+upsertNewTutorialTemplate cid tutorialName anchorDay = runDB $ do
   now <- liftIO getCurrentTime
-  getBy UniqueTutorial cid tutorialName >>= \case
+  existingTut <- getBy UniqueTutorial cid tutorialName
-    Just (Entity{entityVal=tid}) -> return tid -- no need to update
+  templateEnt <- selectFirst [TutorialType <-. tutorialTemplates] [Desc TutorialType]
-    Nothing -> do 
+  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
+      let dayDiff = diffDays firstDay tmplFirstDay
-        Just (Entity {entityVal=template}) -> do
+        addBusinessDays 
-          error "TODO"
+      Entity tutId _ <- upsert
-        Nothing -> do
+        Tutorial
-          Entity tutId _ <- upsert
+          { tutorialCourse = cid
-            Tutorial
+          , tutorialType = CI.mk "Schulung"
-              { tutorialCourse = cid
+          , tutorialCapacity = Nothing
-              , tutorialType = CI.mk "Schulung"
+          , tutorialRoom = Nothing
-              , tutorialCapacity = Nothing
+          , tutorialRoomHidden = False
-              , tutorialRoom = Nothing
+          , tutorialTime = Occurrences mempty mempty
-              , tutorialRoomHidden = False
+          , tutorialRegGroup = Nothing -- TODO: remove
-              , tutorialTime = Occurrences mempty mempty
+          , tutorialRegisterFrom = Nothing
-              , tutorialRegGroup = Nothing -- TODO: remove
+          , tutorialRegisterTo = Nothing
-              , tutorialRegisterFrom = Nothing
+          , tutorialDeregisterUntil = Nothing
-              , tutorialRegisterTo = Nothing
+          , tutorialLastChanged = now
-              , tutorialDeregisterUntil = Nothing
+          , tutorialTutorControlled = False
-              , tutorialLastChanged = now
+          , tutorialFirstDay = anchorDay
-              , tutorialTutorControlled = False
+          , ..
-              , ..
+          }            
-              }
+      error "TODO" -- CONTINUE HERE
-            -- TODO: update should not happen
+      audit $ TransactionTutorialEdit tutId
-            [ TutorialType        =. CI.mk "Schulung"
+      return tutId
-            , TutorialLastChanged =. now
+
-            ]
+    _ -> do
-          audit $ TransactionTutorialEdit tutId
+      Entity tutId _ <- upsert
-          return tutId
+        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
 
 
 

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
 

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 

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' :: WeekDay -> Bool
-    isWeekend' Sunday   = True 
+isWeekend' Sunday   = True 
-    isWeekend' Saturday = True 
+isWeekend' Saturday = True 
-    isWeekend' _        = False
+isWeekend' _        = False
 
 -- | Always returns a business day. 
 -- | Saturday/Sunday/Holiday treated like next (n>=0) or previous (n<0) working day