From f807b42089d4c8f9d26e283fb0a13b4fe3ef553f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 27 Oct 2021 20:03:02 +0200 Subject: [PATCH] chore(dayterms): change termidentifiers to single days complete --- src/Model/Types/DateTime.hs | 10 +- test/Database/Fill.hs | 972 +++++++----------------------------- test/Model/TypesSpec.hs | 11 +- 3 files changed, 184 insertions(+), 809 deletions(-) diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index 4346cd381..ede249af1 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -108,7 +108,7 @@ instance PersistField TermIdentifier where fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x instance PersistFieldSql TermIdentifier where - sqlType _ = SqlNumeric 5 1 + sqlType _ = SqlNumeric 9 5 -- total significant digits; significant digits after decimal point instance ToHttpApiData TermIdentifier where toUrlPiece = termToText @@ -145,10 +145,10 @@ guessDay :: TermIdentifier -> Day guessDay TermIdentifier{..} TermDayLectureStart = getTermDay guessDay TermIdentifier{..} TermDayLectureEnd = addDays 8 getTermDay -- courses last only a week -guessDay tid TermDayStart = fromWeekDate year weekStart 1 -- Monday before lecture time - where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayLectureStart -guessDay tid TermDayEnd = fromWeekDate year weekStart 7 -- Sunday after lecture time - where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayLectureEnd +guessDay tid TermDayStart = fromWeekDate year week 1 -- Monday before lecture time + where ( year, week, _) = toWeekDate $ addDays (-7*4*3) $ guessDay tid TermDayLectureStart +guessDay tid TermDayEnd = fromWeekDate year week 7 -- Sunday after lecture time + where ( year, week, _) = toWeekDate $ addDays (7*3) $ guessDay tid TermDayLectureEnd withinTerm :: Day -> TermIdentifier -> Bool withinTerm d tid = guessDay tid TermDayStart <= d && d <= guessDay tid TermDayEnd diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 6f80532eb..b47723cb4 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -3,17 +3,17 @@ module Database.Fill ) where import "uniworx" Import hiding (Option(..), currentYear) -import Handler.Utils.Form (SheetGrading'(..), SheetGroup'(..)) +-- import Handler.Utils.Form (SheetGrading'(..), SheetGroup'(..)) import qualified Data.ByteString.Lazy as LBS -import qualified Data.Text as Text +-- import qualified Data.Text as Text -- import Data.Text.IO (hPutStrLn) import qualified Data.Set as Set import qualified Data.Map as Map -- import Data.Time.Calendar.OrdinalDate -import Data.Time.Calendar.WeekDate +-- import Data.Time.Calendar.WeekDate import Utils.Holidays import Control.Applicative (ZipList(..)) @@ -21,22 +21,22 @@ import Control.Applicative (ZipList(..)) import Handler.Utils.DateTime import Handler.Utils.AuthorshipStatement (insertAuthorshipStatement) -import Control.Monad.Random.Class (weighted) +-- import Control.Monad.Random.Class (weighted) import System.Random.Shuffle (shuffleM) import qualified Data.CaseInsensitive as CI import qualified Data.Csv as Csv -import Crypto.Random (getRandomBytes) -import Data.List (genericLength) -import qualified Data.List as List (splitAt) - -import qualified Data.Conduit.Combinators as C +-- import Crypto.Random (getRandomBytes) +import Data.List (foldl) +-- import qualified Data.List as List (splitAt) import System.Directory (getModificationTime, doesDirectoryExist) import System.FilePath.Glob (glob) +{- Needed for File Tests only +import qualified Data.Conduit.Combinators as C import Paths_uniworx (getDataFileName) testdataFile :: MonadIO m => FilePath -> m FilePath @@ -48,6 +48,8 @@ insertFile residual fileTitle = do let fileContent = Just $ C.sourceFile filepath fileModified <- liftIO getCurrentTime sinkFile' File{..} residual >>= insert +-} + fillDb :: DB () fillDb = do @@ -56,23 +58,21 @@ fillDb = do let insert' :: (PersistRecordBackend r (YesodPersistBackend UniWorX), AtLeastOneUniqueKey r) => r -> YesodDB UniWorX (Key r) insert' = fmap (either entityKey id) . insertBy - + addBDays = addBusinessDays Fraport -- holiday area to use currentTerm = TermIdentifier $ utctDay now - (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm + -- (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm nextTerm n = TermIdentifier $ addBDays n $ getTermDay currentTerm - termTime :: Integer -- ^ Term Offset to current Term (i.e. Days) - -> Integer -- ^ Days Offset from Start/End of Term - -> Bool -- ^ Relative to end of Term? - -> Maybe WeekDay -- ^ Move to weekday - -> (Day -> UTCTime) -- ^ Add time to day + termTime :: TermIdentifier -- ^ Term + -> TermDay -- ^ Relative to which day? + -> Integer -- ^ Business Days Offset from Start/End of Term + -> Maybe WeekDay -- ^ Move to weekday + -> (Day -> UTCTime) -- ^ Add time to day -> UTCTime - termTime next doff fromEnd mbWeekDay = ($ utctDay) - where - gTid = nextTerm next - gDay | fromEnd = addBDays (negate doff) $ guessDay gTid TermDayLectureEnd - | otherwise = addBDays doff $ guessDay gTid TermDayLectureStart + termTime gTid gTD gOff mbWeekDay = ($ utctDay) + where + gDay = addBDays gOff $ guessDay gTid gTD utctDay = maybe gDay (`firstDayOfWeekOnAfter` gDay) mbWeekDay gkleen <- insert User @@ -345,17 +345,27 @@ fillDb = do matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int) manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel - terms <- forM [-7..31*6] $ \nr -> do - let tid = nextTerm nr tid - term = Term { termName = termToText' tid - , termStart = guessDay tid TermDayStart - , termEnd = guessDay tid TermDayEnd - , termHolidays = bankHolidaysArea Fraport + let tmin = -8 + tmax = 29*6 + trange = [tmin..tmax] + dmin = guessDay (nextTerm tmin) TermDayStart + dmax = guessDay (nextTerm tmax) TermDayEnd + hdys = foldl (<>) mempty $ [bankHolidaysAreaSet Fraport y | y <- [getYear dmin..getYear dmax]] + terms <- forM trange $ \nr -> do + let tid = nextTerm nr + tk = TermKey tid + tStart = guessDay tid TermDayStart + tEnd = guessDay tid TermDayEnd + term = Term { termName = tid + , termStart = tStart + , termEnd = tEnd + , termHolidays = toList $ Set.filter (\d -> tStart <= d && d <= tEnd) hdys , termLectureStart = guessDay tid TermDayLectureStart , termLectureEnd = guessDay tid TermDayLectureEnd } - void $ repsert (TermKey tid) term - insert $ TermActive (TermKey tid) (toMidnight $ addDays (-60) $ termStart term) (Just . beforeMidnight $ addDays 60 $ termEnd term) Nothing + repsert tk term + insert_ $ TermActive tk (toMidnight $ addDays (-60) $ termStart term) (Just . beforeMidnight $ addDays 60 $ termEnd term) Nothing + return tk ifiAuthorshipStatement <- insertAuthorshipStatement I18n { i18nFallback = htmlToStoredMarkup @@ -575,574 +585,138 @@ fillDb = do -- Fahrschule F - fdf <- insert' Course - { courseName = "F - Vorfeldführerschein" - , courseDescription = Just $ htmlToStoredMarkup [shamlet| -

- Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes. -

-

Benötigte Unterlagen -
    -
  • Sehtest - (Bitte vorab hochladen!) -
  • Regulärer Führerschein - |] - , courseLinkExternal = Nothing - , courseShorthand = "F" - , courseTerm = TermKey currentTerm - , courseSchool = avn - , courseCapacity = Nothing - , courseVisibleFrom = Just now - , courseVisibleTo = Nothing - , courseRegisterFrom = Just $ termTime True (season currentTerm) (-2) False Monday toMidnight - , courseRegisterTo = Just $ termTime True (season currentTerm) 0 True Saturday beforeMidnight - , courseDeregisterUntil = Nothing - , courseRegisterSecret = Nothing - , courseMaterialFree = True - , courseApplicationsRequired = False - , courseApplicationsInstructions = Nothing - , courseApplicationsText = False - , courseApplicationsFiles = NoUpload - , courseApplicationsRatingsVisible = False - , courseDeregisterNoShow = True - } - insert_ $ CourseEdit jost now fdf - void $ insert Sheet - { sheetCourse = fdf - , sheetName = "Sehtest" - , sheetDescription = Just $ htmlToStoredMarkup [shamlet|Bitte einen Scan ihres Sehtest hochladen!|] - , sheetType = NotGraded - , sheetGrouping = Arbitrary 3 - , sheetMarkingText = Nothing - , sheetVisibleFrom = Just $ termTime True (season currentTerm) (-2) False Monday toMidnight - , sheetActiveFrom = Just $ termTime True (season currentTerm) (-2) False Monday toMidnight - , sheetActiveTo = Just $ termTime True (season currentTerm) 0 True Saturday beforeMidnight - , sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing False - , sheetHintFrom = Nothing - , sheetSolutionFrom = Nothing - , sheetAutoDistribute = False - , sheetAnonymousCorrection = True - , sheetRequireExamRegistration = Nothing - , sheetAllowNonPersonalisedSubmission = True - , sheetAuthorshipStatementMode = SheetAuthorshipStatementModeExam - , sheetAuthorshipStatementExam = Nothing - , sheetAuthorshipStatement = Nothing - } - forM_ [(Monday)..Thursday] $ \td -> do - forM_ [(1::Int)..(4*4)] $ \tw -> do - let firstTT = termTime True (season currentTerm) (toRational $ tw - 1) False td toMorning - secondTT = termTime True (season currentTerm) (toRational $ tw - 1) False (succ td) toMorning - regFrom = termTime True (season currentTerm) (toRational $ tw - 8) False td toMorning - regTo = termTime True (season currentTerm) (toRational $ tw - 2) False td toMorning - tut1 <- insert Tutorial - { tutorialName = CI.mk $ Text.pack $ "KW" ++ show (snd3 $ toWeekDate $ utctDay firstTT) ++ take 3 (show td) - , tutorialCourse = fdf - , tutorialType = "Schulung" - , tutorialCapacity = Just 16 - , tutorialRoom = Just $ case tw `mod` 4 of - 1 -> "A380" - 2 -> "B747" - 3 -> "MD11" - _ -> "B777" - , tutorialRoomHidden = False - , tutorialTime = Occurrences - { occurrencesScheduled = Set.empty - , occurrencesExceptions = Set.fromList - [ ExceptOccur - { exceptDay = utctDay firstTT - , exceptStart = TimeOfDay 8 30 0 - , exceptEnd = TimeOfDay 16 0 0 - } - , ExceptOccur - { exceptDay = utctDay secondTT - , exceptStart = TimeOfDay 9 0 0 - , exceptEnd = TimeOfDay 16 0 0 - } - ] + forM_ terms $ \tk -> do + let tid = unTermKey tk + jtt = (((Just .) .) .) . termTime tid + weekDay = dayOfWeek $ getTermDay tid + firstDay = utctDay $ termTime tid TermDayLectureStart 0 Nothing toMidnight + secondDay = utctDay $ termTime tid TermDayLectureStart 1 Nothing toMidnight + -- thirdDay = utctDay $ termTime tid TermDayLectureStart 2 Nothing toMidnight + capacity = Just 8 + mkName = CI.mk . (<> termToText' tid) . (<> "_") + if weekDay `elem` [Friday, Saturday, Sunday] + then return () + else do + c <- insert' Course + { courseName = mkName "Vorfeldführerschein" + , courseDescription = Just $ htmlToStoredMarkup [shamlet| +

    + Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes. +

    +

    Benötigte Unterlagen +
      +
    • Sehtest, + bitte vorab hochladen! +
    • Regulärer Führerschein, + Bitte mitbringen. + |] + , courseLinkExternal = Nothing + , courseShorthand = "F" + , courseTerm = tk + , courseSchool = avn + , courseCapacity = capacity + , courseVisibleFrom = jtt TermDayStart 0 Nothing toMidnight + , courseVisibleTo = jtt TermDayEnd 0 Nothing beforeMidnight + , courseRegisterFrom = jtt TermDayStart 0 Nothing toMidnight + , courseRegisterTo = jtt TermDayLectureStart (-1) Nothing toMidnight + , courseDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight + , courseRegisterSecret = Nothing + , courseMaterialFree = True + , courseApplicationsRequired = False + , courseApplicationsInstructions = Nothing + , courseApplicationsText = False + , courseApplicationsFiles = NoUpload + , courseApplicationsRatingsVisible = False + , courseDeregisterNoShow = True } - , tutorialRegGroup = Just "schulung" - , tutorialRegisterFrom = Just regFrom - , tutorialRegisterTo = Just regTo - , tutorialDeregisterUntil = Nothing - , tutorialLastChanged = now - , tutorialTutorControlled = True - } - void . insert $ Tutor tut1 jost - void . insert' $ Exam - { examCourse = fdf - , examName = "Theorie" - , examGradingRule = Nothing - , examBonusRule = Nothing - , examOccurrenceRule = ExamRoomManual - , examExamOccurrenceMapping = Nothing - , examVisibleFrom = Just regFrom - , examRegisterFrom = Just firstTT - , examRegisterTo = Just $ toMidday $ utctDay secondTT - , examDeregisterUntil = Nothing - , examPublishOccurrenceAssignments = Nothing - , examStart = Just $ toTimeOfDay 15 30 0 $ utctDay secondTT - , examEnd = Just $ toTimeOfDay 16 30 0 $ utctDay secondTT - , examFinished = Nothing - , examPartsFrom = Nothing - , examClosed = Nothing - , examPublicStatistics = True - , examGradingMode = ExamGradingPass - , examDescription = Just $ htmlToStoredMarkup [shamlet|Theoretische Prüfung mit Fragebogen|] - , examExamMode = ExamMode - { examAids = Just $ ExamAidsPreset ExamClosedBook - , examOnline = Just $ ExamOnlinePreset ExamOffline - , examSynchronicity = Just $ ExamSynchronicityPreset ExamSynchronous - , examRequiredEquipment = Just $ ExamRequiredEquipmentPreset ExamRequiredEquipmentNone - } - , examStaff = Just "Jost" - , examAuthorshipStatement = Nothing - } - - -- FFP - let nbrs :: [Int] - nbrs = [1,2,3,27,7,1] - ffp <- insert' Course - { courseName = "Fortgeschrittene Funktionale Programmierung" - , courseDescription = Just $ htmlToStoredMarkup [shamlet| -

      It is fun! -

      Come to where the functional is! -

      -

      Functional programming can be done in Haskell! -

      This is not a joke, this is serious! -

      -

      Consider some numbers -
        - $forall n <- nbrs -
      • Number #{n} - |] - , courseLinkExternal = Nothing - , courseShorthand = "FFP" - , courseTerm = TermKey $ seasonTerm True Q1 - , courseSchool = ifi - , courseCapacity = Just 20 - , courseVisibleFrom = Just now - , courseVisibleTo = Nothing - , courseRegisterFrom = Just $ termTime True Q1 (-2) False Monday toMidnight - , courseRegisterTo = Just $ termTime True Q1 0 True Sunday beforeMidnight - , courseDeregisterUntil = Nothing - , courseRegisterSecret = Nothing - , courseMaterialFree = True - , courseApplicationsRequired = False - , courseApplicationsInstructions = Nothing - , courseApplicationsText = False - , courseApplicationsFiles = NoUpload - , courseApplicationsRatingsVisible = False - , courseDeregisterNoShow = True - } - insert_ $ CourseEdit jost now ffp - void . insert $ DegreeCourse ffp sdBsc sdInf - void . insert $ DegreeCourse ffp sdMst sdInf - -- void . insert $ Lecturer jost ffp CourseLecturer - void . insert $ Lecturer gkleen ffp CourseAssistant - adhoc <- insert Sheet - { sheetCourse = ffp - , sheetName = "Adhoc-Gruppen" - , sheetDescription = Nothing - , sheetType = NotGraded - , sheetGrouping = Arbitrary 3 - , sheetMarkingText = Nothing - , 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 - , sheetAutoDistribute = False - , sheetAnonymousCorrection = True - , sheetRequireExamRegistration = Nothing - , sheetAllowNonPersonalisedSubmission = True - , sheetAuthorshipStatementMode = SheetAuthorshipStatementModeExam - , sheetAuthorshipStatementExam = Nothing - , sheetAuthorshipStatement = Nothing - } - insert_ $ SheetEdit gkleen now adhoc - feste <- insert Sheet - { sheetCourse = ffp - , sheetName = "Feste Gruppen" - , sheetDescription = Nothing - , sheetType = NotGraded - , sheetGrouping = RegisteredGroups - , sheetMarkingText = Nothing - , 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 - , sheetAutoDistribute = False - , sheetAnonymousCorrection = True - , sheetRequireExamRegistration = Nothing - , sheetAllowNonPersonalisedSubmission = True - , sheetAuthorshipStatementMode = SheetAuthorshipStatementModeExam - , sheetAuthorshipStatementExam = Nothing - , sheetAuthorshipStatement = Nothing - } - insert_ $ SheetEdit gkleen now feste - keine <- insert Sheet - { sheetCourse = ffp - , sheetName = "Keine Gruppen" - , sheetDescription = Nothing - , sheetType = NotGraded - , sheetGrouping = NoGroups - , sheetMarkingText = Nothing - , 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 - , sheetAutoDistribute = False - , sheetAnonymousCorrection = True - , sheetRequireExamRegistration = Nothing - , sheetAllowNonPersonalisedSubmission = True - , sheetAuthorshipStatementMode = SheetAuthorshipStatementModeExam - , sheetAuthorshipStatementExam = Nothing - , sheetAuthorshipStatement = Nothing - } - insert_ $ SheetEdit gkleen now keine - void . insertMany $ map (\u -> CourseParticipant ffp u now Nothing CourseParticipantActive) - [ fhamann - , maxMuster - , tinaTester - ] - - examFFP <- insert' $ Exam - { examCourse = ffp - , examName = "Klausur" - , examGradingRule = Nothing - , examBonusRule = Nothing - , examOccurrenceRule = ExamRoomManual - , examExamOccurrenceMapping = Nothing - , 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 - , examDescription = Nothing - , examExamMode = ExamMode - { examAids = Just $ ExamAidsPreset ExamClosedBook - , examOnline = Just $ ExamOnlinePreset ExamOffline - , examSynchronicity = Just $ ExamSynchronicityPreset ExamSynchronous - , examRequiredEquipment = Just $ ExamRequiredEquipmentPreset ExamRequiredEquipmentNone - } - , examStaff = Just "Hofmann" - , examAuthorshipStatement = Nothing - } - _ <- insert' Material - { materialCourse = ffp - , materialName = "Material 1" - , materialType = Just "Typ 1" - , materialDescription = Just $ htmlToStoredMarkup [shamlet|Folien für die Zentralübung|] - , materialVisibleFrom = Just now - , materialLastEdit = now - } - - _ <- insert' Material - { materialCourse = ffp - , materialName = "Material 2" - , materialType = Just "Typ 2" - , materialDescription = Just $ htmlToStoredMarkup [shamlet|Videos für die Vorlesung|] - , materialVisibleFrom = Just now - , materialLastEdit = now - } - - void . insertMany $ map (\u -> ExamRegistration examFFP u Nothing now) - [ fhamann - , maxMuster - , tinaTester - ] - - -- EIP - eip <- insert' Course - { courseName = "Einführung in die Programmierung" - , courseDescription = Nothing - , courseLinkExternal = Nothing - , courseShorthand = "EIP" - , courseTerm = TermKey $ seasonTerm False Q4 - , courseSchool = ifi - , courseCapacity = Just 20 - , courseVisibleFrom = Just now - , courseVisibleTo = Nothing - , courseRegisterFrom = Just $ termTime False Q4 (-4) False Monday toMidnight - , courseRegisterTo = Nothing - , courseDeregisterUntil = Nothing - , courseRegisterSecret = Nothing - , courseMaterialFree = True - , courseApplicationsRequired = False - , courseApplicationsInstructions = Nothing - , courseApplicationsText = False - , courseApplicationsFiles = NoUpload - , courseApplicationsRatingsVisible = False - , courseDeregisterNoShow = False - } - insert_ $ CourseEdit fhamann now eip - void . insert' $ DegreeCourse eip sdBsc sdInf - void . insert' $ Lecturer fhamann eip CourseLecturer - -- interaction design - ixd <- insert' Course - { courseName = "Interaction Design (User Experience Design I & II)" - , courseDescription = Nothing - , courseLinkExternal = Nothing - , courseShorthand = "IXD" - , courseTerm = TermKey $ seasonTerm True Q1 - , courseSchool = ifi - , courseCapacity = Just 20 - , courseVisibleFrom = Just now - , courseVisibleTo = Nothing - , courseRegisterFrom = Just $ termTime True Q1 0 False Monday toMidnight - , courseRegisterTo = Just $ termTime True Q1 (-2) True Sunday beforeMidnight - , courseDeregisterUntil = Nothing - , courseRegisterSecret = Nothing - , courseMaterialFree = True - , courseApplicationsRequired = False - , courseApplicationsInstructions = Nothing - , courseApplicationsText = False - , courseApplicationsFiles = NoUpload - , courseApplicationsRatingsVisible = False - , courseDeregisterNoShow = False - } - insert_ $ CourseEdit fhamann now ixd - void . insert' $ DegreeCourse ixd sdBsc sdInf - void . insert' $ Lecturer fhamann ixd CourseAssistant - -- concept development - ux3 <- insert' Course - { courseName = "Concept Development (User Experience Design III)" - , courseDescription = Nothing - , courseLinkExternal = Nothing - , courseShorthand = "UX3" - , courseTerm = TermKey $ seasonTerm True Q4 - , courseSchool = ifi - , courseCapacity = Just 30 - , courseVisibleFrom = Just now - , courseVisibleTo = Nothing - , courseRegisterFrom = Nothing - , courseRegisterTo = Nothing - , courseDeregisterUntil = Nothing - , courseRegisterSecret = Nothing - , courseMaterialFree = True - , courseApplicationsRequired = False - , courseApplicationsInstructions = Nothing - , courseApplicationsText = False - , courseApplicationsFiles = NoUpload - , courseApplicationsRatingsVisible = False - , courseDeregisterNoShow = False - } - insert_ $ CourseEdit fhamann now ux3 - void . insert' $ DegreeCourse ux3 sdBsc sdInf - void . insert' $ Lecturer fhamann ux3 CourseAssistant - -- promo - pmo <- insert' Course - { courseName = "Programmierung und Modellierung" - , courseDescription = Nothing - , courseLinkExternal = Nothing - , courseShorthand = "ProMo" - , courseTerm = TermKey $ seasonTerm True Q1 - , courseSchool = ifi - , courseCapacity = Just 50 - , courseVisibleFrom = Just now - , courseVisibleTo = Nothing - , courseRegisterFrom = Just $ termTime True Q1 (-2) False Monday toMidnight - , courseRegisterTo = Nothing - , courseDeregisterUntil = Nothing - , courseRegisterSecret = Nothing - , courseMaterialFree = True - , courseApplicationsRequired = False - , courseApplicationsInstructions = Nothing - , courseApplicationsText = False - , courseApplicationsFiles = NoUpload - , courseApplicationsRatingsVisible = False - , courseDeregisterNoShow = False - } - insert_ $ CourseEdit jost now pmo - void . insert $ DegreeCourse pmo sdBsc sdInf - void . insert $ Lecturer jost pmo CourseAssistant - void . insertMany $ map (\u -> CourseParticipant pmo u now Nothing CourseParticipantActive) - [ fhamann - , maxMuster - , tinaTester - ] - - let shTypes = NotGraded : [ shType g | g <- shGradings, shType <- [ Normal, Bonus, Informational ] ] - where shGradings = [ Points 6, PassPoints 3 6, PassBinary, PassAlways ] - shGroupings = [ Arbitrary 3, RegisteredGroups, NoGroups ] - shSubModes = do - corrector <- universeF - [ SubmissionMode corrector Nothing - , SubmissionMode corrector $ Just NoUpload - , SubmissionMode corrector $ Just UploadSpecific - { uploadSpecificFiles = impureNonNull $ Set.fromList - [ UploadSpecificFile "Aufgabe 1" "exercise_2.1.hs" False False Nothing - , UploadSpecificFile "Aufgabe 2" "exercise_2.2.hs" False False Nothing - , UploadSpecificFile "Erklärung der Eigenständigkeit" "erklärung.txt" True True (Just 42) - ] + insert_ $ CourseEdit jost now c + insert_ Sheet + { sheetCourse = c + , sheetName = mkName "Sehtest" + , sheetDescription = Just $ htmlToStoredMarkup [shamlet|Bitte einen Scan ihres Sehtest hochladen!|] + , sheetType = NotGraded + , sheetGrouping = Arbitrary 3 + , sheetMarkingText = Nothing + , sheetVisibleFrom = jtt TermDayStart 0 Nothing toMidnight + , sheetActiveFrom = jtt TermDayStart 0 Nothing toMidnight + , sheetActiveTo = jtt TermDayLectureStart 0 Nothing toMorning + , sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing False + , sheetHintFrom = Nothing + , sheetSolutionFrom = Nothing + , sheetAutoDistribute = False + , sheetAnonymousCorrection = True + , sheetRequireExamRegistration = Nothing + , sheetAllowNonPersonalisedSubmission = True + , sheetAuthorshipStatementMode = SheetAuthorshipStatementModeExam + , sheetAuthorshipStatementExam = Nothing + , sheetAuthorshipStatement = Nothing + } + -- TODO: Maybe split into to Tutorials with + -- occurrencesSchedule = Set.fromList [ ScheduleWeekly { scheduleDayOfWeek = weekDay, scheduleStart = TimeOfDay 8 30 0, scheduleEnd = TimeOfDay 16 0 0} ] + tut1 <- insert Tutorial + { tutorialName = mkName "Theorieschulung" + , tutorialCourse = c + , tutorialType = "Schulung" + , tutorialCapacity = capacity + , tutorialRoom = Just $ case weekDay of + Monday -> "A380" + Tuesday -> "B747" + Wednesday -> "MD11" + Thursday -> "A380" + _ -> "B777" + , tutorialRoomHidden = False + , tutorialTime = Occurrences + { occurrencesScheduled = Set.empty + , occurrencesExceptions = Set.fromList + [ ExceptOccur + { exceptDay = firstDay + , exceptStart = TimeOfDay 8 30 0 + , exceptEnd = TimeOfDay 16 0 0 + } + , ExceptOccur + { exceptDay = secondDay + , exceptStart = TimeOfDay 9 0 0 + , exceptEnd = TimeOfDay 16 0 0 + } + ] } - ] ++ [ SubmissionMode corrector $ Just UploadAny{..} - | uploadUnpackZips <- universeF - , uploadExtensionRestriction <- [ Nothing, Just . impureNonNull $ Set.fromList ["pdf", "txt", "jpeg", "hs"] ] - , let uploadEmptyOk = False - ] - - sheetCombinations = (,,) <$> shTypes <*> shGroupings <*> shSubModes - - forM_ (zip [0..] sheetCombinations) $ \(shNr, (sheetType, sheetGrouping, sheetSubmissionMode)) -> do - MsgRenderer mr <- getMsgRenderer - - let sheetSubmissionModeDescr - | Just userMode <- sheetSubmissionMode ^? _submissionModeUser . _Just - = let - extra = catMaybes - [ guardOn (fromMaybe False $ userMode ^? _uploadUnpackZips) $ mr MsgAutoUnzip - , guardOn (maybe False (is _Just) $ userMode ^? _uploadExtensionRestriction) $ mr MsgUploadModeExtensionRestriction - ] - in mr (classifySubmissionMode sheetSubmissionMode) <> " (" <> Text.intercalate ", " (mr (classifyUploadMode userMode) : extra) <> ")" - | Just userMode <- sheetSubmissionMode ^? _submissionModeUser . _Just - = mr (classifySubmissionMode sheetSubmissionMode) <> " (" <> mr (classifyUploadMode userMode) <> ")" - | otherwise - = mr (classifySubmissionMode sheetSubmissionMode) - sheetGroupingDescr = case sheetGrouping of - Arbitrary{} -> mr Arbitrary' - RegisteredGroups -> mr RegisteredGroups' - NoGroups -> mr NoGroups' - sheetTypeDescr - | Just g <- sheetType ^? _grading - = let sheetGrading' = case g of - Points{} -> Points' - PassPoints{} -> PassPoints' - PassBinary{} -> PassBinary' - PassAlways{} -> PassAlways' - in mr sheetType' <> " (" <> mr sheetGrading' <> ")" - | otherwise - = mr sheetType' - where - sheetType' = classifySheetType sheetType - - prog = 14 * (shNr % genericLength sheetCombinations) - - -- liftIO . hPutStrLn stderr $ Text.intercalate ", " [sheetTypeDescr, sheetGroupingDescr, sheetSubmissionModeDescr] - -- liftIO . hPutStrLn stderr $ tshow (sheetType, sheetGrouping, sheetSubmissionMode) - - shId <- insert Sheet - { sheetCourse = pmo - , sheetName = CI.mk $ tshow shNr <> ": " <> Text.intercalate ", " [sheetTypeDescr, sheetGroupingDescr, sheetSubmissionModeDescr] - , sheetDescription = Nothing - , sheetType, sheetGrouping, sheetSubmissionMode - , sheetMarkingText = Nothing - , 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 - , sheetAllowNonPersonalisedSubmission = True - , sheetAuthorshipStatementMode = SheetAuthorshipStatementModeExam - , sheetAuthorshipStatementExam = Nothing - , sheetAuthorshipStatement = Nothing - } - void . insert $ SheetEdit jost now shId - when (submissionModeCorrector sheetSubmissionMode) $ - forM_ [fhamann, maxMuster, tinaTester] $ \uid -> do - p <- liftIO getRandom - void . insert $ SheetPseudonym shId p uid - void . insert $ SheetCorrector jost shId (Load (Just True) 0 1) CorrectorNormal - void . insert $ SheetCorrector gkleen shId (Load (Just True) 1 1) CorrectorNormal - void . insert $ SheetCorrector svaupel shId (Load (Just True) 1 1) CorrectorNormal - void $ insertFile (SheetFileResidual shId SheetHint) "H10-2.hs" - void $ insertFile (SheetFileResidual shId SheetSolution) "H10-3.hs" - void $ insertFile (SheetFileResidual shId SheetExercise) "ProMo_Uebung10.pdf" - - forM_ [fhamann, maxMuster, tinaTester] $ \uid -> do - subId <- insert $ Submission - { submissionSheet = shId - , submissionRatingPoints = Nothing - , submissionRatingComment = Nothing - , submissionRatingBy = Nothing - , submissionRatingAssigned = Nothing - , submissionRatingTime = Nothing + , tutorialRegGroup = Just "schulung" + , tutorialRegisterFrom = jtt TermDayStart 0 Nothing toMidnight + , tutorialRegisterTo = jtt TermDayLectureStart (-1) Nothing toMidnight + , tutorialDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight + , tutorialLastChanged = now + , tutorialTutorControlled = True } - void . insert $ SubmissionEdit (Just uid) now subId - void . insert $ SubmissionUser uid subId - void $ insertFile (SubmissionFileResidual subId False False) "AbgabeH10-1.hs" - tut1 <- insert Tutorial - { tutorialName = "Di08" - , tutorialCourse = pmo - , tutorialType = "Tutorium" - , tutorialCapacity = Just 30 - , tutorialRoom = Just "Hilbert-Raum" - , tutorialRoomHidden = True - , tutorialTime = Occurrences - { occurrencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 08 15 00) (TimeOfDay 10 00 00) - , occurrencesExceptions = Set.empty - } - , tutorialRegGroup = Just "tutorium" - , tutorialRegisterFrom = Just $ termTime True Q1 0 False Monday toMidnight - , tutorialRegisterTo = Nothing - , tutorialDeregisterUntil = Nothing - , tutorialLastChanged = now - , tutorialTutorControlled = True - } - void . insert $ Tutor tut1 gkleen - void . insert $ TutorialParticipant tut1 fhamann - tut2 <- insert Tutorial - { tutorialName = "Di10" - , tutorialCourse = pmo - , tutorialType = "Tutorium" - , tutorialCapacity = Just 30 - , tutorialRoom = Just "Hilbert-Raum" - , tutorialRoomHidden = True - , tutorialTime = Occurrences - { occurrencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 10 15 00) (TimeOfDay 12 00 00) - , occurrencesExceptions = Set.empty - } - , tutorialRegGroup = Just "tutorium" - , tutorialRegisterFrom = Just $ termTime True Q1 0 False Monday toMidnight - , tutorialRegisterTo = Nothing - , tutorialDeregisterUntil = Nothing - , tutorialLastChanged = now - , tutorialTutorControlled = False - } - void . insert $ Tutor tut2 gkleen - -- datenbanksysteme - dbs <- insert' Course - { courseName = "Datenbanksysteme" - , courseDescription = Just "Datenbanken banken Daten damit die Daten nicht wanken. Die Datenschützer danken!" - , courseLinkExternal = Nothing - , courseShorthand = "DBS" - , courseTerm = TermKey $ seasonTerm False Q4 - , courseSchool = ifi - , courseCapacity = Just 50 - , courseVisibleFrom = Just now - , courseVisibleTo = Nothing - , courseRegisterFrom = Nothing - , courseRegisterTo = Nothing - , courseDeregisterUntil = Nothing - , courseRegisterSecret = Just "dbs" - , courseMaterialFree = False - , courseApplicationsRequired = False - , courseApplicationsInstructions = Nothing - , courseApplicationsText = False - , courseApplicationsFiles = NoUpload - , courseApplicationsRatingsVisible = False - , courseDeregisterNoShow = False - } - insert_ $ CourseEdit gkleen now dbs - void . insert' $ DegreeCourse dbs sdBsc sdInf - void . insert' $ DegreeCourse dbs sdBsc sdMath - void . insert' $ Lecturer gkleen dbs CourseLecturer - void . insert' $ Lecturer jost dbs CourseAssistant + insert_ $ Tutor tut1 jost + void . insert' $ Exam + { examCourse = c + , examName = mkName "Theorieprüfung" + , examGradingRule = Nothing + , examBonusRule = Nothing + , examOccurrenceRule = ExamRoomManual + , examExamOccurrenceMapping = Nothing + , examVisibleFrom = jtt TermDayStart 0 Nothing toMidnight + , examRegisterFrom = jtt TermDayStart 0 Nothing toMidnight + , examRegisterTo = jtt TermDayLectureStart (-1) Nothing toMidnight + , examDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight + , examPublishOccurrenceAssignments = Nothing + , examStart = Just $ toTimeOfDay 16 0 0 secondDay + , examEnd = Just $ toTimeOfDay 16 30 0 secondDay + , examFinished = Nothing + , examPartsFrom = Nothing + , examClosed = Nothing + , examPublicStatistics = True + , examGradingMode = ExamGradingPass + , examDescription = Just $ htmlToStoredMarkup [shamlet|Theoretische Prüfung mit Fragebogen|] + , examExamMode = ExamMode + { examAids = Just $ ExamAidsPreset ExamClosedBook + , examOnline = Just $ ExamOnlinePreset ExamOffline + , examSynchronicity = Just $ ExamSynchronicityPreset ExamSynchronous + , examRequiredEquipment = Just $ ExamRequiredEquipmentPreset ExamRequiredEquipmentNone + } + , examStaff = Just "Jost" + , examAuthorshipStatement = Nothing + } testMsg <- insert SystemMessage { systemMessageNewsOnly = False @@ -1216,7 +790,7 @@ fillDb = do , systemMessageLastUnhide = now } - + {- aSeedFunc <- liftIO $ getRandomBytes 40 funAlloc <- insert' Allocation { allocationName = "Funktionale Zentralanmeldung" @@ -1235,220 +809,18 @@ fillDb = do , allocationRegisterByStaffFrom = Nothing , allocationRegisterByStaffTo = Nothing , allocationRegisterByCourse = Nothing - , allocationOverrideDeregister = Just $ termTime True Q1 1 False Monday toMidnight + , allocationOverrideDeregister = Nothing , allocationMatchingSeed = aSeedFunc } insert_ $ AllocationCourse funAlloc pmo 100 Nothing Nothing insert_ $ AllocationCourse funAlloc ffp 2 (Just $ 2300 `addUTCTime` now) Nothing - + void . insertMany $ map (\(u, pState) -> CourseParticipant ffp u now (Just funAlloc) pState) [ (svaupel, CourseParticipantInactive False) , (jost, CourseParticipantActive) ] - -- void $ insertFile "H10-2.hs" -- unreferenced - - -- -- betriebssysteme - bs <- insert' Course - { courseName = "Betriebssystem" - , courseDescription = Nothing - , courseLinkExternal = Nothing - , courseShorthand = "BS" - , courseTerm = TermKey $ seasonTerm False Q4 - , courseSchool = ifi - , courseCapacity = Just 50 - , courseVisibleFrom = Just now - , courseVisibleTo = Nothing - , courseRegisterFrom = Nothing - , courseRegisterTo = Nothing - , courseDeregisterUntil = Nothing - , courseRegisterSecret = Nothing - , courseMaterialFree = False - , courseApplicationsRequired = False - , courseApplicationsInstructions = Nothing - , courseApplicationsText = False - , courseApplicationsFiles = NoUpload - , courseApplicationsRatingsVisible = False - , courseDeregisterNoShow = False - } - insert_ $ CourseEdit gkleen now bs - void . insert' $ Lecturer gkleen bs CourseLecturer - void . insertMany $ do - uid <- take 1024 manyUsers - return $ CourseParticipant bs uid now Nothing CourseParticipantActive - forM_ [1..14] $ \shNr -> do - shId <- insert Sheet - { sheetCourse = bs - , sheetName = CI.mk [st|Blatt #{tshow shNr}|] - , sheetDescription = Nothing - , sheetType = Normal $ PassPoints 12 6 - , sheetGrouping = Arbitrary 3 - , sheetMarkingText = Nothing - , 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 - , sheetAutoDistribute = False - , sheetAnonymousCorrection = True - , sheetRequireExamRegistration = Nothing - , sheetAllowNonPersonalisedSubmission = True - , sheetAuthorshipStatementMode = SheetAuthorshipStatementModeExam - , sheetAuthorshipStatementExam = Nothing - , sheetAuthorshipStatement = Nothing - } - manyUsers' <- shuffleM $ take 1024 manyUsers - groupSizes <- getRandomRs (1, 3) - let groups = go groupSizes manyUsers' - where go [] _ = [] - go (s:ss) us - | (grp, rest) <- splitAt s us - , length grp == s - = grp : go ss rest - | otherwise - = pure us - forM_ groups $ \grpUsers-> case grpUsers of - pUid : _ -> do - sub <- insert Submission - { submissionSheet = shId - , submissionRatingPoints = Nothing - , submissionRatingComment = Nothing - , submissionRatingBy = Nothing - , submissionRatingAssigned = Nothing - , submissionRatingTime = Nothing - } - forM_ grpUsers $ void . insert . flip SubmissionUser sub - void . insert $ SubmissionEdit (Just pUid) now sub - _other -> return () - - forM_ ([1..100] :: [Int]) $ \n -> do - csh <- pack . take 3 <$> getRandomRs ('A', 'Z') - - cid <- insert' Course - { courseName = CI.mk [st|Test Kurs #{n} (#{csh})|] - , courseDescription = Nothing - , courseLinkExternal = Nothing - , courseShorthand = CI.mk csh - , courseTerm = TermKey $ seasonTerm False Q4 - , courseSchool = ifi - , courseCapacity = Just 50 - , courseVisibleFrom = Just now - , courseVisibleTo = Nothing - , courseRegisterFrom = Nothing - , courseRegisterTo = Nothing - , courseDeregisterUntil = Nothing - , courseRegisterSecret = Nothing - , courseMaterialFree = True - , courseApplicationsRequired = False - , courseApplicationsInstructions = Nothing - , courseApplicationsText = False - , courseApplicationsFiles = NoUpload - , courseApplicationsRatingsVisible = False - , courseDeregisterNoShow = False - } - insert_ $ CourseEdit gkleen now cid - -- void . insert' $ Lecturer gkleen cid CourseLecturer - - participants <- getRandomR (0, 50) - manyUsers' <- shuffleM $ take 1024 manyUsers - forM_ (take participants manyUsers') $ \uid -> - void . insertUnique $ CourseParticipant cid uid now Nothing CourseParticipantActive - - aSeedBig <- liftIO $ getRandomBytes 40 - bigAlloc <- insert' Allocation - { allocationName = "Große Zentralanmeldung" - , allocationShorthand = "big" - , allocationTerm = TermKey $ seasonTerm True Q1 - , allocationSchool = ifi - , allocationLegacyShorthands = [] - , allocationDescription = Nothing - , allocationStaffDescription = Nothing - , allocationStaffRegisterFrom = Just now - , allocationStaffRegisterTo = Just $ 300 `addUTCTime` now - , allocationStaffAllocationFrom = Just $ 300 `addUTCTime` now - , allocationStaffAllocationTo = Just $ 900 `addUTCTime` now - , allocationRegisterFrom = Just $ 300 `addUTCTime` now - , allocationRegisterTo = Just $ 600 `addUTCTime` now - , allocationRegisterByStaffFrom = Nothing - , allocationRegisterByStaffTo = Nothing - , allocationRegisterByCourse = Nothing - , allocationOverrideDeregister = Just $ termTime True Q1 1 False Monday toMidnight - , allocationMatchingSeed = aSeedBig - } - bigAllocShorthands <- - let go xs = let (csh, xs') = List.splitAt 3 xs - in pack csh : go xs' - in take 40 . nubOrd . go <$> getRandomRs ('A', 'Z') - bigAllocCourses <- forM (zip [1..] bigAllocShorthands) $ \(n :: Natural, csh) -> do - cap <- getRandomR (10,50) - - minCap <- round . (* fromIntegral cap) <$> getRandomR (0, 0.5 :: Double) - - substitutesUntil <- (`addUTCTime` now) . fromInteger <$> getRandomR (900,2300) - - cid <- insert' Course - { courseName = CI.mk [st|Zentralanmeldungskurs #{n} (#{csh})|] - , courseDescription = Nothing - , courseLinkExternal = Nothing - , courseShorthand = CI.mk csh - , courseTerm = TermKey $ seasonTerm False Q4 - , courseSchool = ifi - , courseCapacity = Just cap - , courseVisibleFrom = Just now - , courseVisibleTo = Nothing - , courseRegisterFrom = Nothing - , courseRegisterTo = Nothing - , courseDeregisterUntil = Nothing - , courseRegisterSecret = Nothing - , courseMaterialFree = True - , courseApplicationsRequired = False - , courseApplicationsInstructions = Nothing - , courseApplicationsText = False - , courseApplicationsFiles = NoUpload - , courseApplicationsRatingsVisible = False - , courseDeregisterNoShow = False - } - insert_ $ CourseEdit gkleen now cid - void . insert' $ AllocationCourse bigAlloc cid minCap (Just substitutesUntil) Nothing - -- void . insert' $ Lecturer gkleen cid CourseLecturer - return cid - - forM_ manyUsers $ \uid -> do - totalCourses <- weighted $ do - n <- [1..10] - return (n, fromIntegral $ (1 - 10) ^ 2 - (1 - n) ^ 2) - - void . insert $ AllocationUser bigAlloc uid (fromIntegral totalCourses) Nothing - - appliedCourses <- weighted $ do - n <- [totalCourses - 2..totalCourses + 5] - return (n, fromIntegral $ (totalCourses + 1 - totalCourses - 5) ^ 2 - (totalCourses + 1 - n) ^ 2) - - appliedCourses' <- take appliedCourses <$> shuffleM bigAllocCourses - - forM_ (zip [0..] appliedCourses') $ \(prio, cid) -> do - rating <- weighted . Map.toList . Map.fromListWith (+) $ do - veto <- universeF :: [Bool] - grade <- universeF :: [ExamGrade] - rated <- universeF - - return ( bool Nothing (Just (veto, grade)) rated - , bool 5 1 veto * bool 5 1 rated - ) - - void $ insert CourseApplication - { courseApplicationCourse = cid - , courseApplicationUser = uid - , courseApplicationText = Nothing - , courseApplicationRatingVeto = maybe False (view _1) rating - , courseApplicationRatingPoints = view _2 <$> rating - , courseApplicationRatingComment = Nothing - , courseApplicationAllocation = Just bigAlloc - , courseApplicationAllocationPriority = Just prio - , courseApplicationTime = now - , courseApplicationRatingTime = now <$ rating - } + -} numericPriorities <- flip foldMapM manyUsers $ \uid -> do uRec <- get uid diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 7c606a858..74d13b545 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -46,6 +46,8 @@ import qualified Data.Text.Lazy as LT import Text.Blaze.Html.Renderer.Text (renderHtml) +import Handler.Utils.DateTime (getYear) + {- instance Arbitrary Day where arbitrary = ModifiedJulianDay <$> choose (-313698, 2973483) -- 1000-01-1 to 9999-12-31 @@ -63,7 +65,7 @@ instance CoArbitrary Day where instance Arbitrary TermIdentifier where arbitrary = TermIdentifier <$> arbitrary - shrink = fmap TermIdentifier . shrink . tday + shrink = fmap TermIdentifier . shrink . getTermDay instance CoArbitrary TermIdentifier instance Function TermIdentifier @@ -387,8 +389,6 @@ spec = do [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ] lawsCheckHspec (Proxy @Load) [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, commutativeSemigroupLaws, commutativeMonoidLaws ] - lawsCheckHspec (Proxy @Season) - [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws ] lawsCheckHspec (Proxy @TermIdentifier) [ eqLaws, showReadLaws, ordLaws, enumLaws, persistFieldLaws, jsonLaws, httpApiDataLaws, pathPieceLaws ] lawsCheckHspec (Proxy @StudyFieldType) @@ -467,8 +467,11 @@ spec = do \term -> termFromText (termToText term) == Right term it "has compatible encoding/decoding to/from Rational" . property $ \term -> termFromRational (termToRational term) == term + -- This is not sufficient + --it "has compatible encoding/decoding to/from PersistValue" . property $ + -- \term -> fromPersistValue (toPersistValue term) == term it "has human readable year encoding to Rational" . property $ - \term -> truncate (termToRational term) == fst3 $ toGregorian $ tday term + \term -> truncate (termToRational term) == getYear (getTermDay term) describe "Pseudonym" $ do it "has sufficient vocabulary" $ (length pseudonymWordlist ^ 2) `shouldSatisfy` (> (fromIntegral (maxBound :: Pseudonym) - fromIntegral (minBound :: Pseudonym)))