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)
}
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
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 ()
createSchemaMigrationsTable :: (?modelContext :: ModelContext) => IO ()
createSchemaMigrationsTable :: IO ()
createSchemaMigrationsTable = do
let modelContext :: ModelContext
modelContext = ?modelContext::ModelContext
ModelContext
?modelContext
let ?modelContext = modelContext { logger = (get #logger modelContext) { write = \_ -> pure ()} }
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 ()
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
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" ()
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
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