fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(testdata): terms changes to yearly quarters working now

Browse Source
This commit is contained in:
Steffen Jost 2021-09-23 18:00:13 +02:00
parent aeafe3118b
commit bcbaad0da8
2 changed files with 75 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

185
test/Database/Fill.hs
View File

@ -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

6
test/Model/TypesSpec.hs
View File

@ -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