{-|
Module: IHP.SchemaMigration
Description: Managing Database Migrations
Copyright: (c) digitally induced GmbH, 2020
-}
module IHP.SchemaMigration where

import IHP.Prelude
import qualified System.Directory as Directory
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import IHP.ModelSupport hiding (withTransaction)
import qualified Data.Char as Char
import IHP.Log.Types

data Migration = Migration
    { Migration -> Int
revision :: Int
    , Migration -> Text
migrationFile :: Text
    } deriving (Int -> Migration -> ShowS
[Migration] -> ShowS
Migration -> FilePath
(Int -> Migration -> ShowS)
-> (Migration -> FilePath)
-> ([Migration] -> ShowS)
-> Show Migration
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Migration -> ShowS
showsPrec :: Int -> Migration -> ShowS
$cshow :: Migration -> FilePath
show :: Migration -> FilePath
$cshowList :: [Migration] -> ShowS
showList :: [Migration] -> ShowS
Show, Migration -> Migration -> Bool
(Migration -> Migration -> Bool)
-> (Migration -> Migration -> Bool) -> Eq Migration
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Migration -> Migration -> Bool
== :: Migration -> Migration -> Bool
$c/= :: Migration -> Migration -> Bool
/= :: Migration -> Migration -> Bool
Eq)

data MigrateOptions = MigrateOptions
    { MigrateOptions -> Maybe Int
minimumRevision :: !(Maybe Int) -- ^ When deploying a fresh install of an existing app that has existing migrations, it might be useful to ignore older migrations as they're already part of the existing schema
    }

-- | Migrates the database schema to the latest version
migrate :: (?modelContext :: ModelContext) => MigrateOptions -> IO ()
migrate :: (?modelContext::ModelContext) => MigrateOptions -> IO ()
migrate MigrateOptions
options = do
    IO ()
(?modelContext::ModelContext) => IO ()
createSchemaMigrationsTable

    let minimumRevision :: Int
minimumRevision = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 MigrateOptions
options.minimumRevision

    [Migration]
openMigrations <- (?modelContext::ModelContext) => Int -> IO [Migration]
Int -> IO [Migration]
findOpenMigrations Int
minimumRevision
    [Migration] -> (Element [Migration] -> IO ()) -> IO ()
forall mono (m :: * -> *).
(MonoFoldable mono, Applicative m) =>
mono -> (Element mono -> m ()) -> m ()
forEach [Migration]
openMigrations (?modelContext::ModelContext) => Migration -> IO ()
Element [Migration] -> IO ()
Migration -> IO ()
runMigration

-- | The sql statements contained in the migration file are executed. Then the revision is inserted into the @schema_migrations@ table.
--
-- All queries are executed inside a database transaction to make sure that it can be restored when something goes wrong.
runMigration :: (?modelContext :: ModelContext) => Migration -> IO ()
runMigration :: (?modelContext::ModelContext) => Migration -> IO ()
runMigration migration :: Migration
migration@Migration { Int
$sel:revision:Migration :: Migration -> Int
revision :: Int
revision, Text
$sel:migrationFile:Migration :: Migration -> Text
migrationFile :: Text
migrationFile } = do
    Text
migrationSql <- 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
migrationPath Migration
migration)

    let fullSql :: Text
fullSql = [trimming|
        BEGIN;
            ${migrationSql};
            INSERT INTO schema_migrations (revision) VALUES (?);
        COMMIT;
    |]
    Query -> [Int] -> IO Int64
forall q.
(?modelContext::ModelContext, ToRow q) =>
Query -> q -> IO Int64
sqlExec (FilePath -> Query
forall a. IsString a => FilePath -> a
fromString (FilePath -> Query) -> (Text -> FilePath) -> Text -> Query
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
. Text -> FilePath
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Query) -> Text -> Query
forall a b. (a -> b) -> a -> b
$ Text
fullSql) [Int
revision]

    () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Creates the @schema_migrations@ table if it doesn't exist yet
createSchemaMigrationsTable :: (?modelContext :: ModelContext) => IO ()
createSchemaMigrationsTable :: (?modelContext::ModelContext) => IO ()
createSchemaMigrationsTable = do
    -- Hide this query from the log
    let modelContext :: ModelContext
modelContext = ?modelContext::ModelContext
ModelContext
?modelContext
    let ?modelContext = ModelContext
modelContext { $sel:logger:ModelContext :: Logger
logger = (ModelContext
modelContext.logger) { $sel:write:Logger :: (FormattedTime -> LogStr) -> IO ()
write = \FormattedTime -> LogStr
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()} }

    -- We don't use CREATE TABLE IF NOT EXISTS as adds a "NOTICE: relation schema_migrations already exists, skipping"
    -- This sometimes confuses users as they don't know if the this is an error or not (it's not)
    -- https://github.com/digitallyinduced/ihp/issues/818
    Maybe Text
maybeTableName :: Maybe Text <- Query -> () -> IO (Maybe Text)
forall q value.
(?modelContext::ModelContext, ToRow q, FromField value) =>
Query -> q -> IO value
sqlQueryScalar Query
"SELECT (to_regclass('schema_migrations')) :: text" ()
    let schemaMigrationTableExists :: Bool
schemaMigrationTableExists = Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
maybeTableName

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
schemaMigrationTableExists do
        let ddl :: Query
ddl = Query
"CREATE TABLE IF NOT EXISTS schema_migrations (revision BIGINT NOT NULL UNIQUE)"
        Int64
_ <- Query -> () -> IO Int64
forall q.
(?modelContext::ModelContext, ToRow q) =>
Query -> q -> IO Int64
sqlExec Query
ddl ()
        () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Returns all migrations that haven't been executed yet. The result is sorted so that the oldest revision is first.
findOpenMigrations :: (?modelContext :: ModelContext) => Int -> IO [Migration]
findOpenMigrations :: (?modelContext::ModelContext) => Int -> IO [Migration]
findOpenMigrations !Int
minimumRevision = do
    let modelContext :: ModelContext
modelContext = ?modelContext::ModelContext
ModelContext
?modelContext
    let ?modelContext = ModelContext
modelContext { $sel:logger:ModelContext :: Logger
logger = (ModelContext
modelContext.logger) { $sel:write:Logger :: (FormattedTime -> LogStr) -> IO ()
write = \FormattedTime -> LogStr
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()} }

    [Int]
migratedRevisions <- IO [Int]
(?modelContext::ModelContext) => IO [Int]
findMigratedRevisions
    [Migration]
migrations <- IO [Migration]
findAllMigrations
    [Migration]
migrations
        [Migration] -> ([Migration] -> [Migration]) -> [Migration]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Migration -> Bool) -> [Migration] -> [Migration]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Migration { Int
$sel:revision:Migration :: Migration -> Int
revision :: Int
revision } -> Bool -> Bool
not ([Int]
migratedRevisions [Int] -> ([Int] -> Bool) -> Bool
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Element [Int] -> [Int] -> Bool
forall container.
(MonoFoldable container, Eq (Element container)) =>
Element container -> container -> Bool
includes Int
Element [Int]
revision))
        [Migration] -> ([Migration] -> [Migration]) -> [Migration]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Migration -> Bool) -> [Migration] -> [Migration]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Migration { Int
$sel:revision:Migration :: Migration -> Int
revision :: Int
revision } -> Int
revision Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
minimumRevision)
        [Migration] -> ([Migration] -> IO [Migration]) -> IO [Migration]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [Migration] -> IO [Migration]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Returns all migration revisions applied to the database schema
--
-- >>> findMigratedRevisions
-- [ 1604850570, 1604850660 ]
--
findMigratedRevisions :: (?modelContext :: ModelContext) => IO [Int]
findMigratedRevisions :: (?modelContext::ModelContext) => IO [Int]
findMigratedRevisions = ([Int] -> Int) -> [[Int]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\[Int
revision] -> Int
revision) ([[Int]] -> [Int]) -> IO [[Int]] -> IO [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Query -> () -> IO [[Int]]
forall q r.
(?modelContext::ModelContext, ToRow q, FromRow r) =>
Query -> q -> IO [r]
sqlQuery Query
"SELECT revision FROM schema_migrations ORDER BY revision" ()

-- | Returns all migrations found in @Application/Migration@
--
-- >>> findAllMigrations
-- [ Migration { revision = 1604850570, migrationFile = "Application/Migration/1604850570-create-projects.sql" } ]
--
-- The result is sorted so that the oldest revision is first.
findAllMigrations :: IO [Migration]
findAllMigrations :: IO [Migration]
findAllMigrations = do
    [FilePath]
directoryFiles <- FilePath -> IO [FilePath]
Directory.listDirectory FilePath
"Application/Migration"
    [FilePath]
directoryFiles
        [FilePath] -> ([FilePath] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (FilePath -> Text) -> [FilePath] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Text
forall a b. ConvertibleStrings a b => a -> b
cs
        [Text] -> ([Text] -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Text
path -> Text
".sql" Text -> Text -> Bool
`isSuffixOf` Text
path)
        [Text] -> ([Text] -> [Migration]) -> [Migration]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Text -> Maybe Migration) -> [Text] -> [Migration]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe Migration
pathToMigration
        [Migration] -> ([Migration] -> [Migration]) -> [Migration]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Migration -> Migration -> Ordering) -> [Migration] -> [Migration]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Migration -> Int) -> Migration -> Migration -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Migration -> Int
revision)
        [Migration] -> ([Migration] -> IO [Migration]) -> IO [Migration]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [Migration] -> IO [Migration]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Given a path such as Application/Migrate/00-initial-migration.sql it returns a Migration
--
-- Returns Nothing if the path is not following the usual migration file path convention.
--
-- >>> pathToMigration "Application/Migration/1604850570-create-projects.sql"
-- Migration { revision = 1604850570, migrationFile = "Application/Migration/1604850570-create-projects.sql" }
--
pathToMigration :: Text -> Maybe Migration
pathToMigration :: Text -> Maybe Migration
pathToMigration Text
fileName = case Maybe Int
revision of
        Just Int
revision -> Migration -> Maybe Migration
forall a. a -> Maybe a
Just Migration { $sel:migrationFile:Migration :: Text
migrationFile = Text
fileName, Int
$sel:revision:Migration :: Int
revision :: Int
revision }
        Maybe Int
Nothing -> Maybe Migration
forall a. Maybe a
Nothing
    where
        revision :: Maybe Int
        revision :: Maybe Int
revision = Text
fileName
                Text -> (Text -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Char -> Bool) -> Text -> [Text]
Text.split (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
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
. Char -> Bool
Char.isDigit)
                [Text] -> ([Text] -> Maybe Text) -> Maybe Text
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [Text] -> Maybe Text
forall a. [a] -> Maybe a
head
                Maybe Text
-> (Maybe Text -> Maybe (Maybe Int)) -> Maybe (Maybe Int)
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Text -> Maybe Int) -> Maybe Text -> Maybe (Maybe Int)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Maybe Int
textToInt
                Maybe (Maybe Int) -> (Maybe (Maybe Int) -> Maybe Int) -> Maybe Int
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Maybe (Maybe Int) -> Maybe Int
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join

migrationPath :: Migration -> Text
migrationPath :: Migration -> Text
migrationPath Migration { Text
$sel:migrationFile:Migration :: Migration -> Text
migrationFile :: Text
migrationFile } = Text
"Application/Migration/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
migrationFile