diff --git a/hasql-migration.cabal b/hasql-migration.cabal --- a/hasql-migration.cabal +++ b/hasql-migration.cabal @@ -1,5 +1,5 @@ name: hasql-migration -version: 0.1.3 +version: 0.2.0 synopsis: PostgreSQL Schema Migrations homepage: https://github.com/tvh/hasql-migration Bug-reports: https://github.com/tvh/hasql-migration/issues @@ -7,12 +7,12 @@ license-file: License author: Timo von Holtz maintainer: Timo von Holtz -copyright: Timo von Holtz, Andreas Meingast +copyright: Timo von Holtz, Andreas Meingast, Sumit Raja category: Database build-type: Simple cabal-version: >= 1.10 description: A PostgreSQL-simple schema migration utility - +tested-with: GHC==8.0.1, GHC==8.2.2, GHC==8.4.3 extra-source-files: License Readme.markdown @@ -26,34 +26,35 @@ type: git location: git://github.com/tvh/hasql-migration -Library +library exposed-modules: Hasql.Migration Hasql.Migration.Util hs-source-dirs: src ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns default-language: Haskell2010 - build-depends: base >= 4.7 && < 5.0, - base64-bytestring >= 1.0 && < 1.1, - bytestring >= 0.10 && < 0.11, - contravariant >= 1.3 && < 1.5, - cryptohash >= 0.11 && < 0.12, - data-default-class >= 0.0.1 && < 0.2, - directory >= 1.2 && < 1.4, - hasql >= 0.19 && < 0.20, - hasql-transaction >= 0.5 && < 0.6, - text >= 1.2 && < 1.3, - time >= 1.4 && < 1.7 + build-depends: base >= 4.7 && < 5, + bytestring >= 0.10, + contravariant >= 1.3, + cryptonite >= 0.11, + data-default-class >= 0.0.1, + directory >= 1.2, + hasql >= 1.3, + hasql-transaction >= 0.7, + memory, + text >= 1.2, + time >= 1.4 -test-suite tests +test-suite hasql-migration-test main-is: Main.hs hs-source-dirs: test ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns + other-modules: Hasql.MigrationTest default-language: Haskell2010 type: exitcode-stdio-1.0 - build-depends: base >= 4.7 && < 5.0, - bytestring >= 0.10 && < 0.11, - hasql >= 0.19 && < 0.20, + build-depends: base >= 4.7 && < 5, + bytestring >= 0.10, + hasql >= 0.19, hasql-migration, - hasql-transaction >= 0.5 && < 0.6, - hspec >= 2.2 && < 2.4, - transformers >= 0.3 && < 0.6 + hasql-transaction >= 0.5, + hspec >= 2.2, + transformers >= 0.3 diff --git a/src/Hasql/Migration.hs b/src/Hasql/Migration.hs --- a/src/Hasql/Migration.hs +++ b/src/Hasql/Migration.hs @@ -23,7 +23,7 @@ -- * Migration types , MigrationCommand(..) - , MigrationResult(..) + , MigrationError(..) , ScriptName , Checksum @@ -35,20 +35,18 @@ ) where import Control.Arrow -import Control.Applicative +import Crypto.Hash (hashWith, MD5(..)) +import Data.ByteArray.Encoding import Data.Default.Class import Data.Functor.Contravariant import Data.List (isPrefixOf, sort) -import Data.Monoid -import Data.Traversable (forM) import Data.Time (LocalTime) +import Data.Traversable (forM) import Hasql.Migration.Util (existsTable) -import Hasql.Query +import Hasql.Statement import Hasql.Transaction import System.Directory (getDirectoryContents) -import qualified Crypto.Hash.MD5 as MD5 (hash) import qualified Data.ByteString as BS (ByteString, readFile) -import qualified Data.ByteString.Base64 as B64 (encode) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Hasql.Decoders as Decoders @@ -59,10 +57,10 @@ -- Returns 'MigrationSuccess' if the provided 'MigrationCommand' executes -- without error. If an error occurs, execution is stopped and -- a 'MigrationError' is returned. -runMigration :: MigrationCommand -> Transaction (MigrationResult String) +runMigration :: MigrationCommand -> Transaction (Maybe MigrationError) runMigration cmd = case cmd of MigrationInitialization -> - initializeSchema >> return MigrationSuccess + initializeSchema >> return Nothing MigrationScript name contents -> executeMigration name contents MigrationValidation validationCmd -> @@ -87,21 +85,20 @@ scriptsInDirectory dir = fmap (sort . filter (\x -> not $ "." `isPrefixOf` x)) (getDirectoryContents dir) - -- | Executes a generic SQL migration for the provided script 'name' with -- content 'contents'. -executeMigration :: ScriptName -> BS.ByteString -> Transaction (MigrationResult String) +executeMigration :: ScriptName -> BS.ByteString -> Transaction (Maybe MigrationError) executeMigration name contents = do let checksum = md5Hash contents checkScript name checksum >>= \case ScriptOk -> do - return MigrationSuccess + return Nothing ScriptNotExecuted -> do sql contents - query (name, checksum) (statement q (contramap (first T.pack) def) Decoders.unit False) - return MigrationSuccess + statement (name, checksum) (Statement q (contramap (first T.pack) def) Decoders.unit False) + return Nothing ScriptModified _ -> do - return (MigrationError name) + return (Just $ ScriptChanged name) where q = "insert into schema_migrations(filename, checksum) values($1, $2)" @@ -123,25 +120,25 @@ -- * 'MigrationInitialization': validate the presence of the meta-information -- table. -- * 'MigrationValidation': always succeeds. -executeValidation :: MigrationCommand -> Transaction (MigrationResult String) +executeValidation :: MigrationCommand -> Transaction (Maybe MigrationError) executeValidation cmd = case cmd of MigrationInitialization -> existsTable "schema_migrations" >>= \r -> return $ if r - then MigrationSuccess - else MigrationError "No such table: schema_migrations" + then Nothing + else (Just NotInitialised) MigrationScript name contents -> validate name contents MigrationValidation _ -> - return MigrationSuccess + return Nothing where validate name contents = checkScript name (md5Hash contents) >>= \case ScriptOk -> do - return MigrationSuccess + return Nothing ScriptNotExecuted -> do - return (MigrationError $ "Missing: " ++ name) + return (Just $ ScriptMissing name) ScriptModified _ -> do - return (MigrationError $ "Checksum mismatch: " ++ name) + return (Just $ ChecksumMismatch name) -- | Checks the status of the script with the given name 'name'. -- If the script has already been executed, the checksum of the script @@ -150,7 +147,7 @@ -- will be executed and its meta-information will be recorded. checkScript :: ScriptName -> Checksum -> Transaction CheckScriptResult checkScript name checksum = - query name (statement q (contramap T.pack (Encoders.value def)) (Decoders.maybeRow (Decoders.value def)) False) >>= \case + statement name (Statement q (contramap T.pack (Encoders.param def)) (Decoders.rowMaybe (Decoders.column def)) False) >>= \case Nothing -> return ScriptNotExecuted Just actualChecksum | checksum == actualChecksum -> @@ -166,7 +163,7 @@ -- | Calculates the MD5 checksum of the provided bytestring in base64 -- encoding. md5Hash :: BS.ByteString -> Checksum -md5Hash = T.decodeUtf8 . B64.encode . MD5.hash +md5Hash = T.decodeUtf8 . convertToBase Base64 . hashWith MD5 -- | The checksum type of a migration script. type Checksum = T.Text @@ -198,18 +195,13 @@ -- ^ The script has not been executed, yet. This is good. deriving (Show, Eq, Read, Ord) --- | A sum-type denoting the result of a migration. -data MigrationResult a - = MigrationError a - -- ^ There was an error in script migration. - | MigrationSuccess - -- ^ All scripts have been executed successfully. - deriving (Show, Eq, Read, Ord) +-- | Errors that could occur when a migration is validated or performed +data MigrationError = ScriptChanged String | NotInitialised | ScriptMissing String | ChecksumMismatch String deriving (Show, Eq, Read, Ord) -- | Produces a list of all executed 'SchemaMigration's. getMigrations :: Transaction [SchemaMigration] getMigrations = - query () $ statement q def (Decoders.rowsList decodeSchemaMigration) False + statement () $ Statement q def (Decoders.rowList decodeSchemaMigration) False where q = mconcat [ "select filename, checksum, executed_at " @@ -233,6 +225,6 @@ decodeSchemaMigration :: Decoders.Row SchemaMigration decodeSchemaMigration = SchemaMigration - <$> Decoders.value def - <*> Decoders.value def - <*> Decoders.value def + <$> Decoders.column def + <*> Decoders.column def + <*> Decoders.column def diff --git a/src/Hasql/Migration/Util.hs b/src/Hasql/Migration/Util.hs --- a/src/Hasql/Migration/Util.hs +++ b/src/Hasql/Migration/Util.hs @@ -16,17 +16,17 @@ ( existsTable ) where -import Hasql.Query +import Hasql.Statement import qualified Hasql.Encoders as Encoders import qualified Hasql.Decoders as Decoders -import Hasql.Transaction (query, Transaction) +import Hasql.Transaction (statement, Transaction) import Data.Text (Text) import Data.Default.Class -- | Checks if the table with the given name exists in the database. existsTable :: Text -> Transaction Bool existsTable table = - fmap (not . null) $ query table q + fmap (not . null) $ statement table q where - q = statement sql (Encoders.value def) (Decoders.rowsList (Decoders.value Decoders.int8)) False - sql = "select count(relname) from pg_class where relname = $1" + q = Statement sql (Encoders.param def) (Decoders.rowList (Decoders.column Decoders.int8)) False + sql = "select relname from pg_class where relname = $1" diff --git a/test/Hasql/MigrationTest.hs b/test/Hasql/MigrationTest.hs --- a/test/Hasql/MigrationTest.hs +++ b/test/Hasql/MigrationTest.hs @@ -14,7 +14,7 @@ module Hasql.MigrationTest where -import Hasql.Session (run, Error) +import Hasql.Session (run, QueryError) import Hasql.Connection import qualified Hasql.Transaction as Tx import qualified Hasql.Transaction.Sessions as Tx @@ -23,7 +23,7 @@ import Test.Hspec (Spec, describe, it, shouldBe, runIO) -runTx :: Connection -> Tx.Transaction a -> IO (Either Error a) +runTx :: Connection -> Tx.Transaction a -> IO (Either QueryError a) runTx con act = do run (Tx.transaction Tx.ReadCommitted Tx.Write act) con @@ -36,15 +36,15 @@ it "initializes a database" $ do r <- runTx con $ runMigration $ MigrationInitialization - r `shouldBe` Right MigrationSuccess + r `shouldBe` Right Nothing it "creates the schema_migrations table" $ do - r <- runTx con $ existsTable "schema_migration" + r <- runTx con $ existsTable "schema_migrations" r `shouldBe` Right True it "executes a migration script" $ do r <- runTx con $ runMigration $ migrationScript - r `shouldBe` Right MigrationSuccess + r `shouldBe` Right Nothing it "creates the table from the executed script" $ do r <- runTx con $ existsTable "t1" @@ -52,15 +52,15 @@ it "skips execution of the same migration script" $ do r <- runTx con $ runMigration $ migrationScript - r `shouldBe` Right MigrationSuccess + r `shouldBe` Right Nothing it "reports an error on a different checksum for the same script" $ do r <- runTx con $ runMigration $ migrationScriptAltered - r `shouldBe` Right (MigrationError "test.sql") + r `shouldBe` Right (Just (ScriptChanged "test.sql")) it "executes migration scripts inside a folder" $ do r <- runTx con $ runMigration $ migrationDir - r `shouldBe` Right MigrationSuccess + r `shouldBe` Right Nothing it "creates the table from the executed scripts" $ do r <- runTx con $ existsTable "t2" @@ -68,7 +68,7 @@ it "executes a file based migration script" $ do r <- runTx con $ runMigration $ migrationFile - r `shouldBe` Right MigrationSuccess + r `shouldBe` Right Nothing it "creates the table from the executed scripts" $ do r <- runTx con $ existsTable "t3" @@ -76,19 +76,19 @@ it "validates initialization" $ do r <- runTx con $ runMigration $ (MigrationValidation MigrationInitialization) - r `shouldBe` Right MigrationSuccess + r `shouldBe` Right Nothing it "validates an executed migration script" $ do r <- runTx con $ runMigration $ (MigrationValidation migrationScript) - r `shouldBe` Right MigrationSuccess + r `shouldBe` Right Nothing it "validates all scripts inside a folder" $ do r <- runTx con $ runMigration $ (MigrationValidation migrationDir) - r `shouldBe` Right MigrationSuccess + r `shouldBe` Right Nothing it "validates an executed migration file" $ do r <- runTx con $ runMigration $ (MigrationValidation migrationFile) - r `shouldBe` Right MigrationSuccess + r `shouldBe` Right Nothing it "gets a list of executed migrations" $ do r <- runTx con getMigrations diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -8,7 +8,7 @@ -- Stability : experimental -- Portability : GHC -- --- The test entry-point for postgresql-simple-migration. +-- The test entry-point for hasql-migration. {-# LANGUAGE OverloadedStrings #-} @@ -18,11 +18,11 @@ import Hasql.Connection import Hasql.MigrationTest -import Test.Hspec (hspec) +import Test.Hspec (hspec) main :: IO () main = do - con <- acquire "dbname=test" - case con of + conE <- acquire "dbname=test" + case conE of Right con -> hspec (migrationSpec con) Left err -> putStrLn $ show err