chore(occurrences): complete bounds function

models/tutorials.model

@@ -16,6 +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
     UniqueTutorial course name
     deriving Generic
 Tutor

src/Handler/Course/ParticipantInvite.hs

@@ -288,6 +288,46 @@ upsertNewTutorial cid tutorialName = do
     audit $ TransactionTutorialEdit tutId
     return tutId
 
+tutorialTemplates :: [CI Text]
+tutorialTemplates = ["Vorlage", "Template"]
+
+upsertNewTutorialTemplate :: CourseId -> TutorialName -> Handler TutorialId
+upsertNewTutorialTemplate cid tutorialName = runDB $ do
+  now <- liftIO getCurrentTime
+  getBy UniqueTutorial cid tutorialName >>= \case
+    Just (Entity{entityVal=tid}) -> return tid -- no need to update
+    Nothing -> 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
+
+
+
 registerTutorialMembers :: TutorialId -> Set UserId -> Handler ()
 registerTutorialMembers tutId (Set.toList -> users) = runDB $ do
   prevParticipants <- Set.fromList . fmap entityKey <$> selectList [TutorialParticipantUser <-. users, TutorialParticipantTutorial ==. tutId] []

src/Handler/Utils/DateTime.hs

@@ -24,7 +24,7 @@ module Handler.Utils.DateTime
   , fromDays, fromMonths
   , weeksToAdd
   , setYear, getYear
-  , firstDayOfWeekOnAfter
+  , firstDayOfWeekOnAfter, daysOfWeekBetween, occurrencesBounds
   , ceilingQuarterHour
   , formatGregorianW
   ) where
@@ -44,6 +44,7 @@ import qualified Data.Csv as Csv
 
 import qualified Data.Char as Char
 
+import Data.List (iterate)
 
 -------------
 -- UTCTime --
@@ -283,6 +284,25 @@ dayOfWeekDiff a b = mod (fromEnum a - fromEnum b) 7
 firstDayOfWeekOnAfter :: DayOfWeek -> Day -> Day
 firstDayOfWeekOnAfter dw d = addDays (toInteger $ dayOfWeekDiff dw $ dayOfWeek d) 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/Jobs/Types.hs

@@ -146,9 +146,9 @@ data Notification
   | NotificationSubmissionEdited { nInitiator :: UserId, nSubmission :: SubmissionId }
   | NotificationSubmissionUserCreated { nUser :: UserId, nSubmission :: SubmissionId }
   | NotificationSubmissionUserDeleted { nUser :: UserId, nSheet :: SheetId, nSubmission :: SubmissionId }
-  | NotificationQualificationExpiry  { nQualification :: QualificationId, nExpiry :: Day }
-  | NotificationQualificationExpired { nQualification :: QualificationId }
-  | NotificationQualificationRenewal { nQualification :: QualificationId }
+  | NotificationQualificationExpiry  { nQualification :: QualificationId, nExpiry :: Day } -- NotificationTrigger: NTQualification TODO: separate
+  | NotificationQualificationExpired { nQualification :: QualificationId }                 -- NotificationTrigger: NTQualification
+  | NotificationQualificationRenewal { nQualification :: QualificationId }                 -- NotificationTrigger: NTQualification
   deriving (Eq, Ord, Show, Read, Generic)
 
 instance Hashable Job

src/Model/Types/DateTime.hs

@@ -15,7 +15,7 @@ module Model.Types.DateTime
 
 import Import.NoModel
 
-import qualified Data.Set as Set
+-- import qualified Data.Set as Set
 import Data.Ratio ((%))
 import qualified Data.Text as Text
 -- import Data.Either.Combinators (maybeToRight, mapLeft)
@@ -207,16 +207,3 @@ derivePersistFieldJSON ''Occurrences
 
 
 nullaryPathPiece ''DayOfWeek camelToPathPiece
-
-
--- | Get bounds for an Occurrences 
---   TODO: unfinished function, only works for a few selected cases yet
-occurrencesBounds :: Occurrences -> (Maybe Day, Maybe Day)
-occurrencesBounds Occurrences{occurrencesScheduled=scd} | notNull scd = (Nothing, Nothing) -- TODO: case is not yet implemented
-occurrencesBounds Occurrences{occurrencesExceptions=exc} = (Set.lookupMin occDays, Set.lookupMax occDays)    
-  where
-    occDays = Set.foldr getOccDays mempty exc
-
-    getOccDays :: OccurrenceException -> Set Day -> Set Day
-    getOccDays ExceptNoOccur{}        acc = acc                         -- TODO: this case ignores ExceptNoOccur for now!
-    getOccDays ExceptOccur{exceptDay} acc = Set.insert exceptDay acc

src/Utils/Print/CourseCertificate.hs

@@ -16,6 +16,7 @@ import Data.FileEmbed (embedFile)
 
 import Utils.Print.Letters
 import Handler.Utils.Profile
+import Handler.Utils.DateTime
 
 data LetterCourseCertificate = LetterCourseCertificate
     { ccCourseId          :: CourseId
@@ -79,8 +80,10 @@ makeCourseCertificates Tutorial{ tutorialName   = CI.original -> ccTutorialName
         , courseShorthand   = CI.original               -> ccCourseShorthand
         , courseSchool      = CI.original . unSchoolKey -> ccCourseSchool
         , courseDescription = fmap html2textlines       -> ccCourseContent
+        , courseTerm        = termId
         } <- get404 ccCourseId
-  let (ccCourseBegin, ccCourseEnd) = eq2nothing $ occurrencesBounds occurrences      
+  term <- get404 termId
+  let (ccCourseBegin, ccCourseEnd) = eq2nothing $ occurrencesBounds term occurrences
   forM participants $ \uid -> do
     User{userDisplayName=ccParticipant, userCompanyDepartment, userCompanyPersonalNumber} <- get404 uid    
     (ccFraNumber, ccFraDepartment, ccCompany) <-