diff --git a/models/tutorials.model b/models/tutorials.model index 0a8558f29..76aed3e3a 100644 --- a/models/tutorials.model +++ b/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 diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index e129b9d53..b79b6ccac 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/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] [] diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 80669b061..1dfad401f 100644 --- 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 + , 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 diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 4a2a9787e..f3e667f61 100644 --- a/src/Jobs/Types.hs +++ b/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 diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index f36420657..e553eef85 100644 --- a/src/Model/Types/DateTime.hs +++ b/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 diff --git a/src/Utils/Print/CourseCertificate.hs b/src/Utils/Print/CourseCertificate.hs index 76d74533f..d26e0989b 100644 --- a/src/Utils/Print/CourseCertificate.hs +++ b/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) <-