Refactor db.hs

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 -- $@

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

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 $@

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"

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