persistent-migration (empty) → 0.0.1

raw patch · 21 files changed

+1676/−0 lines, 21 filesdep +QuickCheckdep +basedep +bytestring

Dependencies added: QuickCheck, base, bytestring, conduit, containers, exceptions, fgl, monad-logger, mtl, persistent, persistent-migration, persistent-postgresql, persistent-template, process, resource-pool, tasty, tasty-golden, tasty-quickcheck, temporary, text, time, unordered-containers, yaml

Files

CHANGELOG.md +3/−0
LICENSE.md +11/−0
README.md +99/−0
persistent-migration.cabal +96/−0
src/Database/Persist/Migration.hs +56/−0
src/Database/Persist/Migration/Internal.hs +307/−0
src/Database/Persist/Migration/Postgres.hs +132/−0
src/Database/Persist/Migration/Utils/Data.hs +24/−0
src/Database/Persist/Migration/Utils/Plan.hs +38/−0
src/Database/Persist/Migration/Utils/Sql.hs +68/−0
test/Integration.hs +26/−0
test/Test/Integration/Migration.hs +218/−0
test/Test/Integration/Property.hs +65/−0
test/Test/Integration/Utils/Backends.hs +59/−0
test/Test/Integration/Utils/RunSql.hs +18/−0
test/Test/Unit/Migration.hs +72/−0
test/Test/Unit/Property.hs +91/−0
test/Test/Unit/Utils/Backends.hs +80/−0
test/Test/Utils/Goldens.hs +44/−0
test/Test/Utils/QuickCheck.hs +148/−0
test/Unit.hs +21/−0

+ CHANGELOG.md view

@@ -0,0 +1,3 @@+## persistent-migration 0.0.1++* Initial implementation

+ LICENSE.md view

@@ -0,0 +1,11 @@+Copyright 2018 Brandon Chinn++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 copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT HOLDER 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.

+ README.md view

@@ -0,0 +1,99 @@+# persistent-migration++This is a migration library for the+[persistent](http://www.stackage.org/package/persistent) package.++By default, persistent provides a way to do automatic migrations; how to+quickly and conveniently update the schema to match the definitions of the+models. Because of its automatic nature, it will also balk at any operations+that may delete data ("unsafe" migrations).++However, in a lot of production cases, you don't actually want this automatic+migration. You might want to be able to run certain unsafe migrations because+you know a column is safe to delete. You might want to be able to copy and+transform data from one column to another and then delete the old column. You+might want explicit/manual migrations for other reasons.++This package exposes an `Operation` data type that will be converted into SQL+by a persistent backend. To define a series of migrations, write a list of+these `Operations` and call `runMigration` from the appropriate backend module.+Each `Operation` represents a movement from one version of the schema to+another. `runMigration` will check to see the current version of the schema and+run the `Operations` necessary to get from the current version to the latest+version.++```+import Database.Persist.Migration+import Database.Persist.Sql (PersistValue(..), rawExecute, rawSql)++createPerson :: CreateTable+createPerson = CreateTable+  { ctName = "person"+  , ctSchema =+      [ Column "id" SqlInt32 [NotNull, AutoIncrement]+      , Column "name" SqlString [NotNull]+      , Column "age" SqlInt32 [NotNull]+      , Column "alive" SqlBool [NotNull]+      , Column "hometown" SqlInt64 [References ("cities", "id")]+      ]+  , ctConstraints =+      [ PrimaryKey ["id"]+      , Unique "person_identifier" ["name", "age", "hometown"]+      ]+  }++migrateHeight :: RawOperation+migrateHeight = RawOperation "Separate height into height_feet, height_inches" $+  rawSql "SELECT id, height FROM person" [] >>= traverse_ migrateHeight'+  where+    migrateHeight' (Single id', Single height) = do+      let (feet, inches) = quotRem height 12+      rawExecute "UPDATE person SET height_feet = ?, height_inches = ? WHERE id = ?"+        [ PersistInt64 feet+        , PersistInt64 inches+        , PersistInt64 id'+        ]++migration :: Migration+migration =+  -- first commit+  [ Operation (0 ~> 1) $ createPerson++  -- second commit+  , Operation (1 ~> 2) $ DropColumn ("person", "alive")+  , Operation (0 ~> 2) $ createPerson{ctSchema = filter ((/= "alive") . colName) $ ctSchema createPerson}+    -- Can define shorter paths for equivalent operations; version 2 should result in the same schema+    -- regardless of the path taken to get there.++  -- second commit+  , Operation (2 ~> 3) $ AddColumn "person" (Column "gender" SqlString []) Nothing+  , Operation (3 ~> 4) $ AddColumn "person" (Column "height" SqlInt32 [NotNull]) (Just "0")+    -- Non-null column needs a default for existing rows++  -- third commit+  , Operation (5 ~> 6) $ AddColumn "person" (Column "height_feet" SqlInt32 []) (Just "0")+  , Operation (6 ~> 7) $ AddColumn "person" (Column "height_inches" SqlInt32 []) (Just "0")+  , Operation (7 ~> 8) $ migrateHeight+  , Operation (8 ~> 9) $ DropColumn ("person", "height")+  ]+```++```+import Database.Persist.Migration (checkMigration, defaultSettings)+import Database.Persist.Migration.Postgres (runMigration)++-- the migration defined above+import MyMigration (migration)++-- the migration from persistent's mkMigrate+import MyMigration.Migrate (migrationDef)++main = do+  -- run the usual migration+  runMigration defaultSettings migration++  -- fails if persistent detects more migrations not accounted for+  checkMigration migrationDef+```++For more examples, see `test/Integration/Migration.hs`.

+ persistent-migration.cabal view

@@ -0,0 +1,96 @@+name:                persistent-migration+version:             0.0.1+license:             BSD3+license-file:        LICENSE.md+author:              Brandon Chinn <brandonchinn178@gmail.com>+maintainer:          Brandon Chinn <brandonchinn178@gmail.com>+category:            Database+synopsis:            Manual migrations for the persistent library+description:         Manual migrations for the persistent library.+build-type:          Simple+cabal-version:       1.18+extra-doc-files:     CHANGELOG.md, README.md++source-repository head+  type: git+  location: https://github.com/brandonchinn178/persistent-migration.git++library+  hs-source-dirs:     src+  default-language:   Haskell2010+  exposed-modules:    Database.Persist.Migration+                      Database.Persist.Migration.Internal+                      Database.Persist.Migration.Postgres+                      Database.Persist.Migration.Utils.Data+                      Database.Persist.Migration.Utils.Plan+                      Database.Persist.Migration.Utils.Sql+  build-depends:      base >= 4.7 && < 5+                    , containers+                    , fgl+                    , persistent+                    , mtl+                    , text+                    , time+                    , unordered-containers+  ghc-options:+    -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat+    -Wredundant-constraints -Wnoncanonical-monad-instances++test-suite persistent-migration-test+  type:               exitcode-stdio-1.0+  hs-source-dirs:     test+  default-language:   Haskell2010+  main-is:            Unit.hs+  other-modules:      Test.Unit.Migration+                      Test.Unit.Property+                      Test.Unit.Utils.Backends+                      Test.Utils.Goldens+                      Test.Utils.QuickCheck+  build-depends: base+               , bytestring+               , conduit+               , containers+               , mtl+               , persistent+               , persistent-migration+               , QuickCheck+               , tasty+               , tasty-golden+               , tasty-quickcheck+               , text+  ghc-options:+    -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat+    -Wredundant-constraints -Wnoncanonical-monad-instances++test-suite persistent-migration-integration+  type:               exitcode-stdio-1.0+  hs-source-dirs:     test+  default-language:   Haskell2010+  main-is:            Integration.hs+  other-modules:      Test.Integration.Migration+                      Test.Integration.Property+                      Test.Integration.Utils.Backends+                      Test.Integration.Utils.RunSql+                      Test.Utils.Goldens+                      Test.Utils.QuickCheck+  build-depends: base+               , bytestring+               , exceptions+               , monad-logger+               , mtl+               , process+               , persistent+               , persistent-migration+               , persistent-postgresql+               , persistent-template+               , resource-pool+               , QuickCheck+               , tasty+               , tasty-golden+               , tasty-quickcheck+               , temporary+               , text+               , yaml+  ghc-options:+    -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat+    -Wredundant-constraints -Wnoncanonical-monad-instances

+ src/Database/Persist/Migration.hs view

@@ -0,0 +1,56 @@+{-|+Module      :  Database.Persist.Migration+Maintainer  :  Brandon Chinn <brandonchinn178@gmail.com>+Stability   :  experimental+Portability :  portable++Defines a migration framework for the persistent library.+-}++module Database.Persist.Migration+  ( -- * Operation types+    Version+  , OperationPath+  , (~>)+  , Operation(..)+  -- * Migration types+  , Migration+  , MigrateBackend(..)+  , Migrateable(..)+  -- * Migration functions+  , MigrateSettings(..)+  , defaultSettings+  , hasMigration+  , checkMigration+  -- * Core operations+  , CreateTable(..)+  , DropTable(..)+  , AddColumn(..)+  , DropColumn(..)+  , RawOperation(..)+  , NoOp(..)+  -- * Auxiliary types+  , ColumnIdentifier+  , dotted+  , Column(..)+  , ColumnProp(..)+  , TableConstraint(..)+  ) where++import Control.Monad (unless)+import qualified Data.Text as Text+import Database.Persist.Migration.Internal+import qualified Database.Persist.Sql as Persistent++-- | True if the persistent library detects more migrations unaccounted for.+hasMigration :: Persistent.Migration -> Persistent.SqlPersistT IO Bool+hasMigration = fmap (not . null) . Persistent.showMigration++-- | Fails if the persistent library detects more migrations unaccounted for.+checkMigration :: Persistent.Migration -> Persistent.SqlPersistT IO ()+checkMigration migration = do+  migrationText <- Persistent.showMigration migration+  unless (null migrationText) $ fail $+    unlines $ "More migrations detected:" : bullets migrationText+  where+    bullets = map ((" * " ++ ) . Text.unpack)

+ src/Database/Persist/Migration/Internal.hs view

@@ -0,0 +1,307 @@+{-|+Module      :  Database.Persist.Migration.Internal+Maintainer  :  Brandon Chinn <brandonchinn178@gmail.com>+Stability   :  experimental+Portability :  portable++Defines a migration framework for the persistent library.+-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}++module Database.Persist.Migration.Internal where++import Control.Monad (unless, when)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Reader (mapReaderT)+import Data.Data (Data)+import Data.List (nub)+import Data.Maybe (fromMaybe, isNothing)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time.Clock (getCurrentTime)+import Database.Persist.Migration.Utils.Data (hasDuplicateConstrs)+import Database.Persist.Migration.Utils.Plan (getPath)+import Database.Persist.Sql+    (PersistValue(..), Single(..), SqlPersistT, rawExecute, rawSql)+import Database.Persist.Types (SqlType(..))++{- Operation types -}++-- | The version of a database. An operation migrates from the given version to another version.+--+-- The version must be increasing, such that the lowest version is the first version and the highest+-- version is the most up-to-date version.+type Version = Int++-- | The path that an operation takes.+type OperationPath = (Version, Version)++-- | An infix constructor for 'OperationPath'.+(~>) :: Int -> Int -> OperationPath+(~>) = (,)++-- | An operation that can be migrated.+data Operation =+  forall op. Migrateable op =>+  Operation+    { opPath :: OperationPath+    , opOp   :: op+    }++deriving instance Show Operation++{- Migration types -}++-- | A migration is simply a list of operations.+type Migration = [Operation]++-- | The backend to migrate with.+data MigrateBackend = MigrateBackend+  { createTable :: Bool -> CreateTable -> SqlPersistT IO [Text]+      -- ^ create a table (True = IF NOT EXISTS)+  , dropTable   :: DropTable -> SqlPersistT IO [Text]+  , addColumn   :: AddColumn -> SqlPersistT IO [Text]+  , dropColumn  :: DropColumn -> SqlPersistT IO [Text]+  }++-- | The type class for data types that can be migrated.+class Show op => Migrateable op where+  -- | Validate any checks for the given operation.+  validateOperation :: op -> Either String ()+  validateOperation _ = Right ()++  -- | Get the SQL queries to run the migration.+  getMigrationText :: MigrateBackend -> op -> SqlPersistT IO [Text]++-- | Get the current version of the database, or Nothing if none exists.+getCurrVersion :: MonadIO m => MigrateBackend -> SqlPersistT m (Maybe Version)+getCurrVersion backend = do+  -- create the persistent_migration table if it doesn't already exist+  mapReaderT liftIO (createTable backend True migrationSchema) >>= rawExecute'+  extractVersion <$> rawSql queryVersion []+  where+    migrationSchema = CreateTable+      { ctName = "persistent_migration"+      , ctSchema =+          [ Column "id" SqlInt32 [NotNull, AutoIncrement]+          , Column "version" SqlInt32 [NotNull]+          , Column "label" SqlString []+          , Column "timestamp" SqlDayTime [NotNull]+          ]+      , ctConstraints =+          [ PrimaryKey ["id"]+          ]+      }+    queryVersion = "SELECT version FROM persistent_migration ORDER BY timestamp DESC LIMIT 1"+    extractVersion = \case+      [] -> Nothing+      [Single v] -> Just v+      _ -> error "Invalid response from the database."++-- | Get the migration plan given the current state of the database.+getMigratePlan :: Migration -> Maybe Version -> Either (Version, Version) Migration+getMigratePlan migration mVersion = case getPath edges start end of+  Just path -> Right path+  Nothing -> Left (start, end)+  where+    edges = map (\op@Operation{opPath} -> (opPath, op)) migration+    start = fromMaybe (getFirstVersion migration) mVersion+    end = getLatestVersion migration++-- | Get the first version in the given migration.+getFirstVersion :: Migration -> Version+getFirstVersion = minimum . map (fst . opPath)++-- | Get the most up-to-date version in the given migration.+getLatestVersion :: Migration -> Version+getLatestVersion = maximum . map (snd . opPath)++{- Migration plan and execution -}++-- | Settings to customize migration steps.+newtype MigrateSettings = MigrateSettings+  { versionToLabel :: Version -> Maybe String+      -- ^ A function to optionally label certain versions+  }++-- | Default migration settings.+defaultSettings :: MigrateSettings+defaultSettings = MigrateSettings+  { versionToLabel = const Nothing+  }++-- | Validate the given migration.+validateMigration :: Migration -> Either String ()+validateMigration migration = do+  unless (allIncreasing opVersions) $+    Left "Operation versions must be monotonically increasing"+  when (hasDuplicates opVersions) $+    Left "There may only be one operation per pair of versions"+  where+    opVersions = map opPath migration+    allIncreasing = all (uncurry (<))+    hasDuplicates l = length (nub l) < length l++-- | Run the given migration. After successful completion, saves the migration to the database.+runMigration :: MonadIO m => MigrateBackend -> MigrateSettings -> Migration -> SqlPersistT m ()+runMigration backend settings@MigrateSettings{..} migration = do+  getMigration backend settings migration >>= rawExecute'+  now <- liftIO getCurrentTime+  let version = getLatestVersion migration+  rawExecute "INSERT INTO persistent_migration(version, label, timestamp) VALUES (?, ?, ?)"+    [ PersistInt64 $ fromIntegral version+    , PersistText $ Text.pack $ fromMaybe (show version) $ versionToLabel version+    , PersistUTCTime now+    ]++-- | Get the SQL queries for the given migration.+getMigration :: MonadIO m => MigrateBackend -> MigrateSettings -> Migration -> SqlPersistT m [Text]+getMigration backend _ migration = do+  either fail return $ validateMigration migration+  either fail return $ mapM_ (\Operation{opOp} -> validateOperation opOp) migration+  currVersion <- getCurrVersion backend+  migratePlan <- either badPath return $ getMigratePlan migration currVersion+  concatMapM getMigrationText' migratePlan+  where+    badPath (start, end) = fail $ "Could not find path: " ++ show start ++ " ~> " ++ show end+    -- Utilities+    concatMapM f = fmap concat . mapM f+    -- Operation helpers+    getMigrationText' Operation{opOp} = mapReaderT liftIO $ getMigrationText backend opOp++-- | Execute the given SQL strings.+rawExecute' :: MonadIO m => [Text] -> SqlPersistT m ()+rawExecute' = mapM_ $ \s -> rawExecute s []++{- Core Operations -}++-- | An operation to create a table according to the specified schema.+data CreateTable = CreateTable+  { ctName        :: Text+  , ctSchema      :: [Column]+  , ctConstraints :: [TableConstraint]+  } deriving (Show)++instance Migrateable CreateTable where+  validateOperation ct@CreateTable{..} = do+    mapM_ validateColumn ctSchema+    when (hasDuplicateConstrs ctConstraints) $+      Left $ "Duplicate table constraints detected: " ++ show ct++    let constraintCols = concatMap getConstraintColumns ctConstraints+        schemaCols = map colName ctSchema+    when (any (`notElem` schemaCols) constraintCols) $+      Left $ "Table constraint references non-existent column: " ++ show ct++  getMigrationText backend = createTable backend False++-- | An operation to drop the given table.+newtype DropTable = DropTable+  { dtName :: Text+  }+  deriving (Show)++instance Migrateable DropTable where+  getMigrationText = dropTable++-- | An operation to add the given column to an existing table.+data AddColumn = AddColumn+  { acTable   :: Text+  , acColumn  :: Column+  , acDefault :: Maybe Text+    -- ^ The default for existing rows; required if the column is non-nullable+  } deriving (Show)++instance Migrateable AddColumn where+  validateOperation ac@AddColumn{..} = do+    validateColumn acColumn+    when (NotNull `elem` colProps acColumn && isNothing acDefault) $+      Left $ "Adding a non-nullable column requires a default: " ++ show ac++  getMigrationText = addColumn++-- | An operation to drop the given column to an existing table.+newtype DropColumn = DropColumn+  { dcColumn :: ColumnIdentifier+  } deriving (Show)++instance Migrateable DropColumn where+  getMigrationText = dropColumn++-- | A custom operation that can be defined manually.+--+-- RawOperations should primarily use 'rawSql' and 'rawExecute' from the persistent library. If the+-- operation depends on the backend being run, query 'connRDBMS' from the 'SqlBackend':+--+-- @+-- asks connRDBMS >>= \case+--   "sqlite" -> ...+--   _ -> return ()+-- @+data RawOperation = RawOperation+  { message :: Text+  , rawOp   :: SqlPersistT IO [Text]+  }++instance Show RawOperation where+  show RawOperation{message} = "RawOperation: " ++ Text.unpack message++instance Migrateable RawOperation where+  getMigrationText _ RawOperation{rawOp} = rawOp++-- | A noop operation.+data NoOp = NoOp+  deriving (Show)++instance Migrateable NoOp where+  getMigrationText _ _ = return []++{- Auxiliary types -}++-- | A column identifier, table.column+type ColumnIdentifier = (Text, Text)++-- | Make a ColumnIdentifier displayable.+dotted :: ColumnIdentifier -> Text+dotted (tab, col) = tab <> "." <> col++-- | The definition for a Column in a SQL database.+data Column = Column+  { colName  :: Text+  , colType  :: SqlType+  , colProps :: [ColumnProp]+  } deriving (Show)++-- | Validate a Column.+validateColumn :: Column -> Either String ()+validateColumn col@Column{..} = when (hasDuplicateConstrs colProps) $+  Left $ "Duplicate column properties detected: " ++ show col++-- | A property for a 'Column'.+data ColumnProp+  = NotNull -- ^ Makes a column non-nullable (defaults to nullable)+  | References ColumnIdentifier -- ^ Mark this column as a foreign key to the given column+  | AutoIncrement -- ^ Makes a column auto-incrementing+  deriving (Show,Eq,Data)++-- | Table constraints in a CREATE query.+data TableConstraint+  = PrimaryKey [Text] -- ^ PRIMARY KEY (col1, col2, ...)+  | Unique Text [Text] -- ^ CONSTRAINT name UNIQUE (col1, col2, ...)+  deriving (Show,Data)++-- | Get the columns defined in the given TableConstraint.+getConstraintColumns :: TableConstraint -> [Text]+getConstraintColumns = \case+  PrimaryKey cols -> cols+  Unique _ cols -> cols

+ src/Database/Persist/Migration/Postgres.hs view

@@ -0,0 +1,132 @@+{-|+Module      :  Database.Persist.Migration.Postgres+Maintainer  :  Brandon Chinn <brandonchinn178@gmail.com>+Stability   :  experimental+Portability :  portable++Defines the migration backend for PostgreSQL.+-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++module Database.Persist.Migration.Postgres+  ( backend+  , getMigration+  , runMigration+  ) where++import Data.Maybe (maybeToList)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as Text+import Database.Persist.Migration+    ( AddColumn(..)+    , Column(..)+    , ColumnProp(..)+    , CreateTable(..)+    , DropColumn(..)+    , DropTable(..)+    , MigrateBackend(..)+    , MigrateSettings+    , Migration+    , TableConstraint(..)+    )+import qualified Database.Persist.Migration.Internal as Migration+import Database.Persist.Migration.Utils.Sql (quote, uncommas)+import Database.Persist.Sql (SqlPersistT, SqlType(..))++-- | Run a migration with the Postgres backend.+runMigration :: MigrateSettings -> Migration -> SqlPersistT IO ()+runMigration = Migration.runMigration backend++-- | Get a migration with the Postgres backend.+getMigration :: MigrateSettings -> Migration -> SqlPersistT IO [Text]+getMigration = Migration.getMigration backend++-- | The migration backend for Postgres.+backend :: MigrateBackend+backend = MigrateBackend+  { createTable = createTable'+  , dropTable = dropTable'+  , addColumn = addColumn'+  , dropColumn = dropColumn'+  }++createTable' :: Bool -> CreateTable -> SqlPersistT IO [Text]+createTable' ifNotExists CreateTable{..} = return+  ["CREATE TABLE " <> ifNotExists' <> quote ctName <> "(" <> uncommas tableDefs <> ")"]+  where+    ifNotExists' = if ifNotExists then "IF NOT EXISTS " else ""+    tableDefs = map showColumn ctSchema ++ map showTableConstraint ctConstraints++dropTable' :: DropTable -> SqlPersistT IO [Text]+dropTable' DropTable{..} = return ["DROP TABLE " <> quote dtName]++addColumn' :: AddColumn -> SqlPersistT IO [Text]+addColumn' AddColumn{..} = return $ createQuery : maybeToList alterQuery+  where+    Column{..} = acColumn+    alterTable = "ALTER TABLE " <> quote acTable <> " "+    -- The CREATE query with the default specified by AddColumn{acDefault}+    createQuery = alterTable <> "ADD COLUMN " <> showColumn acColumn <> createDefault+    createDefault = case acDefault of+      Nothing -> ""+      Just def -> " DEFAULT " <> def+    -- The ALTER query to drop the default (if acDefault was set)+    setJust v = fmap $ const v+    alterQuery =+      setJust (alterTable <> "ALTER COLUMN " <> quote colName <> " DROP DEFAULT") acDefault++dropColumn' :: DropColumn -> SqlPersistT IO [Text]+dropColumn' DropColumn{..} = return ["ALTER TABLE " <> quote tab <> " DROP COLUMN " <> quote col]+  where+    (tab, col) = dcColumn++{- Helpers -}++-- | Show a 'Column'.+showColumn :: Column -> Text+showColumn Column{..} =+  Text.unwords+    $ quote colName+    : sqlType+    : map showColumnProp colProps+  where+    sqlType = if AutoIncrement `elem` colProps+      then "SERIAL"+      else showSqlType colType++-- | Show a 'SqlType'. See `showSqlType` from `Database.Persist.Postgresql`.+showSqlType :: SqlType -> Text+showSqlType = \case+  SqlString -> "VARCHAR"+  SqlInt32 -> "INT4"+  SqlInt64 -> "INT8"+  SqlReal -> "DOUBLE PRECISION"+  SqlNumeric s prec -> "NUMERIC(" <> showT s <> "," <> showT prec <> ")"+  SqlDay -> "DATE"+  SqlTime -> "TIME"+  SqlDayTime -> "TIMESTAMP WITH TIME ZONE"+  SqlBlob -> "BYTEA"+  SqlBool -> "BOOLEAN"+  SqlOther (Text.toLower -> "integer") -> "INT4"+  SqlOther t -> t+  where+    showT = Text.pack . show++-- | Show a 'ColumnProp'.+showColumnProp :: ColumnProp -> Text+showColumnProp = \case+  NotNull -> "NOT NULL"+  References (tab, col) -> "REFERENCES " <> quote tab <> "(" <> quote col <> ")"+  AutoIncrement -> ""++-- | Show a `TableConstraint`.+showTableConstraint :: TableConstraint -> Text+showTableConstraint = \case+  PrimaryKey cols -> "PRIMARY KEY (" <> showCols cols <> ")"+  Unique name cols -> "CONSTRAINT " <> quote name <> " UNIQUE (" <> showCols cols <> ")"+  where+    showCols = uncommas . map quote

+ src/Database/Persist/Migration/Utils/Data.hs view

@@ -0,0 +1,24 @@+{-|+Module      :  Database.Persist.Migration.Utils.Data+Maintainer  :  Brandon Chinn <brandonchinn178@gmail.com>+Stability   :  experimental+Portability :  portable++Define functions useful for data constructors.+-}++module Database.Persist.Migration.Utils.Data+  ( hasDuplicateConstrs+  ) where++import Data.Data (Data, showConstr, toConstr)+import Data.Function (on)+import Data.List (nubBy)++-- | Show the name of the constructor.+showData :: Data a => a -> String+showData = showConstr . toConstr++-- | Return True if the given list has duplicate constructors.+hasDuplicateConstrs :: Data a => [a] -> Bool+hasDuplicateConstrs l = length l /= length (nubBy ((==) `on` showData) l)

+ src/Database/Persist/Migration/Utils/Plan.hs view

@@ -0,0 +1,38 @@+{-|+Module      :  Database.Persist.Migration.Utils.Plan+Maintainer  :  Brandon Chinn <brandonchinn178@gmail.com>+Stability   :  experimental+Portability :  portable++Define functions useful for compiling a plan of migration.+-}+{-# LANGUAGE TupleSections #-}++module Database.Persist.Migration.Utils.Plan+  ( getPath+  ) where++import Data.Graph.Inductive (Gr, mkGraph, sp)+import Data.HashMap.Lazy ((!))+import qualified Data.HashMap.Lazy as HashMap+import qualified Data.IntSet as IntSet++type Node = Int+type Edge = (Int, Int)++-- | Given a list of edges and their data and a start/end node, return the shortest path.+--+-- Errors if no path is found.+getPath :: [(Edge, a)] -> Node -> Node -> Maybe [a]+getPath edgeData start end = map (edgeMap !) . nodesToEdges <$> sp start end graph+  where+    graph = mkGraph' $ map fst edgeData+    nodesToEdges nodes = zip nodes $ tail nodes+    edgeMap = HashMap.fromList edgeData++mkGraph' :: [Edge] -> Gr () Int+mkGraph' edgeData = mkGraph nodes edges+  where+    detuple (a, b) = [a, b]+    nodes = map (, ()) . IntSet.toList . IntSet.fromList . concatMap detuple $ edgeData+    edges = map (uncurry (,,1)) edgeData

+ src/Database/Persist/Migration/Utils/Sql.hs view

@@ -0,0 +1,68 @@+{-|+Module      :  Database.Persist.Migration.Utils.Sql+Maintainer  :  Brandon Chinn <brandonchinn178@gmail.com>+Stability   :  experimental+Portability :  portable++Defines helper functions for writing SQL queries.+-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Database.Persist.Migration.Utils.Sql+  ( commas+  , uncommas+  , quote+  , interpolate+  ) where++import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Database.Persist (PersistValue(..))++-- | Split the given line by commas, ignoring commas within parentheses.+--+-- > commas "a,b,c" == ["a", "b", "c"]+-- > commas "a,b,c (d,e),z" == ["a", "b", "c (d,e)", "z"]+-- > commas "a,b,c (d,e,(f,g)),z" == ["a", "b", "c (d,e,(f,g))", "z"]+commas :: Text -> [Text]+commas t = go (Text.unpack t) "" [] (0 :: Int)+  where+    go src buffer result level =+      let result' = result ++ [Text.pack buffer]+      in case src of+        "" -> result'+        ',':xs | level == 0 -> go xs "" result' level+        '(':xs -> go xs (buffer ++ "(") result (level + 1)+        ')':xs -> go xs (buffer ++ ")") result (max 0 $ level - 1)+        x:xs -> go xs (buffer ++ [x]) result level++-- | Join the given Text with commas separating each item.+uncommas :: [Text] -> Text+uncommas = Text.intercalate ","++-- | Quote the given Text.+quote :: Text -> Text+quote t = "\"" <> t <> "\""++-- | Interpolate the given values into the SQL string.+interpolate :: Text -> [PersistValue] -> Text+interpolate t values = if length splitted == length values + 1+  then Text.concat . interleave splitted . map showValue $ values+  else error $ "Number of ?'s does not match number of values: " ++ show t+  where+    splitted = Text.splitOn "?" t+    interleave (x:xs) (y:ys) = x : y : interleave xs ys+    interleave xs [] = xs+    interleave [] ys = ys+    showValue = \case+      PersistText v -> "'" <> v <> "'"+      PersistByteString v -> "'" <> Text.decodeUtf8 v <> "'"+      PersistInt64 v -> Text.pack . show $ v+      PersistDouble v -> Text.pack . show $ v+      PersistRational v -> Text.pack . show $ v+      PersistBool v -> Text.pack . show $ v+      PersistNull -> "NULL"+      v -> error $ "Could not interpolate value: " ++ show v

+ test/Integration.hs view

@@ -0,0 +1,26 @@+import Data.Pool (Pool)+import Database.Persist.Migration (MigrateBackend)+import qualified Database.Persist.Migration.Postgres as Postgres+import Database.Persist.Sql (SqlBackend)+import System.IO.Temp (withTempDirectory)+import Test.Integration.Migration (testMigrations)+import Test.Integration.Property (testProperties)+import Test.Integration.Utils.Backends (withPostgres)+import Test.Tasty+import Test.Utils.Goldens (goldenDir)++integrationDir :: String -> FilePath+integrationDir = goldenDir "integration"++main :: IO ()+main = withTempDirectory "/tmp" "persistent-migration-integration" $ \dir ->+  defaultMain $ testGroup "persistent-migration-integration"+    [ withPostgres dir $ testBackend "postgresql" Postgres.backend+    ]++-- | Build a test suite running integration tests for the given MigrateBackend.+testBackend :: String -> MigrateBackend -> IO (Pool SqlBackend) -> TestTree+testBackend label backend getPool = testGroup label+  [ testMigrations (integrationDir label) backend getPool+  , testProperties backend getPool+  ]

+ test/Test/Integration/Migration.hs view

@@ -0,0 +1,218 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}++module Test.Integration.Migration (testMigrations) where++import Control.Exception (finally)+import Control.Monad (unless, when)+import Data.ByteString.Lazy (ByteString, fromStrict)+import Data.Maybe (mapMaybe)+import Data.Monoid ((<>))+import Data.Pool (Pool)+import Data.Text (Text)+import Data.Yaml (array, encode, object, (.=))+import Database.Persist (Entity(..), get, insertKey, insertMany_, selectList)+import Database.Persist.Migration+    ( AddColumn(..)+    , Column(..)+    , ColumnProp(..)+    , CreateTable(..)+    , DropColumn(..)+    , MigrateBackend+    , Migration+    , Operation(..)+    , RawOperation(..)+    , TableConstraint(..)+    , checkMigration+    , hasMigration+    , (~>)+    )+import Database.Persist.Migration.Utils.Sql (interpolate, uncommas)+import Database.Persist.Sql+    ( PersistValue(..)+    , Single(..)+    , SqlBackend+    , SqlPersistT+    , SqlType(..)+    , rawExecute+    , rawSql+    )+import Database.Persist.TH+    (mkMigrate, mkPersist, persistLowerCase, share, sqlSettings)+import Test.Integration.Utils.RunSql (runMigration, runSql)+import Test.Tasty (TestTree, testGroup)+import Test.Utils.Goldens (goldenVsString)++{- Schema and migration -}++share [mkPersist sqlSettings, mkMigrate "autoMigration"] [persistLowerCase|+Person+  name String+  hometown CityId+  gender String Maybe+  colorblind Bool+  deriving Show+City+  name String+  state String+  UniqueCity name state+  deriving Show+|]++manualMigration :: Migration+manualMigration =+  -- create tables+  [ Operation (0 ~> 1) $+      CreateTable+        { ctName = "city"+        , ctSchema =+            [ Column "id" SqlInt64 [NotNull, AutoIncrement]+            , Column "name" SqlString [NotNull]+            , Column "state" SqlString [NotNull]+            ]+        , ctConstraints =+            [ PrimaryKey ["id"]+            , Unique "unique_city" ["state", "name"]+            ]+        }+  , Operation (1 ~> 2) $+      CreateTable+        { ctName = "person"+        , ctSchema =+            [ Column "id" SqlInt64 [NotNull, AutoIncrement]+            , Column "name" SqlString [NotNull]+            , Column "hometown" SqlInt64 [NotNull, References ("city", "id")]+            ]+        , ctConstraints =+            [ PrimaryKey ["id"]+            ]+        }++  -- add binary sex column+  , Operation (2 ~> 3) $ AddColumn "person" (Column "sex" SqlInt32 []) Nothing++  -- change binary sex to stringly gender+  , Operation (3 ~> 4) $ AddColumn "person" (Column "gender" SqlString []) Nothing+  , Operation (4 ~> 5) migrateGender+  , Operation (5 ~> 6) $ DropColumn ("person", "sex")+  -- shortcut for databases that hadn't already added the sex column+  , Operation (2 ~> 6) $ AddColumn "person" (Column "gender" SqlString []) Nothing++  -- add colorblind column, with everyone currently in the database being not colorblind+  , Operation (6 ~> 7) $+      AddColumn "person" (Column "colorblind" SqlBool [NotNull]) (Just "FALSE")+  ]+  where+    migrateGender = RawOperation "Convert binary sex column into stringly gender column" $+      mapMaybe migrateGender' <$> rawSql "SELECT id, sex FROM person" []+    migrateGender' = \case+      (_, Single Nothing) -> Nothing+      (Single id', Single (Just sex)) ->+        Just $ interpolate "UPDATE person SET gender = ? WHERE id = ?"+          [ PersistText $ sexToGender sex+          , PersistInt64 id'+          ]+    sexToGender :: Int -> Text+    sexToGender sex = if sex == 0 then "Male" else "Female"++{- Test suite -}++-- | A test suite for running migrations.+testMigrations :: FilePath -> MigrateBackend -> IO (Pool SqlBackend) -> TestTree+testMigrations dir backend getPool = testGroup "migrations"+  [ testMigration' "Migrate from empty" 0 []+  , testMigration' "Migrate after CREATE city" 1 []+  , testMigration' "Migrate with v1 person" 2 [insertPerson "David" []]+  , testMigration' "Migrate from sex to gender" 3+      [ insertPerson "David" [("sex", "0")]+      , insertPerson "Elizabeth" [("sex", "1")]+      , insertPerson "Foster" [("sex", "NULL")]+      ]+  , testMigration' "Migrate with default colorblind" 7 [insertPerson "David" []]+  , testMigration' "Migrations are idempotent" 8 [insertPerson "David" [("colorblind", "TRUE")]]+  ]+  where+    testMigration' = testMigration dir backend getPool+    insertPerson name extra =+      let cols = ["name", "hometown"] ++ map fst extra+          vals = ["'" <> name <> "'", "1"] ++ map snd extra+      in rawExecute+          ("INSERT INTO person(" <> uncommas cols <> ") VALUES (" <> uncommas vals <> ")")+          []++-- | Run a test where:+--    * the first N operations have been migrated+--    * the given query is run to populate the database+--    * the remaining operations are migrated+--    * insert some data into the database+--    * output "SELECT * FROM person" to goldens file+--    * clean up database+testMigration+  :: FilePath+  -> MigrateBackend+  -> IO (Pool SqlBackend)+  -> String+  -> Int+  -> [SqlPersistT IO ()]+  -> TestTree+testMigration dir backend getPool name n populateDb = goldenVsString dir name $ do+  pool <- getPool+  let runMigration' = runMigration backend pool+      city = CityKey 1+      insertCity = insertKey city $ City "Berkeley" "CA"++  res <- (`finally` cleanup pool) $ do+    -- test setup+    unless (null setupMigration) $ do+      runMigration' setupMigration+      -- populateDb scripts can use hometown=1+      runSql pool insertCity+    needsMore <- runSql pool $ hasMigration autoMigration+    if n >= length manualMigration+      then when needsMore $ fail "More migrations are detected"+      else unless needsMore $ fail "No more migrations detected"+    mapM_ (runSql pool) populateDb++    -- run migrations and check inserting current models works+    runMigration' manualMigration+    runSql pool $ do+      checkMigration autoMigration+      get city >>= \case+        Just _ -> return ()+        Nothing -> insertCity+      insertMany_+        [ Person "Alice" city (Just "Female") False+        , Person "Bob" city (Just "Male") True+        , Person "Courtney" city Nothing False+        ]+      map entityVal <$> selectList [] []++  return $ showPersons res+  where+    setupMigration = take n manualMigration+    cleanup pool = runSql pool $ do+      rawExecute "DROP TABLE persistent_migration" []+      rawExecute "DROP TABLE person" []+      rawExecute "DROP TABLE city" []++-- | Display a Person as a YAML object.+showPersons :: [Person] -> ByteString+showPersons = fromStrict . encode . array . map showPerson+  where+    showPerson Person{..} = object+      [ "name" .= personName+      , "hometown" .= personHometown+      , "gender" .= personGender+      , "colorblind" .= personColorblind+      ]

+ test/Test/Integration/Property.hs view

@@ -0,0 +1,65 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Integration.Property (testProperties) where++import Control.Monad ((>=>))+import Control.Monad.Catch (SomeException(..), try)+import Control.Monad.IO.Class (liftIO)+import Data.List (nub)+import Data.Maybe (mapMaybe)+import Data.Monoid ((<>))+import Data.Pool (Pool)+import Database.Persist.Migration.Internal+import Database.Persist.Migration.Utils.Sql (quote)+import Database.Persist.Sql (SqlBackend, rawExecute)+import Test.Integration.Utils.RunSql (runSql)+import Test.QuickCheck+import Test.QuickCheck.Monadic (monadicIO, pick, run)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Test.Utils.QuickCheck ()++-- | A test suite for testing migration properties.+testProperties :: MigrateBackend -> IO (Pool SqlBackend) -> TestTree+testProperties backend getPool = testGroup "properties"+  [ testProperty "Create arbitrary tables" $ monadicIO $ do+      table <- pick arbitrary+      fkTables <- pick $ getForeignKeyTables table+      let createTable = getMigrationText backend >=> mapM_ rawExecutePrint+          dropTable = rawExecutePrint . ("DROP TABLE " <>) . quote . ctName+      runSql' $ do+        mapM_ createTable fkTables+        createTable table+        dropTable table+        mapM_ dropTable fkTables+  ]+  where+    runSql' f = run $ getPool >>= \pool -> runSql pool f+    -- if rawExecute fails, show the sql query run+    rawExecutePrint sql = try (rawExecute sql []) >>= \case+      Right () -> return ()+      Left (SomeException e) -> do+        liftIO $ print sql+        fail $ show e++-- | Get the CreateTable operations that are necessary for the foreign keys in the+-- given CreateTable operation.+getForeignKeyTables :: CreateTable -> Gen [CreateTable]+getForeignKeyTables ct =+  zipWith modifyTable neededTables <$> vectorOf (length neededTables) arbitrary+  where+    neededTables = nub $ concatMap (mapMaybe getReferenceTable . colProps) $ ctSchema ct+    getReferenceTable = \case+      References (table, _) -> Just table+      _ -> Nothing+    isReference = \case+      References _ -> True+      _ -> False+    noFKs = filter (not . isReference) . colProps+    modifyTable name ct' = ct'+      { ctName = name+      , ctSchema = map (\col -> col{colProps = noFKs col}) $ ctSchema ct'+      }

+ test/Test/Integration/Utils/Backends.hs view

@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Integration.Utils.Backends+  ( withPostgres+  ) where++import Control.Concurrent (threadDelay)+import Control.Monad.Logger (runNoLoggingT)+import qualified Data.ByteString.Char8 as ByteString+import Data.Pool (Pool, destroyAllResources)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Database.Persist.Postgresql (createPostgresqlPool)+import Database.Persist.Sql (SqlBackend)+import System.Exit (ExitCode(..), exitWith)+import System.IO (hPutStrLn, stderr)+import System.Process (readProcessWithExitCode)+import Test.Tasty (TestTree, withResource)++-- | Run a function with the PostgreSQL backend.+withPostgres :: FilePath -> (IO (Pool SqlBackend) -> TestTree) -> TestTree+withPostgres dir = withResource startPostgres stopPostgres+  where+    dir' = dir ++ "/postgresql/"+    -- running postgres+    startPostgres = do+      -- initialize local postgres server+      callProcess' "pg_ctl" ["-D", dir', "init"]+      -- modify configuration+      let confFile = dir' ++ "postgresql.conf"+      conf <- Text.readFile confFile+      Text.writeFile confFile . Text.unlines . map modifyConf . Text.lines $ conf+      -- start postgres server+      callProcess' "pg_ctl"+        [ "-D", dir'+        , "-l", dir' ++ "postgres.log"+        , "-o", "-h '' -k '" ++ dir' ++ "'"+        , "start"+        ]+      threadDelay 1000000+      callProcess' "createdb" ["-h", dir', "test_db"]+      -- create a connection Pool+      let connString = ByteString.pack $ "postgresql:///test_db?host=" ++ dir'+      runNoLoggingT $ createPostgresqlPool connString 4+    stopPostgres pool = do+      callProcess' "pg_ctl" ["-D", dir', "stop"]+      destroyAllResources pool+    -- utilities+    callProcess' cmd args = do+      (code, out, err) <- readProcessWithExitCode cmd args ""+      case code of+        ExitSuccess -> return ()+        ExitFailure _ -> do+          hPutStrLn stderr out+          hPutStrLn stderr err+          exitWith code+    modifyConf line+      | "#client_min_messages" `Text.isPrefixOf` line = "client_min_messages = warning"+      | otherwise = line

+ test/Test/Integration/Utils/RunSql.hs view

@@ -0,0 +1,18 @@+module Test.Integration.Utils.RunSql+  ( runSql+  , runMigration+  ) where++import Control.Monad.Reader (runReaderT)+import Data.Pool (Pool, withResource)+import Database.Persist.Migration (MigrateBackend, Migration, defaultSettings)+import qualified Database.Persist.Migration.Internal as Migration+import Database.Persist.Sql (SqlBackend, SqlPersistT)++-- | Run the given persistent query.+runSql :: Pool SqlBackend -> SqlPersistT IO a -> IO a+runSql pool = withResource pool . runReaderT++-- | Run the given migration.+runMigration :: MigrateBackend -> Pool SqlBackend -> Migration -> IO ()+runMigration backend pool = runSql pool . Migration.runMigration backend defaultSettings

+ test/Test/Unit/Migration.hs view

@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Unit.Migration (testMigrations) where++import Control.Monad.Reader (runReaderT)+import qualified Data.Text as Text+import Database.Persist.Migration.Internal+import Database.Persist.Sql (SqlType(..))+import Test.Tasty (TestName, TestTree, testGroup)+import Test.Unit.Utils.Backends+    (MockDatabase(..), defaultDatabase, setDatabase, withTestBackend)+import Test.Utils.Goldens (goldenVsText)++-- | Build a test suite for the given MigrateBackend.+testMigrations :: FilePath -> MigrateBackend -> TestTree+testMigrations dir backend = testGroup "migrations"+  [ goldenMigration' "Basic migration" defaultDatabase+      [ Operation (0 ~> 1) $+          CreateTable+            { ctName = "person"+            , ctSchema =+                [ Column "id" SqlInt32 []+                , Column "name" SqlString [NotNull]+                , Column "age" SqlInt32 [NotNull]+                , Column "alive" SqlBool [NotNull]+                , Column "hometown" SqlInt64 [References ("cities", "id")]+                ]+            , ctConstraints =+                [ PrimaryKey ["id"]+                , Unique "unique_name" ["name"]+                ]+            }+      , Operation (1 ~> 2) $ AddColumn "person" (Column "gender" SqlString []) Nothing+      , Operation (2 ~> 3) $ DropColumn ("person", "alive")+      , Operation (3 ~> 4) $ DropTable "person"+      ]+  , goldenMigration' "Partial migration" (withVersion 1)+      [ Operation (0 ~> 1) $ CreateTable "person" [] []+      , Operation (1 ~> 2) $ DropTable "person"+      ]+  , goldenMigration' "Complete migration" (withVersion 2)+      [ Operation (0 ~> 1) $ CreateTable "person" [] []+      , Operation (1 ~> 2) $ DropTable "person"+      ]+  , goldenMigration' "Migration with shorter path" defaultDatabase+      [ Operation (0 ~> 1) $ CreateTable "person" [] []+      , Operation (1 ~> 2) $ AddColumn "person" (Column "gender" SqlString []) Nothing+      , Operation (0 ~> 2) $ CreateTable "person" [Column "gender" SqlString []] []+      ]+  , goldenMigration' "Partial migration avoids shorter path" (withVersion 1)+      [ Operation (0 ~> 1) $ CreateTable "person" [] []+      , Operation (1 ~> 2) $ AddColumn "person" (Column "gender" SqlString []) Nothing+      , Operation (0 ~> 2) $ CreateTable "person" [Column "gender" SqlString []] []+      ]+  ]+  where+    goldenMigration' = goldenMigration dir backend++{- Helpers -}++-- | Run a goldens test for a migration.+goldenMigration+  :: FilePath -> MigrateBackend -> TestName -> MockDatabase -> Migration -> TestTree+goldenMigration dir backend name testBackend migration = goldenVsText dir name $ do+  setDatabase testBackend+  Text.unlines <$> getMigration' migration+  where+    getMigration' = withTestBackend . runReaderT . getMigration backend defaultSettings++-- | Set the version in the MockDatabase.+withVersion :: Version -> MockDatabase+withVersion v = defaultDatabase{version = Just v}

+ test/Test/Unit/Property.hs view

@@ -0,0 +1,91 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Test.Unit.Property (testProperties) where++import Control.Applicative (liftA2)+import Data.Either (isRight)+import Database.Persist.Migration.Internal+import Test.QuickCheck+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Test.Utils.QuickCheck (Identifier(..), mapSome)++-- | Run tests related to migration validaton.+testProperties :: TestTree+testProperties = testGroup "properties"+  [ testProperty "Valid migration" $ forAll arbitrary isValidMigrationPath+  , testProperty "Invalid decreasing migration" $+      forAll arbitrary $ \(MigrationPath opPaths) -> do+        opPaths' <- mapSome (\(a, b) -> (b, a)) opPaths+        return . not . isValidMigrationPath $ MigrationPath opPaths'+  , testProperty "Invalid duplicate operation path" $+      forAll arbitrary $ \(MigrationPath opPaths) -> do+        opPaths' <- mapSomeDupl opPaths+        return . not . isValidMigrationPath $ MigrationPath opPaths'+  , testProperty "Duplicate ColumnProps in CreateTable" $ do+      colsMaybeProps <- listOf arbitrary+      colsWithProps <- listOf1 (arbitrary `suchThat` (not . null . colProps))+      let duplProps = mapM $ \col@Column{colProps} -> do+            colProps' <- mapSomeDupl colProps+            return col{colProps = colProps'}+      cols <- liftA2 (++) (duplProps colsMaybeProps) (duplProps colsWithProps)+      let ct = CreateTable "foo" cols []+      return . not . isValidOperation $ ct+  , testProperty "Duplicate Constraints in CreateTable" $+      forAll arbitrary $ \ct@CreateTable{ctConstraints} -> do+        ctConstraints' <- mapSomeDupl ctConstraints+        return . not . isValidOperation $ ct{ctConstraints = ctConstraints'}+  , testProperty "Constraint references non-existent column" $+      forAll arbitrary $ \ct@CreateTable{..} -> do+        let existing = map (Identifier . colName) ctSchema+            genConstraint = do+              Identifier name <- arbitrary+              cols <- map unIdent <$> listOf1 (arbitrary `suchThat` (`notElem` existing))+              elements [PrimaryKey cols, Unique name cols]+        newConstraints <- listOf1 genConstraint+        return . not . isValidOperation $ ct{ctConstraints = ctConstraints ++ newConstraints}+  , testProperty "Duplicate ColumnProps in AddColumn" $+      forAll arbitrary $ \col@Column{colProps} -> do+        Identifier acTable <- arbitrary+        acDefault <- arbitrary+        colProps' <- mapSomeDupl colProps+        let acColumn = col{colProps = colProps'}+        return $ not (null colProps) ==> not (isValidOperation AddColumn{..})+  , testProperty "Non-null AddColumn without default" $+      forAll arbitrary $ \col@Column{colProps} -> do+        Identifier acTable <- arbitrary+        let colProps' = if NotNull `elem` colProps then colProps else NotNull : colProps+            acColumn = col{colProps = colProps'}+            acDefault = Nothing+        return . not . isValidOperation $ AddColumn{..}+  ]++newtype MigrationPath = MigrationPath { getOpPaths :: [OperationPath] }+  deriving (Show)++instance Arbitrary MigrationPath where+  arbitrary = do+    Positive maxVersion <- arbitrary+    let versions = [0..maxVersion]+        opPaths = zip versions $ tail versions+    -- order should not matter+    MigrationPath <$> shuffle opPaths++-- | Validate an Operation.+isValidOperation :: Migrateable op => op -> Bool+isValidOperation = isRight . validateOperation++-- | Validate OperationPaths in a Migration.+isValidMigrationPath :: MigrationPath -> Bool+isValidMigrationPath = isRight . validateMigration . map mkOperation . getOpPaths+  where+    mkOperation path = Operation path NoOp++-- | Duplicate some elements in the given list.+mapSomeDupl :: [a] -> Gen [a]+mapSomeDupl = fmap concat . mapSome dupl . map pure+  where+    dupl [x] = [x, x]+    dupl _ = error "unreachable"

+ test/Test/Unit/Utils/Backends.hs view

@@ -0,0 +1,80 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Unit.Utils.Backends+  ( MockDatabase(..)+  , defaultDatabase+  , setDatabase+  , withTestBackend+  ) where++import Control.Monad.IO.Class (liftIO)+import Data.Conduit.List (sourceList)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import qualified Data.Map as Map+import Data.Maybe (maybeToList)+import Database.Persist.Migration (Version)+import Database.Persist.Sql (PersistValue(..), SqlBackend(..), Statement(..))+import System.IO.Unsafe (unsafePerformIO)++{- Mock test database -}++-- | The mock database backend for testing.+newtype MockDatabase = MockDatabase+  { version :: Maybe Version+  }++-- | The default test database.+defaultDatabase :: MockDatabase+defaultDatabase = MockDatabase Nothing++-- | The global test database.+mockDatabase :: IORef MockDatabase+mockDatabase = unsafePerformIO $ newIORef defaultDatabase+{-# NOINLINE mockDatabase #-}++-- | Set the test database.+setDatabase :: MockDatabase -> IO ()+setDatabase = writeIORef mockDatabase++{- Mock SqlBackend -}++-- | Initialize a mock SqlBackend for testing.+withTestBackend :: (SqlBackend -> IO a) -> IO a+withTestBackend action = do+  smap <- newIORef Map.empty+  action SqlBackend+    { connPrepare = \case+        "SELECT version FROM persistent_migration ORDER BY timestamp DESC LIMIT 1" ->+          return stmt+            { stmtQuery = \_ -> do+                MockDatabase{version} <- liftIO $ readIORef mockDatabase+                let result = pure . PersistInt64 . fromIntegral <$> maybeToList version+                return $ sourceList result+            }+        _ -> return stmt+    , connStmtMap = smap+    , connInsertSql = error "connInsertSql"+    , connUpsertSql = error "connUpsertSql"+    , connPutManySql = error "connPutManySql"+    , connInsertManySql = error "connInsertManySql"+    , connClose = error "connClose"+    , connMigrateSql = error "connMigrateSql"+    , connBegin = error "connBegin"+    , connCommit = error "connCommit"+    , connRollback = error "connRollback"+    , connEscapeName = error "connEscapeName"+    , connNoLimit = error "connNoLimit"+    , connRDBMS = error "connRDBMS"+    , connLimitOffset = error "connLimitOffset"+    , connLogFunc = \_ _ _ _ -> return ()+    , connMaxParams = error "connMaxParams"+    }+  where+    stmt = Statement+      { stmtFinalize = return ()+      , stmtReset = return ()+      , stmtExecute = \_ -> return 0+      , stmtQuery = error "stmtQuery"+      }

+ test/Test/Utils/Goldens.hs view

@@ -0,0 +1,44 @@+{-# LANGUAGE LambdaCase #-}++module Test.Utils.Goldens+  ( goldenDir+  , goldenVsString+  , goldenVsText+  , goldenVsShow+  ) where++import Data.ByteString.Lazy (ByteString)+import Data.Char (toLower)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Text.Lazy (fromStrict)+import qualified Data.Text.Lazy.Encoding as Text+import Test.Tasty (TestTree)+import qualified Test.Tasty.Golden as Golden++{- Golden files -}++-- | Get the directory of the golden files for the given test type and label.+goldenDir :: String -> String -> FilePath+goldenDir testType label = "test/goldens-" ++ testType ++ "/" ++ label ++ "/"++{- Golden test -}++-- | Run a goldens test where the goldens file is generated from the name.+goldenVsString :: FilePath -> String -> IO ByteString -> TestTree+goldenVsString dir name = Golden.goldenVsString name goldenFile+  where+    goldenFile = dir ++ map slugify name ++ ".txt"+    slugify = \case+      ' ' -> '-'+      x -> toLower x++-- | Run a goldens test against a Text.+goldenVsText :: FilePath -> String -> IO Text -> TestTree+goldenVsText dir name = goldenVsString dir name . fmap toByteString+  where+    toByteString = Text.encodeUtf8 . fromStrict++-- | Run a goldens test against a Showable value.+goldenVsShow :: Show a => FilePath -> String -> IO a -> TestTree+goldenVsShow dir name = goldenVsText dir name . fmap (Text.pack . show)

+ test/Test/Utils/QuickCheck.hs view

@@ -0,0 +1,148 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Test.Utils.QuickCheck+  ( Identifier(..)+  -- * Utilities+  , DistinctList(..)+  , mapSome+  , group+  ) where++import Control.Monad ((>=>))+import Data.List (nub)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as Text+import Database.Persist.Migration+    (Column(..), ColumnProp(..), CreateTable(..), TableConstraint(..))+import Database.Persist.Sql (SqlType(..))+import Test.QuickCheck++instance Arbitrary CreateTable where+  arbitrary = do+    Identifier ctName <- arbitrary++    -- get names of tables this table can have foreign keys towards+    DistinctList colNames <- arbitrary+    -- max out at 100 names+    let colNames' = take 100 $ map unIdent colNames++    -- generate schema+    DistinctList tableNames <- arbitrary+    let tableNames' = filter (/= Identifier ctName) tableNames+    cols <- vectorOf (length colNames') $ genColumn tableNames'+    let idCol = Column "id" SqlInt32 [NotNull, AutoIncrement]+        cols' = map (\(name, col) -> col{colName = name}) $ zip colNames' cols+        ctSchema = idCol : cols'++    -- all of the columns that will be unique+    uniqueCols <- sublistOf $ map colName cols'+    let mkUnique names =+          -- constraint name can be max 63 characters+          let constraintName = Text.take 63 $ "unique_" <> Text.intercalate "_" names+          in Unique constraintName names+        -- unique constraints should not have more than 32 columns+        max32 l = if length l > 32+          then take 32 l : max32 (drop 32 l)+          else [l]+    uniqueConstraints <- map mkUnique . concatMap max32 <$> group uniqueCols++    let ctConstraints = PrimaryKey ["id"] : uniqueConstraints++    return CreateTable{..}++-- | Generate an arbitrary Column with a possibly pre-determined name.+--+-- Also given the set of table names that can be referenced by foreign keys.+genColumn :: [Identifier] -> Gen Column+genColumn tableNames = do+  colName <- fmap unIdent arbitrary `suchThat` (/= "id")++  references <- if null tableNames+    then return []+    else do+      Identifier table <- elements tableNames+      arbitrarySingleton 10 $ References (table, "id")++  colType <- if null references+    then arbitrary+    else return SqlInt32++  autoIncrement <- arbitrarySingleton 1 AutoIncrement+  notNull <- arbitrarySingleton 50 NotNull++  let colProps = notNull ++ autoIncrement ++ references++  return Column{..}+  where+    -- get list with x% chance of having the given element and (100 - x)% chance of+    -- being an empty list+    arbitrarySingleton x v = frequency [(x, pure [v]), (100 - x, pure [])]++instance Arbitrary Column where+  arbitrary = listOf arbitrary >>= genColumn++newtype Identifier = Identifier { unIdent :: Text }+  deriving (Show,Eq)++instance Arbitrary Identifier where+  arbitrary = do+    first <- elements underletter+    rest <- listOf $ elements $ underletter ++ ['0'..'9']+    -- identifiers max 63 characters long+    return . Identifier . Text.pack . take 63 $ first : rest+    where+      underletter = '_':['a'..'z']++instance Arbitrary SqlType where+  arbitrary = do+    numPrecision <- choose (1, 1000)+    numScale <- choose (0, numPrecision)+    elements+      [ SqlString+      , SqlInt32+      , SqlInt64+      , SqlReal+      , SqlNumeric numPrecision numScale+      , SqlBool+      , SqlDay+      , SqlTime+      , SqlDayTime+      , SqlBlob+      ]++{- Utilities -}++newtype DistinctList a = DistinctList { unDistinctList :: [a] }+  deriving (Show)++instance (Arbitrary a, Eq a) => Arbitrary (DistinctList a) where+  arbitrary = DistinctList . nub <$> listOf arbitrary++instance Arbitrary Text where+  arbitrary = Text.pack . getUnicodeString <$> arbitrary++-- | Randomly modify at least one element in the list with the given function.+mapSome :: (a -> a) -> [a] -> Gen [a]+mapSome _ [] = return []+mapSome f l = do+  i <- choose (0, length l - 1)+  let (half1, half2) = splitAt i l+      modify = mapM $ \x -> do+        shouldModify <- arbitrary+        return $ if shouldModify then f x else x+  half1' <- modify half1+  half2' <- modify $ tail half2+  return $ half1' ++ [f $ head half2] ++ half2'++-- | Randomly group the given list.+group :: [a] -> Gen [[a]]+group = shuffle >=> partition []+  where+    partition res [] = return res+    partition res l = do+      i <- choose (1, length l)+      let (first, rest) = splitAt i l+      partition (first : res) rest

+ test/Unit.hs view

@@ -0,0 +1,21 @@+import Database.Persist.Migration.Internal (MigrateBackend)+import qualified Database.Persist.Migration.Postgres as Postgres+import Test.Tasty+import Test.Unit.Migration (testMigrations)+import Test.Unit.Property (testProperties)+import Test.Utils.Goldens (goldenDir)++unitDir :: String -> FilePath+unitDir = goldenDir "unit"++main :: IO ()+main = defaultMain $ testGroup "persistent-migration-goldens"+  [ testBackend "postgresql" Postgres.backend+  , testProperties+  ]++-- | Build a test suite running unit tests for the given MigrateBackend.+testBackend :: String -> MigrateBackend -> TestTree+testBackend label backend = testGroup label+  [ testMigrations (unitDir label) backend+  ]