{-|
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.Time.Clock.POSIX as POSIX
import qualified IHP.NameSupport as NameSupport
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 -> String
(Int -> Migration -> ShowS)
-> (Migration -> String)
-> ([Migration] -> ShowS)
-> Show Migration
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Migration] -> ShowS
$cshowList :: [Migration] -> ShowS
show :: Migration -> String
$cshow :: Migration -> String
showsPrec :: Int -> Migration -> ShowS
$cshowsPrec :: Int -> Migration -> ShowS
Show, Migration -> Migration -> Bool
(Migration -> Migration -> Bool)
-> (Migration -> Migration -> Bool) -> Eq Migration
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Migration -> Migration -> Bool
$c/= :: Migration -> Migration -> Bool
== :: Migration -> Migration -> Bool
$c== :: 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 :: MigrateOptions -> IO ()
migrate MigrateOptions
options = do
    IO ()
(?modelContext::ModelContext) => IO ()
createSchemaMigrationsTable

    let minimumRevision :: Int
minimumRevision = MigrateOptions
options
            MigrateOptions -> (MigrateOptions -> Maybe Int) -> Maybe Int
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "minimumRevision" -> MigrateOptions -> Maybe Int
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "minimumRevision" (Proxy "minimumRevision")
Proxy "minimumRevision"
#minimumRevision
            Maybe Int -> (Maybe Int -> Int) -> Int
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0

    [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 ()
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 :: Migration -> IO ()
runMigration migration :: Migration
migration@Migration { Int
revision :: Int
$sel:revision:Migration :: Migration -> Int
revision, Text
migrationFile :: Text
$sel:migrationFile:Migration :: Migration -> Text
migrationFile } = do
    Text
migrationSql <- String -> IO Text
Text.readFile (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> String) -> Text -> String
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, Show q) =>
Query -> q -> IO Int64
sqlExec (String -> Query
forall a. IsString a => String -> a
fromString (String -> Query) -> (Text -> String) -> Text -> Query
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> String
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 (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Creates the @schema_migrations@ table if it doesn't exist yet
createSchemaMigrationsTable :: (?modelContext :: ModelContext) => IO ()
createSchemaMigrationsTable :: IO ()
createSchemaMigrationsTable = do
    -- Hide this query from the log
    let modelContext :: ModelContext
modelContext = ?modelContext::ModelContext
ModelContext
?modelContext
    let ?modelContext = modelContext { logger = (get #logger modelContext) { write = \_ -> 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, Show 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, Show q) =>
Query -> q -> IO Int64
sqlExec Query
ddl ()
        () -> IO ()
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 :: Int -> IO [Migration]
findOpenMigrations !Int
minimumRevision = do
    let modelContext :: ModelContext
modelContext = ?modelContext::ModelContext
ModelContext
?modelContext
    let ?modelContext = modelContext { logger = (get #logger modelContext) { write = \_ -> 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
revision :: Int
$sel:revision:Migration :: Migration -> 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
revision :: Int
$sel:revision:Migration :: Migration -> 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 (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 :: 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, Show q) =>
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
    [String]
directoryFiles <- String -> IO [String]
Directory.listDirectory String
"Application/Migration"
    [String]
directoryFiles
        [String] -> ([String] -> [Text]) -> [Text]
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> 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 (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 :: Int -> Text -> Migration
Migration { $sel:migrationFile:Migration :: Text
migrationFile = Text
fileName, Int
revision :: Int
$sel:revision:Migration :: 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 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 (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
migrationFile :: Text
$sel:migrationFile:Migration :: Migration -> Text
migrationFile } = Text
"Application/Migration/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
migrationFile