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