diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 632da122a..39b0246fe 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/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 = ["Vorlage", "Template"] +-- tutorialTemplates :: [CI Text] +-- tutorialTemplates = ["Vorlage", "Template"] +{- upsertNewTutorialTemplate :: CourseId -> TutorialName -> Maybe Day -> Handler TutorialId upsertNewTutorialTemplate cid tutorialName anchorDay = runDB $ do now <- liftIO getCurrentTime - 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 + existingTut <- getBy $ UniqueTutorial cid tutorialName + templateEnt <- selectFirst [TutorialType <-. tutorialTemplates] [Desc TutorialType] + case (existingTut, anchorDay, templateEnt) of + (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 + Course{..} <- get404 cid + 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 diff --git a/src/Handler/Tutorial/Edit.hs b/src/Handler/Tutorial/Edit.hs index 3c58cf3f1..65d616e0a 100644 --- a/src/Handler/Tutorial/Edit.hs +++ b/src/Handler/Tutorial/Edit.hs @@ -25,15 +25,14 @@ getTEditR, postTEditR :: TermId -> SchoolId -> CourseShorthand -> TutorialName - getTEditR = postTEditR postTEditR tid ssh csh tutn = do (cid, tutid, template) <- runDB $ do - (cid, Entity tutid Tutorial{..}) <- fetchCourseIdTutorial tid ssh csh tutn - + (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 tutorInvites <- sourceInvitationsF @Tutor tutid - let + let template = TutorialForm { tfName = tutorialName , tfType = tutorialType @@ -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 diff --git a/src/Handler/Tutorial/New.hs b/src/Handler/Tutorial/New.hs index 8f81c5dcb..cfef01e19 100644 --- a/src/Handler/Tutorial/New.hs +++ b/src/Handler/Tutorial/New.hs @@ -25,8 +25,9 @@ postCTutorialNewR tid ssh csh = do ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing formResult newTutResult $ \TutorialForm{..} -> do - insertRes <- runDBJobs $ 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 diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index 262cad56c..eb3022117 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/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{..} (dayOld, dayNew) Occurrences{..} = Occurrences newSchedule newExceptions - where - newSchedule = Set.map switchDayOfWeek occurrencesScheduled - dayDiff = diffDays dayNew dayOld +-- 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)} +-- switchDayOfWeek :: OccurrenceSchedule -> OccurrenceSchedule +-- switchDayOfWeek _ | 0 == dayDiff `mod` 7 = id +-- 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 ex@ExceptOccur{ exceptDay = ed } = ex{ exceptDay = pushSkip ed } - advanceExceptions ex@ExxceptNoOccur{ exceptTime = et@LocalTime { localDay = ed } } = ex{ exceptDay = et{ localDay = pushSkip ed}} +-- advanceExceptions :: OccurrenceException -> (Integer, Set OccurrenceException) -> (Integer, Set OccurrenceException) +-- advanceExceptions ex@ExceptOccur{ exceptDay = ed } (offset, acc) = +-- | add - pushSkip :: Day -> Day - pushSkip = let weekends = [d | d <- [(min termLectureStart termStart)..(max termEnd termLectureEnd)], isWeekend d] - offDays = Set.fromList $ termHolidays <> weekends - in \ No newline at end of file +-- 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 \ No newline at end of file diff --git a/src/Handler/Utils/Term.hs b/src/Handler/Utils/Term.hs index 49ef41a87..fe3bba7eb 100644 --- a/src/Handler/Utils/Term.hs +++ b/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 \ No newline at end of file diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index e553eef85..301a392cc 100644 --- a/src/Model/Types/DateTime.hs +++ b/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 +-- ] \ No newline at end of file diff --git a/src/Utils.hs b/src/Utils.hs index be7a78eef..4ab7b9a57 100644 --- a/src/Utils.hs +++ b/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 -- ------------ diff --git a/src/Utils/Print/CourseCertificate.hs b/src/Utils/Print/CourseCertificate.hs index d26e0989b..4474ac754 100644 --- a/src/Utils/Print/CourseCertificate.hs +++ b/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 diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 38f6331c2..d393e22cd 100644 --- a/test/Database/Fill.hs +++ b/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 diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 9f5598b68..d6fe5662d 100644 --- a/test/Model/TypesSpec.hs +++ b/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) diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs index 58220bdef..729f1a769 100644 --- a/test/ModelSpec.hs +++ b/test/ModelSpec.hs @@ -93,6 +93,7 @@ instance Arbitrary Tutorial where <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary shrink = genericShrink instance Arbitrary User where