module Database ( main , fillDb , truncateDb ) where import "uniworx" Import hiding (Option(..)) import "uniworx" Application (db, getAppDevSettings) import "uniworx" Jobs (stopJobCtl) import Data.Pool (destroyAllResources) import Database.Persist.Postgresql import Control.Monad.Logger import Control.Monad.Trans.Resource import System.Console.GetOpt import System.Exit (exitWith, ExitCode(..)) import System.IO (hPutStrLn, stderr) import System.FilePath (()) import qualified Data.ByteString as BS import Data.Time data DBAction = DBClear | DBTruncate | DBMigrate | DBFill argsDescr :: [OptDescr DBAction] argsDescr = [ Option ['c'] ["clear"] (NoArg DBClear) "Delete everything accessable by the current database user" , Option ['t'] ["truncate"] (NoArg DBTruncate) "Truncate all tables mentioned in the current schema (This cannot be run concurrently with any other activity accessing the database)" , Option ['m'] ["migrate"] (NoArg DBMigrate) "Perform database migration" , Option ['f'] ["fill"] (NoArg DBFill) "Fill database with example data" ] main :: IO () main = do args <- map unpack <$> getArgs case getOpt Permute argsDescr args of (acts@(_:_), [], []) -> forM_ acts $ \case DBClear -> runStderrLoggingT $ do -- We don't use `db` here, since we do /not/ want any migrations to run, yet settings <- liftIO getAppDevSettings withPostgresqlConn (pgConnStr $ appDatabaseConf settings) . runSqlConn $ do rawExecute "drop owned by current_user;" [] DBTruncate -> db $ do foundation <- getYesod stopJobCtl foundation release . fst $ appLogger foundation liftIO . destroyAllResources $ appConnPool foundation truncateDb DBMigrate -> db $ return () DBFill -> db $ fillDb (_, _, errs) -> do forM_ errs $ hPutStrLn stderr hPutStrLn stderr $ usageInfo "uniworxdb" argsDescr exitWith $ ExitFailure 2 truncateDb :: MonadIO m => ReaderT SqlBackend m () truncateDb = do tables <- map unSingle <$> [sqlQQ|SELECT table_name FROM information_schema.tables WHERE table_schema = 'public'|] sqlBackend <- ask let escapedTables = map (connEscapeName sqlBackend . DBName) $ filter (not . (`elem` protected)) tables 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 appSettings now <- liftIO getCurrentTime let insert' :: PersistRecordBackend r (YesodPersistBackend UniWorX) => 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 , userMatrikelnummer = Nothing , userEmail = "G.Kleen@campus.lmu.de" , userDisplayName = "Gregor Kleen" , userSurname = "Kleen" , userMaxFavourites = 6 , userTheme = ThemeDefault , userDateTimeFormat = userDefaultDateTimeFormat , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles , userMailLanguages = MailLanguages ["en"] , userNotificationSettings = def } fhamann <- insert User { userIdent = "felix.hamann@campus.lmu.de" , userAuthentication = AuthLDAP , userMatrikelnummer = Nothing , userEmail = "felix.hamann@campus.lmu.de" , userDisplayName = "Felix Hamann" , userSurname = "Hamann" , userMaxFavourites = userDefaultMaxFavourites , userTheme = ThemeDefault , userDateTimeFormat = userDefaultDateTimeFormat , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles , userMailLanguages = MailLanguages ["de"] , userNotificationSettings = def } jost <- insert User { userIdent = "jost@tcs.ifi.lmu.de" , userAuthentication = AuthLDAP , userMatrikelnummer = Nothing , userEmail = "jost@tcs.ifi.lmu.de" , userDisplayName = "Steffen Jost" , userSurname = "Jost" , userMaxFavourites = 14 , userTheme = ThemeMossGreen , userDateTimeFormat = userDefaultDateTimeFormat , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles , userMailLanguages = MailLanguages ["de"] , userNotificationSettings = def } maxMuster <- insert User { userIdent = "max@campus.lmu.de" , userAuthentication = AuthLDAP , userMatrikelnummer = Nothing , userEmail = "max@campus.lmu.de" , userDisplayName = "Max Musterstudent" , userSurname = "Musterstudent" , userMaxFavourites = 7 , userTheme = ThemeAberdeenReds , userDateTimeFormat = userDefaultDateTimeFormat , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles , userMailLanguages = MailLanguages ["de"] , userNotificationSettings = def } void . insert $ User { userIdent = "tester@campus.lmu.de" , userAuthentication = AuthLDAP , userMatrikelnummer = Just "999" , userEmail = "tester@campus.lmu.de" , userDisplayName = "Tina Tester" , userSurname = "von Terror" , userMaxFavourites = 5 , userTheme = ThemeAberdeenReds , userDateTimeFormat = userDefaultDateTimeFormat , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles , userMailLanguages = MailLanguages ["de"] , userNotificationSettings = def } 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' $ UserAdmin gkleen ifi void . insert' $ UserAdmin gkleen mi void . insert' $ UserAdmin fhamann ifi void . insert' $ UserAdmin jost ifi void . insert' $ UserAdmin jost mi void . insert' $ UserLecturer gkleen ifi void . insert' $ UserLecturer fhamann ifi void . insert' $ UserLecturer jost ifi let sdBsc = StudyDegreeKey' 82 sdMst = StudyDegreeKey' 88 repsert sdBsc $ StudyDegree 82 (Just "BSc") (Just "Bachelor" ) repsert sdMst $ StudyDegree 88 (Just "MSc") (Just "Master" ) let sdInf = StudyTermsKey' 79 sdMath = StudyTermsKey' 105 repsert sdInf $ StudyTerms 79 (Just "IfI") (Just "Institut für Informatik") repsert sdMath $ StudyTerms 105 (Just "MI" ) (Just "Mathematisches Institut") -- FFP ffp <- insert' Course { courseName = "Fortgeschrittene Funktionale Programmierung" , courseDescription = Nothing , courseLinkExternal = Nothing , courseShorthand = "FFP" , courseTerm = TermKey summer2018 , courseSchool = ifi , courseCapacity = Just 20 , courseRegisterFrom = Just now , courseRegisterTo = Just (nominalDay `addUTCTime` now ) , courseDeregisterUntil = Nothing , courseRegisterSecret = Nothing , courseMaterialFree = True } insert_ $ CourseEdit jost now ffp void . insert $ DegreeCourse ffp sdBsc sdInf void . insert $ DegreeCourse ffp sdMst sdInf void . insert $ Lecturer jost ffp void . insert $ Lecturer gkleen ffp adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions insert_ $ SheetEdit gkleen now adhoc feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions insert_ $ SheetEdit gkleen now feste keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions insert_ $ SheetEdit gkleen now keine -- EIP eip <- insert' Course { courseName = "Einführung in die Programmierung" , courseDescription = Nothing , courseLinkExternal = Nothing , courseShorthand = "EIP" , courseTerm = TermKey summer2017 , courseSchool = ifi , courseCapacity = Just 20 , courseRegisterFrom = Nothing , courseRegisterTo = Nothing , courseDeregisterUntil = Nothing , courseRegisterSecret = Nothing , courseMaterialFree = True } insert_ $ CourseEdit fhamann now eip void . insert' $ DegreeCourse eip sdBsc sdInf void . insert' $ Lecturer fhamann eip -- interaction design ixd <- insert' Course { courseName = "Interaction Design (User Experience Design I & II)" , courseDescription = Nothing , courseLinkExternal = Nothing , courseShorthand = "IXD" , courseTerm = TermKey summer2018 , courseSchool = ifi , courseCapacity = Just 20 , courseRegisterFrom = Just now , courseRegisterTo = Just (nominalDay `addUTCTime` now ) , courseDeregisterUntil = Nothing , courseRegisterSecret = Nothing , courseMaterialFree = True } insert_ $ CourseEdit fhamann now ixd void . insert' $ DegreeCourse ixd sdBsc sdInf void . insert' $ Lecturer fhamann ixd -- concept development ux3 <- insert' Course { courseName = "Concept Development (User Experience Design III)" , courseDescription = Nothing , courseLinkExternal = Nothing , courseShorthand = "UX3" , courseTerm = TermKey winter2017 , courseSchool = ifi , courseCapacity = Just 30 , courseRegisterFrom = Nothing , courseRegisterTo = Nothing , courseDeregisterUntil = Nothing , courseRegisterSecret = Nothing , courseMaterialFree = True } insert_ $ CourseEdit fhamann now ux3 void . insert' $ DegreeCourse ux3 sdBsc sdInf void . insert' $ Lecturer fhamann ux3 -- promo pmo <- insert' Course { courseName = "Programmierung und Modellierung" , courseDescription = Nothing , courseLinkExternal = Nothing , courseShorthand = "ProMo" , courseTerm = TermKey summer2018 , courseSchool = ifi , courseCapacity = Just 50 , courseRegisterFrom = Just now , courseRegisterTo = Nothing , courseDeregisterUntil = Nothing , courseRegisterSecret = Nothing , courseMaterialFree = True } insert_ $ CourseEdit jost now pmo void . insert $ DegreeCourse pmo sdBsc sdInf void . insert $ Lecturer jost pmo sh1 <- insert Sheet { sheetCourse = pmo , sheetName = "Blatt 1" , sheetDescription = Nothing , sheetType = Normal $ Points 6 , sheetGrouping = Arbitrary 3 , sheetMarkingText = Nothing , sheetVisibleFrom = Just now , sheetActiveFrom = now , sheetActiveTo = (14 * nominalDay) `addUTCTime` now , sheetSubmissionMode = CorrectorSubmissions , sheetUploadMode = Upload True , sheetHintFrom = Nothing , sheetSolutionFrom = Nothing } void . insert $ SheetEdit jost now sh1 void . insert $ SheetCorrector jost sh1 (Load (Just True) 0) CorrectorNormal void . insert $ SheetCorrector gkleen sh1 (Load (Just True) 1) CorrectorNormal h102 <- insertFile "H10-2.hs" h103 <- insertFile "H10-3.hs" pdf10 <- insertFile "ProMo_Uebung10.pdf" void . insert $ SheetFile sh1 h102 SheetHint void . insert $ SheetFile sh1 h103 SheetSolution void . insert $ SheetFile sh1 pdf10 SheetExercise -- sub1 <- insert $ Submission sh1 Nothing Nothing Nothing Nothing Nothing void . insert $ SubmissionEdit maxMuster (nominalDay `addUTCTime` now) sub1 void . insert $ SubmissionUser maxMuster sub1 sub1fid1 <- insertFile "AbgabeH10-1.hs" void . insert $ SubmissionFile sub1 sub1fid1 False False -- datenbanksysteme dbs <- insert' Course { courseName = "Datenbanksysteme" , courseDescription = Nothing , courseLinkExternal = Nothing , courseShorthand = "DBS" , courseTerm = TermKey summer2018 , courseSchool = ifi , courseCapacity = Just 50 , courseRegisterFrom = Nothing , courseRegisterTo = Nothing , courseDeregisterUntil = Nothing , courseRegisterSecret = Nothing , courseMaterialFree = True } insert_ $ CourseEdit gkleen now dbs void . insert' $ DegreeCourse dbs sdBsc sdInf void . insert' $ DegreeCourse dbs sdBsc sdMath void . insert' $ Lecturer gkleen dbs void . insert' $ Lecturer jost dbs