Experimental: don't try to marshal if we don't care
Also explicitly test migration during deployment
This commit is contained in:
parent
3bfae5d3c6
commit
66dbad9b72
11
db.hs
11
db.hs
@ -24,12 +24,14 @@ import Data.Time
|
|||||||
|
|
||||||
|
|
||||||
data DBAction = DBClear
|
data DBAction = DBClear
|
||||||
|
| DBMigrate
|
||||||
| DBFill
|
| DBFill
|
||||||
|
|
||||||
argsDescr :: [OptDescr DBAction]
|
argsDescr :: [OptDescr DBAction]
|
||||||
argsDescr =
|
argsDescr =
|
||||||
[ Option ['c'] ["clear"] (NoArg DBClear) "Delete everything accessable by the current database user"
|
[ Option ['c'] ["clear"] (NoArg DBClear) "Delete everything accessable by the current database user"
|
||||||
, Option ['f'] ["fill"] (NoArg DBFill) "Fill database with example data"
|
, Option ['m'] ["migrate"] (NoArg DBMigrate) "Perform database migration"
|
||||||
|
, Option ['f'] ["fill"] (NoArg DBFill) "Fill database with example data"
|
||||||
]
|
]
|
||||||
|
|
||||||
|
|
||||||
@ -38,11 +40,12 @@ main = do
|
|||||||
args <- map unpack <$> getArgs
|
args <- map unpack <$> getArgs
|
||||||
case getOpt Permute argsDescr args of
|
case getOpt Permute argsDescr args of
|
||||||
(acts@(_:_), [], []) -> forM_ acts $ \case
|
(acts@(_:_), [], []) -> forM_ acts $ \case
|
||||||
DBClear -> runStderrLoggingT $ do -- We don't use `db` here, since we do /not/ want any migrations to run, yet
|
DBClear -> runStderrLoggingT $ do -- We don't use `db` here, since we do /not/ want any migrations to run, yet
|
||||||
settings <- liftIO getAppDevSettings
|
settings <- liftIO getAppDevSettings
|
||||||
withPostgresqlConn (pgConnStr $ appDatabaseConf settings) . runSqlConn $ do
|
withPostgresqlConn (pgConnStr $ appDatabaseConf settings) . runSqlConn $ do
|
||||||
rawExecute "drop owned by current_user;" []
|
rawExecute "drop owned by current_user;" []
|
||||||
DBFill -> db $ fillDb
|
DBMigrate -> db $ return ()
|
||||||
|
DBFill -> db $ fillDb
|
||||||
(_, _, errs) -> do
|
(_, _, errs) -> do
|
||||||
forM_ errs $ hPutStrLn stderr
|
forM_ errs $ hPutStrLn stderr
|
||||||
hPutStrLn stderr $ usageInfo "db.hs" argsDescr
|
hPutStrLn stderr $ usageInfo "db.hs" argsDescr
|
||||||
|
|||||||
@ -158,6 +158,6 @@ customMigrations = Map.fromListWith (>>)
|
|||||||
tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
|
tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
|
||||||
tableExists table = do
|
tableExists table = do
|
||||||
haveSchoolTable <- [sqlQQ| SELECT to_regclass(#{table}); |]
|
haveSchoolTable <- [sqlQQ| SELECT to_regclass(#{table}); |]
|
||||||
case haveSchoolTable :: [Maybe (Single Text)] of
|
case haveSchoolTable :: [Maybe (Single PersistValue)] of
|
||||||
[Just _] -> return True
|
[Just _] -> return True
|
||||||
_other -> return False
|
_other -> return False
|
||||||
|
|||||||
Reference in New Issue
Block a user