diff --git a/db.sh b/db.sh new file mode 100755 index 000000000..28bd04d89 --- /dev/null +++ b/db.sh @@ -0,0 +1,6 @@ +#!/usr/bin/env bash + +set -xe + +stack build --fast --flag uniworx:library-only --flag uniworx:dev +stack exec uniworxdb -- $@ diff --git a/package.yaml b/package.yaml index 10ef926b4..c9fdbb55a 100644 --- a/package.yaml +++ b/package.yaml @@ -155,6 +155,7 @@ default-extensions: - DataKinds - BinaryLiterals - PolyKinds + - PackageImports ghc-options: - -Wall @@ -196,11 +197,19 @@ executables: when: - condition: flag(library-only) buildable: false + uniworxdb: + main: Database.hs + ghc-options: + - -main-is Database + source-dirs: test + dependencies: + - uniworx + other-modules: [] # Test suite tests: yesod: - main: Spec.hs + main: Main.hs source-dirs: test dependencies: - uniworx @@ -231,5 +240,5 @@ flags: default: false pedantic: description: Be very pedantic about warnings and errors - manual: true + manual: false default: true diff --git a/start.sh b/start.sh index 7f0a48c4e..67d80033a 100755 --- a/start.sh +++ b/start.sh @@ -19,4 +19,4 @@ if [[ -d .stack-work-run ]]; then trap move-back EXIT fi -stack exec -- yesod devel +stack exec -- yesod devel $@ diff --git a/db.hs b/test/Database.hs similarity index 85% rename from db.hs rename to test/Database.hs index d28038000..8359210ce 100755 --- a/db.hs +++ b/test/Database.hs @@ -1,40 +1,40 @@ -#!/usr/bin/env stack --- stack runghc --package uniworx - -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} +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 Database.Persist.Sql import Control.Monad.Logger import System.Console.GetOpt import System.Exit (exitWith, ExitCode(..)) import System.IO (hPutStrLn, stderr) -import qualified Data.ByteString as BS +import System.FilePath (()) -import Database.Persist.Sql (toSqlKey) +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 ['m'] ["migrate"] (NoArg DBMigrate) "Perform database migration" - , Option ['f'] ["fill"] (NoArg DBFill) "Fill database with example data" + [ 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" ] @@ -47,16 +47,31 @@ main = do settings <- liftIO getAppDevSettings withPostgresqlConn (pgConnStr $ appDatabaseConf settings) . runSqlConn $ do rawExecute "drop owned by current_user;" [] + DBTruncate -> db $ do + foundation <- getYesod + stopJobCtl foundation + liftIO . destroyAllResources $ appConnPool foundation + truncateDb DBMigrate -> db $ return () DBFill -> db $ fillDb (_, _, errs) -> do forM_ errs $ hPutStrLn stderr - hPutStrLn stderr $ usageInfo "db.hs" argsDescr + 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 $ Just <$> BS.readFile ("testdata/" <> fileTitle) + fileContent <- liftIO . fmap Just . BS.readFile $ "testdata" fileTitle fileModified <- liftIO getCurrentTime insert File{..} @@ -217,12 +232,12 @@ fillDb = do void . insert $ DegreeCourse ffp sdMst sdInf void . insert $ Lecturer jost ffp void . insert $ Lecturer gkleen ffp - sheetkey <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions - insert_ $ SheetEdit gkleen now sheetkey - sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions - insert_ $ SheetEdit gkleen now sheetkey - sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions - insert_ $ SheetEdit gkleen now sheetkey + 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" diff --git a/test/Spec.hs b/test/Main.hs similarity index 100% rename from test/Spec.hs rename to test/Main.hs diff --git a/test/TestImport.hs b/test/TestImport.hs index 35464d9ce..1ef954051 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -6,7 +6,7 @@ module TestImport import Application (makeFoundation, makeLogWare) import ClassyPrelude as X hiding (delete, deleteBy, Handler) import Database.Persist as X hiding (get) -import Database.Persist.Sql (SqlPersistM, runSqlPersistMPool, rawExecute, unSingle, connEscapeName, sqlQQ) +import Database.Persist.Sql (SqlPersistM, runSqlPersistMPool) import Foundation as X import Model as X import Test.Hspec as X @@ -21,6 +21,9 @@ import Test.QuickCheck.Instances as X () import System.IO as X (hPrint, hPutStrLn, stderr) import Jobs (handleJobs, stopJobCtl) +import Database (truncateDb) +import Database as X (fillDb) + import Control.Monad.Trans.Resource (runResourceT, MonadResourceBase) import Data.Pool (destroyAllResources) @@ -63,14 +66,7 @@ withApp = around $ \act -> runResourceT $ do -- 'withApp' calls it before each test, creating a clean environment for each -- spec to run in. wipeDB :: (MonadResourceBase m, MonadMask m) => UniWorX -> m () -wipeDB app = runDBWithApp app $ 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 [] +wipeDB app = runDBWithApp app Database.truncateDb -- | Authenticate as a user. This relies on the `auth-dummy-login: true` flag -- being set in test-settings.yaml, which enables dummy authentication in