Changed error handling

hasql-migration.cabal

@@ -1,13 +1,13 @@
 name:                       hasql-migration
-version:                    0.1.3
+version:                    0.1.4
 synopsis:                   PostgreSQL Schema Migrations
 homepage:                   https://github.com/tvh/hasql-migration
 Bug-reports:                https://github.com/tvh/hasql-migration/issues
 license:                    BSD3
 license-file:               License
 author:                     Timo von Holtz <[email protected]>
 maintainer:                 Timo von Holtz <[email protected]>
-copyright:                  Timo von Holtz, Andreas Meingast
+copyright:                  Timo von Holtz, Andreas Meingast, Sumit Raja
 category:                   Database
 build-type:                 Simple
 cabal-version:              >= 1.10
@@ -26,7 +26,7 @@ source-repository head
     type:                   git
     location:               git://github.com/tvh/hasql-migration
 
-Library
+library
     exposed-modules:        Hasql.Migration
                             Hasql.Migration.Util
     hs-source-dirs:         src
@@ -44,10 +44,11 @@ Library
                             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,

src/Hasql/Migration.hs

@@ -23,7 +23,7 @@ module Hasql.Migration
 
     -- * Migration types
     , MigrationCommand(..)
-    , MigrationResult(..)
+    , MigrationError(..)
     , ScriptName
     , Checksum
 
@@ -34,14 +34,12 @@ module Hasql.Migration
     , SchemaMigration(..)
     ) where
 
-import Control.Applicative
 import Control.Arrow
 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.Time (LocalTime)
 import Data.Traversable (forM)
 import Hasql.Migration.Util (existsTable)
@@ -59,10 +57,10 @@ import qualified Hasql.Encoders as Encoders
 -- 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 :: FilePath -> IO [String]
 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
+            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 @@ initializeSchema = do
 -- * '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
@@ -198,13 +195,8 @@ data CheckScriptResult
     -- ^ 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]

src/Hasql/Migration/Util.hs

@@ -29,4 +29,4 @@ existsTable table =
     fmap (not . null) $ query 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"
+        sql = "select relname from pg_class where relname = $1"

test/Hasql/MigrationTest.hs

@@ -36,59 +36,59 @@ migrationSpec con = describe "Migrations" $ do
 
     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"
         r `shouldBe` Right True
 
     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"
         r `shouldBe` Right True
 
     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"
         r `shouldBe` Right True
 
     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

test/Main.hs

@@ -22,7 +22,7 @@ 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