packages feed

ihp-migrate 1.4.0 → 1.5.0

raw patch · 6 files changed

+301/−44 lines, 6 filesdep +basedep +directorydep +filepathdep −ihp

Dependencies added: base, directory, filepath, hasql, hasql-transaction, hspec, ihp-migrate, string-conversions, temporary, text

Dependencies removed: ihp

Files

+ IHP/SchemaMigration.hs view
@@ -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)+
+ LICENSE view
@@ -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.
Migrate.hs view
@@ -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)
+ Test/SchemaMigrationSpec.hs view
@@ -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
+ changelog.md view
@@ -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"
ihp-migrate.cabal view
@@ -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