hasql-migration (empty) → 0.1.0

raw patch · 10 files changed

+555/−0 lines, 10 filesdep +basedep +base64-bytestringdep +bytestringsetup-changed

Dependencies added: base, base64-bytestring, bytestring, contravariant, cryptohash, data-default-class, directory, hasql, hasql-migration, hasql-transaction, hspec, text, time, transformers

Files

• License +31/−0
• Readme.markdown +64/−0
• Setup.hs +2/−0
• hasql-migration.cabal +60/−0
• share/test/script.sql +1/−0
• share/test/scripts/1.sql +1/−0
• src/Hasql/Migration.hs +238/−0
• src/Hasql/Migration/Util.hs +32/−0
• test/Hasql/MigrationTest.hs +98/−0
• test/Main.hs +28/−0

@@ -0,0 +1,31 @@+Copyright (c) 2014, Andreas Meingast <ameingast@gmail.com>+Copyright (c) 2016, Timo von Holtz <tvh@tvholtz.de>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.

@@ -0,0 +1,64 @@+# PostgreSQL Migrations for Haskell++[![Build Status](https://api.travis-ci.org/tvh/hasql-migration.png)](https://travis-ci.org/tvh/hasql-migration)++Welcome to hasql-migrations, a tool for helping you with+PostgreSQL schema migrations. This is a port of+[postgresql-simple-migration](https://github.com/ameingast/postgresql-simple-migration)+for use with hasql.++## Why?+Database migrations should not be hard. They should be under version control+and documented in both your production systems and in your project files.++## What?+This library executes SQL/Haskell migration scripts and keeps track of their+meta information.++Scripts are be executed exactly once and any changes to scripts will cause+a run-time error notifying you of a corrupted database.++The meta information consists of:+* an MD5 checksum of the executed script to make sure already existing+  scripts cannot be modified in your production system.+* a time-stamp of the date of execution so you can easily track when a change+  happened.++This library also supports migration validation so you can ensure (some)+correctness before your application logic kicks in.++## How?+TODO++## Compilation and Tests+The program is built with the _cabal_ build system. The following command+builds the library, the standalone binary and the test package.++```bash+cabal configure --enable-tests && cabal build -j+```++To execute the tests, you need a running PostgreSQL server with an empty+database called _test_. Tests are executed through cabal as follows:++```bash+cabal configure --enable-tests && cabal test+```++To build the project in a cabal sandbox, use the following code:++```bash+cabal sandbox init+cabal install -j --only-dependencies --enable-tests --disable-documentation+cabal configure --enable-tests+cabal test+```++To remove the generated cabal sandbox, use:+```bash+cabal sandbox delete+```++## To Do+* Collect executed scripts and check if already executed scripts have been+  deleted.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,60 @@+name:                       hasql-migration+version:                    0.1.0+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 <tvh@tvholtz.de>+maintainer:                 Timo von Holtz <tvh@tvholtz.de>+copyright:                  2014-2016, Andreas Meingast+                            2016, Timo von Holtz+category:                   Database+build-type:                 Simple+cabal-version:              >= 1.10+description:                A PostgreSQL-simple schema migration utility++extra-source-files:         License+                            Readme.markdown++                            test/*.hs+                            test/Hasql/*.hs++                            share/test/*.sql+                            share/test/scripts/*.sql++source-repository head+    type:                   git+    location:               git://github.com/tvh/hasql-migration++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.3,+                            hasql                       >= 0.19     && < 0.20,+                            hasql-transaction           >= 0.4      && < 0.5,+                            text                        >= 1.2      && < 1.3,+                            time                        >= 1.4      && < 1.7++test-suite tests+    main-is:                Main.hs+    hs-source-dirs:         test+    ghc-options:            -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns+    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,+                            hasql-migration,+                            hasql-transaction           >= 0.4      && < 0.5,+                            hspec                       >= 2.2      && < 2.3,+                            transformers                >= 0.3      && < 0.6

@@ -0,0 +1,1 @@+create table t3 (c3 varchar);

@@ -0,0 +1,1 @@+create table t2 (c2 varchar);

@@ -0,0 +1,238 @@+-- |+-- Module      : Hasql..Migration+-- Copyright   : (c) 2016 Timo von Holtz <tvh@tvholtz.de>,+--               (c) 2014 Andreas Meingast <ameingast@gmail.com>+--+-- License     : BSD-style+-- Maintainer  : tvh@tvholtz.de+-- Stability   : experimental+-- Portability : GHC+--+-- A migration library for hasql.++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Hasql.Migration+    (+    -- * Migration actions+    runMigration+    , loadMigrationFromFile+    , loadMigrationsFromDirectory++    -- * Migration types+    , MigrationCommand(..)+    , MigrationResult(..)+    , ScriptName+    , Checksum++    -- * Migration result actions+    , getMigrations++    -- * Migration result types+    , SchemaMigration(..)+    ) where++import Control.Arrow+import Control.Applicative+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 Hasql.Migration.Util (existsTable)+import Hasql.Query+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+import qualified Hasql.Encoders as Encoders++-- | Executes a 'MigrationCommand'.+--+-- 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 cmd = case cmd of+    MigrationInitialization ->+        initializeSchema >> return MigrationSuccess+    MigrationScript name contents ->+        executeMigration name contents+    MigrationValidation validationCmd ->+        executeValidation validationCmd++-- | Load migrations from SQL scripts in the provided 'FilePath'+-- in alphabetical order.+loadMigrationsFromDirectory :: FilePath -> IO [MigrationCommand]+loadMigrationsFromDirectory dir = do+    scripts <- scriptsInDirectory dir+    forM scripts $ \f -> loadMigrationFromFile f (dir ++ "/" ++ f)++-- | load a migration from script located at the provided+-- 'FilePath'.+loadMigrationFromFile :: ScriptName -> FilePath -> IO MigrationCommand+loadMigrationFromFile name fp =+    MigrationScript name <$> BS.readFile fp+++-- | Lists all files in the given 'FilePath' 'dir' in alphabetical order.+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 name contents = do+    let checksum = md5Hash contents+    checkScript name checksum >>= \case+        ScriptOk -> do+            return MigrationSuccess+        ScriptNotExecuted -> do+            sql contents+            query (name, checksum) (statement q (contramap (first T.pack) def) Decoders.unit False)+            return MigrationSuccess+        ScriptModified _ -> do+            return (MigrationError name)+    where+        q = "insert into schema_migrations(filename, checksum) values($1, $2)"++-- | Initializes the database schema with a helper table containing+-- meta-information about executed migrations.+initializeSchema :: Transaction ()+initializeSchema = do+    sql $ mconcat+        [ "create table if not exists schema_migrations "+        , "( filename varchar(512) not null"+        , ", checksum varchar(32) not null"+        , ", executed_at timestamp without time zone not null default now() "+        , ");"+        ]++-- | Validates a 'MigrationCommand'. Validation is defined as follows for these+-- types:+--+-- * 'MigrationInitialization': validate the presence of the meta-information+-- table.+-- * 'MigrationValidation': always succeeds.+executeValidation :: MigrationCommand -> Transaction (MigrationResult String)+executeValidation cmd = case cmd of+    MigrationInitialization ->+        existsTable "schema_migrations" >>= \r -> return $ if r+            then MigrationSuccess+            else MigrationError "No such table: schema_migrations"+    MigrationScript name contents ->+        validate name contents+    MigrationValidation _ ->+        return MigrationSuccess+    where+        validate name contents =+            checkScript name (md5Hash contents) >>= \case+                ScriptOk -> do+                    return MigrationSuccess+                ScriptNotExecuted -> do+                    return (MigrationError $ "Missing: " ++ name)+                ScriptModified _ -> do+                    return (MigrationError $ "Checksum mismatch: " ++ name)++-- | Checks the status of the script with the given name 'name'.+-- If the script has already been executed, the checksum of the script+-- is compared against the one that was executed.+-- If there is no matching script entry in the database, the script+-- 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+        Nothing ->+            return ScriptNotExecuted+        Just actualChecksum | checksum == actualChecksum ->+            return ScriptOk+        Just actualChecksum ->+            return (ScriptModified actualChecksum)+    where+        q = mconcat+            [ "select checksum from schema_migrations "+            , "where filename = $1 limit 1"+            ]++-- | Calculates the MD5 checksum of the provided bytestring in base64+-- encoding.+md5Hash :: BS.ByteString -> Checksum+md5Hash = T.decodeUtf8 . B64.encode . MD5.hash++-- | The checksum type of a migration script.+type Checksum = T.Text++-- | The name of a script. Typically the filename or a custom name+-- when using Haskell migrations.+type ScriptName = String++-- | 'MigrationCommand' determines the action of the 'runMigration' script.+data MigrationCommand+    = MigrationInitialization+    -- ^ Initializes the database with a helper table containing meta+    -- information.+    | MigrationScript ScriptName BS.ByteString+    -- ^ Executes a migration based on the provided bytestring.+    | MigrationValidation MigrationCommand+    -- ^ Validates the provided MigrationCommand.+    deriving (Show, Eq, Read, Ord)++-- | A sum-type denoting the result of a single migration.+data CheckScriptResult+    = ScriptOk+    -- ^ The script has already been executed and the checksums match.+    -- This is good.+    | ScriptModified Checksum+    -- ^ The script has already been executed and there is a checksum+    -- mismatch. This is bad.+    | ScriptNotExecuted+    -- ^ 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)++-- | Produces a list of all executed 'SchemaMigration's.+getMigrations :: Transaction [SchemaMigration]+getMigrations =+    query () $ statement q def (Decoders.rowsList decodeSchemaMigration) False+    where+        q = mconcat+            [ "select filename, checksum, executed_at "+            , "from schema_migrations order by executed_at asc"+            ]++-- | A product type representing a single, executed 'SchemaMigration'.+data SchemaMigration = SchemaMigration+    { schemaMigrationName       :: BS.ByteString+    -- ^ The name of the executed migration.+    , schemaMigrationChecksum   :: Checksum+    -- ^ The calculated MD5 checksum of the executed script.+    , schemaMigrationExecutedAt :: LocalTime+    -- ^ A timestamp without timezone of the date of execution of the script.+    } deriving (Show, Eq, Read)++instance Ord SchemaMigration where+    compare (SchemaMigration nameLeft _ _) (SchemaMigration nameRight _ _) =+        compare nameLeft nameRight++decodeSchemaMigration :: Decoders.Row SchemaMigration+decodeSchemaMigration =+    SchemaMigration+    <$> Decoders.value def+    <*> Decoders.value def+    <*> Decoders.value def

@@ -0,0 +1,32 @@+-- |+-- Module      : Hasql.Migration.Util+-- Copyright   : (c) 2016 Timo von Holtz <tvh@tvholtz.de>,+--               (c) 2014-2016 Andreas Meingast <ameingast@gmail.com>+--+-- License     : BSD-style+-- Maintainer  : tvh@tvholtz.de+-- Stability   : experimental+-- Portability : GHC+--+-- A collection of utilites for database migrations.++{-# LANGUAGE OverloadedStrings #-}++module Hasql.Migration.Util+    ( existsTable+    ) where++import           Hasql.Query+import qualified Hasql.Encoders as Encoders+import qualified Hasql.Decoders as Decoders+import           Hasql.Transaction (query, 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+    where+        q = statement sql (Encoders.value def) (Decoders.rowsList (Decoders.value Decoders.int8)) False+        sql = "select count(relname) from pg_class where relname = $1"

@@ -0,0 +1,98 @@+-- |+-- Module      : Database.PostgreSQL.Simple.MigrationTest+-- Copyright   : (c) 2016 Timo von Holtz <tvh@tvholtz.de>,+--               (c) 2014 Andreas Meingast <ameingast@gmail.com>+--+-- License     : BSD-style+-- Maintainer  : tvh@tvholtz.de+-- Stability   : experimental+-- Portability : GHC+--+-- A collection of hasql-migration specifications.++{-# LANGUAGE OverloadedStrings #-}++module Hasql.MigrationTest where++import           Hasql.Session                        (run, Error)+import           Hasql.Connection+import qualified Hasql.Transaction                    as Tx+import           Hasql.Migration+import           Hasql.Migration.Util                 (existsTable)+import           Test.Hspec                           (Spec, describe, it,+                                                       shouldBe, runIO)++runTx :: Connection -> Tx.Transaction a -> IO (Either Error a)+runTx con act = do+    run (Tx.run act Tx.ReadCommitted Tx.Write) con++migrationSpec :: Connection -> Spec+migrationSpec con = describe "Migrations" $ do+    let migrationScript = MigrationScript "test.sql" q+    let migrationScriptAltered = MigrationScript "test.sql" ""+    [migrationDir] <- runIO $ loadMigrationsFromDirectory "share/test/scripts"+    migrationFile <- runIO $ loadMigrationFromFile "s.sql" "share/test/script.sql"++    it "initializes a database" $ do+        r <- runTx con $ runMigration $ MigrationInitialization+        r `shouldBe` Right MigrationSuccess++    it "creates the schema_migrations table" $ do+        r <- runTx con $ existsTable "schema_migration"+        r `shouldBe` Right True++    it "executes a migration script" $ do+        r <- runTx con $ runMigration $ migrationScript+        r `shouldBe` Right MigrationSuccess++    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++    it "reports an error on a different checksum for the same script" $ do+        r <- runTx con $ runMigration $ migrationScriptAltered+        r `shouldBe` Right (MigrationError "test.sql")++    it "executes migration scripts inside a folder" $ do+        r <- runTx con $ runMigration $ migrationDir+        r `shouldBe` Right MigrationSuccess++    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++    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++    it "validates an executed migration script" $ do+        r <- runTx con $ runMigration $ (MigrationValidation migrationScript)+        r `shouldBe` Right MigrationSuccess++    it "validates all scripts inside a folder" $ do+        r <- runTx con $ runMigration $ (MigrationValidation migrationDir)+        r `shouldBe` Right MigrationSuccess++    it "validates an executed migration file" $ do+        r <- runTx con $ runMigration $ (MigrationValidation migrationFile)+        r `shouldBe` Right MigrationSuccess++    it "gets a list of executed migrations" $ do+        r <- runTx con getMigrations+        fmap (map schemaMigrationName) r `shouldBe` Right ["test.sql", "1.sql", "s.sql"]++    where+        q = "create table t1 (c1 varchar);"+

@@ -0,0 +1,28 @@+-- |+-- Module      : Main+-- Copyright   : (c) 2014 Andreas Meingast <ameingast@gmail.com>+--               (c) 2016 Timo von Holtz <tvh@tvholtz.de>+--+-- License     : BSD-style+-- Maintainer  : tvh@tvholtz.de+-- Stability   : experimental+-- Portability : GHC+--+-- The test entry-point for postgresql-simple-migration.++{-# LANGUAGE OverloadedStrings #-}++module Main+    ( main+    ) where++import Hasql.Connection+import Hasql.MigrationTest+import           Test.Hspec                               (hspec)++main :: IO ()+main = do+    con <- acquire "dbname=test"+    case con of+      Right con -> hspec (migrationSpec con)+      Left err -> putStrLn $ show err