From 42089e17a17734b5086f0e2f46f0716be020c7a5 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 3 Mar 2020 09:11:54 +0100 Subject: [PATCH 001/151] chore: better test data --- package.yaml | 5 +- src/Handler/Utils/DateTime.hs | 14 +- test/Database.hs | 749 +------------------------- test/Database/Fill.hs | 976 ++++++++++++++++++++++++++++++++++ 4 files changed, 993 insertions(+), 751 deletions(-) create mode 100644 test/Database/Fill.hs diff --git a/package.yaml b/package.yaml index e5af6ee7f..71c0af7ef 100644 --- a/package.yaml +++ b/package.yaml @@ -227,6 +227,8 @@ library: - -ddump-splices - -ddump-to-file cpp-options: -DDEVELOPMENT + ghc-prof-options: + - -fprof-auto else: ghc-options: - -O2 @@ -249,7 +251,8 @@ executables: source-dirs: test dependencies: - uniworx - other-modules: [] + other-modules: + - Database.Fill when: - condition: flag(library-only) buildable: false diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 64afdc7ef..59bb82141 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -1,6 +1,7 @@ module Handler.Utils.DateTime ( utcToLocalTime, utcToZonedTime , localTimeToUTC, TZ.LocalToUTCResult(..) + , toTimeOfDay , toMidnight, beforeMidnight, toMidday, toMorning , formatDiffDays , formatTime' @@ -44,19 +45,22 @@ localTimeToUTC = TZ.localTimeToUTCFull appTZ -- | Local midnight of given day toMidnight :: Day -> UTCTime -toMidnight d = localTimeToUTCTZ appTZ $ LocalTime d midnight +toMidnight = toTimeOfDay 0 0 0 --- | Local midnight of given day +-- | Local midday of given day toMidday :: Day -> UTCTime -toMidday d = localTimeToUTCTZ appTZ $ LocalTime d midday +toMidday = toTimeOfDay 12 0 0 -- | One second before the end of day beforeMidnight :: Day -> UTCTime -beforeMidnight d = localTimeToUTCTZ appTZ $ LocalTime d $ TimeOfDay 23 59 59 +beforeMidnight = toTimeOfDay 23 59 59 -- | 6am in the morning toMorning :: Day -> UTCTime -toMorning d = localTimeToUTCTZ appTZ $ LocalTime d $ TimeOfDay 6 0 0 +toMorning = toTimeOfDay 6 0 0 + +toTimeOfDay :: Int -> Int -> Pico -> Day -> UTCTime +toTimeOfDay todHour todMin todSec d = localTimeToUTCTZ appTZ $ LocalTime d TimeOfDay{..} class FormatTime t => HasLocalTime t where diff --git a/test/Database.hs b/test/Database.hs index 976bf95b1..8644d0df7 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -1,7 +1,7 @@ module Database ( main - , fillDb , truncateDb + , module Database.Fill ) where import "uniworx" Import hiding (Option(..)) @@ -16,18 +16,17 @@ import System.Console.GetOpt import System.Exit (exitWith, ExitCode(..)) import System.IO (hPutStrLn) -import qualified Data.ByteString as BS - -import qualified Data.Set as Set - import Database.Persist.Sql.Raw.QQ +import Database.Fill (fillDb) + data DBAction = DBClear | DBTruncate | DBMigrate | DBFill + argsDescr :: [OptDescr DBAction] argsDescr = [ Option ['c'] ["clear"] (NoArg DBClear) "Delete everything accessable by the current database user" @@ -66,743 +65,3 @@ truncateDb = do query = "TRUNCATE TABLE " ++ intercalate ", " escapedTables ++ " RESTART IDENTITY" protected = ["applied_migration"] rawExecute query [] - -insertFile :: FilePath -> DB FileId -insertFile fileTitle = do - fileContent <- liftIO . fmap Just . BS.readFile $ "testdata" fileTitle - fileModified <- liftIO getCurrentTime - insert File{..} - -fillDb :: DB () -fillDb = do - AppSettings{ appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod $ view appSettings - now <- liftIO getCurrentTime - let - insert' :: (PersistRecordBackend r (YesodPersistBackend UniWorX), AtLeastOneUniqueKey r) => r -> YesodDB UniWorX (Key r) - insert' = fmap (either entityKey id) . insertBy - summer2017 = TermIdentifier 2017 Summer - winter2017 = TermIdentifier 2017 Winter - summer2018 = TermIdentifier 2018 Summer - gkleen <- insert User - { userIdent = "G.Kleen@campus.lmu.de" - , userAuthentication = AuthLDAP - , userLastAuthentication = Just now - , userTokensIssuedAfter = Just now - , userMatrikelnummer = Nothing - , userEmail = "G.Kleen@campus.lmu.de" - , userDisplayEmail = "gregor.kleen@ifi.lmu.de" - , userDisplayName = "Gregor Kleen" - , userSurname = "Kleen" - , userFirstName = "Gregor Julius Arthur" - , userTitle = Nothing - , userMaxFavourites = 6 - , userMaxFavouriteTerms = 1 - , userTheme = ThemeDefault - , userDateTimeFormat = userDefaultDateTimeFormat - , userDateFormat = userDefaultDateFormat - , userTimeFormat = userDefaultTimeFormat - , userDownloadFiles = userDefaultDownloadFiles - , userWarningDays = userDefaultWarningDays - , userLanguages = Just $ Languages ["en"] - , userNotificationSettings = def - , userCreated = now - , userLastLdapSynchronisation = Nothing - , userCsvOptions = def { csvFormat = csvPreset # CsvPresetRFC } - , userSex = Just SexMale - , userShowSex = userDefaultShowSex - } - fhamann <- insert User - { userIdent = "felix.hamann@campus.lmu.de" - , userAuthentication = AuthLDAP - , userLastAuthentication = Nothing - , userTokensIssuedAfter = Nothing - , userMatrikelnummer = Nothing - , userEmail = "felix.hamann@campus.lmu.de" - , userDisplayEmail = "felix.hamann@campus.lmu.de" - , userDisplayName = "Felix Hamann" - , userSurname = "Hamann" - , userFirstName = "Felix" - , userTitle = Nothing - , userMaxFavourites = userDefaultMaxFavourites - , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms - , userTheme = ThemeDefault - , userDateTimeFormat = userDefaultDateTimeFormat - , userDateFormat = userDefaultDateFormat - , userTimeFormat = userDefaultTimeFormat - , userDownloadFiles = userDefaultDownloadFiles - , userWarningDays = userDefaultWarningDays - , userLanguages = Nothing - , userNotificationSettings = def - , userCreated = now - , userLastLdapSynchronisation = Nothing - , userCsvOptions = def { csvFormat = csvPreset # CsvPresetExcel } - , userSex = Just SexMale - , userShowSex = userDefaultShowSex - } - jost <- insert User - { userIdent = "jost@tcs.ifi.lmu.de" - , userAuthentication = AuthLDAP - , userLastAuthentication = Nothing - , userTokensIssuedAfter = Nothing - , userMatrikelnummer = Nothing - , userEmail = "jost@tcs.ifi.lmu.de" - , userDisplayEmail = "jost@tcs.ifi.lmu.de" - , userDisplayName = "Steffen Jost" - , userSurname = "Jost" - , userFirstName = "Steffen" - , userTitle = Just "Dr." - , userMaxFavourites = 14 - , userMaxFavouriteTerms = 4 - , userTheme = ThemeMossGreen - , userDateTimeFormat = userDefaultDateTimeFormat - , userDateFormat = userDefaultDateFormat - , userTimeFormat = userDefaultTimeFormat - , userDownloadFiles = userDefaultDownloadFiles - , userWarningDays = userDefaultWarningDays - , userLanguages = Nothing - , userNotificationSettings = def - , userCreated = now - , userLastLdapSynchronisation = Nothing - , userSex = Just SexMale - , userCsvOptions = def - , userShowSex = userDefaultShowSex - } - maxMuster <- insert User - { userIdent = "max@campus.lmu.de" - , userAuthentication = AuthLDAP - , userLastAuthentication = Just now - , userTokensIssuedAfter = Nothing - , userMatrikelnummer = Just "1299" - , userEmail = "max@campus.lmu.de" - , userDisplayEmail = "max@max.com" - , userDisplayName = "Max Musterstudent" - , userSurname = "Musterstudent" - , userFirstName = "Max" - , userTitle = Nothing - , userMaxFavourites = 7 - , userTheme = ThemeAberdeenReds - , userDateTimeFormat = userDefaultDateTimeFormat - , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms - , userDateFormat = userDefaultDateFormat - , userTimeFormat = userDefaultTimeFormat - , userDownloadFiles = userDefaultDownloadFiles - , userWarningDays = userDefaultWarningDays - , userLanguages = Just $ Languages ["de"] - , userNotificationSettings = def - , userCreated = now - , userLastLdapSynchronisation = Nothing - , userCsvOptions = def - , userSex = Just SexMale - , userShowSex = userDefaultShowSex - } - tinaTester <- insert $ User - { userIdent = "tester@campus.lmu.de" - , userAuthentication = AuthLDAP - , userLastAuthentication = Nothing - , userTokensIssuedAfter = Nothing - , userMatrikelnummer = Just "999" - , userEmail = "tester@campus.lmu.de" - , userDisplayEmail = "tina@tester.example" - , userDisplayName = "Tina Tester" - , userSurname = "von Terror" - , userFirstName = "Sabrina" - , userTitle = Just "Magister" - , userMaxFavourites = 5 - , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms - , userTheme = ThemeAberdeenReds - , userDateTimeFormat = userDefaultDateTimeFormat - , userDateFormat = userDefaultDateFormat - , userTimeFormat = userDefaultTimeFormat - , userDownloadFiles = userDefaultDownloadFiles - , userWarningDays = userDefaultWarningDays - , userLanguages = Just $ Languages ["sn"] - , userNotificationSettings = def - , userCreated = now - , userLastLdapSynchronisation = Nothing - , userCsvOptions = def - , userSex = Just SexNotApplicable - , userShowSex = userDefaultShowSex - } - svaupel <- insert User - { userIdent = "vaupel.sarah@campus.lmu.de" - , userAuthentication = AuthLDAP - , userLastAuthentication = Nothing - , userTokensIssuedAfter = Nothing - , userMatrikelnummer = Nothing - , userEmail = "vaupel.sarah@campus.lmu.de" - , userDisplayEmail = "vaupel.sarah@campus.lmu.de" - , userDisplayName = "Sarah Vaupel" - , userSurname = "Vaupel" - , userFirstName = "Sarah" - , userTitle = Nothing - , userMaxFavourites = 14 - , userMaxFavouriteTerms = 4 - , userTheme = ThemeMossGreen - , userDateTimeFormat = userDefaultDateTimeFormat - , userDateFormat = userDefaultDateFormat - , userTimeFormat = userDefaultTimeFormat - , userDownloadFiles = userDefaultDownloadFiles - , userWarningDays = userDefaultWarningDays - , userLanguages = Nothing - , userNotificationSettings = def - , userCreated = now - , userLastLdapSynchronisation = Nothing - , userCsvOptions = def - , userSex = Just SexFemale - , userShowSex = userDefaultShowSex - } - void . repsert (TermKey summer2017) $ Term - { termName = summer2017 - , termStart = fromGregorian 2017 04 09 - , termEnd = fromGregorian 2017 07 14 - , termHolidays = [] - , termLectureStart = fromGregorian 2017 04 09 - , termLectureEnd = fromGregorian 2018 07 14 - , termActive = False - } - void . repsert (TermKey winter2017) $ Term - { termName = winter2017 - , termStart = fromGregorian 2017 10 16 - , termEnd = fromGregorian 2018 02 10 - , termHolidays = [fromGregorian 2017 12 24..fromGregorian 2018 01 06] - , termLectureStart = fromGregorian 2017 10 16 - , termLectureEnd = fromGregorian 2018 02 10 - , termActive = True - } - void . repsert (TermKey summer2018) $ Term - { termName = summer2018 - , termStart = fromGregorian 2018 04 09 - , termEnd = fromGregorian 2018 07 14 - , termHolidays = [] - , termLectureStart = fromGregorian 2018 04 09 - , termLectureEnd = fromGregorian 2018 07 14 - , termActive = True - } - ifi <- insert' $ School "Institut für Informatik" "IfI" - mi <- insert' $ School "Institut für Mathematik" "MI" - void . insert' $ UserFunction gkleen ifi SchoolAdmin - void . insert' $ UserFunction gkleen mi SchoolAdmin - void . insert' $ UserFunction fhamann ifi SchoolAdmin - void . insert' $ UserFunction jost ifi SchoolAdmin - void . insert' $ UserFunction jost mi SchoolAdmin - void . insert' $ UserFunction svaupel ifi SchoolAdmin - void . insert' $ UserFunction svaupel mi SchoolAdmin - void . insert' $ UserFunction gkleen ifi SchoolLecturer - void . insert' $ UserFunction fhamann ifi SchoolLecturer - void . insert' $ UserFunction jost ifi SchoolLecturer - void . insert' $ UserFunction svaupel ifi SchoolLecturer - let - sdBsc = StudyDegreeKey' 82 - sdMst = StudyDegreeKey' 88 - sdLAR = StudyDegreeKey' 33 - sdLAG = StudyDegreeKey' 35 - repsert sdBsc $ StudyDegree 82 (Just "BSc") (Just "Bachelor" ) - repsert sdMst $ StudyDegree 88 (Just "MSc") (Just "Master" ) - repsert sdLAR $ StudyDegree 33 (Just "LAR") Nothing -- intentionally left unknown - repsert sdLAG $ StudyDegree 35 Nothing Nothing -- intentionally left unknown - let - sdInf = StudyTermsKey' 79 - sdMath = StudyTermsKey' 105 - sdMedi = StudyTermsKey' 121 - sdPhys = StudyTermsKey' 128 - sdBioI1 = StudyTermsKey' 221 - sdBioI2 = StudyTermsKey' 228 - sdBiol = StudyTermsKey' 26 - sdChem1 = StudyTermsKey' 61 - sdChem2 = StudyTermsKey' 113 - sdBWL = StudyTermsKey' 21 - sdDeut = StudyTermsKey' 103 - repsert sdInf $ StudyTerms 79 (Just "Inf") (Just "Informatikk") Nothing Nothing - repsert sdMath $ StudyTerms 105 (Just "Math" ) (Just "Mathematik") Nothing Nothing - repsert sdMedi $ StudyTerms 121 Nothing (Just "Fehler hier") Nothing Nothing - repsert sdPhys $ StudyTerms 128 Nothing Nothing Nothing Nothing -- intentionally left unknown - repsert sdBioI1 $ StudyTerms 221 Nothing Nothing Nothing Nothing -- intentionally left unknown - repsert sdBioI2 $ StudyTerms 228 Nothing Nothing Nothing Nothing -- intentionally left unknown - repsert sdBiol $ StudyTerms 26 Nothing Nothing Nothing Nothing -- intentionally left unknown - repsert sdChem1 $ StudyTerms 61 Nothing Nothing Nothing Nothing -- intentionally left unknown - repsert sdChem2 $ StudyTerms 113 Nothing Nothing Nothing Nothing -- intentionally left unknown - repsert sdBWL $ StudyTerms 21 Nothing Nothing Nothing Nothing -- intentionally left unknown - repsert sdDeut $ StudyTerms 103 Nothing Nothing Nothing Nothing -- intentionally left unknown - incidence1 <- liftIO getRandom - void . insert $ StudyTermNameCandidate incidence1 221 "Bioinformatik" - void . insert $ StudyTermNameCandidate incidence1 221 "Mathematik" - void . insert $ StudyTermNameCandidate incidence1 105 "Bioinformatik" - void . insert $ StudyTermNameCandidate incidence1 105 "Mathematik" - incidence2 <- liftIO getRandom - void . insert $ StudyTermNameCandidate incidence2 221 "Bioinformatik" - void . insert $ StudyTermNameCandidate incidence2 221 "Chemie" - void . insert $ StudyTermNameCandidate incidence2 61 "Bioinformatik" - void . insert $ StudyTermNameCandidate incidence2 61 "Chemie" - incidence3 <- liftIO getRandom - void . insert $ StudyTermNameCandidate incidence3 113 "Chemie" - incidence4 <- liftIO getRandom -- ambiguous incidence - void . insert $ StudyTermNameCandidate incidence4 221 "Bioinformatik" - void . insert $ StudyTermNameCandidate incidence4 221 "Chemie" - void . insert $ StudyTermNameCandidate incidence4 221 "Biologie" - void . insert $ StudyTermNameCandidate incidence4 61 "Bioinformatik" - void . insert $ StudyTermNameCandidate incidence4 61 "Chemie" - void . insert $ StudyTermNameCandidate incidence4 61 "Biologie" - void . insert $ StudyTermNameCandidate incidence4 61 "Chemie" - void . insert $ StudyTermNameCandidate incidence4 26 "Bioinformatik" - void . insert $ StudyTermNameCandidate incidence4 26 "Chemie" - void . insert $ StudyTermNameCandidate incidence4 26 "Biologie" - incidence5 <- liftIO getRandom - void . insert $ StudyTermNameCandidate incidence5 228 "Bioinformatik" - void . insert $ StudyTermNameCandidate incidence5 228 "Physik" - void . insert $ StudyTermNameCandidate incidence5 128 "Bioinformatik" - void . insert $ StudyTermNameCandidate incidence5 128 "Physik" - incidence6 <- liftIO getRandom - void . insert $ StudyTermNameCandidate incidence6 228 "Bioinformatik" - void . insert $ StudyTermNameCandidate incidence6 228 "Physik" - void . insert $ StudyTermNameCandidate incidence6 128 "Bioinformatik" - void . insert $ StudyTermNameCandidate incidence6 128 "Physik" - incidence7 <- liftIO getRandom - void . insert $ StudyTermNameCandidate incidence7 228 "Physik" - void . insert $ StudyTermNameCandidate incidence7 228 "Bioinformatik" - void . insert $ StudyTermNameCandidate incidence7 128 "Physik" - void . insert $ StudyTermNameCandidate incidence7 128 "Bioinformatik" - incidence8 <- liftIO getRandom - void . insert $ StudyTermNameCandidate incidence8 128 "Physik" - void . insert $ StudyTermNameCandidate incidence8 128 "Medieninformatik" - void . insert $ StudyTermNameCandidate incidence8 121 "Physik" - void . insert $ StudyTermNameCandidate incidence8 121 "Medieninformatik" - incidence9 <- liftIO getRandom - void . insert $ StudyTermNameCandidate incidence9 79 "Informatik" - incidence10 <- liftIO getRandom - void . insert $ StudyTermNameCandidate incidence10 103 "Deutsch" - void . insert $ StudyTermNameCandidate incidence10 103 "Betriebswirtschaftslehre" - void . insert $ StudyTermNameCandidate incidence10 21 "Deutsch" - void . insert $ StudyTermNameCandidate incidence10 21 "Betriebswirtschaftslehre" - incidence11 <- liftIO getRandom - void . insert $ StudyTermNameCandidate incidence11 221 "Bioinformatik" - void . insert $ StudyTermNameCandidate incidence11 221 "Chemie" - void . insert $ StudyTermNameCandidate incidence11 221 "Biologie" - void . insert $ StudyTermNameCandidate incidence11 61 "Bioinformatik" - void . insert $ StudyTermNameCandidate incidence11 61 "Chemie" - void . insert $ StudyTermNameCandidate incidence11 61 "Biologie" - void . insert $ StudyTermNameCandidate incidence11 26 "Bioinformatik" - void . insert $ StudyTermNameCandidate incidence11 26 "Chemie" - void . insert $ StudyTermNameCandidate incidence11 26 "Biologie" - incidence12 <- liftIO getRandom - void . insert $ StudyTermNameCandidate incidence12 103 "Deutsch" - void . insert $ StudyTermNameCandidate incidence12 103 "Betriebswirtschaftslehre" - void . insert $ StudyTermNameCandidate incidence12 21 "Deutsch" - void . insert $ StudyTermNameCandidate incidence12 21 "Betriebswirtschaftslehre" - - sfMMp <- insert $ StudyFeatures -- keyword type prevents record syntax here - maxMuster - sdBsc - sdInf - Nothing - FieldPrimary - 2 - now - True - sfMMs <- insert $ StudyFeatures - maxMuster - sdBsc - sdMath - Nothing - FieldSecondary - 2 - now - True - _sfTTa <- insert $ StudyFeatures - tinaTester - sdBsc - sdInf - Nothing - FieldPrimary - 4 - now - False - sfTTb <- insert $ StudyFeatures - tinaTester - sdLAG - sdPhys - Nothing - FieldPrimary - 1 - now - True - sfTTc <- insert $ StudyFeatures - tinaTester - sdLAR - sdMedi - Nothing - FieldPrimary - 7 - now - True - _sfTTd <- insert $ StudyFeatures - tinaTester - sdMst - sdMath - Nothing - FieldPrimary - 3 - now - True - - -- FFP - let nbrs :: [Int] - nbrs = [1,2,3,27,7,1] - ffp <- insert' Course - { courseName = "Fortgeschrittene Funktionale Programmierung" - , courseDescription = Just [shamlet| -

It is fun! -

Come to where the functional is! -

-

Functional programming can be done in Haskell! -

This is not a joke, this is serious! -

-

Consider some numbers -