packages feed

peregrin (empty) → 0.1.0

raw patch · 7 files changed

+459/−0 lines, 7 filesdep +basedep +hspecdep +peregrinsetup-changed

Dependencies added: base, hspec, peregrin, pg-harness-client, postgresql-simple, resource-pool, text, transformers

Files

+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2017 Bardur Arantsson++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ peregrin.cabal view
@@ -0,0 +1,44 @@+Name:                peregrin+Version:             0.1.0+Synopsis:            Database migration support for use in other libraries.+Description:         Database migration support for use in other libraries.+                     Currently only supports PostgreSQL.+License:             MIT+License-file:        LICENSE+Category:            Database+Cabal-version:       >=1.10+Build-type:          Simple+Author:              Bardur Arantsson+Maintainer:          Bardur Arantsson <bardur@scientician.net>++Source-Repository head+  Type:     git+  Location: https://github.com/BardurArantsson/peregrin++Library+  build-depends:      base >= 4.9 && < 5+                    , postgresql-simple >= 0.5.2.1 && < 0.6+                    , text >= 1.1.0 && < 2+  default-language:   Haskell2010+  ghc-options:        -Wall+  hs-source-dirs:     src+  exposed-modules:    Database.Peregrin.Metadata+                      Database.Peregrin++Test-Suite tests+  type:               exitcode-stdio-1.0+  hs-source-dirs:     src-test+  main-is:            Main.hs+  build-depends:      base == 4.*+                    , pg-harness-client >= 0.4.0 && < 0.5.0+                    , postgresql-simple >= 0.5.2.1 && < 0.6+                    , resource-pool >= 0.2.1 && < 0.3+                    , text >= 1.0 && < 2+                    , transformers >= 0.5.2 && < 0.6+                    -- Self-dependency:+                    , peregrin+                    -- Test framework:+                    , hspec >= 2.2.0 && < 3.0+  default-language:   Haskell2010+  ghc-options:        -Wall+  other-modules:      Database.PeregrinSpec
+ src-test/Database/PeregrinSpec.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Database.PeregrinSpec+    ( mkMigrateSpec+    ) where++import           Control.Exception (Exception, bracket)+import           Control.Monad (forM_)+import           Control.Monad.Trans.Class (lift)+import           Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)+import           Database.Peregrin+import           Database.Peregrin.Metadata+import           Data.Pool (Pool, withResource, destroyAllResources)+import           Data.Text (Text)+import           Database.PostgreSQL.Simple (Connection, Query, Only(..), FromRow)+import qualified Database.PostgreSQL.Simple as PS+import           Test.Hspec (Spec, Selector, describe)+import qualified Test.Hspec as Hspec++-- | Create specs.+mkMigrateSpec :: IO (Pool Connection) -> Spec+mkMigrateSpec mkConnectionPool =+  forM_ [DefaultSchema, NamedSchema "foobar"] $ \schema -> do+    -- Show which case we're in+    let extra = case schema of+                  DefaultSchema -> " (default schema)"+                  NamedSchema _ -> " (named schema)"+    -- Specs:+    describe ("migrate" ++ extra) $ do+      it "can apply a single migration" $ do+        -- Exercise:+        migrate' schema [ (cid0, createXSql) ]+        -- Verify:+        assertCanSelectFromX++      it "ignores migrations that have already been applied (single call)" $ do+        -- Exercise:+        migrate' schema [ (cid0, createXSql)+                        , (cid0, createXSql) -- Would fail if applied again+                        ]+        -- Verify:+        assertCanSelectFromX++      it "ignores migrations that have already been applied (multiple calls)" $ do+        -- Exercise:+        migrate' schema [ (cid0, createXSql) ]+        migrate' schema [ (cid0, createXSql) ] -- Would fail if applied again+        -- Verify:+        assertCanSelectFromX++      it "throws an error if SQL is changed for a given change set ID" $ do+        -- Exercise:+        migrate' schema [ (cid0, createXSql) ]+        migrate' schema [ (cid0, createXSqlBad) ]+          -- Verify: Should throw here+          `shouldThrow` (== MigrationModifiedError cid0)++      it "can apply multiple distinct migrations in a single call" $ do+        -- Exercise+        migrate' schema [ (cid0, createXSql)+                        , (cid1, createYSql)+                        ]+        -- Verify: Make sure both migrations have been applied+        assertCanSelectFromXY++  where+    it msg action = Hspec.it msg $+      bracket mkConnectionPool destroyAllResources $ runReaderT action++    createXSql = "CREATE TABLE X (A INT)"+    createYSql = "CREATE TABLE Y (B INT)"+    createXSqlBad = "CREATE TABLE X (Y CHAR(1))"++    assertCanSelectFromX =+      assertCanQuery_ "SELECT * FROM X"++    assertCanSelectFromXY =+      assertCanQuery_ "SELECT * FROM X, Y where X.A = Y.B"++    cid0 = "a328156d-9875-4471-8192-0c86959badb3"+    cid1 = "00c6159c-c7f6-4cec-b63f-f70c1c4c7bb1"++assertCanQuery_ :: Query -> ReaderT (Pool Connection) IO ()+assertCanQuery_ q = do+  _ :: [Only Int] <- query_ q+  return ()++query_ :: FromRow a => Query -> ReaderT (Pool Connection) IO [a]+query_ sql = do+  connectionPool <- ask+  withResource connectionPool $ \connection ->+    lift $ PS.query_ connection sql++shouldThrow :: Exception e => ReaderT (Pool Connection) IO a -> Selector e -> ReaderT (Pool Connection) IO ()+shouldThrow action selector = do+  connectionPool <- ask+  lift (Hspec.shouldThrow (runReaderT action connectionPool) selector)++migrate' :: Schema -> [(Text, Text)] -> ReaderT (Pool Connection) IO ()+migrate' schema migrations = do+  connectionPool <- ask+  lift $ withResource connectionPool $ \connection ->+    migrate connection schema migrations
+ src-test/Main.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}+module Main ( main ) where++import           Control.Applicative ((<$>))+import           Database.PeregrinSpec ( mkMigrateSpec )+import           Data.Pool (createPool)+import qualified Database.PostgreSQL.Harness.Client as H+import           Database.PostgreSQL.Simple (connectPostgreSQL, close)+import           Test.Hspec++main :: IO ()+main = do+  -- HSpec has no easy way to get "other" command line parameters, so+  -- we'll just settle for a hardcoded value here.+  let url = "http://localhost:8900"+  -- Connection pool creation function. We use a fresh temporary+  -- database for every connection pool.+  let mkConnectionPool = do+        connectionString <- H.toConnectionString <$> H.createTemporaryDatabase url+        createPool (connectPostgreSQL connectionString) close 1 1 5+  -- Run+  hspec $ mkMigrateSpec mkConnectionPool
+ src/Database/Peregrin.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Database.Peregrin+    ( migrate+    , MigrationError(..)+    ) where++import           Control.Applicative ((<$>))+import           Control.Exception (Exception, throwIO)+import           Control.Monad (forM_, when, void)+import           Database.Peregrin.Metadata+import           Data.Text (Text)+import qualified Data.Text as T+import           Data.Int (Int32, Int64)+import           Data.Maybe (listToMaybe, fromMaybe)+import           Data.String (fromString)+import           Database.PostgreSQL.Simple (Connection, Only(..), Query)+import qualified Database.PostgreSQL.Simple as P+import           Database.PostgreSQL.Simple.ToField (ToField(..))+import           Database.PostgreSQL.Simple.FromRow (FromRow(..), field)+import           Database.PostgreSQL.Simple.Transaction (withTransactionLevel, IsolationLevel(..))++-- | Migration information stored in 'migration' table.+data Migration = Migration Text Text++instance FromRow Migration where+  fromRow = Migration <$> field <*> field++-- | Exception happened running migrations.+data MigrationError =+    -- | The migration with the given ID has been modified in the+    -- program code since it was applied. Since this can have very+    -- unpredictable effects it is considered an error.+    MigrationModifiedError Text+  deriving (Show, Eq)++instance Exception MigrationError++-- | Context for migrations.+data MigrationContext = MigrationContext { mcMetaMigrationTable :: Table+                                         , mcMigrationTable :: Table+                                         }++-- | Apply a list of migrations to a database. For example,+--+-- > migrate conn schema [("a", "CREATE TABLE ...")]+-- >                     [("b", "INSERT INTO TABLE ...")]+--+-- will apply the given SQL statements __in order__ and track them by+-- the identifiers "a" and "b". It is recommended to use __fixed__,+-- randomly generated UUIDs to identify migrations, though you are+-- free to use whatever identifiers you like as long as they are+-- unique within the given schema. For example, on a Linux system you+-- can run the command `uuidgen -r` on the command line and paste that+-- into your migration list.+--+-- The given 'Schema' parameter indicates the schema used for the+-- /metadata/ stored to track which migrations have been applied. It+-- does not affect the migrations themselves in any way. Therefore,+-- __ALL__ migrations should __ALWAYS__ specify their schema+-- explicitly in the SQL.+--+-- Any migrations that have already been applied will be skipped. If+-- the SQL text for any given migration /changes/, a+-- 'MigrationModifiedError' exception will be thrown.+--+-- Migrations are tracked using two tables, namely+-- "@\__peregrin_migration_meta\__@" and "@\__peregrin_migration\__@",+-- which will automatically be created in the given 'Schema'.+--+migrate :: Connection -> Schema -> [(Text, Text)] -> IO ()+migrate connection schema =+    migrate' tables connection schema+  where+    tables = MigrationContext { mcMetaMigrationTable = Table schema "__peregrin_migration_meta__"+                              , mcMigrationTable = Table schema "__peregrin_migration__"+                              }++migrate' :: MigrationContext -> Connection -> Schema -> [(Text, Text)] -> IO ()+migrate' tables c schema migrations = do+  -- Must always create the "migration_meta" table (and its+  -- schema) if necessary. Having just created this table without+  -- any rows represents "version 0" of the metadata data+  -- structures. These operations are idempotent and so we don't+  -- need any lock.+  void $ transact $ execute sqlCreateSchema [ schema ]+  void $ transact $ execute sqlCreateMetaTbl [ metaTable ]+  -- Apply meta-migrations.+  withLock $+    -- Apply meta-migrations; these are hardcoded for obvious reasons.+    -- EXCEPT for the very first migration, NO changes may be made to+    -- the "migration_meta" table in any migration here. This is to+    -- ensure 'perpetual' compatibility.+    metaMigrate 1 [ (sqlInsertMetaVersion0, [metaTable])+                  , (sqlCreateMigrationTbl, [migrationTable])+                  ]+  -- Apply all the migrations; we do it one-by-one since our lock is+  -- itself automatically released by PostgreSQL at the end of each of+  -- each transaction.+  forM_ migrations $ \(mid, sql) ->+    withLock $ do+      -- Check if change set has already been applied+      existingMigration :: (Maybe Migration) <-+        listToMaybe <$> query sqlFindMigration+                          [ toField migrationTable+                          , toField mid ]+      case existingMigration of+        Just (Migration _ sql') | sql == sql' ->+          return ()+        Just _ ->+          throwIO $ MigrationModifiedError mid+        Nothing -> do+          void $ execute sqlInsertMigration [ toField migrationTable+                                            , toField mid+                                            , toField sql+                                            ]+          void $ execute_ $ fromString $ T.unpack sql++  where++    -- Tables+    migrationTable = mcMigrationTable tables+    metaTable = mcMetaMigrationTable tables++    -- Apply a meta-migration.+    metaMigrate :: ToField a => Int32 -> [(Query, [a])] -> IO ()+    metaMigrate metaVersion sqls = do+      -- Get the meta-version; defaults to 0 if we've only just+      -- created the metadata table.+      Only currentMetaVersion <- fromMaybe (Only 0) <$> fmap listToMaybe (query sqlGetMetaVersion [metaTable])+      -- If the migration is applicable, then we apply it.+      when (currentMetaVersion + 1 == metaVersion) $ do+        forM_ sqls $ \(q, ps) -> execute q ps+        rowCount <- execute sqlUpdateMetaVersion [ toField metaTable+                                                 , toField metaVersion+                                                 , toField currentMetaVersion+                                                 ]+        when (rowCount /= 1) $ error $ "Unexpected row count " ++ show rowCount ++ " from update on \"migration_meta\" table!"++    -- Shorthand:+    transact = withTransactionLevel ReadCommitted c++    execute :: ToField a => Query -> [a] -> IO Int64+    execute = P.execute c++    execute_ :: Query -> IO Int64+    execute_ = P.execute_ c++    query :: (ToField a, FromRow r) => Query -> [a] -> IO [r]+    query = P.query c++    -- Perform a transaction with the exclusive lock held. The lock is+    -- automatically released when the transaction ends.+    withLock txn =+      transact $ do+        void $ execute sqlLockMetaTbl [metaTable]+        txn++    -- Support SQL:+    sqlCreateSchema =+      "CREATE SCHEMA IF NOT EXISTS ?"++    sqlCreateMetaTbl =+      "CREATE TABLE IF NOT EXISTS ? (\+      \  \"meta_version\" INTEGER PRIMARY KEY\+      \)"++    sqlGetMetaVersion =+      "SELECT \"meta_version\" FROM ?"++    sqlUpdateMetaVersion =+      "UPDATE ? \+      \   SET \"meta_version\" = ? \+      \ WHERE \"meta_version\" = ?"++    sqlLockMetaTbl =+      "LOCK TABLE ? IN ACCESS EXCLUSIVE MODE"++    sqlInsertMetaVersion0 =+      "INSERT INTO ? (\"meta_version\") VALUES (0)"++    sqlCreateMigrationTbl =+      "CREATE TABLE ? ( \+      \  \"id\" TEXT PRIMARY KEY,\+      \  \"sql\" TEXT NOT NULL\+      \)"++    sqlFindMigration =+      "SELECT \"id\", \"sql\"\+      \ FROM ? \+      \ WHERE \"id\" = ?"++    sqlInsertMigration =+      "INSERT INTO ? \+       \           (\"id\", \"sql\") \+       \    VALUES (?, ?)"
+ src/Database/Peregrin/Metadata.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings #-}+module Database.Peregrin.Metadata+    ( Schema(..)+    , Table(..)+    , ToSQL(..)+    , Typ(..)+    ) where++import qualified Data.Text as T+import           Data.Text (Text)+import           Database.PostgreSQL.Simple.ToField (ToField(..))+import           Database.PostgreSQL.Simple.Types (Identifier(..), QualifiedIdentifier(..))++-- | A schema designation.+data Schema = DefaultSchema+            | NamedSchema Text++instance ToField Schema where+  toField schema = toField $ Identifier $ schemaToText schema++-- | Convert schema to 'Text'.+schemaToText :: Schema -> Text+schemaToText DefaultSchema = "public"+schemaToText (NamedSchema schemaId) = schemaId++-- | Create a qualified identifier.+mkQualifiedIdentifier :: Schema -> Text -> QualifiedIdentifier+mkQualifiedIdentifier schema = QualifiedIdentifier (Just $ schemaToText schema)++-- | Table name, including which schema it is in.+data Table = Table Schema Text++instance ToField Table where+  toField (Table schema name) = toField $ mkQualifiedIdentifier schema name++-- | Type name, including which schema it is in.+data Typ = Typ Schema Text++instance ToField Typ where+  toField (Typ schema name) = toField $ mkQualifiedIdentifier schema name++-- | Quote a PostgreSQL object identifier. Useful in circumstances+-- where you need to quote a dynamically generated identifier.+quoteToSQL :: Text -> Text+quoteToSQL i = T.concat [ singleQt+                        , T.replace singleQt doubleQt i+                        , singleQt+                        ]+  where+    singleQt = "\""+    doubleQt = "\"\""++-- | Convert metadata object identifier to its quoted SQL+-- representation.+class ToSQL a where+    toSQL :: a -> Text++--+-- Instances+--++instance ToSQL Schema where+  toSQL DefaultSchema = quoteToSQL "public"+  toSQL (NamedSchema schemaId) = quoteToSQL schemaId++instance ToSQL Table where+  toSQL (Table schema tableId) =+    T.concat [toSQL schema, ".", quoteToSQL tableId]++instance ToSQL Typ where+  toSQL (Typ schema tableId) =+    T.concat [toSQL schema, ".", quoteToSQL tableId]