chore(tutorial): prepare occurrencesAddBusinessDays for templates

src/Handler/Course/ParticipantInvite.hs

@@ -279,6 +279,7 @@ upsertNewTutorial cid tutorialName = do
         , tutorialDeregisterUntil = Nothing
         , tutorialLastChanged = now
         , tutorialTutorControlled = False
+        , tutorialFirstDay = Nothing
         , ..
         }
       [ TutorialName        =. tutorialName
@@ -288,21 +289,22 @@ upsertNewTutorial cid tutorialName = do
     audit $ TransactionTutorialEdit tutId
     return tutId
 
-tutorialTemplates :: [CI Text]
+-- tutorialTemplates :: [CI Text]
-tutorialTemplates = ["Vorlage", "Template"]
+-- tutorialTemplates = ["Vorlage", "Template"]
 
+{-
 upsertNewTutorialTemplate :: CourseId -> TutorialName -> Maybe Day -> Handler TutorialId
 upsertNewTutorialTemplate cid tutorialName anchorDay = runDB $ do
   now <- liftIO getCurrentTime
-  existingTut <- getBy UniqueTutorial cid tutorialName
+  existingTut <- getBy $ UniqueTutorial cid tutorialName
   templateEnt <- selectFirst [TutorialType <-. tutorialTemplates] [Desc TutorialType]  
-  case (existingTut, anchorDay) of
+  case (existingTut, anchorDay, templateEnt) of
-    (Just (Entity{entityVal=tid}),_,_) -> return tid -- no need to update, we ignore the anchor day 
+    (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 firstDay, Just Entity{entityVal=Tutorial{tutorialFirstDay=Just tmplFirstDay}}) -> do
-      Course{..} <- getBy404 cid
+      Course{..} <- get404 cid
-      Term{termLectureStart} <- getBy404 courseTerm
+      Term{termLectureStart} <- get404 courseTerm
       let dayDiff = diffDays firstDay tmplFirstDay
-        addBusinessDays 
+      -- addBusinessDays 
       Entity tutId _ <- upsert
         Tutorial
           { tutorialCourse = cid
@@ -319,11 +321,10 @@ upsertNewTutorialTemplate cid tutorialName anchorDay = runDB $ do
           , tutorialTutorControlled = False
           , tutorialFirstDay = anchorDay
           , ..
-          }            
+          }  []
-      error "TODO" -- CONTINUE HERE
+      -- error "TODO" -- CONTINUE HERE
       audit $ TransactionTutorialEdit tutId
       return tutId
-
     _ -> do
       Entity tutId _ <- upsert
         Tutorial
@@ -346,7 +347,7 @@ upsertNewTutorialTemplate cid tutorialName anchorDay = runDB $ do
       audit $ TransactionTutorialEdit tutId
       return tutId
 
-
+-}
 
 registerTutorialMembers :: TutorialId -> Set UserId -> Handler ()
 registerTutorialMembers tutId (Set.toList -> users) = runDB $ do

src/Handler/Tutorial/Edit.hs

@@ -26,7 +26,6 @@ getTEditR = postTEditR
 postTEditR tid ssh csh tutn = do
   (cid, tutid, template) <- runDB $ do
     (cid, Entity tutid Tutorial{..}) <- fetchCourseIdTutorial tid ssh csh tutn        
-
     tutorIds <- fmap (map E.unValue) . E.select . E.from $ \tutor -> do
       E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
       return $ tutor E.^. TutorUser
@@ -56,6 +55,7 @@ postTEditR tid ssh csh tutn = do
 
   formResult newTutResult $ \TutorialForm{..} -> do
     insertRes <- runDBJobs $ do
+      term <- fetchTermByCID cid
       now <- liftIO getCurrentTime
       insertRes <- myReplaceUnique tutid Tutorial
         { tutorialName            = tfName
@@ -71,6 +71,7 @@ postTEditR tid ssh csh tutn = do
         , tutorialDeregisterUntil = tfDeregisterUntil
         , tutorialLastChanged     = now
         , tutorialTutorControlled = tfTutorControlled
+        , tutorialFirstDay        = fst $ occurrencesBounds term tfTime
         }
       when (is _Nothing insertRes) $ do
         audit $ TransactionTutorialEdit tutid

src/Handler/Tutorial/New.hs

@@ -27,6 +27,7 @@ postCTutorialNewR tid ssh csh = do
   formResult newTutResult $ \TutorialForm{..} -> do
     insertRes <- runDBJobs $ do      
       now <- liftIO getCurrentTime
+      term <- fetchTermByCID cid
       insertRes <- insertUnique Tutorial
         { tutorialName            = tfName
         , tutorialCourse          = cid
@@ -41,6 +42,7 @@ postCTutorialNewR tid ssh csh = do
         , tutorialDeregisterUntil = tfDeregisterUntil
         , tutorialLastChanged     = now
         , tutorialTutorControlled = tfTutorControlled
+        , tutorialFirstDay        = fst $ occurrencesBounds term tfTime
         }
       whenIsJust insertRes $ \tutid -> do
         audit $ TransactionTutorialEdit tutid

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,24 +51,30 @@ 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 -> (Day,Day) -> Occurrences -> Occurrences
-occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrences newSchedule newExceptions
+-- occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrences newSchedule newExceptions
-  where
+--   where
-    newSchedule = Set.map switchDayOfWeek occurrencesScheduled
+--     newSchedule = Set.map switchDayOfWeek occurrencesScheduled
-    dayDiff = diffDays dayNew dayOld
+--     dayDiff = diffDays dayNew dayOld
 
-    switchDayOfWeek :: OccurrenceSchedule -> OccurrenceSchedule
+--     switchDayOfWeek :: OccurrenceSchedule -> OccurrenceSchedule
-    switchDayOfWeek _ | 0 == dayDiff `mod` 7 = id
+--     switchDayOfWeek _ | 0 == dayDiff `mod` 7    = id
-      os{scheduleDayOfWeek=wday} = os{scheduleDayOfWeek= toEnum (dayDiff + fromEnum wday)}
+--     switchDayOfWeek os@ScheduleWeekly{scheduleDayOfWeek=wday}  = os{scheduleDayOfWeek= toEnum (dayDiff + fromEnum wday)}
 
-    newExceptions = Set.map advanceExceptions occurrencesExceptions
+--     newExceptions = snd $ Set.foldr advanceExceptions (dayDiff,mempty) occurrencesExceptions
 
-    advanceExceptions :: OccurrenceException -> OccurrenceException
+--     advanceExceptions :: OccurrenceException -> (Integer, Set OccurrenceException) -> (Integer, Set OccurrenceException)
-    advanceExceptions ex@ExceptOccur{ exceptDay = ed } = ex{ exceptDay = pushSkip ed }
+--     advanceExceptions ex@ExceptOccur{ exceptDay = ed } (offset, acc) =
-    advanceExceptions ex@ExxceptNoOccur{ exceptTime = et@LocalTime { localDay = ed } } = ex{ exceptDay = et{ localDay = pushSkip ed}}
+--       | add
 
-    pushSkip :: Day -> Day
-    pushSkip = let  weekends = [d | d <- [(min termLectureStart termStart)..(max termEnd termLectureEnd)], isWeekend d]
-                    offDays = Set.fromList $ termHolidays <> weekends
 
-               in 
+--     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 

src/Handler/Utils/Term.hs

@@ -6,6 +6,7 @@ module Handler.Utils.Term
   ( groupHolidays
   , getCurrentTerm
   , getActiveTerms
+  , fetchTermByCID
   , module Utils.Term
   ) where
 
@@ -61,3 +62,17 @@ getActiveTerms = do
 
   fmap Set.fromDistinctAscList . runConduit $
     E.selectSource activeTermsQuery .| C.map E.unValue .| C.sinkList
+
+fetchTermByCID :: ( MonadHandler m
+                  , BackendCompatible SqlBackend backend                  
+                  , PersistQueryRead backend, PersistUniqueRead backend
+                  )
+              => CourseId -> ReaderT backend m Term
+fetchTermByCID cid = do
+  termList <- E.select . 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
+  case termList of
+    [term] -> return $ entityVal term
+    _other -> notFound

src/Model/Types/DateTime.hs

@@ -21,6 +21,7 @@ import qualified Data.Text as Text
 -- import Data.Either.Combinators (maybeToRight, mapLeft)
 import Text.Read (readMaybe)
 
+-- import Data.Time.LocalTime
 import Data.Time.Calendar.WeekDate
 -- import Data.Time.Format.ISO8601
 
@@ -184,9 +185,21 @@ data OccurrenceException = ExceptOccur
                         | ExceptNoOccur
                           { exceptTime  :: LocalTime
                           }
-  deriving (Eq, Ord, Read, Show, Generic)
+  deriving (Eq, Read, Show, Generic)
   deriving anyclass (NFData)
 
+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
+  compare ExceptNoOccur{exceptTime=e } ExceptOccur{exceptDay=d, exceptStart=s} 
+    = -- replaceEq LT $ 
+      compare e (LocalTime d s)
+  compare ExceptNoOccur{exceptTime=ae } ExceptNoOccur{exceptTime=be }
+    = compare ae be 
+
 deriveJSON defaultOptions
   { fieldLabelModifier = camelToPathPiece' 1
   , constructorTagModifier = camelToPathPiece' 1
@@ -207,3 +220,23 @@ derivePersistFieldJSON ''Occurrences
 
 
 nullaryPathPiece ''DayOfWeek camelToPathPiece
+
+
+-- test :: IO [OccurrenceException]
+-- test = do 
+--   now <- getCurrentTime
+--   tz <- getCurrentTimeZone
+--   let lt1 = utcToLocalTime tz now 
+--       tomorrow = addUTCTime nominalDay now 
+--       lt2 = utcToLocalTime tz tomorrow
+--       yesterday = addUTCTime (negate nominalDay) now 
+--       lt3 = utcToLocalTime tz yesterday
+--   pure 
+--     [ ExceptOccur (utctDay tomorrow ) midday midnight
+--     , ExceptOccur (utctDay now      ) midnight midnight
+--     , ExceptOccur (utctDay now      ) midday midnight
+--     , ExceptOccur (utctDay yesterday) midday midnight 
+--     , ExceptNoOccur lt3
+--     , ExceptNoOccur lt1
+--     , ExceptNoOccur lt2
+--     ]

src/Utils.hs

@@ -1745,7 +1745,7 @@ maxOn = maxBy . comparing
 inBetween:: Ord a => a -> (a,a) -> Bool
 inBetween x (lower,upper) = lower <= x && x <= upper
 
--- | Given to values and a criterion, returns the unique argument that fulfills the criterion, if it exists
+-- | Given two values and a criterion, returns the unique argument that fulfills the criterion, if it exists
 pickBetter :: a -> a -> (a -> Bool) -> Maybe a
 pickBetter x y crit
     | cx == cy  = Nothing
@@ -1755,6 +1755,15 @@ pickBetter x y crit
     cx = crit x 
     cy = crit y
 
+reverseOrdering :: Ordering -> Ordering
+reverseOrdering EQ = EQ
+reverseOrdering GT = LT
+reverseOrdering LT = GT
+
+replaceEq :: Ordering -> Ordering -> Ordering
+replaceEq r EQ    = r
+replaceEq _ other = other
+
 ------------
 -- Random --
 ------------

src/Utils/Print/CourseCertificate.hs

@@ -16,7 +16,8 @@ import Data.FileEmbed (embedFile)
 
 import Utils.Print.Letters
 import Handler.Utils.Profile
-import Handler.Utils.DateTime
+-- import Handler.Utils.DateTime
+import Handler.Utils.Occurrences
 
 data LetterCourseCertificate = LetterCourseCertificate
     { ccCourseId          :: CourseId

test/Database/Fill.hs

@@ -1014,6 +1014,7 @@ fillDb = do
           , tutorialDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight
           , tutorialLastChanged     = now
           , tutorialTutorControlled = True
+          , tutorialFirstDay        = Just firstDay
           }
         insert_ $ Tutor tut1 jost
         void . insert' $ Exam

test/Model/TypesSpec.hs

@@ -445,6 +445,8 @@ spec = do
       [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, commutativeSemigroupLaws, commutativeMonoidLaws ]
     lawsCheckHspec (Proxy @TermIdentifier)
       [ eqLaws, showReadLaws, ordLaws, enumLaws, persistFieldLaws, jsonLaws, httpApiDataLaws, pathPieceLaws ]
+    lawsCheckHspec (Proxy @Occurrences)
+      [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws  ]
     lawsCheckHspec (Proxy @StudyFieldType)
       [ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, persistFieldLaws ]
     lawsCheckHspec (Proxy @Theme)

test/ModelSpec.hs

@@ -93,6 +93,7 @@ instance Arbitrary Tutorial where
     <*> arbitrary
     <*> arbitrary
     <*> arbitrary
+    <*> arbitrary
   shrink = genericShrink
 
 instance Arbitrary User where