From bcbaad0da89e40b5cd25152c080220dd887688ba Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 23 Sep 2021 18:00:13 +0200 Subject: [PATCH] chore(testdata): terms changes to yearly quarters working now --- test/Database/Fill.hs | 185 ++++++++++++++++------------------------ test/Model/TypesSpec.hs | 6 +- 2 files changed, 75 insertions(+), 116 deletions(-) diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 1734b2f1b..df48e0d35 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -12,7 +12,7 @@ import qualified Data.Text as Text import qualified Data.Set as Set import qualified Data.Map as Map -import Data.Time.Calendar.OrdinalDate +-- import Data.Time.Calendar.OrdinalDate import Data.Time.Calendar.WeekDate import Control.Applicative (ZipList(..)) @@ -57,48 +57,31 @@ fillDb = do (currentYear, currentMonth, _) = toGregorian $ utctDay now currentTerm - | 4 <= currentMonth - , currentMonth <= 9 - = TermIdentifier currentYear Summer - | otherwise - = TermIdentifier (pred currentYear) Winter + | 3 <= currentMonth = TermIdentifier currentYear Q1 + | 6 <= currentMonth = TermIdentifier currentYear Q2 + | 9 <= currentMonth = TermIdentifier currentYear Q3 + | otherwise = TermIdentifier currentYear Q4 nextTerm = succ currentTerm prevTerm = pred currentTerm prevPrevTerm = pred prevTerm - seasonTerm next wSeason - | wSeason == season currentTerm - , next = currentTerm - | wSeason == season currentTerm - = prevPrevTerm - | next - = nextTerm - | otherwise - = prevTerm + seasonTerm next wSeason = until (((==) wSeason) . season) prog currentTerm + where prog | next = succ + | otherwise = pred termTime :: Bool -- ^ Next term? -> Season -> Rational -> Bool -- ^ Relative to end of semester? -> WeekDay - -> (Day -> UTCTime) + -> (Day -> UTCTime) -- ^ Add time to day -> UTCTime termTime next gSeason weekOffset fromEnd d = ($ utctDay) where utctDay = fromWeekDate wYear wWeek $ fromEnum d - (wYear, wWeek, _) = toWeekDate . addDays (round $ 7 * weekOffset) $ fromGregorian gYear rMonth rDay - gYear = year $ seasonTerm next gSeason - (rMonth, rDay) - | Winter <- gSeason - , True <- fromEnd - = (03, 31) - | Winter <- gSeason - , False <- fromEnd - = (10, 01) - | True <- fromEnd - = (09, 30) - | otherwise - = (04, 01) + (wYear, wWeek, _) = toWeekDate . addDays (round $ 7 * weekOffset) $ fromGregorian rYear rMonth rDay + gTid = seasonTerm next gSeason + (rYear, rMonth, rDay) = toGregorian $ guessDay gTid $ bool TermDayLectureStart TermDayLectureEnd fromEnd gkleen <- insert User { userIdent = "G.Kleen@campus.lmu.de" @@ -369,42 +352,18 @@ fillDb = do Nothing -> repack [st|#{firstName}.#{userSurname}@example.invalid|] matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int) manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel + + forM_ [prevPrevTerm, prevTerm, currentTerm, nextTerm, succ nextTerm] $ \tid -> do + let term = Term { termName = tid + , termStart = guessDay tid TermDayStart + , termEnd = guessDay tid TermDayEnd + , termHolidays = [] + , termLectureStart = guessDay tid TermDayLectureStart + , termLectureEnd = guessDay tid TermDayLectureEnd + } + void $ repsert (TermKey tid) term + void . insert_ $ TermActive (TermKey tid) (toMidnight $ addDays (-60) $ termStart term) (Just . beforeMidnight $ addDays 60 $ termEnd term) Nothing - forM_ [prevPrevTerm, prevTerm, currentTerm, nextTerm] $ \term@TermIdentifier{..} -> case season of - Summer -> do - let (wYearStart, wWeekStart, _) = toWeekDate $ fromGregorian year 04 01 - termLectureStart = fromWeekDate wYearStart (wWeekStart + 2) 1 - termLectureEnd = fromWeekDate wYearStart (wWeekStart + 16) 5 - termStart = fromGregorian year 04 01 - termEnd = fromGregorian year 09 30 - void . repsert (TermKey term) $ Term - { termName = term - , termStart - , termEnd - , termHolidays = [] - , termLectureStart - , termLectureEnd - } - void . insert_ $ TermActive (TermKey term) (toMidnight $ addDays (-60) termStart) (Just . beforeMidnight $ addDays 60 termEnd) Nothing - Winter -> do - let (wYearStart, wWeekStart, _) = toWeekDate $ fromGregorian year 10 01 - termLectureStart = fromWeekDate wYearStart (wWeekStart + 2) 1 - (fromIntegral -> wYearOffset, wWeekEnd) = (wWeekStart + 18) `divMod` bool 53 54 longYear - termLectureEnd = fromWeekDate (wYearStart + wYearOffset) (bool id succ (wYearOffset /= 0) wWeekEnd) 5 - longYear = case toWeekDate $ fromOrdinalDate wYearStart 365 of - (_, 53, _) -> True - _other -> False - termStart = fromGregorian year 10 01 - termEnd = fromGregorian (succ year) 03 31 - void . repsert (TermKey term) $ Term - { termName = term - , termStart - , termEnd - , termHolidays = [] - , termLectureStart - , termLectureEnd - } - void . insert_ $ TermActive (TermKey term) (toMidnight $ addDays (-60) termStart) (Just . beforeMidnight $ addDays 60 termEnd) Nothing ifiAuthorshipStatement <- insertAuthorshipStatement I18n { i18nFallback = htmlToStoredMarkup [shamlet| @@ -616,7 +575,7 @@ fillDb = do now True Nothing - + -- FFP let nbrs :: [Int] nbrs = [1,2,3,27,7,1] @@ -636,13 +595,13 @@ fillDb = do |] , courseLinkExternal = Nothing , courseShorthand = "FFP" - , courseTerm = TermKey $ seasonTerm True Summer + , courseTerm = TermKey $ seasonTerm True Q1 , courseSchool = ifi , courseCapacity = Just 20 , courseVisibleFrom = Just now , courseVisibleTo = Nothing - , courseRegisterFrom = Just $ termTime True Summer (-2) False Monday toMidnight - , courseRegisterTo = Just $ termTime True Summer 0 True Sunday beforeMidnight + , courseRegisterFrom = Just $ termTime True Q1 (-2) False Monday toMidnight + , courseRegisterTo = Just $ termTime True Q1 0 True Sunday beforeMidnight , courseDeregisterUntil = Nothing , courseRegisterSecret = Nothing , courseMaterialFree = True @@ -665,9 +624,9 @@ fillDb = do , sheetType = NotGraded , sheetGrouping = Arbitrary 3 , sheetMarkingText = Nothing - , sheetVisibleFrom = Just $ termTime True Summer 0 False Monday toMidnight - , sheetActiveFrom = Just $ termTime True Summer 1 False Monday toMidnight - , sheetActiveTo = Just $ termTime True Summer 2 False Sunday beforeMidnight + , sheetVisibleFrom = Just $ termTime True Q1 0 False Monday toMidnight + , sheetActiveFrom = Just $ termTime True Q1 1 False Monday toMidnight + , sheetActiveTo = Just $ termTime True Q1 2 False Sunday beforeMidnight , sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing False , sheetHintFrom = Nothing , sheetSolutionFrom = Nothing @@ -687,9 +646,9 @@ fillDb = do , sheetType = NotGraded , sheetGrouping = RegisteredGroups , sheetMarkingText = Nothing - , sheetVisibleFrom = Just $ termTime True Summer 1 False Monday toMidnight - , sheetActiveFrom = Just $ termTime True Summer 2 False Monday toMidnight - , sheetActiveTo = Just $ termTime True Summer 3 False Sunday beforeMidnight + , sheetVisibleFrom = Just $ termTime True Q1 1 False Monday toMidnight + , sheetActiveFrom = Just $ termTime True Q1 2 False Monday toMidnight + , sheetActiveTo = Just $ termTime True Q1 3 False Sunday beforeMidnight , sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing False , sheetHintFrom = Nothing , sheetSolutionFrom = Nothing @@ -709,9 +668,9 @@ fillDb = do , sheetType = NotGraded , sheetGrouping = NoGroups , sheetMarkingText = Nothing - , sheetVisibleFrom = Just $ termTime True Summer 2 False Monday toMidnight - , sheetActiveFrom = Just $ termTime True Summer 3 False Monday toMidnight - , sheetActiveTo = Just $ termTime True Summer 4 False Sunday beforeMidnight + , sheetVisibleFrom = Just $ termTime True Q1 2 False Monday toMidnight + , sheetActiveFrom = Just $ termTime True Q1 3 False Monday toMidnight + , sheetActiveTo = Just $ termTime True Q1 4 False Sunday beforeMidnight , sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing False , sheetHintFrom = Nothing , sheetSolutionFrom = Nothing @@ -737,15 +696,15 @@ fillDb = do , examBonusRule = Nothing , examOccurrenceRule = ExamRoomManual , examExamOccurrenceMapping = Nothing - , examVisibleFrom = Just $ termTime True Summer (-4) True Monday toMidnight - , examRegisterFrom = Just $ termTime True Summer (-4) True Monday toMidnight - , examRegisterTo = Just $ termTime True Summer 1 True Sunday beforeMidnight - , examDeregisterUntil = Just $ termTime True Summer 2 True Wednesday beforeMidnight - , examPublishOccurrenceAssignments = Just $ termTime True Summer 3 True Monday toMidnight - , examStart = Just $ termTime True Summer 3 True Tuesday (toTimeOfDay 10 0 0) - , examEnd = Just $ termTime True Summer 3 True Tuesday (toTimeOfDay 12 0 0) - , examFinished = Just $ termTime True Summer 3 True Wednesday (toTimeOfDay 22 0 0) - , examPartsFrom = Just $ termTime True Summer (-4) True Monday toMidnight + , examVisibleFrom = Just $ termTime True Q1 (-4) True Monday toMidnight + , examRegisterFrom = Just $ termTime True Q1 (-4) True Monday toMidnight + , examRegisterTo = Just $ termTime True Q1 1 True Sunday beforeMidnight + , examDeregisterUntil = Just $ termTime True Q1 2 True Wednesday beforeMidnight + , examPublishOccurrenceAssignments = Just $ termTime True Q1 3 True Monday toMidnight + , examStart = Just $ termTime True Q1 3 True Tuesday (toTimeOfDay 10 0 0) + , examEnd = Just $ termTime True Q1 3 True Tuesday (toTimeOfDay 12 0 0) + , examFinished = Just $ termTime True Q1 3 True Wednesday (toTimeOfDay 22 0 0) + , examPartsFrom = Just $ termTime True Q1 (-4) True Monday toMidnight , examClosed = Nothing , examPublicStatistics = True , examGradingMode = ExamGradingGrades @@ -789,12 +748,12 @@ fillDb = do , courseDescription = Nothing , courseLinkExternal = Nothing , courseShorthand = "EIP" - , courseTerm = TermKey $ seasonTerm False Winter + , courseTerm = TermKey $ seasonTerm False Q4 , courseSchool = ifi , courseCapacity = Just 20 , courseVisibleFrom = Just now , courseVisibleTo = Nothing - , courseRegisterFrom = Just $ termTime False Winter (-4) False Monday toMidnight + , courseRegisterFrom = Just $ termTime False Q4 (-4) False Monday toMidnight , courseRegisterTo = Nothing , courseDeregisterUntil = Nothing , courseRegisterSecret = Nothing @@ -815,13 +774,13 @@ fillDb = do , courseDescription = Nothing , courseLinkExternal = Nothing , courseShorthand = "IXD" - , courseTerm = TermKey $ seasonTerm True Summer + , courseTerm = TermKey $ seasonTerm True Q1 , courseSchool = ifi , courseCapacity = Just 20 , courseVisibleFrom = Just now , courseVisibleTo = Nothing - , courseRegisterFrom = Just $ termTime True Summer 0 False Monday toMidnight - , courseRegisterTo = Just $ termTime True Summer (-2) True Sunday beforeMidnight + , courseRegisterFrom = Just $ termTime True Q1 0 False Monday toMidnight + , courseRegisterTo = Just $ termTime True Q1 (-2) True Sunday beforeMidnight , courseDeregisterUntil = Nothing , courseRegisterSecret = Nothing , courseMaterialFree = True @@ -841,7 +800,7 @@ fillDb = do , courseDescription = Nothing , courseLinkExternal = Nothing , courseShorthand = "UX3" - , courseTerm = TermKey $ seasonTerm True Winter + , courseTerm = TermKey $ seasonTerm True Q4 , courseSchool = ifi , courseCapacity = Just 30 , courseVisibleFrom = Just now @@ -867,12 +826,12 @@ fillDb = do , courseDescription = Nothing , courseLinkExternal = Nothing , courseShorthand = "ProMo" - , courseTerm = TermKey $ seasonTerm True Summer + , courseTerm = TermKey $ seasonTerm True Q1 , courseSchool = ifi , courseCapacity = Just 50 , courseVisibleFrom = Just now , courseVisibleTo = Nothing - , courseRegisterFrom = Just $ termTime True Summer (-2) False Monday toMidnight + , courseRegisterFrom = Just $ termTime True Q1 (-2) False Monday toMidnight , courseRegisterTo = Nothing , courseDeregisterUntil = Nothing , courseRegisterSecret = Nothing @@ -958,11 +917,11 @@ fillDb = do , sheetDescription = Nothing , sheetType, sheetGrouping, sheetSubmissionMode , sheetMarkingText = Nothing - , sheetVisibleFrom = Just $ termTime True Summer prog False Monday toMidnight - , sheetActiveFrom = Just $ termTime True Summer (prog + 1) False Monday toMidnight - , sheetActiveTo = Just $ termTime True Summer (prog + 2) False Sunday beforeMidnight - , sheetHintFrom = Just $ termTime True Summer (prog + 1) False Sunday beforeMidnight - , sheetSolutionFrom = Just $ termTime True Summer (prog + 2) False Sunday beforeMidnight + , sheetVisibleFrom = Just $ termTime True Q1 prog False Monday toMidnight + , sheetActiveFrom = Just $ termTime True Q1 (prog + 1) False Monday toMidnight + , sheetActiveTo = Just $ termTime True Q1 (prog + 2) False Sunday beforeMidnight + , sheetHintFrom = Just $ termTime True Q1 (prog + 1) False Sunday beforeMidnight + , sheetSolutionFrom = Just $ termTime True Q1 (prog + 2) False Sunday beforeMidnight , sheetAutoDistribute = True , sheetAnonymousCorrection = True , sheetRequireExamRegistration = Nothing @@ -1007,7 +966,7 @@ fillDb = do , occurrencesExceptions = Set.empty } , tutorialRegGroup = Just "tutorium" - , tutorialRegisterFrom = Just $ termTime True Summer 0 False Monday toMidnight + , tutorialRegisterFrom = Just $ termTime True Q1 0 False Monday toMidnight , tutorialRegisterTo = Nothing , tutorialDeregisterUntil = Nothing , tutorialLastChanged = now @@ -1027,7 +986,7 @@ fillDb = do , occurrencesExceptions = Set.empty } , tutorialRegGroup = Just "tutorium" - , tutorialRegisterFrom = Just $ termTime True Summer 0 False Monday toMidnight + , tutorialRegisterFrom = Just $ termTime True Q1 0 False Monday toMidnight , tutorialRegisterTo = Nothing , tutorialDeregisterUntil = Nothing , tutorialLastChanged = now @@ -1040,7 +999,7 @@ fillDb = do , courseDescription = Just "Datenbanken banken Daten damit die Daten nicht wanken. Die Datenschützer danken!" , courseLinkExternal = Nothing , courseShorthand = "DBS" - , courseTerm = TermKey $ seasonTerm False Winter + , courseTerm = TermKey $ seasonTerm False Q4 , courseSchool = ifi , courseCapacity = Just 50 , courseVisibleFrom = Just now @@ -1062,7 +1021,7 @@ fillDb = do void . insert' $ DegreeCourse dbs sdBsc sdMath void . insert' $ Lecturer gkleen dbs CourseLecturer void . insert' $ Lecturer jost dbs CourseAssistant - + testMsg <- insert SystemMessage { systemMessageNewsOnly = False , systemMessageFrom = Just now @@ -1140,7 +1099,7 @@ fillDb = do funAlloc <- insert' Allocation { allocationName = "Funktionale Zentralanmeldung" , allocationShorthand = "fun" - , allocationTerm = TermKey $ seasonTerm True Summer + , allocationTerm = TermKey currentTerm , allocationSchool = ifi , allocationLegacyShorthands = [] , allocationDescription = Nothing @@ -1154,7 +1113,7 @@ fillDb = do , allocationRegisterByStaffFrom = Nothing , allocationRegisterByStaffTo = Nothing , allocationRegisterByCourse = Nothing - , allocationOverrideDeregister = Just $ termTime True Summer 1 False Monday toMidnight + , allocationOverrideDeregister = Just $ termTime True Q1 1 False Monday toMidnight , allocationMatchingSeed = aSeedFunc } insert_ $ AllocationCourse funAlloc pmo 100 Nothing Nothing @@ -1173,7 +1132,7 @@ fillDb = do , courseDescription = Nothing , courseLinkExternal = Nothing , courseShorthand = "BS" - , courseTerm = TermKey $ seasonTerm False Winter + , courseTerm = TermKey $ seasonTerm False Q4 , courseSchool = ifi , courseCapacity = Just 50 , courseVisibleFrom = Just now @@ -1203,9 +1162,9 @@ fillDb = do , sheetType = Normal $ PassPoints 12 6 , sheetGrouping = Arbitrary 3 , sheetMarkingText = Nothing - , sheetVisibleFrom = Just $ termTime False Winter (fromInteger shNr) False Monday toMidnight - , sheetActiveFrom = Just $ termTime False Winter (fromInteger $ succ shNr) False Monday toMidnight - , sheetActiveTo = Just $ termTime False Winter (fromInteger $ succ shNr) False Sunday beforeMidnight + , sheetVisibleFrom = Just $ termTime False Q4 (fromInteger shNr) False Monday toMidnight + , sheetActiveFrom = Just $ termTime False Q4 (fromInteger $ succ shNr) False Monday toMidnight + , sheetActiveTo = Just $ termTime False Q4 (fromInteger $ succ shNr) False Sunday beforeMidnight , sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing False , sheetHintFrom = Nothing , sheetSolutionFrom = Nothing @@ -1249,7 +1208,7 @@ fillDb = do , courseDescription = Nothing , courseLinkExternal = Nothing , courseShorthand = CI.mk csh - , courseTerm = TermKey $ seasonTerm False Winter + , courseTerm = TermKey $ seasonTerm False Q4 , courseSchool = ifi , courseCapacity = Just 50 , courseVisibleFrom = Just now @@ -1278,7 +1237,7 @@ fillDb = do bigAlloc <- insert' Allocation { allocationName = "Große Zentralanmeldung" , allocationShorthand = "big" - , allocationTerm = TermKey $ seasonTerm True Summer + , allocationTerm = TermKey $ seasonTerm True Q1 , allocationSchool = ifi , allocationLegacyShorthands = [] , allocationDescription = Nothing @@ -1292,7 +1251,7 @@ fillDb = do , allocationRegisterByStaffFrom = Nothing , allocationRegisterByStaffTo = Nothing , allocationRegisterByCourse = Nothing - , allocationOverrideDeregister = Just $ termTime True Summer 1 False Monday toMidnight + , allocationOverrideDeregister = Just $ termTime True Q1 1 False Monday toMidnight , allocationMatchingSeed = aSeedBig } bigAllocShorthands <- @@ -1311,7 +1270,7 @@ fillDb = do , courseDescription = Nothing , courseLinkExternal = Nothing , courseShorthand = CI.mk csh - , courseTerm = TermKey $ seasonTerm False Winter + , courseTerm = TermKey $ seasonTerm False Q4 , courseSchool = ifi , courseCapacity = Just cap , courseVisibleFrom = Just now diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 94c5a937a..7f4e705ed 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -462,9 +462,9 @@ spec = do it "has compatible encoding/decoding to/from Text" . property $ \term -> termFromText (termToText term) == Right term it "works for some examples" . mapM_ termExample $ - [ (TermIdentifier 2017 Summer, "S17") - , (TermIdentifier 1995 Winter, "W95") - , (TermIdentifier 3068 Winter, "W3068") + [ (TermIdentifier 2017 Q2, "17Q2") + , (TermIdentifier 1995 Q4, "95Q4") + , (TermIdentifier 3068 Q1, "3068Q1") ] it "has compatbile encoding/decoding to/from Rational" . property $ \term -> termFromRational (termToRational term) == term