Merge branch 'term2days' into 'master'
Term2days See merge request FraDrive/fradrive!5
This commit is contained in:
Steffen Jost
commit
21f217d0a2
@ -1,11 +1,3 @@
|
||||
Quarter1st year@Integer: Erstes Quartal #{year}
|
||||
Quarter2nd year@Integer: Zweites Quartal #{year}
|
||||
Quarter3rd year@Integer: Drittes Quartal #{year}
|
||||
Quarter4th year@Integer: Viertes Quartal #{year}
|
||||
Quarter1stShort year@Integer: #{year}/Q1
|
||||
Quarter2ndShort year@Integer: #{year}/Q2
|
||||
Quarter3rdShort year@Integer: #{year}/Q3
|
||||
Quarter4thShort year@Integer: #{year}/Q4
|
||||
CorByProportionOnly proportion@Rational: #{rationalToFixed3 proportion} Anteile
|
||||
CorByProportionIncludingTutorial proportion@Rational: #{rationalToFixed3 proportion} Anteile - Tutorium
|
||||
CorByProportionExcludingTutorial proportion@Rational: #{rationalToFixed3 proportion} Anteile + Tutorium
|
||||
|
||||
@ -1,11 +1,3 @@
|
||||
Quarter1st year@Integer: First Quarter of #{year}
|
||||
Quarter2nd year@Integer: Second Quarter of #{year}
|
||||
Quarter3rd year@Integer: Third Quarter of #{year}
|
||||
Quarter4th year@Integer: Last Quarter of #{year}
|
||||
Quarter1stShort year@Integer: #{year}/Q1st
|
||||
Quarter2ndShort year@Integer: #{year}/Q2nd
|
||||
Quarter3rdShort year@Integer: #{year}/Q3rd
|
||||
Quarter4thShort year@Integer: #{year}/Q4th
|
||||
CorByProportionOnly proportion: #{rationalToFixed3 proportion} parts
|
||||
CorByProportionIncludingTutorial proportion: #{rationalToFixed3 proportion} parts - tutorials
|
||||
CorByProportionExcludingTutorial proportion: #{rationalToFixed3 proportion} parts + tutorials
|
||||
|
||||
@ -21,7 +21,11 @@ let
|
||||
contents = with final; [
|
||||
uniworx.uniworx.components.exes.uniworx
|
||||
prev.dockerTools.binSh findutils coreutils
|
||||
curl wget
|
||||
cups # needed for interface with print center
|
||||
texlive.combined.scheme-medium # probably needed by pandoc library to produce PDFs?
|
||||
# For manual testing, maybe remove for production?
|
||||
curl wget pandoc
|
||||
|
||||
] ++ optionals isDemo [ postgresql_12 memcached uniworx.uniworx.components.exes.uniworxdb ];
|
||||
|
||||
runAsRoot = ''
|
||||
|
||||
1
routes
1
routes
@ -69,6 +69,7 @@
|
||||
/info/glossary GlossaryR GET !free
|
||||
/info/faq FaqR GET !free
|
||||
/version VersionR GET !free
|
||||
/status StatusR GET !free
|
||||
|
||||
/help HelpR GET POST !free
|
||||
|
||||
|
||||
@ -195,20 +195,10 @@ mkMessageVariant ''UniWorX ''ButtonMessage "messages/button" "de"
|
||||
mkMessageVariant ''UniWorX ''FrontendMessage "messages/frontend" "de-de-formal"
|
||||
|
||||
instance RenderMessage UniWorX TermIdentifier where
|
||||
renderMessage foundation ls TermIdentifier{..} = case season of
|
||||
Q1 -> renderMessage' $ MsgQuarter1st year
|
||||
Q2 -> renderMessage' $ MsgQuarter2nd year
|
||||
Q3 -> renderMessage' $ MsgQuarter3rd year
|
||||
Q4 -> renderMessage' $ MsgQuarter4th year
|
||||
where renderMessage' = renderMessage foundation ls
|
||||
renderMessage _foundation _ls = termToText -- TODO: respect user selected Datetime Format
|
||||
|
||||
instance RenderMessage UniWorX ShortTermIdentifier where
|
||||
renderMessage foundation ls (ShortTermIdentifier TermIdentifier{..}) = case season of
|
||||
Q1 -> renderMessage' $ MsgQuarter1stShort year
|
||||
Q2 -> renderMessage' $ MsgQuarter2ndShort year
|
||||
Q3 -> renderMessage' $ MsgQuarter3rdShort year
|
||||
Q4 -> renderMessage' $ MsgQuarter4thShort year
|
||||
where renderMessage' = renderMessage foundation ls
|
||||
renderMessage _foundation _ls (ShortTermIdentifier tid) = termToText tid -- TODO: implement shorttermidentifier properly
|
||||
|
||||
instance RenderMessage UniWorX String where
|
||||
renderMessage f ls str = renderMessage f ls $ Text.pack str
|
||||
|
||||
@ -132,6 +132,7 @@ breadcrumb HelpR = i18nCrumb MsgMenuHelp Nothing
|
||||
|
||||
breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing
|
||||
breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing
|
||||
breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed
|
||||
|
||||
breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing
|
||||
breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail $ Just ProfileR
|
||||
|
||||
@ -159,8 +159,7 @@ suggestAllocationForm (Set.fromList . map optionInternalValue . olOptions -> ter
|
||||
newTerm <- MaybeT $ get tid
|
||||
Entity _ Allocation{..} <- MaybeT . getBy $ TermSchoolAllocationShort oldTid ssh ash
|
||||
|
||||
let dayOffset = (diffDays `on` termLectureStart) newTerm oldTerm
|
||||
addTime = addLocalDays dayOffset
|
||||
let addTime = addLocalDays $ (diffDays `on` termLectureStart) newTerm oldTerm
|
||||
|
||||
return AllocationForm
|
||||
{ afTerm = tid
|
||||
|
||||
@ -435,7 +435,7 @@ getCourseNewR = do
|
||||
let newTemplate = courseToForm oldTemplate mempty mempty Nothing in
|
||||
return $ Just $ newTemplate
|
||||
{ cfCourseId = Nothing
|
||||
, cfTerm = TermKey $ TermIdentifier 0 Q1 -- invalid, will be ignored; undefined won't work due to strictness
|
||||
, cfTerm = TermKey $ termFromRational 0 -- invalid, will be ignored; undefined won't work due to strictness
|
||||
, cfRegFrom = Nothing
|
||||
, cfRegTo = Nothing
|
||||
, cfDeRegUntil = Nothing
|
||||
|
||||
@ -11,6 +11,9 @@ import qualified Data.Set as Set
|
||||
|
||||
import Control.Concurrent.STM.Delay
|
||||
|
||||
import Language.Haskell.TH (stringE,runIO)
|
||||
|
||||
-- import Data.FileEmbed (embedStringFile)
|
||||
|
||||
getHealthR :: Handler TypedContent
|
||||
getHealthR = do
|
||||
@ -94,3 +97,31 @@ getInstanceR = do
|
||||
|]
|
||||
provideJson instanceInfo
|
||||
provideRep . return $ tshow instanceInfo
|
||||
|
||||
|
||||
-- Most simple page for simple liveness checks
|
||||
getStatusR :: Handler Html
|
||||
getStatusR = withUrlRenderer
|
||||
[hamlet|
|
||||
$doctype 5
|
||||
<html lang=en>
|
||||
<head>
|
||||
<title>Alive
|
||||
<body>
|
||||
<p>
|
||||
Compile Time {#{comptime}}
|
||||
|]
|
||||
{-
|
||||
<p>
|
||||
Alive #{vnr_full}
|
||||
<p>
|
||||
Demo #{vnr_demo}
|
||||
<p>
|
||||
CI #{vnr_ci}
|
||||
-}
|
||||
where
|
||||
-- vnr_full :: Text = $(embedStringFile "./nix/docker/version.json")
|
||||
-- vnr_demo :: Text = $(embedStringFile "./nix/docker/demo-version.json")
|
||||
-- vnr_ci :: Text = $(embedStringFile "./nix/docker/ci-version.json")
|
||||
comptime :: Text = $(stringE =<< runIO (show <$> getCurrentTime))
|
||||
|
||||
@ -26,7 +26,6 @@ validateTerm :: (MonadHandler m, HandlerSite m ~ UniWorX)
|
||||
=> FormValidator TermForm m ()
|
||||
validateTerm = do
|
||||
TermForm{..} <- State.get
|
||||
guardValidation MsgTermStartMustMatchName $ tfStart `withinTermYear` tfName
|
||||
guardValidation MsgTermEndMustBeAfterStart $ tfStart < tfEnd
|
||||
guardValidation MsgTermLectureEndMustBeAfterStart $ tfLectureStart < tfLectureEnd
|
||||
guardValidation MsgTermStartMustBeBeforeLectureStart $ tfStart <= tfLectureStart
|
||||
|
||||
@ -16,6 +16,7 @@ module Handler.Utils.DateTime
|
||||
, addOneWeek, addWeeks
|
||||
, weeksToAdd
|
||||
, setYear, getYear
|
||||
, firstDayOfWeekOnAfter
|
||||
, ceilingQuarterHour
|
||||
, formatGregorianW
|
||||
) where
|
||||
@ -224,6 +225,14 @@ getYear date = y
|
||||
where
|
||||
(y,_,_) = toGregorian date
|
||||
|
||||
dayOfWeekDiff :: DayOfWeek -> DayOfWeek -> Int
|
||||
dayOfWeekDiff a b = mod (fromEnum a - fromEnum b) 7
|
||||
|
||||
-- | The first day-of-week on or after some day
|
||||
-- | from time-compat-1.9.5, not included
|
||||
firstDayOfWeekOnAfter :: DayOfWeek -> Day -> Day
|
||||
firstDayOfWeekOnAfter dw d = addDays (toInteger $ dayOfWeekDiff dw $ dayOfWeek d) d
|
||||
|
||||
addOneWeek :: UTCTime -> UTCTime
|
||||
addOneWeek = addWeeks 1
|
||||
|
||||
|
||||
@ -12,11 +12,10 @@ module Model.Types.DateTime
|
||||
import Import.NoModel
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Data.Either.Combinators (maybeToRight)
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
import Data.Time.Calendar.WeekDate
|
||||
import Data.Time.Format.ISO8601
|
||||
|
||||
import Database.Persist.Sql
|
||||
|
||||
@ -26,45 +25,13 @@ import Data.Aeson.Types as Aeson
|
||||
|
||||
|
||||
----
|
||||
-- Terms, Seaons, anything loosely related to time
|
||||
-- Terms and anything loosely related to time
|
||||
|
||||
data Season = Q1 | Q2 | Q3 | Q4
|
||||
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Binary, Universe, Finite, NFData)
|
||||
|
||||
numSeasons :: Int -- to be flexible
|
||||
numSeasons = succ $ fromEnum(maxBound::Season)
|
||||
|
||||
seasonFromText' :: Text -> Either Text Season
|
||||
seasonFromText' t = maybeToRight errmsg (readMaybe $ Text.unpack $ Text.toUpper t)
|
||||
where
|
||||
errmsg = "Invalid season: ‘" <> tshow t <> "’"
|
||||
|
||||
seasonFromText :: Text -> Either Text Season
|
||||
seasonFromText t
|
||||
| Just (q, ne) <- Text.uncons t
|
||||
, q ~= 'Q'
|
||||
, Just (n, e) <- Text.uncons ne
|
||||
, Text.null e = case n of '1' -> Right Q1
|
||||
'2' -> Right Q2
|
||||
'3' -> Right Q3
|
||||
'4' -> Right Q4
|
||||
_ -> Left $ "Invalid quarter number: ‘" <> tshow t <> "’"
|
||||
| otherwise = Left $ "Invalid season: ‘" <> tshow t <> "’"
|
||||
where
|
||||
(~=) :: Char -> Char -> Bool
|
||||
(~=) = (==) `on` CI.mk
|
||||
|
||||
data TermIdentifier = TermIdentifier
|
||||
{ year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar'
|
||||
, season :: Season
|
||||
} deriving (Show, Read, Eq, Ord, Generic, Typeable)
|
||||
deriving anyclass (Binary, NFData)
|
||||
|
||||
instance Enum TermIdentifier where
|
||||
-- ^ Do not use for conversion – Enumeration only
|
||||
toEnum int = let (toInteger -> year, toEnum -> season) = int `divMod` numSeasons in TermIdentifier{..}
|
||||
fromEnum TermIdentifier{..} = fromInteger year * numSeasons + fromEnum season
|
||||
newtype TermIdentifier = TermIdentifier { getTermDay :: Day }
|
||||
deriving (Show, Read, Eq, Ord, Generic, Typeable, Enum)
|
||||
deriving newtype (Binary, ISO8601, PersistField, PersistFieldSql)
|
||||
deriving anyclass (NFData)
|
||||
-- ought to be equivalent to deriving stock (Show, Read, Eq, Ord, Generic, Typeable, Enum, Binary, NFData)
|
||||
|
||||
-- Conversion TermId <-> TermIdentifier::
|
||||
-- from_TermId_to_TermIdentifier = unTermKey
|
||||
@ -94,40 +61,56 @@ shortened = iso shorten expand
|
||||
, year < $currentYear + 50 = year `mod` 100
|
||||
| otherwise = year
|
||||
|
||||
-- Option 1: date in iso8601
|
||||
termToText :: TermIdentifier -> Text
|
||||
termToText TermIdentifier{..} = Text.pack $ show (year ^. shortened) ++ show season
|
||||
termToText = Text.pack . iso8601Show
|
||||
|
||||
-- also see Hander.Utils.tidFromText
|
||||
termFromText :: Text -> Either Text TermIdentifier
|
||||
termFromText t
|
||||
| (ys,s) <- Text.break (~= 'Q') t
|
||||
, Right season <- seasonFromText s
|
||||
, Just (review shortened -> year) <- readMaybe $ Text.unpack ys
|
||||
= Right TermIdentifier{..}
|
||||
| otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" -- TODO: Could be improved, I.e. say "W"/"S" from Number
|
||||
termFromText t = maybeToRight errm $ iso8601ParseM $ Text.unpack t
|
||||
where
|
||||
(~=) :: Char -> Char -> Bool
|
||||
(~=) = (==) `on` CI.mk
|
||||
errm = "Invalid TermIdentifier: “" <> t <> "”"
|
||||
|
||||
termToRational :: TermIdentifier -> Rational
|
||||
termToRational TermIdentifier{..} = toRational year + seasonOffset
|
||||
-- Option 2: show as WeekNr-DayOfWeek-Year, e.g. 22Mon2021?
|
||||
termToText' :: TermIdentifier -> Text
|
||||
termToText' TermIdentifier{..} = Text.pack $ show weeknr ++ wd ++ show year
|
||||
where
|
||||
seasonOffset = fromIntegral (fromEnum season) % fromIntegral numSeasons
|
||||
wd = take 3 $ show $ dayOfWeek getTermDay
|
||||
(year,weeknr,_wd_) = toWeekDate getTermDay
|
||||
|
||||
{- TODO
|
||||
termFromText' :: Text -> Either Text TermIdentifier
|
||||
termFromText' t = error "not implemented"
|
||||
where
|
||||
errm = "Invalid TermIdentifier: “" <> t <> "”"
|
||||
-}
|
||||
|
||||
daysPerYear :: Rational
|
||||
daysPerYear = 365 + (97 % 400)
|
||||
|
||||
dayOffset :: Rational
|
||||
dayOffset = fromIntegral yearzero + (fromIntegral diffstart / daysPerYear)
|
||||
where
|
||||
dayzero = toEnum 0
|
||||
yearzero = fst3 $ toGregorian dayzero
|
||||
diffstart = diffDays dayzero $ fromGregorian yearzero 1 1
|
||||
|
||||
-- Attempt to ensure that ``truncate . termToRational == fst3 . toGregorian . getTermDay´´ holds
|
||||
termToRational :: TermIdentifier -> Rational
|
||||
termToRational = (dayOffset +) . (/ daysPerYear) . fromIntegral . fromEnum
|
||||
|
||||
termFromRational :: Rational -> TermIdentifier
|
||||
termFromRational n = TermIdentifier{..}
|
||||
where
|
||||
year = floor n
|
||||
remainder = n - fromInteger (floor n) -- properFraction problematic for negative year values
|
||||
season = toEnum $ floor $ remainder * fromIntegral numSeasons
|
||||
termFromRational = toEnum . round . (daysPerYear *) . subtract dayOffset
|
||||
|
||||
{- -- For newtype Day, PersistField instance can be derived automatically
|
||||
instance PersistField TermIdentifier where
|
||||
toPersistValue = PersistRational . termToRational
|
||||
fromPersistValue (PersistRational t) = Right $ termFromRational t
|
||||
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
|
||||
@ -162,27 +145,16 @@ data TermDay
|
||||
guessDay :: TermIdentifier
|
||||
-> TermDay
|
||||
-> Day
|
||||
guessDay TermIdentifier{ year, season = Q1 } TermDayStart = fromGregorian year 1 1
|
||||
guessDay TermIdentifier{ year, season = Q2 } TermDayStart = fromGregorian year 4 1
|
||||
guessDay TermIdentifier{ year, season = Q3 } TermDayStart = fromGregorian year 7 1
|
||||
guessDay TermIdentifier{ year, season = Q4 } TermDayStart = fromGregorian year 10 1
|
||||
guessDay tid TermDayEnd = pred $ guessDay (succ tid) TermDayStart
|
||||
guessDay tid TermDayLectureStart = fromWeekDate year weekStart 1 -- first Monday within Quarter
|
||||
where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayStart
|
||||
guessDay tid TermDayLectureEnd = fromWeekDate year weekStart 5 -- Friday of last week within Quarter
|
||||
where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayEnd
|
||||
guessDay TermIdentifier{..} TermDayLectureStart = getTermDay
|
||||
guessDay TermIdentifier{..} TermDayLectureEnd = addDays 8 getTermDay -- courses last only a week
|
||||
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
|
||||
|
||||
-- | Check only if last two digits within the year numbers match
|
||||
withinTermYear :: Day -> TermIdentifier -> Bool
|
||||
time `withinTermYear` term = timeYear `mod` 100 == termYear `mod` 100
|
||||
where
|
||||
timeYear = fst3 $ toGregorian time
|
||||
termYear = year term
|
||||
|
||||
|
||||
data OccurrenceSchedule = ScheduleWeekly
|
||||
{ scheduleDayOfWeek :: WeekDay
|
||||
, scheduleStart :: TimeOfDay
|
||||
|
||||
@ -10,6 +10,8 @@ module Utils.Holidays
|
||||
, feiertage
|
||||
, bankHolidays, bankHolidaysArea, bankHolidaysAreaSet
|
||||
, isBankHoliday, isBankHolidayArea
|
||||
, isWeekend
|
||||
, addBusinessDays
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
@ -107,11 +109,14 @@ isBankHolidayArea land dd = dd `Set.member` holidays
|
||||
-- | Returns whether a day is a bank holiday for years >= 1995
|
||||
-- | Repeated calls are handled efficiently using lazy memoization
|
||||
isBankHolidayArea :: Feiertagsgebiet -> Day -> Bool
|
||||
isBankHolidayArea land dd = dd `Set.member` holidays
|
||||
isBankHolidayArea land = ibha
|
||||
where
|
||||
landHoliday = Map.lookup land memoHolidays
|
||||
ibha dd = dd `Set.member` holidays
|
||||
where
|
||||
(year, _, _) = toGregorian dd
|
||||
holidays
|
||||
| (Just hys) <- Map.lookup land memoHolidays
|
||||
| (Just hys) <- landHoliday
|
||||
, (Just hds) <- index hys $ fromInteger $ year2index year = hds
|
||||
| otherwise = bankHolidaysAreaSet land year
|
||||
|
||||
@ -137,3 +142,27 @@ index2year y = result
|
||||
(x,r) = y `divMod` 2
|
||||
result | r == 0 = memoTip + x
|
||||
| otherwise = memoTip - x - 1
|
||||
|
||||
-- | Test for Saturday/Sunday
|
||||
isWeekend :: Day -> Bool
|
||||
isWeekend = isWeekend' . dayOfWeek
|
||||
where
|
||||
isWeekend' :: WeekDay -> Bool
|
||||
isWeekend' Sunday = True
|
||||
isWeekend' Saturday = True
|
||||
isWeekend' _ = False
|
||||
|
||||
-- | Always returns a business day.
|
||||
-- | Saturday/Sunday/Holiday treated like next (n>=0) or previous (n<0) working day
|
||||
addBusinessDays :: Feiertagsgebiet -> Integer -> Day -> Day
|
||||
addBusinessDays land = abd
|
||||
where
|
||||
ibhal = isBankHolidayArea land
|
||||
freeday dd = isWeekend dd || ibhal dd
|
||||
abd n = abd' n
|
||||
where
|
||||
(fwd, bwd) | n >= 0 = (succ, pred)
|
||||
| otherwise = (pred, succ)
|
||||
abd' m dd | freeday dd = abd' m (fwd dd)
|
||||
| m == 0 = dd
|
||||
| otherwise = abd' (bwd m) (fwd dd)
|
||||
|
||||
@ -3,39 +3,40 @@ 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(..))
|
||||
|
||||
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
|
||||
@ -47,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,33 +59,21 @@ fillDb = do
|
||||
insert' :: (PersistRecordBackend r (YesodPersistBackend UniWorX), AtLeastOneUniqueKey r) => r -> YesodDB UniWorX (Key r)
|
||||
insert' = fmap (either entityKey id) . insertBy
|
||||
|
||||
(currentYear, currentMonth, _) = toGregorian $ utctDay now
|
||||
currentTerm
|
||||
| 3 >= currentMonth = TermIdentifier currentYear Q1
|
||||
| 6 >= currentMonth = TermIdentifier currentYear Q2
|
||||
| 9 >= currentMonth = TermIdentifier currentYear Q3
|
||||
| otherwise = TermIdentifier currentYear Q4
|
||||
nextTerm = succ currentTerm
|
||||
prevTerm = pred currentTerm
|
||||
prevPrevTerm = pred prevTerm
|
||||
addBDays = addBusinessDays Fraport -- holiday area to use
|
||||
currentTerm = TermIdentifier $ utctDay now
|
||||
-- (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm
|
||||
nextTerm n = TermIdentifier $ addBDays n $ getTermDay currentTerm
|
||||
|
||||
seasonTerm next wSeason = until ((wSeason ==) . season) prog currentTerm
|
||||
where prog | next = succ
|
||||
| otherwise = pred
|
||||
|
||||
termTime :: Bool -- ^ Next term?
|
||||
-> Season
|
||||
-> Rational
|
||||
-> Bool -- ^ Relative to end of semester?
|
||||
-> WeekDay
|
||||
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 gSeason weekOffset fromEnd d = ($ utctDay)
|
||||
termTime gTid gTD gOff mbWeekDay = ($ utctDay)
|
||||
where
|
||||
utctDay = fromWeekDate wYear wWeek $ fromEnum d
|
||||
(wYear, wWeek, _) = toWeekDate . addDays (round $ 7 * weekOffset) $ fromGregorian rYear rMonth rDay
|
||||
gTid = seasonTerm next gSeason
|
||||
(rYear, rMonth, rDay) = toGregorian $ guessDay gTid $ bool TermDayLectureStart TermDayLectureEnd fromEnd
|
||||
gDay = addBDays gOff $ guessDay gTid gTD
|
||||
utctDay = maybe gDay (`firstDayOfWeekOnAfter` gDay) mbWeekDay
|
||||
|
||||
gkleen <- insert User
|
||||
{ userIdent = "G.Kleen@campus.lmu.de"
|
||||
@ -354,16 +345,27 @@ fillDb = do
|
||||
matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int)
|
||||
manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel
|
||||
|
||||
forM_ [(pred $ pred prevPrevTerm)..(succ $ succ $ succ $ succ nextTerm)] $ \tid -> do
|
||||
let term = Term { termName = tid
|
||||
, termStart = guessDay tid TermDayStart
|
||||
, termEnd = guessDay tid TermDayEnd
|
||||
, termHolidays = []
|
||||
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
|
||||
void . 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
|
||||
@ -583,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
|
||||
@ -614,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
|
||||
@ -636,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
|
||||
@ -706,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
|
||||
@ -1224,7 +790,7 @@ fillDb = do
|
||||
, systemMessageLastUnhide = now
|
||||
}
|
||||
|
||||
|
||||
{-
|
||||
aSeedFunc <- liftIO $ getRandomBytes 40
|
||||
funAlloc <- insert' Allocation
|
||||
{ allocationName = "Funktionale Zentralanmeldung"
|
||||
@ -1243,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
|
||||
@ -1254,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,20 +46,26 @@ 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
|
||||
-- arbitrary = ModifiedJulianDay <$> choose (15020, 2973483) -- 1900-01-1 to 9999-12-31
|
||||
shrink day = let
|
||||
(y, m, d) = toGregorian day
|
||||
dayShrink = [fromGregorian y m (d - 1) | d > 1]
|
||||
monthShrink = [fromGregorian y (m - 1) d | m > 1]
|
||||
yearShrink = [fromGregorian (y - 1) m d | y > 2000]
|
||||
in dayShrink ++ monthShrink ++ yearShrink
|
||||
|
||||
instance Arbitrary Season where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
instance CoArbitrary Season
|
||||
instance Function Season
|
||||
instance CoArbitrary Day where
|
||||
coarbitrary (ModifiedJulianDay d) = coarbitrary d
|
||||
-}
|
||||
|
||||
instance Arbitrary TermIdentifier where
|
||||
arbitrary = do
|
||||
season <- arbitrary
|
||||
year <- arbitrary `suchThat` (\y -> abs y >= 100)
|
||||
return $ TermIdentifier{..}
|
||||
shrink = filter ((\y -> abs y >= 100) . year) . genericShrink
|
||||
arbitrary = TermIdentifier <$> arbitrary
|
||||
shrink = fmap TermIdentifier . shrink . getTermDay
|
||||
instance CoArbitrary TermIdentifier
|
||||
instance Function TermIdentifier
|
||||
|
||||
@ -383,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)
|
||||
@ -461,13 +465,13 @@ spec = do
|
||||
describe "TermIdentifier" $ do
|
||||
it "has compatible encoding/decoding to/from Text" . property $
|
||||
\term -> termFromText (termToText term) == Right term
|
||||
it "works for some examples" . mapM_ termExample $
|
||||
[ (TermIdentifier 2017 Q2, "17Q2")
|
||||
, (TermIdentifier 1995 Q4, "95Q4")
|
||||
, (TermIdentifier 3068 Q1, "3068Q1")
|
||||
]
|
||||
it "has compatbile encoding/decoding to/from Rational" . property $
|
||||
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) == 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