diff --git a/IHP/SchemaMigration.hs b/IHP/SchemaMigration.hs new file mode 100644 --- /dev/null +++ b/IHP/SchemaMigration.hs @@ -0,0 +1,170 @@ +{-| +Module: IHP.SchemaMigration +Description: Managing Database Migrations +Copyright: (c) digitally induced GmbH, 2020 +-} +module IHP.SchemaMigration where + +import Prelude +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Data.String.Conversions (cs) +import Data.Maybe (fromMaybe, mapMaybe, isJust, listToMaybe) +import Data.List (sortBy) +import Data.Ord (comparing) +import Data.Function ((&)) +import Control.Monad (unless, forM_, join) +import Data.Int (Int64) +import System.Environment (lookupEnv) +import System.Exit (die) +import Text.Read (readMaybe) +import qualified Data.Char as Char + +import qualified System.Directory.OsPath as Directory +import System.OsPath (encodeUtf, decodeUtf) + +import qualified Hasql.Connection as Connection +import qualified Hasql.Session as Session +import qualified Hasql.Statement as Statement +import qualified Hasql.Decoders as Decoders +import qualified Hasql.Encoders as Encoders + +data Migration = Migration + { revision :: Int + , migrationFile :: Text + } deriving (Show, Eq) + +data MigrateOptions = MigrateOptions + { 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 + } + +-- | Run a session on the bare connection, dying on error +runSession :: Connection.Connection -> Session.Session a -> IO a +runSession connection session = Connection.use connection session >>= either (die . show) pure + +-- | Migrates the database schema to the latest version +migrate :: Connection.Connection -> MigrateOptions -> IO () +migrate connection options = do + createSchemaMigrationsTable connection + + let minimumRevision = fromMaybe 0 options.minimumRevision + + openMigrations <- findOpenMigrations connection minimumRevision + forM_ openMigrations (runMigration connection) + +-- | 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 :: Connection.Connection -> Migration -> IO () +runMigration connection Migration { revision, migrationFile } = do + migrationFilePath <- migrationPath Migration { revision, migrationFile } + migrationSql <- Text.readFile (cs migrationFilePath) + + runSession connection do + Session.script "BEGIN" + Session.script (cs migrationSql) + Session.statement (fromIntegral revision :: Int64) insertRevisionStatement + Session.script "COMMIT" + +insertRevisionStatement :: Statement.Statement Int64 () +insertRevisionStatement = + Statement.preparable + "INSERT INTO schema_migrations (revision) VALUES ($1)" + (Encoders.param (Encoders.nonNullable Encoders.int8)) + Decoders.noResult + +checkSchemaMigrationsExistsStatement :: Statement.Statement () (Maybe Text) +checkSchemaMigrationsExistsStatement = + Statement.preparable + "SELECT (to_regclass('schema_migrations')) :: text" + Encoders.noParams + (Decoders.singleRow (Decoders.column (Decoders.nullable Decoders.text))) + +selectMigratedRevisionsStatement :: Statement.Statement () [Int64] +selectMigratedRevisionsStatement = + Statement.preparable + "SELECT revision FROM schema_migrations ORDER BY revision" + Encoders.noParams + (Decoders.rowList (Decoders.column (Decoders.nonNullable Decoders.int8))) + +-- | Creates the @schema_migrations@ table if it doesn't exist yet +createSchemaMigrationsTable :: Connection.Connection -> IO () +createSchemaMigrationsTable connection = do + -- 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 + maybeTableName <- runSession connection (Session.statement () checkSchemaMigrationsExistsStatement) + let schemaMigrationTableExists = isJust maybeTableName + + unless schemaMigrationTableExists do + runSession connection (Session.script "CREATE TABLE IF NOT EXISTS schema_migrations (revision BIGINT NOT NULL UNIQUE)") + +-- | Returns all migrations that haven't been executed yet. The result is sorted so that the oldest revision is first. +findOpenMigrations :: Connection.Connection -> Int -> IO [Migration] +findOpenMigrations connection !minimumRevision = do + migratedRevisions <- findMigratedRevisions connection + migrations <- findAllMigrations + migrations + & filter (\Migration { revision } -> not (revision `elem` migratedRevisions)) + & filter (\Migration { revision } -> revision > minimumRevision) + & pure + +-- | Returns all migration revisions applied to the database schema +-- +-- >>> findMigratedRevisions connection +-- [ 1604850570, 1604850660 ] +-- +findMigratedRevisions :: Connection.Connection -> IO [Int] +findMigratedRevisions connection = do + revisions <- runSession connection (Session.statement () selectMigratedRevisionsStatement) + pure (map fromIntegral revisions) + +-- | 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 = do + migrationDir <- detectMigrationDir + migrationDirOsPath <- encodeUtf (cs migrationDir) + directoryFiles <- Directory.listDirectory migrationDirOsPath + fileNames <- mapM decodeUtf directoryFiles + let textNames = map (cs :: FilePath -> Text) fileNames + textNames + & filter (\path -> ".sql" `Text.isSuffixOf` path) + & mapMaybe pathToMigration + & sortBy (comparing revision) + & 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 fileName = case revision of + Just revision -> Just Migration { migrationFile = fileName, revision } + Nothing -> Nothing + where + revision :: Maybe Int + revision = fileName + & Text.split (not . Char.isDigit) + & listToMaybe + & fmap (readMaybe . Text.unpack) + & join + +migrationPath :: Migration -> IO Text +migrationPath Migration { migrationFile } = do + migrationDir <- detectMigrationDir + pure (migrationDir <> migrationFile) + +detectMigrationDir :: IO Text +detectMigrationDir = do + envValue <- lookupEnv "IHP_MIGRATION_DIR" + pure (maybe "Application/Migration/" cs envValue) + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2020 digitally induced GmbH + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Migrate.hs b/Migrate.hs --- a/Migrate.hs +++ b/Migrate.hs @@ -1,32 +1,26 @@ module Main where -import IHP.Prelude +import Prelude import IHP.SchemaMigration -import IHP.ModelSupport -import IHP.FrameworkConfig -import IHP.Log.Types import Main.Utf8 (withUtf8) -import qualified IHP.EnvVar as EnvVar +import System.Environment (lookupEnv) +import System.Exit (die) +import Text.Read (readMaybe) +import Data.String.Conversions (cs) +import Control.Exception (bracket) +import qualified Hasql.Connection as Connection +import qualified Hasql.Connection.Settings as ConnectionSettings main :: IO () main = withUtf8 do - frameworkConfig <- buildFrameworkConfig (pure ()) - - -- We need a debug logger to print out all sql queries during the migration. - -- The production env logger could be set to a different log level, therefore - -- we don't use the logger in 'frameworkConfig' - -- - logger <- defaultLogger - - modelContext <- createModelContext - frameworkConfig.dbPoolIdleTime - frameworkConfig.dbPoolMaxConnections - frameworkConfig.databaseUrl - logger - - let ?modelContext = modelContext - - minimumRevision <- EnvVar.envOrNothing "MINIMUM_REVISION" - migrate MigrateOptions { minimumRevision } + databaseUrl <- lookupEnv "DATABASE_URL" >>= maybe (die "DATABASE_URL not set") pure + bracket (acquireConnection databaseUrl) Connection.release \connection -> do + minimumRevision <- fmap (>>= readMaybe) (lookupEnv "MINIMUM_REVISION") + migrate connection MigrateOptions { minimumRevision } - logger |> cleanup +acquireConnection :: String -> IO Connection.Connection +acquireConnection databaseUrl = do + result <- Connection.acquire (ConnectionSettings.connectionString (cs databaseUrl)) + case result of + Right connection -> pure connection + Left err -> die ("Failed to connect to database: " <> show err) diff --git a/Test/SchemaMigrationSpec.hs b/Test/SchemaMigrationSpec.hs new file mode 100644 --- /dev/null +++ b/Test/SchemaMigrationSpec.hs @@ -0,0 +1,46 @@ +{-| +Module: Test.HaskellSupportSpec +Copyright: (c) digitally induced GmbH, 2020 +-} +module Main where + +import Test.Hspec +import Prelude +import IHP.SchemaMigration +import qualified System.Directory as Directory +import System.FilePath (()) +import System.IO.Temp + +main :: IO () +main = hspec do + tests + +tests = do + describe "IHP.SchemaMigration" do + describe "findAllMigrations" do + it "should find all migrations" do + withTempApp do + migrations <- findAllMigrations + + migrations `shouldBe` + [ Migration { revision = 1605721927, migrationFile = "1605721927.sql"} + , Migration { revision = 1605721940, migrationFile = "1605721940-create-users.sql" } + ] + + +withTempApp :: IO a -> IO a +withTempApp action = + withSystemTempDirectory "ihp-migrate-test" \tmp -> do + let appRoot = tmp + let migrationDir = appRoot "Application" "Migration" + + -- Create the directory structure + Directory.createDirectoryIfMissing True migrationDir + + -- Create two migration files and one non-migration file + writeFile (migrationDir "1605721927.sql") "" + writeFile (migrationDir "1605721940-create-users.sql") "" + writeFile (migrationDir "not_a_migration") "" + + -- Now run findAllMigrations as if this were an IHP app root + Directory.withCurrentDirectory appRoot action diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,7 @@ +# Changelog for `ihp-migrate` + +## v1.5.0 + +- Migrate from postgresql-simple to hasql +- Remove ihp dependency for a lighter install +- Fix crash: "cannot enter pipeline mode, connection not idle" diff --git a/ihp-migrate.cabal b/ihp-migrate.cabal --- a/ihp-migrate.cabal +++ b/ihp-migrate.cabal @@ -1,36 +1,55 @@ cabal-version: 2.2 name: ihp-migrate -version: 1.4.0 +version: 1.5.0 synopsis: Provides the IHP migrate binary description: Postgres DB migrations for IHP applications license: MIT +license-file: LICENSE author: digitally induced GmbH maintainer: support@digitallyinduced.com +homepage: https://ihp.digitallyinduced.com/ bug-reports: https://github.com/digitallyinduced/ihp/issues +copyright: (c) digitally induced GmbH category: Database build-type: Simple +extra-source-files: changelog.md -executable migrate +source-repository head + type: git + location: https://github.com/digitallyinduced/ihp + + +common ihp-std default-language: GHC2021 default-extensions: + OverloadedLabels + OverloadedRecordDot + DuplicateRecordFields + DisambiguateRecordFields + TypeApplications + PackageImports + ScopedTypeVariables + BlockArguments OverloadedStrings - , NoImplicitPrelude - , ImplicitParams - , DisambiguateRecordFields - , DuplicateRecordFields - , OverloadedLabels - , DataKinds - , QuasiQuotes - , TypeFamilies - , PackageImports - , RecordWildCards - , DefaultSignatures - , FunctionalDependencies - , PartialTypeSignatures - , BlockArguments - , LambdaCase - , TemplateHaskell - , OverloadedRecordDot - build-depends: ihp, with-utf8 + ImplicitParams + ghc-options: -Werror=incomplete-patterns -Werror=unused-imports -Werror=missing-fields + +library + import: ihp-std + build-depends: base >= 4.17.0 && < 4.22, with-utf8, text, directory >= 1.3.8.0, filepath >= 1.5, string-conversions, hasql, hasql-transaction hs-source-dirs: . + exposed-modules: IHP.SchemaMigration + +executable migrate + import: ihp-std + build-depends: base >= 4.17.0 && < 4.22, with-utf8, text, directory >= 1.3.8.0, filepath >= 1.5, ihp-migrate, string-conversions, hasql, hasql-transaction + hs-source-dirs: . main-is: Migrate.hs + ghc-options: -threaded + +test-suite tests + import: ihp-std + type: exitcode-stdio-1.0 + main-is: SchemaMigrationSpec.hs + build-depends: base >= 4.17.0 && < 4.22, hspec, with-utf8, directory >= 1.3.8.0, ihp-migrate, filepath >= 1.5, temporary + hs-source-dirs: Test