beam-automigrate 0.1.2.0 → 0.1.3.0
raw patch · 19 files changed
+577/−238 lines, 19 filesdep +postgresql-syntaxdep +sybdep −tmp-postgresdep ~aesondep ~basedep ~beam-corenew-component:exe:beam-automigrate-integration-tests
Dependencies added: postgresql-syntax, syb
Dependencies removed: tmp-postgres
Dependency ranges changed: aeson, base, beam-core, beam-postgres, dlist, postgresql-simple, pretty-simple, splitmix
Files
- CHANGELOG.md +10/−0
- README.lhs +30/−29
- README.md +30/−29
- beam-automigrate.cabal +33/−24
- examples/Example.hs +1/−1
- integration-tests/Main.hs +92/−45
- integration-tests/PostgresqlSyntax/Data/Orphans.hs +129/−0
- src/Database/Beam/AutoMigrate.hs +65/−8
- src/Database/Beam/AutoMigrate/Annotated.hs +1/−0
- src/Database/Beam/AutoMigrate/BenchUtil.hs +12/−13
- src/Database/Beam/AutoMigrate/Compat.hs +9/−0
- src/Database/Beam/AutoMigrate/Diff.hs +4/−4
- src/Database/Beam/AutoMigrate/Generic.hs +4/−3
- src/Database/Beam/AutoMigrate/Postgres.hs +6/−3
- src/Database/Beam/AutoMigrate/Types.hs +25/−5
- src/Database/Beam/AutoMigrate/Util.hs +3/−3
- src/Database/Beam/AutoMigrate/Validity.hs +98/−68
- tests/Test/Database/Beam/AutoMigrate/Arbitrary.hs +0/−3
- util/Database/Beam/AutoMigrate/TestUtils.hs +25/−0
CHANGELOG.md view
@@ -1,5 +1,15 @@ # Revision history for beam-automigrate +## 0.1.3.0++* [#47](https://github.com/obsidiansystems/beam-automigrate/pull/47): Generate postgres enum types in schema when using `Nullable PgEnum` values.+* Add `showMigration`+* Extend allowable version bounds for aeson, base, dlist, pretty-simple, and splitmix+* Add support for postgres' oid column type+* Add `calcMigrationSteps` function to compute the `Diff` that will be performed by a migration without altering the database.+* Support GHC 9.0.2+* Fix an issue where names starting with an upper case letter and containing no other characters requiring escaping would not be properly escaped+ ## 0.1.2.0 * Escape sql identifiers that are on the [postgres reserved keywords list](https://www.postgresql.org/docs/current/sql-keywords-appendix.html)
README.lhs view
@@ -36,7 +36,7 @@ appropriate dependencies with the following command: ```bash-$ nix-shell release.nix -A env+$ nix-shell ``` From that nix-shell, you can run `cabal repl readme`.@@ -56,6 +56,7 @@ > {-# LANGUAGE DataKinds #-} > {-# LANGUAGE DeriveGeneric #-} > {-# LANGUAGE DeriveAnyClass #-}+> {-# LANGUAGE OverloadedStrings #-} > {-# LANGUAGE TypeApplications #-} > {-# LANGUAGE TypeFamilies #-} > import Prelude hiding ((.))@@ -65,11 +66,11 @@ > import Database.Beam.Schema > import Database.Beam (val_) > import qualified Database.Beam.AutoMigrate as BA+> import Database.Beam.AutoMigrate.TestUtils > import Database.PostgreSQL.Simple as Pg-> import Gargoyle.PostgreSQL.Connect > import GHC.Generics-> import Data.Pool (withResource) > import Data.Text+> import System.Environment (getArgs) > > data CitiesT f = City > { ctCity :: Columnar f Text@@ -261,36 +262,36 @@ ```haskell >-> readmeDbTransaction :: (Connection -> IO a) -> IO a-> readmeDbTransaction f = withDb "readme-db" $ \pool ->-> withResource pool $ \conn ->-> Pg.withTransaction conn $ f conn->-> exampleShowMigration :: IO ()-> exampleShowMigration = readmeDbTransaction $ \conn ->-> runBeamPostgres conn $-> BA.printMigration $ BA.migrate conn hsSchema+> exampleShowMigration :: Connection -> IO ()+> exampleShowMigration conn = runBeamPostgres conn $+> BA.printMigration $ BA.migrate conn hsSchema >-> exampleAutoMigration :: IO ()-> exampleAutoMigration = withDb "readme-db" $ \pool ->-> withResource pool $ \conn ->-> BA.tryRunMigrationsWithEditUpdate annotatedDB conn+> exampleAutoMigration :: Connection -> IO ()+> exampleAutoMigration conn =+> BA.tryRunMigrationsWithEditUpdate annotatedDB conn > > main :: IO () > main = do-> putStrLn "----------------------------------------------------"-> putStrLn "MIGRATION PLAN (if migration needed):"-> putStrLn "----------------------------------------------------"-> exampleShowMigration-> putStrLn "----------------------------------------------------"-> putStrLn "MIGRATE?"-> putStrLn "----------------------------------------------------"-> putStrLn "Would you like to run the migration on the database in the folder \"readme-db\" (will be created if it doesn't exist)? (y/n)"-> response <- getLine-> case response of-> "y" -> exampleAutoMigration-> "Y" -> exampleAutoMigration-> _ -> putStrLn "Exiting"+> args <- getArgs+> let (getLine', connMethod) = case args of+> -- The "ci" argument allows the readme to be run and tested in a headless+> -- environment (e.g., by a continuous integration server)+> ["ci"] -> (return "y", ConnMethod_Direct $ defaultConnectInfo { connectDatabase = "readme" })+> _ -> (getLine, ConnMethod_Gargoyle "readme-db")+> withConnection connMethod $ \conn -> Pg.withTransaction conn$ do+> putStrLn "----------------------------------------------------"+> putStrLn "MIGRATION PLAN (if migration needed):"+> putStrLn "----------------------------------------------------"+> exampleShowMigration conn+> putStrLn "----------------------------------------------------"+> putStrLn "MIGRATE?"+> putStrLn "----------------------------------------------------"+> putStrLn "Would you like to run the migration on the database in the folder \"readme-db\" (will be created if it doesn't exist)? (y/n)"+> response <- getLine'+> case response of+> "y" -> exampleAutoMigration conn+> "Y" -> exampleAutoMigration conn+> _ -> putStrLn "Exiting" > ```
README.md view
@@ -36,7 +36,7 @@ appropriate dependencies with the following command: ```bash-$ nix-shell release.nix -A env+$ nix-shell ``` From that nix-shell, you can run `cabal repl readme`.@@ -56,6 +56,7 @@ > {-# LANGUAGE DataKinds #-} > {-# LANGUAGE DeriveGeneric #-} > {-# LANGUAGE DeriveAnyClass #-}+> {-# LANGUAGE OverloadedStrings #-} > {-# LANGUAGE TypeApplications #-} > {-# LANGUAGE TypeFamilies #-} > import Prelude hiding ((.))@@ -65,11 +66,11 @@ > import Database.Beam.Schema > import Database.Beam (val_) > import qualified Database.Beam.AutoMigrate as BA+> import Database.Beam.AutoMigrate.TestUtils > import Database.PostgreSQL.Simple as Pg-> import Gargoyle.PostgreSQL.Connect > import GHC.Generics-> import Data.Pool (withResource) > import Data.Text+> import System.Environment (getArgs) > > data CitiesT f = City > { ctCity :: Columnar f Text@@ -261,36 +262,36 @@ ```haskell >-> readmeDbTransaction :: (Connection -> IO a) -> IO a-> readmeDbTransaction f = withDb "readme-db" $ \pool ->-> withResource pool $ \conn ->-> Pg.withTransaction conn $ f conn->-> exampleShowMigration :: IO ()-> exampleShowMigration = readmeDbTransaction $ \conn ->-> runBeamPostgres conn $-> BA.printMigration $ BA.migrate conn hsSchema+> exampleShowMigration :: Connection -> IO ()+> exampleShowMigration conn = runBeamPostgres conn $+> BA.printMigration $ BA.migrate conn hsSchema >-> exampleAutoMigration :: IO ()-> exampleAutoMigration = withDb "readme-db" $ \pool ->-> withResource pool $ \conn ->-> BA.tryRunMigrationsWithEditUpdate annotatedDB conn+> exampleAutoMigration :: Connection -> IO ()+> exampleAutoMigration conn =+> BA.tryRunMigrationsWithEditUpdate annotatedDB conn > > main :: IO () > main = do-> putStrLn "----------------------------------------------------"-> putStrLn "MIGRATION PLAN (if migration needed):"-> putStrLn "----------------------------------------------------"-> exampleShowMigration-> putStrLn "----------------------------------------------------"-> putStrLn "MIGRATE?"-> putStrLn "----------------------------------------------------"-> putStrLn "Would you like to run the migration on the database in the folder \"readme-db\" (will be created if it doesn't exist)? (y/n)"-> response <- getLine-> case response of-> "y" -> exampleAutoMigration-> "Y" -> exampleAutoMigration-> _ -> putStrLn "Exiting"+> args <- getArgs+> let (getLine', connMethod) = case args of+> -- The "ci" argument allows the readme to be run and tested in a headless+> -- environment (e.g., by a continuous integration server)+> ["ci"] -> (return "y", ConnMethod_Direct $ defaultConnectInfo { connectDatabase = "readme" })+> _ -> (getLine, ConnMethod_Gargoyle "readme-db")+> withConnection connMethod $ \conn -> Pg.withTransaction conn$ do+> putStrLn "----------------------------------------------------"+> putStrLn "MIGRATION PLAN (if migration needed):"+> putStrLn "----------------------------------------------------"+> exampleShowMigration conn+> putStrLn "----------------------------------------------------"+> putStrLn "MIGRATE?"+> putStrLn "----------------------------------------------------"+> putStrLn "Would you like to run the migration on the database in the folder \"readme-db\" (will be created if it doesn't exist)? (y/n)"+> response <- getLine'+> case response of+> "y" -> exampleAutoMigration conn+> "Y" -> exampleAutoMigration conn+> _ -> putStrLn "Exiting" > ```
beam-automigrate.cabal view
@@ -1,8 +1,8 @@ name: beam-automigrate-version: 0.1.2.0+version: 0.1.3.0 license-file: LICENSE build-type: Simple-cabal-version: >=1.10+cabal-version: 2.0 author: Alfredo Di Napoli, Andres Löh, Well-Typed LLP, and Obsidian Systems LLC copyright: 2020 Obsidian Systems LLC maintainer: maintainer@obsidian.systems@@ -22,7 +22,7 @@ README.md CHANGELOG.md -tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 library exposed-modules:@@ -40,22 +40,22 @@ hs-source-dirs: src build-depends:- aeson >=1.4.4 && <1.5+ aeson >=1.4.4 && <2.2 , base >=4.9 && <5 , beam-core >=0.9 && <0.10 , beam-postgres >=0.5 && <0.6 , bytestring >=0.10.8.2 && <0.12.0.0 , containers >=0.5.9.2 && <0.8.0.0 , deepseq >=1.4.4 && <1.6- , dlist >=0.8.0 && <0.10+ , dlist >=0.8.0 && <1.1 , microlens >=0.4.10 && <0.6 , mtl >=2.2.2 && <2.4 , postgresql-simple >=0.5.4 && <0.7.0.0- , pretty-simple >=2.2.0 && <3.3+ , pretty-simple >=2.2.0 && <4.2 , QuickCheck >=2.13 && <2.15 , quickcheck-instances >=0.3 && <0.4 , scientific >=0.3.6 && <0.5- , splitmix >=0.0.3 && <0.1+ , splitmix >=0.0.3 && <0.2 , string-conv >=0.1.2 && <0.3 , text >=1.2.0.0 && <1.3.0.0 , time >=1.8.0 && <2@@ -81,6 +81,19 @@ if flag(werror) ghc-options: -Werror +library beam-automigrate-test-utils+ hs-source-dirs: util+ build-depends:+ base+ , gargoyle-postgresql-connect+ , postgresql-simple+ , resource-pool+ , tasty+ exposed-modules:+ Database.Beam.AutoMigrate.TestUtils+ ghc-options: -Wall+ default-language: Haskell2010+ test-suite beam-automigrate-tests type: exitcode-stdio-1.0 hs-source-dirs: tests@@ -99,31 +112,33 @@ default-language: Haskell2010 default-extensions: OverloadedStrings -test-suite beam-automigrate-integration-tests- type: exitcode-stdio-1.0+executable beam-automigrate-integration-tests hs-source-dirs: integration-tests tests main-is: Main.hs other-modules: Test.Database.Beam.AutoMigrate.Arbitrary+ PostgresqlSyntax.Data.Orphans build-depends: base , beam-automigrate+ , beam-automigrate-test-utils+ , beam-core+ , beam-postgres , containers , postgresql-simple+ , postgresql-syntax >= 0.4 && <0.5 , pretty-simple , QuickCheck , tasty , tasty-quickcheck , text- , tmp-postgres >=1.31.0.1 && <1.35.0.0+ , syb + ghc-options: -Wall -threaded default-language: Haskell2010 default-extensions: OverloadedStrings ScopedTypeVariables - if !flag(integration-tests)- buildable: False- executable beam-automigrate-examples hs-source-dirs: examples main-is: Main.hs@@ -155,7 +170,7 @@ TypeApplications TypeFamilies - ghc-options: -Wall -O2 -rtsopts+ ghc-options: -Wall -O2 -rtsopts -threaded if flag(werror) ghc-options: -Werror@@ -176,7 +191,7 @@ default-language: Haskell2010 default-extensions: OverloadedStrings- ghc-options: -Wall -O2 -rtsopts+ ghc-options: -Wall -O2 -rtsopts -threaded benchmark beam-automigrate-bench type: exitcode-stdio-1.0@@ -195,21 +210,20 @@ , splitmix default-language: Haskell2010- ghc-options: -Wall -O2 -rtsopts+ ghc-options: -Wall -O2 -rtsopts -threaded executable readme build-depends: base , beam-automigrate+ , beam-automigrate-test-utils , beam-core , beam-postgres- , gargoyle-postgresql-connect , postgresql-simple- , resource-pool , text default-language: Haskell2010 main-is: README.lhs- ghc-options: -Wall -optL -q+ ghc-options: -Wall -optL -q -threaded flag werror description: Enable -Werror during development@@ -218,11 +232,6 @@ flag ghcipretty description: Enable pretty-show for pretty-printing purposes- default: False- manual: True--flag integration-tests- description: Enable integration tests that talks to a Postgres DB. default: False manual: True
examples/Example.hs view
@@ -223,7 +223,7 @@ getDbSchema :: String -> IO Schema getDbSchema dbName =- bracket (connect defaultConnectInfo {connectUser = "adinapoli", connectDatabase = dbName}) close getSchema+ bracket (connect defaultConnectInfo {connectDatabase = dbName}) close getSchema getFlowerDbSchema :: IO Schema getFlowerDbSchema = getDbSchema "beam-test-db"
integration-tests/Main.hs view
@@ -1,70 +1,117 @@+{-# LANGUAGE LambdaCase #-}+ module Main where -import Control.Exception (bracket) import Control.Monad.IO.Class (liftIO)-import qualified Data.List as L-import qualified Data.Text.Lazy as TL+import Data.Proxy import Database.Beam.AutoMigrate-import Database.Beam.AutoMigrate.BenchUtil (cleanDatabase, tearDownDatabase)+import Database.Beam.AutoMigrate.BenchUtil (cleanDatabase) import Database.Beam.AutoMigrate.Postgres (getSchema)-import Database.Beam.AutoMigrate.Schema.Gen-import Database.Beam.AutoMigrate.Validity+import Database.Beam.AutoMigrate.TestUtils+import Database.Beam.Postgres import qualified Database.PostgreSQL.Simple as Pg-import qualified Database.Postgres.Temp as Tmp+import qualified Database.PostgreSQL.Simple.Transaction as Pg import qualified Test.Database.Beam.AutoMigrate.Arbitrary as Pretty import Test.QuickCheck import Test.QuickCheck.Monadic import Test.Tasty+import Test.Tasty.Options import Test.Tasty.QuickCheck as QC+import Test.Tasty.Runners +import Data.Generics.Aliases (mkT)+import Data.Generics.Schemes (everywhere)+import Data.Int+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import PostgresqlSyntax.Ast+import PostgresqlSyntax.Data.Orphans ()+import qualified PostgresqlSyntax.Parsing as PgParsing+import qualified PostgresqlSyntax.Rendering as PgRendering+ main :: IO ()-main = defaultMain tests+main = do+ let opts = includingOptions [Option (Proxy :: Proxy ConnMethod)]+ optset <- parseOptions [opts] (testGroup "" [])+ withConnection (lookupOption optset) $ \conn ->+ defaultMainWithIngredients (opts : defaultIngredients) $ tests conn -tests :: TestTree-tests = testGroup "Tests" [properties]+tests :: Pg.Connection -> TestTree+tests c = testGroup "Tests" [properties c] -properties :: TestTree-properties =+properties :: Pg.Connection -> TestTree+properties conn = testGroup "Integration tests" [ -- We test that if we generate and apply a migration from a 'hsSchema', when we read the -- 'Schema' back from the DB, we should end up with the original 'hsSchema'.- dbResource $ \getResource -> QC.testProperty "Migration roundtrip (empty DB)" $- \hsSchema -> hsSchema /= noSchema ==> dbProperty getResource $ \dbConn -> liftIO $ do- let mig = migrate dbConn hsSchema- runMigrationUnsafe dbConn mig- dbSchema <- getSchema dbConn- pure $ hsSchema Pretty.=== dbSchema,+ QC.testProperty "Migration roundtrip (empty DB)" $+ \hsSchema -> hsSchema /= noSchema ==> do+ dbProperty conn $ \_ -> do+ let mig = migrate conn hsSchema+ runBeamPostgres conn (unsafeRunMigration mig)+ dbSchema <- getSchema conn+ let hsSchema' = normalizeDefaultExprs hsSchema+ dbSchema' = normalizeDefaultExprs dbSchema+ pure $ whenFail (printMigrationIO mig) $ hsSchema' Pretty.=== dbSchema' -- We test that after a successful migration, calling 'diff' should yield no edits.- dbResource $ \getResource -> QC.testProperty "Diffing after a migration yields no edits" $- \hsSchema -> hsSchema /= noSchema ==> dbProperty getResource $ \dbConn -> liftIO $ do- let mig = migrate dbConn hsSchema- runMigrationUnsafe dbConn mig- dbSchema <- getSchema dbConn- pure $ diff hsSchema dbSchema === Right []+ , QC.testProperty "Diffing after a migration yields no edits" $+ \hsSchema -> hsSchema /= noSchema ==> dbProperty conn $ \_ -> liftIO $ do+ let mig = migrate conn hsSchema+ runBeamPostgres conn (unsafeRunMigration mig)+ dbSchema <- getSchema conn+ pure $ diff (normalizeDefaultExprs hsSchema) (normalizeDefaultExprs dbSchema) === Right [] ] -- | Execute a monadic 'Property' while also cleaning up any database's data at the end.-dbProperty :: Testable prop => IO (Tmp.DB, Pg.Connection) -> (Pg.Connection -> PropertyM IO prop) -> Property-dbProperty getResource prop = withMaxSuccess 50 $- monadicIO $ do- (_, dbConn) <- liftIO getResource- r <- prop dbConn- liftIO $ cleanDatabase dbConn- pure r+dbProperty :: Testable prop => Pg.Connection -> (Pg.Connection -> IO prop) -> Property+dbProperty conn prop = withMaxSuccess 50 $ monadicIO $ liftIO $ Pg.withTransactionSerializable conn $ do+ cleanDatabase conn+ r <- prop conn+ pure r --- | Acquire a temporary database for each 'TestTree', and dispose it afterwards.-dbResource :: (IO (Tmp.DB, Pg.Connection) -> TestTree) -> TestTree-dbResource use = withResource acquire release use- where- acquire :: IO (Tmp.DB, Pg.Connection)- acquire = do- r <- Tmp.start- case r of- Left e -> fail ("dbResource startup failed: " ++ show e)- Right tmpDb -> do- conn <- Pg.connectPostgreSQL (Tmp.toConnectionString tmpDb)- pure (tmpDb, conn)+class NormalizeDefaultExprs t where+ normalizeDefaultExprs :: t -> t - release :: (Tmp.DB, Pg.Connection) -> IO ()- release (db, conn) = tearDownDatabase conn >> Tmp.stop db+instance NormalizeDefaultExprs Schema where+ normalizeDefaultExprs s = s { schemaTables = Map.map normalizeDefaultExprs (schemaTables s) }++instance NormalizeDefaultExprs Table where+ normalizeDefaultExprs t = t { tableColumns = Map.map normalizeDefaultExprs (tableColumns t)}++instance NormalizeDefaultExprs Column where+ normalizeDefaultExprs c = c { columnConstraints = Set.map normalizeDefaultExprs (columnConstraints c) }++instance NormalizeDefaultExprs ColumnConstraint where+ normalizeDefaultExprs = \case+ NotNull -> NotNull+ Default t -> Default (normalizeDefaultExpr t)++normalizeDefaultExpr :: Text -> Text+normalizeDefaultExpr t = case PgParsing.run PgParsing.aExpr t of+ Left _error -> t+ Right x -> PgRendering.toText . PgRendering.aExpr . everywhere (mkT simplifyAExpr) $ x++simplifyAExpr :: AExpr -> AExpr+simplifyAExpr e = case e of+ TypecastAExpr e' _type -> e'+ CExprAExpr (InParensCExpr e' Nothing) -> e'+ e' | Just n <- evaluableAExprInt64 e' -> CExprAExpr (AexprConstCExpr (IAexprConst n))+ _ -> e++evaluableAExprInt64 :: AExpr -> Maybe Int64+evaluableAExprInt64 e = case e of+ MinusAExpr e' -> fmap negate (evaluableAExprInt64 e')+ CExprAExpr e' -> evaluableCExprInt64 e'+ _ -> Nothing++evaluableCExprInt64 :: CExpr -> Maybe Int64+evaluableCExprInt64 e = case e of+ AexprConstCExpr (IAexprConst n) -> Just n+ AexprConstCExpr (SAexprConst s) -> case reads (T.unpack s) of+ [(n,"")] -> Just n+ _ -> Nothing+ _ -> Nothing+
+ integration-tests/PostgresqlSyntax/Data/Orphans.hs view
@@ -0,0 +1,129 @@+{-|+Description:+ Orphan Data instances for PostgresqlSyntax++These instances are being upstreamed <here https://github.com/nikita-volkov/postgresql-syntax/pull/6> and, once they are, this module will be removed.+-}+{-# Language CPP #-}+{-# Language DeriveDataTypeable #-}+{-# Language StandaloneDeriving #-}+{-# options_ghc -fno-warn-orphans #-}+module PostgresqlSyntax.Data.Orphans where++import Data.Data+import PostgresqlSyntax.Ast++deriving instance Data AExpr+deriving instance Data CExpr+deriving instance Data Typename+deriving instance Data Columnref+deriving instance Data AnyName+deriving instance Data AexprConst+deriving instance Data TypenameArrayDimensions+deriving instance Data IndirectionEl+deriving instance Data SymbolicExprBinOp+deriving instance Data CaseExpr+deriving instance Data SimpleTypename+deriving instance Data Ident+deriving instance Data FuncConstArgs+deriving instance Data QualOp+deriving instance Data FuncExpr+deriving instance Data FuncName+deriving instance Data MathOp+deriving instance Data WhenClause+deriving instance Data GenericType+deriving instance Data SortBy+deriving instance Data VerbalExprBinOp+deriving instance Data SelectWithParens+deriving instance Data ConstTypename+deriving instance Data Numeric+deriving instance Data FuncArgExpr+deriving instance Data AnyOperator+deriving instance Data OverClause+deriving instance Data NullsOrder+deriving instance Data AExprReversableOp+deriving instance Data ArrayExpr+deriving instance Data Interval+deriving instance Data Bit+deriving instance Data FuncApplication+deriving instance Data QualAllOp+deriving instance Data SelectNoParens+deriving instance Data AllOp+deriving instance Data WindowSpecification+deriving instance Data Row+deriving instance Data ImplicitRow+deriving instance Data Character+deriving instance Data FuncExprCommonSubexpr+deriving instance Data AscDesc+deriving instance Data ConstCharacter+deriving instance Data BExpr+deriving instance Data FuncApplicationParams+deriving instance Data ForLockingClause+deriving instance Data FrameClause+deriving instance Data SubType+deriving instance Data ConstDatetime+deriving instance Data InExpr+deriving instance Data SelectLimit+deriving instance Data ExtractList+deriving instance Data BExprIsOp+deriving instance Data ForLockingItem+deriving instance Data WindowExclusionClause+deriving instance Data SubqueryOp+deriving instance Data SimpleSelect+deriving instance Data OverlayList+deriving instance Data FrameExtent+deriving instance Data OffsetClause+deriving instance Data ExtractArg+deriving instance Data QualifiedName+deriving instance Data WithClause+deriving instance Data PositionList+deriving instance Data FrameClauseMode+deriving instance Data LimitClause+deriving instance Data ForLockingStrength+deriving instance Data WindowDefinition+deriving instance Data FrameBound+deriving instance Data SelectFetchFirstValue+deriving instance Data SubstrList+deriving instance Data GroupByItem+deriving instance Data CommonTableExpr+deriving instance Data SelectLimitValue+deriving instance Data TrimList+deriving instance Data TableRef+deriving instance Data SubstrListFromFor+deriving instance Data PreparableStmt+deriving instance Data TrimModifier+deriving instance Data OptTempTableName+deriving instance Data TablesampleClause+deriving instance Data InsertStmt+deriving instance Data Targeting+deriving instance Data AliasClause+deriving instance Data UpdateStmt+deriving instance Data TargetEl+deriving instance Data RelationExpr+deriving instance Data DeleteStmt+deriving instance Data OnConflict+deriving instance Data WhereOrCurrentClause+deriving instance Data SelectBinOp+deriving instance Data FuncAliasClause+#if MIN_VERSION_postgresql_syntax(0,4,1)+deriving instance Data CallStmt+#endif+deriving instance Data InsertRest+deriving instance Data SetClause+deriving instance Data RelationExprOptAlias+deriving instance Data OnConflictDo+deriving instance Data FuncTable+deriving instance Data InsertTarget+deriving instance Data ConfExpr+deriving instance Data TableFuncElement+deriving instance Data OverrideKind+deriving instance Data SetTarget+deriving instance Data JoinedTable+deriving instance Data InsertColumnItem+deriving instance Data FuncExprWindowless+deriving instance Data IndexElem+deriving instance Data RowsfromItem+deriving instance Data JoinMeth+deriving instance Data IndexElemDef+deriving instance Data JoinQual+deriving instance Data JoinType
src/Database/Beam/AutoMigrate.hs view
@@ -28,6 +28,7 @@ runMigrationUnsafe, runMigrationWithEditUpdate, tryRunMigrationsWithEditUpdate,+ calcMigrationSteps, -- * Creating a migration from a Diff createMigration,@@ -39,6 +40,7 @@ -- * Printing migrations for debugging purposes prettyEditActionDescription, prettyEditSQL,+ showMigration, printMigration, printMigrationIO, @@ -59,7 +61,6 @@ import Control.Exception import Control.Monad.Except-import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Identity (runIdentity) import Control.Monad.State.Strict import Data.Bifunctor (first)@@ -75,7 +76,6 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as LT-import Database.Beam (MonadBeam) import Database.Beam.AutoMigrate.Annotated as Exports import Database.Beam.AutoMigrate.Compat as Exports import Database.Beam.AutoMigrate.Diff as Exports@@ -266,8 +266,14 @@ -- intervene in the event of unsafe edits. let newEdits = sortEdits $ editUpdate $ sortEdits edits -- If the new list of edits still contains any unsafe edits then fail out.++ when (newEdits /= sortEdits edits) $ do+ putStrLn "Changes requested to diff induced migration. Attempting..."+ prettyPrintEdits newEdits+ when (any (editSafetyIs Unsafe . fst . unPriority) newEdits) $ throwIO $ UnsafeEditsDetected $ fmap (\(WithPriority (e, _)) -> _editAction e) newEdits+ -- Execute all the edits within a single transaction so we rollback if any of them fail. Pg.withTransaction conn $ Pg.runBeamPostgres conn $@@ -332,8 +338,8 @@ -- | Converts a single 'Edit' into the relevant 'PgSyntax' necessary to generate the final SQL. toSqlSyntax :: Edit -> Pg.PgSyntax toSqlSyntax e =- safetyPrefix $- _editAction e & \case+ safetyPrefix $ _editAction e & \case+ EditAction_Automatic ea -> case ea of TableAdded tblName tbl -> ddlSyntax ( "CREATE TABLE " <> sqlEscaped (tableName tblName)@@ -394,6 +400,14 @@ <> " DROP " <> renderColumnConstraint DropConstraint cstr )+ EditAction_Manual ea -> case ea of+ ColumnRenamed tblName oldName newName ->+ updateSyntax+ ( alterTable tblName <> "RENAME COLUMN "+ <> sqlEscaped (columnName oldName)+ <> " TO "+ <> sqlEscaped (columnName newName)+ ) where safetyPrefix query = if editSafetyIs Safe e@@ -553,6 +567,8 @@ PgSpecificType PgUuid -> toS $ displaySyntax Pg.pgUuidType -- enumerations PgSpecificType (PgEnumeration (EnumerationName ty)) -> ty+ -- oid+ PgSpecificType PgOid -> "oid" evalMigration :: Monad m => Migration m -> m (Either MigrationError [WithPriority Edit]) evalMigration m = do@@ -571,10 +587,15 @@ -- | Prints the migration to stdout. Useful for debugging and diagnostic. printMigration :: MonadIO m => Migration m -> m () printMigration m = do+ showMigration m >>= liftIO . putStrLn++-- | Pretty-prints the migration. Useful for debugging and diagnostic.+showMigration :: MonadIO m => Migration m -> m String+showMigration m = do (a, sortedEdits) <- fmap sortEdits <$> runStateT (runExceptT m) mempty case a of Left e -> liftIO $ throwIO e- Right () -> liftIO $ putStrLn (unlines . map displaySyntax $ editsToPgSyntax sortedEdits)+ Right () -> return $ unlines $ map displaySyntax $ editsToPgSyntax sortedEdits printMigrationIO :: Migration Pg.Pg -> IO () printMigrationIO mig = Pg.runBeamPostgres (undefined :: Pg.Connection) $ printMigration mig@@ -586,8 +607,8 @@ prettyEditSQL = T.pack . displaySyntax . Pg.fromPgCommand . editToSqlCommand prettyEditActionDescription :: EditAction -> Text-prettyEditActionDescription =- T.unwords . \case+prettyEditActionDescription = T.unwords . \case+ EditAction_Automatic ea -> case ea of TableAdded tblName table -> ["create table:", qt tblName, "\n", pshow' table] TableRemoved tblName ->@@ -644,6 +665,15 @@ ["add sequence:", qs sequenceName, pshow' sequence0] SequenceRemoved sequenceName -> ["remove sequence:", qs sequenceName]+ EditAction_Manual ea -> case ea of+ ColumnRenamed tblName oldName newName ->+ [ "rename column in table:",+ qt tblName,+ "\nfrom:",+ qc oldName,+ "\nto:",+ qc newName+ ] where q t = "'" <> t <> "'" qt = q . tableName@@ -653,6 +683,9 @@ pshow' :: Show a => a -> Text pshow' = LT.toStrict . PS.pShow +prettyPrintEdits :: [WithPriority Edit] -> IO ()+prettyPrintEdits edits = putStrLn $ T.unpack $ T.unlines $ fmap (prettyEditSQL . fst . unPriority) (sortEdits edits)+ -- | Compare the existing schema in the database with the expected -- schema in Haskell and try to edit the existing schema as necessary tryRunMigrationsWithEditUpdate@@ -683,10 +716,34 @@ putStrLn "No database migration required, continuing startup." Right edits -> do putStrLn "Database migration required, attempting..."- putStrLn $ T.unpack $ T.unlines $ fmap (prettyEditSQL . fst . unPriority) edits+ prettyPrintEdits edits try (runMigrationWithEditUpdate Prelude.id conn expectedHaskellSchema) >>= \case Left (e :: SomeException) -> error $ "Database migration error: " <> displayException e Right _ -> pure ()++-- | Compute the `Diff` consisting of the steps that would be taken to migrate from the current actual+-- database schema to the given one, without actually performing the migration.+calcMigrationSteps+ :: ( Generic (db (DatabaseEntity be db))+ , (Generic (db (AnnotatedDatabaseEntity be db)))+ , Database be db+ , (GZipDatabase be+ (AnnotatedDatabaseEntity be db)+ (AnnotatedDatabaseEntity be db)+ (DatabaseEntity be db)+ (Rep (db (AnnotatedDatabaseEntity be db)))+ (Rep (db (AnnotatedDatabaseEntity be db)))+ (Rep (db (DatabaseEntity be db)))+ )+ , (GSchema be db '[] (Rep (db (AnnotatedDatabaseEntity be db))))+ )+ => AnnotatedDatabaseSettings be db+ -> Pg.Connection+ -> IO Diff+calcMigrationSteps annotatedDb conn = do+ let expectedHaskellSchema = fromAnnotatedDbSettings annotatedDb (Proxy @'[])+ actualDatabaseSchema <- getSchema conn+ pure $ diff expectedHaskellSchema actualDatabaseSchema
src/Database/Beam/AutoMigrate/Annotated.hs view
@@ -24,6 +24,7 @@ dbAnnotatedConstraints, annotatedDescriptor, defaultTableSchema,+ GDefaultTableSchema(..), -- * Downcasting annotated types lowerEntityDescriptor,
src/Database/Beam/AutoMigrate/BenchUtil.hs view
@@ -1,12 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} module Database.Beam.AutoMigrate.BenchUtil- ( SpineStrict (..),- predictableSchemas,- connInfo,- setupDatabase,- cleanDatabase,- tearDownDatabase,+ ( SpineStrict (..)+ , predictableSchemas+ , connInfo+ , setupDatabase+ , cleanDatabase+ , tearDownDatabase ) where @@ -45,13 +45,12 @@ cleanDatabase :: Pg.Connection -> IO () cleanDatabase conn = do- Pg.withTransaction conn $ do- -- Delete all tables to start from a clean slate- _ <- Pg.execute_ conn "DROP SCHEMA public CASCADE"- _ <- Pg.execute_ conn "CREATE SCHEMA public"- _ <- Pg.execute_ conn "GRANT USAGE ON SCHEMA public TO public"- _ <- Pg.execute_ conn "GRANT CREATE ON SCHEMA public TO public"- pure ()+ -- Delete all tables to start from a clean slate+ _ <- Pg.execute_ conn "DROP SCHEMA public CASCADE"+ _ <- Pg.execute_ conn "CREATE SCHEMA public"+ _ <- Pg.execute_ conn "GRANT USAGE ON SCHEMA public TO public"+ _ <- Pg.execute_ conn "GRANT CREATE ON SCHEMA public TO public"+ pure () tearDownDatabase :: Pg.Connection -> IO () tearDownDatabase conn = cleanDatabase conn `finally` Pg.close conn
src/Database/Beam/AutoMigrate/Compat.hs view
@@ -27,6 +27,7 @@ import Database.Beam.Backend.SQL hiding (tableName) import qualified Database.Beam.Backend.SQL.AST as AST import qualified Database.Beam.Postgres as Pg+import qualified Database.PostgreSQL.Simple.Types as Psql -- -- Specifying SQL data types and constraints@@ -135,6 +136,7 @@ instance HasColumnType ty => HasColumnType (Maybe ty) where defaultColumnType _ = defaultColumnType (Proxy @ty) defaultTypeCast _ = defaultTypeCast (Proxy @ty)+ defaultEnums _ = defaultEnums (Proxy @ty) instance HasColumnType Int where defaultColumnType _ = SqlStdType intType@@ -289,3 +291,10 @@ instance (Show a, Typeable a, Enum a, Bounded a) => HasColumnType (DbEnum a) where defaultColumnType _ = SqlStdType $ varCharType Nothing Nothing defaultTypeCast _ = Just "character varying"++--+-- support for oid+--++instance HasColumnType Psql.Oid where+ defaultColumnType _ = PgSpecificType PgOid
src/Database/Beam/AutoMigrate/Diff.hs view
@@ -45,7 +45,7 @@ newtype WithPriority a = WithPriority {unPriority :: (a, Priority)} deriving (Show, Eq, Ord) -editPriority :: EditAction -> Priority+editPriority :: AutomaticEditAction -> Priority editPriority = \case -- Operations that create tables, sequences or enums have top priority EnumTypeAdded {} -> Priority 0@@ -70,7 +70,7 @@ SequenceRemoved {} -> Priority 15 -- TODO: This needs to support adding conditional queries.-mkEdit :: EditAction -> WithPriority Edit+mkEdit :: AutomaticEditAction -> WithPriority Edit mkEdit e = WithPriority (defMkEdit e, editPriority e) -- | Sort edits according to their execution order, to make sure they don't reference@@ -135,8 +135,8 @@ pure $ e <> d addEdit ::- (k -> v -> EditAction) ->- (k -> c -> EditAction) ->+ (k -> v -> AutomaticEditAction) ->+ (k -> c -> AutomaticEditAction) -> (v -> S.Set c) -> (k, v) -> [WithPriority Edit]
src/Database/Beam/AutoMigrate/Generic.hs view
@@ -141,7 +141,7 @@ instance GTableEntry be db anns 'False (S1 f x) => GTables be db anns (S1 f x) where gTables db p x =- let (tbls, sqs) = gTableEntries db p (Proxy @ 'False) x+ let (tbls, sqs) = gTableEntries db p (Proxy @'False) x in (M.fromList tbls, sqs) instance GTableEntry be db anns tableFound x => GTableEntry be db anns tableFound (S1 f x) where@@ -160,8 +160,9 @@ mkTableEntryNoFkDiscovery annEntity = let entity = annEntity ^. deannotate tName = entity ^. dbEntityDescriptor . dbEntityName- pks = S.singleton (PrimaryKey (tName <> "_pkey") (S.fromList $ pkFieldNames entity))- (columns, seqs) = gColumns (Proxy @ 'GenSequences) (TableName tName) . from $ dbAnnotatedSchema (annEntity ^. annotatedDescriptor)+ pkColSet = S.fromList $ pkFieldNames entity+ pks = if S.null pkColSet then mempty else S.singleton (PrimaryKey (tName <> "_pkey") pkColSet)+ (columns, seqs) = gColumns (Proxy @'GenSequences) (TableName tName) . from $ dbAnnotatedSchema (annEntity ^. annotatedDescriptor) annotatedCons = dbAnnotatedConstraints (annEntity ^. annotatedDescriptor) in ((TableName tName, Table (pks <> annotatedCons) columns), seqs)
src/Database/Beam/AutoMigrate/Postgres.hs view
@@ -149,8 +149,8 @@ unlines [ "SELECT kcu.table_name::text as foreign_table,", " rel_kcu.table_name::text as primary_table,",- " array_agg(kcu.column_name::text)::text[] as fk_columns,",- " array_agg(rel_kcu.column_name::text)::text[] as pk_columns,",+ " array_agg(kcu.column_name::text ORDER BY kcu.position_in_unique_constraint)::text[] as fk_columns,",+ " array_agg(rel_kcu.column_name::text ORDER BY rel_kcu.ordinal_position)::text[] as pk_columns,", " kcu.constraint_name as cname", "FROM information_schema.table_constraints tco", "JOIN information_schema.key_column_usage kcu",@@ -373,6 +373,8 @@ Just (PgSpecificType PgRangeDate) | Pg.typoid Pg.uuid == oid = Just (PgSpecificType PgUuid)+ | Pg.typoid Pg.oid == oid =+ Just (PgSpecificType PgOid) | otherwise = Nothing @@ -471,7 +473,8 @@ let columnSet = S.fromList . V.toList $ sqlCon_fk_colums case sqlCon_constraint_type of SQL_raw_unique -> addTableConstraint currentTable (Unique sqlCon_name columnSet)- SQL_raw_pk -> addTableConstraint currentTable (PrimaryKey sqlCon_name columnSet)+ SQL_raw_pk -> if S.null columnSet then pure () else+ addTableConstraint currentTable (PrimaryKey sqlCon_name columnSet) newtype ReferenceActions = ReferenceActions {getActions :: Map Text Actions}
src/Database/Beam/AutoMigrate/Types.hs view
@@ -101,6 +101,9 @@ } deriving (Show, Eq, Ord, NFData, Generic) +instance IsString TableName where+ fromString = TableName . T.pack+ data Table = Table { tableConstraints :: Set TableConstraint, tableColumns :: Columns@@ -151,6 +154,7 @@ | PgRangeDate | PgUuid | PgEnumeration EnumerationName+ | PgOid deriving instance Show PgDataType @@ -211,6 +215,15 @@ -- | A possible list of edits on a 'Schema'. data EditAction+ = EditAction_Manual ManualEditAction+ | EditAction_Automatic AutomaticEditAction+ deriving (Show, Eq)++data ManualEditAction+ = ColumnRenamed TableName ColumnName {- old name -} ColumnName {- new name -}+ deriving (Show, Eq)++data AutomaticEditAction = TableAdded TableName Table | TableRemoved TableName | TableConstraintAdded TableName TableConstraint@@ -236,7 +249,7 @@ | Unsafe deriving (Show, Eq, Ord) -defaultEditSafety :: EditAction -> EditSafety+defaultEditSafety :: AutomaticEditAction -> EditSafety defaultEditSafety = \case TableAdded {} -> Safe TableRemoved {} -> Unsafe@@ -293,10 +306,10 @@ editSafetyIs :: EditSafety -> Edit -> Bool editSafetyIs s = fromMaybe False . preview (editCondition . _Right . to (== s)) -mkEditWith :: (EditAction -> EditSafety) -> EditAction -> Edit-mkEditWith isSafe e = Edit e (Right $ isSafe e)+mkEditWith :: (AutomaticEditAction -> EditSafety) -> AutomaticEditAction -> Edit+mkEditWith isSafe e = Edit (EditAction_Automatic e) (Right $ isSafe e) -defMkEdit :: EditAction -> Edit+defMkEdit :: AutomaticEditAction -> Edit defMkEdit = mkEditWith defaultEditSafety data InsertionOrder@@ -306,8 +319,15 @@ instance NFData InsertionOrder --- Manual instance as 'AST.DataType' doesn't derive 'NFData'. instance NFData EditAction where+ rnf (EditAction_Automatic ea) = rnf ea+ rnf (EditAction_Manual ea) = rnf ea++instance NFData ManualEditAction where+ rnf (ColumnRenamed tName oldName newName) = tName `deepseq` oldName `deepseq` newName `deepseq` ()++-- Manual instance as 'AST.DataType' doesn't derive 'NFData'.+instance NFData AutomaticEditAction where rnf (TableAdded tName tbl) = tName `deepseq` tbl `deepseq` () rnf (TableRemoved tName) = rnf tName rnf (TableConstraintAdded tName tCon) = tName `deepseq` tCon `deepseq` ()
src/Database/Beam/AutoMigrate/Util.hs view
@@ -13,7 +13,6 @@ import Data.Text (Text) import qualified Data.Text as T import Database.Beam.AutoMigrate.Types (ColumnName(..), TableName(..))-import Database.Beam.Schema (Beamable, PrimaryKey, TableEntity, TableSettings) import qualified Database.Beam.Schema as Beam import Database.Beam.Schema.Tables import Lens.Micro ((^.))@@ -122,9 +121,10 @@ Nothing -> True Just (c, rest) -> validUnescapedHead c && validUnescapedTail rest && not (sqlIsReservedKeyword t) where- validUnescapedHead c = c `elem` ("1234567890_"::String) || isAlpha c+ lowercase c = isAlpha c && isLower c+ validUnescapedHead c = c `elem` ("1234567890_"::String) || lowercase c validUnescapedTail = all- (\r -> (isAlpha r && isLower r) || r `elem` ("1234567890$_"::String)) . T.unpack+ (\r -> lowercase r || r `elem` ("1234567890$_"::String)) . T.unpack sqlIsReservedKeyword :: Text -> Bool sqlIsReservedKeyword t = T.toCaseFold t `Set.member` postgresKeywordsReserved
src/Database/Beam/AutoMigrate/Validity.hs view
@@ -30,6 +30,7 @@ import Data.Text (Text) import Database.Beam.AutoMigrate.Diff import Database.Beam.AutoMigrate.Types+import Lens.Micro ((&)) -- | Simple type that allows us to talk about \"qualified entities\" like columns, which name might not be -- unique globally (for which we need the 'TableName' to disambiguate things).@@ -175,17 +176,12 @@ -- 'Enum' type which doesn't exist. validateColumn :: Schema -> TableName -> (ColumnName, Column) -> Either [ValidationFailed] () validateColumn s tName (colName, col) =- when (isPgEnum $ columnType col) $- forM_ (M.keys $ schemaEnumerations s) $ \eName ->- case getAlt $ lookupEnumRef eName (colName, col) of- Nothing ->- let reason = ColumnReferencesNonExistingEnum (Qualified tName colName) eName- in Left [InvalidColumn (Qualified tName colName) reason]- Just _ -> Right ()- where- isPgEnum :: ColumnType -> Bool- isPgEnum (PgSpecificType (PgEnumeration _)) = True- isPgEnum _ = False+ case lookupEnum (colName, col) of+ Nothing -> Right ()+ Just eName | eName `elem` M.keys (schemaEnumerations s) -> Right ()+ Just eName ->+ let reason = ColumnReferencesNonExistingEnum (Qualified tName colName) eName+ in Left [InvalidColumn (Qualified tName colName) reason] -- | A 'Schema' enum is considered always valid in this context /except/ if it contains duplicate values. validateSchemaEnums :: Schema -> Either [ValidationFailed] ()@@ -241,11 +237,17 @@ Unique _ _ -> Nothing -- | Check that the input 'Column's type matches the input 'EnumerationName'.+lookupEnum :: (ColumnName, Column) -> Maybe EnumerationName+lookupEnum (_colName, col) =+ case columnType col of+ PgSpecificType (PgEnumeration eName) -> Just eName+ _ -> Nothing++-- | Check that the input 'Column's type matches the input 'EnumerationName'. lookupEnumRef :: EnumerationName -> (ColumnName, Column) -> Alt Maybe ColumnName lookupEnumRef eName (colName, col) = Alt $ case columnType col of- PgSpecificType (PgEnumeration eName') ->- if eName' == eName then Just colName else Nothing+ PgSpecificType (PgEnumeration eName') | eName == eName' -> Just colName _ -> Nothing -- | Removing an 'Enum' is valid if none of the 'Schema's tables have columns of this type.@@ -364,60 +366,62 @@ applyEdit :: Schema -> Edit -> Either ApplyFailed Schema applyEdit s edit@(Edit e _safety) = runExcept $ case e of- TableAdded tName tbl -> liftEither $ do- tables' <-- M.alterF- ( \case- -- Constaints are added as a separate edit step.- Nothing -> Right (Just tbl {tableConstraints = mempty})- Just existing -> Left (InvalidEdit edit (TableAlreadyExist tName existing))- )- tName- (schemaTables s)- pure $ s {schemaTables = tables'}- TableRemoved tName ->- withExistingTable tName edit s (removeTable edit s tName)- TableConstraintAdded tName con ->- withExistingTable tName edit s (addTableConstraint edit s con tName)- TableConstraintRemoved tName con ->- withExistingTable tName edit s (removeTableConstraint edit s con tName)- ColumnAdded tName colName col ->- withExistingTable tName edit s (addColumn edit colName col)- ColumnRemoved tName colName ->- withExistingTable tName edit s (removeColumn edit s colName tName)- ColumnTypeChanged tName colName oldType newType ->- withExistingColumn tName colName edit s (\_ -> changeColumnType edit colName oldType newType)- ColumnConstraintAdded tName colName con ->- withExistingColumn tName colName edit s (\_ -> addColumnConstraint edit tName con colName)- ColumnConstraintRemoved tName colName con ->- withExistingColumn tName colName edit s (\tbl -> removeColumnConstraint edit tbl tName colName con)- EnumTypeAdded eName enum -> liftEither $ do- enums' <-- M.alterF- ( \case- Nothing -> Right (Just enum)- Just existing -> Left (InvalidEdit edit (EnumAlreadyExist eName existing))- )- eName- (schemaEnumerations s)- pure $ s {schemaEnumerations = enums'}- EnumTypeRemoved eName ->- withExistingEnum eName edit s (removeEnum edit s eName)- EnumTypeValueAdded eName addedValue insOrder insPoint ->- withExistingEnum eName edit s (addValueToEnum edit eName addedValue insOrder insPoint)- SequenceAdded sName seqq -> liftEither $ do- seqs' <-- M.alterF- ( \case- Nothing -> Right (Just seqq)- Just existing -> Left (InvalidEdit edit (SequenceAlreadyExist sName existing))- )- sName- (schemaSequences s)- pure $ s {schemaSequences = seqs'}- SequenceRemoved sName ->- withExistingSequence sName edit s (removeSequence edit s sName)-+ EditAction_Automatic ea -> case ea of+ TableAdded tName tbl -> liftEither $ do+ tables' <-+ M.alterF+ ( \case+ -- Constaints are added as a separate edit step.+ Nothing -> Right (Just tbl {tableConstraints = mempty})+ Just existing -> Left (InvalidEdit edit (TableAlreadyExist tName existing))+ )+ tName+ (schemaTables s)+ pure $ s {schemaTables = tables'}+ TableRemoved tName ->+ withExistingTable tName edit s (removeTable edit s tName)+ TableConstraintAdded tName con ->+ withExistingTable tName edit s (addTableConstraint edit s con tName)+ TableConstraintRemoved tName con ->+ withExistingTable tName edit s (removeTableConstraint edit s con tName)+ ColumnAdded tName colName col ->+ withExistingTable tName edit s (addColumn edit colName col)+ ColumnRemoved tName colName ->+ withExistingTable tName edit s (removeColumn edit s colName tName)+ ColumnTypeChanged tName colName oldType newType ->+ withExistingColumn tName colName edit s (\_ -> changeColumnType edit colName oldType newType)+ ColumnConstraintAdded tName colName con ->+ withExistingColumn tName colName edit s (\_ -> addColumnConstraint edit tName con colName)+ ColumnConstraintRemoved tName colName con ->+ withExistingColumn tName colName edit s (\tbl -> removeColumnConstraint edit tbl tName colName con)+ EnumTypeAdded eName enum -> liftEither $ do+ enums' <-+ M.alterF+ ( \case+ Nothing -> Right (Just enum)+ Just existing -> Left (InvalidEdit edit (EnumAlreadyExist eName existing))+ )+ eName+ (schemaEnumerations s)+ pure $ s {schemaEnumerations = enums'}+ EnumTypeRemoved eName ->+ withExistingEnum eName edit s (removeEnum edit s eName)+ EnumTypeValueAdded eName addedValue insOrder insPoint ->+ withExistingEnum eName edit s (addValueToEnum edit eName addedValue insOrder insPoint)+ SequenceAdded sName seqq -> liftEither $ do+ seqs' <-+ M.alterF+ ( \case+ Nothing -> Right (Just seqq)+ Just existing -> Left (InvalidEdit edit (SequenceAlreadyExist sName existing))+ )+ sName+ (schemaSequences s)+ pure $ s {schemaSequences = seqs'}+ SequenceRemoved sName ->+ withExistingSequence sName edit s (removeSequence edit s sName)+ EditAction_Manual ea -> case ea of+ ColumnRenamed tName oldName newName -> withExistingTable tName edit s (renameColumn edit oldName newName) -- -- Various combinators for specific parts of a Schema --@@ -432,7 +436,7 @@ columns' <- M.alterF ( \case- -- Constaints are added as a separate edit step.+ -- Constraints are added as a separate edit step. Nothing -> Right (Just col {columnConstraints = mempty}) Just existing -> Left (InvalidEdit e (ColumnAlreadyExist colName existing)) )@@ -451,6 +455,32 @@ colName (tableColumns tbl) pure $ Just tbl {tableColumns = columns'}++renameColumn ::+ Edit ->+ ColumnName ->+ -- | old name+ ColumnName ->+ -- | new name+ Table ->+ Either ApplyFailed (Maybe Table)+renameColumn e oldName newName tbl = do+ let oldColumns = tableColumns tbl++ case M.lookup newName oldColumns of+ Nothing -> pure ()+ Just c -> throwError $ InvalidEdit e $ ColumnAlreadyExist newName c++ c <- case M.lookup oldName oldColumns of+ Nothing -> throwError $ InvalidEdit e $ ColumnDoesntExist oldName+ Just c -> pure c++ let+ newColumns = oldColumns+ & M.delete oldName+ & M.insert newName c++ pure $ Just $ tbl {tableColumns = newColumns} changeColumnType :: Edit ->
tests/Test/Database/Beam/AutoMigrate/Arbitrary.hs view
@@ -3,9 +3,6 @@ module Test.Database.Beam.AutoMigrate.Arbitrary where import qualified Data.Text.Lazy as TL-import Database.Beam.AutoMigrate.Schema.Gen-import Database.Beam.AutoMigrate.Types-import GHC.Generics import Test.QuickCheck import Text.Pretty.Simple (pShowNoColor)
+ util/Database/Beam/AutoMigrate/TestUtils.hs view
@@ -0,0 +1,25 @@+{-# Language OverloadedStrings #-}+module Database.Beam.AutoMigrate.TestUtils where++import Control.Exception (bracket)+import Data.Pool (withResource)+import Data.Typeable+import Database.PostgreSQL.Simple as Pg+import Gargoyle.PostgreSQL.Connect (withDb)+import Test.Tasty.Options++data ConnMethod = ConnMethod_Direct Pg.ConnectInfo | ConnMethod_Gargoyle String+ deriving (Typeable)++instance IsOption ConnMethod where+ defaultValue = ConnMethod_Direct Pg.defaultConnectInfo+ parseValue x = if null x then Nothing else Just $ ConnMethod_Gargoyle x+ optionName = "with-gargoyle"+ optionHelp = "Whether to use a gargoyle database. Supply the database name."++-- | Connect to a database using gargoyle or connect directly to an already-running+-- postgresql instance+withConnection :: ConnMethod -> (Pg.Connection -> IO a) -> IO a+withConnection c f = case c of+ ConnMethod_Gargoyle db -> withDb db $ \pool -> withResource pool $ f+ ConnMethod_Direct connInfo -> bracket (Pg.connect connInfo) Pg.close f