{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Moo.CommandHandlers where
import Data.String.Conversions (cs, (<>))
import Moo.Core
import Moo.CommandUtils
import Control.Monad ( when, forM_ )
import Data.Maybe ( isJust )
import Control.Monad.Reader ( asks )
import System.Exit ( exitWith, ExitCode(..), exitSuccess )
import qualified Data.Time.Clock as Clock
import Control.Monad.Trans ( liftIO )
import Database.Schema.Migrations.Store hiding (getMigrations)
import Database.Schema.Migrations
import Database.Schema.Migrations.Migration
import Database.Schema.Migrations.Backend
newCommand :: CommandHandler
newCommand :: CommandHandler
newCommand StoreData
storeData = do
[Text]
required <- (AppState -> [Text]) -> ReaderT AppState IO [Text]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppState -> [Text]
_appRequiredArgs
MigrationStore
store <- (AppState -> MigrationStore) -> ReaderT AppState IO MigrationStore
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppState -> MigrationStore
_appStore
Bool
linear <- (AppState -> Bool) -> ReaderT AppState IO Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppState -> Bool
_appLinearMigrations
Bool
timestamp <- (AppState -> Bool) -> ReaderT AppState IO Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppState -> Bool
_appTimestampFilenames
Text
timeString <- (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
"_") (Text -> Text)
-> ReaderT AppState IO Text -> ReaderT AppState IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Text -> ReaderT AppState IO Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Text
getCurrentTimestamp
let [Text
migrationId] = if Bool
timestamp
then (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
timeStringText -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
required
else [Text]
required
Bool
noAsk <- CommandOptions -> Bool
_noAsk (CommandOptions -> Bool)
-> ReaderT AppState IO CommandOptions -> ReaderT AppState IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AppState -> CommandOptions) -> ReaderT AppState IO CommandOptions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppState -> CommandOptions
_appOptions
IO () -> AppT ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AppT ()) -> IO () -> AppT ()
forall a b. (a -> b) -> a -> b
$ do
FilePath
fullPath <- MigrationStore -> Text -> IO FilePath
fullMigrationName MigrationStore
store Text
migrationId
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Migration -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Migration -> Bool) -> Maybe Migration -> Bool
forall a b. (a -> b) -> a -> b
$ StoreData -> Text -> Maybe Migration
storeLookup StoreData
storeData Text
migrationId) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
do
FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Migration " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
fullPath) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" already exists"
ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
[Text]
deps <- if Bool
linear then ([Text] -> IO [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> IO [Text]) -> [Text] -> IO [Text]
forall a b. (a -> b) -> a -> b
$ StoreData -> [Text]
leafMigrations StoreData
storeData) else
if Bool
noAsk then ([Text] -> IO [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return []) else
do
FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> (Text -> FilePath) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Selecting dependencies for new \
\migration: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
migrationId
StoreData -> IO [Text]
interactiveAskDeps StoreData
storeData
Bool
result <- if Bool
noAsk then (Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) else
(Text -> [Text] -> IO Bool
confirmCreation Text
migrationId [Text]
deps)
case Bool
result of
Bool
True -> do
UTCTime
now <- IO UTCTime
Clock.getCurrentTime
Either FilePath Migration
status <- MigrationStore -> Migration -> IO (Either FilePath Migration)
createNewMigration MigrationStore
store (Migration -> IO (Either FilePath Migration))
-> Migration -> IO (Either FilePath Migration)
forall a b. (a -> b) -> a -> b
$ (Text -> Migration
newMigration Text
migrationId) { mDeps :: [Text]
mDeps = [Text]
deps
, mTimestamp :: Maybe UTCTime
mTimestamp = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
now
}
case Either FilePath Migration
status of
Left FilePath
e -> FilePath -> IO ()
putStrLn FilePath
e IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1))
Right Migration
_ -> FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Migration created successfully: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
fullPath
Bool
False -> do
FilePath -> IO ()
putStrLn FilePath
"Migration creation cancelled."
upgradeCommand :: CommandHandler
upgradeCommand :: CommandHandler
upgradeCommand StoreData
storeData = do
Bool
isTesting <- CommandOptions -> Bool
_test (CommandOptions -> Bool)
-> ReaderT AppState IO CommandOptions -> ReaderT AppState IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AppState -> CommandOptions) -> ReaderT AppState IO CommandOptions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppState -> CommandOptions
_appOptions
(Backend -> IO ()) -> AppT ()
forall a. (Backend -> IO a) -> AppT a
withBackend ((Backend -> IO ()) -> AppT ()) -> (Backend -> IO ()) -> AppT ()
forall a b. (a -> b) -> a -> b
$ \Backend
backend -> do
Backend -> IO ()
ensureBootstrappedBackend Backend
backend IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Backend -> IO ()
commitBackend Backend
backend
[Text]
migrationNames <- Backend -> StoreData -> IO [Text]
missingMigrations Backend
backend StoreData
storeData
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
migrationNames) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
FilePath -> IO ()
putStrLn FilePath
"Database is up to date."
IO ()
forall a. IO a
exitSuccess
[Text] -> (Text -> IO [Migration]) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
migrationNames ((Text -> IO [Migration]) -> IO ())
-> (Text -> IO [Migration]) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Text
migrationName -> do
Migration
m <- StoreData -> Text -> IO Migration
lookupMigration StoreData
storeData Text
migrationName
Migration -> StoreData -> Backend -> Bool -> IO [Migration]
apply Migration
m StoreData
storeData Backend
backend Bool
False
case Bool
isTesting of
Bool
True -> do
Backend -> IO ()
rollbackBackend Backend
backend
FilePath -> IO ()
putStrLn FilePath
"Upgrade test successful."
Bool
False -> do
Backend -> IO ()
commitBackend Backend
backend
FilePath -> IO ()
putStrLn FilePath
"Database successfully upgraded."
upgradeListCommand :: CommandHandler
upgradeListCommand :: CommandHandler
upgradeListCommand StoreData
storeData = do
(Backend -> IO ()) -> AppT ()
forall a. (Backend -> IO a) -> AppT a
withBackend ((Backend -> IO ()) -> AppT ()) -> (Backend -> IO ()) -> AppT ()
forall a b. (a -> b) -> a -> b
$ \Backend
backend -> do
Backend -> IO ()
ensureBootstrappedBackend Backend
backend IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Backend -> IO ()
commitBackend Backend
backend
[Text]
migrationNames <- Backend -> StoreData -> IO [Text]
missingMigrations Backend
backend StoreData
storeData
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
migrationNames) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
FilePath -> IO ()
putStrLn FilePath
"Database is up to date."
IO ()
forall a. IO a
exitSuccess
FilePath -> IO ()
putStrLn FilePath
"Migrations to install:"
[Text] -> (Text -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
migrationNames (FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> (Text -> FilePath) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> FilePath) -> (Text -> Text) -> Text -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>))
reinstallCommand :: CommandHandler
reinstallCommand :: CommandHandler
reinstallCommand StoreData
storeData = do
Bool
isTesting <- CommandOptions -> Bool
_test (CommandOptions -> Bool)
-> ReaderT AppState IO CommandOptions -> ReaderT AppState IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AppState -> CommandOptions) -> ReaderT AppState IO CommandOptions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppState -> CommandOptions
_appOptions
[Text]
required <- (AppState -> [Text]) -> ReaderT AppState IO [Text]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppState -> [Text]
_appRequiredArgs
let [Text
migrationId] = [Text]
required
(Backend -> IO ()) -> AppT ()
forall a. (Backend -> IO a) -> AppT a
withBackend ((Backend -> IO ()) -> AppT ()) -> (Backend -> IO ()) -> AppT ()
forall a b. (a -> b) -> a -> b
$ \Backend
backend -> do
Backend -> IO ()
ensureBootstrappedBackend Backend
backend IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Backend -> IO ()
commitBackend Backend
backend
Migration
m <- StoreData -> Text -> IO Migration
lookupMigration StoreData
storeData Text
migrationId
[Migration]
_ <- Migration -> StoreData -> Backend -> IO [Migration]
revert Migration
m StoreData
storeData Backend
backend
[Migration]
_ <- Migration -> StoreData -> Backend -> Bool -> IO [Migration]
apply Migration
m StoreData
storeData Backend
backend Bool
True
case Bool
isTesting of
Bool
False -> do
Backend -> IO ()
commitBackend Backend
backend
FilePath -> IO ()
putStrLn FilePath
"Migration successfully reinstalled."
Bool
True -> do
Backend -> IO ()
rollbackBackend Backend
backend
FilePath -> IO ()
putStrLn FilePath
"Reinstall test successful."
listCommand :: CommandHandler
listCommand :: CommandHandler
listCommand StoreData
_ = do
(Backend -> IO ()) -> AppT ()
forall a. (Backend -> IO a) -> AppT a
withBackend ((Backend -> IO ()) -> AppT ()) -> (Backend -> IO ()) -> AppT ()
forall a b. (a -> b) -> a -> b
$ \Backend
backend -> do
Backend -> IO ()
ensureBootstrappedBackend Backend
backend IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Backend -> IO ()
commitBackend Backend
backend
[Text]
ms <- Backend -> IO [Text]
getMigrations Backend
backend
[Text] -> (Text -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
ms ((Text -> IO ()) -> IO ()) -> (Text -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Text
m ->
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text
m Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
rootMigrationName) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> (Text -> FilePath) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
m
applyCommand :: CommandHandler
applyCommand :: CommandHandler
applyCommand StoreData
storeData = do
Bool
isTesting <- CommandOptions -> Bool
_test (CommandOptions -> Bool)
-> ReaderT AppState IO CommandOptions -> ReaderT AppState IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AppState -> CommandOptions) -> ReaderT AppState IO CommandOptions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppState -> CommandOptions
_appOptions
[Text]
required <- (AppState -> [Text]) -> ReaderT AppState IO [Text]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppState -> [Text]
_appRequiredArgs
let [Text
migrationId] = [Text]
required
(Backend -> IO ()) -> AppT ()
forall a. (Backend -> IO a) -> AppT a
withBackend ((Backend -> IO ()) -> AppT ()) -> (Backend -> IO ()) -> AppT ()
forall a b. (a -> b) -> a -> b
$ \Backend
backend -> do
Backend -> IO ()
ensureBootstrappedBackend Backend
backend IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Backend -> IO ()
commitBackend Backend
backend
Migration
m <- StoreData -> Text -> IO Migration
lookupMigration StoreData
storeData Text
migrationId
[Migration]
_ <- Migration -> StoreData -> Backend -> Bool -> IO [Migration]
apply Migration
m StoreData
storeData Backend
backend Bool
True
case Bool
isTesting of
Bool
False -> do
Backend -> IO ()
commitBackend Backend
backend
FilePath -> IO ()
putStrLn FilePath
"Successfully applied migrations."
Bool
True -> do
Backend -> IO ()
rollbackBackend Backend
backend
FilePath -> IO ()
putStrLn FilePath
"Migration installation test successful."
revertCommand :: CommandHandler
revertCommand :: CommandHandler
revertCommand StoreData
storeData = do
Bool
isTesting <- CommandOptions -> Bool
_test (CommandOptions -> Bool)
-> ReaderT AppState IO CommandOptions -> ReaderT AppState IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AppState -> CommandOptions) -> ReaderT AppState IO CommandOptions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppState -> CommandOptions
_appOptions
[Text]
required <- (AppState -> [Text]) -> ReaderT AppState IO [Text]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppState -> [Text]
_appRequiredArgs
let [Text
migrationId] = [Text]
required
(Backend -> IO ()) -> AppT ()
forall a. (Backend -> IO a) -> AppT a
withBackend ((Backend -> IO ()) -> AppT ()) -> (Backend -> IO ()) -> AppT ()
forall a b. (a -> b) -> a -> b
$ \Backend
backend -> do
Backend -> IO ()
ensureBootstrappedBackend Backend
backend IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Backend -> IO ()
commitBackend Backend
backend
Migration
m <- StoreData -> Text -> IO Migration
lookupMigration StoreData
storeData Text
migrationId
[Migration]
_ <- Migration -> StoreData -> Backend -> IO [Migration]
revert Migration
m StoreData
storeData Backend
backend
case Bool
isTesting of
Bool
False -> do
Backend -> IO ()
commitBackend Backend
backend
FilePath -> IO ()
putStrLn FilePath
"Successfully reverted migrations."
Bool
True -> do
Backend -> IO ()
rollbackBackend Backend
backend
FilePath -> IO ()
putStrLn FilePath
"Migration uninstallation test successful."
testCommand :: CommandHandler
testCommand :: CommandHandler
testCommand StoreData
storeData = do
[Text]
required <- (AppState -> [Text]) -> ReaderT AppState IO [Text]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppState -> [Text]
_appRequiredArgs
let [Text
migrationId] = [Text]
required
(Backend -> IO ()) -> AppT ()
forall a. (Backend -> IO a) -> AppT a
withBackend ((Backend -> IO ()) -> AppT ()) -> (Backend -> IO ()) -> AppT ()
forall a b. (a -> b) -> a -> b
$ \Backend
backend -> do
Backend -> IO ()
ensureBootstrappedBackend Backend
backend IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Backend -> IO ()
commitBackend Backend
backend
Migration
m <- StoreData -> Text -> IO Migration
lookupMigration StoreData
storeData Text
migrationId
[Text]
migrationNames <- Backend -> StoreData -> IO [Text]
missingMigrations Backend
backend StoreData
storeData
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text
migrationId Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
migrationNames) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
do [Migration]
_ <- Migration -> StoreData -> Backend -> IO [Migration]
revert Migration
m StoreData
storeData Backend
backend
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[Migration]
applied <- Migration -> StoreData -> Backend -> Bool -> IO [Migration]
apply Migration
m StoreData
storeData Backend
backend Bool
True
[Migration] -> (Migration -> IO [Migration]) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Migration] -> [Migration]
forall a. [a] -> [a]
reverse [Migration]
applied) ((Migration -> IO [Migration]) -> IO ())
-> (Migration -> IO [Migration]) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Migration
migration -> do
Migration -> StoreData -> Backend -> IO [Migration]
revert Migration
migration StoreData
storeData Backend
backend
Backend -> IO ()
rollbackBackend Backend
backend
FilePath -> IO ()
putStrLn FilePath
"Successfully tested migrations."