chore(dayterms): change termidentifiers to single days complete

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 
+guessDay tid TermDayStart = fromWeekDate year week 1 -- Monday before lecture time 
-  where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayLectureStart
+  where ( year, week, _) = toWeekDate $ addDays (-7*4*3) $ guessDay tid TermDayLectureStart
-guessDay tid TermDayEnd   = fromWeekDate year weekStart 7 -- Sunday after lecture time
+guessDay tid TermDayEnd   = fromWeekDate year week 7 -- Sunday after lecture time
-  where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayLectureEnd
+  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

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 Crypto.Random (getRandomBytes)
-import Data.List (genericLength)
+import Data.List (foldl)
-import qualified Data.List as List (splitAt)
+-- import qualified Data.List as List (splitAt)
-
-import qualified Data.Conduit.Combinators as C
 
 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)
+    termTime :: TermIdentifier     -- ^ Term 
-             -> Integer -- ^ Days Offset from Start/End of Term 
+             -> TermDay            -- ^ Relative to which day? 
-             -> Bool    -- ^ Relative to end of Term?
+             -> 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 = addBDays gOff $ guessDay gTid gTD          
-        gDay | fromEnd   = addBDays (negate doff) $ guessDay gTid TermDayLectureEnd
-             | otherwise = addBDays         doff  $ guessDay gTid TermDayLectureStart 
         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 tmin   = -8
-    let tid = nextTerm nr tid 
+      tmax   = 29*6
-        term = Term { termName     = termToText' tid 
+      trange = [tmin..tmax]
-                    , termStart    = guessDay tid TermDayStart
+      dmin   = guessDay (nextTerm tmin) TermDayStart
-                    , termEnd      = guessDay tid TermDayEnd
+      dmax   = guessDay (nextTerm tmax) TermDayEnd
-                    , termHolidays = bankHolidaysArea Fraport
+      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 
+    repsert tk term 
-    insert $ TermActive (TermKey tid) (toMidnight $ addDays (-60) $ termStart term) (Just . beforeMidnight $ addDays 60 $ termEnd term) Nothing
+    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
+  forM_ terms $ \tk -> do
-    { courseName = "F - Vorfeldführerschein"
+    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 
+                    <li>Sehtest, 
-                <i>(Bitte vorab hochladen!)
+                      <i>bitte vorab hochladen!
-              <li>Regulärer Führerschein 
+                    <li>Regulärer Führerschein,
+                      <i>Bitte mitbringen.
               |]
           , courseLinkExternal = Nothing
           , courseShorthand = "F"
-    , courseTerm = TermKey currentTerm
+          , courseTerm      = tk
           , courseSchool    = avn
-    , courseCapacity = Nothing
+          , courseCapacity  = capacity
-    , courseVisibleFrom = Just now 
+          , courseVisibleFrom     = jtt TermDayStart          0  Nothing       toMidnight
-    , courseVisibleTo = Nothing
+          , courseVisibleTo       = jtt TermDayEnd            0  Nothing   beforeMidnight
-    , courseRegisterFrom = Just $ termTime True (season currentTerm) (-2) False Monday toMidnight
+          , courseRegisterFrom    = jtt TermDayStart          0  Nothing       toMidnight
-    , courseRegisterTo = Just $ termTime True (season currentTerm) 0 True Saturday beforeMidnight
+          , courseRegisterTo      = jtt TermDayLectureStart (-1) Nothing       toMidnight
-    , courseDeregisterUntil = Nothing
+          , 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
+        insert_ $ CourseEdit jost now c
-  void $ insert Sheet
+        insert_ Sheet
-    { sheetCourse = fdf
+          { sheetCourse = c
-    , sheetName = "Sehtest"
+          , 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
+          , sheetVisibleFrom = jtt TermDayStart        0 Nothing toMidnight
-    , sheetActiveFrom = Just $ termTime True (season currentTerm) (-2) False Monday toMidnight
+          , sheetActiveFrom  = jtt TermDayStart        0 Nothing toMidnight
-    , sheetActiveTo = Just $ termTime True (season currentTerm) 0 True Saturday beforeMidnight
+          , 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
+        -- TODO: Maybe split into to Tutorials with 
-    forM_ [(1::Int)..(4*4)] $ \tw -> do
+        -- occurrencesSchedule = Set.fromList [ ScheduleWeekly { scheduleDayOfWeek = weekDay, scheduleStart = TimeOfDay 8 30 0, scheduleEnd = TimeOfDay 16 0 0} ]
-      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)
+          { tutorialName = mkName "Theorieschulung"
-        , tutorialCourse = fdf
+          , tutorialCourse = c
           , tutorialType = "Schulung"
-        , tutorialCapacity = Just 16
+          , tutorialCapacity = capacity
-        , tutorialRoom = Just $ case tw `mod` 4 of 
+          , tutorialRoom = Just $ case weekDay of 
-            1 -> "A380"
+                Monday -> "A380"
-            2 -> "B747"
+                Tuesday -> "B747"
-            3 -> "MD11"
+                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 
+          , tutorialRegisterFrom    = jtt TermDayStart          0  Nothing       toMidnight
-        , tutorialRegisterTo   = Just regTo    
+          , tutorialRegisterTo      = jtt TermDayLectureStart (-1) Nothing       toMidnight
-        , tutorialDeregisterUntil = Nothing
+          , 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
+            { examCourse = c
-        , examName = "Theorie"
+            , examName = mkName "Theorieprüfung"
             , examGradingRule = Nothing
             , examBonusRule = Nothing
             , examOccurrenceRule = ExamRoomManual
             , examExamOccurrenceMapping = Nothing
-        , examVisibleFrom = Just regFrom
+            , examVisibleFrom     = jtt TermDayStart          0  Nothing       toMidnight
-        , examRegisterFrom = Just firstTT
+            , examRegisterFrom    = jtt TermDayStart          0  Nothing       toMidnight
-        , examRegisterTo = Just $ toMidday $ utctDay secondTT 
+            , examRegisterTo      = jtt TermDayLectureStart (-1) Nothing       toMidnight
-        , examDeregisterUntil = Nothing
+            , examDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight 
             , examPublishOccurrenceAssignments = Nothing
-        , examStart = Just $ toTimeOfDay 15 30 0 $ utctDay secondTT
+            , examStart = Just $ toTimeOfDay 16  0  0 secondDay 
-        , examEnd   = Just $ toTimeOfDay 16 30 0 $ utctDay secondTT
+            , 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

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