fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'term2days' into 'master'

Browse Source 
Term2days

See merge request FraDrive/fradrive!5
This commit is contained in:
Steffen Jost 2021-10-28 13:13:39 +02:00
commit 21f217d0a2
16 changed files with 337 additions and 950 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
messages/uniworx/categories/I18n/de-de-formal.msg
View File

@ -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 CorByProportionOnly proportion@Rational: #{rationalToFixed3 proportion} Anteile
CorByProportionIncludingTutorial proportion@Rational: #{rationalToFixed3 proportion} Anteile - Tutorium CorByProportionIncludingTutorial proportion@Rational: #{rationalToFixed3 proportion} Anteile - Tutorium
CorByProportionExcludingTutorial proportion@Rational: #{rationalToFixed3 proportion} Anteile + Tutorium CorByProportionExcludingTutorial proportion@Rational: #{rationalToFixed3 proportion} Anteile + Tutorium

8
messages/uniworx/categories/I18n/en-eu.msg
View File

@ -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 CorByProportionOnly proportion: #{rationalToFixed3 proportion} parts
CorByProportionIncludingTutorial proportion: #{rationalToFixed3 proportion} parts - tutorials CorByProportionIncludingTutorial proportion: #{rationalToFixed3 proportion} parts - tutorials
CorByProportionExcludingTutorial proportion: #{rationalToFixed3 proportion} parts + tutorials CorByProportionExcludingTutorial proportion: #{rationalToFixed3 proportion} parts + tutorials

6
nix/docker/default.nix
View File

@ -21,7 +21,11 @@ let
contents = with final; [ contents = with final; [
uniworx.uniworx.components.exes.uniworx uniworx.uniworx.components.exes.uniworx
prev.dockerTools.binSh findutils coreutils 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 ]; ] ++ optionals isDemo [ postgresql_12 memcached uniworx.uniworx.components.exes.uniworxdb ];
runAsRoot = '' runAsRoot = ''

1
routes
View File

@ -69,6 +69,7 @@
/info/glossary GlossaryR GET !free /info/glossary GlossaryR GET !free
/info/faq FaqR GET !free /info/faq FaqR GET !free
/version VersionR GET !free /version VersionR GET !free
/status StatusR GET !free
/help HelpR GET POST !free /help HelpR GET POST !free

14
src/Foundation/I18n.hs
View File

@ -195,20 +195,10 @@ mkMessageVariant ''UniWorX ''ButtonMessage "messages/button" "de"
mkMessageVariant ''UniWorX ''FrontendMessage "messages/frontend" "de-de-formal" mkMessageVariant ''UniWorX ''FrontendMessage "messages/frontend" "de-de-formal"
instance RenderMessage UniWorX TermIdentifier where instance RenderMessage UniWorX TermIdentifier where
renderMessage foundation ls TermIdentifier{..} = case season of renderMessage _foundation _ls = termToText -- TODO: respect user selected Datetime Format
Q1 -> renderMessage' $ MsgQuarter1st year
Q2 -> renderMessage' $ MsgQuarter2nd year
Q3 -> renderMessage' $ MsgQuarter3rd year
Q4 -> renderMessage' $ MsgQuarter4th year
where renderMessage' = renderMessage foundation ls
instance RenderMessage UniWorX ShortTermIdentifier where instance RenderMessage UniWorX ShortTermIdentifier where
renderMessage foundation ls (ShortTermIdentifier TermIdentifier{..}) = case season of renderMessage _foundation _ls (ShortTermIdentifier tid) = termToText tid -- TODO: implement shorttermidentifier properly
Q1 -> renderMessage' $ MsgQuarter1stShort year
Q2 -> renderMessage' $ MsgQuarter2ndShort year
Q3 -> renderMessage' $ MsgQuarter3rdShort year
Q4 -> renderMessage' $ MsgQuarter4thShort year
where renderMessage' = renderMessage foundation ls
instance RenderMessage UniWorX String where instance RenderMessage UniWorX String where
renderMessage f ls str = renderMessage f ls $ Text.pack str renderMessage f ls str = renderMessage f ls $ Text.pack str

1
src/Foundation/Navigation.hs
View File

@ -132,6 +132,7 @@ breadcrumb HelpR = i18nCrumb MsgMenuHelp Nothing
breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing
breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing
breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed
breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing
breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail $ Just ProfileR breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail $ Just ProfileR

3
src/Handler/Allocation/Form.hs
View File

@ -159,8 +159,7 @@ suggestAllocationForm (Set.fromList . map optionInternalValue . olOptions -> ter
newTerm <- MaybeT $ get tid newTerm <- MaybeT $ get tid
Entity _ Allocation{..} <- MaybeT . getBy $ TermSchoolAllocationShort oldTid ssh ash Entity _ Allocation{..} <- MaybeT . getBy $ TermSchoolAllocationShort oldTid ssh ash
let dayOffset = (diffDays `on` termLectureStart) newTerm oldTerm let addTime = addLocalDays $ (diffDays `on` termLectureStart) newTerm oldTerm
addTime = addLocalDays dayOffset
return AllocationForm return AllocationForm
{ afTerm = tid { afTerm = tid

2
src/Handler/Course/Edit.hs
View File

@ -435,7 +435,7 @@ getCourseNewR = do
let newTemplate = courseToForm oldTemplate mempty mempty Nothing in let newTemplate = courseToForm oldTemplate mempty mempty Nothing in
return $ Just $ newTemplate return $ Just $ newTemplate
{ cfCourseId = Nothing { 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 , cfRegFrom = Nothing
, cfRegTo = Nothing , cfRegTo = Nothing
, cfDeRegUntil = Nothing , cfDeRegUntil = Nothing

31
src/Handler/Health.hs
View File

@ -11,6 +11,9 @@ import qualified Data.Set as Set
import Control.Concurrent.STM.Delay import Control.Concurrent.STM.Delay
import Language.Haskell.TH (stringE,runIO)
-- import Data.FileEmbed (embedStringFile)
getHealthR :: Handler TypedContent getHealthR :: Handler TypedContent
getHealthR = do getHealthR = do
@ -94,3 +97,31 @@ getInstanceR = do
|] |]
provideJson instanceInfo provideJson instanceInfo
provideRep . return $ tshow 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))

1
src/Handler/Term.hs
View File

@ -26,7 +26,6 @@ validateTerm :: (MonadHandler m, HandlerSite m ~ UniWorX)
=> FormValidator TermForm m () => FormValidator TermForm m ()
validateTerm = do validateTerm = do
TermForm{..} <- State.get TermForm{..} <- State.get
guardValidation MsgTermStartMustMatchName $ tfStart `withinTermYear` tfName
guardValidation MsgTermEndMustBeAfterStart $ tfStart < tfEnd guardValidation MsgTermEndMustBeAfterStart $ tfStart < tfEnd
guardValidation MsgTermLectureEndMustBeAfterStart $ tfLectureStart < tfLectureEnd guardValidation MsgTermLectureEndMustBeAfterStart $ tfLectureStart < tfLectureEnd
guardValidation MsgTermStartMustBeBeforeLectureStart $ tfStart <= tfLectureStart guardValidation MsgTermStartMustBeBeforeLectureStart $ tfStart <= tfLectureStart

9
src/Handler/Utils/DateTime.hs
View File

@ -16,6 +16,7 @@ module Handler.Utils.DateTime
, addOneWeek, addWeeks , addOneWeek, addWeeks
, weeksToAdd , weeksToAdd
, setYear, getYear , setYear, getYear
, firstDayOfWeekOnAfter
, ceilingQuarterHour , ceilingQuarterHour
, formatGregorianW , formatGregorianW
) where ) where
@ -224,6 +225,14 @@ getYear date = y
where where
(y,_,_) = toGregorian date (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 :: UTCTime -> UTCTime
addOneWeek = addWeeks 1 addOneWeek = addWeeks 1

122
src/Model/Types/DateTime.hs
View File

@ -12,11 +12,10 @@ module Model.Types.DateTime
import Import.NoModel import Import.NoModel
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI
import Data.Either.Combinators (maybeToRight) import Data.Either.Combinators (maybeToRight)
import Text.Read (readMaybe)
import Data.Time.Calendar.WeekDate import Data.Time.Calendar.WeekDate
import Data.Time.Format.ISO8601
import Database.Persist.Sql 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 newtype TermIdentifier = TermIdentifier { getTermDay :: Day }
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable) deriving (Show, Read, Eq, Ord, Generic, Typeable, Enum)
deriving anyclass (Binary, Universe, Finite, NFData) deriving newtype (Binary, ISO8601, PersistField, PersistFieldSql)
deriving anyclass (NFData)
numSeasons :: Int -- to be flexible -- ought to be equivalent to deriving stock (Show, Read, Eq, Ord, Generic, Typeable, Enum, Binary, NFData)
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
-- Conversion TermId <-> TermIdentifier:: -- Conversion TermId <-> TermIdentifier::
-- from_TermId_to_TermIdentifier = unTermKey -- from_TermId_to_TermIdentifier = unTermKey
@ -94,40 +61,56 @@ shortened = iso shorten expand
, year < $currentYear + 50 = year `mod` 100 , year < $currentYear + 50 = year `mod` 100
| otherwise = year | otherwise = year
-- Option 1: date in iso8601
termToText :: TermIdentifier -> Text termToText :: TermIdentifier -> Text
termToText TermIdentifier{..} = Text.pack $ show (year ^. shortened) ++ show season termToText = Text.pack . iso8601Show
-- also see Hander.Utils.tidFromText -- also see Hander.Utils.tidFromText
termFromText :: Text -> Either Text TermIdentifier termFromText :: Text -> Either Text TermIdentifier
termFromText t termFromText t = maybeToRight errm $ iso8601ParseM $ Text.unpack 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
where where
(~=) :: Char -> Char -> Bool errm = "Invalid TermIdentifier: “" <> t <> "”"
(~=) = (==) `on` CI.mk
termToRational :: TermIdentifier -> Rational -- Option 2: show as WeekNr-DayOfWeek-Year, e.g. 22Mon2021?
termToRational TermIdentifier{..} = toRational year + seasonOffset termToText' :: TermIdentifier -> Text
termToText' TermIdentifier{..} = Text.pack $ show weeknr ++ wd ++ show year
where 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 :: Rational -> TermIdentifier
termFromRational n = TermIdentifier{..} termFromRational = toEnum . round . (daysPerYear *) . subtract dayOffset
where
year = floor n
remainder = n - fromInteger (floor n) -- properFraction problematic for negative year values
season = toEnum $ floor $ remainder * fromIntegral numSeasons
{- -- For newtype Day, PersistField instance can be derived automatically
instance PersistField TermIdentifier where instance PersistField TermIdentifier where
toPersistValue = PersistRational . termToRational toPersistValue = PersistRational . termToRational
fromPersistValue (PersistRational t) = Right $ termFromRational t fromPersistValue (PersistRational t) = Right $ termFromRational t
fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x
instance PersistFieldSql TermIdentifier where instance PersistFieldSql TermIdentifier where
sqlType _ = SqlNumeric 5 1 sqlType _ = SqlNumeric 9 5 -- total significant digits; significant digits after decimal point
-}
instance ToHttpApiData TermIdentifier where instance ToHttpApiData TermIdentifier where
toUrlPiece = termToText toUrlPiece = termToText
@ -162,27 +145,16 @@ data TermDay
guessDay :: TermIdentifier guessDay :: TermIdentifier
-> TermDay -> TermDay
-> Day -> Day
guessDay TermIdentifier{ year, season = Q1 } TermDayStart = fromGregorian year 1 1 guessDay TermIdentifier{..} TermDayLectureStart = getTermDay
guessDay TermIdentifier{ year, season = Q2 } TermDayStart = fromGregorian year 4 1 guessDay TermIdentifier{..} TermDayLectureEnd = addDays 8 getTermDay -- courses last only a week
guessDay TermIdentifier{ year, season = Q3 } TermDayStart = fromGregorian year 7 1 guessDay tid TermDayStart = fromWeekDate year week 1 -- Monday before lecture time
guessDay TermIdentifier{ year, season = Q4 } TermDayStart = fromGregorian year 10 1 where ( year, week, _) = toWeekDate $ addDays (-7*4*3) $ guessDay tid TermDayLectureStart
guessDay tid TermDayEnd = pred $ guessDay (succ tid) TermDayStart guessDay tid TermDayEnd = fromWeekDate year week 7 -- Sunday after lecture time
guessDay tid TermDayLectureStart = fromWeekDate year weekStart 1 -- first Monday within Quarter where ( year, week, _) = toWeekDate $ addDays (7*3) $ guessDay tid TermDayLectureEnd
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
withinTerm :: Day -> TermIdentifier -> Bool withinTerm :: Day -> TermIdentifier -> Bool
withinTerm d tid = guessDay tid TermDayStart <= d && d <= guessDay tid TermDayEnd 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 data OccurrenceSchedule = ScheduleWeekly
{ scheduleDayOfWeek :: WeekDay { scheduleDayOfWeek :: WeekDay
, scheduleStart :: TimeOfDay , scheduleStart :: TimeOfDay

33
src/Utils/Holidays.hs
View File

@ -10,6 +10,8 @@ module Utils.Holidays
, feiertage , feiertage
, bankHolidays, bankHolidaysArea, bankHolidaysAreaSet , bankHolidays, bankHolidaysArea, bankHolidaysAreaSet
, isBankHoliday, isBankHolidayArea , isBankHoliday, isBankHolidayArea
, isWeekend
, addBusinessDays
) where ) where
import Import.NoModel 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 -- | Returns whether a day is a bank holiday for years >= 1995
-- | Repeated calls are handled efficiently using lazy memoization -- | Repeated calls are handled efficiently using lazy memoization
isBankHolidayArea :: Feiertagsgebiet -> Day -> Bool 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 where
(year, _, _) = toGregorian dd (year, _, _) = toGregorian dd
holidays holidays
| (Just hys) <- Map.lookup land memoHolidays | (Just hys) <- landHoliday
, (Just hds) <- index hys $ fromInteger $ year2index year = hds , (Just hds) <- index hys $ fromInteger $ year2index year = hds
| otherwise = bankHolidaysAreaSet land year | otherwise = bankHolidaysAreaSet land year
@ -137,3 +142,27 @@ index2year y = result
(x,r) = y `divMod` 2 (x,r) = y `divMod` 2
result | r == 0 = memoTip + x result | r == 0 = memoTip + x
| otherwise = memoTip - x - 1 | 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)

836
test/Database/Fill.hs
View File

@ -3,39 +3,40 @@ module Database.Fill
) where ) where
import "uniworx" Import hiding (Option(..), currentYear) 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.ByteString.Lazy as LBS
import qualified Data.Text as Text -- import qualified Data.Text as Text
-- import Data.Text.IO (hPutStrLn) -- import Data.Text.IO (hPutStrLn)
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Map as Map import qualified Data.Map as Map
-- import Data.Time.Calendar.OrdinalDate -- import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.WeekDate -- import Data.Time.Calendar.WeekDate
import Utils.Holidays
import Control.Applicative (ZipList(..)) import Control.Applicative (ZipList(..))
import Handler.Utils.DateTime import Handler.Utils.DateTime
import Handler.Utils.AuthorshipStatement (insertAuthorshipStatement) import Handler.Utils.AuthorshipStatement (insertAuthorshipStatement)
import Control.Monad.Random.Class (weighted) -- import Control.Monad.Random.Class (weighted)
import System.Random.Shuffle (shuffleM) import System.Random.Shuffle (shuffleM)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.Csv as Csv 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.Directory (getModificationTime, doesDirectoryExist)
import System.FilePath.Glob (glob) import System.FilePath.Glob (glob)
{- Needed for File Tests only
import qualified Data.Conduit.Combinators as C
import Paths_uniworx (getDataFileName) import Paths_uniworx (getDataFileName)
testdataFile :: MonadIO m => FilePath -> m FilePath testdataFile :: MonadIO m => FilePath -> m FilePath
@ -47,6 +48,8 @@ insertFile residual fileTitle = do
let fileContent = Just $ C.sourceFile filepath let fileContent = Just $ C.sourceFile filepath
fileModified <- liftIO getCurrentTime fileModified <- liftIO getCurrentTime
sinkFile' File{..} residual >>= insert sinkFile' File{..} residual >>= insert
-}
fillDb :: DB () fillDb :: DB ()
fillDb = do fillDb = do
@ -56,33 +59,21 @@ fillDb = do
insert' :: (PersistRecordBackend r (YesodPersistBackend UniWorX), AtLeastOneUniqueKey r) => r -> YesodDB UniWorX (Key r) insert' :: (PersistRecordBackend r (YesodPersistBackend UniWorX), AtLeastOneUniqueKey r) => r -> YesodDB UniWorX (Key r)
insert' = fmap (either entityKey id) . insertBy insert' = fmap (either entityKey id) . insertBy
(currentYear, currentMonth, _) = toGregorian $ utctDay now addBDays = addBusinessDays Fraport -- holiday area to use
currentTerm currentTerm = TermIdentifier $ utctDay now
| 3 >= currentMonth = TermIdentifier currentYear Q1 -- (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm
| 6 >= currentMonth = TermIdentifier currentYear Q2 nextTerm n = TermIdentifier $ addBDays n $ getTermDay currentTerm
| 9 >= currentMonth = TermIdentifier currentYear Q3
| otherwise = TermIdentifier currentYear Q4
nextTerm = succ currentTerm
prevTerm = pred currentTerm
prevPrevTerm = pred prevTerm
seasonTerm next wSeason = until ((wSeason ==) . season) prog currentTerm termTime :: TermIdentifier -- ^ Term
where prog | next = succ -> TermDay -- ^ Relative to which day?
| otherwise = pred -> Integer -- ^ Business Days Offset from Start/End of Term
-> Maybe WeekDay -- ^ Move to weekday
termTime :: Bool -- ^ Next term?
-> Season
-> Rational
-> Bool -- ^ Relative to end of semester?
-> WeekDay
-> (Day -> UTCTime) -- ^ Add time to day -> (Day -> UTCTime) -- ^ Add time to day
-> UTCTime -> UTCTime
termTime next gSeason weekOffset fromEnd d = ($ utctDay) termTime gTid gTD gOff mbWeekDay = ($ utctDay)
where where
utctDay = fromWeekDate wYear wWeek $ fromEnum d gDay = addBDays gOff $ guessDay gTid gTD
(wYear, wWeek, _) = toWeekDate . addDays (round $ 7 * weekOffset) $ fromGregorian rYear rMonth rDay utctDay = maybe gDay (`firstDayOfWeekOnAfter` gDay) mbWeekDay
gTid = seasonTerm next gSeason
(rYear, rMonth, rDay) = toGregorian $ guessDay gTid $ bool TermDayLectureStart TermDayLectureEnd fromEnd
gkleen <- insert User gkleen <- insert User
{ userIdent = "G.Kleen@campus.lmu.de" { userIdent = "G.Kleen@campus.lmu.de"
@ -354,16 +345,27 @@ fillDb = do
matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int) matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int)
manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel
forM_ [(pred $ pred prevPrevTerm)..(succ $ succ $ succ $ succ nextTerm)] $ \tid -> do let tmin = -8
let term = Term { termName = tid tmax = 29*6
, termStart = guessDay tid TermDayStart trange = [tmin..tmax]
, termEnd = guessDay tid TermDayEnd dmin = guessDay (nextTerm tmin) TermDayStart
, termHolidays = [] 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 , termLectureStart = guessDay tid TermDayLectureStart
, termLectureEnd = guessDay tid TermDayLectureEnd , termLectureEnd = guessDay tid TermDayLectureEnd
} }
void $ repsert (TermKey tid) term repsert tk term
void . 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 ifiAuthorshipStatement <- insertAuthorshipStatement I18n
{ i18nFallback = htmlToStoredMarkup { i18nFallback = htmlToStoredMarkup
@ -583,28 +585,41 @@ fillDb = do
-- Fahrschule F -- 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| , courseDescription = Just $ htmlToStoredMarkup [shamlet|
<p> <p>
Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes. Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.
<section> <section>
<h3>Benötigte Unterlagen <h3>Benötigte Unterlagen
<ul> <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 , courseLinkExternal = Nothing
, courseShorthand = "F" , courseShorthand = "F"
, courseTerm = TermKey currentTerm , courseTerm = tk
, courseSchool = avn , 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 , courseRegisterSecret = Nothing
, courseMaterialFree = True , courseMaterialFree = True
, courseApplicationsRequired = False , courseApplicationsRequired = False
@ -614,17 +629,17 @@ fillDb = do
, courseApplicationsRatingsVisible = False , courseApplicationsRatingsVisible = False
, courseDeregisterNoShow = True , 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!|] , sheetDescription = Just $ htmlToStoredMarkup [shamlet|Bitte einen Scan ihres Sehtest hochladen!|]
, sheetType = NotGraded , sheetType = NotGraded
, sheetGrouping = Arbitrary 3 , sheetGrouping = Arbitrary 3
, sheetMarkingText = Nothing , 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 , sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing False
, sheetHintFrom = Nothing , sheetHintFrom = Nothing
, sheetSolutionFrom = Nothing , sheetSolutionFrom = Nothing
@ -636,60 +651,57 @@ fillDb = do
, sheetAuthorshipStatementExam = Nothing , sheetAuthorshipStatementExam = Nothing
, sheetAuthorshipStatement = 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 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" , 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" _ -> "B777"
, tutorialRoomHidden = False , tutorialRoomHidden = False
, tutorialTime = Occurrences , tutorialTime = Occurrences
{ occurrencesScheduled = Set.empty { occurrencesScheduled = Set.empty
, occurrencesExceptions = Set.fromList , occurrencesExceptions = Set.fromList
[ ExceptOccur [ ExceptOccur
{ exceptDay = utctDay firstTT { exceptDay = firstDay
, exceptStart = TimeOfDay 8 30 0 , exceptStart = TimeOfDay 8 30 0
, exceptEnd = TimeOfDay 16 0 0 , exceptEnd = TimeOfDay 16 0 0
} }
, ExceptOccur , ExceptOccur
{ exceptDay = utctDay secondTT { exceptDay = secondDay
, exceptStart = TimeOfDay 9 0 0 , exceptStart = TimeOfDay 9 0 0
, exceptEnd = TimeOfDay 16 0 0 , exceptEnd = TimeOfDay 16 0 0
} }
] ]
} }
, tutorialRegGroup = Just "schulung" , 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 , tutorialLastChanged = now
, tutorialTutorControlled = True , tutorialTutorControlled = True
} }
void . insert $ Tutor tut1 jost insert_ $ Tutor tut1 jost
void . insert' $ Exam void . insert' $ Exam
{ examCourse = fdf { examCourse = c
, examName = "Theorie" , examName = mkName "Theorieprüfung"
, examGradingRule = Nothing , examGradingRule = Nothing
, examBonusRule = Nothing , examBonusRule = Nothing
, examOccurrenceRule = ExamRoomManual , examOccurrenceRule = ExamRoomManual
, examExamOccurrenceMapping = Nothing , 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 , 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 , examFinished = Nothing
, examPartsFrom = Nothing , examPartsFrom = Nothing
, examClosed = Nothing , examClosed = Nothing
@ -706,452 +718,6 @@ fillDb = do
, examAuthorshipStatement = Nothing , 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 testMsg <- insert SystemMessage
{ systemMessageNewsOnly = False { systemMessageNewsOnly = False
, systemMessageFrom = Just now , systemMessageFrom = Just now
@ -1224,7 +790,7 @@ fillDb = do
, systemMessageLastUnhide = now , systemMessageLastUnhide = now
} }
{-
aSeedFunc <- liftIO $ getRandomBytes 40 aSeedFunc <- liftIO $ getRandomBytes 40
funAlloc <- insert' Allocation funAlloc <- insert' Allocation
{ allocationName = "Funktionale Zentralanmeldung" { allocationName = "Funktionale Zentralanmeldung"
@ -1243,7 +809,7 @@ fillDb = do
, allocationRegisterByStaffFrom = Nothing , allocationRegisterByStaffFrom = Nothing
, allocationRegisterByStaffTo = Nothing , allocationRegisterByStaffTo = Nothing
, allocationRegisterByCourse = Nothing , allocationRegisterByCourse = Nothing
, allocationOverrideDeregister = Just $ termTime True Q1 1 False Monday toMidnight , allocationOverrideDeregister = Nothing
, allocationMatchingSeed = aSeedFunc , allocationMatchingSeed = aSeedFunc
} }
insert_ $ AllocationCourse funAlloc pmo 100 Nothing Nothing insert_ $ AllocationCourse funAlloc pmo 100 Nothing Nothing
@ -1254,209 +820,7 @@ fillDb = do
, (jost, CourseParticipantActive) , (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 numericPriorities <- flip foldMapM manyUsers $ \uid -> do
uRec <- get uid uRec <- get uid

40
test/Model/TypesSpec.hs
View File

@ -46,20 +46,26 @@ import qualified Data.Text.Lazy as LT
import Text.Blaze.Html.Renderer.Text (renderHtml) 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 instance CoArbitrary Day where
arbitrary = genericArbitrary coarbitrary (ModifiedJulianDay d) = coarbitrary d
shrink = genericShrink -}
instance CoArbitrary Season
instance Function Season
instance Arbitrary TermIdentifier where instance Arbitrary TermIdentifier where
arbitrary = do arbitrary = TermIdentifier <$> arbitrary
season <- arbitrary shrink = fmap TermIdentifier . shrink . getTermDay
year <- arbitrary `suchThat` (\y -> abs y >= 100)
return $ TermIdentifier{..}
shrink = filter ((\y -> abs y >= 100) . year) . genericShrink
instance CoArbitrary TermIdentifier instance CoArbitrary TermIdentifier
instance Function TermIdentifier instance Function TermIdentifier
@ -383,8 +389,6 @@ spec = do
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ] [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ]
lawsCheckHspec (Proxy @Load) lawsCheckHspec (Proxy @Load)
[ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, commutativeSemigroupLaws, commutativeMonoidLaws ] [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, commutativeSemigroupLaws, commutativeMonoidLaws ]
lawsCheckHspec (Proxy @Season)
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws ]
lawsCheckHspec (Proxy @TermIdentifier) lawsCheckHspec (Proxy @TermIdentifier)
[ eqLaws, showReadLaws, ordLaws, enumLaws, persistFieldLaws, jsonLaws, httpApiDataLaws, pathPieceLaws ] [ eqLaws, showReadLaws, ordLaws, enumLaws, persistFieldLaws, jsonLaws, httpApiDataLaws, pathPieceLaws ]
lawsCheckHspec (Proxy @StudyFieldType) lawsCheckHspec (Proxy @StudyFieldType)
@ -461,13 +465,13 @@ spec = do
describe "TermIdentifier" $ do describe "TermIdentifier" $ do
it "has compatible encoding/decoding to/from Text" . property $ it "has compatible encoding/decoding to/from Text" . property $
\term -> termFromText (termToText term) == Right term \term -> termFromText (termToText term) == Right term
it "works for some examples" . mapM_ termExample $ it "has compatible encoding/decoding to/from Rational" . property $
[ (TermIdentifier 2017 Q2, "17Q2")
, (TermIdentifier 1995 Q4, "95Q4")
, (TermIdentifier 3068 Q1, "3068Q1")
]
it "has compatbile encoding/decoding to/from Rational" . property $
\term -> termFromRational (termToRational term) == term \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 describe "Pseudonym" $ do
it "has sufficient vocabulary" $ it "has sufficient vocabulary" $
(length pseudonymWordlist ^ 2) `shouldSatisfy` (> (fromIntegral (maxBound :: Pseudonym) - fromIntegral (minBound :: Pseudonym))) (length pseudonymWordlist ^ 2) `shouldSatisfy` (> (fromIntegral (maxBound :: Pseudonym) - fromIntegral (minBound :: Pseudonym)))