chore(dayterms): change termidentifiers to single days complete
This commit is contained in:
Steffen Jost
parent
0c0cb06cdc
commit
f807b42089
@ -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
|
||||
|
||||
@ -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
|
||||
@ -59,20 +61,18 @@ fillDb = do
|
||||
|
||||
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?
|
||||
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)
|
||||
termTime gTid gTD gOff mbWeekDay = ($ utctDay)
|
||||
where
|
||||
gTid = nextTerm next
|
||||
gDay | fromEnd = addBDays (negate doff) $ guessDay gTid TermDayLectureEnd
|
||||
| otherwise = addBDays doff $ guessDay gTid TermDayLectureStart
|
||||
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,28 +585,41 @@ fillDb = do
|
||||
|
||||
|
||||
-- Fahrschule F
|
||||
fdf <- insert' Course
|
||||
{ courseName = "F - Vorfeldführerschein"
|
||||
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|
|
||||
<p>
|
||||
Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.
|
||||
<section>
|
||||
<h3>Benötigte Unterlagen
|
||||
<ul>
|
||||
<li>Sehtest
|
||||
<i>(Bitte vorab hochladen!)
|
||||
<li>Regulärer Führerschein
|
||||
<li>Sehtest,
|
||||
<i>bitte vorab hochladen!
|
||||
<li>Regulärer Führerschein,
|
||||
<i>Bitte mitbringen.
|
||||
|]
|
||||
, courseLinkExternal = Nothing
|
||||
, courseShorthand = "F"
|
||||
, courseTerm = TermKey currentTerm
|
||||
, courseTerm = tk
|
||||
, 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
|
||||
, 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
|
||||
@ -606,17 +629,17 @@ fillDb = do
|
||||
, courseApplicationsRatingsVisible = False
|
||||
, courseDeregisterNoShow = True
|
||||
}
|
||||
insert_ $ CourseEdit jost now fdf
|
||||
void $ insert Sheet
|
||||
{ sheetCourse = fdf
|
||||
, sheetName = "Sehtest"
|
||||
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 = 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
|
||||
, 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
|
||||
@ -628,60 +651,57 @@ fillDb = do
|
||||
, 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
|
||||
-- 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 = CI.mk $ Text.pack $ "KW" ++ show (snd3 $ toWeekDate $ utctDay firstTT) ++ take 3 (show td)
|
||||
, tutorialCourse = fdf
|
||||
{ tutorialName = mkName "Theorieschulung"
|
||||
, tutorialCourse = c
|
||||
, tutorialType = "Schulung"
|
||||
, tutorialCapacity = Just 16
|
||||
, tutorialRoom = Just $ case tw `mod` 4 of
|
||||
1 -> "A380"
|
||||
2 -> "B747"
|
||||
3 -> "MD11"
|
||||
, 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 = utctDay firstTT
|
||||
{ exceptDay = firstDay
|
||||
, exceptStart = TimeOfDay 8 30 0
|
||||
, exceptEnd = TimeOfDay 16 0 0
|
||||
}
|
||||
, ExceptOccur
|
||||
{ exceptDay = utctDay secondTT
|
||||
{ exceptDay = secondDay
|
||||
, exceptStart = TimeOfDay 9 0 0
|
||||
, exceptEnd = TimeOfDay 16 0 0
|
||||
}
|
||||
]
|
||||
}
|
||||
, tutorialRegGroup = Just "schulung"
|
||||
, tutorialRegisterFrom = Just regFrom
|
||||
, tutorialRegisterTo = Just regTo
|
||||
, tutorialDeregisterUntil = Nothing
|
||||
, 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 $ Tutor tut1 jost
|
||||
insert_ $ Tutor tut1 jost
|
||||
void . insert' $ Exam
|
||||
{ examCourse = fdf
|
||||
, examName = "Theorie"
|
||||
{ examCourse = c
|
||||
, examName = mkName "Theorieprüfung"
|
||||
, examGradingRule = Nothing
|
||||
, examBonusRule = Nothing
|
||||
, examOccurrenceRule = ExamRoomManual
|
||||
, examExamOccurrenceMapping = Nothing
|
||||
, examVisibleFrom = Just regFrom
|
||||
, examRegisterFrom = Just firstTT
|
||||
, examRegisterTo = Just $ toMidday $ utctDay secondTT
|
||||
, examDeregisterUntil = 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 15 30 0 $ utctDay secondTT
|
||||
, examEnd = Just $ toTimeOfDay 16 30 0 $ utctDay secondTT
|
||||
, examStart = Just $ toTimeOfDay 16 0 0 secondDay
|
||||
, examEnd = Just $ toTimeOfDay 16 30 0 secondDay
|
||||
, examFinished = Nothing
|
||||
, examPartsFrom = Nothing
|
||||
, examClosed = Nothing
|
||||
@ -698,452 +718,6 @@ fillDb = do
|
||||
, examAuthorshipStatement = Nothing
|
||||
}
|
||||
|
||||
-- FFP
|
||||
let nbrs :: [Int]
|
||||
nbrs = [1,2,3,27,7,1]
|
||||
ffp <- insert' Course
|
||||
{ courseName = "Fortgeschrittene Funktionale Programmierung"
|
||||
, courseDescription = Just $ htmlToStoredMarkup [shamlet|
|
||||
<h2>It is fun!
|
||||
<p>Come to where the functional is!
|
||||
<section>
|
||||
<h3>Functional programming can be done in Haskell!
|
||||
<p>This is not a joke, this is serious!
|
||||
<section>
|
||||
<h3>Consider some numbers
|
||||
<ul>
|
||||
$forall n <- nbrs
|
||||
<li>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|<i>Folien</i> 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|<i>Videos</i> 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)
|
||||
]
|
||||
}
|
||||
] ++ [ 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
|
||||
}
|
||||
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
|
||||
|
||||
testMsg <- insert SystemMessage
|
||||
{ systemMessageNewsOnly = False
|
||||
, systemMessageFrom = Just now
|
||||
@ -1216,7 +790,7 @@ fillDb = do
|
||||
, systemMessageLastUnhide = now
|
||||
}
|
||||
|
||||
|
||||
{-
|
||||
aSeedFunc <- liftIO $ getRandomBytes 40
|
||||
funAlloc <- insert' Allocation
|
||||
{ allocationName = "Funktionale Zentralanmeldung"
|
||||
@ -1235,7 +809,7 @@ 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
|
||||
@ -1246,209 +820,7 @@ fillDb = do
|
||||
, (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
|
||||
|
||||
@ -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)))
|
||||
|
||||
Reference in New Issue
Block a user