peregrin 0.1.1 → 0.2.0

raw patch · 4 files changed

+107/−86 lines, 4 filesdep +bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring

API changes (from Hackage documentation)

Files

• peregrin.cabal +2/−1
• src-test/Database/PeregrinSpec.hs +57/−16
• src/Database/Peregrin.hs +30/−15
• src/Database/Peregrin/Metadata.hs +18/−54

@@ -1,5 +1,5 @@ Name:                peregrin-Version:             0.1.1+Version:             0.2.0 Synopsis:            Database migration support for use in other libraries. Description:         Database migration support for use in other libraries.                      Currently only supports PostgreSQL.@@ -17,6 +17,7 @@  Library   build-depends:      base >= 4.9 && < 5+                    , bytestring >= 0.10 && < 0.11                     , postgresql-simple >= 0.5.2.1 && < 0.6                     , text >= 1.1.0 && < 2   default-language:   Haskell2010

@@ -13,7 +13,7 @@ import           Database.Peregrin.Metadata import           Data.Pool (Pool, withResource, destroyAllResources) import           Data.Text (Text)-import           Database.PostgreSQL.Simple (Connection, Query, Only(..), FromRow)+import           Database.PostgreSQL.Simple (Connection, Query, Only(..), FromRow, ToRow) import qualified Database.PostgreSQL.Simple as PS import           Test.Hspec (Spec, Selector, describe) import qualified Test.Hspec as Hspec@@ -30,40 +30,71 @@     describe ("migrate" ++ extra) $ do       it "can apply a single migration" $ do         -- Exercise:-        migrate' schema [ (cid0, createXSql) ]+        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+        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+        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) ]+        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)+        migrate' schema [ (cid0, createXSql, ())+                        , (cid1, createYSql, ())                         ]         -- Verify: Make sure both migrations have been applied         assertCanSelectFromXY +      it "can apply parameterized migrations" $ do+        -- Setup+        let table = Only $ QIdentifier schema "X"+        -- Exercise+        migrate' schema [ (cid0, createTableSql, table)+                        ]+        -- Verify:+        assertCanSelectFromP table++      it "can apply identical parameterized migrations with different parameters" $ do+        -- Setup:+        let tableX = QIdentifier schema "X"+        let tableY = QIdentifier schema "Y"+        -- Exercise:+        migrate' schema [ (cid0, createTableSql, Only tableX)+                        , (cid1, createTableSql, Only tableY)+                        ]+        -- Verify:+        assertCanSelectFromPP (tableX, tableY)++      it "can apply parameterized migrations with different parameter 'shapes'" $ do+        -- Setup:+        let tableX = QIdentifier schema "X"+        let tableY = QIdentifier schema "Y"+        -- Exercise:+        migrate' schema [ (cid0, "CREATE TABLE ? (X INT)", QP $ Only $ tableX)+                        , (cid1, "CREATE TABLE ? (? INT)", QP $ (tableY, Identifier "Y"))+                        ]+        -- Verify:+        assertCanSelectFromPP (tableX, tableY)+   where     it msg action = Hspec.it msg $       bracket mkConnectionPool destroyAllResources $ runReaderT action@@ -72,32 +103,42 @@     createYSql = "CREATE TABLE Y (B INT)"     createXSqlBad = "CREATE TABLE X (Y CHAR(1))" +    createTableSql = "CREATE TABLE ? (X INT)"+     assertCanSelectFromX =       assertCanQuery_ "SELECT * FROM X"+    assertCanSelectFromP p =+      assertCanQuery "SELECT * FROM ?" p+    assertCanSelectFromPP p =+      assertCanQuery "SELECT * FROM ?, ?" p      assertCanSelectFromXY =-      assertCanQuery_ "SELECT * FROM X, Y where X.A = Y.B"+      assertCanQuery_ "SELECT * FROM X, Y"      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+  assertCanQuery q ()++assertCanQuery :: ToRow p => Query -> p -> ReaderT (Pool Connection) IO ()+assertCanQuery q p = do+  _ :: [Only Int] <- query q p   return () -query_ :: FromRow a => Query -> ReaderT (Pool Connection) IO [a]-query_ sql = do+query :: (ToRow p, FromRow a) => Query -> p -> ReaderT (Pool Connection) IO [a]+query q p = do   connectionPool <- ask   withResource connectionPool $ \connection ->-    lift $ PS.query_ connection sql+    lift $ PS.query connection q p  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' :: ToRow p => Schema -> [(Text, Query, p)] -> ReaderT (Pool Connection) IO () migrate' schema migrations = do   connectionPool <- ask   lift $ withResource connectionPool $ \connection ->

@@ -1,27 +1,29 @@+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Database.Peregrin     ( migrate     , MigrationError(..)+    , QP(..)     ) where  import           Control.Applicative ((<$>)) import           Control.Exception (Exception, throwIO) import           Control.Monad (forM_, when, void)-import           Database.Peregrin.Metadata+import           Data.ByteString (ByteString) 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           Database.Peregrin.Metadata+import           Database.PostgreSQL.Simple (Connection, Only(..), formatQuery) import qualified Database.PostgreSQL.Simple as P import           Database.PostgreSQL.Simple.ToRow (ToRow(..))+import           Database.PostgreSQL.Simple.Types (Query(..)) 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+data Migration = Migration Text ByteString  instance FromRow Migration where   fromRow = Migration <$> field <*> field@@ -37,14 +39,21 @@ instance Exception MigrationError  -- | Context for migrations.-data MigrationContext = MigrationContext { mcMetaMigrationTable :: Table-                                         , mcMigrationTable :: Table+data MigrationContext = MigrationContext { mcMetaMigrationTable :: QIdentifier+                                         , mcMigrationTable :: QIdentifier                                          } +-- | Parameter wrapper for a query. Used in when there are several+-- sets of parameters which must have the same type.+data QP = forall p . ToRow p => QP p++instance ToRow QP where+  toRow (QP qp) = toRow qp+ -- | Apply a list of migrations to a database. For example, ----- > migrate conn schema [("a", "CREATE TABLE ...")]--- >                     [("b", "INSERT INTO TABLE ...")]+-- > migrate conn schema [("a", "CREATE TABLE ...", QP $ Only $ Table schema "foo")]+-- >                     [("b", "INSERT INTO TABLE ...", QP $ (Table schema "foo", "bar"))] -- -- will apply the given SQL statements __in order__ and track them by -- the identifiers "a" and "b". It is recommended to use __fixed__,@@ -54,6 +63,10 @@ -- can run the command `uuidgen -r` on the command line and paste that -- into your migration list. --+-- If the parameter sets are all of the same "shape" (type), then the+-- `P $` prefix may be omitted — it serves only to make sure that+-- the types match up.+-- -- 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,@@ -68,15 +81,15 @@ -- "@\__peregrin_migration_meta\__@" and "@\__peregrin_migration\__@", -- which will automatically be created in the given 'Schema'. ---migrate :: Connection -> Schema -> [(Text, Text)] -> IO ()+migrate :: ToRow p => Connection -> Schema -> [(Text, Query, p)] -> IO () migrate connection schema =     migrate' tables connection schema   where-    tables = MigrationContext { mcMetaMigrationTable = Table schema "__peregrin_migration_meta__"-                              , mcMigrationTable = Table schema "__peregrin_migration__"+    tables = MigrationContext { mcMetaMigrationTable = QIdentifier schema "__peregrin_migration_meta__"+                              , mcMigrationTable = QIdentifier schema "__peregrin_migration__"                               } -migrate' :: MigrationContext -> Connection -> Schema -> [(Text, Text)] -> IO ()+migrate' :: ToRow p => MigrationContext -> Connection -> Schema -> [(Text, Query, p)] -> 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@@ -97,8 +110,10 @@   -- 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) ->+  forM_ migrations $ \(mid, q, p) ->     withLock $ do+      -- Subsitute parameters+      sql <- formatQuery c q p       -- Check if change set has already been applied       existingMigration :: (Maybe Migration) <-         listToMaybe <$> query sqlFindMigration ( migrationTable@@ -114,7 +129,7 @@                                             , mid                                             , sql                                             )-          void $ execute_ $ fromString $ T.unpack sql+          void $ execute_ $ Query sql    where 

@@ -1,16 +1,28 @@ {-# LANGUAGE OverloadedStrings #-} module Database.Peregrin.Metadata-    ( Schema(..)-    , Table(..)-    , ToSQL(..)-    , Typ(..)+    ( Identifier(..)+    , QIdentifier(..)+    , Schema(..)     ) where -import qualified Data.Text as T import           Data.Text (Text) import           Database.PostgreSQL.Simple.ToField (ToField(..))-import           Database.PostgreSQL.Simple.Types (Identifier(..), QualifiedIdentifier(..))+import qualified Database.PostgreSQL.Simple.Types as PST +-- | An /unqalified/ identifier of an object in the database, i.e.+-- an identifier without an attached schema.+data Identifier = Identifier Text++instance ToField Identifier where+  toField (Identifier i) = toField $ PST.Identifier i++-- | A /qualified/ identifier of an object in the database, i.e.+-- an identifier with an attached schema.+data QIdentifier = QIdentifier Schema Text++instance ToField QIdentifier where+  toField (QIdentifier schema i) = toField $ PST.QualifiedIdentifier (Just $ schemaToText schema) i+ -- | A schema designation. data Schema = DefaultSchema             | NamedSchema Text@@ -22,51 +34,3 @@ 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]