From 4ad3081176aab5bd12fc85da49c878a81a159ef6 Mon Sep 17 00:00:00 2001 From: Ken Aguilar Date: Fri, 12 Jun 2020 23:50:19 -0500 Subject: [PATCH 1/3] package with nix (#1) - created nix files. - commented out test because it was relying on a system dependency. --- .gitignore | 1 + dbmigrations-postgresql.cabal | 42 ++++++++++++++++----------------- default.nix | 16 +++++++++++++ nix/pinned.nix | 11 +++++++++ release.nix | 4 ++++ shell.nix | 14 +++++++++++ test/{TestDriver.hs => Main.hs} | 28 ++++++++++++---------- 7 files changed, 81 insertions(+), 35 deletions(-) create mode 100644 default.nix create mode 100644 nix/pinned.nix create mode 100644 release.nix create mode 100644 shell.nix rename test/{TestDriver.hs => Main.hs} (65%) diff --git a/.gitignore b/.gitignore index fcb65ba..29e1e2f 100644 --- a/.gitignore +++ b/.gitignore @@ -4,3 +4,4 @@ cabal.project dist dist-newstyle .*.swp +result diff --git a/dbmigrations-postgresql.cabal b/dbmigrations-postgresql.cabal index 1278fc6..ed3bb6f 100644 --- a/dbmigrations-postgresql.cabal +++ b/dbmigrations-postgresql.cabal @@ -41,25 +41,23 @@ Executable moo-postgresql Hs-Source-Dirs: programs Main-is: MooPostgreSQL.hs -test-suite dbmigrations-postgresql-tests - default-language: Haskell2010 - type: exitcode-stdio-1.0 - Build-Depends: - base >= 4 && < 5, - dbmigrations >= 2, - HDBC >= 2.2.1, - HDBC-postgresql == 2.3.2.4, - process >= 1.1, - HUnit >= 1.2 - - other-modules: - TestDriver - - if impl(ghc >= 6.12.0) - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields - -fno-warn-unused-do-bind -Wwarn - else - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields - - Hs-Source-Dirs: test - Main-is: TestDriver.hs +-- Commented +-- test-suite dbmigrations-postgresql-tests +-- default-language: Haskell2010 +-- type: exitcode-stdio-1.0 +-- Build-Depends: +-- base >= 4 && < 5, +-- dbmigrations >= 2, +-- HDBC >= 2.2.1, +-- HDBC-postgresql == 2.3.2.7, +-- process >= 1.1, +-- HUnit >= 1.2 + +-- if impl(ghc >= 6.12.0) +-- ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields +-- -fno-warn-unused-do-bind -Wwarn +-- else +-- ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields + +-- Hs-Source-Dirs: test +-- Main-is: Main.hs diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..3a8d683 --- /dev/null +++ b/default.nix @@ -0,0 +1,16 @@ +{ mkDerivation, base, dbmigrations, HDBC, HDBC-postgresql, HUnit +, process, stdenv +}: +mkDerivation { + pname = "dbmigrations-postgresql"; + version = "2.0.0"; + src = ./.; + isLibrary = false; + isExecutable = true; + executableHaskellDepends = [ base dbmigrations HDBC-postgresql ]; + testHaskellDepends = [ + base dbmigrations HDBC HDBC-postgresql HUnit process + ]; + description = "The dbmigrations tool built for PostgreSQL databases"; + license = stdenv.lib.licenses.bsd3; +} diff --git a/nix/pinned.nix b/nix/pinned.nix new file mode 100644 index 0000000..2aac730 --- /dev/null +++ b/nix/pinned.nix @@ -0,0 +1,11 @@ +let + pkgs = import {}; +in +import ( + pkgs.fetchFromGitHub { + owner = "nixos"; + repo = "nixpkgs"; + rev = "1cd56fc68216423a0413294c8e56453166be87dd"; + sha256 = "0cihxsy5958l9nk0rlnwd1bz4ayhrp7v5bspjdrmfgwgv40j0rw3"; + } +) diff --git a/release.nix b/release.nix new file mode 100644 index 0000000..772d9d7 --- /dev/null +++ b/release.nix @@ -0,0 +1,4 @@ +let + pkgs = import ./nix/pinned.nix {}; +in +pkgs.haskellPackages.callPackage ./default.nix {} diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..b154924 --- /dev/null +++ b/shell.nix @@ -0,0 +1,14 @@ +{ nixpkgs ? import ./nix/pinned.nix {} }: +let + inherit ( nixpkgs ) pkgs; + inherit ( pkgs ) haskellPackages; + + project = import ./release.nix; +in +pkgs.stdenv.mkDerivation { + name = "dbmigrations-postgresql"; + buildInputs = project.env.nativeBuildInputs ++ [ + haskellPackages.cabal-install + haskellPackages.ghcid + ]; +} diff --git a/test/TestDriver.hs b/test/Main.hs similarity index 65% rename from test/TestDriver.hs rename to test/Main.hs index 0758582..a45e96b 100644 --- a/test/TestDriver.hs +++ b/test/Main.hs @@ -1,21 +1,23 @@ {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} module Main where -import Database.Schema.Migrations.Backend.HDBC (hdbcBackend) -import Database.Schema.Migrations.Test.BackendTest as BackendTest +import Database.Schema.Migrations.Backend.HDBC (hdbcBackend) +import Database.Schema.Migrations.Test.BackendTest as BackendTest -import Control.Exception (catch, catches, finally, Handler(..), SomeException ) -import Database.HDBC ( IConnection(disconnect) ) -import qualified Database.HDBC as HDBC -import qualified Database.HDBC.PostgreSQL as PostgreSQL -import System.Exit -import System.IO ( stderr ) -import System.Process ( system ) -import Test.HUnit +import Control.Exception (Handler (..), + SomeException, + catch, catches, + finally) +import Database.HDBC (IConnection (disconnect)) +import qualified Database.HDBC as HDBC +import qualified Database.HDBC.PostgreSQL as PostgreSQL +import System.Exit +import System.IO (stderr) +import System.Process (system) +import Test.HUnit -data PostgreSQLBackendConnection = - forall a. HDBC.IConnection a => HDBCConnection a +data PostgreSQLBackendConnection = forall a . HDBC.IConnection a => HDBCConnection a instance BackendConnection PostgreSQLBackendConnection where supportsTransactionalDDL = const True From d97ccfd86abb7cbf6b02780f4ec9459583d7abae Mon Sep 17 00:00:00 2001 From: Ken Aguilar Date: Sat, 13 Jun 2020 02:03:30 -0500 Subject: [PATCH 2/3] nix-packaging (#2) --- .gitignore | 7 +- .travis.yml | 16 + CHANGELOG.md | 0 README.md | 1 + cabal.project | 1 + LICENSE => dbmigrations-postgresql/LICENSE | 0 .../dbmigrations-postgresql.cabal | 7 +- dbmigrations-postgresql/default.nix | 16 + dbmigrations-postgresql/nix/pinned.nix | 11 + .../programs}/MooPostgreSQL.hs | 0 dbmigrations-postgresql/release.nix | 4 + dbmigrations-postgresql/shell.nix | 14 + .../test}/Main.hs | 0 dbmigrations/CHANGELOG.md | 67 ++++ dbmigrations/LICENSE | 30 ++ dbmigrations/MOO.TXT | 316 ++++++++++++++++++ dbmigrations/README.md | 50 +++ dbmigrations/Setup.lhs | 3 + dbmigrations/dbmigrations.cabal | 169 ++++++++++ dbmigrations/default.nix | 26 ++ dbmigrations/nix/pinned.nix | 11 + dbmigrations/programs/Moo.hs | 17 + dbmigrations/release.nix | 4 + dbmigrations/shell.nix | 14 + .../src/Database/Schema/Migrations.hs | 93 ++++++ .../src/Database/Schema/Migrations/Backend.hs | 77 +++++ .../Schema/Migrations/Backend/HDBC.hs | 69 ++++ .../Schema/Migrations/CycleDetection.hs | 64 ++++ .../Schema/Migrations/Dependencies.hs | 100 ++++++ .../Database/Schema/Migrations/Filesystem.hs | 187 +++++++++++ .../Schema/Migrations/Filesystem/Serialize.hs | 75 +++++ .../Database/Schema/Migrations/Migration.hs | 43 +++ .../src/Database/Schema/Migrations/Store.hs | 141 ++++++++ .../Schema/Migrations/Test/BackendTest.hs | 180 ++++++++++ dbmigrations/src/Moo/CommandHandlers.hs | 182 ++++++++++ dbmigrations/src/Moo/CommandInterface.hs | 126 +++++++ dbmigrations/src/Moo/CommandUtils.hs | 257 ++++++++++++++ dbmigrations/src/Moo/Core.hs | 196 +++++++++++ dbmigrations/src/Moo/Main.hs | 97 ++++++ dbmigrations/src/StoreManager.hs | 232 +++++++++++++ dbmigrations/test/Common.hs | 44 +++ dbmigrations/test/CommonTH.hs | 16 + dbmigrations/test/ConfigurationTest.hs | 97 ++++++ dbmigrations/test/CycleDetectionTest.hs | 69 ++++ dbmigrations/test/DependencyTest.hs | 82 +++++ dbmigrations/test/FilesystemParseTest.hs | 121 +++++++ dbmigrations/test/FilesystemSerializeTest.hs | 77 +++++ dbmigrations/test/FilesystemTest.hs | 35 ++ dbmigrations/test/InMemoryStore.hs | 35 ++ dbmigrations/test/LinearMigrationsTest.hs | 95 ++++++ dbmigrations/test/Main.hs | 51 +++ dbmigrations/test/MigrationsTest.hs | 71 ++++ dbmigrations/test/StoreTest.hs | 119 +++++++ dbmigrations/test/config_loading/cfg1.cfg | 3 + dbmigrations/test/config_loading/cfg_ts.cfg | 4 + dbmigrations/test/config_loading/invalid.cfg | 3 + dbmigrations/test/config_loading/missing.cfg | 0 dbmigrations/test/config_loading/moo.cfg | 3 + dbmigrations/test/example_store/root | 10 + dbmigrations/test/example_store/update1 | 10 + dbmigrations/test/example_store/update2 | 10 + .../migration_parsing/invalid_field_name.txt | 11 + .../invalid_missing_required_fields.txt | 8 + .../test/migration_parsing/invalid_syntax.txt | 9 + .../migration_parsing/invalid_timestamp.txt | 10 + .../test/migration_parsing/valid_full.txt | 10 + .../migration_parsing/valid_no_depends.txt | 10 + .../test/migration_parsing/valid_no_desc.txt | 9 + .../migration_parsing/valid_no_revert.txt | 8 + .../migration_parsing/valid_no_timestamp.txt | 9 + .../migration_parsing/valid_with_colon.txt | 11 + .../migration_parsing/valid_with_comments.txt | 13 + .../valid_with_comments2.txt | 11 + .../valid_with_multiline_deps.txt | 15 + default.nix | 20 +- nixpkgs.nix | 28 ++ shell.nix | 10 +- 77 files changed, 4025 insertions(+), 25 deletions(-) create mode 100644 .travis.yml create mode 100644 CHANGELOG.md create mode 100644 README.md create mode 100644 cabal.project rename LICENSE => dbmigrations-postgresql/LICENSE (100%) rename dbmigrations-postgresql.cabal => dbmigrations-postgresql/dbmigrations-postgresql.cabal (95%) create mode 100644 dbmigrations-postgresql/default.nix create mode 100644 dbmigrations-postgresql/nix/pinned.nix rename {programs => dbmigrations-postgresql/programs}/MooPostgreSQL.hs (100%) create mode 100644 dbmigrations-postgresql/release.nix create mode 100644 dbmigrations-postgresql/shell.nix rename {test => dbmigrations-postgresql/test}/Main.hs (100%) create mode 100644 dbmigrations/CHANGELOG.md create mode 100644 dbmigrations/LICENSE create mode 100644 dbmigrations/MOO.TXT create mode 100644 dbmigrations/README.md create mode 100755 dbmigrations/Setup.lhs create mode 100644 dbmigrations/dbmigrations.cabal create mode 100644 dbmigrations/default.nix create mode 100644 dbmigrations/nix/pinned.nix create mode 100644 dbmigrations/programs/Moo.hs create mode 100644 dbmigrations/release.nix create mode 100644 dbmigrations/shell.nix create mode 100644 dbmigrations/src/Database/Schema/Migrations.hs create mode 100644 dbmigrations/src/Database/Schema/Migrations/Backend.hs create mode 100644 dbmigrations/src/Database/Schema/Migrations/Backend/HDBC.hs create mode 100644 dbmigrations/src/Database/Schema/Migrations/CycleDetection.hs create mode 100644 dbmigrations/src/Database/Schema/Migrations/Dependencies.hs create mode 100644 dbmigrations/src/Database/Schema/Migrations/Filesystem.hs create mode 100644 dbmigrations/src/Database/Schema/Migrations/Filesystem/Serialize.hs create mode 100644 dbmigrations/src/Database/Schema/Migrations/Migration.hs create mode 100644 dbmigrations/src/Database/Schema/Migrations/Store.hs create mode 100644 dbmigrations/src/Database/Schema/Migrations/Test/BackendTest.hs create mode 100644 dbmigrations/src/Moo/CommandHandlers.hs create mode 100644 dbmigrations/src/Moo/CommandInterface.hs create mode 100644 dbmigrations/src/Moo/CommandUtils.hs create mode 100644 dbmigrations/src/Moo/Core.hs create mode 100644 dbmigrations/src/Moo/Main.hs create mode 100644 dbmigrations/src/StoreManager.hs create mode 100644 dbmigrations/test/Common.hs create mode 100644 dbmigrations/test/CommonTH.hs create mode 100644 dbmigrations/test/ConfigurationTest.hs create mode 100644 dbmigrations/test/CycleDetectionTest.hs create mode 100644 dbmigrations/test/DependencyTest.hs create mode 100644 dbmigrations/test/FilesystemParseTest.hs create mode 100644 dbmigrations/test/FilesystemSerializeTest.hs create mode 100644 dbmigrations/test/FilesystemTest.hs create mode 100644 dbmigrations/test/InMemoryStore.hs create mode 100644 dbmigrations/test/LinearMigrationsTest.hs create mode 100644 dbmigrations/test/Main.hs create mode 100644 dbmigrations/test/MigrationsTest.hs create mode 100644 dbmigrations/test/StoreTest.hs create mode 100644 dbmigrations/test/config_loading/cfg1.cfg create mode 100644 dbmigrations/test/config_loading/cfg_ts.cfg create mode 100644 dbmigrations/test/config_loading/invalid.cfg create mode 100644 dbmigrations/test/config_loading/missing.cfg create mode 100644 dbmigrations/test/config_loading/moo.cfg create mode 100644 dbmigrations/test/example_store/root create mode 100644 dbmigrations/test/example_store/update1 create mode 100644 dbmigrations/test/example_store/update2 create mode 100644 dbmigrations/test/migration_parsing/invalid_field_name.txt create mode 100644 dbmigrations/test/migration_parsing/invalid_missing_required_fields.txt create mode 100644 dbmigrations/test/migration_parsing/invalid_syntax.txt create mode 100644 dbmigrations/test/migration_parsing/invalid_timestamp.txt create mode 100644 dbmigrations/test/migration_parsing/valid_full.txt create mode 100644 dbmigrations/test/migration_parsing/valid_no_depends.txt create mode 100644 dbmigrations/test/migration_parsing/valid_no_desc.txt create mode 100644 dbmigrations/test/migration_parsing/valid_no_revert.txt create mode 100644 dbmigrations/test/migration_parsing/valid_no_timestamp.txt create mode 100644 dbmigrations/test/migration_parsing/valid_with_colon.txt create mode 100644 dbmigrations/test/migration_parsing/valid_with_comments.txt create mode 100644 dbmigrations/test/migration_parsing/valid_with_comments2.txt create mode 100644 dbmigrations/test/migration_parsing/valid_with_multiline_deps.txt create mode 100644 nixpkgs.nix diff --git a/.gitignore b/.gitignore index 29e1e2f..a193ebc 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,11 @@ +.*.swp .cabal-sandbox cabal.sandbox.config -cabal.project +dist +dist-newstyle +result + +.cabal-sandbox dist dist-newstyle .*.swp diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..1d13330 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,16 @@ +# Do not choose a language; we provide our own build tools. +language: generic + +before_install: +- wget https://www.haskell.org/platform/download/8.4.3/haskell-platform-8.4.3-unknown-posix--full-x86_64.tar.gz +- tar xf haskell-platform-8.4.3-unknown-posix--full-x86_64.tar.gz +- sudo ./install-haskell-platform.sh +- cabal --version + +install: +- cabal update +- cabal install --enable-tests + +script: +- cabal test +- cabal haddock diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..e69de29 diff --git a/README.md b/README.md new file mode 100644 index 0000000..d4604d4 --- /dev/null +++ b/README.md @@ -0,0 +1 @@ +# dbmigrations-postgresql diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..4151f55 --- /dev/null +++ b/cabal.project @@ -0,0 +1 @@ +packages: dbmigrations-postgresql/ dbmigrations/ diff --git a/LICENSE b/dbmigrations-postgresql/LICENSE similarity index 100% rename from LICENSE rename to dbmigrations-postgresql/LICENSE diff --git a/dbmigrations-postgresql.cabal b/dbmigrations-postgresql/dbmigrations-postgresql.cabal similarity index 95% rename from dbmigrations-postgresql.cabal rename to dbmigrations-postgresql/dbmigrations-postgresql.cabal index ed3bb6f..4200e12 100644 --- a/dbmigrations-postgresql.cabal +++ b/dbmigrations-postgresql/dbmigrations-postgresql.cabal @@ -27,10 +27,9 @@ Source-Repository head Executable moo-postgresql default-language: Haskell2010 - Build-Depends: - base >= 4 && < 5, - dbmigrations >= 2, - HDBC-postgresql + Build-Depends: base >= 4 && < 5 + , dbmigrations + , HDBC-postgresql if impl(ghc >= 6.12.0) ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields diff --git a/dbmigrations-postgresql/default.nix b/dbmigrations-postgresql/default.nix new file mode 100644 index 0000000..3a8d683 --- /dev/null +++ b/dbmigrations-postgresql/default.nix @@ -0,0 +1,16 @@ +{ mkDerivation, base, dbmigrations, HDBC, HDBC-postgresql, HUnit +, process, stdenv +}: +mkDerivation { + pname = "dbmigrations-postgresql"; + version = "2.0.0"; + src = ./.; + isLibrary = false; + isExecutable = true; + executableHaskellDepends = [ base dbmigrations HDBC-postgresql ]; + testHaskellDepends = [ + base dbmigrations HDBC HDBC-postgresql HUnit process + ]; + description = "The dbmigrations tool built for PostgreSQL databases"; + license = stdenv.lib.licenses.bsd3; +} diff --git a/dbmigrations-postgresql/nix/pinned.nix b/dbmigrations-postgresql/nix/pinned.nix new file mode 100644 index 0000000..2aac730 --- /dev/null +++ b/dbmigrations-postgresql/nix/pinned.nix @@ -0,0 +1,11 @@ +let + pkgs = import {}; +in +import ( + pkgs.fetchFromGitHub { + owner = "nixos"; + repo = "nixpkgs"; + rev = "1cd56fc68216423a0413294c8e56453166be87dd"; + sha256 = "0cihxsy5958l9nk0rlnwd1bz4ayhrp7v5bspjdrmfgwgv40j0rw3"; + } +) diff --git a/programs/MooPostgreSQL.hs b/dbmigrations-postgresql/programs/MooPostgreSQL.hs similarity index 100% rename from programs/MooPostgreSQL.hs rename to dbmigrations-postgresql/programs/MooPostgreSQL.hs diff --git a/dbmigrations-postgresql/release.nix b/dbmigrations-postgresql/release.nix new file mode 100644 index 0000000..772d9d7 --- /dev/null +++ b/dbmigrations-postgresql/release.nix @@ -0,0 +1,4 @@ +let + pkgs = import ./nix/pinned.nix {}; +in +pkgs.haskellPackages.callPackage ./default.nix {} diff --git a/dbmigrations-postgresql/shell.nix b/dbmigrations-postgresql/shell.nix new file mode 100644 index 0000000..b154924 --- /dev/null +++ b/dbmigrations-postgresql/shell.nix @@ -0,0 +1,14 @@ +{ nixpkgs ? import ./nix/pinned.nix {} }: +let + inherit ( nixpkgs ) pkgs; + inherit ( pkgs ) haskellPackages; + + project = import ./release.nix; +in +pkgs.stdenv.mkDerivation { + name = "dbmigrations-postgresql"; + buildInputs = project.env.nativeBuildInputs ++ [ + haskellPackages.cabal-install + haskellPackages.ghcid + ]; +} diff --git a/test/Main.hs b/dbmigrations-postgresql/test/Main.hs similarity index 100% rename from test/Main.hs rename to dbmigrations-postgresql/test/Main.hs diff --git a/dbmigrations/CHANGELOG.md b/dbmigrations/CHANGELOG.md new file mode 100644 index 0000000..0da6bc5 --- /dev/null +++ b/dbmigrations/CHANGELOG.md @@ -0,0 +1,67 @@ +2.0.0 +----- + +This release contains breaking changes! + +- Factored out all database-specific functionality into separate +packages (thanks Bastian Krol) +- Replaced "moo" program with one that emits an error instructing users +to use backend-specific dbmigrations packages +- Added missing test data files to package +- Removed `DBM_DATABASE_TYPE` environment variable in favor of backend +selection by use of backend-specific packages +- Allow `DBM_TIMESTAMP_FILENAMES` to be set via environment variable +(thanks Alexander Lippling) + +1.1.1 +----- + +- Improve configuration validation error messages and clean up +validation routine +- Reinstate support for GHC 7.8 + +1.1 +--- + +- Add support for MySQL databases (thanks Ollie Charles +). Please see MOO.TXT for a disclaimer about this +feature! + +1.0 +--- + +- Added support for (optionally) adding timestamps to generated +migration filenames (thanks Matt Parsons ) + * Adds flag for time stamp on file names + * Adds configuration for timestamping filenames +- Added new "linear migrations" feature (thanks Jakub Fijałkowski +, Andrew Martin ). This +feature is an optional alternative to the default behavior: rather than +prompting the user for dependencies of new migrations (the default +behavior), linear mode automatically selects dependencies for new +migrations such that they depend on the smallest subset of migrations +necessary to (effectively) depend on all existing migrations, thus +"linearizing" the migration sequence. See MOO.TXT for details. +- Configuration file loading now defaults to "moo.cfg" in the CWD if +--config-file is not specified, and environment variables override +settings in the config file + +0.9.1 +----- + +- Restored default timestamp and description values in migrations +created by new migration command + +0.9 +--- + +- Fix 'moo' usage output to use correct program name +- Replaced Backend type class in favor of concrete Backend record type +- Added hdbcBackend constructor +- Backends now always run in IO rather than some MonadIO +- Removed monad parameter from MigrationStore (always use IO) +- Replaced MigrationStore type class with concrete MigrationStore type +- Added filesystem migration store constructor +- Improve configuration type so that it has been implicitly validated +- Made newMigration pure, made migration timestamps optional +- createNewMigration now takes a Migration for greater caller control diff --git a/dbmigrations/LICENSE b/dbmigrations/LICENSE new file mode 100644 index 0000000..beb707e --- /dev/null +++ b/dbmigrations/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2009, Jonathan Daugherty. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of the contributors may not be used to endorse or + promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/dbmigrations/MOO.TXT b/dbmigrations/MOO.TXT new file mode 100644 index 0000000..fa95d40 --- /dev/null +++ b/dbmigrations/MOO.TXT @@ -0,0 +1,316 @@ + +moo: the dbmigrations management tools +------------------------------------------ + +The database type specific package that work as a companion to this +library contain tools called "moo-postgresql", "moo-mysql", "moo-sqlite", +etc. They are responsible for creating, installing, and reverting migrations +in your database backend. Since all of these command line tools offer the +exact same interface, they are described here in a single document. +The executables mentioned above are simply called "moo" for the rest of +this document. That is, given an example that reads as "moo command" you +actually have to execute "moo-postgresql command" or "moo-mysql command" +and so on. + +At present, MySQL, PostgreSQL and Sqlite3 are the only supported database +backends. + +The moo tools work by creating migration files in a specific location, +called a migration store, on your filesystem. This directory is where +all possible migrations for your project will be kept. Moo allows you to +create migrations that depend on each other. When you use moo to upgrade +your database schema, it determines which migrations are missing, what +their dependencies are, and installs the required migrations in the +correct order (based on dependencies). + +Moo works by prompting you for new migration information. It then +creates a migration YAML file (whose format is described below), which +you then edit by hand. + +When migrations are installed into your database, the set of installed +migrations is tracked by way of a migration table that is installed into +your database. + + +Using dbmigrations with MySQL +----------------------------- + +While dbmigrations supports MySQL in general, the moo executable in this +package does not work with a MySQL backend directly. MySQL support has +been factored out into a separate package, called dbmigrations-mysql. +If you want to apply migrations to a MySQL backend, please install and +use dbmigrations-mysql instead of this package. The reason is that the +MySQL support depends on MySQL Haskell libraries which in turn have +build dependencies that make it necessary for MySQL itself to be +installed during build time. + + +Getting started +--------------- + + 1. Create a directory in which to store migration files. + + 2. Set an environment variable DBM_MIGRATION_STORE to the path to the + directory you created in step 1. + + 3. Set an environment variable DBM_DATABASE to a database connection + string that is appropriate for the database type you + chose. The contents of this depend on the database type, see the + "Environment" documentation section for more information. + + 4. Run "moo upgrade". This command will not actually install any + migrations, since you have not created any, but it will attempt to + connect to your database and install a migration-tracking table. + + If this step succeeds, you should see this output: + + Database is up to date. + + 5. Create a migration with "moo new". Here is an example output: + + $ moo new hello-world + Selecting dependencies for new migration: hello-world + + Confirm: create migration 'hello-world' + (No dependencies) + Are you sure? (yn): y + Migration created successfully: ".../hello-world.yml" + + New migration will be stored with .yml extension. Older .txt migrations are supported. + + 6. Edit the migration you created. In this case, moo created a file + $DBM_MIGRATION_STORE/hello_world.yml that looks like this: + + Description: (Description here.) + Created: 2015-02-18 00:50:12.041176 UTC + Depends: + Apply: | + (Apply SQL here.) + + Revert: | + (Revert SQL here.) + + This migration has no valid apply or revert SQL yet; that's for you + to provide. You might edit the apply and revert fields as follows: + + Apply: | + CREATE TABLE foo (a int); + + Revert: | + DROP TABLE foo; + + 7. Test the new migration with "moo test". This will install the + migration in a transaction and roll it back. Here is example output: + + $ moo test hello-world + Applying: hello-world... done. + Reverting: hello-world... done. + Successfully tested migrations. + + 8. Install the migration. This can be done in one of two ways: with + "moo upgrade" or with "moo apply". Here are examples: + + $ moo apply hello-world + Applying: hello-world... done. + Successfully applied migrations. + + $ moo upgrade + Applying: hello-world... done. + Database successfully upgraded. + + 9. List installed migrations with "moo list". + + $ moo list + hello-world + + 10. Revert the migration. + + $ moo revert hello-world + Reverting: hello-world... done. + Successfully reverted migrations. + + 11. List migrations that have not been installed. + + $ moo upgrade-list + Migrations to install: + hello-world + +Configuration file format +------------------------- + +All moo commands accept a --config-file option which you can use to +specify the path to a configuration file containing your settings. This +approach is an alternative to setting environment variables. The +configuration file format uses the same environment variable names for +its fields. An example configuration is as follows: + + DBM_DATABASE = "/path/to/database.db" + DBM_MIGRATION_STORE = "/path/to/migration/store" + DBM_LINEAR_MIGRATIONS = on/off (or true/false; defaults to off) + DBM_TIMESTAMP_FILENAMES = on/off (or true/false; defaults to off) + +Alternatively, you may save your settings to "moo.cfg" file in the current +directory (probably a project root) and moo will load it automatically, if +present. Specifying --config-file disables this behavior. + +If you use a config file (either the default one or the one specified with +--config-file option) but the environment variables are set, they will +override settings from the file. You may use this to have project settings +specified in a file and use environment to specify user-local configuration +options. + +Migration file format +--------------------- + +A migration used by this package is a structured document in YAML +format containing these fields: + + Description: (optional) a textual description of the migration + + Dependencies: (required, but may be empty) a whitespace-separated + list of migration names on which the migration + depends; these names are the migration filenames + without the filename extension + + Created: The UTC date and time at which this migration was + created + + Apply: The SQL necessary to apply this migration to the + database + + Revert: (optional) The SQL necessary to revert this migration + from the database + +The format of this file is somewhat flexible; please see the YAML 1.2 +format specification for a full description of syntax features. I +recommend appending "|" to the Apply and Revert fields if they contain +multi-line SQL that you want to keep that way, e.g., + + Apply: | + CREATE OR REPLACE FUNCTION ... + ... + ... + + Revert: | + DROP TABLE foo; + DROP TABLE bar; + +Note that this is only *necessary* when concatenating the lines would +have a different meaning, e.g., + + Apply: + -- Comment here + CREATE TABLE; + +Without "|" on the "Apply:" line, the above text would be collapsed to +"-- Comment here CREATE TABLE;" which is probably not what you want. +For a full treatment of this behavior, see the YAML spec. + +Environment +----------- + +Moo depends on these environment variables / configuration file +settings: + + DBM_DATABASE + + The database connection string for the database you'll be + managing. The connection strings for each supported database type + are as follows: + + PostgreSQL: + + The format of this value is a PostgreSQL database connection + string, i.e., that described at: + + http://www.postgresql.org/docs/8.1/static/libpq.html#LIBPQ-CONNECT + + SQlite3: + + The format of this value is a filesystem path to the Sqlite3 + database to be used. + + MySQL: + + For MySQL, DBM_DATABASE should be a value of key value pairs, + where each pair is formed by `key=value`, and each pair separated + by a semicolon. Required keys are `host`, `user` and `database`, + and you can optionally supply `port` and `password`. + + Example: DBM_DATABASE="host=localhost; user=root; database=cows" + + DBM_MIGRATION_STORE + + The path to the filesystem directory where your migrations will be + kept. moo will create new migrations in this directory and use + the migrations in this directory when updating the database + schema. Initially, you'll probably set this to an extant (but + empty) directory. moo will not create it for you. + + DBM_LINEAR_MIGRATIONS + + If set to true/on, the linear migrations feature will be enabled. + Defaults to off. See 'Linear migrations' section for more details. + + DBM_TIMESTAMP_FILENAMES + + If set to true/on, the migration filename for new migrations will + have a timestamp embedded in it. + +Commands +-------- + + new : create a new migration with the given name and + save it in the migration store. This command will prompt you for + dependencies on other migrations (if the 'linear migrations' + feature is disabled) and ask for confirmation before creating the + migration in the store. If you use the --no-ask flag, the migration + will be created immediately with no dependencies. + + apply : apply the specified migration (and its + dependencies) to the database. This operation will be performed + in a single transaction which will be rolled back if an error + occurs. moo will output updates as each migration is applied. + + revert : revert the specified migration (and its + reverse dependencies -- the migrations which depend on it) from + the database. This operation will be performed in a single + transaction which will be rolled back if an error occurs. moo + will output updates as each migration is reverted. + + test : once you've created a migration, you might + find it useful to test the migration to be sure that it is + syntactically valid; the "test" command will apply the specified + migration and revert it (if revert SQL is specified in the + migration). It will perform both of these operations in a + transaction and then issue a rollback. + + upgrade: this will apply all migrations in the migration store which + have not yet been applied to the database. Each migration will be + applied with its dependenciees in the correct order. All of the + migrations will be applied together in a single transaction. By + default, this transaction is committed; if you use the --test + flag, the transaction will be rolled back, allowing you to test + the entire upgrade process. + + upgrade-list: this will list the migrations that the "upgrade" + command would apply if you were to run it. In other words, this + will list all migrations which have not yet been applied to the + database. + + reinstall: this will revert, then reapply a migration, all in a + transaction. If --test is specified, the transaction will be + rolled back; otherwise it will be committed. This is mostly + useful in development when a migration applies but is incorrect + and needs to be tweaked and reapplied. + +Linear migrations +----------------- + +If you know that every migration needs to depend on all previous ones, +consider enabling this feature. When enabled, 'moo new' will automatically +select smallest subset of existing migrations that will make the new one +indirectly depend on every other already in the store. This in turn makes +the store linear-ish (in terms of order of execution) and helps managing the +migrations by always depending on previous work. Also, this may easily be used +to see how the database changed in time. diff --git a/dbmigrations/README.md b/dbmigrations/README.md new file mode 100644 index 0000000..009c084 --- /dev/null +++ b/dbmigrations/README.md @@ -0,0 +1,50 @@ + +dbmigrations +------------ + +This package contains a library for the creation, management, and +installation of schema updates (called "migrations") for a relational +database. In particular, this package lets the migration author express +explicit dependencies between migrations. This library is accompanied +by a number database-specific packages that contain the management +tools to automatically install or revert migrations accordingly. + +This package operates on two logical entities: + + - The "backend": the relational database whose schema you want to + manage. + + - The "migration store": the collection of schema changes you want to + apply to the database. These migrations are expressed using plain + text files collected together in a single directory, although the + library is general enough to permit easy implementation of other + storage representations for migrations. + +Getting started +--------------- + +To get started, install the right database-specific dbmigrations package +for your database. Current options are: + + * `dbmigrations-postgresql` + * `dbmigrations-mysql` + * `dbmigrations-sqlite` + +Each package provides a variant of the "moo" management program +("moo-postgresql", "moo-mysql", and "moo-sqlite" respectively) to be +used to manage your database schema. See MOO.TXT for details on how to +use these tools to manage your database migrations. + +Submitting patches +------------------ + +I'll gladly consider accepting patches to this package; please do not +hesitate to submit GitHub pull requests. I'll be more likely to accept +a patch if you can follow these guidelines where appropriate: + + - Keep patches small; a single patch should make a single logical + change with minimal scope. + + - If possible, include tests with your patch. + + - If possible, include haddock with your patch. diff --git a/dbmigrations/Setup.lhs b/dbmigrations/Setup.lhs new file mode 100755 index 0000000..5bde0de --- /dev/null +++ b/dbmigrations/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/dbmigrations/dbmigrations.cabal b/dbmigrations/dbmigrations.cabal new file mode 100644 index 0000000..9f91538 --- /dev/null +++ b/dbmigrations/dbmigrations.cabal @@ -0,0 +1,169 @@ +Name: dbmigrations +Version: 2.0.0 +Synopsis: An implementation of relational database "migrations" +Description: A library and program for the creation, + management, and installation of schema updates + (called /migrations/) for a relational database. In + particular, this package lets the migration author + express explicit dependencies between migrations + and the management tool automatically installs or + reverts migrations accordingly, using transactions + for safety. + + This package is written to support a number of + different databases. For packages that support + specific databases using this library, see packages + named "dbmigrations-BACKEND". Each package + provides an executable "moo-BACKEND" for managing + migrations. Usage information for the "moo-" + executables can be found in "MOO.TXT" in this + package. + + This package also includes a conformance test suite + to ensure that backend implementations respect the + library's required semantics. + +Category: Database +Author: Jonathan Daugherty +Maintainer: Jonathan Daugherty +Build-Type: Simple +License: BSD3 +License-File: LICENSE +Cabal-Version: >= 1.10 + +Data-Files: + README.md + MOO.TXT + test/example_store/root + test/example_store/update1 + test/example_store/update2 + test/config_loading/cfg1.cfg + test/config_loading/cfg_ts.cfg + test/config_loading/invalid.cfg + test/config_loading/missing.cfg + test/config_loading/moo.cfg + test/migration_parsing/invalid_field_name.txt + test/migration_parsing/invalid_missing_required_fields.txt + test/migration_parsing/invalid_syntax.txt + test/migration_parsing/invalid_timestamp.txt + test/migration_parsing/valid_full.txt + test/migration_parsing/valid_no_depends.txt + test/migration_parsing/valid_no_desc.txt + test/migration_parsing/valid_no_revert.txt + test/migration_parsing/valid_no_timestamp.txt + test/migration_parsing/valid_with_colon.txt + test/migration_parsing/valid_with_comments.txt + test/migration_parsing/valid_with_comments2.txt + test/migration_parsing/valid_with_multiline_deps.txt + +Source-Repository head + type: git + location: git://github.com/jtdaugherty/dbmigrations.git + +Library + default-language: Haskell2010 + if impl(ghc >= 6.12.0) + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields + -fno-warn-unused-do-bind + else + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields + + Build-Depends: + base >= 4 && < 5, + HDBC >= 2.2.1, + time >= 1.4, + random >= 1.0, + containers >= 0.2, + mtl >= 2.1, + filepath >= 1.1, + directory >= 1.0, + fgl >= 5.4, + template-haskell, + yaml-light >= 0.1, + bytestring >= 0.9, + string-conversions >= 0.4, + text >= 0.11, + configurator >= 0.2, + split >= 0.2.2, + HUnit >= 1.2 + + Hs-Source-Dirs: src + Exposed-Modules: + Database.Schema.Migrations + Database.Schema.Migrations.Backend + Database.Schema.Migrations.Backend.HDBC + Database.Schema.Migrations.CycleDetection + Database.Schema.Migrations.Dependencies + Database.Schema.Migrations.Filesystem + Database.Schema.Migrations.Filesystem.Serialize + Database.Schema.Migrations.Migration + Database.Schema.Migrations.Store + Database.Schema.Migrations.Test.BackendTest + Moo.CommandHandlers + Moo.CommandInterface + Moo.CommandUtils + Moo.Core + Moo.Main + +test-suite dbmigrations-tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + Build-Depends: + base >= 4 && < 5, + dbmigrations, + time >= 1.4, + containers >= 0.2, + mtl >= 2.1, + filepath >= 1.1, + directory >= 1.0, + fgl >= 5.4, + template-haskell, + yaml-light >= 0.1, + bytestring >= 0.9, + string-conversions >= 0.4, + MissingH, + HDBC >= 2.2.1, + HUnit >= 1.2, + process >= 1.1, + configurator >= 0.2, + text >= 0.11, + split >= 0.2.2 + + other-modules: + Common + CommonTH + CycleDetectionTest + DependencyTest + FilesystemParseTest + FilesystemSerializeTest + FilesystemTest + MigrationsTest + StoreTest + InMemoryStore + LinearMigrationsTest + ConfigurationTest + + if impl(ghc >= 6.12.0) + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields + -fno-warn-unused-do-bind -Wwarn + else + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields + + Hs-Source-Dirs: test + Main-is: Main.hs + +Executable moo + default-language: Haskell2010 + Build-Depends: + base >= 4 && < 5, + configurator >= 0.2, + dbmigrations + + if impl(ghc >= 6.12.0) + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields + -fno-warn-unused-do-bind + else + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields + + Hs-Source-Dirs: programs + Main-is: Moo.hs diff --git a/dbmigrations/default.nix b/dbmigrations/default.nix new file mode 100644 index 0000000..ad3e67d --- /dev/null +++ b/dbmigrations/default.nix @@ -0,0 +1,26 @@ +{ mkDerivation, base, bytestring, configurator, containers +, directory, fgl, filepath, HDBC, HUnit, MissingH, mtl, process +, random, split, stdenv, string-conversions, template-haskell, text +, time, yaml-light +}: +mkDerivation { + pname = "dbmigrations"; + version = "2.0.0"; + src = ./.; + isLibrary = true; + isExecutable = true; + enableSeparateDataOutput = true; + libraryHaskellDepends = [ + base bytestring configurator containers directory fgl filepath HDBC + HUnit mtl random split string-conversions template-haskell text + time yaml-light + ]; + executableHaskellDepends = [ base configurator ]; + testHaskellDepends = [ + base bytestring configurator containers directory fgl filepath HDBC + HUnit MissingH mtl process split string-conversions + template-haskell text time yaml-light + ]; + description = "An implementation of relational database \"migrations\""; + license = stdenv.lib.licenses.bsd3; +} diff --git a/dbmigrations/nix/pinned.nix b/dbmigrations/nix/pinned.nix new file mode 100644 index 0000000..2aac730 --- /dev/null +++ b/dbmigrations/nix/pinned.nix @@ -0,0 +1,11 @@ +let + pkgs = import {}; +in +import ( + pkgs.fetchFromGitHub { + owner = "nixos"; + repo = "nixpkgs"; + rev = "1cd56fc68216423a0413294c8e56453166be87dd"; + sha256 = "0cihxsy5958l9nk0rlnwd1bz4ayhrp7v5bspjdrmfgwgv40j0rw3"; + } +) diff --git a/dbmigrations/programs/Moo.hs b/dbmigrations/programs/Moo.hs new file mode 100644 index 0000000..3e4d7b9 --- /dev/null +++ b/dbmigrations/programs/Moo.hs @@ -0,0 +1,17 @@ +module Main + ( main + ) +where + +import Prelude + +main :: IO () +main = do + error $ + "This package (dbmigrations) does no longer contain the executable to \ + \create, apply or revert database migrations. Please install the specific \ + \wrapper package for your database: dbmigrations-postgresql, \ + \dbmigrations-mysql, or dbmigrations-sqlite. These packages contain \ + \database-specific executables that replace the former moo executable from the \ + \dbmigrations package." + diff --git a/dbmigrations/release.nix b/dbmigrations/release.nix new file mode 100644 index 0000000..1c2ec34 --- /dev/null +++ b/dbmigrations/release.nix @@ -0,0 +1,4 @@ +let + pkgs = import ./nix/pinned.nix {}; +in + pkgs.haskellPackages.callPackage ./default.nix {} diff --git a/dbmigrations/shell.nix b/dbmigrations/shell.nix new file mode 100644 index 0000000..03291f1 --- /dev/null +++ b/dbmigrations/shell.nix @@ -0,0 +1,14 @@ +{ nixpkgs ? import ./nix/pinned.nix {} }: +let + inherit ( nixpkgs ) pkgs; + inherit ( pkgs ) haskellPackages; + + project = import ./release.nix; +in +pkgs.stdenv.mkDerivation { + name = "dbmigrations"; + buildInputs = project.env.nativeBuildInputs ++ [ + haskellPackages.cabal-install + haskellPackages.ghcid + ]; +} diff --git a/dbmigrations/src/Database/Schema/Migrations.hs b/dbmigrations/src/Database/Schema/Migrations.hs new file mode 100644 index 0000000..252a2c6 --- /dev/null +++ b/dbmigrations/src/Database/Schema/Migrations.hs @@ -0,0 +1,93 @@ +-- |This module provides a high-level interface for the rest of this +-- library. +module Database.Schema.Migrations + ( createNewMigration + , ensureBootstrappedBackend + , migrationsToApply + , migrationsToRevert + , missingMigrations + ) +where + +import Data.Text ( Text ) +import qualified Data.Set as Set +import Data.Maybe ( catMaybes ) + +import Database.Schema.Migrations.Dependencies + ( dependencies + , reverseDependencies + ) +import qualified Database.Schema.Migrations.Backend as B +import qualified Database.Schema.Migrations.Store as S +import Database.Schema.Migrations.Migration + ( Migration(..) + ) + +-- |Given a 'B.Backend' and a 'S.MigrationMap', query the backend and +-- return a list of migration names which are available in the +-- 'S.MigrationMap' but which are not installed in the 'B.Backend'. +missingMigrations :: B.Backend -> S.StoreData -> IO [Text] +missingMigrations backend storeData = do + let storeMigrationNames = map mId $ S.storeMigrations storeData + backendMigrations <- B.getMigrations backend + + return $ Set.toList $ Set.difference + (Set.fromList storeMigrationNames) + (Set.fromList backendMigrations) + +-- |Create a new migration and store it in the 'S.MigrationStore'. +createNewMigration :: S.MigrationStore -- ^ The 'S.MigrationStore' in which to create a new migration + -> Migration -- ^ The new migration + -> IO (Either String Migration) +createNewMigration store newM = do + available <- S.getMigrations store + case mId newM `elem` available of + True -> do + fullPath <- S.fullMigrationName store (mId newM) + return $ Left $ "Migration " ++ (show fullPath) ++ " already exists" + False -> do + S.saveMigration store newM + return $ Right newM + +-- |Given a 'B.Backend', ensure that the backend is ready for use by +-- bootstrapping it. This entails installing the appropriate database +-- elements to track installed migrations. If the backend is already +-- bootstrapped, this has no effect. +ensureBootstrappedBackend :: B.Backend -> IO () +ensureBootstrappedBackend backend = do + bsStatus <- B.isBootstrapped backend + case bsStatus of + True -> return () + False -> B.getBootstrapMigration backend >>= B.applyMigration backend + +-- |Given a migration mapping computed from a MigrationStore, a +-- backend, and a migration to apply, return a list of migrations to +-- apply, in order. +migrationsToApply :: S.StoreData -> B.Backend + -> Migration -> IO [Migration] +migrationsToApply storeData backend migration = do + let graph = S.storeDataGraph storeData + + allMissing <- missingMigrations backend storeData + + let deps = (dependencies graph $ mId migration) ++ [mId migration] + namesToInstall = [ e | e <- deps, e `elem` allMissing ] + loadedMigrations = catMaybes $ map (S.storeLookup storeData) namesToInstall + + return loadedMigrations + +-- |Given a migration mapping computed from a MigrationStore, a +-- backend, and a migration to revert, return a list of migrations to +-- revert, in order. +migrationsToRevert :: S.StoreData -> B.Backend + -> Migration -> IO [Migration] +migrationsToRevert storeData backend migration = do + let graph = S.storeDataGraph storeData + + allInstalled <- B.getMigrations backend + + let rDeps = (reverseDependencies graph $ mId migration) ++ [mId migration] + namesToRevert = [ e | e <- rDeps, e `elem` allInstalled ] + loadedMigrations = catMaybes $ map (S.storeLookup storeData) namesToRevert + + return loadedMigrations diff --git a/dbmigrations/src/Database/Schema/Migrations/Backend.hs b/dbmigrations/src/Database/Schema/Migrations/Backend.hs new file mode 100644 index 0000000..ffee25e --- /dev/null +++ b/dbmigrations/src/Database/Schema/Migrations/Backend.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} +module Database.Schema.Migrations.Backend + ( Backend(..) + , rootMigrationName + ) +where + +import Data.Text ( Text ) + +import Database.Schema.Migrations.Migration + ( Migration(..) ) + +-- |Backend instances should use this as the name of the migration +-- returned by getBootstrapMigration; this migration is special +-- because it cannot be reverted. +rootMigrationName :: Text +rootMigrationName = "root" + +-- |A Backend represents a database engine backend such as MySQL or +-- SQLite. A Backend supplies relatively low-level functions for +-- inspecting the backend's state, applying migrations, and reverting +-- migrations. A Backend also supplies the migration necessary to +-- "bootstrap" a backend so that it can track which migrations are +-- installed. +data Backend = + Backend { getBootstrapMigration :: IO Migration + -- ^ The migration necessary to bootstrap a database with + -- this connection interface. This might differ slightly + -- from one backend to another. + + , isBootstrapped :: IO Bool + -- ^ Returns whether the backend has been bootstrapped. A + -- backend has been bootstrapped if is capable of tracking + -- which migrations have been installed; the "bootstrap + -- migration" provided by getBootstrapMigration should + -- suffice to bootstrap the backend. + + , applyMigration :: Migration -> IO () + -- ^ Apply the specified migration on the backend. + -- applyMigration does NOT assume control of the + -- transaction, since it expects the transaction to + -- (possibly) cover more than one applyMigration operation. + -- The caller is expected to call commit at the appropriate + -- time. If the application fails, the underlying SqlError + -- is raised and a manual rollback may be necessary; for + -- this, see withTransaction from HDBC. + + , revertMigration :: Migration -> IO () + -- ^ Revert the specified migration from the backend and + -- record this action in the table which tracks installed + -- migrations. revertMigration does NOT assume control of + -- the transaction, since it expects the transaction to + -- (possibly) cover more than one revertMigration operation. + -- The caller is expected to call commit at the appropriate + -- time. If the revert fails, the underlying SqlError is + -- raised and a manual rollback may be necessary; for this, + -- see withTransaction from HDBC. If the specified migration + -- does not supply a revert instruction, this has no effect + -- other than bookkeeping. + + , getMigrations :: IO [Text] + -- ^ Returns a list of installed migration names from the + -- backend. + + , commitBackend :: IO () + -- ^ Commit changes to the backend. + + , rollbackBackend :: IO () + -- ^ Revert changes made to the backend since the current + -- transaction began. + + , disconnectBackend :: IO () + -- ^ Disconnect from the backend. + } + +instance Show Backend where + show _ = "dbmigrations backend" diff --git a/dbmigrations/src/Database/Schema/Migrations/Backend/HDBC.hs b/dbmigrations/src/Database/Schema/Migrations/Backend/HDBC.hs new file mode 100644 index 0000000..2d649ea --- /dev/null +++ b/dbmigrations/src/Database/Schema/Migrations/Backend/HDBC.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} +module Database.Schema.Migrations.Backend.HDBC + ( hdbcBackend + ) +where + +import Database.HDBC (IConnection (getTables, run, runRaw), + commit, disconnect, + fromSql, quickQuery', + rollback, toSql) + +import Database.Schema.Migrations.Backend (Backend (..), + rootMigrationName) +import Database.Schema.Migrations.Migration (Migration (..), + newMigration) + +import Data.String.Conversions (cs) +import Data.Text (Text) + +import Data.Time.Clock (getCurrentTime) + +migrationTableName :: Text +migrationTableName = "installed_migrations" + +createSql :: Text +createSql = "CREATE TABLE " <> migrationTableName <> " (migration_id TEXT)" + +revertSql :: Text +revertSql = "DROP TABLE " <> migrationTableName + +-- |General Backend constructor for all HDBC connection implementations. +hdbcBackend :: (IConnection conn) => conn -> Backend +hdbcBackend conn = + Backend { isBootstrapped = elem (cs migrationTableName) <$> getTables conn + , getBootstrapMigration = + do + ts <- getCurrentTime + return $ (newMigration rootMigrationName) + { mApply = createSql + , mRevert = Just revertSql + , mDesc = Just "Migration table installation" + , mTimestamp = Just ts + } + + , applyMigration = \m -> do + runRaw conn (cs $ mApply m) + _ <- run conn (cs $ "INSERT INTO " <> migrationTableName <> + " (migration_id) VALUES (?)") [toSql $ mId m] + return () + + , revertMigration = \m -> do + case mRevert m of + Nothing -> return () + Just query -> runRaw conn (cs query) + -- Remove migration from installed_migrations in either case. + _ <- run conn (cs $ "DELETE FROM " <> migrationTableName <> + " WHERE migration_id = ?") [toSql $ mId m] + return () + + , getMigrations = do + results <- quickQuery' conn (cs $ "SELECT migration_id FROM " <> migrationTableName) [] + return $ map (fromSql . head) results + + , commitBackend = commit conn + + , rollbackBackend = rollback conn + + , disconnectBackend = disconnect conn + } diff --git a/dbmigrations/src/Database/Schema/Migrations/CycleDetection.hs b/dbmigrations/src/Database/Schema/Migrations/CycleDetection.hs new file mode 100644 index 0000000..7dcb073 --- /dev/null +++ b/dbmigrations/src/Database/Schema/Migrations/CycleDetection.hs @@ -0,0 +1,64 @@ +module Database.Schema.Migrations.CycleDetection + ( hasCycle + ) +where + +import Data.Graph.Inductive.Graph + ( Graph(..) + , Node + , nodes + , edges + ) + +import Control.Monad.State ( State, evalState, gets, get, put ) +import Control.Monad ( forM ) + +import Data.Maybe ( fromJust ) +import Data.List ( findIndex ) + +data Mark = White | Gray | Black +type CycleDetectionState = [(Node, Mark)] + +-- Cycle detection algorithm taken from http://www.cs.berkeley.edu/~kamil/teaching/sp03/041403.pdf +hasCycle :: Graph g => g a b -> Bool +hasCycle g = evalState (hasCycle' g) [(n, White) | n <- nodes g] + +getMark :: Int -> State CycleDetectionState Mark +getMark n = gets (fromJust . lookup n) + +replace :: [a] -> Int -> a -> [a] +replace elems index val + | index > length elems = error "replacement index too large" + | otherwise = (take index elems) ++ + [val] ++ + (reverse $ take ((length elems) - (index + 1)) $ reverse elems) + +setMark :: Int -> Mark -> State CycleDetectionState () +setMark n mark = do + st <- get + let index = fromJust $ findIndex (\(n', _) -> n' == n) st + put $ replace st index (n, mark) + +hasCycle' :: Graph g => g a b -> State CycleDetectionState Bool +hasCycle' g = do + result <- forM (nodes g) $ \n -> do + m <- getMark n + case m of + White -> visit g n + _ -> return False + return $ or result + +visit :: Graph g => g a b -> Node -> State CycleDetectionState Bool +visit g n = do + setMark n Gray + result <- forM [ v | (u,v) <- edges g, u == n ] $ \node -> do + m <- getMark node + case m of + Gray -> return True + White -> visit g node + _ -> return False + case or result of + True -> return True + False -> do + setMark n Black + return False diff --git a/dbmigrations/src/Database/Schema/Migrations/Dependencies.hs b/dbmigrations/src/Database/Schema/Migrations/Dependencies.hs new file mode 100644 index 0000000..371ede5 --- /dev/null +++ b/dbmigrations/src/Database/Schema/Migrations/Dependencies.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- |This module types and functions for representing a dependency +-- graph of arbitrary objects and functions for querying such graphs +-- to get dependency and reverse dependency information. +module Database.Schema.Migrations.Dependencies + ( Dependable(..) + , DependencyGraph(..) + , mkDepGraph + , dependencies + , reverseDependencies + ) +where + +import Data.Graph.Inductive.Graph (Graph (..), Node, + edges, lab, nodes, + pre, suc) +import Data.Graph.Inductive.PatriciaTree (Gr) +import Data.Maybe (fromJust) +import Data.Text (Text) + +import Database.Schema.Migrations.CycleDetection (hasCycle) + +-- |'Dependable' objects supply a representation of their identifiers, +-- and a list of other objects upon which they depend. +class (Eq a, Ord a) => Dependable a where + -- |The identifiers of the objects on which @a@ depends. + depsOf :: a -> [Text] + -- |The identifier of a 'Dependable' object. + depId :: a -> Text + +-- |A 'DependencyGraph' represents a collection of objects together +-- with a graph of their dependency relationships. This is intended +-- to be used with instances of 'Dependable'. +data DependencyGraph a = DG + { depGraphObjectMap :: [(a, Int)] + -- ^ A mapping of 'Dependable' objects to + , depGraphNameMap :: [(Text, Int)] + -- ^ A mapping of 'Dependable' object + , depGraph :: Gr Text Text + -- ^ A directed 'Gr' (graph) of the + } + +instance (Eq a) => Eq (DependencyGraph a) where + g1 == g2 = ((nodes $ depGraph g1) == (nodes $ depGraph g2) && + (edges $ depGraph g1) == (edges $ depGraph g2)) + +instance (Show a) => Show (DependencyGraph a) where + show g = "(" ++ (show $ nodes $ depGraph g) ++ ", " ++ (show $ edges $ depGraph g) ++ ")" + +-- XXX: provide details about detected cycles +-- |Build a dependency graph from a list of 'Dependable's. Return the +-- graph on success or return an error message if the graph cannot be +-- constructed (e.g., if the graph contains a cycle). +mkDepGraph :: (Dependable a) => [a] -> Either String (DependencyGraph a) +mkDepGraph objects = if hasCycle theGraph + then Left "Invalid dependency graph; cycle detected" + else Right $ DG { depGraphObjectMap = ids + , depGraphNameMap = names + , depGraph = theGraph + } + where + theGraph = mkGraph n e + n = [ (fromJust $ lookup o ids, depId o) | o <- objects ] + e = [ ( fromJust $ lookup o ids + , fromJust $ lookup d ids + , depId o <> " -> " <> depId d) | o <- objects, d <- depsOf' o ] + depsOf' o = map (\i -> fromJust $ lookup i objMap) $ depsOf o + + objMap = map (\o -> (depId o, o)) objects + ids = zip objects [1..] + names = map (\(o,i) -> (depId o, i)) ids + +type NextNodesFunc = Gr Text Text -> Node -> [Node] + +cleanLDups :: (Eq a) => [a] -> [a] +cleanLDups [] = [] +cleanLDups [e] = [e] +cleanLDups (e:es) = if e `elem` es then (cleanLDups es) else (e:cleanLDups es) + +-- |Given a dependency graph and an ID, return the IDs of objects that +-- the object depends on. IDs are returned with least direct +-- dependencies first (i.e., the apply order). +dependencies :: (Dependable d) => DependencyGraph d -> Text -> [Text] +dependencies g m = reverse $ cleanLDups $ dependenciesWith suc g m + +-- |Given a dependency graph and an ID, return the IDs of objects that +-- depend on it. IDs are returned with least direct reverse +-- dependencies first (i.e., the revert order). +reverseDependencies :: (Dependable d) => DependencyGraph d -> Text -> [Text] +reverseDependencies g m = reverse $ cleanLDups $ dependenciesWith pre g m + +dependenciesWith :: (Dependable d) => NextNodesFunc -> DependencyGraph d -> Text -> [Text] +dependenciesWith nextNodes dg@(DG _ nMap theGraph) name = + let lookupId = fromJust $ lookup name nMap + depNodes = nextNodes theGraph lookupId + recurse theNodes = map (dependenciesWith nextNodes dg) theNodes + getLabel node = fromJust $ lab theGraph node + labels = map getLabel depNodes + in labels ++ (concat $ recurse labels) diff --git a/dbmigrations/src/Database/Schema/Migrations/Filesystem.hs b/dbmigrations/src/Database/Schema/Migrations/Filesystem.hs new file mode 100644 index 0000000..a4e42ee --- /dev/null +++ b/dbmigrations/src/Database/Schema/Migrations/Filesystem.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- |This module provides a type for interacting with a +-- filesystem-backed 'MigrationStore'. +module Database.Schema.Migrations.Filesystem + ( FilesystemStoreSettings(..) + , migrationFromFile + , migrationFromPath + , filesystemStore + ) +where + +import Prelude + +import qualified Data.ByteString.Char8 as BSC +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Data.Text as T +import System.Directory (doesFileExist, getDirectoryContents) +import System.FilePath (dropExtension, + takeBaseName, + takeExtension, + ()) + +import qualified Data.Map as Map +import Data.Time () +import Data.Time.Clock (UTCTime) +import Data.Typeable (Typeable) + +import Control.Exception (Exception (..), + IOException, + catch, throw) +import Control.Monad (filterM) + +import Data.Yaml.YamlLight + +import Database.Schema.Migrations.Filesystem.Serialize +import Database.Schema.Migrations.Migration (Migration (..), + emptyMigration) +import Database.Schema.Migrations.Store + +type FieldProcessor = Text -> Migration -> Maybe Migration + +data FilesystemStoreSettings = FSStore + { storePath :: FilePath + } + +data FilesystemStoreError = FilesystemStoreError String + deriving (Show, Typeable) + +instance Exception FilesystemStoreError + +throwFS :: String -> a +throwFS = throw . FilesystemStoreError + +filenameExtension :: String +filenameExtension = ".yml" + +filenameExtensionTxt :: String +filenameExtensionTxt = ".txt" + +filesystemStore :: FilesystemStoreSettings -> MigrationStore +filesystemStore s = + MigrationStore { fullMigrationName = fmap addNewMigrationExtension . fsFullMigrationName s + + , loadMigration = \theId -> migrationFromFile s theId + + , getMigrations = do + contents <- getDirectoryContents $ storePath s + let migrationFilenames = [ f | f <- contents, isMigrationFilename f ] + fullPaths = [ (f, storePath s f) | f <- migrationFilenames ] + existing <- filterM (\(_, full) -> doesFileExist full) fullPaths + return [ cs $ dropExtension short | (short, _) <- existing ] + + , saveMigration = \m -> do + filename <- fsFullMigrationName s $ mId m + BSC.writeFile (cs $ addNewMigrationExtension filename) $ serializeMigration m + } + +addNewMigrationExtension :: FilePath -> FilePath +addNewMigrationExtension path = path <> filenameExtension + +addMigrationExtension :: FilePath -> String -> FilePath +addMigrationExtension path ext = path <> ext + +-- |Build path to migrations without extension. +fsFullMigrationName :: FilesystemStoreSettings -> Text -> IO FilePath +fsFullMigrationName s name = return $ storePath s cs name + +isMigrationFilename :: String -> Bool +isMigrationFilename path = (cs $ takeExtension path) `elem` [filenameExtension, filenameExtensionTxt] + +-- |Given a store and migration name, read and parse the associated +-- migration and return the migration if successful. Otherwise return +-- a parsing error message. +migrationFromFile :: FilesystemStoreSettings -> Text -> IO (Either String Migration) +migrationFromFile store name = + fsFullMigrationName store (cs name) >>= migrationFromPath + +-- |Given a filesystem path, read and parse the file as a migration +-- return the 'Migration' if successful. Otherwise return a parsing +-- error message. +migrationFromPath :: FilePath -> IO (Either String Migration) +migrationFromPath path = do + let name = cs $ takeBaseName path + (Right <$> process name) `catch` (\(FilesystemStoreError s) -> return $ Left $ "Could not parse migration " ++ path ++ ":" ++ s) + + where + readMigrationFile = do + ymlExists <- doesFileExist (addNewMigrationExtension path) + if ymlExists + then parseYamlFile (addNewMigrationExtension path) `catch` (\(e::IOException) -> throwFS $ show e) + else parseYamlFile (addMigrationExtension path filenameExtensionTxt) `catch` (\(e::IOException) -> throwFS $ show e) + + process name = do + yaml <- readMigrationFile + + -- Convert yaml structure into basic key/value map + let fields = getFields yaml + missing = missingFields fields + + case length missing of + 0 -> do + let newM = emptyMigration name + case migrationFromFields newM fields of + Nothing -> throwFS $ "Error in " ++ (show path) ++ ": unrecognized field found" + Just m -> return m + _ -> throwFS $ "Error in " ++ (show path) ++ ": missing required field(s): " ++ (show missing) + +getFields :: YamlLight -> [(Text, Text)] +getFields (YMap mp) = map toPair $ Map.assocs mp + where + toPair :: (YamlLight, YamlLight) -> (Text, Text) + toPair (YStr k, YStr v) = (cs k, cs v) + toPair (k, v) = throwFS $ "Error in YAML input; expected string key and string value, got " ++ (show (k, v)) +getFields _ = throwFS "Error in YAML input; expected mapping" + +missingFields :: [(Text, Text)] -> [Text] +missingFields fs = + [ k | k <- requiredFields, not (k `elem` inputStrings) ] + where + inputStrings = map fst fs + +-- |Given a migration and a list of parsed migration fields, update +-- the migration from the field values for recognized fields. +migrationFromFields :: Migration -> [(Text, Text)] -> Maybe Migration +migrationFromFields m [] = Just m +migrationFromFields m ((name, value):rest) = do + processor <- lookup name fieldProcessors + newM <- processor value m + migrationFromFields newM rest + +requiredFields :: [Text] +requiredFields = [ "Apply" + , "Depends" + ] + +fieldProcessors :: [(Text, FieldProcessor)] +fieldProcessors = [ ("Created", setTimestamp ) + , ("Description", setDescription ) + , ("Apply", setApply ) + , ("Revert", setRevert ) + , ("Depends", setDepends ) + ] + +setTimestamp :: FieldProcessor +setTimestamp value m = do + ts <- case readTimestamp value of + [(t, _)] -> return t + _ -> fail "expected one valid parse" + return $ m { mTimestamp = Just ts } + +readTimestamp :: Text -> [(UTCTime, String)] +readTimestamp = reads . cs + +setDescription :: FieldProcessor +setDescription desc m = Just $ m { mDesc = Just desc } + +setApply :: FieldProcessor +setApply apply m = Just $ m { mApply = apply } + +setRevert :: FieldProcessor +setRevert revert m = Just $ m { mRevert = Just revert } + +setDepends :: FieldProcessor +setDepends depString m = Just $ m { mDeps = T.words depString } diff --git a/dbmigrations/src/Database/Schema/Migrations/Filesystem/Serialize.hs b/dbmigrations/src/Database/Schema/Migrations/Filesystem/Serialize.hs new file mode 100644 index 0000000..17845b4 --- /dev/null +++ b/dbmigrations/src/Database/Schema/Migrations/Filesystem/Serialize.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} +module Database.Schema.Migrations.Filesystem.Serialize + ( serializeMigration + ) +where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Maybe (catMaybes) +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time () + +import Database.Schema.Migrations.Migration (Migration (..)) + +type FieldSerializer = Migration -> Maybe ByteString + +fieldSerializers :: [FieldSerializer] +fieldSerializers = [ serializeDesc + , serializeTimestamp + , serializeDepends + , serializeApply + , serializeRevert + ] + +serializeDesc :: FieldSerializer +serializeDesc m = + case mDesc m of + Nothing -> Nothing + Just desc -> Just . cs $ "Description: " <> desc + +serializeTimestamp :: FieldSerializer +serializeTimestamp m = + case mTimestamp m of + Nothing -> Nothing + Just ts -> Just $ "Created: " <> (cs . show $ ts) + +serializeDepends :: FieldSerializer +serializeDepends m = Just . cs $ "Depends: " <> (T.intercalate " " $ mDeps m) + +serializeRevert :: FieldSerializer +serializeRevert m = + case mRevert m of + Nothing -> Nothing + Just revert -> Just $ "Revert: |\n" <> + (serializeMultiline revert) + +serializeApply :: FieldSerializer +serializeApply m = Just $ "Apply: |\n" <> (serializeMultiline $ mApply m) + +commonPrefix :: Text -> Text -> Text +commonPrefix a b = cs . map fst $ takeWhile (uncurry (==)) (T.zip a b) + +commonPrefixLines :: [Text] -> Text +commonPrefixLines [] = "" +commonPrefixLines theLines = foldl1 commonPrefix theLines + +serializeMultiline :: Text -> ByteString +serializeMultiline s = + let sLines = T.lines s + prefix = case T.head $ commonPrefixLines sLines of + -- If the lines already have a common prefix that + -- begins with whitespace, no new prefix is + -- necessary. + ' ' -> "" + -- Otherwise, use a new prefix of two spaces. + _ -> " " + + in cs . T.unlines $ map (prefix <>) sLines + +serializeMigration :: Migration -> ByteString +serializeMigration m = BS.intercalate "\n" fields + where + fields = catMaybes [ f m | f <- fieldSerializers ] diff --git a/dbmigrations/src/Database/Schema/Migrations/Migration.hs b/dbmigrations/src/Database/Schema/Migrations/Migration.hs new file mode 100644 index 0000000..8222323 --- /dev/null +++ b/dbmigrations/src/Database/Schema/Migrations/Migration.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} +module Database.Schema.Migrations.Migration + ( Migration(..) + , newMigration + , emptyMigration + ) +where + +import Database.Schema.Migrations.Dependencies + +import Data.Text ( Text ) +import Data.Time () -- for UTCTime Show instance +import qualified Data.Time.Clock as Clock + +data Migration = Migration { mTimestamp :: Maybe Clock.UTCTime + , mId :: Text + , mDesc :: Maybe Text + , mApply :: Text + , mRevert :: Maybe Text + , mDeps :: [Text] + } + deriving (Eq, Show, Ord) + +instance Dependable Migration where + depsOf = mDeps + depId = mId + +emptyMigration :: Text -> Migration +emptyMigration name = + Migration { mTimestamp = Nothing + , mId = name + , mApply = "" + , mRevert = Nothing + , mDesc = Nothing + , mDeps = [] + } + +newMigration :: Text -> Migration +newMigration theId = + (emptyMigration theId) + { mApply = "(Apply SQL here.)" + , mDesc = Just "(Describe migration here.)" + } diff --git a/dbmigrations/src/Database/Schema/Migrations/Store.hs b/dbmigrations/src/Database/Schema/Migrations/Store.hs new file mode 100644 index 0000000..5d832c1 --- /dev/null +++ b/dbmigrations/src/Database/Schema/Migrations/Store.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +-- |This module provides an abstraction for a /migration store/, a +-- facility in which 'Migration's can be stored and from which they +-- can be loaded. This module also provides functions for taking +-- 'Migration's from a store and converting them into the appropriate +-- intermediate types for use with the rest of this library. +module Database.Schema.Migrations.Store + ( MigrationStore(..) + , MapValidationError(..) + , StoreData(..) + , MigrationMap + + -- * High-level Store API + , loadMigrations + , storeMigrations + , storeLookup + + -- * Miscellaneous Functions + , depGraphFromMapping + , validateMigrationMap + , validateSingleMigration + , leafMigrations + ) +where + +import Control.Monad (mzero) +import Data.Graph.Inductive.Graph (indeg, labNodes) +import qualified Data.Map as Map +import Data.Maybe (isJust) +import Data.Text (Text) + +import Database.Schema.Migrations.Dependencies (DependencyGraph (..), + depsOf, mkDepGraph) +import Database.Schema.Migrations.Migration (Migration (..)) + +-- |A mapping from migration name to 'Migration'. This is exported +-- for testing purposes, but you'll want to interface with this +-- through the encapsulating 'StoreData' type. +type MigrationMap = Map.Map Text Migration + +data StoreData = StoreData + { storeDataMapping :: MigrationMap + , storeDataGraph :: DependencyGraph Migration + } + +-- |The type of migration storage facilities. A MigrationStore is a +-- facility in which new migrations can be created, and from which +-- existing migrations can be loaded. +data MigrationStore = MigrationStore + { loadMigration :: Text -> IO (Either String Migration) + -- ^ Load a migration from the store. + , saveMigration :: Migration -> IO () + -- ^ Save a migration to the store. + , getMigrations :: IO [Text] + -- ^ Return a list of all available migrations' + , fullMigrationName :: Text -> IO FilePath + -- ^ Return the full representation of a given + } + +-- |A type for types of validation errors for migration maps. +data MapValidationError = DependencyReferenceError Text Text + | DependencyGraphError String + | InvalidMigration String + deriving (Eq) + +instance Show MapValidationError where + show (DependencyReferenceError from to) = + "Migration " ++ (show from) ++ " references nonexistent dependency " ++ show to + show (DependencyGraphError msg) = + "There was an error constructing the dependency graph: " ++ msg + show (InvalidMigration msg) = + "There was an error loading a migration: " ++ msg + +-- |A convenience function for extracting the list of 'Migration's +-- extant in the specified 'StoreData'. +storeMigrations :: StoreData -> [Migration] +storeMigrations storeData = + Map.elems $ storeDataMapping storeData + +-- |A convenience function for looking up a 'Migration' by name in the +-- specified 'StoreData'. +storeLookup :: StoreData -> Text -> Maybe Migration +storeLookup storeData migrationName = + Map.lookup migrationName $ storeDataMapping storeData + +-- |Load migrations from the specified 'MigrationStore', validate the +-- loaded migrations, and return errors or a 'MigrationMap' on +-- success. Generally speaking, this will be the first thing you +-- should call once you have constructed a 'MigrationStore'. +loadMigrations :: MigrationStore -> IO (Either [MapValidationError] StoreData) +loadMigrations store = do + migrations <- getMigrations store + loadedWithErrors <- mapM (\name -> loadMigration store name) migrations + + let mMap = Map.fromList $ [ (mId e, e) | e <- loaded ] + validationErrors = validateMigrationMap mMap + (loaded, loadErrors) = sortResults loadedWithErrors ([], []) + allErrors = validationErrors ++ (InvalidMigration <$> loadErrors) + + sortResults [] v = v + sortResults (Left e:rest) (ms, es) = sortResults rest (ms, e:es) + sortResults (Right m:rest) (ms, es) = sortResults rest (m:ms, es) + + case null allErrors of + False -> return $ Left allErrors + True -> do + -- Construct a dependency graph and, if that succeeds, return + -- StoreData. + case depGraphFromMapping mMap of + Left e -> return $ Left [DependencyGraphError e] + Right gr -> return $ Right StoreData { storeDataMapping = mMap + , storeDataGraph = gr + } + +-- |Validate a migration map. Returns zero or more validation errors. +validateMigrationMap :: MigrationMap -> [MapValidationError] +validateMigrationMap mMap = do + validateSingleMigration mMap =<< snd <$> Map.toList mMap + +-- |Validate a single migration. Looks up the migration's +-- dependencies in the specified 'MigrationMap' and returns a +-- 'MapValidationError' for each one that does not exist in the map. +validateSingleMigration :: MigrationMap -> Migration -> [MapValidationError] +validateSingleMigration mMap m = do + depId <- depsOf m + if isJust $ Map.lookup depId mMap then + mzero else + return $ DependencyReferenceError (mId m) depId + +-- |Create a 'DependencyGraph' from a 'MigrationMap'; returns Left if +-- the dependency graph cannot be constructed (e.g., due to a +-- dependency cycle) or Right on success. Generally speaking, you +-- won't want to use this directly; use 'loadMigrations' instead. +depGraphFromMapping :: MigrationMap -> Either String (DependencyGraph Migration) +depGraphFromMapping mapping = mkDepGraph $ Map.elems mapping + +-- |Finds migrations that no other migration depends on (effectively finds all +-- vertices with in-degree equal to zero). +leafMigrations :: StoreData -> [Text] +leafMigrations s = [l | (n, l) <- labNodes g, indeg g n == 0] + where g = depGraph $ storeDataGraph s diff --git a/dbmigrations/src/Database/Schema/Migrations/Test/BackendTest.hs b/dbmigrations/src/Database/Schema/Migrations/Test/BackendTest.hs new file mode 100644 index 0000000..a5a7c45 --- /dev/null +++ b/dbmigrations/src/Database/Schema/Migrations/Test/BackendTest.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | A test that is not executed as part of this package's test suite but rather +-- acts as a conformance test suit for database specific backend +-- implementations. All backend specific executable packages are expected to +-- have a test suite that runs this test. +module Database.Schema.Migrations.Test.BackendTest + ( BackendConnection (..) + , tests + ) where + +import Data.ByteString ( ByteString ) + +import Control.Monad ( forM_ ) +import Test.HUnit + +import Database.Schema.Migrations.Migration ( Migration(..), newMigration ) +import Database.Schema.Migrations.Backend ( Backend(..) ) + +-- | A typeclass for database connections that needs to implemented for each +-- specific database type to use this test. +class BackendConnection c where + + -- | Whether this backend supports transactional DDL; if it doesn't, + -- we'll skip any tests that rely on that behavior. + supportsTransactionalDDL :: c -> Bool + + -- | Commits the current transaction. + commit :: c -> IO () + + -- | Executes an IO action inside a transaction. + withTransaction :: c -> (c -> IO a) -> IO a + + -- | Retrieves a list of all tables in the current database/scheme. + getTables :: c -> IO [ByteString] + + catchAll :: c -> (IO a -> IO a -> IO a) + + -- | Returns a backend instance. + makeBackend :: c -> Backend + +testSuite :: BackendConnection bc => Bool -> [bc -> IO ()] +testSuite transactDDL = + [ isBootstrappedFalseTest + , bootstrapTest + , isBootstrappedTrueTest + , if transactDDL then applyMigrationFailure else (const $ return ()) + , applyMigrationSuccess + , revertMigrationFailure + , revertMigrationNothing + , revertMigrationJust + ] + +tests :: BackendConnection bc => bc -> IO () +tests conn = do + let acts = testSuite $ supportsTransactionalDDL conn + forM_ acts $ \act -> do + commit conn + act conn + +bootstrapTest :: BackendConnection bc => bc -> IO () +bootstrapTest conn = do + let backend = makeBackend conn + bs <- getBootstrapMigration backend + applyMigration backend bs + assertEqual "installed_migrations table exists" ["installed_migrations"] =<< getTables conn + assertEqual "successfully bootstrapped" [mId bs] =<< getMigrations backend + +isBootstrappedTrueTest :: BackendConnection bc => bc -> IO () +isBootstrappedTrueTest conn = do + result <- isBootstrapped $ makeBackend conn + assertBool "Bootstrapped check" result + +isBootstrappedFalseTest :: BackendConnection bc => bc -> IO () +isBootstrappedFalseTest conn = do + result <- isBootstrapped $ makeBackend conn + assertBool "Bootstrapped check" $ not result + +ignoreSqlExceptions :: BackendConnection bc => bc -> IO a -> IO (Maybe a) +ignoreSqlExceptions conn act = + (catchAll conn) + (act >>= return . Just) + (return Nothing) + +applyMigrationSuccess :: BackendConnection bc => bc -> IO () +applyMigrationSuccess conn = do + let backend = makeBackend conn + + let m1 = (newMigration "validMigration") { mApply = "CREATE TABLE valid1 (a int)" } + + -- Apply the migrations, ignore exceptions + withTransaction conn $ \conn' -> applyMigration (makeBackend conn') m1 + + -- Check that none of the migrations were installed + assertEqual "Installed migrations" ["root", "validMigration"] =<< getMigrations backend + assertEqual "Installed tables" ["installed_migrations", "valid1"] =<< getTables conn + +-- |Does a failure to apply a migration imply a transaction rollback? +applyMigrationFailure :: BackendConnection bc => bc -> IO () +applyMigrationFailure conn = do + let backend = makeBackend conn + + let m1 = (newMigration "second") { mApply = "CREATE TABLE validButTemporary (a int)" } + m2 = (newMigration "third") { mApply = "INVALID SQL" } + + -- Apply the migrations, ignore exceptions + _ <- ignoreSqlExceptions conn $ withTransaction conn $ \conn' -> do + let backend' = makeBackend conn' + applyMigration backend' m1 + applyMigration backend' m2 + + -- Check that none of the migrations were installed + assertEqual "Installed migrations" ["root"] =<< getMigrations backend + assertEqual "Installed tables" ["installed_migrations"] =<< getTables conn + +revertMigrationFailure :: BackendConnection bc => bc -> IO () +revertMigrationFailure conn = do + let backend = makeBackend conn + + let m1 = (newMigration "second") { mApply = "CREATE TABLE validRMF (a int)" + , mRevert = Just "DROP TABLE validRMF"} + m2 = (newMigration "third") { mApply = "alter table validRMF add column b int" + , mRevert = Just "INVALID REVERT SQL"} + + applyMigration backend m1 + applyMigration backend m2 + + installedBeforeRevert <- getMigrations backend + + commitBackend backend + + -- Revert the migrations, ignore exceptions; the revert will fail, + -- but withTransaction will roll back. + _ <- ignoreSqlExceptions conn $ withTransaction conn $ \conn' -> do + let backend' = makeBackend conn' + revertMigration backend' m2 + revertMigration backend' m1 + + -- Check that none of the migrations were reverted + assertEqual "successfully roll back failed revert" installedBeforeRevert + =<< getMigrations backend + +revertMigrationNothing :: BackendConnection bc => bc -> IO () +revertMigrationNothing conn = do + let backend = makeBackend conn + + let m1 = (newMigration "second") { mApply = "create table revert_nothing (a int)" + , mRevert = Nothing } + + applyMigration backend m1 + + installedAfterApply <- getMigrations backend + assertBool "Check that the migration was applied" $ "second" `elem` installedAfterApply + + -- Revert the migration, which should do nothing EXCEPT remove it + -- from the installed list + revertMigration backend m1 + + installed <- getMigrations backend + assertBool "Check that the migration was reverted" $ not $ "second" `elem` installed + +revertMigrationJust :: BackendConnection bc => bc -> IO () +revertMigrationJust conn = do + let name = "revertable" + backend = makeBackend conn + + let m1 = (newMigration name) { mApply = "CREATE TABLE the_test_table (a int)" + , mRevert = Just "DROP TABLE the_test_table" } + + applyMigration backend m1 + + installedAfterApply <- getMigrations backend + assertBool "Check that the migration was applied" $ name `elem` installedAfterApply + + -- Revert the migration, which should do nothing EXCEPT remove it + -- from the installed list + revertMigration backend m1 + + installed <- getMigrations backend + assertBool "Check that the migration was reverted" $ not $ name `elem` installed diff --git a/dbmigrations/src/Moo/CommandHandlers.hs b/dbmigrations/src/Moo/CommandHandlers.hs new file mode 100644 index 0000000..4a90175 --- /dev/null +++ b/dbmigrations/src/Moo/CommandHandlers.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +module Moo.CommandHandlers where + +import Data.String.Conversions (cs) + +import Control.Monad (forM_, when) +import Control.Monad.Reader (asks) +import Control.Monad.Trans (liftIO) +import Data.Maybe (isJust) +import qualified Data.Time.Clock as Clock +import Moo.CommandUtils +import Moo.Core +import System.Exit (ExitCode (..), + exitSuccess, exitWith) + +import Database.Schema.Migrations +import Database.Schema.Migrations.Backend +import Database.Schema.Migrations.Migration +import Database.Schema.Migrations.Store hiding (getMigrations) + +newCommand :: CommandHandler +newCommand storeData = do + required <- asks _appRequiredArgs + store <- asks _appStore + linear <- asks _appLinearMigrations + timestamp <- asks _appTimestampFilenames + timeString <- (<>"_") <$> liftIO getCurrentTimestamp + + let [migrationId] = if timestamp + then fmap (timeString<>) required + else required + noAsk <- _noAsk <$> asks _appOptions + + liftIO $ do + fullPath <- fullMigrationName store migrationId + when (isJust $ storeLookup storeData migrationId) $ + do + putStrLn $ "Migration " <> (show fullPath) ++ " already exists" + exitWith (ExitFailure 1) + + -- Default behavior: ask for dependencies if linear mode is disabled + deps <- if linear then (return $ leafMigrations storeData) else + if noAsk then (return []) else + do + putStrLn . cs $ "Selecting dependencies for new \ + \migration: " <> migrationId + interactiveAskDeps storeData + + result <- if noAsk then (return True) else + (confirmCreation migrationId deps) + + case result of + True -> do + now <- Clock.getCurrentTime + status <- createNewMigration store $ (newMigration migrationId) { mDeps = deps + , mTimestamp = Just now + } + case status of + Left e -> putStrLn e >> (exitWith (ExitFailure 1)) + Right _ -> putStrLn $ "Migration created successfully: " ++ + show fullPath + False -> do + putStrLn "Migration creation cancelled." + +upgradeCommand :: CommandHandler +upgradeCommand storeData = do + isTesting <- _test <$> asks _appOptions + withBackend $ \backend -> do + ensureBootstrappedBackend backend >> commitBackend backend + migrationNames <- missingMigrations backend storeData + when (null migrationNames) $ do + putStrLn "Database is up to date." + exitSuccess + forM_ migrationNames $ \migrationName -> do + m <- lookupMigration storeData migrationName + apply m storeData backend False + case isTesting of + True -> do + rollbackBackend backend + putStrLn "Upgrade test successful." + False -> do + commitBackend backend + putStrLn "Database successfully upgraded." + +upgradeListCommand :: CommandHandler +upgradeListCommand storeData = do + withBackend $ \backend -> do + ensureBootstrappedBackend backend >> commitBackend backend + migrationNames <- missingMigrations backend storeData + when (null migrationNames) $ do + putStrLn "Database is up to date." + exitSuccess + putStrLn "Migrations to install:" + forM_ migrationNames (putStrLn . cs . (" " <>)) + +reinstallCommand :: CommandHandler +reinstallCommand storeData = do + isTesting <- _test <$> asks _appOptions + required <- asks _appRequiredArgs + let [migrationId] = required + + withBackend $ \backend -> do + ensureBootstrappedBackend backend >> commitBackend backend + m <- lookupMigration storeData migrationId + + _ <- revert m storeData backend + _ <- apply m storeData backend True + + case isTesting of + False -> do + commitBackend backend + putStrLn "Migration successfully reinstalled." + True -> do + rollbackBackend backend + putStrLn "Reinstall test successful." + +listCommand :: CommandHandler +listCommand _ = do + withBackend $ \backend -> do + ensureBootstrappedBackend backend >> commitBackend backend + ms <- getMigrations backend + forM_ ms $ \m -> + when (not $ m == rootMigrationName) $ putStrLn . cs $ m + +applyCommand :: CommandHandler +applyCommand storeData = do + isTesting <- _test <$> asks _appOptions + required <- asks _appRequiredArgs + let [migrationId] = required + + withBackend $ \backend -> do + ensureBootstrappedBackend backend >> commitBackend backend + m <- lookupMigration storeData migrationId + _ <- apply m storeData backend True + case isTesting of + False -> do + commitBackend backend + putStrLn "Successfully applied migrations." + True -> do + rollbackBackend backend + putStrLn "Migration installation test successful." + +revertCommand :: CommandHandler +revertCommand storeData = do + isTesting <- _test <$> asks _appOptions + required <- asks _appRequiredArgs + let [migrationId] = required + + withBackend $ \backend -> do + ensureBootstrappedBackend backend >> commitBackend backend + m <- lookupMigration storeData migrationId + _ <- revert m storeData backend + + case isTesting of + False -> do + commitBackend backend + putStrLn "Successfully reverted migrations." + True -> do + rollbackBackend backend + putStrLn "Migration uninstallation test successful." + +testCommand :: CommandHandler +testCommand storeData = do + required <- asks _appRequiredArgs + let [migrationId] = required + + withBackend $ \backend -> do + ensureBootstrappedBackend backend >> commitBackend backend + m <- lookupMigration storeData migrationId + migrationNames <- missingMigrations backend storeData + -- If the migration is already installed, remove it as part of + -- the test + when (not $ migrationId `elem` migrationNames) $ + do _ <- revert m storeData backend + return () + applied <- apply m storeData backend True + forM_ (reverse applied) $ \migration -> do + revert migration storeData backend + rollbackBackend backend + putStrLn "Successfully tested migrations." diff --git a/dbmigrations/src/Moo/CommandInterface.hs b/dbmigrations/src/Moo/CommandInterface.hs new file mode 100644 index 0000000..4912c75 --- /dev/null +++ b/dbmigrations/src/Moo/CommandInterface.hs @@ -0,0 +1,126 @@ +-- |This module defines the MOO command interface, the commnad line options +-- parser, and helpers to manipulate the Command data structure. +module Moo.CommandInterface + ( commands + , commandOptionUsage + , findCommand + , getCommandArgs + , usageString + ) where + +import Data.Maybe +import Moo.CommandHandlers +import Moo.Core +import System.Console.GetOpt + +-- |The available commands; used to dispatch from the command line and +-- used to generate usage output. +-- |The available commands; used to dispatch from the command line and +-- used to generate usage output. +commands :: [Command] +commands = [ Command "new" [migrationName] + [] + ["no-ask", configFile] + "Create a new empty migration" + newCommand + + , Command "apply" [migrationName] + [] + [testOption, configFile] + "Apply the specified migration and its \ + \dependencies" + applyCommand + + , Command "revert" [migrationName] + [] + [testOption, configFile] + "Revert the specified migration and those \ + \that depend on it" + revertCommand + + , Command "test" [migrationName] + [] + [configFile] + "Test the specified migration by applying \ + \and reverting it in a transaction, then \ + \roll back" + testCommand + + , Command "upgrade" [] + [] + [testOption, configFile] + "Install all migrations that have not yet \ + \been installed" + + upgradeCommand + + , Command "upgrade-list" [] + [] + [] + "Show the list of migrations not yet \ + \installed" + upgradeListCommand + + , Command "reinstall" [migrationName] + [] + [testOption, configFile] + "Reinstall a migration by reverting, then \ + \reapplying it" + reinstallCommand + + , Command "list" [] + [] + [configFile] + "List migrations already installed in the backend" + listCommand + ] + where migrationName = "migrationName" + testOption = "test" + configFile = "config-file" + + +findCommand :: String -> Maybe Command +findCommand name = listToMaybe [ c | c <- commands, _cName c == name ] + +commandOptions :: [ OptDescr (CommandOptions -> IO CommandOptions) ] +commandOptions = [ optionConfigFile + , optionTest + , optionNoAsk + ] + +optionConfigFile :: OptDescr (CommandOptions -> IO CommandOptions) +optionConfigFile = Option "c" ["config-file"] + (ReqArg (\arg opt -> + return opt { _configFilePath = Just arg }) "FILE") + "Specify location of configuration file" + +optionTest :: OptDescr (CommandOptions -> IO CommandOptions) +optionTest = Option "t" ["test"] + (NoArg (\opt -> return opt { _test = True })) + "Perform the action then rollback when finished" + +optionNoAsk :: OptDescr (CommandOptions -> IO CommandOptions) +optionNoAsk = Option "n" ["no-ask"] + (NoArg (\opt -> return opt { _noAsk = True })) + "Do not interactively ask any questions, just do it" + +getCommandArgs :: [String] -> IO ( CommandOptions, [String] ) +getCommandArgs args = do + let (actions, required, _) = getOpt RequireOrder commandOptions args + opts <- foldl (>>=) defaultOptions actions + return ( opts, required ) + +defaultOptions :: IO CommandOptions +defaultOptions = return $ CommandOptions Nothing False False + +commandOptionUsage :: String +commandOptionUsage = usageInfo "Options:" commandOptions + +usageString :: Command -> String +usageString command = + unwords (_cName command:optionalArgs ++ options ++ requiredArgs) + where + requiredArgs = map (\s -> "<" ++ s ++ ">") $ _cRequired command + optionalArgs = map (\s -> "[" ++ s ++ "]") $ _cOptional command + options = map (\s -> "["++ "--" ++ s ++ "]") optionStrings + optionStrings = _cAllowedOptions command diff --git a/dbmigrations/src/Moo/CommandUtils.hs b/dbmigrations/src/Moo/CommandUtils.hs new file mode 100644 index 0000000..fef0a26 --- /dev/null +++ b/dbmigrations/src/Moo/CommandUtils.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +module Moo.CommandUtils + ( apply + , confirmCreation + , interactiveAskDeps + , lookupMigration + , revert + , withBackend + , getCurrentTimestamp + ) where + +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Data.Text as T + +import Control.Exception (finally) +import Control.Monad (forM_, unless, when) +import Control.Monad.Reader (asks) +import Control.Monad.Trans (liftIO) +import Data.List (intercalate, isPrefixOf, + sortBy) +import Data.Maybe (fromJust, isJust) +import Data.Time.Clock (getCurrentTime) +import System.Exit (ExitCode (..), exitWith) +import System.IO (BufferMode (..), hFlush, + hGetBuffering, + hSetBuffering, stdin, + stdout) + +import Database.Schema.Migrations (migrationsToApply, + migrationsToRevert) +import Database.Schema.Migrations.Backend (Backend (..)) +import Database.Schema.Migrations.Migration (Migration (..)) +import Database.Schema.Migrations.Store (StoreData, storeLookup, + storeMigrations) +import Moo.Core + +getCurrentTimestamp :: IO Text +getCurrentTimestamp = + cs . replace ":" "-" . replace " " "_" . take 19 . show <$> getCurrentTime + +apply :: Migration -> StoreData -> Backend -> Bool -> IO [Migration] +apply m storeData backend complain = do + -- Get the list of migrations to apply + toApply <- migrationsToApply storeData backend m + + -- Apply them + if null toApply then + nothingToDo >> return [] else + mapM_ (applyIt backend) toApply >> return toApply + + where + nothingToDo = + when complain $ + putStrLn . cs $ "Nothing to do; " <> + mId m <> + " already installed." + + applyIt conn it = do + putStr . cs $ "Applying: " <> mId it <> "... " + applyMigration conn it + putStrLn "done." + +revert :: Migration -> StoreData -> Backend -> IO [Migration] +revert m storeData backend = do + -- Get the list of migrations to revert + toRevert <- liftIO $ migrationsToRevert storeData backend m + + -- Revert them + if null toRevert then + nothingToDo >> return [] else + mapM_ (revertIt backend) toRevert >> return toRevert + + where + nothingToDo = + putStrLn . cs $ "Nothing to do; " <> + mId m <> + " not installed." + + revertIt conn it = do + putStr . cs $ "Reverting: " <> mId it <> "... " + revertMigration conn it + putStrLn "done." + + +lookupMigration :: StoreData -> Text -> IO Migration +lookupMigration storeData name = do + let theMigration = storeLookup storeData name + case theMigration of + Nothing -> do + putStrLn . cs $ "No such migration: " <> name + exitWith (ExitFailure 1) + Just m' -> return m' + +-- Given an action that needs a database connection, connect to the +-- database using the backend and invoke the action +-- with the connection. Return its result. +withBackend :: (Backend -> IO a) -> AppT a +withBackend act = do + backend <- asks _appBackend + liftIO $ (act backend) `finally` (disconnectBackend backend) + +-- Given a migration name and selected dependencies, get the user's +-- confirmation that a migration should be created. +confirmCreation :: Text -> [Text] -> IO Bool +confirmCreation migrationId deps = do + putStrLn "" + putStrLn . cs $ "Confirm: create migration '" <> migrationId <> "'" + if null deps then putStrLn " (No dependencies)" + else putStrLn "with dependencies:" + forM_ deps $ \d -> putStrLn . cs $ " " <> d + prompt "Are you sure?" [ ('y', (True, Nothing)) + , ('n', (False, Nothing)) + ] + +-- Prompt the user for a choice, given a prompt and a list of possible +-- choices. Let the user get help for the available choices, and loop +-- until the user makes a valid choice. +prompt :: (Eq a) => String -> PromptChoices a -> IO a +prompt _ [] = error "prompt requires a list of choices" +prompt message choiceMap = do + putStr $ message ++ " (" ++ choiceStr ++ helpChar ++ "): " + hFlush stdout + c <- unbufferedGetChar + case lookup c choiceMap of + Nothing -> do + when (c /= '\n') $ putStrLn "" + when (c == 'h') $ putStr $ mkPromptHelp choiceMapWithHelp + retry + Just (val, _) -> putStrLn "" >> return val + where + retry = prompt message choiceMap + choiceStr = intercalate "" $ map (return . fst) choiceMap + helpChar = if hasHelp choiceMap then "h" else "" + choiceMapWithHelp = choiceMap ++ [('h', (undefined, Just "this help"))] + +-- Given a PromptChoices, build a multi-line help string for those +-- choices using the description information in the choice list. +mkPromptHelp :: PromptChoices a -> String +mkPromptHelp choices = + intercalate "" [ [c] ++ ": " ++ fromJust msg ++ "\n" | + (c, (_, msg)) <- choices, isJust msg ] + +-- Does the specified prompt choice list have any help messages in it? +hasHelp :: PromptChoices a -> Bool +hasHelp = (> 0) . length . filter hasMsg + where hasMsg (_, (_, m)) = isJust m + +-- A general type for a set of choices that the user can make at a +-- prompt. +type PromptChoices a = [(Char, (a, Maybe String))] + +-- Get an input character in non-buffered mode, then restore the +-- original buffering setting. +unbufferedGetChar :: IO Char +unbufferedGetChar = do + bufferingMode <- hGetBuffering stdin + hSetBuffering stdin NoBuffering + c <- getChar + hSetBuffering stdin bufferingMode + return c + +-- The types for choices the user can make when being prompted for +-- dependencies. +data AskDepsChoice = Yes + | No + | View + | Done + | Quit + deriving (Eq) + +-- Interactively ask the user about which dependencies should be used +-- when creating a new migration. +interactiveAskDeps :: StoreData -> IO [Text] +interactiveAskDeps storeData = do + -- For each migration in the store, starting with the most recently + -- added, ask the user if it should be added to a dependency list + let sorted = sortBy compareTimestamps $ storeMigrations storeData + interactiveAskDeps' storeData (map mId sorted) + where + compareTimestamps m1 m2 = compare (mTimestamp m2) (mTimestamp m1) + +-- Recursive function to prompt the user for dependencies and let the +-- user view information about potential dependencies. Returns a list +-- of migration names which were selected. +interactiveAskDeps' :: StoreData -> [Text] -> IO [Text] +interactiveAskDeps' _ [] = return [] +interactiveAskDeps' storeData (name:rest) = do + result <- prompt ("Depend on '" ++ cs name ++ "'?") askDepsChoices + if result == Done then return [] else + case result of + Yes -> do + next <- interactiveAskDeps' storeData rest + return $ name:next + No -> interactiveAskDeps' storeData rest + View -> do + -- load migration + let Just m = storeLookup storeData name + -- print out description, timestamp, deps + when (isJust $ mDesc m) + (putStrLn . cs $ " Description: " <> + fromJust (mDesc m)) + putStrLn $ " Created: " ++ show (mTimestamp m) + unless (null $ mDeps m) + (putStrLn . cs $ " Deps: " <> + T.intercalate "\n " (mDeps m)) + -- ask again + interactiveAskDeps' storeData (name:rest) + Quit -> do + putStrLn "cancelled." + exitWith (ExitFailure 1) + Done -> return [] + +-- The choices the user can make when being prompted for dependencies. +askDepsChoices :: PromptChoices AskDepsChoice +askDepsChoices = [ ('y', (Yes, Just "yes, depend on this migration")) + , ('n', (No, Just "no, do not depend on this migration")) + , ('v', (View, Just "view migration details")) + , ('d', (Done, Just "done, do not ask me about more dependencies")) + , ('q', (Quit, Just "cancel this operation and quit")) + ] + +-- The following code is vendored from MissingH Data.List.Utils: + +{- | Similar to Data.List.span, but performs the test on the entire remaining +list instead of just one element. + +@spanList p xs@ is the same as @(takeWhileList p xs, dropWhileList p xs)@ +-} +spanList :: ([a] -> Bool) -> [a] -> ([a], [a]) + +spanList _ [] = ([],[]) +spanList func list@(x:xs) = + if func list + then (x:ys,zs) + else ([],list) + where (ys,zs) = spanList func xs + +{- | Similar to Data.List.break, but performs the test on the entire remaining +list instead of just one element. +-} +breakList :: ([a] -> Bool) -> [a] -> ([a], [a]) +breakList func = spanList (not . func) + +replace :: Eq a => [a] -> [a] -> [a] -> [a] +replace old new = intercalate new . split old + +split :: Eq a => [a] -> [a] -> [[a]] +split _ [] = [] +split delim str = + let (firstline, remainder) = breakList (isPrefixOf delim) str + in firstline : case remainder of + [] -> [] + x -> if x == delim + then [[]] + else split delim (drop (length delim) x) diff --git a/dbmigrations/src/Moo/Core.hs b/dbmigrations/src/Moo/Core.hs new file mode 100644 index 0000000..979908d --- /dev/null +++ b/dbmigrations/src/Moo/Core.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE ExistentialQuantification #-} +module Moo.Core + ( AppT + , CommandHandler + , CommandOptions (..) + , Command (..) + , AppState (..) + , Configuration (..) + , makeParameters + , ExecutableParameters (..) + , envDatabaseName + , envLinearMigrations + , envStoreName + , loadConfiguration) where + +import Data.Text ( Text ) + +import Control.Monad.Reader (ReaderT) +import qualified Data.Configurator as C +import Data.Configurator.Types (Config, Configured) +import qualified Data.Text as T +import Data.Char (toLower) +import System.Environment (getEnvironment) +import Data.Maybe (fromMaybe) + +import Database.Schema.Migrations.Store (MigrationStore, StoreData) +import Database.Schema.Migrations.Backend + +-- |The monad in which the application runs. +type AppT a = ReaderT AppState IO a + +-- |The type of actions that are invoked to handle specific commands +type CommandHandler = StoreData -> AppT () + +-- |Application state which can be accessed by any command handler. +data AppState = AppState { _appOptions :: CommandOptions + , _appCommand :: Command + , _appRequiredArgs :: [Text] + , _appOptionalArgs :: [Text] + , _appBackend :: Backend + , _appStore :: MigrationStore + , _appStoreData :: StoreData + , _appLinearMigrations :: Bool + , _appTimestampFilenames :: Bool + } + +type ShellEnvironment = [(String, String)] + +-- |Intermediate type used during config loading. +data LoadConfig = LoadConfig + { _lcConnectionString :: Maybe String + , _lcMigrationStorePath :: Maybe FilePath + , _lcLinearMigrations :: Maybe Bool + , _lcTimestampFilenames :: Maybe Bool + } deriving Show + +-- |Loading the configuration from a file or having it specified via environment +-- |variables results in a value of type Configuration. +data Configuration = Configuration + { _connectionString :: String + , _migrationStorePath :: FilePath + , _linearMigrations :: Bool + , _timestampFilenames :: Bool + } deriving Show + +-- |A value of type ExecutableParameters is what a moo executable (moo-postgresql, +-- |moo-mysql, etc.) pass to the core package when they want to execute a +-- |command. +data ExecutableParameters = ExecutableParameters + { _parametersBackend :: Backend + , _parametersMigrationStorePath :: FilePath + , _parametersLinearMigrations :: Bool + , _parametersTimestampFilenames :: Bool + } deriving Show + +defConfigFile :: String +defConfigFile = "moo.cfg" + +newLoadConfig :: LoadConfig +newLoadConfig = LoadConfig Nothing Nothing Nothing Nothing + +validateLoadConfig :: LoadConfig -> Either String Configuration +validateLoadConfig (LoadConfig Nothing _ _ _) = + Left "Invalid configuration: connection string not specified" +validateLoadConfig (LoadConfig _ Nothing _ _) = + Left "Invalid configuration: migration store path not specified" +validateLoadConfig (LoadConfig (Just cs) (Just msp) lm ts) = + Right $ Configuration cs msp (fromMaybe False lm) (fromMaybe False ts) + +-- |Setters for fields of 'LoadConfig'. +lcConnectionString, lcMigrationStorePath + :: LoadConfig -> Maybe String -> LoadConfig +lcConnectionString c v = c { _lcConnectionString = v } +lcMigrationStorePath c v = c { _lcMigrationStorePath = v } + +lcLinearMigrations :: LoadConfig -> Maybe Bool -> LoadConfig +lcLinearMigrations c v = c { _lcLinearMigrations = v } + +lcTimestampFilenames :: LoadConfig -> Maybe Bool -> LoadConfig +lcTimestampFilenames c v = c { _lcTimestampFilenames = v } + + +-- | @f .= v@ invokes f only if v is 'Just' +(.=) :: (Monad m) => (a -> Maybe b -> a) -> m (Maybe b) -> m (a -> a) +(.=) f v' = do + v <- v' + return $ case v of + Just _ -> flip f v + _ -> id + +-- |It's just @flip '<*>'@ +(&) :: (Applicative m) => m a -> m (a -> b) -> m b +(&) = flip (<*>) + +infixr 3 .= +infixl 2 & + +applyEnvironment :: ShellEnvironment -> LoadConfig -> IO LoadConfig +applyEnvironment env lc = + return lc & lcConnectionString .= f envDatabaseName + & lcMigrationStorePath .= f envStoreName + & lcLinearMigrations .= readFlag <$> f envLinearMigrations + & lcTimestampFilenames .= readFlag <$> f envTimestampFilenames + where f n = return $ lookup n env + +applyConfigFile :: Config -> LoadConfig -> IO LoadConfig +applyConfigFile cfg lc = + return lc & lcConnectionString .= f envDatabaseName + & lcMigrationStorePath .= f envStoreName + & lcLinearMigrations .= f envLinearMigrations + & lcTimestampFilenames .= f envTimestampFilenames + where + f :: Configured a => String -> IO (Maybe a) + f = C.lookup cfg . T.pack + +-- |Loads config file (falling back to default one if not specified) and then +-- overrides configuration with an environment. +loadConfiguration :: Maybe FilePath -> IO (Either String Configuration) +loadConfiguration pth = do + file <- maybe (C.load [C.Optional defConfigFile]) + (\p -> C.load [C.Required p]) pth + env <- getEnvironment + cfg <- applyConfigFile file newLoadConfig >>= applyEnvironment env + + return $ validateLoadConfig cfg + +makeParameters :: Configuration -> Backend -> ExecutableParameters +makeParameters conf backend = + ExecutableParameters + { _parametersBackend = backend + , _parametersMigrationStorePath = _migrationStorePath conf + , _parametersLinearMigrations = _linearMigrations conf + , _parametersTimestampFilenames = _timestampFilenames conf + } + +-- |Converts @Just "on"@ and @Just "true"@ (case insensitive) to @True@, +-- anything else to @False@. +readFlag :: Maybe String -> Maybe Bool +readFlag Nothing = Nothing +readFlag (Just v) = go $ map toLower v + where + go "on" = Just True + go "true" = Just True + go "off" = Just False + go "false" = Just False + go _ = Nothing + +-- |CommandOptions are those options that can be specified at the command +-- prompt to modify the behavior of a command. +data CommandOptions = CommandOptions { _configFilePath :: Maybe String + , _test :: Bool + , _noAsk :: Bool + } + +-- |A command has a name, a number of required arguments' labels, a +-- number of optional arguments' labels, and an action to invoke. +data Command = Command { _cName :: String + , _cRequired :: [String] + , _cOptional :: [String] + , _cAllowedOptions :: [String] + , _cDescription :: String + , _cHandler :: CommandHandler + } + +envDatabaseName :: String +envDatabaseName = "DBM_DATABASE" + +envStoreName :: String +envStoreName = "DBM_MIGRATION_STORE" + +envLinearMigrations :: String +envLinearMigrations = "DBM_LINEAR_MIGRATIONS" + +envTimestampFilenames :: String +envTimestampFilenames = "DBM_TIMESTAMP_FILENAMES" + diff --git a/dbmigrations/src/Moo/Main.hs b/dbmigrations/src/Moo/Main.hs new file mode 100644 index 0000000..259a4c4 --- /dev/null +++ b/dbmigrations/src/Moo/Main.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} +module Moo.Main + ( mainWithParameters + , ExecutableParameters (..) + , Configuration (..) + , Args + , usage + , usageSpecific + , procArgs + ) +where + +import Control.Monad.Reader (forM_, runReaderT, when) +import Database.HDBC (SqlError, catchSql, seErrorMsg) +import Prelude hiding (lookup) +import Data.Text (Text) +import Data.String.Conversions (cs) +import System.Environment (getProgName) +import System.Exit (ExitCode (ExitFailure), exitWith) + +import Database.Schema.Migrations.Filesystem (filesystemStore, FilesystemStoreSettings(..)) +import Database.Schema.Migrations.Store +import Moo.CommandInterface +import Moo.Core + +type Args = [String] + +usage :: IO a +usage = do + progName <- getProgName + + putStrLn $ "Usage: " ++ progName ++ " [args]" + putStrLn "Environment:" + putStrLn $ " " ++ envDatabaseName ++ ": database connection string" + putStrLn $ " " ++ envStoreName ++ ": path to migration store" + putStrLn $ " " ++ envLinearMigrations ++ ": whether to use linear migrations (defaults to False)" + putStrLn "Commands:" + forM_ commands $ \command -> do + putStrLn $ " " ++ usageString command + putStrLn $ " " ++ _cDescription command + putStrLn "" + + putStrLn commandOptionUsage + exitWith (ExitFailure 1) + +usageSpecific :: Command -> IO a +usageSpecific command = do + pn <- getProgName + putStrLn $ "Usage: " ++ pn ++ " " ++ usageString command + exitWith (ExitFailure 1) + +procArgs :: Args -> IO (Command, CommandOptions, [String]) +procArgs args = do + when (null args) usage + + command <- case findCommand $ head args of + Nothing -> usage + Just c -> return c + + (opts, required) <- getCommandArgs $ tail args + + return (command, opts, required) + +mainWithParameters :: Args -> ExecutableParameters -> IO () +mainWithParameters args parameters = do + (command, opts, required) <- procArgs args + + let storePathStr = _parametersMigrationStorePath parameters + store = filesystemStore $ FSStore { storePath = storePathStr } + linear = _parametersLinearMigrations parameters + + if length required < length ( _cRequired command) then + usageSpecific command else + do + loadedStoreData <- loadMigrations store + case loadedStoreData of + Left es -> do + putStrLn "There were errors in the migration store:" + forM_ es $ \err -> putStrLn $ " " ++ show err + Right storeData -> do + let st = AppState { _appOptions = opts + , _appCommand = command + , _appRequiredArgs = map cs required + , _appOptionalArgs = ["" :: Text] + , _appBackend = _parametersBackend parameters + , _appStore = store + , _appStoreData = storeData + , _appLinearMigrations = linear + , _appTimestampFilenames = + _parametersTimestampFilenames parameters + } + runReaderT (_cHandler command storeData) st `catchSql` reportSqlError + +reportSqlError :: SqlError -> IO a +reportSqlError e = do + putStrLn $ "\n" ++ "A database error occurred: " ++ seErrorMsg e + exitWith (ExitFailure 1) diff --git a/dbmigrations/src/StoreManager.hs b/dbmigrations/src/StoreManager.hs new file mode 100644 index 0000000..b46e0f9 --- /dev/null +++ b/dbmigrations/src/StoreManager.hs @@ -0,0 +1,232 @@ +module Main where + +import Control.Applicative ( (<$>) ) +import Control.Monad.State +import qualified Data.Map as Map +import System.Environment + ( getArgs + , getProgName + , getEnvironment + ) +import System.Exit + ( exitFailure + ) +import System.IO + ( Handle + , hClose + , openTempFile + , hPutStr + ) +import System.Directory + ( getTemporaryDirectory + ) +import System.Process +import System.Posix.Files + ( removeLink + ) + +import Data.Maybe + ( fromJust + ) + +import Graphics.Vty +import Graphics.Vty.Widgets.All +import Database.Schema.Migrations.Filesystem +import Database.Schema.Migrations.Migration + ( Migration(..) + ) +import Database.Schema.Migrations.Store + +-- XXX Generalize over all MigrationStore instances +data AppState = AppState { appStoreData :: StoreData + , appStore :: FilesystemStore + , appMigrationList :: SimpleList + , appVty :: Vty + } + +type AppM = StateT AppState IO + +titleAttr :: Attr +titleAttr = def_attr + `with_back_color` blue + `with_fore_color` bright_white + +bodyAttr :: Attr +bodyAttr = def_attr + `with_back_color` black + `with_fore_color` bright_white + +fieldAttr :: Attr +fieldAttr = def_attr + `with_back_color` black + `with_fore_color` bright_green + +selAttr :: Attr +selAttr = def_attr + `with_back_color` yellow + `with_fore_color` black + +scrollListUp :: AppState -> AppState +scrollListUp appst = + appst { appMigrationList = scrollUp $ appMigrationList appst } + +scrollListDown :: AppState -> AppState +scrollListDown appst = + appst { appMigrationList = scrollDown $ appMigrationList appst } + +eventloop :: (Widget a) => AppM a -> (Event -> AppM Bool) -> AppM () +eventloop uiBuilder handle = do + w <- uiBuilder + vty <- gets appVty + evt <- liftIO $ do + (img, _) <- mkImage vty w + update vty $ pic_for_image img + next_event vty + next <- handle evt + if next then + eventloop uiBuilder handle else + return () + +continue :: AppM Bool +continue = return True + +stop :: AppM Bool +stop = return False + +handleEvent :: Event -> AppM Bool +handleEvent (EvKey KUp []) = modify scrollListUp >> continue +handleEvent (EvKey KDown []) = modify scrollListDown >> continue +handleEvent (EvKey (KASCII 'q') []) = stop +handleEvent (EvKey (KASCII 'e') []) = editCurrentMigration >> continue +handleEvent (EvResize w h) = do + let wSize = appropriateListWindow $ DisplayRegion (toEnum w) (toEnum h) + modify (\appst -> appst { appMigrationList = (appMigrationList appst) { scrollWindowSize = wSize }}) + continue +handleEvent _ = continue + +withTempFile :: (MonadIO m) => (Handle -> FilePath -> m a) -> m a +withTempFile act = do + (tempFilePath, newFile) <- liftIO $ createTempFile + result <- act newFile tempFilePath + liftIO $ cleanup newFile tempFilePath + return result + where + createTempFile = do + tempDir <- getTemporaryDirectory + openTempFile tempDir "migration.txt" + + cleanup handle tempFilePath = do + (hClose handle) `catch` (\_ -> return ()) + removeLink tempFilePath + +editCurrentMigration :: AppM () +editCurrentMigration = do + -- Get the current migration + m <- gets getSelectedMigration + store <- gets appStore + migrationPath <- fullMigrationName store $ mId m + vty <- gets appVty + + withTempFile $ \tempHandle tempPath -> + liftIO $ do + -- Copy the migration to a temporary file + readFile migrationPath >>= hPutStr tempHandle + hClose tempHandle + + shutdown vty + + currentEnv <- getEnvironment + let editor = maybe "vi" id $ lookup "EDITOR" currentEnv + spawnEditor = do + -- Invoke an editor to edit the temporary file + (_, _, _, pHandle) <- createProcess $ shell $ editor ++ " " ++ tempPath + waitForProcess pHandle + + -- Once the editor closes, validate the temporary file + validateResult <- migrationFromPath tempPath + case validateResult of + Left e -> do + putStrLn $ "Error in edited migration: " ++ e + putStrLn $ "Try again? (y/n) " + c <- getChar + if c == 'y' then spawnEditor else return False + Right _ -> return True + + proceed <- spawnEditor + + -- Replace the original migration with the contents of the + -- temporary file + when (proceed) (readFile tempPath >>= writeFile migrationPath) + + -- Reinitialize application state + put =<< (liftIO $ mkState store) + +getSelectedMigration :: AppState -> Migration +getSelectedMigration appst = fromJust $ Map.lookup (fst $ getSelected list) mMap + where mMap = storeDataMapping $ appStoreData appst + list = appMigrationList appst + +buildUi :: AppState -> Box +buildUi appst = + let header = text titleAttr (" " ++ (storePath $ appStore appst) ++ " ") + <++> hFill titleAttr '-' 1 + <++> text titleAttr " Store Manager " + status = text bodyAttr $ maybe "" id $ mDesc $ getSelectedMigration appst + helpBar = text titleAttr "q:quit e:edit " + <++> hFill titleAttr '-' 1 + in header + <--> appMigrationList appst + <--> helpBar + <--> status + +uiFromState :: AppM Box +uiFromState = buildUi <$> get + +readStore :: FilesystemStore -> IO StoreData +readStore store = do + result <- loadMigrations store + case result of + Left es -> do + putStrLn "There were errors in the migration store:" + forM_ es $ \err -> do + putStrLn $ " " ++ show err + exitFailure + Right theStoreData -> return theStoreData + +mkState :: FilesystemStore -> IO AppState +mkState fsStore = do + vty <- mkVty + sz <- display_bounds $ terminal vty + storeData <- readStore fsStore + let migrationList = mkSimpleList bodyAttr selAttr (appropriateListWindow sz) migrationNames + migrationNames = Map.keys $ storeDataMapping storeData + return $ AppState { appStoreData = storeData + , appStore = fsStore + , appMigrationList = migrationList + , appVty = vty + } + +appropriateListWindow :: DisplayRegion -> Int +appropriateListWindow sz = fromEnum $ region_height sz - 3 + +main :: IO () +main = do + args <- getArgs + + when (length args /= 1) $ do + p <- getProgName + putStrLn ("Usage: " ++ p ++ " ") + exitFailure + + let store = FSStore { storePath = args !! 0 } + + beginState <- mkState store + + -- Capture the new application state because it might contain a new + -- Vty. + endState <- execStateT (eventloop uiFromState handleEvent) beginState + let endVty = appVty endState + + -- Clear the screen. + reserve_display $ terminal endVty + shutdown endVty \ No newline at end of file diff --git a/dbmigrations/test/Common.hs b/dbmigrations/test/Common.hs new file mode 100644 index 0000000..51e17f0 --- /dev/null +++ b/dbmigrations/test/Common.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TemplateHaskell #-} +module Common + ( TestDependable(..) + , repoRoot + , testFile + , satisfies + , (.&&.) + ) +where + +import Data.Text ( Text ) + +import CommonTH +import System.FilePath ( () ) +import Language.Haskell.TH.Syntax (lift) +import Test.HUnit + +import Database.Schema.Migrations.Dependencies ( Dependable(..) ) + +repoRoot :: FilePath +repoRoot = $(getRepoRoot >>= lift) + +testFile :: FilePath -> FilePath +testFile fp = repoRoot "test" fp + +instance Dependable TestDependable where + depId = tdId + depsOf = tdDeps + +data TestDependable = TD { tdId :: Text + , tdDeps :: [Text] + } + deriving (Show, Eq, Ord) + + +satisfies :: String -> a -> (a -> Bool) -> IO Test +satisfies m v f = return $ TestCase $ assertBool m (f v) + +(.&&.) :: Test -> Test -> Test +(TestList xs) .&&. (TestList ys) = TestList (xs ++ ys) +(TestList xs) .&&. y = TestList (xs ++ [y]) +x .&&. (TestList ys) = TestList (x:ys) +a .&&. b = TestList [a, b] +infixl 0 .&&. diff --git a/dbmigrations/test/CommonTH.hs b/dbmigrations/test/CommonTH.hs new file mode 100644 index 0000000..369c968 --- /dev/null +++ b/dbmigrations/test/CommonTH.hs @@ -0,0 +1,16 @@ +module CommonTH + ( getRepoRoot + ) +where + +import Language.Haskell.TH +import System.FilePath ( takeDirectory, combine ) +import System.Directory ( getCurrentDirectory, canonicalizePath ) + +getRepoRoot :: Q FilePath +getRepoRoot = + do here <- location + cwd <- runIO getCurrentDirectory + let thisFileName = combine cwd $ loc_filename here + -- XXX: This depends on the location of this file in the source tree + return =<< runIO $ canonicalizePath $ head $ drop 2 $ iterate takeDirectory thisFileName diff --git a/dbmigrations/test/ConfigurationTest.hs b/dbmigrations/test/ConfigurationTest.hs new file mode 100644 index 0000000..943d1ea --- /dev/null +++ b/dbmigrations/test/ConfigurationTest.hs @@ -0,0 +1,97 @@ +module ConfigurationTest (tests) where + +import Control.Exception (SomeException, try) +import Data.Either (isLeft, isRight) +import System.Directory +import System.Environment (setEnv, unsetEnv) +import Test.HUnit + +import Common +import Moo.Core + +tests :: IO [Test] +tests = sequence [prepareTestEnv >> e | e <- entries] + where entries = [ loadsConfigFile + , loadsPropertiesFromFile + , loadsDefaultConfigFile + , environmentOverridesProperties + , ifNoConfigFileIsAvailableEnvironmentIsUsed + , throwsWhenConfigFileIsInvalid + , returnsErrorWhenNotAllPropertiesAreSet + , canReadTimestampsConfig + ] + +prepareTestEnv :: IO () +prepareTestEnv = do + setCurrentDirectory $ testFile "config_loading" + unsetEnv "DBM_DATABASE" + unsetEnv "DBM_MIGRATION_STORE" + unsetEnv "DBM_LINEAR_MIGRATIONS" + unsetEnv "DBM_TIMESTAMP_FILENAMES" + +canReadTimestampsConfig :: IO Test +canReadTimestampsConfig = do + Right cfg <- loadConfiguration (Just "cfg_ts.cfg") + satisfies "Timestamp not set" cfg _timestampFilenames + +loadsConfigFile :: IO Test +loadsConfigFile = do + cfg' <- loadConfiguration (Just "cfg1.cfg") + satisfies "File not loaded" cfg' isRight + +loadsPropertiesFromFile :: IO Test +loadsPropertiesFromFile = do + Right cfg <- loadConfiguration (Just "cfg1.cfg") + return + ( + _connectionString cfg ~?= "connection" .&&. + _migrationStorePath cfg ~?= "store" .&&. + _linearMigrations cfg ~?= True + ) + +loadsDefaultConfigFile :: IO Test +loadsDefaultConfigFile = do + Right cfg <- loadConfiguration Nothing + return + ( + _connectionString cfg ~?= "mooconn" .&&. + _migrationStorePath cfg ~?= "moostore" .&&. + _linearMigrations cfg ~?= True + ) + +environmentOverridesProperties :: IO Test +environmentOverridesProperties = do + setEnv "DBM_DATABASE" "envconn" + setEnv "DBM_MIGRATION_STORE" "envstore" + setEnv "DBM_LINEAR_MIGRATIONS" "off" + Right cfg <- loadConfiguration (Just "cfg1.cfg") + return + ( + _connectionString cfg ~?= "envconn" .&&. + _migrationStorePath cfg ~?= "envstore" .&&. + _linearMigrations cfg ~?= False + ) + +ifNoConfigFileIsAvailableEnvironmentIsUsed :: IO Test +ifNoConfigFileIsAvailableEnvironmentIsUsed = do + setCurrentDirectory $ testFile "" + setEnv "DBM_DATABASE" "envconn" + setEnv "DBM_MIGRATION_STORE" "envstore" + setEnv "DBM_LINEAR_MIGRATIONS" "off" + Right cfg <- loadConfiguration Nothing + return + ( + _connectionString cfg ~?= "envconn" .&&. + _migrationStorePath cfg ~?= "envstore" .&&. + _linearMigrations cfg ~?= False + ) + +returnsErrorWhenNotAllPropertiesAreSet :: IO Test +returnsErrorWhenNotAllPropertiesAreSet = do + cfg <- loadConfiguration (Just "missing.cfg") + satisfies "Should return error" cfg isLeft + +throwsWhenConfigFileIsInvalid :: IO Test +throwsWhenConfigFileIsInvalid = do + c <- try $ loadConfiguration (Just "invalid.cfg") + satisfies "Should throw" c (isLeft :: Either SomeException a -> Bool) diff --git a/dbmigrations/test/CycleDetectionTest.hs b/dbmigrations/test/CycleDetectionTest.hs new file mode 100644 index 0000000..dfdd3e5 --- /dev/null +++ b/dbmigrations/test/CycleDetectionTest.hs @@ -0,0 +1,69 @@ +module CycleDetectionTest + ( tests + ) +where + +import Test.HUnit +import Data.Graph.Inductive.PatriciaTree ( Gr ) +import Data.Graph.Inductive.Graph ( mkGraph ) + +import Database.Schema.Migrations.CycleDetection + +tests :: [Test] +tests = mkCycleTests + +noCycles :: Gr String String +noCycles = mkGraph [(1,"one"),(2,"two")] [(1,2,"one->two")] + +noCyclesEmpty :: Gr String String +noCyclesEmpty = mkGraph [] [] + +withCycleSimple :: Gr String String +withCycleSimple = mkGraph [(1,"one")] [(1,1,"one->one")] + +withCycleComplex :: Gr String String +withCycleComplex = mkGraph [(1,"one"),(2,"two"),(3,"three"),(4,"four")] + [(4,1,"four->one"),(1,2,"one->two"),(2,3,"two->three"),(3,1,"three->one")] + +withCycleRadial :: Gr String String +withCycleRadial = mkGraph [(1,"one"),(2,"two"),(3,"three"),(4,"four")] + [(2,1,""),(2,3,""),(3,4,""),(3,2,"")] + +noCycleRadial :: Gr String String +noCycleRadial = mkGraph [(1,""),(2,""),(3,""),(4,"")] + [(1,2,""),(3,1,""),(4,1,"")] + +-- This graph would contain a loop if it were undirected, but it does +-- not contain a directed cycle. +noDirectedCycle1 :: Gr String String +noDirectedCycle1 = mkGraph [(1,""),(2,""),(3,""),(4,"")] + [(1,2,""),(1,3,""),(3,2,""),(2,4,"")] + +-- This graph would contain a loop if it were undirected, but it does +-- not contain a directed cycle. +noDirectedCycle2 :: Gr String String +noDirectedCycle2 = mkGraph [(1,"flub"),(2,"test.db"),(3,"test2"),(4,"test3"),(5,"test1")] + [ (1,2,"flub->test.db") + , (2,3,"test.db->test2") + , (2,4,"test.db->test3") + , (3,5,"test2->test1") + , (4,3,"test3->test2") + ] + +type CycleTestCase = (Gr String String, Bool) + +cycleTests :: [CycleTestCase] +cycleTests = [ (noCyclesEmpty, False) + , (noCycles, False) + , (noCycleRadial, False) + , (withCycleSimple, True) + , (withCycleComplex, True) + , (withCycleRadial, True) + , (noDirectedCycle1, False) + , (noDirectedCycle2, False) + ] + +mkCycleTests :: [Test] +mkCycleTests = map mkCycleTest cycleTests + where + mkCycleTest (g, expected) = expected ~=? hasCycle g diff --git a/dbmigrations/test/DependencyTest.hs b/dbmigrations/test/DependencyTest.hs new file mode 100644 index 0000000..7bf1495 --- /dev/null +++ b/dbmigrations/test/DependencyTest.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} +module DependencyTest + ( tests + ) +where + +import Data.Text ( Text ) + +import Test.HUnit +import Data.Graph.Inductive.Graph ( Graph(..) ) + +import Database.Schema.Migrations.Dependencies +import Common + +tests :: [Test] +tests = depGraphTests ++ dependencyTests + +type DepGraphTestCase = ([TestDependable], Either String (DependencyGraph TestDependable)) + +depGraphTestCases :: [DepGraphTestCase] +depGraphTestCases = [ ( [] + , Right $ DG [] [] empty + ) + , ( [first, second] + , Right $ DG [(first,1),(second,2)] + [("first",1),("second",2)] (mkGraph [(1, "first"), (2, "second")] + [(2, 1, "first -> second")]) + ) + , ( [cycleFirst, cycleSecond] + , Left "Invalid dependency graph; cycle detected") + ] + where + first = TD "first" [] + second = TD "second" ["first"] + cycleFirst = TD "first" ["second"] + cycleSecond = TD "second" ["first"] + +depGraphTests :: [Test] +depGraphTests = map mkDepGraphTest depGraphTestCases + +mkDepGraphTest :: DepGraphTestCase -> Test +mkDepGraphTest (input, expected) = expected ~=? mkDepGraph input + +data Direction = Forward | Reverse deriving (Show) +type DependencyTestCase = ([TestDependable], Text, Direction, [Text]) + +dependencyTestCases :: [DependencyTestCase] +dependencyTestCases = [ ([TD "first" []], "first", Forward, []) + , ([TD "first" []], "first", Reverse, []) + + , ([TD "first" ["second"], TD "second" []], "first", Forward, ["second"]) + , ([TD "first" ["second"], TD "second" []], "second", Reverse, ["first"]) + , ([TD "first" ["second"], TD "second" ["third"], TD "third" []], "first", Forward, ["third", "second"]) + , ([TD "first" ["second"], TD "second" ["third"], TD "third" [], TD "fourth" ["third"]] + , "first", Forward, ["third", "second"]) + , ([TD "first" [], TD "second" ["first"]] + , "first", Reverse, ["second"]) + , ([TD "first" [], TD "second" ["first"], TD "third" ["second"]] + , "first", Reverse, ["third", "second"]) + , ([TD "first" [], TD "second" ["first"], TD "third" ["second"], TD "fourth" ["second"]] + , "first", Reverse, ["fourth", "third", "second"]) + , ([ TD "first" ["second"], TD "second" ["third"], TD "third" ["fourth"] + , TD "second" ["fifth"], TD "fifth" ["third"], TD "fourth" []] + , "fourth", Reverse, ["first", "second", "fifth", "third"]) + , ([ TD "first" ["second"], TD "second" ["third", "fifth"], TD "third" ["fourth"] + , TD "fifth" ["third"], TD "fourth" []] + , "first", Forward, ["fourth", "third", "fifth", "second"]) + ] + +fromRight :: Either a b -> b +fromRight (Left _) = error "Got a Left value" +fromRight (Right v) = v + +mkDependencyTest :: DependencyTestCase -> Test +mkDependencyTest testCase@(deps, a, dir, expected) = + let f = case dir of + Forward -> dependencies + Reverse -> reverseDependencies + in (show testCase) ~: expected ~=? f (fromRight $ mkDepGraph deps) a + +dependencyTests :: [Test] +dependencyTests = map mkDependencyTest dependencyTestCases diff --git a/dbmigrations/test/FilesystemParseTest.hs b/dbmigrations/test/FilesystemParseTest.hs new file mode 100644 index 0000000..8cbf67b --- /dev/null +++ b/dbmigrations/test/FilesystemParseTest.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE OverloadedStrings #-} +module FilesystemParseTest + ( tests + ) +where + +import Test.HUnit +import Data.Time.Clock ( UTCTime ) +import System.FilePath ( () ) +import Data.String.Conversions ( cs ) + +import Common + +import Database.Schema.Migrations.Migration +import Database.Schema.Migrations.Filesystem + ( FilesystemStoreSettings(..) + , migrationFromFile + ) + +tests :: IO [Test] +tests = migrationParsingTests + +-- filename, result +type MigrationParsingTestCase = (FilePath, Either String Migration) + +tsStr :: String +tsStr = "2009-04-15 10:02:06 UTC" + +ts :: UTCTime +ts = read tsStr + +valid_full :: Migration +valid_full = Migration { + mTimestamp = Just ts + , mId = "valid_full" + , mDesc = Just "A valid full migration." + , mDeps = ["another_migration"] + , mApply = "CREATE TABLE test ( a int );" + , mRevert = Just "DROP TABLE test;" + } + +valid_full_comments :: Migration +valid_full_comments = Migration { + mTimestamp = Just ts + , mId = "valid_full" + , mDesc = Just "A valid full migration." + , mDeps = ["another_migration"] + , mApply = "\n-- Comment on a line\nCREATE TABLE test (\n a int -- comment inline\n);\n" + , mRevert = Just "DROP TABLE test;" + } + +valid_full_colon :: Migration +valid_full_colon = Migration { + mTimestamp = Just ts + , mId = "valid_full" + , mDesc = Just "A valid full migration." + , mDeps = ["another_migration"] + , mApply = "\n-- Comment on a line with a colon:\nCREATE TABLE test (\n a int\n);\n" + , mRevert = Just "DROP TABLE test;" + } + +testStorePath :: FilePath +testStorePath = testFile $ "migration_parsing" + +fp :: FilePath -> FilePath +fp = (testStorePath ) + +migrationParsingTestCases :: [MigrationParsingTestCase] +migrationParsingTestCases = [ ("valid_full", Right valid_full) + , ("valid_with_comments" + , Right (valid_full { mId = "valid_with_comments" })) + , ("valid_with_comments2" + , Right (valid_full_comments { mId = "valid_with_comments2" })) + , ("valid_with_colon" + , Right (valid_full_colon { mId = "valid_with_colon" })) + , ("valid_with_multiline_deps" + , Right (valid_full { mId = "valid_with_multiline_deps" + , mDeps = ["one", "two", "three"] } )) + , ("valid_no_depends" + , Right (valid_full { mId = "valid_no_depends", mDeps = [] })) + , ("valid_no_desc" + , Right (valid_full { mId = "valid_no_desc", mDesc = Nothing })) + , ("valid_no_revert" + , Right (valid_full { mId = "valid_no_revert", mRevert = Nothing })) + , ("valid_no_timestamp" + , Right (valid_full { mId = "valid_no_timestamp", mTimestamp = Nothing })) + , ("invalid_missing_required_fields" + , Left $ "Could not parse migration " ++ + (fp "invalid_missing_required_fields") ++ + ":Error in " ++ + (show $ fp "invalid_missing_required_fields") ++ + ": missing required field(s): " ++ + "[\"Depends\"]") + , ("invalid_field_name" + , Left $ "Could not parse migration " ++ + (fp "invalid_field_name") ++ + ":Error in " ++ + (show $ fp "invalid_field_name") ++ + ": unrecognized field found") + , ("invalid_syntax" + , Left $ "Could not parse migration " ++ + (fp "invalid_syntax") ++ + ":user error (syntax error: line 7, " ++ + "column 0)") + , ("invalid_timestamp" + , Left $ "Could not parse migration " ++ + (fp "invalid_timestamp") ++ + ":Error in " ++ + (show $ fp "invalid_timestamp") ++ + ": unrecognized field found") + ] + +mkParsingTest :: MigrationParsingTestCase -> IO Test +mkParsingTest (fname, expected) = do + let store = FSStore { storePath = testStorePath } + actual <- migrationFromFile store (cs fname) + return $ test $ expected ~=? actual + +migrationParsingTests :: IO [Test] +migrationParsingTests = + traverse mkParsingTest migrationParsingTestCases diff --git a/dbmigrations/test/FilesystemSerializeTest.hs b/dbmigrations/test/FilesystemSerializeTest.hs new file mode 100644 index 0000000..2510c27 --- /dev/null +++ b/dbmigrations/test/FilesystemSerializeTest.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} +module FilesystemSerializeTest + ( tests + ) +where + +import Test.HUnit +import Data.ByteString ( ByteString ) +import Data.String.Conversions ( (<>), cs ) +import Data.Time.Clock ( UTCTime ) + +import Database.Schema.Migrations.Filesystem.Serialize +import Database.Schema.Migrations.Migration + +tests :: [Test] +tests = serializationTests + +mkSerializationTest :: (Migration, ByteString) -> Test +mkSerializationTest (m, expectedString) = test $ expectedString ~=? serializeMigration m + +tsStr :: String +tsStr = "2009-04-15 10:02:06 UTC" + +ts :: UTCTime +ts = read tsStr + +valid_full :: Migration +valid_full = Migration { + mTimestamp = Just ts + , mId = "valid_full" + , mDesc = Just "A valid full migration." + , mDeps = ["another_migration"] + , mApply = " CREATE TABLE test (\n a int\n );\n" + , mRevert = Just "DROP TABLE test;" + } + +serializationTestCases :: [(Migration, ByteString)] +serializationTestCases = [ (valid_full, cs $ "Description: A valid full migration.\n\ + \Created: " <> tsStr <> "\n\ + \Depends: another_migration\n\ + \Apply: |\n\ + \ CREATE TABLE test (\n\ + \ a int\n\ + \ );\n\n\ + \Revert: |\n\ + \ DROP TABLE test;\n") + , (valid_full { mDesc = Nothing } + , cs $ "Created: " <> tsStr <> "\n\ + \Depends: another_migration\n\ + \Apply: |\n\ + \ CREATE TABLE test (\n\ + \ a int\n\ + \ );\n\n\ + \Revert: |\n\ + \ DROP TABLE test;\n") + , (valid_full { mDeps = ["one", "two"] } + , cs $ "Description: A valid full migration.\n\ + \Created: " <> tsStr <> "\n\ + \Depends: one two\n\ + \Apply: |\n\ + \ CREATE TABLE test (\n\ + \ a int\n\ + \ );\n\n\ + \Revert: |\n\ + \ DROP TABLE test;\n") + , (valid_full { mRevert = Nothing } + , cs $ "Description: A valid full migration.\n\ + \Created: " <> tsStr <> "\n\ + \Depends: another_migration\n\ + \Apply: |\n\ + \ CREATE TABLE test (\n\ + \ a int\n\ + \ );\n") + ] + +serializationTests :: [Test] +serializationTests = map mkSerializationTest serializationTestCases diff --git a/dbmigrations/test/FilesystemTest.hs b/dbmigrations/test/FilesystemTest.hs new file mode 100644 index 0000000..9240df9 --- /dev/null +++ b/dbmigrations/test/FilesystemTest.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} +module FilesystemTest + ( tests + ) +where + +import Database.Schema.Migrations.Filesystem +import Database.Schema.Migrations.Store ( MigrationStore(..) ) + +import Test.HUnit +import qualified Data.Set as Set +import Common + +tests :: IO [Test] +tests = sequence [getMigrationsTest] + +getMigrationsTest :: IO Test +getMigrationsTest = do + let store = filesystemStore $ FSStore { storePath = testFile "migration_parsing" } + expected = Set.fromList [ "invalid_field_name" + , "invalid_missing_required_fields" + , "invalid_syntax" + , "invalid_timestamp" + , "valid_full" + , "valid_no_depends" + , "valid_no_desc" + , "valid_no_revert" + , "valid_no_timestamp" + , "valid_with_comments" + , "valid_with_comments2" + , "valid_with_colon" + , "valid_with_multiline_deps" + ] + migrations <- getMigrations store + return $ expected ~=? Set.fromList migrations diff --git a/dbmigrations/test/InMemoryStore.hs b/dbmigrations/test/InMemoryStore.hs new file mode 100644 index 0000000..96b906a --- /dev/null +++ b/dbmigrations/test/InMemoryStore.hs @@ -0,0 +1,35 @@ +module InMemoryStore (inMemoryStore) where + +import Data.Text ( Text ) +import Data.String.Conversions ( cs ) + +import Control.Concurrent.MVar +import Database.Schema.Migrations.Migration +import Database.Schema.Migrations.Store + +type InMemoryData = [(Text, Migration)] + +-- |Builds simple in-memory store that uses 'MVar' to preserve a list of +-- migrations. +inMemoryStore :: IO MigrationStore +inMemoryStore = do + store <- newMVar [] + return MigrationStore { + loadMigration = loadMigrationInMem store + , saveMigration = saveMigrationInMem store + , getMigrations = getMigrationsInMem store + , fullMigrationName = return . cs + } + +loadMigrationInMem :: MVar InMemoryData -> Text -> IO (Either String Migration) +loadMigrationInMem store migId = withMVar store $ \migrations -> do + let mig = lookup migId migrations + return $ case mig of + Just m -> Right m + _ -> Left "Migration not found" + +saveMigrationInMem :: MVar InMemoryData -> Migration -> IO () +saveMigrationInMem store m = modifyMVar_ store $ return . ((mId m, m):) + +getMigrationsInMem :: MVar InMemoryData -> IO [Text] +getMigrationsInMem store = withMVar store $ return . fmap fst diff --git a/dbmigrations/test/LinearMigrationsTest.hs b/dbmigrations/test/LinearMigrationsTest.hs new file mode 100644 index 0000000..ab3649e --- /dev/null +++ b/dbmigrations/test/LinearMigrationsTest.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} +module LinearMigrationsTest (tests) where + +import InMemoryStore +import Test.HUnit + +import Common +import Control.Monad.Reader (runReaderT) +import Data.Text (Text) +import Data.Either (isRight) +import Database.Schema.Migrations.Migration +import Database.Schema.Migrations.Store +import Moo.CommandHandlers +import Moo.Core + +tests :: IO [Test] +tests = sequence [ addsMigration + , selectsLatestMigrationAsDep + , selectsOnlyLeavesAsDeps + , doesNotAddDependencyWhenLinearMigrationsAreDisabled + ] + +addsMigration :: IO Test +addsMigration = do + state <- prepareState "first" + mig <- addTestMigration state + satisfies "Migration not added" mig isRight + +selectsLatestMigrationAsDep :: IO Test +selectsLatestMigrationAsDep = do + state1 <- prepareState "first" + _ <- addTestMigration state1 + state2 <- prepareStateWith state1 "second" + Right mig <- addTestMigration state2 + return $ ["first"] ~=? mDeps mig + +selectsOnlyLeavesAsDeps :: IO Test +selectsOnlyLeavesAsDeps = do + state1 <- prepareNormalState "first" + addTestMigrationWithDeps state1 [] + state2 <- prepareStateWith state1 "second" + addTestMigrationWithDeps state2 ["first"] + state3 <- prepareStateWith state2 "third" + addTestMigrationWithDeps state3 ["first"] + state4' <- prepareStateWith state3 "fourth" + let state4 = state4' { _appLinearMigrations = True } + Right mig <- addTestMigration state4 + return $ ["second", "third"] ~=? mDeps mig + +doesNotAddDependencyWhenLinearMigrationsAreDisabled :: IO Test +doesNotAddDependencyWhenLinearMigrationsAreDisabled = do + state1 <- prepareNormalState "first" + _ <- addTestMigration state1 + state2 <- prepareStateWith state1 "second" + Right mig <- addTestMigration state2 + satisfies "Dependencies should be empty" (mDeps mig) null + +addTestMigration :: AppState -> IO (Either String Migration) +addTestMigration state = do + let store = _appStore state + [migrationId] = _appRequiredArgs state + runReaderT (newCommand $ _appStoreData state) state + loadMigration store migrationId + +addTestMigrationWithDeps :: AppState -> [Text] -> IO () +addTestMigrationWithDeps state deps = do + let store = _appStore state + let [migrationId] = _appRequiredArgs state + saveMigration store (newMigration migrationId) { mDeps = deps } + +prepareState :: Text -> IO AppState +prepareState m = do + store <- inMemoryStore + Right storeData <- loadMigrations store + return AppState { + _appOptions = CommandOptions Nothing False True + , _appBackend = undefined -- Not used here + , _appCommand = undefined -- Not used by newCommand + , _appRequiredArgs = [m] + , _appOptionalArgs = [] + , _appStore = store + , _appStoreData = storeData + , _appLinearMigrations = True + , _appTimestampFilenames = False + } + +prepareStateWith :: AppState -> Text -> IO AppState +prepareStateWith state m = do + Right storeData <- loadMigrations $ _appStore state + return state { _appRequiredArgs = [m], _appStoreData = storeData } + +prepareNormalState :: Text -> IO AppState +prepareNormalState m = do + state <- prepareState m + return $ state { _appLinearMigrations = False } diff --git a/dbmigrations/test/Main.hs b/dbmigrations/test/Main.hs new file mode 100644 index 0000000..4aeb008 --- /dev/null +++ b/dbmigrations/test/Main.hs @@ -0,0 +1,51 @@ +module Main where +import Prelude +import Test.HUnit +import System.Exit +import System.IO ( stderr ) + +import qualified DependencyTest +import qualified MigrationsTest +import qualified FilesystemSerializeTest +import qualified FilesystemParseTest +import qualified FilesystemTest +import qualified CycleDetectionTest +import qualified StoreTest +import qualified LinearMigrationsTest +import qualified ConfigurationTest + +import Control.Exception ( SomeException(..) ) + +loadTests :: IO [Test] +loadTests = do + + ioTests <- sequence [ do fspTests <- FilesystemParseTest.tests + return $ "Filesystem Parsing" ~: test fspTests + , do fsTests <- FilesystemTest.tests + return $ "Filesystem general" ~: test fsTests + , do linTests <- LinearMigrationsTest.tests + return $ "Linear migrations" ~: test linTests + , do cfgTests <- ConfigurationTest.tests + return $ "Configuration tests" ~: test cfgTests + ] + return $ concat [ ioTests + , DependencyTest.tests + , FilesystemSerializeTest.tests + , MigrationsTest.tests + , CycleDetectionTest.tests + , StoreTest.tests + ] + +tempDatabase :: String +tempDatabase = "dbmigrations_test" + +ignoreException :: SomeException -> IO () +ignoreException _ = return () + +main :: IO () +main = do + tests <- loadTests + (testResults, _) <- runTestText (putTextToHandle stderr False) $ test tests + if errors testResults + failures testResults > 0 + then exitFailure + else exitSuccess diff --git a/dbmigrations/test/MigrationsTest.hs b/dbmigrations/test/MigrationsTest.hs new file mode 100644 index 0000000..a53a994 --- /dev/null +++ b/dbmigrations/test/MigrationsTest.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE TypeSynonymInstances,GeneralizedNewtypeDeriving,MultiParamTypeClasses,FlexibleInstances,OverloadedStrings #-} +module MigrationsTest + ( tests + ) +where + +import Test.HUnit +import Control.Applicative ((<$>)) +import qualified Data.Map as Map +import Data.Time.Clock ( UTCTime ) + +import Database.Schema.Migrations +import Database.Schema.Migrations.Store hiding (getMigrations) +import Database.Schema.Migrations.Migration +import Database.Schema.Migrations.Backend + +tests :: [Test] +tests = migrationsToApplyTests + +testBackend :: [Migration] -> Backend +testBackend testMs = + Backend { getBootstrapMigration = undefined + , isBootstrapped = return True + , applyMigration = const undefined + , revertMigration = const undefined + , getMigrations = return $ mId <$> testMs + , commitBackend = return () + , rollbackBackend = return () + , disconnectBackend = return () + } + +-- |Given a backend and a store, what are the list of migrations +-- missing in the backend that are available in the store? +type MissingMigrationTestCase = (MigrationMap, Backend, Migration, + [Migration]) + +ts :: UTCTime +ts = read "2009-04-15 10:02:06 UTC" + +blankMigration :: Migration +blankMigration = Migration { mTimestamp = Just ts + , mId = undefined + , mDesc = Nothing + , mApply = "" + , mRevert = Nothing + , mDeps = [] + } + +missingMigrationsTestcases :: [MissingMigrationTestCase] +missingMigrationsTestcases = [ (m, testBackend [], one, [one]) + , (m, testBackend [one], one, []) + , (m, testBackend [one], two, [two]) + , (m, testBackend [one, two], one, []) + , (m, testBackend [one, two], two, []) + ] + where + one = blankMigration { mId = "one" } + two = blankMigration { mId = "two", mDeps = ["one"] } + m = Map.fromList [ (mId e, e) | e <- [one, two] ] + +mkTest :: MissingMigrationTestCase -> Test +mkTest (mapping, backend, theMigration, expected) = + let Right graph = depGraphFromMapping mapping + storeData = StoreData mapping graph + result = migrationsToApply storeData backend theMigration + in "a test" ~: do + actual <- result + return $ expected == actual + +migrationsToApplyTests :: [Test] +migrationsToApplyTests = map mkTest missingMigrationsTestcases diff --git a/dbmigrations/test/StoreTest.hs b/dbmigrations/test/StoreTest.hs new file mode 100644 index 0000000..4db956f --- /dev/null +++ b/dbmigrations/test/StoreTest.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE OverloadedStrings #-} +module StoreTest + ( tests + ) +where + +import Test.HUnit +import qualified Data.Map as Map + +import Database.Schema.Migrations.Migration +import Database.Schema.Migrations.Store + +tests :: [Test] +tests = validateSingleMigrationTests + ++ validateMigrationMapTests + +type ValidateSingleTestCase = ( MigrationMap + , Migration + , [MapValidationError] + ) + +type ValidateMigrationMapTestCase = ( MigrationMap + , [MapValidationError] + ) + +emptyMap :: MigrationMap +emptyMap = Map.fromList [] + +partialMap :: MigrationMap +partialMap = Map.fromList [ ("one", undefined) + , ("three", undefined) + ] + +fullMap :: MigrationMap +fullMap = Map.fromList [ ("one", undefined) + , ("two", undefined) + , ("three", undefined) + ] + +withDeps :: Migration +withDeps = Migration { mTimestamp = undefined + , mId = "with_deps" + , mDesc = Just "with dependencies" + , mApply = "" + , mRevert = Nothing + , mDeps = ["one", "two", "three"] + } + +noDeps :: Migration +noDeps = Migration { mTimestamp = undefined + , mId = "no_deps" + , mDesc = Just "no dependencies" + , mApply = "" + , mRevert = Nothing + , mDeps = [] + } + +validateSingleTestCases :: [ValidateSingleTestCase] +validateSingleTestCases = [ (emptyMap, withDeps, [ DependencyReferenceError (mId withDeps) "one" + , DependencyReferenceError (mId withDeps) "two" + , DependencyReferenceError (mId withDeps) "three" + ] + ) + , (emptyMap, noDeps, []) + , (partialMap, withDeps, [DependencyReferenceError (mId withDeps) "two"]) + , (fullMap, withDeps, []) + , (fullMap, noDeps, []) + ] + +validateSingleMigrationTests :: [Test] +validateSingleMigrationTests = + map mkValidateSingleTest validateSingleTestCases + where + mkValidateSingleTest (mmap, m, errs) = + errs ~=? validateSingleMigration mmap m + +m1 :: Migration +m1 = noDeps { mId = "m1" + , mDeps = [] } + +m2 :: Migration +m2 = noDeps { mId = "m2" + , mDeps = ["m1"] } + +m3 :: Migration +m3 = noDeps { mId = "m3" + , mDeps = ["nonexistent"] } + +m4 :: Migration +m4 = noDeps { mId = "m4" + , mDeps = ["one", "two"] } + +map1 :: MigrationMap +map1 = Map.fromList [ ("m1", m1) + , ("m2", m2) + ] + +map2 :: MigrationMap +map2 = Map.fromList [ ("m3", m3) + ] + +map3 :: MigrationMap +map3 = Map.fromList [ ("m4", m4) + ] + +validateMapTestCases :: [ValidateMigrationMapTestCase] +validateMapTestCases = [ (emptyMap, []) + , (map1, []) + , (map2, [DependencyReferenceError (mId m3) "nonexistent"]) + , (map3, [ DependencyReferenceError (mId m4) "one" + , DependencyReferenceError (mId m4) "two"]) + ] + +validateMigrationMapTests :: [Test] +validateMigrationMapTests = + map mkValidateMapTest validateMapTestCases + where + mkValidateMapTest (mmap, errs) = + errs ~=? validateMigrationMap mmap diff --git a/dbmigrations/test/config_loading/cfg1.cfg b/dbmigrations/test/config_loading/cfg1.cfg new file mode 100644 index 0000000..4804398 --- /dev/null +++ b/dbmigrations/test/config_loading/cfg1.cfg @@ -0,0 +1,3 @@ +DBM_DATABASE = "connection" +DBM_MIGRATION_STORE = "store" +DBM_LINEAR_MIGRATIONS = on diff --git a/dbmigrations/test/config_loading/cfg_ts.cfg b/dbmigrations/test/config_loading/cfg_ts.cfg new file mode 100644 index 0000000..8ca8844 --- /dev/null +++ b/dbmigrations/test/config_loading/cfg_ts.cfg @@ -0,0 +1,4 @@ +DBM_DATABASE = "connection" +DBM_MIGRATION_STORE = "store" +DBM_LINEAR_MIGRATIONS = on +DBM_TIMESTAMP_FILENAMES = true diff --git a/dbmigrations/test/config_loading/invalid.cfg b/dbmigrations/test/config_loading/invalid.cfg new file mode 100644 index 0000000..1145e94 --- /dev/null +++ b/dbmigrations/test/config_loading/invalid.cfg @@ -0,0 +1,3 @@ +MALFORMED_ = +CONFIG = ASD +FILE diff --git a/dbmigrations/test/config_loading/missing.cfg b/dbmigrations/test/config_loading/missing.cfg new file mode 100644 index 0000000..e69de29 diff --git a/dbmigrations/test/config_loading/moo.cfg b/dbmigrations/test/config_loading/moo.cfg new file mode 100644 index 0000000..af94e74 --- /dev/null +++ b/dbmigrations/test/config_loading/moo.cfg @@ -0,0 +1,3 @@ +DBM_DATABASE = "mooconn" +DBM_MIGRATION_STORE = "moostore" +DBM_LINEAR_MIGRATIONS = on diff --git a/dbmigrations/test/example_store/root b/dbmigrations/test/example_store/root new file mode 100644 index 0000000..9486003 --- /dev/null +++ b/dbmigrations/test/example_store/root @@ -0,0 +1,10 @@ +Description: The first migration in the store. +Created: 2009-04-15 10:02:06 UTC +Depends: +Apply: + + CREATE TABLE test (a int); + +Revert: + + DROP TABLE test; diff --git a/dbmigrations/test/example_store/update1 b/dbmigrations/test/example_store/update1 new file mode 100644 index 0000000..c8ee23e --- /dev/null +++ b/dbmigrations/test/example_store/update1 @@ -0,0 +1,10 @@ +Description: Add another meaningless column to test. +Created: 2009-04-15 10:04:31 UTC +Depends: root +Apply: + + ALTER TABLE test ADD b int; + +Revert: + + ALTER TABLE test DROP COLUMN b; diff --git a/dbmigrations/test/example_store/update2 b/dbmigrations/test/example_store/update2 new file mode 100644 index 0000000..66e2ecb --- /dev/null +++ b/dbmigrations/test/example_store/update2 @@ -0,0 +1,10 @@ +Description: Add a constraint on test.b. +Created: 2009-04-15 11:36:49 UTC +Depends: update1 +Apply: + + CREATE UNIQUE INDEX test_b_idx ON test(b); + +Revert: + + DROP INDEX test_b_idx; diff --git a/dbmigrations/test/migration_parsing/invalid_field_name.txt b/dbmigrations/test/migration_parsing/invalid_field_name.txt new file mode 100644 index 0000000..6e6ba89 --- /dev/null +++ b/dbmigrations/test/migration_parsing/invalid_field_name.txt @@ -0,0 +1,11 @@ +Description: The first migration in the store. +InvalidField: bogus +Created: 2009-04-15 10:02:06 UTC +Depends: valid +Apply: + + CREATE TABLE test (a int); + +Revert: + + DROP TABLE test; diff --git a/dbmigrations/test/migration_parsing/invalid_missing_required_fields.txt b/dbmigrations/test/migration_parsing/invalid_missing_required_fields.txt new file mode 100644 index 0000000..d50962d --- /dev/null +++ b/dbmigrations/test/migration_parsing/invalid_missing_required_fields.txt @@ -0,0 +1,8 @@ +Description: A valid full migration. +Apply: + + CREATE TABLE test ( + a int + ); + +Revert: DROP TABLE test; diff --git a/dbmigrations/test/migration_parsing/invalid_syntax.txt b/dbmigrations/test/migration_parsing/invalid_syntax.txt new file mode 100644 index 0000000..3776626 --- /dev/null +++ b/dbmigrations/test/migration_parsing/invalid_syntax.txt @@ -0,0 +1,9 @@ +Description: The first migration in the store. +Created: 2009-04-15 10:02:06 UTC +Depends: valid +Apply: +CREATE TABLE test (a int); + +Revert: + + DROP TABLE test; diff --git a/dbmigrations/test/migration_parsing/invalid_timestamp.txt b/dbmigrations/test/migration_parsing/invalid_timestamp.txt new file mode 100644 index 0000000..ab1e48c --- /dev/null +++ b/dbmigrations/test/migration_parsing/invalid_timestamp.txt @@ -0,0 +1,10 @@ +Description: The first migration in the store. +Created: 209-41-15 :02:06 UTC +Depends: valid +Apply: + + CREATE TABLE test (a int); + +Revert: + + DROP TABLE test; diff --git a/dbmigrations/test/migration_parsing/valid_full.txt b/dbmigrations/test/migration_parsing/valid_full.txt new file mode 100644 index 0000000..c072eb2 --- /dev/null +++ b/dbmigrations/test/migration_parsing/valid_full.txt @@ -0,0 +1,10 @@ +Description: A valid full migration. +Created: 2009-04-15 10:02:06 UTC +Depends: another_migration +Apply: + + CREATE TABLE test ( + a int + ); + +Revert: DROP TABLE test; diff --git a/dbmigrations/test/migration_parsing/valid_no_depends.txt b/dbmigrations/test/migration_parsing/valid_no_depends.txt new file mode 100644 index 0000000..747e7fe --- /dev/null +++ b/dbmigrations/test/migration_parsing/valid_no_depends.txt @@ -0,0 +1,10 @@ +Description: A valid full migration. +Created: 2009-04-15 10:02:06 UTC +Depends: +Apply: + + CREATE TABLE test ( + a int + ); + +Revert: DROP TABLE test; diff --git a/dbmigrations/test/migration_parsing/valid_no_desc.txt b/dbmigrations/test/migration_parsing/valid_no_desc.txt new file mode 100644 index 0000000..b839762 --- /dev/null +++ b/dbmigrations/test/migration_parsing/valid_no_desc.txt @@ -0,0 +1,9 @@ +Created: 2009-04-15 10:02:06 UTC +Depends: another_migration +Apply: + + CREATE TABLE test ( + a int + ); + +Revert: DROP TABLE test; diff --git a/dbmigrations/test/migration_parsing/valid_no_revert.txt b/dbmigrations/test/migration_parsing/valid_no_revert.txt new file mode 100644 index 0000000..bdec1ce --- /dev/null +++ b/dbmigrations/test/migration_parsing/valid_no_revert.txt @@ -0,0 +1,8 @@ +Description: A valid full migration. +Created: 2009-04-15 10:02:06 UTC +Depends: another_migration +Apply: + + CREATE TABLE test ( + a int + ); diff --git a/dbmigrations/test/migration_parsing/valid_no_timestamp.txt b/dbmigrations/test/migration_parsing/valid_no_timestamp.txt new file mode 100644 index 0000000..0bdf8e2 --- /dev/null +++ b/dbmigrations/test/migration_parsing/valid_no_timestamp.txt @@ -0,0 +1,9 @@ +Description: A valid full migration. +Depends: another_migration +Apply: + + CREATE TABLE test ( + a int + ); + +Revert: DROP TABLE test; diff --git a/dbmigrations/test/migration_parsing/valid_with_colon.txt b/dbmigrations/test/migration_parsing/valid_with_colon.txt new file mode 100644 index 0000000..d45cc48 --- /dev/null +++ b/dbmigrations/test/migration_parsing/valid_with_colon.txt @@ -0,0 +1,11 @@ +Description: A valid full migration. +Created: 2009-04-15 10:02:06 UTC +Depends: another_migration +Apply: | + + -- Comment on a line with a colon: + CREATE TABLE test ( + a int + ); + +Revert: DROP TABLE test; diff --git a/dbmigrations/test/migration_parsing/valid_with_comments.txt b/dbmigrations/test/migration_parsing/valid_with_comments.txt new file mode 100644 index 0000000..42f3ecd --- /dev/null +++ b/dbmigrations/test/migration_parsing/valid_with_comments.txt @@ -0,0 +1,13 @@ +# This is a test migration. It includes all fields with valid values +# and takes advantage of most parser corner-cases and features. + +Description: A valid full migration. +Created: 2009-04-15 10:02:06 UTC +Depends: another_migration +Apply: + + CREATE TABLE test ( + a int + ); + +Revert: DROP TABLE test; diff --git a/dbmigrations/test/migration_parsing/valid_with_comments2.txt b/dbmigrations/test/migration_parsing/valid_with_comments2.txt new file mode 100644 index 0000000..c2546d4 --- /dev/null +++ b/dbmigrations/test/migration_parsing/valid_with_comments2.txt @@ -0,0 +1,11 @@ +Description: A valid full migration. +Created: 2009-04-15 10:02:06 UTC +Depends: another_migration +Apply: | + + -- Comment on a line + CREATE TABLE test ( + a int -- comment inline + ); + +Revert: DROP TABLE test; diff --git a/dbmigrations/test/migration_parsing/valid_with_multiline_deps.txt b/dbmigrations/test/migration_parsing/valid_with_multiline_deps.txt new file mode 100644 index 0000000..f305af3 --- /dev/null +++ b/dbmigrations/test/migration_parsing/valid_with_multiline_deps.txt @@ -0,0 +1,15 @@ +Description: A valid full migration. +Created: 2009-04-15 10:02:06 UTC + +Depends: + one + two + three + +Apply: + + CREATE TABLE test ( + a int + ); + +Revert: DROP TABLE test; diff --git a/default.nix b/default.nix index 3a8d683..8b8f489 100644 --- a/default.nix +++ b/default.nix @@ -1,16 +1,4 @@ -{ mkDerivation, base, dbmigrations, HDBC, HDBC-postgresql, HUnit -, process, stdenv -}: -mkDerivation { - pname = "dbmigrations-postgresql"; - version = "2.0.0"; - src = ./.; - isLibrary = false; - isExecutable = true; - executableHaskellDepends = [ base dbmigrations HDBC-postgresql ]; - testHaskellDepends = [ - base dbmigrations HDBC HDBC-postgresql HUnit process - ]; - description = "The dbmigrations tool built for PostgreSQL databases"; - license = stdenv.lib.licenses.bsd3; -} +let + nixpkgs = import ./nixpkgs.nix; +in +{ dbmigrations-postgresql = nixpkgs.dbmigrations-postgresql; } diff --git a/nixpkgs.nix b/nixpkgs.nix new file mode 100644 index 0000000..4ac9438 --- /dev/null +++ b/nixpkgs.nix @@ -0,0 +1,28 @@ +let + nixpkgSrc = builtins.fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/1cd56fc68216423a0413294c8e56453166be87dd.tar.gz"; + sha256 = "0cihxsy5958l9nk0rlnwd1bz4ayhrp7v5bspjdrmfgwgv40j0rw3"; + }; + + overlay = self: super: { + project-pkg-set = self.haskell.packages.ghc883.override { + overrides = hself: hsuper: { + dbmigrations = hself.callPackage ./dbmigrations/default.nix {}; + dbmigrations-postgresql = hself.callPackage ./dbmigrations-postgresql/default.nix {}; + + project-packages = [ + hself.dbmigrations + hself.dbmigrations-postgresql + ]; + }; + }; + + dbmigrations-postgresql = self.buildEnv { + name = "dbmigrations-postgresql "; + paths = self.project-pkg-set.project-packages; + }; + }; +in +import nixpkgSrc { + overlays = [ overlay ]; +} diff --git a/shell.nix b/shell.nix index b154924..12298d3 100644 --- a/shell.nix +++ b/shell.nix @@ -3,12 +3,14 @@ let inherit ( nixpkgs ) pkgs; inherit ( pkgs ) haskellPackages; - project = import ./release.nix; + project = import ./nixpkgs.nix; in pkgs.stdenv.mkDerivation { name = "dbmigrations-postgresql"; - buildInputs = project.env.nativeBuildInputs ++ [ - haskellPackages.cabal-install - haskellPackages.ghcid + buildInputs = project.dbmigrations-postgresql.nativeBuildInputs ++ [ + pkgs.postgresql + pkgs.haskellPackages.cabal-install + pkgs.haskellPackages.ghc + pkgs.haskellPackages.ghcid ]; } From e2af68d2e757594e31a1d3deda5fc94310c12d7a Mon Sep 17 00:00:00 2001 From: ken Date: Sat, 13 Jun 2020 02:19:21 -0500 Subject: [PATCH 3/3] one pinned.nix --- dbmigrations-postgresql/nix/pinned.nix | 11 ----------- dbmigrations-postgresql/release.nix | 2 +- dbmigrations-postgresql/shell.nix | 2 +- dbmigrations/nix/pinned.nix | 11 ----------- dbmigrations/release.nix | 2 +- dbmigrations/shell.nix | 2 +- 6 files changed, 4 insertions(+), 26 deletions(-) delete mode 100644 dbmigrations-postgresql/nix/pinned.nix delete mode 100644 dbmigrations/nix/pinned.nix diff --git a/dbmigrations-postgresql/nix/pinned.nix b/dbmigrations-postgresql/nix/pinned.nix deleted file mode 100644 index 2aac730..0000000 --- a/dbmigrations-postgresql/nix/pinned.nix +++ /dev/null @@ -1,11 +0,0 @@ -let - pkgs = import {}; -in -import ( - pkgs.fetchFromGitHub { - owner = "nixos"; - repo = "nixpkgs"; - rev = "1cd56fc68216423a0413294c8e56453166be87dd"; - sha256 = "0cihxsy5958l9nk0rlnwd1bz4ayhrp7v5bspjdrmfgwgv40j0rw3"; - } -) diff --git a/dbmigrations-postgresql/release.nix b/dbmigrations-postgresql/release.nix index 772d9d7..7005903 100644 --- a/dbmigrations-postgresql/release.nix +++ b/dbmigrations-postgresql/release.nix @@ -1,4 +1,4 @@ let - pkgs = import ./nix/pinned.nix {}; + pkgs = import ../nix/pinned.nix {}; in pkgs.haskellPackages.callPackage ./default.nix {} diff --git a/dbmigrations-postgresql/shell.nix b/dbmigrations-postgresql/shell.nix index b154924..0bffed9 100644 --- a/dbmigrations-postgresql/shell.nix +++ b/dbmigrations-postgresql/shell.nix @@ -1,4 +1,4 @@ -{ nixpkgs ? import ./nix/pinned.nix {} }: +{ nixpkgs ? import ../nix/pinned.nix {} }: let inherit ( nixpkgs ) pkgs; inherit ( pkgs ) haskellPackages; diff --git a/dbmigrations/nix/pinned.nix b/dbmigrations/nix/pinned.nix deleted file mode 100644 index 2aac730..0000000 --- a/dbmigrations/nix/pinned.nix +++ /dev/null @@ -1,11 +0,0 @@ -let - pkgs = import {}; -in -import ( - pkgs.fetchFromGitHub { - owner = "nixos"; - repo = "nixpkgs"; - rev = "1cd56fc68216423a0413294c8e56453166be87dd"; - sha256 = "0cihxsy5958l9nk0rlnwd1bz4ayhrp7v5bspjdrmfgwgv40j0rw3"; - } -) diff --git a/dbmigrations/release.nix b/dbmigrations/release.nix index 1c2ec34..3fdadcd 100644 --- a/dbmigrations/release.nix +++ b/dbmigrations/release.nix @@ -1,4 +1,4 @@ let - pkgs = import ./nix/pinned.nix {}; + pkgs = import ../nix/pinned.nix {}; in pkgs.haskellPackages.callPackage ./default.nix {} diff --git a/dbmigrations/shell.nix b/dbmigrations/shell.nix index 03291f1..c28e192 100644 --- a/dbmigrations/shell.nix +++ b/dbmigrations/shell.nix @@ -1,4 +1,4 @@ -{ nixpkgs ? import ./nix/pinned.nix {} }: +{ nixpkgs ? import ../nix/pinned.nix {} }: let inherit ( nixpkgs ) pkgs; inherit ( pkgs ) haskellPackages;