chore(tutorial): WIP towards tutorial templates

2023-05-22 14:36:49 +00:00 · 2023-05-22 14:36:49 +00:00 · 109f8ce860
commit 109f8ce860
parent e99a37cfd6
5 changed files with 99 additions and 54 deletions
--- 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
--- 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



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

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