{-|
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 Database.PostgreSQL.Simple.Types as PG
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)

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

    -- Print out all sql queries during the migration. This might be set to false in it's called inside a production env
    let modelContext :: ModelContext
modelContext = ?modelContext::ModelContext
ModelContext
?modelContext
    Logger
logger <- IO Logger
defaultLogger
    let ?modelContext = modelContext { logger }

    [Migration]
openMigrations <- IO [Migration]
(?modelContext::ModelContext) => IO [Migration]
findOpenMigrations
    [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)

    IO Int64 -> IO Int64
forall a. (?modelContext::ModelContext) => IO a -> IO a
withTransaction do
        Query -> () -> 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
migrationSql) ()
        Query -> [Int] -> IO Int64
forall q.
(?modelContext::ModelContext, ToRow q, Show q) =>
Query -> q -> IO Int64
sqlExec Query
"INSERT INTO schema_migrations (revision) VALUES (?)" [Int
revision]

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

withTransaction :: (?modelContext :: ModelContext) => IO a -> IO a
withTransaction :: IO a -> IO a
withTransaction IO a
block = do
    Int64
_ <- Query -> () -> IO Int64
forall q.
(?modelContext::ModelContext, ToRow q, Show q) =>
Query -> q -> IO Int64
sqlExec Query
"BEGIN" ()
    a
result <- IO a
block
    Int64
_ <- Query -> () -> IO Int64
forall q.
(?modelContext::ModelContext, ToRow q, Show q) =>
Query -> q -> IO Int64
sqlExec Query
"COMMIT" ()
    a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result

-- | Creates the @schema_migrations@ table if it doesn't exist yet
createSchemaMigrationsTable :: (?modelContext :: ModelContext) => IO ()
createSchemaMigrationsTable :: IO ()
createSchemaMigrationsTable = 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) => IO [Migration]
findOpenMigrations :: IO [Migration]
findOpenMigrations = do
    [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] -> 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

-- | Generates a new migration @.sql@ file in @Application/Migration@
createMigration :: Text -> IO Migration
createMigration :: Text -> IO Migration
createMigration Text
description = do
    Int
revision <- POSIXTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Int) -> IO POSIXTime -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO POSIXTime
POSIX.getPOSIXTime
    let slug :: Text
slug = Text -> Text
NameSupport.toSlug Text
description
    let migrationFile :: Text
migrationFile = Int -> Text
forall a. Show a => a -> Text
tshow Int
revision Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Text -> Bool
forall value. IsEmpty value => value -> Bool
isEmpty Text
slug then Text
"" else Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
slug) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".sql"
    Bool -> String -> IO ()
Directory.createDirectoryIfMissing Bool
False String
"Application/Migration"
    String -> Text -> IO ()
Text.writeFile (String
"Application/Migration/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
migrationFile) Text
"-- Write your SQL migration code in here\n"
    Migration -> IO Migration
forall (f :: * -> *) a. Applicative f => a -> f a
pure Migration :: Int -> Text -> Migration
Migration { Int
Text
migrationFile :: Text
revision :: Int
$sel:migrationFile:Migration :: Text
$sel:revision:Migration :: Int
.. }