module IHP.IDE.SchemaDesigner.Controller.Migrations where

import IHP.ControllerPrelude
import IHP.IDE.ToolServer.Types

import IHP.IDE.SchemaDesigner.View.Migrations.Index
import IHP.IDE.SchemaDesigner.View.Migrations.New
import IHP.IDE.SchemaDesigner.View.Migrations.Edit

import IHP.IDE.SchemaDesigner.View.Layout (schemaDesignerLayout)

import qualified Data.Text.IO as Text

import qualified IHP.SchemaMigration as SchemaMigration
import qualified IHP.IDE.CodeGen.MigrationGenerator as MigrationGenerator
import IHP.IDE.CodeGen.Controller
import IHP.IDE.ToolServer.Helper.Controller (openEditor, clearDatabaseNeedsMigration)
import IHP.Log.Types
import qualified Control.Exception as Exception
import qualified System.Directory as Directory
import qualified Database.PostgreSQL.Simple as PG

instance Controller MigrationsController where
    beforeAction :: (?context::ControllerContext, ?modelContext::ModelContext,
 ?theAction::MigrationsController) =>
IO ()
beforeAction = (?context::ControllerContext) =>
((?context::ControllerContext) => Layout) -> IO ()
((?context::ControllerContext) => Layout) -> IO ()
setLayout (?context::ControllerContext) => Layout
Layout
Html -> Html
schemaDesignerLayout

    action :: (?context::ControllerContext, ?modelContext::ModelContext,
 ?theAction::MigrationsController) =>
MigrationsController -> IO ()
action MigrationsController
MigrationsAction = do
        [Migration]
migrations <- IO [Migration]
findRecentMigrations
        [Int]
migratedRevisions <- IO [Int]
findMigratedRevisions

        [(Migration, Text)]
migrationsWithSql <- [Migration]
-> (Migration -> IO (Migration, Text)) -> IO [(Migration, Text)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Migration]
migrations ((Migration -> IO (Migration, Text)) -> IO [(Migration, Text)])
-> (Migration -> IO (Migration, Text)) -> IO [(Migration, Text)]
forall a b. (a -> b) -> a -> b
$ \Migration
migration -> do
                Text
sql <- Migration -> IO Text
readSqlStatements Migration
migration
                (Migration, Text) -> IO (Migration, Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Migration
migration, Text
sql)

        Maybe Text
lastError <- ByteString -> IO (Maybe Text)
forall value.
(?context::ControllerContext, Serialize value) =>
ByteString -> IO (Maybe value)
getSessionAndClear ByteString
"last_migraton_error"
        IndexView -> IO ()
forall view.
(View view, ?context::ControllerContext) =>
view -> IO ()
render IndexView { [Int]
[(Migration, Text)]
Maybe Text
migratedRevisions :: [Int]
migrationsWithSql :: [(Migration, Text)]
lastError :: Maybe Text
$sel:migrationsWithSql:IndexView :: [(Migration, Text)]
$sel:migratedRevisions:IndexView :: [Int]
$sel:lastError:IndexView :: Maybe Text
.. }


    action MigrationsController
NewMigrationAction = do
        let description :: Text
description = Text -> ByteString -> Text
forall a.
(?context::ControllerContext, ParamReader a) =>
a -> ByteString -> a
paramOrDefault Text
"" ByteString
"description"
        (Int
_, [GeneratorAction]
plan) <- Text -> Maybe Text -> IO (Int, [GeneratorAction])
MigrationGenerator.buildPlan Text
description Maybe Text
forall a. Maybe a
Nothing
        let runMigration :: Bool
runMigration = Bool -> ByteString -> Bool
forall a.
(?context::ControllerContext, ParamReader a) =>
a -> ByteString -> a
paramOrDefault Bool
True ByteString
"runMigration"
        NewView -> IO ()
forall view.
(View view, ?context::ControllerContext) =>
view -> IO ()
render NewView { [GeneratorAction]
plan :: [GeneratorAction]
$sel:plan:NewView :: [GeneratorAction]
.. }

    action MigrationsController
CreateMigrationAction = do
        let description :: Text
description = Text -> ByteString -> Text
forall a.
(?context::ControllerContext, ParamReader a) =>
a -> ByteString -> a
paramOrDefault Text
"" ByteString
"description"
        let sqlStatements :: Maybe Text
sqlStatements = ByteString -> Maybe Text
forall paramType.
(?context::ControllerContext, ParamReader (Maybe paramType)) =>
ByteString -> Maybe paramType
paramOrNothing ByteString
"sqlStatements"
        (Int
revision, [GeneratorAction]
plan) <- Text -> Maybe Text -> IO (Int, [GeneratorAction])
MigrationGenerator.buildPlan Text
description Maybe Text
sqlStatements
        let path :: Text
path = [GeneratorAction] -> Text
MigrationGenerator.migrationPathFromPlan [GeneratorAction]
plan

        [GeneratorAction] -> IO ()
executePlan [GeneratorAction]
plan

        let createOnly :: Bool
createOnly = Bool -> ByteString -> Bool
forall a.
(?context::ControllerContext, ParamReader a) =>
a -> ByteString -> a
paramOrDefault Bool
False ByteString
"createOnly"
        if Bool
createOnly
            then do
                (?context::ControllerContext) => Text -> IO ()
Text -> IO ()
setSuccessMessage (Text
"Migration generated: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path)
                Text -> Int -> Int -> IO ()
openEditor Text
path Int
0 Int
0
            else do
                Either SomeException ()
result <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
Exception.try (Int -> IO ()
migrateAppDB Int
revision)
                case Either SomeException ()
result of
                    Left (SomeException
exception :: SomeException) -> do
                        let errorMessage :: Text
errorMessage = case SomeException -> Maybe EnhancedSqlError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
                                Just (EnhancedSqlError
exception :: EnhancedSqlError) -> ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs EnhancedSqlError
exception.sqlError.sqlErrorMsg
                                Maybe EnhancedSqlError
Nothing -> SomeException -> Text
forall a. Show a => a -> Text
tshow SomeException
exception
                        
                        (?context::ControllerContext) => Text -> IO ()
Text -> IO ()
setErrorMessage Text
errorMessage
                        MigrationsController -> IO ()
forall action.
(?context::ControllerContext, HasPath action) =>
action -> IO ()
redirectTo MigrationsController
MigrationsAction
                    Right ()
_ -> do
                        IO ()
(?context::ControllerContext) => IO ()
clearDatabaseNeedsMigration
                        MigrationsController -> IO ()
forall action.
(?context::ControllerContext, HasPath action) =>
action -> IO ()
redirectTo MigrationsController
MigrationsAction

        MigrationsController -> IO ()
forall action.
(?context::ControllerContext, HasPath action) =>
action -> IO ()
redirectTo MigrationsController
MigrationsAction

    action EditMigrationAction { Int
migrationId :: Int
$sel:migrationId:MigrationsAction :: MigrationsController -> Int
migrationId } = do
        Migration
migration <- Int -> IO Migration
findMigrationByRevision Int
migrationId
        Text
sqlStatements <- Migration -> IO Text
readSqlStatements Migration
migration

        EditView -> IO ()
forall view.
(View view, ?context::ControllerContext) =>
view -> IO ()
render EditView { Text
Migration
migration :: Migration
sqlStatements :: Text
$sel:migration:EditView :: Migration
$sel:sqlStatements:EditView :: Text
.. }

    action UpdateMigrationAction { Int
$sel:migrationId:MigrationsAction :: MigrationsController -> Int
migrationId :: Int
migrationId } = do
        Migration
migration <- Int -> IO Migration
findMigrationByRevision Int
migrationId
        let sqlStatements :: Text
sqlStatements = ByteString -> Text
forall valueType.
(?context::ControllerContext, ParamReader valueType) =>
ByteString -> valueType
param ByteString
"sqlStatements"

        FilePath -> Text -> IO ()
Text.writeFile (Text -> FilePath
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Migration -> Text
SchemaMigration.migrationPath Migration
migration) Text
sqlStatements

        MigrationsController -> IO ()
forall action.
(?context::ControllerContext, HasPath action) =>
action -> IO ()
redirectTo MigrationsController
MigrationsAction

    action DeleteMigrationAction { Int
$sel:migrationId:MigrationsAction :: MigrationsController -> Int
migrationId :: Int
migrationId } = do
        Migration
migration <- Int -> IO Migration
findMigrationByRevision Int
migrationId
        let path :: FilePath
path = Text -> FilePath
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Migration -> Text
SchemaMigration.migrationPath Migration
migration

        FilePath -> IO ()
Directory.removeFile FilePath
path

        MigrationsController -> IO ()
forall action.
(?context::ControllerContext, HasPath action) =>
action -> IO ()
redirectTo MigrationsController
MigrationsAction

    action RunMigrationAction { Int
$sel:migrationId:MigrationsAction :: MigrationsController -> Int
migrationId :: Int
migrationId } = do
        Migration
migration <- Int -> IO Migration
findMigrationByRevision Int
migrationId

        Either SomeException ()
result <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
Exception.try (Int -> IO ()
migrateAppDB Int
migrationId)
        case Either SomeException ()
result of
            Left (SomeException
exception :: SomeException) -> do
                let errorMessage :: Text
errorMessage = case SomeException -> Maybe EnhancedSqlError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
                        Just (EnhancedSqlError
exception :: EnhancedSqlError) -> ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs EnhancedSqlError
exception.sqlError.sqlErrorMsg
                        Maybe EnhancedSqlError
Nothing -> SomeException -> Text
forall a. Show a => a -> Text
tshow SomeException
exception
                
                (?context::ControllerContext) => Text -> IO ()
Text -> IO ()
setErrorMessage Text
errorMessage
                MigrationsController -> IO ()
forall action.
(?context::ControllerContext, HasPath action) =>
action -> IO ()
redirectTo MigrationsController
MigrationsAction
            Right ()
_ -> do
                IO ()
(?context::ControllerContext) => IO ()
clearDatabaseNeedsMigration
                MigrationsController -> IO ()
forall action.
(?context::ControllerContext, HasPath action) =>
action -> IO ()
redirectTo MigrationsController
MigrationsAction

readSqlStatements :: SchemaMigration.Migration -> IO Text
readSqlStatements :: Migration -> IO Text
readSqlStatements Migration
migration = FilePath -> IO Text
Text.readFile (Text -> FilePath
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Migration -> Text
SchemaMigration.migrationPath Migration
migration)

findRecentMigrations :: IO [SchemaMigration.Migration]
findRecentMigrations :: IO [Migration]
findRecentMigrations = Int -> [Migration] -> [Migration]
forall a. Int -> [a] -> [a]
take Int
20 ([Migration] -> [Migration])
-> ([Migration] -> [Migration]) -> [Migration] -> [Migration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Migration] -> [Migration]
forall a. [a] -> [a]
reverse ([Migration] -> [Migration]) -> IO [Migration] -> IO [Migration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Migration]
SchemaMigration.findAllMigrations

findMigrationByRevision :: Int -> IO SchemaMigration.Migration
findMigrationByRevision :: Int -> IO Migration
findMigrationByRevision Int
migrationRevision = do
    [Migration]
migrations <- IO [Migration]
findRecentMigrations
    let (Just Migration
migration) = [Migration]
migrations [Migration] -> ([Migration] -> Maybe Migration) -> Maybe Migration
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Migration -> Bool) -> [Migration] -> Maybe Migration
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\SchemaMigration.Migration { Int
revision :: Int
$sel:revision:Migration :: Migration -> Int
revision } -> Int
revision Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
migrationRevision)
    Migration -> IO Migration
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Migration
migration

migrateAppDB :: Int -> IO ()
migrateAppDB :: Int -> IO ()
migrateAppDB Int
revision = ((?modelContext::ModelContext) => IO ()) -> IO ()
forall result.
((?modelContext::ModelContext) => IO result) -> IO result
withAppModelContext do
    let minimumRevision :: Maybe Int
minimumRevision = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
revision Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    (?modelContext::ModelContext) => MigrateOptions -> IO ()
MigrateOptions -> IO ()
SchemaMigration.migrate SchemaMigration.MigrateOptions { Maybe Int
minimumRevision :: Maybe Int
$sel:minimumRevision:MigrateOptions :: Maybe Int
minimumRevision }

findMigratedRevisions :: IO [Int]
findMigratedRevisions :: IO [Int]
findMigratedRevisions = IO [Int] -> IO [Int]
forall {a}. IO [a] -> IO [a]
emptyListIfTablesDoesntExists (((?modelContext::ModelContext) => IO [Int]) -> IO [Int]
forall result.
((?modelContext::ModelContext) => IO result) -> IO result
withAppModelContext IO [Int]
(?modelContext::ModelContext) => IO [Int]
SchemaMigration.findMigratedRevisions)
    where
        -- The schema_migrations table might not have been created yet
        -- In that case there cannot be any migrations that have been run yet
        emptyListIfTablesDoesntExists :: IO [a] -> IO [a]
emptyListIfTablesDoesntExists IO [a]
operation = do
            Either EnhancedSqlError [a]
result <- IO [a] -> IO (Either EnhancedSqlError [a])
forall e a. Exception e => IO a -> IO (Either e a)
Exception.try IO [a]
operation
            case Either EnhancedSqlError [a]
result of
                Left (EnhancedSqlError { SqlError
sqlError :: SqlError
$sel:sqlError:EnhancedSqlError :: EnhancedSqlError -> SqlError
sqlError }) | SqlError
sqlError.sqlErrorMsg ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"relation \"schema_migrations\" does not exist" -> [a] -> IO [a]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                Right [a]
result -> [a] -> IO [a]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
result

withAppModelContext :: ((?modelContext :: ModelContext) => IO result) -> IO result
withAppModelContext :: forall result.
((?modelContext::ModelContext) => IO result) -> IO result
withAppModelContext (?modelContext::ModelContext) => IO result
inner =
        IO (FrameworkConfig, Logger, ModelContext)
-> ((FrameworkConfig, Logger, ModelContext) -> IO ())
-> ((FrameworkConfig, Logger, ModelContext) -> IO result)
-> IO result
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket IO (FrameworkConfig, Logger, ModelContext)
initModelContext (FrameworkConfig, Logger, ModelContext) -> IO ()
forall {a} {c}. (a, Logger, c) -> IO ()
cleanupModelContext (FrameworkConfig, Logger, ModelContext) -> IO result
callback
    where
        callback :: (FrameworkConfig, Logger, ModelContext) -> IO result
callback (FrameworkConfig
frameworkConfig, Logger
logger, ModelContext
modelContext) = let ?modelContext = ?modelContext::ModelContext
ModelContext
modelContext in IO result
(?modelContext::ModelContext) => IO result
inner
        initModelContext :: IO (FrameworkConfig, Logger, ModelContext)
initModelContext = do
            FrameworkConfig
frameworkConfig <- ConfigBuilder -> IO FrameworkConfig
buildFrameworkConfig (() -> ConfigBuilder
forall a. a -> StateT TMap IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
            Logger
logger <- IO Logger
defaultLogger

            ModelContext
modelContext <- NominalDiffTime -> Int -> ByteString -> Logger -> IO ModelContext
createModelContext
                (FrameworkConfig
frameworkConfig.dbPoolIdleTime)
                (FrameworkConfig
frameworkConfig.dbPoolMaxConnections)
                (FrameworkConfig
frameworkConfig.databaseUrl)
                Logger
logger

            (FrameworkConfig, Logger, ModelContext)
-> IO (FrameworkConfig, Logger, ModelContext)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FrameworkConfig
frameworkConfig, Logger
logger, ModelContext
modelContext)

        cleanupModelContext :: (a, Logger, c) -> IO ()
cleanupModelContext (a
frameworkConfig, Logger
logger, c
modelContext) = do
            Logger
logger Logger -> (Logger -> IO ()) -> IO ()
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Logger -> IO ()
cleanup