{-# 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)

    -- Default behavior: ask for dependencies if linear mode is disabled
    [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
        -- If the migration is already installed, remove it as part of
        -- the test
        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."