diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for beam-automigrate + +## 0.1.0.0 + +* Initial release. Generate schemas and migrations for beam databases. See limitations in [README.md](README.md) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,12 @@ +Copyright (c) 2015, Obsidian Systems LLC +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + +3. Neither the name of the 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. diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,438 @@ +beam-automigrate +================ +[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/beam-automigrate.svg)](https://hackage.haskell.org/package/beam-automigrate) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/beam-automigrate/badge)](https://matrix.hackage.haskell.org/#/package/beam-automigrate) [![Github CI](https://github.com/obsidiansystems/beam-automigrate/workflows/github-action/badge.svg)](https://github.com/obsidiansystems/beam-automigrate/actions) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/obsidiansystems/beam-automigrate/blob/master/LICENSE) + +Automatic migrations for [beam](https://hackage.haskell.org/package/beam-core) databases! + +![Auto-migration example animation](https://i.imgur.com/xuPyUfg.gif) + +Table of Contents +----------------- + +* [Table of Contents](#table-of-contents) +* [Getting started (User guide/reference)](#getting-started-user-guidereference) + * [Deriving an AnnotatedDatabaseSettings](#deriving-an-annotateddatabasesettings) + * [Overriding the defaults of an AnnotatedDatabaseSettings](#overriding-the-defaults-of-an-annotateddatabasesettings) + * [Deriving a Schema](#deriving-a-schema) + * [Generating an automatic migration](#generating-an-automatic-migration) +* [Current design (10_000ft overview)](#current-design-10_000ft-overview) + * [Deriving information from a DatabaseSettings](#deriving-information-from-a-databasesettings) + * [Deriving information from an AnnotatedDatabaseSettings](#deriving-information-from-an-annotateddatabasesettings) + * [What is implemented](#what-is-implemented) + * [Shortcomings and limitations](#shortcomings-and-limitations) +* [Contributors](#contributors) + +Getting started (User guide/reference) +====================================== + +This example is a literate haskell source file. You can run it interactively +with the following command: + +```bash +$ cabal repl readme +``` + +If you're using [nix](https://nixos.org/nix), you can enter a shell with the +appropriate dependencies with the following command: + +```bash +$ nix-shell release.nix -A env +``` + +From that nix-shell, you can run `cabal repl readme`. + +To run the example code, run `main` inside of the cabal repl. + +For a more examples, refer to the `examples` folder. + +Deriving an AnnotatedDatabaseSettings +------------------------------------- + +Deriving an `AnnotatedDatabaseSettings` for a Haskell database type is a matter of calling +`defaultAnnotatedDbSettings`. For example, given: + +``` haskell + +> {-# LANGUAGE DataKinds #-} +> {-# LANGUAGE DeriveGeneric #-} +> {-# LANGUAGE DeriveAnyClass #-} +> {-# LANGUAGE TypeApplications #-} +> {-# LANGUAGE TypeFamilies #-} +> import Prelude hiding ((.)) +> import Control.Category ((.)) +> import Data.Proxy (Proxy(..)) +> import Database.Beam.Postgres +> import Database.Beam.Schema +> import Database.Beam (val_) +> import qualified Database.Beam.AutoMigrate as BA +> import Database.PostgreSQL.Simple as Pg +> import Gargoyle.PostgreSQL.Connect +> import GHC.Generics +> import Data.Pool (withResource) +> import Data.Text +> +> data CitiesT f = City +> { ctCity :: Columnar f Text +> , ctLocation :: Columnar f Text +> , ctCapital :: Columnar f Bool +> } +> deriving (Generic, Beamable) +> +> data WeatherT f = Weather +> { wtId :: Columnar f Int +> , wtCity :: PrimaryKey CitiesT f +> , wtTempLo :: Columnar f Int +> , wtTempHi :: Columnar f Int +> } +> deriving (Generic, Beamable) +> +> data ForecastDB f = ForecastDB +> { dbCities :: f (TableEntity CitiesT) +> , dbWeathers :: f (TableEntity WeatherT) +> } +> deriving (Generic, Database be) +> +> instance Table CitiesT where +> data PrimaryKey CitiesT f = CityID (Columnar f Text) +> deriving (Generic, Beamable) +> primaryKey = CityID . ctCity +> +> instance Table WeatherT where +> data PrimaryKey WeatherT f = WeatherID (Columnar f Int) +> deriving (Generic, Beamable) +> primaryKey = WeatherID . wtId + +``` + +Then calling `defaultAnnotatedDbSettings` will yield: + +```haskell + +> forecastDB :: BA.AnnotatedDatabaseSettings Postgres ForecastDB +> forecastDB = BA.defaultAnnotatedDbSettings defaultDbSettings + +``` + +Where `defaultDbSettings` is the classic function from `beam-core`. + +Overriding the defaults of an `AnnotatedDatabaseSettings` +--------------------------------------------------------- + +It is likely that the end user would like to attach extra meta-information to an `AnnotatedDatabaseSettings`. +For example, the user might want to specify which is the default value for a nullable field, or simple express +things like uniqueness constraints or foreign keys (when the inference algorithm cannot proceed due to +ambiguity). To do this, we can piggyback on the familiar API from `beam-core`. For example, we can do something like this: + +```haskell + +> annotatedDB :: BA.AnnotatedDatabaseSettings Postgres ForecastDB +> annotatedDB = BA.defaultAnnotatedDbSettings defaultDbSettings `withDbModification` dbModification +> { dbCities = +> BA.annotateTableFields tableModification { ctCapital = BA.defaultsTo $ val_ False } +> <> BA.uniqueConstraintOn [BA.U ctCity, BA.U ctLocation] +> , dbWeathers = BA.annotateTableFields tableModification <> +> BA.foreignKeyOnPk (dbCities defaultDbSettings) wtCity BA.Cascade BA.Restrict +> } + +``` + +**This is where we deviate from beam-migrate.** Beam-migrate forces you to specify "annotations" for each +and every field of each and every column, making everything a bit verbose. Here we decided instead to use the +_other_ API that `beam-core` offers, that is typically used to modify the field names for a standard +`DatabaseSettings`, but it turns out its types are general enough to be used for an `AnnotatedDatabaseSettings`, +just by adding some extra functions (the ones prefixed with `BA`, the rest is the standard `beam-core` API). + +This allows us to still override defaults when we need to without all the extra boilerplate. This API and +these combinators simply manipulates under the hood the particular `TableFieldSchema` associated to each +column, so that the information contained within can be "spliced back" when we generate a `Schema` out of +an `AnnotatedDatabaseSettings`. + +Deriving a Schema +----------------- + +Once we have an `AnnotatedDatabaseSettings`, the next step is to generate a `Schema`. This can be done +simply by calling `fromAnnotatedDbSettings`, like so: + +``` +> hsSchema :: BA.Schema +> hsSchema = BA.fromAnnotatedDbSettings annotatedDB (Proxy @'[]) + +``` + +This will generate something like this: + +```haskell +Schema + { schemaTables = fromList + [ + ( TableName { tableName = "cities" } + , Table + { tableConstraints = fromList + [ PrimaryKey "cities_pkey" + ( fromList + [ ColumnName { columnName = "city" } ] + ) + ] + , tableColumns = fromList + [ + ( ColumnName { columnName = "city" } + , Column + { columnType = SqlStdType ( DataTypeChar True Nothing Nothing ) + , columnConstraints = fromList [ NotNull ] + } + ) + , + ( ColumnName { columnName = "location" } + , Column + { columnType = SqlStdType ( DataTypeChar True Nothing Nothing ) + , columnConstraints = fromList [ NotNull ] + } + ) + ] + } + ) + , + ( TableName { tableName = "weathers" } + , Table + { tableConstraints = fromList + [ PrimaryKey "weathers_pkey" + ( fromList + [ ColumnName { columnName = "id" } ] + ) + , ForeignKey "weathers_city__city_fkey" + ( TableName { tableName = "cities" } ) + ( fromList + [ + ( ColumnName { columnName = "city__city" } + , ColumnName { columnName = "city" } + ) + ] + ) NoAction NoAction + ] + , tableColumns = fromList + [ + ( ColumnName { columnName = "city__city" } + , Column + { columnType = SqlStdType ( DataTypeChar True Nothing Nothing ) + , columnConstraints = fromList [ NotNull ] + } + ) + , + ( ColumnName { columnName = "id" } + , Column + { columnType = SqlStdType DataTypeInteger + , columnConstraints = fromList [ NotNull ] + } + ) + , + ( ColumnName { columnName = "temp_hi" } + , Column + { columnType = SqlStdType DataTypeInteger + , columnConstraints = fromList [ NotNull ] + } + ) + , + ( ColumnName { columnName = "temp_lo" } + , Column + { columnType = SqlStdType DataTypeInteger + , columnConstraints = fromList [ NotNull ] + } + ) + ] + } + ) + ] + , schemaEnumerations = fromList [] + } +``` + +Notable things to notice: + +* Foreign keys have been automatically inferred; +* Each column is mapped to a sensible SQL datatype; +* Non `Maybe/Nullable` types have a `NotNull` constraint added; + +Generating an automatic migration +--------------------------------- + +Once a `Schema` has been generated, in order to automatically migrate your schema, it is sufficient to write +something like this: + +```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 +> +> exampleAutoMigration :: IO () +> exampleAutoMigration = readmeDbTransaction $ \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" +> + +``` + +The `exampleAutoMigration` function will try to generate another `Schema`, this time from the Postgres database and +the two `Schema`s will be "diffed together" in order to compute the list of edits necessary to migrate from +the DB to the Haskell database. To begin with, we can call `exampleShowMigration` to "preview" the full +SQL command that will be run: + +``` +Ok, 12 modules loaded. +-> import Database.Beam.Migrate.Example.ForeignKeys +-> exampleShowMigration +CREATE TABLE "cities" (city VARCHAR NOT NULL, location VARCHAR NOT NULL); + +CREATE TABLE "weathers" (city__city VARCHAR NOT NULL, id INT NOT NULL, temp_hi INT NOT NULL, temp_lo INT NOT NULL); + +ALTER TABLE "cities" ADD CONSTRAINT "cities_pkey" PRIMARY KEY (city); + +ALTER TABLE "weathers" ADD CONSTRAINT "weathers_pkey" PRIMARY KEY (id); + +ALTER TABLE "weathers" ADD CONSTRAINT "weathers_city__city_fkey" FOREIGN KEY (city__city) REFERENCES "cities"(city); + +``` + +Once we are satisfied with visual inspection, we can run it via `exampleAutoMigration`. If all is well, we +can now check how the DB has been migrated. If we try to call `exampleShowMigration` again, no output should +be shown, because the DB is now up-to-date with the Haskell types. + +Current design (10_000ft overview) +================================== + +Beam itself provides a `DatabaseSettings` type. A value of this type is typically derived generically from +the Haskell datatypes representing the database schema, but can be amended. The primary purpose of +`DatabaseSettings` is to provide a mapping between Haskell names for tables and columns and the corresponding +DB-side names. + +On top of this, we provide an `AnnotatedDatabaseSettings` type. This is similar in spirit to the +`CheckedDatabaseSettings` provided by the original `beam-migrate`, but a bit simpler. On top of `DatabaseSettings`, +the `AnnotatedDatabaseSettings` contain additional information, in particular constraints that tables and +columns must satisfy. Once again, a value of this type can be derived generically, but the information +can be amended. + +Both `DatabaseSettings` and `AnnotatedDatabaseSettings` follow the structure of the Haskell datatypes +comprising the schema, and are therefore quite strongly typed. + +From an `AnnotatedDatabaseSettings` value, we can internally derive a `Schema`. This is a straightforward +representation of a DB schema without any type-level magic. + +We can similarly generate a `Schema` value for the DB schema currently stored in the database. We can then +diff the two `Schema`s to get a `Diff` which determines a list of `Edit`s. Such edits can be applied in a +particular (prioritised) order to migrate the DB schema to the Haskell schema. + +There are two important stages in the library, the first one being when we call `defaultAnnotatedDbSettings` +and the second one when we call `fromAnnotatedDbSettings`. The first function converts from a `DatabaseSettings` +into an `AnnotatedDatabaseSettings` whereas the latter convert from an `AnnotatedDatabaseSettings` into a +`Schema`. Both uses generic-derivation but in a different way and for different purposes. + +Deriving information from a DatabaseSettings +-------------------------------------------- + +During this phase we "zip" all the tables together and we essentially convert each `DatabaseEntity` into an +`AnnotatedDatabaseEntity`. The latter is ever so slightly similar to the former but crucially it embeds extra +information. One way to see this is that exactly as a `DatabaseEntity` carry around a `TableSettings` which +carries meta-information on the naming of each particular column for each table, an `AnnotatedDatabaseEntity` +carries what's called a `TableSchema`, which is defined as: + +```haskell +-- | A table schema. +type TableSchema tbl = + tbl (TableFieldSchema tbl) + +-- | A schema for a field within a given table +data TableFieldSchema (tbl :: (* -> *) -> *) ty where + TableFieldSchema + :: + { tableFieldName :: Text + , tableFieldSchema :: FieldSchema ty } + -> TableFieldSchema tbl ty + +data FieldSchema ty where + FieldSchema :: ColumnType + -> Set ColumnConstraint + -> FieldSchema ty +``` + +Looking at this, the similarity with a `TableSettings` is quite obvious: + +```haskell +type TableSettings tbl = tbl (TableField tbl) +``` + +Here is where the second generic-derivation algorithm comes in, and it "maps" each `TableField` with a new +`TableFieldSchema`, which is initialised with "stock" default values for the `ColumnType` +and `Set ColumnConstraint`. There values are automatically inferred thanks to the `HasDefaultSqlDataType` and +`HasSchemaConstraints` typeclasses defined over at `Database.Beam.Migrate.Compat`. **This gives us a concrete +anchor point for the user to further annotate the database and override each individual table & column with +extra information.** + +This is described later on in the "Overriding the defaults of an `AnnotatedDatabaseSettings`" section. + +Deriving information from an AnnotatedDatabaseSettings +------------------------------------------------------ + +This is the phase where we traverse the generic representation of an `AnnotatedDatabaseSettings` in order to +infer the `Schema`. It is **during this phase that we try to discover Foreign keys**. + +Foreign key discovery can fail statically. If foreign key discovery fails, one should have the possibility +to override `AnnotatedDatabaseSettings` before running the transformation to `Schema` to manually provide the +necessary hints. + +What is implemented +------------------- + +- [x] Support for JSON, JSONB and Range types; +- [x] Support for automatically inferring FKs (if unambiguous); +- [x] Support for annotating tables and fields via the standard, familiar `beam-core` API + (e.g. add a table/column constraint); +- [x] Support for running a migration to mutate the database; + +Shortcomings and limitations +---------------------------- + +- [ ] Deriving a particular instance using `deriving via` could hamper `Schema` discovery. For example + let's imagine we have: + +```haskell +data Foo = Bar | Baz deriving HasDefaultSqlDataType via (DbEnum Foo) + +data MyTable f = MyTable { + myTableFoo :: Columnar f Foo +} +``` + +This won't correctly infer `Foo` is a `DbEnum`, at the moment, as this information is derived directly from +the types of each individual columns. + +- [ ] There is no support yet for specifying FKs in case the discovery algorithm fails due to ambiguity; +- [ ] There is no support yet for manual migrations; +- [ ] There is no support/design for "composable databases"; +- [ ] Some parts of the library are Pg-specific. + +Contributors +============ + +This library was originally written for [Obsidian Systems](https://obsidian.systems) by Alfredo Di Napoli and Andres Löh of [Well-Typed](https://www.well-typed.com/). Other contributors include Dan Bornside, Sean Chalmers, Ryan Trinkle, and Ali Abrar of Obsidian Systems. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,438 @@ +beam-automigrate +================ +[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/beam-automigrate.svg)](https://hackage.haskell.org/package/beam-automigrate) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/beam-automigrate/badge)](https://matrix.hackage.haskell.org/#/package/beam-automigrate) [![Github CI](https://github.com/obsidiansystems/beam-automigrate/workflows/github-action/badge.svg)](https://github.com/obsidiansystems/beam-automigrate/actions) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/obsidiansystems/beam-automigrate/blob/master/LICENSE) + +Automatic migrations for [beam](https://hackage.haskell.org/package/beam-core) databases! + +![Auto-migration example animation](https://i.imgur.com/xuPyUfg.gif) + +Table of Contents +----------------- + +* [Table of Contents](#table-of-contents) +* [Getting started (User guide/reference)](#getting-started-user-guidereference) + * [Deriving an AnnotatedDatabaseSettings](#deriving-an-annotateddatabasesettings) + * [Overriding the defaults of an AnnotatedDatabaseSettings](#overriding-the-defaults-of-an-annotateddatabasesettings) + * [Deriving a Schema](#deriving-a-schema) + * [Generating an automatic migration](#generating-an-automatic-migration) +* [Current design (10_000ft overview)](#current-design-10_000ft-overview) + * [Deriving information from a DatabaseSettings](#deriving-information-from-a-databasesettings) + * [Deriving information from an AnnotatedDatabaseSettings](#deriving-information-from-an-annotateddatabasesettings) + * [What is implemented](#what-is-implemented) + * [Shortcomings and limitations](#shortcomings-and-limitations) +* [Contributors](#contributors) + +Getting started (User guide/reference) +====================================== + +This example is a literate haskell source file. You can run it interactively +with the following command: + +```bash +$ cabal repl readme +``` + +If you're using [nix](https://nixos.org/nix), you can enter a shell with the +appropriate dependencies with the following command: + +```bash +$ nix-shell release.nix -A env +``` + +From that nix-shell, you can run `cabal repl readme`. + +To run the example code, run `main` inside of the cabal repl. + +For a more examples, refer to the `examples` folder. + +Deriving an AnnotatedDatabaseSettings +------------------------------------- + +Deriving an `AnnotatedDatabaseSettings` for a Haskell database type is a matter of calling +`defaultAnnotatedDbSettings`. For example, given: + +``` haskell + +> {-# LANGUAGE DataKinds #-} +> {-# LANGUAGE DeriveGeneric #-} +> {-# LANGUAGE DeriveAnyClass #-} +> {-# LANGUAGE TypeApplications #-} +> {-# LANGUAGE TypeFamilies #-} +> import Prelude hiding ((.)) +> import Control.Category ((.)) +> import Data.Proxy (Proxy(..)) +> import Database.Beam.Postgres +> import Database.Beam.Schema +> import Database.Beam (val_) +> import qualified Database.Beam.AutoMigrate as BA +> import Database.PostgreSQL.Simple as Pg +> import Gargoyle.PostgreSQL.Connect +> import GHC.Generics +> import Data.Pool (withResource) +> import Data.Text +> +> data CitiesT f = City +> { ctCity :: Columnar f Text +> , ctLocation :: Columnar f Text +> , ctCapital :: Columnar f Bool +> } +> deriving (Generic, Beamable) +> +> data WeatherT f = Weather +> { wtId :: Columnar f Int +> , wtCity :: PrimaryKey CitiesT f +> , wtTempLo :: Columnar f Int +> , wtTempHi :: Columnar f Int +> } +> deriving (Generic, Beamable) +> +> data ForecastDB f = ForecastDB +> { dbCities :: f (TableEntity CitiesT) +> , dbWeathers :: f (TableEntity WeatherT) +> } +> deriving (Generic, Database be) +> +> instance Table CitiesT where +> data PrimaryKey CitiesT f = CityID (Columnar f Text) +> deriving (Generic, Beamable) +> primaryKey = CityID . ctCity +> +> instance Table WeatherT where +> data PrimaryKey WeatherT f = WeatherID (Columnar f Int) +> deriving (Generic, Beamable) +> primaryKey = WeatherID . wtId + +``` + +Then calling `defaultAnnotatedDbSettings` will yield: + +```haskell + +> forecastDB :: BA.AnnotatedDatabaseSettings Postgres ForecastDB +> forecastDB = BA.defaultAnnotatedDbSettings defaultDbSettings + +``` + +Where `defaultDbSettings` is the classic function from `beam-core`. + +Overriding the defaults of an `AnnotatedDatabaseSettings` +--------------------------------------------------------- + +It is likely that the end user would like to attach extra meta-information to an `AnnotatedDatabaseSettings`. +For example, the user might want to specify which is the default value for a nullable field, or simple express +things like uniqueness constraints or foreign keys (when the inference algorithm cannot proceed due to +ambiguity). To do this, we can piggyback on the familiar API from `beam-core`. For example, we can do something like this: + +```haskell + +> annotatedDB :: BA.AnnotatedDatabaseSettings Postgres ForecastDB +> annotatedDB = BA.defaultAnnotatedDbSettings defaultDbSettings `withDbModification` dbModification +> { dbCities = +> BA.annotateTableFields tableModification { ctCapital = BA.defaultsTo $ val_ False } +> <> BA.uniqueConstraintOn [BA.U ctCity, BA.U ctLocation] +> , dbWeathers = BA.annotateTableFields tableModification <> +> BA.foreignKeyOnPk (dbCities defaultDbSettings) wtCity BA.Cascade BA.Restrict +> } + +``` + +**This is where we deviate from beam-migrate.** Beam-migrate forces you to specify "annotations" for each +and every field of each and every column, making everything a bit verbose. Here we decided instead to use the +_other_ API that `beam-core` offers, that is typically used to modify the field names for a standard +`DatabaseSettings`, but it turns out its types are general enough to be used for an `AnnotatedDatabaseSettings`, +just by adding some extra functions (the ones prefixed with `BA`, the rest is the standard `beam-core` API). + +This allows us to still override defaults when we need to without all the extra boilerplate. This API and +these combinators simply manipulates under the hood the particular `TableFieldSchema` associated to each +column, so that the information contained within can be "spliced back" when we generate a `Schema` out of +an `AnnotatedDatabaseSettings`. + +Deriving a Schema +----------------- + +Once we have an `AnnotatedDatabaseSettings`, the next step is to generate a `Schema`. This can be done +simply by calling `fromAnnotatedDbSettings`, like so: + +``` +> hsSchema :: BA.Schema +> hsSchema = BA.fromAnnotatedDbSettings annotatedDB (Proxy @'[]) + +``` + +This will generate something like this: + +```haskell +Schema + { schemaTables = fromList + [ + ( TableName { tableName = "cities" } + , Table + { tableConstraints = fromList + [ PrimaryKey "cities_pkey" + ( fromList + [ ColumnName { columnName = "city" } ] + ) + ] + , tableColumns = fromList + [ + ( ColumnName { columnName = "city" } + , Column + { columnType = SqlStdType ( DataTypeChar True Nothing Nothing ) + , columnConstraints = fromList [ NotNull ] + } + ) + , + ( ColumnName { columnName = "location" } + , Column + { columnType = SqlStdType ( DataTypeChar True Nothing Nothing ) + , columnConstraints = fromList [ NotNull ] + } + ) + ] + } + ) + , + ( TableName { tableName = "weathers" } + , Table + { tableConstraints = fromList + [ PrimaryKey "weathers_pkey" + ( fromList + [ ColumnName { columnName = "id" } ] + ) + , ForeignKey "weathers_city__city_fkey" + ( TableName { tableName = "cities" } ) + ( fromList + [ + ( ColumnName { columnName = "city__city" } + , ColumnName { columnName = "city" } + ) + ] + ) NoAction NoAction + ] + , tableColumns = fromList + [ + ( ColumnName { columnName = "city__city" } + , Column + { columnType = SqlStdType ( DataTypeChar True Nothing Nothing ) + , columnConstraints = fromList [ NotNull ] + } + ) + , + ( ColumnName { columnName = "id" } + , Column + { columnType = SqlStdType DataTypeInteger + , columnConstraints = fromList [ NotNull ] + } + ) + , + ( ColumnName { columnName = "temp_hi" } + , Column + { columnType = SqlStdType DataTypeInteger + , columnConstraints = fromList [ NotNull ] + } + ) + , + ( ColumnName { columnName = "temp_lo" } + , Column + { columnType = SqlStdType DataTypeInteger + , columnConstraints = fromList [ NotNull ] + } + ) + ] + } + ) + ] + , schemaEnumerations = fromList [] + } +``` + +Notable things to notice: + +* Foreign keys have been automatically inferred; +* Each column is mapped to a sensible SQL datatype; +* Non `Maybe/Nullable` types have a `NotNull` constraint added; + +Generating an automatic migration +--------------------------------- + +Once a `Schema` has been generated, in order to automatically migrate your schema, it is sufficient to write +something like this: + +```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 +> +> exampleAutoMigration :: IO () +> exampleAutoMigration = readmeDbTransaction $ \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" +> + +``` + +The `exampleAutoMigration` function will try to generate another `Schema`, this time from the Postgres database and +the two `Schema`s will be "diffed together" in order to compute the list of edits necessary to migrate from +the DB to the Haskell database. To begin with, we can call `exampleShowMigration` to "preview" the full +SQL command that will be run: + +``` +Ok, 12 modules loaded. +-> import Database.Beam.Migrate.Example.ForeignKeys +-> exampleShowMigration +CREATE TABLE "cities" (city VARCHAR NOT NULL, location VARCHAR NOT NULL); + +CREATE TABLE "weathers" (city__city VARCHAR NOT NULL, id INT NOT NULL, temp_hi INT NOT NULL, temp_lo INT NOT NULL); + +ALTER TABLE "cities" ADD CONSTRAINT "cities_pkey" PRIMARY KEY (city); + +ALTER TABLE "weathers" ADD CONSTRAINT "weathers_pkey" PRIMARY KEY (id); + +ALTER TABLE "weathers" ADD CONSTRAINT "weathers_city__city_fkey" FOREIGN KEY (city__city) REFERENCES "cities"(city); + +``` + +Once we are satisfied with visual inspection, we can run it via `exampleAutoMigration`. If all is well, we +can now check how the DB has been migrated. If we try to call `exampleShowMigration` again, no output should +be shown, because the DB is now up-to-date with the Haskell types. + +Current design (10_000ft overview) +================================== + +Beam itself provides a `DatabaseSettings` type. A value of this type is typically derived generically from +the Haskell datatypes representing the database schema, but can be amended. The primary purpose of +`DatabaseSettings` is to provide a mapping between Haskell names for tables and columns and the corresponding +DB-side names. + +On top of this, we provide an `AnnotatedDatabaseSettings` type. This is similar in spirit to the +`CheckedDatabaseSettings` provided by the original `beam-migrate`, but a bit simpler. On top of `DatabaseSettings`, +the `AnnotatedDatabaseSettings` contain additional information, in particular constraints that tables and +columns must satisfy. Once again, a value of this type can be derived generically, but the information +can be amended. + +Both `DatabaseSettings` and `AnnotatedDatabaseSettings` follow the structure of the Haskell datatypes +comprising the schema, and are therefore quite strongly typed. + +From an `AnnotatedDatabaseSettings` value, we can internally derive a `Schema`. This is a straightforward +representation of a DB schema without any type-level magic. + +We can similarly generate a `Schema` value for the DB schema currently stored in the database. We can then +diff the two `Schema`s to get a `Diff` which determines a list of `Edit`s. Such edits can be applied in a +particular (prioritised) order to migrate the DB schema to the Haskell schema. + +There are two important stages in the library, the first one being when we call `defaultAnnotatedDbSettings` +and the second one when we call `fromAnnotatedDbSettings`. The first function converts from a `DatabaseSettings` +into an `AnnotatedDatabaseSettings` whereas the latter convert from an `AnnotatedDatabaseSettings` into a +`Schema`. Both uses generic-derivation but in a different way and for different purposes. + +Deriving information from a DatabaseSettings +-------------------------------------------- + +During this phase we "zip" all the tables together and we essentially convert each `DatabaseEntity` into an +`AnnotatedDatabaseEntity`. The latter is ever so slightly similar to the former but crucially it embeds extra +information. One way to see this is that exactly as a `DatabaseEntity` carry around a `TableSettings` which +carries meta-information on the naming of each particular column for each table, an `AnnotatedDatabaseEntity` +carries what's called a `TableSchema`, which is defined as: + +```haskell +-- | A table schema. +type TableSchema tbl = + tbl (TableFieldSchema tbl) + +-- | A schema for a field within a given table +data TableFieldSchema (tbl :: (* -> *) -> *) ty where + TableFieldSchema + :: + { tableFieldName :: Text + , tableFieldSchema :: FieldSchema ty } + -> TableFieldSchema tbl ty + +data FieldSchema ty where + FieldSchema :: ColumnType + -> Set ColumnConstraint + -> FieldSchema ty +``` + +Looking at this, the similarity with a `TableSettings` is quite obvious: + +```haskell +type TableSettings tbl = tbl (TableField tbl) +``` + +Here is where the second generic-derivation algorithm comes in, and it "maps" each `TableField` with a new +`TableFieldSchema`, which is initialised with "stock" default values for the `ColumnType` +and `Set ColumnConstraint`. There values are automatically inferred thanks to the `HasDefaultSqlDataType` and +`HasSchemaConstraints` typeclasses defined over at `Database.Beam.Migrate.Compat`. **This gives us a concrete +anchor point for the user to further annotate the database and override each individual table & column with +extra information.** + +This is described later on in the "Overriding the defaults of an `AnnotatedDatabaseSettings`" section. + +Deriving information from an AnnotatedDatabaseSettings +------------------------------------------------------ + +This is the phase where we traverse the generic representation of an `AnnotatedDatabaseSettings` in order to +infer the `Schema`. It is **during this phase that we try to discover Foreign keys**. + +Foreign key discovery can fail statically. If foreign key discovery fails, one should have the possibility +to override `AnnotatedDatabaseSettings` before running the transformation to `Schema` to manually provide the +necessary hints. + +What is implemented +------------------- + +- [x] Support for JSON, JSONB and Range types; +- [x] Support for automatically inferring FKs (if unambiguous); +- [x] Support for annotating tables and fields via the standard, familiar `beam-core` API + (e.g. add a table/column constraint); +- [x] Support for running a migration to mutate the database; + +Shortcomings and limitations +---------------------------- + +- [ ] Deriving a particular instance using `deriving via` could hamper `Schema` discovery. For example + let's imagine we have: + +```haskell +data Foo = Bar | Baz deriving HasDefaultSqlDataType via (DbEnum Foo) + +data MyTable f = MyTable { + myTableFoo :: Columnar f Foo +} +``` + +This won't correctly infer `Foo` is a `DbEnum`, at the moment, as this information is derived directly from +the types of each individual columns. + +- [ ] There is no support yet for specifying FKs in case the discovery algorithm fails due to ambiguity; +- [ ] There is no support yet for manual migrations; +- [ ] There is no support/design for "composable databases"; +- [ ] Some parts of the library are Pg-specific. + +Contributors +============ + +This library was originally written for [Obsidian Systems](https://obsidian.systems) by Alfredo Di Napoli and Andres Löh of [Well-Typed](https://www.well-typed.com/). Other contributors include Dan Bornside, Sean Chalmers, Ryan Trinkle, and Ali Abrar of Obsidian Systems. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/beam-automigrate.cabal b/beam-automigrate.cabal new file mode 100644 --- /dev/null +++ b/beam-automigrate.cabal @@ -0,0 +1,229 @@ +name: beam-automigrate +version: 0.1.0.0 +license-file: LICENSE +build-type: Simple +cabal-version: >=1.10 +author: Alfredo Di Napoli, Andres Löh, Well-Typed LLP, and Obsidian Systems LLC +copyright: 2020 Obsidian Systems LLC +maintainer: maintainer@obsidian.systems +category: Database +license: BSD3 +license-file: LICENSE +bug-reports: https://github.com/obsidiansystems/beam-automigrate/issues +synopsis: DB migration library for beam, targeting Postgres. +description: + This package offers an alternative to @@ + and can be used to migrate a database between different versions of a Haskell schema. It doesn't depend + on @beam-migrate@ if not transitively (@beam-postgres@ depends on it, for example). + . + <> + +extra-source-files: + README.md + CHANGELOG.md + +library + exposed-modules: + Database.Beam.AutoMigrate + Database.Beam.AutoMigrate.Annotated + Database.Beam.AutoMigrate.BenchUtil + Database.Beam.AutoMigrate.Compat + Database.Beam.AutoMigrate.Diff + Database.Beam.AutoMigrate.Generic + Database.Beam.AutoMigrate.Postgres + Database.Beam.AutoMigrate.Schema.Gen + Database.Beam.AutoMigrate.Types + Database.Beam.AutoMigrate.Util + Database.Beam.AutoMigrate.Validity + + hs-source-dirs: src + build-depends: + aeson >=1.4.4 && <1.5 + , 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 + , 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 && <2.3 + , QuickCheck >=2.13 && <2.15 + , quickcheck-instances >=0.3 && <0.4 + , scientific >=0.3.6 && <0.5 + , splitmix >=0.0.3 && <0.1 + , string-conv >=0.1.2 && <0.3 + , text >=1.2.0.0 && <1.3.0.0 + , time >=1.8.0 && <1.9 + , transformers >=0.5.6 && <0.7 + , uuid >=1.3 && <1.4 + , vector >=0.12.0.3 && <0.13.0.0 + + default-language: Haskell2010 + default-extensions: + DataKinds + FlexibleInstances + GADTs + KindSignatures + LambdaCase + MultiParamTypeClasses + OverloadedStrings + ScopedTypeVariables + TypeApplications + TypeFamilies + + ghc-options: -Wall + + if flag(werror) + ghc-options: -Werror + +test-suite beam-automigrate-tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Main.hs + other-modules: Test.Database.Beam.AutoMigrate.Arbitrary + build-depends: + base + , beam-automigrate + , containers + , pretty-simple + , QuickCheck + , tasty + , tasty-quickcheck + , text + + default-language: Haskell2010 + default-extensions: OverloadedStrings + +test-suite beam-automigrate-integration-tests + type: exitcode-stdio-1.0 + hs-source-dirs: integration-tests tests + main-is: Main.hs + other-modules: Test.Database.Beam.AutoMigrate.Arbitrary + build-depends: + base + , beam-automigrate + , containers + , postgresql-simple + , pretty-simple + , QuickCheck + , tasty + , tasty-quickcheck + , text + , tmp-postgres >=1.31.0.1 && <1.35.0.0 + + 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 + other-modules: + Example + ForeignKeys + -- SubDatabases -- Sub-database support hasn't been added to beam yet. See https://github.com/adinapoli/beam/commit/a00ea815e74aea666af840dbe75571b8165ca506 + + build-depends: + aeson + , base + , beam-automigrate + , beam-core + , beam-postgres + , bytestring + , postgresql-simple + , text + , time + + default-language: Haskell2010 + default-extensions: + DataKinds + DeriveGeneric + FlexibleContexts + FlexibleInstances + MultiParamTypeClasses + OverloadedStrings + StandaloneDeriving + TypeApplications + TypeFamilies + + ghc-options: -Wall -O2 -rtsopts + + if flag(werror) + ghc-options: -Werror + + if flag(ghcipretty) + build-depends: pretty-simple + +executable beam-automigrate-large-migration-test + hs-source-dirs: large-migration-test + main-is: Main.hs + build-depends: + base + , beam-automigrate + , beam-postgres + , containers + , postgresql-simple + , time + + default-language: Haskell2010 + default-extensions: OverloadedStrings + ghc-options: -Wall -O2 -rtsopts + +benchmark beam-automigrate-bench + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Main.hs + build-depends: + base + , beam-automigrate + , beam-postgres + , bytestring + , containers + , criterion + , deepseq + , postgresql-simple + , QuickCheck + , splitmix + + default-language: Haskell2010 + ghc-options: -Wall -O2 -rtsopts + +executable readme + build-depends: + base + , beam-automigrate + , beam-core + , beam-postgres + , gargoyle-postgresql-connect + , postgresql-simple + , resource-pool + , text + default-language: Haskell2010 + main-is: README.lhs + ghc-options: -Wall -optL -q + +flag werror + description: Enable -Werror during development + default: False + manual: True + +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 + +source-repository head + type: git + location: https://github.com/obsidiansystems/beam-automigrate diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Exception (bracket) +import Control.Monad.IO.Class (liftIO) +import Criterion.Main +import qualified Data.Map.Strict as M +import Database.Beam.Migrate.New +import Database.Beam.Migrate.New.BenchUtil +import Database.Beam.Migrate.New.Postgres (getSchema) +import Database.Beam.Postgres (runBeamPostgres) +import qualified Database.PostgreSQL.Simple as Pg + +pgMigrate :: Pg.Connection -> (Schema -> Schema -> Diff) -> Schema -> IO SpineStrict +pgMigrate conn diffFun hsSchema = + Pg.withTransaction conn $ + runBeamPostgres conn $ do + dbSchema <- liftIO (getSchema conn) + pure . SS $ diffFun hsSchema dbSchema + +main :: IO () +main = do + putStrLn "Generating schema with 10_000 tables ..." + (hsSchema, dbSchema) <- predictableSchemas 10000 + putStrLn $ "Generated schema with " ++ show (M.size . schemaTables $ hsSchema) ++ " tables." + bracket (setupDatabase dbSchema) tearDownDatabase $ \pgConn -> + defaultMain + [ bgroup + "diff" + [ bench "reference/10_000 tables avg. case (similar schema)" $ nf (SS . diffReferenceImplementation hsSchema) dbSchema, + bench "efficient/10_000 tables avg. case (similar schema)" $ nf (SS . diff hsSchema) dbSchema, + bench "reference/10_000 tables worst case (no schema)" $ nf (SS . diffReferenceImplementation hsSchema) noSchema, + bench "efficient/10_000 tables worst case (no schema)" $ nf (SS . diff hsSchema) noSchema + ], + bgroup + "getSchema" + [ bench "10_000 tables" $ nfIO (getSchema pgConn) + ], + bgroup + "full_migration" + [ bench "reference/10_000 tables avg. case (similar schema)" $ nfIO (pgMigrate pgConn diffReferenceImplementation hsSchema), + bench "efficient/10_000 tables avg. case (similar schema)" $ nfIO (pgMigrate pgConn diff hsSchema), + bench "reference/10_000 tables worst case (no previous schema)" $ nfIO (pgMigrate pgConn diffReferenceImplementation hsSchema), + bench "efficient/10_000 tables worst case (no previous schema)" $ nfIO (pgMigrate pgConn diff hsSchema) + ] + ] diff --git a/examples/Example.hs b/examples/Example.hs new file mode 100644 --- /dev/null +++ b/examples/Example.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Example where + +import Control.Exception +import Data.Aeson.TH +import Data.ByteString (ByteString) +import Data.Int (Int32, Int64) +import Data.Proxy +import Data.Text (Text) +import Data.Time (LocalTime) +import Database.Beam.AutoMigrate + ( DbEnum, + Diff, + HasColumnType, + Migration, + PgEnum, + ReferenceAction (..), + Schema, + defaultAnnotatedDbSettings, + diff, + fromAnnotatedDbSettings, + migrate, + printMigration, + unsafeRunMigration, + ) +import Database.Beam.AutoMigrate.Annotated +import Database.Beam.AutoMigrate.Postgres (getSchema) +import Database.Beam.Backend.SQL.Types (SqlSerial (..)) +import Database.Beam.Postgres +import qualified Database.Beam.Postgres as Pg +import Database.Beam.Query (currentTimestamp_, val_) +import Database.Beam.Schema + ( Beamable, + Columnar, + Database, + DatabaseSettings, + PrimaryKey, + TableEntity, + dbModification, + defaultDbSettings, + fieldNamed, + modifyTableFields, + tableModification, + withDbModification, + ) +import qualified Database.Beam.Schema as Beam +import Database.Beam.Schema.Tables (primaryKey) +import qualified Database.PostgreSQL.Simple as Pg +import GHC.Generics + +-- +-- Example +-- + +data MyJson = MyJson + { foo :: Int, + bar :: Maybe Bool, + quux :: Text + } + +deriveJSON defaultOptions ''MyJson + +data FlowerType + = Rose + | Sunflower + | Tulip + deriving (Show, Enum, Bounded) + +data Foo + = Bar + | Baz + | Quux + deriving (Show, Enum, Bounded) + deriving (HasColumnType) via (PgEnum Foo) + +-- A mixin embedded into another (i.e. 'Address'). +data AddressRegion f = AddressRegion + { addressState :: Columnar f (Maybe Text), + addressCountry :: Columnar f (Maybe Text), + addressPostalCode :: Columnar f (Maybe Text) + } + deriving (Generic, Beamable) + +data Address f = Address + { address :: Columnar f (Maybe Text), + addressCity :: Columnar f (Maybe Text), + addressRegion :: AddressRegion f + } + deriving (Generic, Beamable) + +data FlowerT f = Flower + { flowerID :: Columnar f Int32, + flowerName :: Columnar f Text, + flowerInternalID :: Columnar f (SqlSerial Int), + flowerPrice :: Columnar (Beam.Nullable f) Double, + flowerDiscounted :: Columnar f (Maybe Bool), + flowerSchemaOne :: Columnar f (PgJSON MyJson), + flowerSchemaTwo :: Columnar f (PgJSONB MyJson), + flowerType :: Columnar f (DbEnum FlowerType), + flowerPgType :: Columnar f Foo, + flowerAddress :: Address f + } + deriving (Generic, Beamable) + +data OrderT f = Order + { orderID :: Columnar f (SqlSerial Int64), + orderTime :: Columnar f LocalTime, + orderFlowerIdRef :: PrimaryKey FlowerT f, + orderValidity :: Columnar f (Pg.PgRange Pg.PgInt8Range Int64), + orderAddress :: Address f, + orderLineItemRef :: PrimaryKey LineItemT f + } + deriving (Generic, Beamable) + +data LineItemT f = LineItem + { lineItemOrderID :: PrimaryKey OrderT f, + lineItemFlowerID :: PrimaryKey FlowerT f, + lineItemQuantity :: Columnar f Int64, + lineItemDiscount :: Columnar f (Maybe Bool), + lineItemBytearray :: Columnar f ByteString, + lineItemNullableRef :: PrimaryKey OrderT (Beam.Nullable f) + } + deriving (Generic, Beamable) + +data LineItemTwoT f = LineItemTwo + { lineItemTwoID :: Columnar f Int64, + lineItemTwoFk :: PrimaryKey LineItemT f + } + deriving (Generic, Beamable) + +data FlowerDB f = FlowerDB + { dbFlowers :: f (TableEntity FlowerT), + dbOrders :: f (TableEntity OrderT), + dbOrders2 :: f (TableEntity OrderT), + dbLineItems :: f (TableEntity LineItemT), + dbLineItemsTwo :: f (TableEntity LineItemTwoT) + } + deriving (Generic, Database be) + +instance Beam.Table FlowerT where + data PrimaryKey FlowerT f = FlowerID (Columnar f Int32) + deriving (Generic, Beamable) + primaryKey = FlowerID . flowerID + +instance Beam.Table OrderT where + data PrimaryKey OrderT f = OrderID (Columnar f (SqlSerial Int64)) + deriving (Generic, Beamable) + primaryKey = OrderID . orderID + +instance Beam.Table LineItemT where + data PrimaryKey LineItemT f + = LineItemID (PrimaryKey OrderT f) (PrimaryKey FlowerT f) + deriving (Generic, Beamable) + primaryKey = LineItemID <$> lineItemOrderID <*> lineItemFlowerID + +instance Beam.Table LineItemTwoT where + data PrimaryKey LineItemTwoT f = LineItemTwoID (Columnar f Int64) + deriving (Generic, Beamable) + primaryKey = LineItemTwoID <$> lineItemTwoID + +-- Modify the field names to be compliant with William Yao's format. +flowerDB :: DatabaseSettings Postgres FlowerDB +flowerDB = + defaultDbSettings + `withDbModification` dbModification + { dbFlowers = modifyTableFields tableModification {flowerID = fieldNamed "id"}, + dbOrders = + modifyTableFields + tableModification + { orderID = fieldNamed "id", + orderTime = fieldNamed "order_time" + }, + dbLineItems = + modifyTableFields + tableModification + { lineItemFlowerID = FlowerID "flower_id", + lineItemOrderID = OrderID "order_id", + lineItemQuantity = fieldNamed "quantity", + lineItemNullableRef = + OrderID "external_nullable_ref" + } + } + +annotatedDB :: AnnotatedDatabaseSettings Postgres FlowerDB +annotatedDB = + defaultAnnotatedDbSettings flowerDB + `withDbModification` dbModification + { dbFlowers = + annotateTableFields tableModification {flowerDiscounted = defaultsTo (val_ $ Just True)} + <> annotateTableFields tableModification {flowerPrice = defaultsTo (val_ $ Just 10.0)} + <> uniqueConstraintOn [U (addressPostalCode . addressRegion . flowerAddress)], + dbLineItems = + annotateTableFields tableModification {lineItemDiscount = defaultsTo (val_ $ Just False)} + <> uniqueConstraintOn [U lineItemFlowerID, U lineItemOrderID, U lineItemQuantity], + dbOrders = + annotateTableFields + tableModification + { orderTime = defaultsTo currentTimestamp_, + orderValidity = defaultsTo (range_ Inclusive Inclusive (val_ $ Just 10) (val_ $ Just 20)) + } + <> foreignKeyOnPk (dbFlowers flowerDB) orderFlowerIdRef Cascade Restrict + <> uniqueConstraintOn [U (addressPostalCode . addressRegion . orderAddress)] + --, dbLineItemsTwo = foreignKeyOn (dbLineItems flowerDB) [ + -- lineItemTwoFk `References` LineItemID + -- ] Cascade Restrict + } + +hsSchema :: Schema +hsSchema = + fromAnnotatedDbSettings annotatedDB (Proxy @'[ 'UserDefinedFk LineItemT]) + +-- fromAnnotatedDbSettings annotatedDB (Proxy @'[]) + +getDbSchema :: String -> IO Schema +getDbSchema dbName = + bracket (connect defaultConnectInfo {connectUser = "adinapoli", connectDatabase = dbName}) close getSchema + +getFlowerDbSchema :: IO Schema +getFlowerDbSchema = getDbSchema "beam-test-db" + +getSchemaDiff :: IO Diff +getSchemaDiff = diff hsSchema <$> getFlowerDbSchema + +getGroundhogSchema :: IO Schema +getGroundhogSchema = getDbSchema "groundhog-test-db" + +-- | Just a simple example demonstrating a possible workflow for a migration. +example :: IO () +example = do + print hsSchema + dbSchema <- getFlowerDbSchema + print dbSchema + print $ dbSchema == hsSchema + let schemaDiff = diff hsSchema dbSchema + print schemaDiff + putStrLn "GROUNDHOG" + getGroundhogSchema >>= print + +exampleShowMigration :: IO () +exampleShowMigration = withBeamTestDb printMigration + +withBeamTestDb :: (Migration Pg -> Pg ()) -> IO () +withBeamTestDb action = do + let connInfo = "host=localhost port=5432 dbname=beam-test-db" + bracket (Pg.connectPostgreSQL connInfo) Pg.close $ \conn -> + Pg.withTransaction conn $ + runBeamPostgresDebug putStrLn conn $ do + let mig = migrate conn hsSchema + action mig + +exampleAutoMigration :: IO () +exampleAutoMigration = withBeamTestDb unsafeRunMigration diff --git a/examples/ForeignKeys.hs b/examples/ForeignKeys.hs new file mode 100644 --- /dev/null +++ b/examples/ForeignKeys.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module ForeignKeys where + +import Control.Exception (bracket) +import Data.Proxy +import Data.Text (Text) +import Database.Beam.AutoMigrate (AnnotatedDatabaseSettings, Migration, Schema, defaultAnnotatedDbSettings, fromAnnotatedDbSettings, migrate, printMigration, unsafeRunMigration) +import Database.Beam.Postgres +import Database.Beam.Schema (Beamable, Columnar, Database, PrimaryKey, TableEntity, defaultDbSettings) +import qualified Database.Beam.Schema as Beam +import Database.Beam.Schema.Tables (primaryKey) +import qualified Database.PostgreSQL.Simple as Pg +import GHC.Generics + +-- +-- Example +-- + +data CitiesT f = Flower + { ctCity :: Columnar f Text, + ctLocation :: Columnar f Text + } + deriving (Generic, Beamable) + +data WeatherT f = Weather + { wtId :: Columnar f Int, + wtCity :: PrimaryKey CitiesT f, + wtTempLo :: Columnar f Int, + wtTempHi :: Columnar f Int + } + deriving (Generic, Beamable) + +data ForecastDB f = ForecastDB + { dbCities :: f (TableEntity CitiesT), + dbWeathers :: f (TableEntity WeatherT) + } + deriving (Generic, Database be) + +instance Beam.Table CitiesT where + data PrimaryKey CitiesT f = CityID (Columnar f Text) + deriving (Generic, Beamable) + primaryKey = CityID . ctCity + +instance Beam.Table WeatherT where + data PrimaryKey WeatherT f = WeatherID (Columnar f Int) + deriving (Generic, Beamable) + primaryKey = WeatherID . wtId + +-- This are 'AnnotatedDatabaseSettings' derived directly from "stock" 'DatabaseSettings'. +forecastDB :: AnnotatedDatabaseSettings Postgres ForecastDB +forecastDB = defaultAnnotatedDbSettings defaultDbSettings + +hsSchema :: Schema +hsSchema = fromAnnotatedDbSettings forecastDB (Proxy @'[]) + +exampleShowMigration :: IO () +exampleShowMigration = withBeamTestDb printMigration + +withBeamTestDb :: (Migration Pg -> Pg ()) -> IO () +withBeamTestDb action = do + let connInfo = "host=localhost port=5432 dbname=beam-test-forecast-db" + bracket (Pg.connectPostgreSQL connInfo) Pg.close $ \conn -> + Pg.withTransaction conn $ + runBeamPostgres conn $ do + let mig = migrate conn hsSchema + action mig + +exampleAutoMigration :: IO () +exampleAutoMigration = withBeamTestDb unsafeRunMigration diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Example (example) + +main :: IO () +main = example diff --git a/integration-tests/Main.hs b/integration-tests/Main.hs new file mode 100644 --- /dev/null +++ b/integration-tests/Main.hs @@ -0,0 +1,70 @@ +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 Database.Beam.AutoMigrate +import Database.Beam.AutoMigrate.BenchUtil (cleanDatabase, tearDownDatabase) +import Database.Beam.AutoMigrate.Postgres (getSchema) +import Database.Beam.AutoMigrate.Schema.Gen +import Database.Beam.AutoMigrate.Validity +import qualified Database.PostgreSQL.Simple as Pg +import qualified Database.Postgres.Temp as Tmp +import qualified Test.Database.Beam.AutoMigrate.Arbitrary as Pretty +import Test.QuickCheck +import Test.QuickCheck.Monadic +import Test.Tasty +import Test.Tasty.QuickCheck as QC + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [properties] + +properties :: TestTree +properties = + 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, + -- 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 [] + ] + +-- | 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 + +-- | 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) + + release :: (Tmp.DB, Pg.Connection) -> IO () + release (db, conn) = tearDownDatabase conn >> Tmp.stop db diff --git a/large-migration-test/Main.hs b/large-migration-test/Main.hs new file mode 100644 --- /dev/null +++ b/large-migration-test/Main.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +module Main where + +import Control.Exception (bracket) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Map.Strict as M +import Data.Time +import Database.Beam.AutoMigrate +import Database.Beam.AutoMigrate.BenchUtil +import Database.Beam.AutoMigrate.Postgres (getSchema) +import Database.Beam.Postgres (runBeamPostgres) +import qualified Database.PostgreSQL.Simple as Pg + +pgMigrate :: Pg.Connection -> Schema -> IO () +pgMigrate conn hsSchema = + Pg.withTransaction conn $ + runBeamPostgres conn $ do + dbSchema <- liftIO (getSchema conn) + unsafeRunMigration (createMigration (diff hsSchema dbSchema)) + +main :: IO () +main = do + putStrLn $ "Generating schema with 10_000 tables ..." + (hsSchema, dbSchema) <- predictableSchemas 10000 + --printMigration $ createMigration (diff dbSchema noSchema) + putStrLn $ "Generated schema with " ++ show (M.size . schemaTables $ hsSchema) ++ " tables." + bracket (setupDatabase dbSchema) tearDownDatabase $ \conn -> do + putStrLn "Starting the migration.." + startTime <- getCurrentTime + pgMigrate conn hsSchema + stopTime <- getCurrentTime + putStrLn $ "Total time (seconds): " <> show (round (stopTime `diffUTCTime` startTime)) diff --git a/src/Database/Beam/AutoMigrate.hs b/src/Database/Beam/AutoMigrate.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/AutoMigrate.hs @@ -0,0 +1,692 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +-- | This module provides the high-level API to migrate a database. +module Database.Beam.AutoMigrate + ( -- * Annotating a database + -- $annotatingDbSettings + defaultAnnotatedDbSettings, + + -- * Generating a Schema + -- $generatingASchema + fromAnnotatedDbSettings, + + -- * Downcasting an AnnotatedDatabaseSettings into a simple DatabaseSettings + deAnnotateDatabase, + + -- * Generating and running migrations + Migration, + migrate, + runMigrationUnsafe, + runMigrationWithEditUpdate, + tryRunMigrationsWithEditUpdate, + + -- * Creating a migration from a Diff + createMigration, + + -- * Migration utility functions + splitEditsOnSafety, + fastApproximateRowCountFor, + + -- * Printing migrations for debugging purposes + prettyEditActionDescription, + prettyEditSQL, + printMigration, + printMigrationIO, + + -- * Unsafe functions + unsafeRunMigration, + + -- * Handy re-exports + module Exports, + + -- * Internals + FromAnnotated, + ToAnnotated, + sqlSingleQuoted, + sqlEscaped, + editToSqlCommand, + ) +where + +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) +import Data.Function ((&)) +import Data.Int (Int64) +import Data.List (foldl') +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) +import Data.Proxy +import qualified Data.Set as S +import Data.String.Conv (toS) +import Data.Text (Text) +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 +import Database.Beam.AutoMigrate.Generic as Exports +import Database.Beam.AutoMigrate.Postgres (getSchema) +import Database.Beam.AutoMigrate.Types as Exports +import Database.Beam.AutoMigrate.Util hiding (tableName) +import Database.Beam.AutoMigrate.Validity as Exports +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.Beam.Postgres.Syntax as Pg +import Database.Beam.Schema (Database, DatabaseSettings) +import Database.Beam.Schema.Tables (DatabaseEntity (..)) +import qualified Database.PostgreSQL.Simple as Pg +import GHC.Generics hiding (prec) +import Lens.Micro (over, (^.), _1, _2) +import qualified Text.Pretty.Simple as PS + +-- $annotatingDbSettings +-- The first thing to do in order to be able to use this library is to convert a Beam's 'DatabaseSettings' +-- into an 'AnnotatedDatabaseSettings'. You typically have two options in order to do that: +-- +-- 1. If you don't have an existing 'DatabaseSettings' from a previous application, you can simply call +-- 'defaultAnnotatedDbSettings' with 'defaultDbSettings', as in @defaultAnnotatedDbSettings defaultDbSettings@; +-- +-- 2. If you are starting from an existing 'DatabaseSettings', then simply call 'defaultAnnotatedDbSettings' +-- passing your existing 'DatabaseSettings'. + +-- | Simple synonym to make the signatures for 'defaultAnnotatedDbSettings' and 'fromAnnotatedDbSettings' +-- less scary. From a user's standpoint, there is nothing you have to implement. +type ToAnnotated (be :: *) (db :: DatabaseKind) e1 e2 = + ( Generic (db (e1 be db)), + Generic (db (e2 be db)), + Database be db, + GZipDatabase + be + (e1 be db) + (e2 be db) + (e2 be db) + (Rep (db (e1 be db))) + (Rep (db (e2 be db))) + (Rep (db (e2 be db))) + ) + +-- | Simple class to make the signatures for 'defaultAnnotatedDbSettings' and 'fromAnnotatedDbSettings' +-- less scary. From a user's standpoint, there is nothing you have to implement. +type FromAnnotated (be :: *) (db :: DatabaseKind) e1 e2 = + ( Generic (db (e1 be db)), + Generic (db (e2 be db)), + Database be db, + GZipDatabase + be + (e2 be db) + (e2 be db) + (e1 be db) + (Rep (db (e2 be db))) + (Rep (db (e2 be db))) + (Rep (db (e1 be db))) + ) + +-- | Turns a Beam's 'DatabaseSettings' into an 'AnnotatedDatabaseSettings'. +defaultAnnotatedDbSettings :: + forall be db. + ToAnnotated be db DatabaseEntity AnnotatedDatabaseEntity => + DatabaseSettings be db -> + AnnotatedDatabaseSettings be db +defaultAnnotatedDbSettings db = + runIdentity $ + zipTables (Proxy @be) annotate db (undefined :: AnnotatedDatabaseSettings be db) + where + annotate :: + ( Monad m, + IsAnnotatedDatabaseEntity be ty, + AnnotatedDatabaseEntityRegularRequirements be ty + ) => + DatabaseEntity be db ty -> + AnnotatedDatabaseEntity be db ty -> + m (AnnotatedDatabaseEntity be db ty) + annotate (DatabaseEntity edesc) _ = + pure $ AnnotatedDatabaseEntity (dbAnnotatedEntityAuto edesc) (DatabaseEntity edesc) + +-- | Downcast an 'AnnotatedDatabaseSettings' into Beam's standard 'DatabaseSettings'. +deAnnotateDatabase :: + forall be db. + FromAnnotated be db DatabaseEntity AnnotatedDatabaseEntity => + AnnotatedDatabaseSettings be db -> + DatabaseSettings be db +deAnnotateDatabase db = + runIdentity $ zipTables (Proxy @be) (\ann _ -> pure $ ann ^. deannotate) db db + +-- $generatingASchema +-- Once you have an 'AnnotatedDatabaseSettings', you can produce a 'Schema' simply by calling +-- 'fromAnnotatedDbSettings'. The second parameter can be used to selectively turn off automatic FK-discovery +-- for one or more tables. For more information about specifying your own table constraints, refer to the +-- 'Database.Beam.AutoMigrate.Annotated' module. + +-- | Turns an 'AnnotatedDatabaseSettings' into a 'Schema'. Under the hood, this function will do the +-- following: +-- +-- * It will turn each 'TableEntity' of your database into a 'Table'; +-- * It will turn each 'PgEnum' enumeration type into an 'Enumeration', which will map to an @ENUM@ type in the DB; +-- * It will run what we call the __/automatic FK-discovery algorithm/__. What this means practically speaking +-- is that if a reference to an external 'PrimaryKey' is found, and such 'PrimaryKey' uniquely identifies +-- another 'TableEntity' in your database, the automatic FK-discovery algorithm will turn into into a +-- 'ForeignKey' 'TableConstraint', without any user intervention. In case there is ambiguity instead, the +-- library will fail with a static error until the user won't disable the relevant tables (via the provided +-- 'Proxy' type) and annotate them to do the \"right thing\". +fromAnnotatedDbSettings :: + ( FromAnnotated be db DatabaseEntity AnnotatedDatabaseEntity, + GSchema be db anns (Rep (AnnotatedDatabaseSettings be db)) + ) => + AnnotatedDatabaseSettings be db -> + Proxy (anns :: [Annotation]) -> + Schema +fromAnnotatedDbSettings db p = gSchema db p (from db) + +editsToPgSyntax :: [WithPriority Edit] -> [Pg.PgSyntax] +editsToPgSyntax = map (toSqlSyntax . fst . unPriority) + +-- | A database 'Migration'. +type Migration m = ExceptT MigrationError (StateT [WithPriority Edit] m) () + +data MigrationError + = DiffFailed DiffError + | HaskellSchemaValidationFailed [ValidationFailed] + | DatabaseSchemaValidationFailed [ValidationFailed] + | UnsafeEditsDetected [EditAction] + deriving (Show) + +instance Exception MigrationError + +-- | Split the given list of 'Edit's based on their 'EditSafety' setting. +splitEditsOnSafety :: [WithPriority Edit] -> ([WithPriority Edit], [WithPriority Edit]) +splitEditsOnSafety = + foldl' + ( \acc p -> + if editSafetyIs Unsafe (fst $ unPriority p) + then over _1 (p :) acc + else over _2 (p :) acc + ) + (mempty, mempty) + +-- | Given a 'Connection' to a database and a 'Schema' (which can be generated using 'fromAnnotatedDbSettings') +-- it returns a 'Migration', which can then be executed via 'runMigration'. +migrate :: MonadIO m => Pg.Connection -> Schema -> Migration m +migrate conn hsSchema = do + dbSchema <- lift . liftIO $ getSchema conn + liftEither $ first HaskellSchemaValidationFailed (validateSchema hsSchema) + liftEither $ first DatabaseSchemaValidationFailed (validateSchema dbSchema) + let schemaDiff = diff hsSchema dbSchema + case schemaDiff of + Left e -> throwError (DiffFailed e) + Right edits -> lift (put edits) + +-- | Runs the input 'Migration' in a concrete 'Postgres' backend. +-- +-- __IMPORTANT:__ This function /does not/ run inside a SQL transaction, hence the @unsafe@ prefix. +unsafeRunMigration :: (MonadBeam Pg.Postgres m, MonadIO m) => Migration m -> m () +unsafeRunMigration m = do + migs <- evalMigration m + case migs of + Left e -> liftIO $ throwIO e + Right (sortEdits -> edits) -> + runNoReturn $ Pg.PgCommandSyntax Pg.PgCommandTypeDdl (mconcat . editsToPgSyntax $ edits) + +-- | Runs the input 'Migration' in a concrete 'Postgres' backend. +runMigrationUnsafe :: MonadBeam Pg.Postgres Pg.Pg => Pg.Connection -> Migration Pg.Pg -> IO () +runMigrationUnsafe conn mig = Pg.withTransaction conn $ Pg.runBeamPostgres conn (unsafeRunMigration mig) + +-- | Run the steps of the migration in priority order, providing a hook to allow the user +-- to take action for 'Unsafe' edits. The given function is only called for unsafe edits. +-- +-- This allows you to perform some checks for when the edit safe in some circumstances. +-- +-- * Deleting an empty table/column +-- * Making an empty column non-nullable +runMigrationWithEditUpdate :: + MonadBeam Pg.Postgres Pg.Pg => + ([WithPriority Edit] -> [WithPriority Edit]) -> + Pg.Connection -> + Schema -> + IO () +runMigrationWithEditUpdate editUpdate conn hsSchema = do + -- Create the migration with all the safeety information + edits <- either throwIO pure =<< evalMigration (migrate conn hsSchema) + -- Apply the user function to possibly update the list of edits to allow the user to + -- 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 (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 $ + forM_ newEdits $ \(WithPriority (edit, _)) -> do + case _editCondition edit of + Right Unsafe -> liftIO $ throwIO $ UnsafeEditsDetected [_editAction edit] + -- Safe or slow, run that edit. + Right safeMaybeSlow -> safeOrSlow safeMaybeSlow edit + Left ec -> do + -- Edit is conditional, run the condition to see how safe it is to run this edit. + printmsg $ "edit has condition: " <> toS (prettyEditConditionQuery ec) + checkedSafety <- _editCondition_check ec + case checkedSafety of + Unsafe -> do + -- Edit determined to be unsafe, don't run it. + printmsg "edit unsafe by condition" + liftIO $ throwIO $ UnsafeEditsDetected [_editAction edit] + safeMaybeSlow -> do + -- Safe or slow, run that edit. + printmsg "edit condition satisfied" + safeOrSlow safeMaybeSlow edit + where + safeOrSlow safety edit = do + when (safety == PotentiallySlow) $ do + printmsg "Running potentially slow edit" + printmsg $ T.unpack $ prettyEditActionDescription $ _editAction edit + + runNoReturn $ editToSqlCommand edit + + printmsg :: MonadIO m => String -> m () + printmsg = liftIO . putStrLn . mappend "[beam-migrate] " + +-- | Helper query to retrieve the approximate row count from the @pg_class@ table. +-- +-- Number of live rows in the table. This is only an estimate used by the planner. It is +-- updated by VACUUM, ANALYZE, and a few DDL commands such as CREATE INDEX. +-- +-- This can be used as a check to see if an otherwise 'Unsafe' 'EditAction' is safe to execute. +-- +-- See: +-- * and +-- * +-- for more information. +fastApproximateRowCountFor :: TableName -> Pg.Pg (Maybe Int64) +fastApproximateRowCountFor tblName = runReturningOne $ selectCmd $ Pg.PgSelectSyntax $ qry + where + qry = + Pg.emit $ + toS $ + "SELECT reltuples AS approximate_row_count FROM pg_class WHERE relname = " + <> sqlEscaped (tableName tblName) + <> ";" + +-- Unfortunately Postgres' syntax is different when setting or dropping constaints. For example when we +-- drop the default value we /don't/ repeat which was the original default value (which makes sense), but +-- doing so means we have to discriminate between these two events to render the SQL fragment correctly. +data AlterTableAction + = SetConstraint + | DropConstraint + deriving (Show, Eq) + +-- | Converts a single 'Edit' into the relevant 'PgSyntax' necessary to generate the final SQL. +toSqlSyntax :: Edit -> Pg.PgSyntax +toSqlSyntax e = + safetyPrefix $ + _editAction e & \case + TableAdded tblName tbl -> + ddlSyntax + ( "CREATE TABLE " <> sqlEscaped (tableName tblName) + <> " (" + <> T.intercalate ", " (map renderTableColumn (M.toList (tableColumns tbl))) + <> ")" + ) + TableRemoved tblName -> + ddlSyntax ("DROP TABLE " <> sqlEscaped (tableName tblName)) + TableConstraintAdded tblName cstr -> + updateSyntax (alterTable tblName <> renderAddConstraint cstr) + TableConstraintRemoved tblName cstr -> + updateSyntax (alterTable tblName <> renderDropConstraint cstr) + SequenceAdded sName (Sequence _tName _cName) -> createSequenceSyntax sName + SequenceRemoved sName -> dropSequenceSyntax sName + EnumTypeAdded tyName vals -> createTypeSyntax tyName vals + EnumTypeRemoved (EnumerationName tyName) -> ddlSyntax ("DROP TYPE " <> tyName) + EnumTypeValueAdded (EnumerationName tyName) newVal order insPoint -> + ddlSyntax + ( "ALTER TYPE " <> tyName + <> " ADD VALUE " + <> sqlSingleQuoted newVal + <> " " + <> renderInsertionOrder order + <> " " + <> sqlSingleQuoted insPoint + ) + ColumnAdded tblName colName col -> + updateSyntax + ( alterTable tblName + <> "ADD COLUMN " + <> sqlEscaped (columnName colName) + <> " " + <> renderDataType (columnType col) + <> " " + <> T.intercalate " " (map (renderColumnConstraint SetConstraint) (S.toList $ columnConstraints col)) + ) + ColumnRemoved tblName colName -> + updateSyntax (alterTable tblName <> "DROP COLUMN " <> sqlEscaped (columnName colName)) + ColumnTypeChanged tblName colName _old new -> + updateSyntax + ( alterTable tblName <> "ALTER COLUMN " + <> sqlEscaped (columnName colName) + <> " TYPE " + <> renderDataType new + ) + ColumnConstraintAdded tblName colName cstr -> + updateSyntax + ( alterTable tblName <> "ALTER COLUMN " + <> sqlEscaped (columnName colName) + <> " SET " + <> renderColumnConstraint SetConstraint cstr + ) + ColumnConstraintRemoved tblName colName cstr -> + updateSyntax + ( alterTable tblName <> "ALTER COLUMN " + <> sqlEscaped (columnName colName) + <> " DROP " + <> renderColumnConstraint DropConstraint cstr + ) + where + safetyPrefix query = + if editSafetyIs Safe e + then Pg.emit " " <> query + else Pg.emit "" <> query + + ddlSyntax query = Pg.emit . TE.encodeUtf8 $ query <> ";\n" + updateSyntax query = Pg.emit . TE.encodeUtf8 $ query <> ";\n" + + alterTable :: TableName -> Text + alterTable (TableName tName) = "ALTER TABLE " <> sqlEscaped tName <> " " + + renderTableColumn :: (ColumnName, Column) -> Text + renderTableColumn (colName, col) = + sqlEscaped (columnName colName) <> " " + <> renderDataType (columnType col) + <> " " + <> T.intercalate " " (map (renderColumnConstraint SetConstraint) (S.toList $ columnConstraints col)) + + renderInsertionOrder :: InsertionOrder -> Text + renderInsertionOrder Before = "BEFORE" + renderInsertionOrder After = "AFTER" + + renderCreateTableConstraint :: TableConstraint -> Text + renderCreateTableConstraint = \case + Unique fname cols -> + conKeyword <> sqlEscaped fname + <> " UNIQUE (" + <> T.intercalate ", " (map (sqlEscaped . columnName) (S.toList cols)) + <> ")" + PrimaryKey fname cols -> + conKeyword <> sqlEscaped fname + <> " PRIMARY KEY (" + <> T.intercalate ", " (map (sqlEscaped . columnName) (S.toList cols)) + <> ")" + ForeignKey fname (tableName -> tName) (S.toList -> colPair) onDelete onUpdate -> + let (fkCols, referenced) = + ( map (sqlEscaped . columnName . fst) colPair, + map (sqlEscaped . columnName . snd) colPair + ) + in conKeyword <> sqlEscaped fname + <> " FOREIGN KEY (" + <> T.intercalate ", " fkCols + <> ") REFERENCES " + <> sqlEscaped tName + <> "(" + <> T.intercalate ", " referenced + <> ")" + <> renderAction "ON DELETE" onDelete + <> renderAction "ON UPDATE" onUpdate + where + conKeyword = "CONSTRAINT " + + renderAddConstraint :: TableConstraint -> Text + renderAddConstraint = mappend "ADD " . renderCreateTableConstraint + + renderDropConstraint :: TableConstraint -> Text + renderDropConstraint tc = case tc of + Unique cName _ -> dropC cName + PrimaryKey cName _ -> dropC cName + ForeignKey cName _ _ _ _ -> dropC cName + where + dropC = mappend "DROP CONSTRAINT " . sqlEscaped + + renderAction actionPrefix = \case + NoAction -> mempty + Cascade -> " " <> actionPrefix <> " " <> "CASCADE " + Restrict -> " " <> actionPrefix <> " " <> "RESTRICT " + SetNull -> " " <> actionPrefix <> " " <> "SET NULL " + SetDefault -> " " <> actionPrefix <> " " <> "SET DEFAULT " + + renderColumnConstraint :: AlterTableAction -> ColumnConstraint -> Text + renderColumnConstraint act = \case + NotNull -> "NOT NULL" + Default defValue | act == SetConstraint -> "DEFAULT " <> defValue + Default _ -> "DEFAULT" + + createTypeSyntax :: EnumerationName -> Enumeration -> Pg.PgSyntax + createTypeSyntax (EnumerationName ty) (Enumeration vals) = + Pg.emit $ + toS $ + "CREATE TYPE " <> ty <> " AS ENUM (" <> T.intercalate "," (map sqlSingleQuoted vals) <> ");\n" + + createSequenceSyntax :: SequenceName -> Pg.PgSyntax + createSequenceSyntax (SequenceName s) = Pg.emit $ toS $ "CREATE SEQUENCE " <> sqlEscaped s <> ";\n" + + dropSequenceSyntax :: SequenceName -> Pg.PgSyntax + dropSequenceSyntax (SequenceName s) = Pg.emit $ toS $ "DROP SEQUENCE " <> sqlEscaped s <> ";\n" + +renderStdType :: AST.DataType -> Text +renderStdType = \case + -- From the Postgres' documentation: + -- \"character without length specifier is equivalent to character(1).\" + (AST.DataTypeChar False prec charSet) -> + "CHAR" <> sqlOptPrec (Just $ fromMaybe 1 prec) <> sqlOptCharSet charSet + (AST.DataTypeChar True prec charSet) -> + "VARCHAR" <> sqlOptPrec prec <> sqlOptCharSet charSet + (AST.DataTypeNationalChar varying prec) -> + let ty = if varying then "NATIONAL CHARACTER VARYING" else "NATIONAL CHAR" + in ty <> sqlOptPrec prec + (AST.DataTypeBit varying prec) -> + let ty = if varying then "BIT VARYING" else "BIT" + in ty <> sqlOptPrec prec + (AST.DataTypeNumeric prec) -> "NUMERIC" <> sqlOptNumericPrec prec + -- Even though beam emits 'DOUBLE here' + -- (see: https://github.com/tathougies/beam/blob/b245bf2c0b4c810dbac334d08ca572cec49e4d83/beam-postgres/Database/Beam/Postgres/Syntax.hs#L544) + -- the \"double\" type doesn't exist in Postgres. + -- Rather, the "NUMERIC" and "DECIMAL" types are equivalent in Postgres, and that's what we use here. + (AST.DataTypeDecimal prec) -> "NUMERIC" <> sqlOptNumericPrec prec + AST.DataTypeInteger -> "INT" + AST.DataTypeSmallInt -> "SMALLINT" + AST.DataTypeBigInt -> "BIGINT" + (AST.DataTypeFloat prec) -> "FLOAT" <> sqlOptPrec prec + AST.DataTypeReal -> "REAL" + AST.DataTypeDoublePrecision -> "DOUBLE PRECISION" + AST.DataTypeDate -> "DATE" + (AST.DataTypeTime prec withTz) -> wTz withTz "TIME" prec <> sqlOptPrec prec + (AST.DataTypeTimeStamp prec withTz) -> wTz withTz "TIMESTAMP" prec <> sqlOptPrec prec + (AST.DataTypeInterval _i) -> + error $ + "Impossible: DataTypeInterval doesn't map to any SQLXX beam typeclass, so we don't know" + <> " how to render it." + (AST.DataTypeIntervalFromTo _from _to) -> + error $ + "Impossible: DataTypeIntervalFromTo doesn't map to any SQLXX beam typeclass, so we don't know" + <> " how to render it." + AST.DataTypeBoolean -> "BOOL" + AST.DataTypeBinaryLargeObject -> "BYTEA" + AST.DataTypeCharacterLargeObject -> "TEXT" + (AST.DataTypeArray dt sz) -> + renderStdType dt <> "[" <> T.pack (show sz) <> "]" + (AST.DataTypeRow _rows) -> + error "DataTypeRow not supported both for beam-postgres and this library." + (AST.DataTypeDomain nm) -> "\"" <> nm <> "\"" + where + wTz withTz tt prec = + tt <> sqlOptPrec prec <> (if withTz then " WITH" else " WITHOUT") <> " TIME ZONE" + +-- This function also overlaps with beam-migrate functionalities. +renderDataType :: ColumnType -> Text +renderDataType = \case + SqlStdType stdType -> renderStdType stdType + -- text-based enum types + DbEnumeration (EnumerationName _) _ -> + renderDataType (SqlStdType (AST.DataTypeChar True Nothing Nothing)) + -- Json types + PgSpecificType PgJson -> toS $ displaySyntax Pg.pgJsonType + PgSpecificType PgJsonB -> toS $ displaySyntax Pg.pgJsonbType + -- Range types + PgSpecificType PgRangeInt4 -> toS $ Pg.rangeName @Pg.PgInt4Range + PgSpecificType PgRangeInt8 -> toS $ Pg.rangeName @Pg.PgInt8Range + PgSpecificType PgRangeNum -> toS $ Pg.rangeName @Pg.PgNumRange + PgSpecificType PgRangeTs -> toS $ Pg.rangeName @Pg.PgTsRange + PgSpecificType PgRangeTsTz -> toS $ Pg.rangeName @Pg.PgTsTzRange + PgSpecificType PgRangeDate -> toS $ Pg.rangeName @Pg.PgDateRange + -- UUID + PgSpecificType PgUuid -> toS $ displaySyntax Pg.pgUuidType + -- enumerations + PgSpecificType (PgEnumeration (EnumerationName ty)) -> ty + +evalMigration :: Monad m => Migration m -> m (Either MigrationError [WithPriority Edit]) +evalMigration m = do + (a, s) <- runStateT (runExceptT m) mempty + case a of + Left e -> pure (Left e) + Right () -> pure (Right s) + +-- | Create the migration from a 'Diff'. +createMigration :: Monad m => Diff -> Migration m +createMigration (Left e) = throwError (DiffFailed e) +createMigration (Right edits) = ExceptT $ do + put edits + pure (Right ()) + +-- | Prints the migration to stdout. Useful for debugging and diagnostic. +printMigration :: MonadIO m => Migration m -> m () +printMigration 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) + +printMigrationIO :: Migration Pg.Pg -> IO () +printMigrationIO mig = Pg.runBeamPostgres (undefined :: Pg.Connection) $ printMigration mig + +editToSqlCommand :: Edit -> Pg.PgCommandSyntax +editToSqlCommand = Pg.PgCommandSyntax Pg.PgCommandTypeDdl . toSqlSyntax + +prettyEditSQL :: Edit -> Text +prettyEditSQL = T.pack . displaySyntax . Pg.fromPgCommand . editToSqlCommand + +prettyEditActionDescription :: EditAction -> Text +prettyEditActionDescription = + T.unwords . \case + TableAdded tblName table -> + ["create table:", qt tblName, "\n", pshow' table] + TableRemoved tblName -> + ["remove table:", qt tblName] + TableConstraintAdded tblName tableConstraint -> + ["add table constraint to:", qt tblName, "\n", pshow' tableConstraint] + TableConstraintRemoved tblName tableConstraint -> + ["remove table constraint from:", qt tblName, "\n", pshow' tableConstraint] + ColumnAdded tblName colName column -> + ["add column:", qc colName, ", from:", qt tblName, "\n", pshow' column] + ColumnRemoved tblName colName -> + ["remove column:", qc colName, ", from:", qt tblName] + ColumnTypeChanged tblName colName oldColumnType newColumnType -> + [ "change type of column:", + qc colName, + "in table:", + qt tblName, + "\nfrom:", + renderDataType oldColumnType, + "\nto:", + renderDataType newColumnType + ] + ColumnConstraintAdded tblName colName columnConstraint -> + [ "add column constraint to:", + qc colName, + "in table:", + qt tblName, + "\n", + pshow' columnConstraint + ] + ColumnConstraintRemoved tblName colName columnConstraint -> + [ "remove column constraint from:", + qc colName, + "in table:", + qt tblName, + "\n", + pshow' columnConstraint + ] + EnumTypeAdded eName enumeration -> + ["add enum type:", enumName eName, pshow' enumeration] + EnumTypeRemoved eName -> + ["remove enum type:", enumName eName] + EnumTypeValueAdded eName newValue insertionOrder insertedAt -> + [ "add enum value to enum:", + enumName eName, + ", value:", + newValue, + ", with order:", + pshow' insertionOrder, + ", at pos", + insertedAt + ] + SequenceAdded sequenceName sequence0 -> + ["add sequence:", qs sequenceName, pshow' sequence0] + SequenceRemoved sequenceName -> + ["remove sequence:", qs sequenceName] + where + q t = "'" <> t <> "'" + qt = q . tableName + qc = q . columnName + qs = q . seqName + + pshow' :: Show a => a -> Text + pshow' = LT.toStrict . PS.pShow + +-- | Compare the existing schema in the database with the expected +-- schema in Haskell and try to edit the existing schema as necessary +tryRunMigrationsWithEditUpdate + :: ( 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 () +tryRunMigrationsWithEditUpdate annotatedDb conn = do + let expectedHaskellSchema = fromAnnotatedDbSettings annotatedDb (Proxy @'[]) + actualDatabaseSchema <- getSchema conn + case diff expectedHaskellSchema actualDatabaseSchema of + Left err -> do + putStrLn "Error detecting database migration requirements: " + print err + Right [] -> + 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 + + try (runMigrationWithEditUpdate Prelude.id conn expectedHaskellSchema) >>= \case + Left (e :: SomeException) -> + error $ "Database migration error: " <> displayException e + Right _ -> + pure () diff --git a/src/Database/Beam/AutoMigrate/Annotated.hs b/src/Database/Beam/AutoMigrate/Annotated.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/AutoMigrate/Annotated.hs @@ -0,0 +1,595 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module provides an 'AnnotatedDatabaseSettings' type to be used as a drop-in replacement for the +-- standard 'DatabaseSettings'. Is it possible to \"downcast\" an 'AnnotatedDatabaseSettings' to a standard +-- 'DatabaseSettings' simply by calling 'deAnnotateDatabase'. +module Database.Beam.AutoMigrate.Annotated + ( -- * User annotations + Annotation (..), + + -- * Annotating a 'DatabaseSettings' + AnnotatedDatabaseSettings, + AnnotatedDatabaseEntity (..), + IsAnnotatedDatabaseEntity (..), + TableSchema, + TableFieldSchema (..), + FieldSchema (..), + dbAnnotatedSchema, + dbAnnotatedConstraints, + annotatedDescriptor, + defaultTableSchema, + + -- * Downcasting annotated types + lowerEntityDescriptor, + deannotate, + + -- * Specifying constraints + -- $specifyingConstraints + annotateTableFields, + + -- * Specifying Column constraints + -- $specifyingColumnConstraints + defaultsTo, + + -- * Specifying Table constraints + -- $specifyingTableConstraints + UniqueConstraint (..), + + -- ** Unique constraint + uniqueConstraintOn, + + -- ** Foreign key constraint + ForeignKeyConstraint (..), + foreignKeyOnPk, + foreignKeyOn, + + -- * Other types and functions + TableKind, + DatabaseKind, + + -- * Ports from Beam + zipTables, + GZipDatabase, + + -- * Internals + pgDefaultConstraint, + ) +where + +import Data.Kind +import Data.Monoid (Endo (..)) +import Data.Proxy +import Data.Set (Set) +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Database.Beam as Beam +import Database.Beam.AutoMigrate.Compat +import Database.Beam.AutoMigrate.Types +import Database.Beam.AutoMigrate.Util +import Database.Beam.Backend.SQL (HasSqlValueSyntax (..), displaySyntax) +import Database.Beam.Postgres (Postgres) +import qualified Database.Beam.Postgres.Syntax as Pg +import Database.Beam.Query (QExpr) +import Database.Beam.Schema.Tables + ( DatabaseEntity, + DatabaseEntityDefaultRequirements, + DatabaseEntityDescriptor, + DatabaseEntityRegularRequirements, + EntityModification (..), + FieldModification (..), + IsDatabaseEntity, + PrimaryKey, + TableEntity, + dbEntityDescriptor, + dbEntityName, + dbTableSettings, + ) +import GHC.Generics as Generic +import Lens.Micro (SimpleGetter, (^.)) +import qualified Lens.Micro as Lens + +-- +-- Annotating a 'DatabaseSettings' with meta information. +-- + +-- | To make kind signatures more readable. +type DatabaseKind = (Type -> Type) -> Type + +-- | To make kind signatures more readable. +type TableKind = (Type -> Type) -> Type + +-- | A user-defined annotation. Currently the only possible annotation is the ability to specify for which +-- tables the FK-discovery algorithm is \"turned\" off. +data Annotation where + -- | Specifies that the given 'TableKind' (i.e. a table) has user-specified FK constraints. This is + -- useful in case of ambiguity, i.e. when the automatic FK-discovery algorithm is not capable to + -- infer the correct 'ForeignKey' constraints for a 'Table'. This can happen when the 'PrimaryKey' type + -- family is not injective, which means there are multiple tables of table @FooT@ in the DB. Consider a + -- situation where we have a table @BarT@ having a field of type @barField :: PrimaryKey FooT f@ but + -- (crucially) there are two tables with type @f (TableEntity FooT)@ in the final database. In this + -- circumstance the FK-discovery algorithm will bail out with a (static) error, and this is where this + -- annotation comes into play: it allows us to selectively \"disable\" the discovery for the given + -- table(s), and manually override the FKs. + -- + -- /Caveat emptor/: Due to what we said earlier (namely that we cannot enforce that tables are not + -- repeated multiple times within a DB) there might be situations where also the specified 'TableKind' + -- is not unique. In this case the annotation would affect all the tables of the same type, but that is + -- usually unavoidable, as the ambiguity was already present the minute we introduced in the DB two tables + -- of the same type, and so it makes sense for the user to fully resolve the ambiguity manually. + UserDefinedFk :: TableKind -> Annotation + +-- | Zip tables together. Unfortunately we cannot reuse the stock 'zipTables' from 'beam-core', because it +-- works by supplying a rank-2 function with 'IsDatabaseEntity' and 'DatabaseEntityRegularRequirements' as +-- witnesses, we we need the annotated counterparts instead. +-- +-- This function can be written without the need of a typeclass, but alas it requires the /unexported/ +-- 'GZipDatabase' from 'beam-core', so we had to re-implement this ourselves for now. +zipTables :: + ( Generic (db f), + Generic (db g), + Generic (db h), + Monad m, + GZipDatabase be f g h (Rep (db f)) (Rep (db g)) (Rep (db h)) + ) => + Proxy be -> + (forall tbl. (IsAnnotatedDatabaseEntity be tbl, AnnotatedDatabaseEntityRegularRequirements be tbl) => f tbl -> g tbl -> m (h tbl)) -> + db f -> + db g -> + m (db h) +-- We need the pattern type signature on 'combine' to get around a type checking bug in GHC 8.0.1. +-- In future releases, we will switch to the standard forall. +zipTables be combine (f :: db f) (g :: db g) = + refl $ \h -> + to <$> gZipDatabase (Proxy @f, Proxy @g, h, be) combine (from f) (from g) + where + -- For GHC 8.0.1 renamer bug + refl :: (Proxy h -> m (db h)) -> m (db h) + refl fn = fn Proxy + +-- | See above on why this class has been re-implemented. +class GZipDatabase be f g h x y z where + gZipDatabase :: + Monad m => + (Proxy f, Proxy g, Proxy h, Proxy be) -> + (forall tbl. (IsAnnotatedDatabaseEntity be tbl, AnnotatedDatabaseEntityRegularRequirements be tbl) => f tbl -> g tbl -> m (h tbl)) -> + x () -> + y () -> + m (z ()) + +instance GZipDatabase be f g h x y z => GZipDatabase be f g h (M1 a b x) (M1 a b y) (M1 a b z) where + gZipDatabase p combine ~(M1 f) ~(M1 g) = M1 <$> gZipDatabase p combine f g + +instance + ( GZipDatabase be f g h ax ay az, + GZipDatabase be f g h bx by bz + ) => + GZipDatabase be f g h (ax :*: bx) (ay :*: by) (az :*: bz) + where + gZipDatabase p combine ~(ax :*: bx) ~(ay :*: by) = do + a <- gZipDatabase p combine ax ay + b <- gZipDatabase p combine bx by + pure (a :*: b) + +instance + ( IsAnnotatedDatabaseEntity be tbl, + AnnotatedDatabaseEntityRegularRequirements be tbl + ) => + GZipDatabase be f g h (K1 Generic.R (f tbl)) (K1 Generic.R (g tbl)) (K1 Generic.R (h tbl)) + where + gZipDatabase _ combine ~(K1 x) ~(K1 y) = + K1 <$> combine x y + +instance + ( Beam.Database be db, + Generic (db f), + Generic (db g), + Generic (db h), + GZipDatabase be f g h (Rep (db f)) (Rep (db g)) (Rep (db h)) + ) => + GZipDatabase be f g h (K1 Generic.R (db f)) (K1 Generic.R (db g)) (K1 Generic.R (db h)) + where + gZipDatabase _ combine ~(K1 x) ~(K1 y) = + K1 <$> zipTables (Proxy :: Proxy be) combine x y + +-- +-- An annotated Database settings. +-- + +-- | An 'AnnotatedDatabaseSettings' is similar in spirit to a @beam-core@ 'DatabaseSettings', but it +-- embellish the latter with extra metadata this library can use to derive more information about the input +-- DB, like table and column constraints. +type AnnotatedDatabaseSettings be db = db (AnnotatedDatabaseEntity be db) + +-- | An 'AnnotatedDatabaseEntity' wraps the underlying 'DatabaseEntity' together with an annotated +-- description called 'AnnotatedDatabaseEntityDescriptor', which is once again similar to the standard +-- 'DatabaseEntityDescriptor' from Beam. +-- +-- An 'AnnotatedDatabaseEntityDescriptor' is not a concrete type, but rather a data family provided by the +-- 'IsAnnotatedDatabaseEntity'. +data AnnotatedDatabaseEntity be (db :: (* -> *) -> *) entityType where + AnnotatedDatabaseEntity :: + (IsAnnotatedDatabaseEntity be entityType, IsDatabaseEntity be entityType) => + AnnotatedDatabaseEntityDescriptor be entityType -> + DatabaseEntity be db entityType -> + AnnotatedDatabaseEntity be db entityType + +class IsDatabaseEntity be entityType => IsAnnotatedDatabaseEntity be entityType where + data AnnotatedDatabaseEntityDescriptor be entityType :: * + type AnnotatedDatabaseEntityDefaultRequirements be entityType :: Constraint + type AnnotatedDatabaseEntityRegularRequirements be entityType :: Constraint + + dbAnnotatedEntityAuto :: + AnnotatedDatabaseEntityRegularRequirements be entityType => + DatabaseEntityDescriptor be entityType -> + AnnotatedDatabaseEntityDescriptor be entityType + +instance + IsDatabaseEntity be (TableEntity tbl) => + IsAnnotatedDatabaseEntity be (TableEntity tbl) + where + data AnnotatedDatabaseEntityDescriptor be (TableEntity tbl) where + AnnotatedDatabaseTable :: + Beam.Table tbl => + { dbAnnotatedSchema :: TableSchema tbl, + dbAnnotatedConstraints :: Set TableConstraint + } -> + AnnotatedDatabaseEntityDescriptor be (TableEntity tbl) + type + AnnotatedDatabaseEntityDefaultRequirements be (TableEntity tbl) = + (DatabaseEntityDefaultRequirements be (TableEntity tbl)) + type + AnnotatedDatabaseEntityRegularRequirements be (TableEntity tbl) = + ( DatabaseEntityRegularRequirements be (TableEntity tbl), + GDefaultTableSchema (Rep (TableSchema tbl) ()) (Rep (Beam.TableSettings tbl) ()), + Generic (TableSchema tbl), + Generic (Beam.TableSettings tbl) + ) + + dbAnnotatedEntityAuto edesc = AnnotatedDatabaseTable (defaultTableSchema . dbTableSettings $ edesc) mempty + +-- | A 'SimpleGetter' to get a plain 'DatabaseEntityDescriptor' from an 'AnnotatedDatabaseEntity'. +lowerEntityDescriptor :: SimpleGetter (AnnotatedDatabaseEntity be db entityType) (DatabaseEntityDescriptor be entityType) +lowerEntityDescriptor = Lens.to (\(AnnotatedDatabaseEntity _ e) -> e ^. dbEntityDescriptor) + +annotatedDescriptor :: SimpleGetter (AnnotatedDatabaseEntity be db entityType) (AnnotatedDatabaseEntityDescriptor be entityType) +annotatedDescriptor = Lens.to (\(AnnotatedDatabaseEntity e _) -> e) + +deannotate :: SimpleGetter (AnnotatedDatabaseEntity be db entityType) (DatabaseEntity be db entityType) +deannotate = Lens.to (\(AnnotatedDatabaseEntity _ e) -> e) + +-- | A table schema. +type TableSchema tbl = + tbl (TableFieldSchema tbl) + +-- | A schema for a field within a given table +data TableFieldSchema (tbl :: (* -> *) -> *) ty where + TableFieldSchema :: + { tableFieldName :: ColumnName, + tableFieldSchema :: FieldSchema ty + } -> + TableFieldSchema tbl ty + +data FieldSchema ty where + FieldSchema :: + ColumnType -> + Set ColumnConstraint -> + FieldSchema ty + +deriving instance Show (FieldSchema ty) + +-- +-- Deriving a 'TableSchema'. +-- + +class GDefaultTableSchema x y where + gDefTblSchema :: Proxy x -> y -> x + +instance GDefaultTableSchema (x p) (y p) => GDefaultTableSchema (D1 f x p) (D1 f y p) where + gDefTblSchema (Proxy :: Proxy (D1 f x p)) (M1 y) = + M1 $ gDefTblSchema (Proxy :: Proxy (x p)) y + +instance GDefaultTableSchema (x p) (y p) => GDefaultTableSchema (C1 f x p) (C1 f y p) where + gDefTblSchema (Proxy :: Proxy (C1 f x p)) (M1 y) = + M1 $ gDefTblSchema (Proxy :: Proxy (x p)) y + +instance + (GDefaultTableSchema (a p) (c p), GDefaultTableSchema (b p) (d p)) => + GDefaultTableSchema ((a :*: b) p) ((c :*: d) p) + where + gDefTblSchema (Proxy :: Proxy ((a :*: b) p)) (c :*: d) = + gDefTblSchema (Proxy :: Proxy (a p)) c + :*: gDefTblSchema (Proxy :: Proxy (b p)) d + +instance + ( SchemaConstraint (Beam.TableField tbl ty) ~ ColumnConstraint, + HasSchemaConstraints (Beam.TableField tbl ty), + HasColumnType ty + ) => + GDefaultTableSchema + (S1 f (K1 Generic.R (TableFieldSchema tbl ty)) p) + (S1 f (K1 Generic.R (Beam.TableField tbl ty)) p) + where + gDefTblSchema (_ :: Proxy (S1 f (K1 Generic.R (TableFieldSchema tbl ty)) p)) (M1 (K1 fName)) = M1 (K1 s) + where + s = TableFieldSchema (ColumnName $ fName ^. Beam.fieldName) defaultFieldSchema + defaultFieldSchema = + FieldSchema + (defaultColumnType (Proxy @ty)) + (schemaConstraints (Proxy @(Beam.TableField tbl ty))) + +-- | Instance where /g/ is things like a 'PrimaryKey' or a /mixin/. +instance + ( Generic (g (Beam.TableField tbl2)), + Generic (g (TableFieldSchema tbl2)), + GDefaultTableSchema + (Rep (g (TableFieldSchema tbl2)) ()) + (Rep (g (Beam.TableField tbl2)) ()) + ) => + GDefaultTableSchema + (S1 f (K1 Generic.R (g (TableFieldSchema tbl2))) ()) + (S1 f (K1 Generic.R (g (Beam.TableField tbl2))) ()) + where + gDefTblSchema (_ :: Proxy (S1 f (K1 Generic.R (g (TableFieldSchema tbl2))) ())) (M1 (K1 fName)) = + M1 (K1 $ to' $ gDefTblSchema Proxy (from' fName)) + +-- | Instance for things like 'Nullable (TableFieldSchema tbl)'. +instance + ( Generic (PrimaryKey tbl1 (g (Beam.TableField tbl2))), + Generic (PrimaryKey tbl1 (g (TableFieldSchema tbl2))), + GDefaultTableSchema + (Rep (PrimaryKey tbl1 (g (TableFieldSchema tbl2))) ()) + (Rep (PrimaryKey tbl1 (g (Beam.TableField tbl2))) ()) + ) => + GDefaultTableSchema + (S1 f (K1 Generic.R (PrimaryKey tbl1 (g (TableFieldSchema tbl2)))) p) + (S1 f (K1 Generic.R (PrimaryKey tbl1 (g (Beam.TableField tbl2)))) p) + where + gDefTblSchema (_ :: Proxy (S1 f (K1 Generic.R (PrimaryKey tbl1 (g (TableFieldSchema tbl2)))) p)) (M1 (K1 fName)) = + M1 (K1 $ to' $ gDefTblSchema Proxy (from' fName)) + +defaultTableSchema :: + forall tbl. + ( GDefaultTableSchema (Rep (TableSchema tbl) ()) (Rep (Beam.TableSettings tbl) ()), + Generic (TableSchema tbl), + Generic (Beam.TableSettings tbl) + ) => + Beam.TableSettings tbl -> + TableSchema tbl +defaultTableSchema tSettings = + to $ gDefTblSchema (Proxy :: Proxy (Rep (TableSchema tbl) ())) (from' tSettings) + +from' :: Generic a => a -> Rep a () +from' = from + +to' :: Generic a => Rep a () -> a +to' = to + +-- +-- Annotating 'Table's and 'Field's after the default 'AnnotatedDatabaseSettings' has been instantiated. +-- + +-- $specifyingConstraints +-- Once an 'AnnotatedDatabaseSettings' has been acquired, the user is able to customise the default +-- medatata associated with it. In order to do so, one can reuse the existing machinery from Beam, in +-- particular the `withDbModification`. For example: +-- +-- > annotatedDB :: AnnotatedDatabaseSettings Postgres FlowerDB +-- > annotatedDB = defaultAnnotatedDbSettings flowerDB `withDbModification` dbModification +-- > { dbFlowers = annotateTableFields tableModification { flowerDiscounted = defaultsTo (val_ $ Just True) +-- > , flowerPrice = defaultsTo (val_ $ Just 10.0) +-- > } +-- > <> uniqueFields [U (addressPostalCode . addressRegion . flowerAddress)] +-- > , dbLineItems = annotateTableFields tableModification { lineItemDiscount = defaultsTo (val_ $ Just False) } +-- > <> uniqueFields [U lineItemFlowerID, U lineItemOrderID, U lineItemQuantity] +-- > , dbOrders = annotateTableFields tableModification { orderTime = defaultsTo (cast_ currentTimestamp_ utctime) } +-- > <> foreignKeyOnPk (dbFlowers flowerDB) orderFlowerIdRef Cascade Restrict +-- > <> uniqueFields [U (addressPostalCode . addressRegion . orderAddress)] +-- > } +-- +-- Refer to the rest of the documentation for this module for more information about 'annotateTableFields', +-- 'uniqueFields' and 'foreignKeyOnPk'. + +-- | Annotate the table fields for a given 'AnnotatedDatabaseEntity'. Refer to the $specifyingConstraints +-- section for an example. +annotateTableFields :: + tbl (FieldModification (TableFieldSchema tbl)) -> + EntityModification (AnnotatedDatabaseEntity be db) be (TableEntity tbl) +annotateTableFields modFields = + EntityModification + ( Endo + ( \(AnnotatedDatabaseEntity tbl@(AnnotatedDatabaseTable {}) e) -> + AnnotatedDatabaseEntity + ( tbl + { dbAnnotatedSchema = Beam.withTableModification modFields (dbAnnotatedSchema tbl) + } + ) + e + ) + ) + +-- +-- Specifying default values (Postgres-specific) +-- + +-- $specifyingColumnConstraints +-- Due to the fact most column constraints can span /multiple/ columns (think about @UNIQUE@ or +-- @FOREIGN KEY@) the only constraint associated to a 'TableFieldSchema' we allow to customise at the +-- \"single-column-granularity\" is @DEFAULT@. + +-- | Specify a default value for an entity. The relevant migration will generate an associated SQL +-- @DEFAULT@. This function accepts any Beam's expression that also the standard 'field' machinery would +-- accept, for example: +-- +-- > defaultsTo (val_ $ Just 10) +defaultsTo :: + (HasColumnType ty, HasSqlValueSyntax Pg.PgValueSyntax ty) => + (forall ctx s. Beam.QGenExpr ctx Postgres s ty) -> + FieldModification (TableFieldSchema tbl) ty +defaultsTo tyVal = FieldModification $ \old -> + case tableFieldSchema old of + FieldSchema ty c -> + old + { tableFieldSchema = + FieldSchema ty $ S.singleton (pgDefaultConstraint tyVal) <> c + } + +-- | Postgres-specific function to convert any 'QGenExpr' into a meaningful 'PgExpressionSyntax', so +-- that it can be rendered inside a 'Default' column constraint. +pgDefaultConstraint :: + forall ty. + (HasColumnType ty, HasSqlValueSyntax Pg.PgValueSyntax ty) => + (forall ctx s. Beam.QGenExpr ctx Postgres s ty) -> + ColumnConstraint +pgDefaultConstraint tyVal = + let syntaxFragment = T.pack . displaySyntax . Pg.fromPgExpression $ defaultTo_ tyVal + dVal = case defaultTypeCast (Proxy @ty) of + Nothing -> syntaxFragment + Just tc | T.head syntaxFragment == '\'' -> syntaxFragment <> "::" <> tc + -- NOTE(and) Special-case handling for CURRENT_TIMESTAMP. See issue #31. + Just tc | syntaxFragment == "CURRENT_TIMESTAMP" -> "(" <> syntaxFragment <> ")::" <> tc + Just tc -> "'" <> syntaxFragment <> "'::" <> tc + in Default dVal + where + -- NOTE(adn) We are unfortunately once again forced to copy and paste some code from beam-migrate. + -- In particular, `beam-migrate` wraps the returning 'QExpr' into a 'DefaultValue' newtype wrapper, + -- which only purpose is to define an instance for 'FieldReturnType' (cfr. + -- /Database.Beam.AutoMigrate.SQL.Tables/) and the underlying 'BeamSqlBackendExpressionSyntax' is used to + -- call 'columnSchemaSyntax', which is then used in /their own/ definition of `FieldSchema`, which we + -- don't follow. + -- NOTE(adn) It's unclear what \"t\" stands for here, probably \"TablePrefix\". Not documented in + -- `beam-migrate` itself. + defaultTo_ :: (forall s. QExpr Postgres s a) -> Pg.PgExpressionSyntax + defaultTo_ (Beam.QExpr e) = e "t" + +-- +-- Specifying uniqueness constraints +-- + +-- $specifyingTableConstraints +-- Is it possible to annotate an 'AnnotatedDatabaseEntity' with @UNIQUE@ and @FOREIGN KEY@ constraints. + +data UniqueConstraint (tbl :: ((* -> *) -> *)) where + -- | Use this to \"tag\" a standard Beam 'TableField' selector or 'PrimaryKey'. + U :: HasColumnNames entity tbl => (tbl (Beam.TableField tbl) -> entity) -> UniqueConstraint tbl + +-- | Given a list of 'TableField' selectors wrapped in a 'UniqueConstraint' type constructor, it adds +-- to the relevant 'AnnotatedDatabaseEntity' a new @UNIQUE@ 'TableConstraint' composed by /all/ the +-- fields specified. To put it differently, every call to 'uniqueConstraintOn' generates a /separate/ +-- @UNIQUE@ constraint composed by the listed fields. +-- If a 'PrimaryKey' is passed as input, it will desugar under the hood into as many columns as +-- the primary key refers to. +uniqueConstraintOn :: + [UniqueConstraint tbl] -> + EntityModification (AnnotatedDatabaseEntity be db) be (TableEntity tbl) +uniqueConstraintOn us = + EntityModification + ( Endo + ( \(AnnotatedDatabaseEntity tbl@(AnnotatedDatabaseTable {}) e) -> + AnnotatedDatabaseEntity + ( tbl + { dbAnnotatedConstraints = + let cols = concatMap (\case (U f) -> colNames (tableSettings e) f) us + tName = e ^. dbEntityDescriptor . dbEntityName + conname = T.intercalate "_" (tName : map columnName cols) <> "_ukey" + in S.insert (Unique conname (S.fromList cols)) (dbAnnotatedConstraints tbl) + } + ) + e + ) + ) + +-- +-- Specifying FK constrainst +-- + +data ForeignKeyConstraint (tbl :: ((* -> *) -> *)) (tbl' :: ((* -> *) -> *)) where + References :: + Beam.Beamable (PrimaryKey tbl') => + (tbl (Beam.TableField tbl) -> PrimaryKey tbl' (Beam.TableField tbl)) -> + (tbl' (Beam.TableField tbl') -> Beam.Columnar Beam.Identity (Beam.TableField tbl' ty)) -> + ForeignKeyConstraint tbl tbl' + +-- | Special-case combinator to use when defining FK constraints referencing the /primary key/ of the +-- target table. +foreignKeyOnPk :: + ( Beam.Beamable (PrimaryKey tbl'), + Beam.Beamable tbl', + Beam.Table tbl', + PrimaryKey tbl' f ~ PrimaryKey tbl' g + ) => + -- | The 'DatabaseEntity' of the /referenced/ table. + DatabaseEntity be db (TableEntity tbl') -> + -- | A function yielding a 'PrimaryKey'. This is usually a record field of the table + -- you want to define the FK /for/, and it must have /PrimaryKey externalTable f/ as + -- its column-tag. + (tbl (Beam.TableField tbl) -> PrimaryKey tbl' (Beam.TableField tbl)) -> + -- | What do to \"on delete\" + ReferenceAction -> + -- | What do to \"on update\" + ReferenceAction -> + EntityModification (AnnotatedDatabaseEntity be db) be (TableEntity tbl) +foreignKeyOnPk externalEntity ourColumn onDelete onUpdate = + EntityModification + ( Endo + ( \(AnnotatedDatabaseEntity tbl@(AnnotatedDatabaseTable {}) e) -> + AnnotatedDatabaseEntity + ( tbl + { dbAnnotatedConstraints = + let colPairs = + zipWith + (,) + (fieldAsColumnNames (ourColumn (tableSettings e))) + (fieldAsColumnNames (Beam.pk (tableSettings externalEntity))) + tName = externalEntity ^. dbEntityDescriptor . dbEntityName + conname = T.intercalate "_" (tName : map (columnName . snd) colPairs) <> "_fkey" + in S.insert + (ForeignKey conname (TableName tName) (S.fromList colPairs) onDelete onUpdate) + (dbAnnotatedConstraints tbl) + } + ) + e + ) + ) + +foreignKeyOn :: + Beam.Beamable tbl' => + DatabaseEntity be db (TableEntity tbl') -> + [ForeignKeyConstraint tbl tbl'] -> + -- | On Delete + ReferenceAction -> + -- | On Update + ReferenceAction -> + EntityModification (AnnotatedDatabaseEntity be db) be (TableEntity tbl) +foreignKeyOn externalEntity us onDelete onUpdate = + EntityModification + ( Endo + ( \(AnnotatedDatabaseEntity tbl@(AnnotatedDatabaseTable {}) e) -> + AnnotatedDatabaseEntity + ( tbl + { dbAnnotatedConstraints = + let colPairs = + concatMap + ( \case + (References ours theirs) -> + zipWith + (,) + (fieldAsColumnNames (ours (tableSettings e))) + [ColumnName (theirs (tableSettings externalEntity) ^. Beam.fieldName)] + ) + us + tName = externalEntity ^. dbEntityDescriptor . dbEntityName + conname = T.intercalate "_" (tName : map (columnName . snd) colPairs) <> "_fkey" + in S.insert + (ForeignKey conname (TableName tName) (S.fromList colPairs) onDelete onUpdate) + (dbAnnotatedConstraints tbl) + } + ) + e + ) + ) diff --git a/src/Database/Beam/AutoMigrate/BenchUtil.hs b/src/Database/Beam/AutoMigrate/BenchUtil.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/AutoMigrate/BenchUtil.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Database.Beam.AutoMigrate.BenchUtil + ( SpineStrict (..), + predictableSchemas, + connInfo, + setupDatabase, + cleanDatabase, + tearDownDatabase, + ) +where + +import Control.DeepSeq +import Control.Exception (finally) +import Data.ByteString (ByteString) +import Database.Beam.AutoMigrate +import Database.Beam.AutoMigrate.Schema.Gen (genSimilarSchemas) +import qualified Database.PostgreSQL.Simple as Pg +import System.Random.SplitMix (mkSMGen) +import Test.QuickCheck.Gen +import Test.QuickCheck.Random + +newtype SpineStrict = SS {unSS :: Diff} + +-- For us is enough to make the list of edits spine-strict. +instance NFData SpineStrict where + rnf (SS (Left e)) = rnf e + rnf (SS (Right edits)) = length edits `deepseq` () + +predictableSchemas :: Int -> IO (Schema, Schema) +predictableSchemas tableNum = do + let g = unGen genSimilarSchemas + let r = QCGen (mkSMGen 42) + return (g r tableNum) + +connInfo :: ByteString +connInfo = "host=localhost port=5432 dbname=beam-migrate-prototype-bench" + +setupDatabase :: Schema -> IO Pg.Connection +setupDatabase dbSchema = do + conn <- Pg.connectPostgreSQL connInfo + let mig = createMigration (diff dbSchema noSchema) + runMigrationUnsafe conn mig -- At this point the DB contains the full schema. + pure conn + +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 () + +tearDownDatabase :: Pg.Connection -> IO () +tearDownDatabase conn = cleanDatabase conn `finally` Pg.close conn diff --git a/src/Database/Beam/AutoMigrate/Compat.hs b/src/Database/Beam/AutoMigrate/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/AutoMigrate/Compat.hs @@ -0,0 +1,291 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This is a module which adapts and simplifies certain things normally provided by "beam-migrate", but +-- without the extra complication of importing and using the library itself. +module Database.Beam.AutoMigrate.Compat where + +import Data.Aeson (FromJSON, ToJSON) +import Data.ByteString (ByteString) +import Data.Int +import qualified Data.Map.Strict as M +import Data.Scientific (Scientific) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (LocalTime, TimeOfDay, UTCTime) +import Data.Time.Calendar (Day) +import Data.Typeable +import Data.UUID +import Data.Word +import qualified Database.Beam as Beam +import Database.Beam.AutoMigrate.Types +import qualified Database.Beam.AutoMigrate.Util as Util +import Database.Beam.Backend.SQL hiding (tableName) +import qualified Database.Beam.Backend.SQL.AST as AST +import qualified Database.Beam.Postgres as Pg + +-- +-- Specifying SQL data types and constraints +-- + +class HasColumnType ty where + -- | Provide a 'ColumnType' for the given type + defaultColumnType :: Proxy ty -> ColumnType + + defaultTypeCast :: Proxy ty -> Maybe Text + defaultTypeCast _ = Nothing + + -- | If @ty@ maps to a DB @ENUM@, use this method to specify which one. + defaultEnums :: Proxy ty -> Enumerations + defaultEnums _ = mempty + +class Ord (SchemaConstraint ty) => HasSchemaConstraints ty where + -- | Provide arbitrary constraints on a field of the requested type. + schemaConstraints :: Proxy ty -> Set (SchemaConstraint ty) + schemaConstraints _ = mempty + +class Ord (SchemaConstraint ty) => HasSchemaConstraints' (nullary :: Bool) ty where + schemaConstraints' :: Proxy nullary -> Proxy ty -> Set (SchemaConstraint ty) + +type family SchemaConstraint (k :: *) where + SchemaConstraint (Beam.TableEntity e) = TableConstraint + SchemaConstraint (Beam.TableField e t) = ColumnConstraint + +type family IsMaybe (k :: *) :: Bool where + IsMaybe (Maybe x) = 'True + IsMaybe (Beam.TableField t (Maybe x)) = 'True + IsMaybe (Beam.TableField t _) = 'False + IsMaybe _ = 'False + +-- Default /table-level/ constraints. +instance HasSchemaConstraints' 'True (Beam.TableEntity tbl) where + schemaConstraints' Proxy Proxy = mempty + +instance HasSchemaConstraints' 'False (Beam.TableEntity tbl) where + schemaConstraints' Proxy Proxy = mempty + +-- Default /field-level/ constraints. + +instance HasSchemaConstraints' 'True (Beam.TableField e (Beam.TableField e t)) where + schemaConstraints' Proxy Proxy = mempty + +instance HasSchemaConstraints' 'False (Beam.TableField e (Beam.TableField e t)) where + schemaConstraints' Proxy Proxy = S.singleton NotNull + +instance HasSchemaConstraints' 'True (Beam.TableField e (Maybe t)) where + schemaConstraints' Proxy Proxy = mempty + +instance HasSchemaConstraints' 'False (Beam.TableField e t) where + schemaConstraints' Proxy Proxy = S.singleton NotNull + +instance + ( IsMaybe a ~ nullary, + HasSchemaConstraints' nullary a + ) => + HasSchemaConstraints a + where + schemaConstraints = schemaConstraints' (Proxy :: Proxy nullary) + +-- +-- Generating \"companion\" sequences when particular types are used. +-- + +type family GeneratesSqlSequence ty where + GeneratesSqlSequence (SqlSerial a) = 'True + GeneratesSqlSequence _ = 'False + +class HasCompanionSequence' (generatesSeq :: Bool) ty where + hasCompanionSequence' :: + Proxy generatesSeq -> + Proxy ty -> + TableName -> + ColumnName -> + Maybe ((SequenceName, Sequence), ColumnConstraint) + +class HasCompanionSequence ty where + hasCompanionSequence :: + Proxy ty -> + TableName -> + ColumnName -> + Maybe ((SequenceName, Sequence), ColumnConstraint) + +instance + ( GeneratesSqlSequence ty ~ genSeq, + HasCompanionSequence' genSeq ty + ) => + HasCompanionSequence ty + where + hasCompanionSequence = hasCompanionSequence' (Proxy :: Proxy genSeq) + +instance HasCompanionSequence' 'False ty where + hasCompanionSequence' _ _ _ _ = Nothing + +-- +-- Sql datatype instances for the most common types. +-- + +instance HasColumnType ty => HasColumnType (Beam.TableField e ty) where + defaultColumnType _ = defaultColumnType (Proxy @ty) + defaultTypeCast _ = defaultTypeCast (Proxy @ty) + +instance HasColumnType ty => HasColumnType (Maybe ty) where + defaultColumnType _ = defaultColumnType (Proxy @ty) + defaultTypeCast _ = defaultTypeCast (Proxy @ty) + +instance HasColumnType Int where + defaultColumnType _ = SqlStdType intType + defaultTypeCast _ = Just "integer" + +instance HasColumnType Int32 where + defaultColumnType _ = SqlStdType intType + defaultTypeCast _ = Just "integer" + +instance HasColumnType Int16 where + defaultColumnType _ = SqlStdType intType + defaultTypeCast _ = Just "integer" + +instance HasColumnType Int64 where + defaultColumnType _ = SqlStdType bigIntType + defaultTypeCast _ = Just "bigint" + +instance HasColumnType Word where + defaultColumnType _ = SqlStdType $ numericType (Just (10, Nothing)) + defaultTypeCast _ = Just "numeric" + +instance HasColumnType Word16 where + defaultColumnType _ = SqlStdType $ numericType (Just (5, Nothing)) + defaultTypeCast _ = Just "numeric" + +instance HasColumnType Word32 where + defaultColumnType _ = SqlStdType $ numericType (Just (10, Nothing)) + defaultTypeCast _ = Just "numeric" + +instance HasColumnType Word64 where + defaultColumnType _ = SqlStdType $ numericType (Just (20, Nothing)) + defaultTypeCast _ = Just "numeric" + +instance HasColumnType Text where + defaultColumnType _ = SqlStdType $ varCharType Nothing Nothing + defaultTypeCast _ = Just "character varying" + +instance HasColumnType SqlBitString where + defaultColumnType _ = SqlStdType $ varBitType Nothing + defaultTypeCast _ = Just "bit" + +instance HasColumnType ByteString where + defaultColumnType _ = SqlStdType AST.DataTypeBinaryLargeObject + +instance HasColumnType Double where + defaultColumnType _ = SqlStdType doubleType + defaultTypeCast _ = Just "double precision" + +instance HasColumnType Scientific where + defaultColumnType _ = SqlStdType $ numericType (Just (20, Just 10)) + defaultTypeCast _ = Just "numeric" + +instance HasColumnType Day where + defaultColumnType _ = SqlStdType dateType + defaultTypeCast _ = Just "date" + +instance HasColumnType TimeOfDay where + defaultColumnType _ = SqlStdType $ timeType Nothing False + defaultTypeCast _ = Just "time without time zone" + +instance HasColumnType Bool where + defaultColumnType _ = SqlStdType booleanType + defaultTypeCast _ = Just "boolean" + +instance HasColumnType LocalTime where + defaultColumnType _ = SqlStdType $ timestampType Nothing False + defaultTypeCast _ = Just "timestamp without time zone" + +instance HasColumnType UTCTime where + defaultColumnType _ = SqlStdType $ timestampType Nothing True + defaultTypeCast _ = Just "timestamp with time zone" + +instance HasColumnType UUID where + defaultColumnType _ = PgSpecificType PgUuid + defaultTypeCast _ = Just "uuid" + +-- +-- support for json types +-- + +instance (FromJSON a, ToJSON a) => HasColumnType (Pg.PgJSON a) where + defaultColumnType _ = PgSpecificType PgJson + +instance (FromJSON a, ToJSON a) => HasColumnType (Pg.PgJSONB a) where + defaultColumnType _ = PgSpecificType PgJsonB + +-- +-- support for pg range types +-- + +instance HasColumnType (Pg.PgRange Pg.PgInt4Range a) where + defaultColumnType _ = PgSpecificType PgRangeInt4 + +instance HasColumnType (Pg.PgRange Pg.PgInt8Range a) where + defaultColumnType _ = PgSpecificType PgRangeInt8 + +instance HasColumnType (Pg.PgRange Pg.PgNumRange a) where + defaultColumnType _ = PgSpecificType PgRangeNum + +instance HasColumnType (Pg.PgRange Pg.PgTsRange a) where + defaultColumnType _ = PgSpecificType PgRangeTs + +instance HasColumnType (Pg.PgRange Pg.PgTsTzRange a) where + defaultColumnType _ = PgSpecificType PgRangeTsTz + +instance HasColumnType (Pg.PgRange Pg.PgDateRange a) where + defaultColumnType _ = PgSpecificType PgRangeDate + +-- +-- Support for 'SqlSerial'. \"SERIAL\" is treated by Postgres as syntactic sugar for: +--- +-- CREATE SEQUENCE tablename_colname_seq; +-- CREATE TABLE tablename ( +-- colname integer DEFAULT nextval('tablename_colname_seq') NOT NULL +-- ); +-- +-- Historically this was treated as a richer type (i.e. a 'PgSpecificType PgSerial') which had the advantage +-- of being able, for example, to track down when a column type changed so that we were able to drop the +-- relevant sequence if needed. However, this created problems when reconciling the 'Schema' type with the +-- one from the DB in case this type appeared \"behind\" a 'PrimaryKey' constraint. In that case it appeared +-- in the 'Schema' as a 'PgSerial' but in reality that should have been simply an integer. This led to the +-- creation of an auxiliary \"companion type\" concept which was making the overall complication ever so +-- slightly more complicated. Using just 'intType' here simplifies everything, at the cost of not-so-precise +-- \"resource tracking\" (i.e. created-but-now-unused requences remains in the DB). +instance (Integral ty, HasColumnType ty) => HasColumnType (SqlSerial ty) where + defaultColumnType _ = defaultColumnType (Proxy @ty) + +instance HasCompanionSequence' 'True (SqlSerial a) where + hasCompanionSequence' Proxy Proxy tName cname = + let s@(SequenceName sname) = mkSeqName + in Just ((s, Sequence tName cname), Default ("nextval('" <> Util.sqlEscaped sname <> "'::regclass)")) + where + mkSeqName :: SequenceName + mkSeqName = SequenceName (tableName tName <> "___" <> columnName cname <> "___seq") + +-- +-- support for enum types +-- + +instance (Show a, Typeable a, Enum a, Bounded a) => HasColumnType (PgEnum a) where + defaultColumnType (Proxy :: (Proxy (PgEnum a))) = + -- Postgres converts enumeration types to lowercase, so we need to call 'toLower' here. + PgSpecificType (PgEnumeration $ EnumerationName (T.toLower . T.pack $ showsTypeRep (typeRep (Proxy @a)) mempty)) + + defaultEnums p@(Proxy :: (Proxy (PgEnum a))) = + let (PgSpecificType (PgEnumeration ty)) = defaultColumnType p + vals = Enumeration $ map (T.pack . show) ([minBound .. maxBound] :: [a]) + in M.singleton ty vals + +-- For now a `DbEnum` is isomorphic to a `varCharType`, as we don't have enough information on the Postgres +-- side to reconstruct the enumerated values. +instance (Show a, Typeable a, Enum a, Bounded a) => HasColumnType (DbEnum a) where + defaultColumnType _ = SqlStdType $ varCharType Nothing Nothing + defaultTypeCast _ = Just "character varying" diff --git a/src/Database/Beam/AutoMigrate/Diff.hs b/src/Database/Beam/AutoMigrate/Diff.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/AutoMigrate/Diff.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} + +module Database.Beam.AutoMigrate.Diff + ( Diffable (..), + Diff, + Priority (..), + WithPriority (..), + + -- * Reference implementation, for model-testing purposes + diffColumnReferenceImplementation, + diffTablesReferenceImplementation, + diffTableReferenceImplementation, + diffReferenceImplementation, + + -- * Hopefully-efficient implementation + diffColumn, + diffTables, + diffTable, + sortEdits, + ) +where + +import Control.Exception (assert) +import Control.Monad +import Data.DList (DList) +import qualified Data.DList as D +import Data.Foldable (foldlM) +import Data.List (foldl', (\\)) +import qualified Data.List as L +import Data.Map.Merge.Strict +import qualified Data.Map.Strict as M +import Data.Maybe +import qualified Data.Set as S +import Data.Text (Text) +import Data.Word (Word8) +import Database.Beam.AutoMigrate.Types + +-- +-- Simple typeclass to diff things +-- + +-- | Some notion of 'Priority'. The lower the value, the higher the priority. +newtype Priority = Priority Word8 deriving (Show, Eq, Ord) + +newtype WithPriority a = WithPriority {unPriority :: (a, Priority)} deriving (Show, Eq, Ord) + +editPriority :: EditAction -> Priority +editPriority = \case + -- Operations that create tables, sequences or enums have top priority + EnumTypeAdded {} -> Priority 0 + SequenceAdded {} -> Priority 1 + TableAdded {} -> Priority 2 + -- We cannot create a column if the relevant table (or enum type) is not there. + ColumnAdded {} -> Priority 3 + -- Operations that set constraints or change the shape of a type have lower priority + ColumnTypeChanged {} -> Priority 4 + EnumTypeValueAdded {} -> Priority 5 + -- foreign keys need to go last, as the referenced columns needs to be either UNIQUE or have PKs. + TableConstraintAdded _ Unique {} -> Priority 6 + TableConstraintAdded _ PrimaryKey {} -> Priority 7 + TableConstraintAdded _ ForeignKey {} -> Priority 8 + ColumnConstraintAdded {} -> Priority 9 + TableConstraintRemoved {} -> Priority 10 + ColumnConstraintRemoved {} -> Priority 11 + -- Destructive operations go last + ColumnRemoved {} -> Priority 12 + TableRemoved {} -> Priority 13 + EnumTypeRemoved {} -> Priority 14 + SequenceRemoved {} -> Priority 15 + +-- TODO: This needs to support adding conditional queries. +mkEdit :: EditAction -> WithPriority Edit +mkEdit e = WithPriority (defMkEdit e, editPriority e) + +-- | Sort edits according to their execution order, to make sure they don't reference +-- something which hasn't been created yet. +sortEdits :: [WithPriority Edit] -> [WithPriority Edit] +sortEdits = L.sortOn (snd . unPriority) + +type DiffA t = Either DiffError (t (WithPriority Edit)) + +type Diff = DiffA [] + +-- NOTE(adn) Accumulate all the errors independently instead of short circuiting? +class Diffable a where + diff :: a -> a -> Diff + +-- | Computes the diff between two 'Schema's, either failing with a 'DiffError' +-- or returning the list of 'Edit's necessary to turn the first into the second. +instance Diffable Schema where + diff hsSchema dbSchema = do + tableDiffs <- diff (schemaTables hsSchema) (schemaTables dbSchema) + enumDiffs <- diff (schemaEnumerations hsSchema) (schemaEnumerations dbSchema) + sequenceDiffs <- diff (schemaSequences hsSchema) (schemaSequences dbSchema) + pure $ tableDiffs <> enumDiffs <> sequenceDiffs + +instance Diffable Tables where + diff t1 = fmap D.toList . diffTables t1 + +instance Diffable Enumerations where + diff e1 = fmap D.toList . diffEnums e1 + +instance Diffable Sequences where + diff s1 = fmap D.toList . diffSequences s1 + +-- +-- Reference implementation +-- + +diffReferenceImplementation :: Schema -> Schema -> Diff +diffReferenceImplementation hsSchema = diff (schemaTables hsSchema) . schemaTables + +-- | A slow but hopefully correct implementation of the diffing algorithm, for QuickCheck comparison with +-- more sophisticated ones. +diffTablesReferenceImplementation :: Tables -> Tables -> Diff +diffTablesReferenceImplementation hsTables dbTables = do + let tablesAdded = M.difference hsTables dbTables + tablesRemoved = M.difference dbTables hsTables + diffableTables = M.intersection hsTables dbTables + diffableTables' = M.intersection dbTables hsTables + whenBoth <- foldlM go mempty (zip (M.toList diffableTables) (M.toList diffableTables')) + pure $ whenAdded tablesAdded <> whenRemoved tablesRemoved <> whenBoth + where + whenAdded :: Tables -> [WithPriority Edit] + whenAdded = concatMap (addEdit TableAdded TableConstraintAdded tableConstraints) . M.toList + + whenRemoved :: Tables -> [WithPriority Edit] + whenRemoved = + concatMap (addEdit (\k _ -> TableRemoved k) TableConstraintRemoved tableConstraints) . M.toList + + go :: [WithPriority Edit] -> ((TableName, Table), (TableName, Table)) -> Diff + go e ((hsName, hsTable), (dbName, dbTable)) = assert (hsName == dbName) $ do + d <- diffTableReferenceImplementation hsName hsTable dbTable + pure $ e <> d + +addEdit :: + (k -> v -> EditAction) -> + (k -> c -> EditAction) -> + (v -> S.Set c) -> + (k, v) -> + [WithPriority Edit] +addEdit onValue onConstr getConstr (k, v) = + mkEdit (onValue k v) : map (mkEdit . onConstr k) (S.toList $ getConstr v) + +diffTableReferenceImplementation :: TableName -> Table -> Table -> Diff +diffTableReferenceImplementation tName hsTable dbTable = do + let constraintsAdded = S.difference (tableConstraints hsTable) (tableConstraints dbTable) + constraintsRemoved = S.difference (tableConstraints dbTable) (tableConstraints hsTable) + columnsAdded = M.difference (tableColumns hsTable) (tableColumns dbTable) + columnsRemoved = M.difference (tableColumns dbTable) (tableColumns hsTable) + diffableColumns = M.intersection (tableColumns hsTable) (tableColumns dbTable) + diffableColumns' = M.intersection (tableColumns dbTable) (tableColumns hsTable) + whenBoth <- foldlM go mempty (zip (M.toList diffableColumns) (M.toList diffableColumns')) + let tblConstraintsAdded = do + guard (not $ S.null constraintsAdded) + pure $ map (mkEdit . TableConstraintAdded tName) (S.toList constraintsAdded) + let tblConstraintsRemoved = do + guard (not $ S.null constraintsRemoved) + pure $ map (mkEdit . TableConstraintRemoved tName) (S.toList constraintsRemoved) + let colsAdded = whenAdded columnsAdded + let colsRemoved = whenRemoved columnsRemoved + pure $ + join (catMaybes [tblConstraintsAdded, tblConstraintsRemoved]) + <> colsAdded + <> colsRemoved + <> whenBoth + where + go :: [WithPriority Edit] -> ((ColumnName, Column), (ColumnName, Column)) -> Diff + go e ((hsName, hsCol), (dbName, dbCol)) = assert (hsName == dbName) $ do + d <- diffColumnReferenceImplementation tName hsName hsCol dbCol + pure $ e <> d + + whenAdded :: Columns -> [WithPriority Edit] + whenAdded = + concatMap (addEdit (ColumnAdded tName) (ColumnConstraintAdded tName) columnConstraints) . M.toList + + whenRemoved :: Columns -> [WithPriority Edit] + whenRemoved = + concatMap (addEdit (\k _ -> ColumnRemoved tName k) (ColumnConstraintRemoved tName) columnConstraints) . M.toList + +diffColumnReferenceImplementation :: TableName -> ColumnName -> Column -> Column -> Diff +diffColumnReferenceImplementation tName colName hsColumn dbColumn = do + let constraintsAdded = S.difference (columnConstraints hsColumn) (columnConstraints dbColumn) + constraintsRemoved = S.difference (columnConstraints dbColumn) (columnConstraints hsColumn) + let colConstraintsAdded = do + guard (not $ S.null constraintsAdded) + pure $ map (mkEdit . ColumnConstraintAdded tName colName) (S.toList constraintsAdded) + let colConstraintsRemoved = do + guard (not $ S.null constraintsRemoved) + pure $ map (mkEdit . ColumnConstraintRemoved tName colName) (S.toList constraintsRemoved) + let typeChanged = do + guard (columnType hsColumn /= columnType dbColumn) + pure [mkEdit $ ColumnTypeChanged tName colName (columnType dbColumn) (columnType hsColumn)] + pure $ join $ catMaybes [colConstraintsAdded, colConstraintsRemoved, typeChanged] + +-- +-- Actual implementation +-- + +-- +-- Diffing enums together +-- + +diffEnums :: Enumerations -> Enumerations -> DiffA DList +diffEnums hsEnums dbEnums = + M.foldl' D.append mempty <$> mergeA whenEnumsAdded whenEnumsRemoved whenBoth hsEnums dbEnums + where + whenEnumsAdded :: WhenMissing (Either DiffError) EnumerationName Enumeration (DList (WithPriority Edit)) + whenEnumsAdded = traverseMissing (\k v -> Right . D.singleton . mkEdit $ EnumTypeAdded k v) + + whenEnumsRemoved :: WhenMissing (Either DiffError) EnumerationName Enumeration (DList (WithPriority Edit)) + whenEnumsRemoved = traverseMissing (\k _ -> Right . D.singleton . mkEdit $ EnumTypeRemoved k) + + whenBoth :: WhenMatched (Either DiffError) EnumerationName Enumeration Enumeration (DList (WithPriority Edit)) + whenBoth = zipWithAMatched diffEnumeration + +diffEnumeration :: EnumerationName -> Enumeration -> Enumeration -> DiffA DList +diffEnumeration eName (Enumeration hsEnum) (Enumeration dbEnum) = do + let valuesRemoved = dbEnum \\ hsEnum + if L.null valuesRemoved then Right $ D.fromList (computeEnumEdit eName hsEnum dbEnum) else Left $ ValuesRemovedFromEnum eName valuesRemoved + +computeEnumEdit :: EnumerationName -> [Text] -> [Text] -> [WithPriority Edit] +computeEnumEdit _ [] [] = mempty +computeEnumEdit _ [] (_ : _) = mempty +computeEnumEdit eName (x : xs) [] = appendAfter eName xs x +computeEnumEdit eName (x : xs) [y] = + if x == y + then appendAfter eName xs y + else mkEdit (EnumTypeValueAdded eName x Before y) : computeEnumEdit eName xs [y] +computeEnumEdit eName (x : xs) (y : ys) = + if x == y + then computeEnumEdit eName xs ys + else mkEdit (EnumTypeValueAdded eName x Before y) : computeEnumEdit eName xs (y : ys) + +appendAfter :: EnumerationName -> [Text] -> Text -> [WithPriority Edit] +appendAfter _ [] _ = mempty +appendAfter eName [l] z = [mkEdit $ EnumTypeValueAdded eName l After z] +appendAfter eName (l : ls) z = mkEdit (EnumTypeValueAdded eName l After z) : appendAfter eName ls l + +-- +-- Diffing sequences together +-- + +diffSequences :: Sequences -> Sequences -> DiffA DList +diffSequences hsSeqs dbSeqs = + M.foldl' D.append mempty <$> mergeA whenSeqsAdded whenSeqsRemoved whenBoth hsSeqs dbSeqs + where + whenSeqsAdded :: WhenMissing (Either DiffError) SequenceName Sequence (DList (WithPriority Edit)) + whenSeqsAdded = traverseMissing (\k v -> Right . D.singleton . mkEdit $ SequenceAdded k v) + + whenSeqsRemoved :: WhenMissing (Either DiffError) SequenceName Sequence (DList (WithPriority Edit)) + whenSeqsRemoved = traverseMissing (\k _ -> Right . D.singleton . mkEdit $ SequenceRemoved k) + + -- Currently a 'Sequence' doesn't carry any extra information, so diffing two 'Sequence's is + -- a no-op, basically. + whenBoth :: WhenMatched (Either DiffError) SequenceName Sequence Sequence (DList (WithPriority Edit)) + whenBoth = zipWithAMatched (\_ (Sequence _ _) (Sequence _ _) -> Right mempty) + +-- +-- Diffing tables together +-- + +diffTables :: Tables -> Tables -> DiffA DList +diffTables hsTables dbTables = + M.foldl' D.append mempty <$> mergeA whenTablesAdded whenTablesRemoved whenBoth hsTables dbTables + where + whenTablesAdded :: WhenMissing (Either DiffError) TableName Table (DList (WithPriority Edit)) + whenTablesAdded = + traverseMissing + ( \k v -> do + let created = mkEdit $ TableAdded k v + let constraintsAdded = map (mkEdit . TableConstraintAdded k) (S.toList $ tableConstraints v) + pure $ D.fromList (created : constraintsAdded) + ) + + whenTablesRemoved :: WhenMissing (Either DiffError) TableName Table (DList (WithPriority Edit)) + whenTablesRemoved = + traverseMissing + ( \k v -> do + let removed = mkEdit $ TableRemoved k + let constraintsRemoved = map (mkEdit . TableConstraintRemoved k) (S.toList $ tableConstraints v) + pure $ D.fromList (removed : constraintsRemoved) + ) + + whenBoth :: WhenMatched (Either DiffError) TableName Table Table (DList (WithPriority Edit)) + whenBoth = zipWithAMatched diffTable + +diffTable :: TableName -> Table -> Table -> DiffA DList +diffTable tName hsTable dbTable = do + let constraintsAdded = S.difference (tableConstraints hsTable) (tableConstraints dbTable) + constraintsRemoved = S.difference (tableConstraints dbTable) (tableConstraints hsTable) + tblConstraintsAdded = do + guard (not $ S.null constraintsAdded) + pure $ D.map (mkEdit . TableConstraintAdded tName) (D.fromList . S.toList $ constraintsAdded) + tblConstraintsRemoved = do + guard (not $ S.null constraintsRemoved) + pure $ D.map (mkEdit . TableConstraintRemoved tName) (D.fromList . S.toList $ constraintsRemoved) + diffs <- + M.foldl' D.append mempty + <$> mergeA whenColumnAdded whenColumnRemoved whenBoth (tableColumns hsTable) (tableColumns dbTable) + pure $ foldl' D.append D.empty (catMaybes [tblConstraintsAdded, tblConstraintsRemoved]) <> diffs + where + whenColumnAdded :: WhenMissing (Either DiffError) ColumnName Column (DList (WithPriority Edit)) + whenColumnAdded = + traverseMissing + ( \k v -> do + let added = mkEdit $ ColumnAdded tName k v + let constraintsAdded = map (mkEdit . ColumnConstraintAdded tName k) (S.toList $ columnConstraints v) + pure $ D.fromList (added : constraintsAdded) + ) + + whenColumnRemoved :: WhenMissing (Either DiffError) ColumnName Column (DList (WithPriority Edit)) + whenColumnRemoved = + traverseMissing + ( \k v -> do + let removed = mkEdit $ ColumnRemoved tName k + let constraintsRemoved = map (mkEdit . ColumnConstraintRemoved tName k) (S.toList $ columnConstraints v) + pure $ D.fromList (removed : constraintsRemoved) + ) + + whenBoth :: WhenMatched (Either DiffError) ColumnName Column Column (DList (WithPriority Edit)) + whenBoth = zipWithAMatched (diffColumn tName) + +diffColumn :: TableName -> ColumnName -> Column -> Column -> DiffA DList +diffColumn tName colName hsColumn dbColumn = do + let constraintsAdded = S.difference (columnConstraints hsColumn) (columnConstraints dbColumn) + constraintsRemoved = S.difference (columnConstraints dbColumn) (columnConstraints hsColumn) + let colConstraintsAdded = do + guard (not $ S.null constraintsAdded) + pure $ D.map (mkEdit . ColumnConstraintAdded tName colName) (D.fromList . S.toList $ constraintsAdded) + let colConstraintsRemoved = do + guard (not $ S.null constraintsRemoved) + pure $ D.map (mkEdit . ColumnConstraintRemoved tName colName) (D.fromList . S.toList $ constraintsRemoved) + let typeChanged = do + guard (columnType hsColumn /= columnType dbColumn) + pure $ D.singleton (mkEdit $ ColumnTypeChanged tName colName (columnType dbColumn) (columnType hsColumn)) + pure $ foldl' D.append D.empty $ catMaybes [colConstraintsAdded, colConstraintsRemoved, typeChanged] diff --git a/src/Database/Beam/AutoMigrate/Generic.hs b/src/Database/Beam/AutoMigrate/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/AutoMigrate/Generic.hs @@ -0,0 +1,559 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} + +module Database.Beam.AutoMigrate.Generic where + +import Data.Bifunctor +import Data.Kind +import qualified Data.List as L +import qualified Data.Map.Strict as M +import Data.Proxy +import qualified Data.Set as S +import Database.Beam.AutoMigrate.Annotated +import Database.Beam.AutoMigrate.Compat +import Database.Beam.AutoMigrate.Types +import Database.Beam.AutoMigrate.Util (pkFieldNames) +import Database.Beam.Schema (PrimaryKey, TableEntity) +import qualified Database.Beam.Schema as Beam +import Database.Beam.Schema.Tables (Beamable (..), dbEntityDescriptor, dbEntityName) +import GHC.Generics +import GHC.TypeLits +import Lens.Micro ((^.)) + +-- +--- Machinery to derive a 'Schema' from a 'DatabaseSettings'. +-- + +class GSchema be db (anns :: [Annotation]) (x :: * -> *) where + gSchema :: AnnotatedDatabaseSettings be db -> Proxy anns -> x p -> Schema + +-- Table-specific classes + +class GTables be db (anns :: [Annotation]) (x :: * -> *) where + gTables :: AnnotatedDatabaseSettings be db -> Proxy anns -> x p -> (Tables, Sequences) + +class GTableEntry (be :: *) (db :: DatabaseKind) (anns :: [Annotation]) (tableFound :: Bool) (x :: * -> *) where + gTableEntries :: + AnnotatedDatabaseSettings be db -> + Proxy anns -> + Proxy tableFound -> + x p -> + ([(TableName, Table)], Sequences) + +class GTable be db (x :: * -> *) where + gTable :: AnnotatedDatabaseSettings be db -> x p -> Table + +-- Enumerations-specific classes + +class GEnums be db x where + gEnums :: AnnotatedDatabaseSettings be db -> x p -> Enumerations + +-- Column-specific classes + +-- | Type-level witness of whether or not we have to generate an extra \"SEQUENCE\" in case the table +-- field is a 'SqlSerial'. +data GenSequencesForSerial + = GenSequences + | NoGenSequences + +class GColumns (genSeqs :: GenSequencesForSerial) (x :: * -> *) where + gColumns :: Proxy genSeqs -> TableName -> x p -> (Columns, Sequences) + +class GTableConstraintColumns be db x where + gTableConstraintsColumns :: AnnotatedDatabaseSettings be db -> TableName -> x p -> S.Set TableConstraint + +-- +-- Deriving information about 'Schema's +-- + +instance GSchema be db anns x => GSchema be db anns (D1 f x) where + gSchema db p (M1 x) = gSchema db p x + +instance + ( Constructor f, + GTables be db anns x, + GEnums be db x + ) => + GSchema be db anns (C1 f x) + where + gSchema db p (M1 x) = + let (tables, sequences) = gTables db p x + in Schema + { schemaTables = tables, + schemaEnumerations = gEnums db x, + schemaSequences = sequences + } + +-- +-- Deriving information about 'Enums'. +-- + +instance GEnums be db x => GEnums be db (D1 f x) where + gEnums db (M1 x) = gEnums db x + +instance GEnums be db x => GEnums be db (C1 f x) where + gEnums db (M1 x) = gEnums db x + +instance (GEnums be db a, GEnums be db b) => GEnums be db (a :*: b) where + gEnums db (a :*: b) = gEnums db a <> gEnums db b + +instance + ( IsAnnotatedDatabaseEntity be (TableEntity tbl), + Beam.Table tbl, + GEnums be db (Rep (TableSchema tbl)), + Generic (TableSchema tbl) + ) => + GEnums be db (S1 f (K1 R (AnnotatedDatabaseEntity be db (TableEntity tbl)))) + where + gEnums db (M1 (K1 annEntity)) = + gEnums db (from (dbAnnotatedSchema (annEntity ^. annotatedDescriptor))) + +instance + {-# OVERLAPS #-} + (GEnums be db (Rep (sub f)), Generic (sub f)) => + GEnums be db (S1 m (K1 R (sub f))) + where + gEnums db (M1 (K1 e)) = gEnums db (from e) + +instance HasColumnType ty => GEnums be db (S1 f (K1 R (TableFieldSchema tbl ty))) where + gEnums _ (M1 (K1 _)) = defaultEnums (Proxy @ty) + +-- primary-key-wrapped types do not yield any enumerations. + +instance GEnums be db (S1 f (K1 R (PrimaryKey tbl1 (TableFieldSchema tbl2)))) where + gEnums _ (M1 (K1 _)) = mempty + +instance GEnums be db (S1 f (K1 R (PrimaryKey tbl1 (g (TableFieldSchema tbl2))))) where + gEnums _ (M1 (K1 _)) = mempty + +-- +-- Deriving information about 'Table's. +-- + +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 + in (M.fromList tbls, sqs) + +instance GTableEntry be db anns tableFound x => GTableEntry be db anns tableFound (S1 f x) where + gTableEntries db p1 p2 (M1 x) = gTableEntries db p1 p2 x + +instance (GTables be db anns a, GTables be db anns b) => GTables be db anns (a :*: b) where + gTables db p (a :*: b) = gTables db p a <> gTables db p b + +mkTableEntryNoFkDiscovery :: + ( GColumns 'GenSequences (Rep (TableSchema tbl)), + Generic (TableSchema tbl), + Beam.Table tbl + ) => + AnnotatedDatabaseEntity be db (TableEntity tbl) -> + ((TableName, Table), Sequences) +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) + annotatedCons = dbAnnotatedConstraints (annEntity ^. annotatedDescriptor) + in ((TableName tName, Table (pks <> annotatedCons) columns), seqs) + +mkTableEntryFkDiscovery :: + ( GColumns 'GenSequences (Rep (TableSchema tbl)), + Generic (TableSchema tbl), + Beam.Table tbl, + GTableConstraintColumns be db (Rep (TableSchema tbl)) + ) => + AnnotatedDatabaseSettings be db -> + AnnotatedDatabaseEntity be db (TableEntity tbl) -> + ((TableName, Table), Sequences) +mkTableEntryFkDiscovery db annEntity = + let ((tName, table), seqs) = mkTableEntryNoFkDiscovery annEntity + discoveredCons = + gTableConstraintsColumns db tName . from $ dbAnnotatedSchema (annEntity ^. annotatedDescriptor) + in ((tName, table {tableConstraints = discoveredCons <> tableConstraints table}), seqs) + +-- +-- Automatic FK-discovery algorithm starts here +-- +-- The general idea is to carry around a (tableFound :: Bool) type-level witness to be used as we uncons +-- the type-level list. If we find a match, we toggle-off the FK-discovery algorithm, otherwise we don't. + +instance + ( GColumns 'GenSequences (Rep (TableSchema tbl)), + Generic (TableSchema tbl), + Beam.Table tbl, + GTableEntry be db xs (TestTableEqual tbl tbl') (K1 R (AnnotatedDatabaseEntity be db (TableEntity tbl))) + ) => + GTableEntry be db (UserDefinedFk tbl' ': xs) 'False (K1 R (AnnotatedDatabaseEntity be db (TableEntity tbl))) + where + gTableEntries _ _ _ (K1 annEntity) = first (: []) (mkTableEntryNoFkDiscovery annEntity) + +instance + ( GColumns 'GenSequences (Rep (TableSchema tbl)), + Generic (TableSchema tbl), + Beam.Table tbl + ) => + GTableEntry be db (UserDefinedFk tbl' ': xs) 'True (K1 R (AnnotatedDatabaseEntity be db (TableEntity tbl))) + where + gTableEntries _ _ _ (K1 annEntity) = first (: []) (mkTableEntryNoFkDiscovery annEntity) + +-- At this point we explored the full list and the previous equality check yielded 'True, which means a +-- match was found. We disable the FK-discovery algorithm. + +instance + ( IsAnnotatedDatabaseEntity be (TableEntity tbl), + GColumns 'GenSequences (Rep (TableSchema tbl)), + Generic (TableSchema tbl), + Beam.Table tbl + ) => + GTableEntry be db '[] 'True (K1 R (AnnotatedDatabaseEntity be db (TableEntity tbl))) + where + gTableEntries _ _ _ (K1 annEntity) = first (: []) (mkTableEntryNoFkDiscovery annEntity) + +-- At this point we explored the full list and the previous equality check yielded 'False, so we kickoff the +-- automatic FK-discovery algorithm. + +instance + ( IsAnnotatedDatabaseEntity be (TableEntity tbl), + GColumns 'GenSequences (Rep (TableSchema tbl)), + Generic (TableSchema tbl), + Beam.Table tbl, + GTableConstraintColumns be db (Rep (TableSchema tbl)) + ) => + GTableEntry be db '[] 'False (K1 R (AnnotatedDatabaseEntity be db (TableEntity tbl))) + where + gTableEntries db Proxy Proxy (K1 annEntity) = first (: []) (mkTableEntryFkDiscovery db annEntity) + +-- sub-db support for GTableEntry + +instance + ( Generic (innerDB (AnnotatedDatabaseEntity be outerDB)), + Beam.Database be innerDB, + GTableEntry be outerDB xs found (Rep (innerDB (AnnotatedDatabaseEntity be outerDB))) + ) => + GTableEntry be outerDB xs found (K1 R (innerDB (AnnotatedDatabaseEntity be outerDB))) + where + gTableEntries outerDB p1 p2 (K1 innerDB) = + gTableEntries outerDB p1 p2 (from innerDB) + +instance GTableEntry be outerDB xs found x => GTableEntry be outerDB xs found (D1 f x) where + gTableEntries outerDB p1 p2 (M1 x) = gTableEntries outerDB p1 p2 x + +instance GTableEntry be outerDB xs found x => GTableEntry be outerDB xs found (C1 f x) where + gTableEntries outerDB p1 p2 (M1 x) = gTableEntries outerDB p1 p2 x + +instance + (GTableEntry be outerDB xs found a, GTableEntry be outerDB xs found b) => + GTableEntry be outerDB xs found (a :*: b) + where + gTableEntries outerDB p1 p2 (a :*: b) = + gTableEntries outerDB p1 p2 a <> gTableEntries outerDB p1 p2 b + +-- end of sub-db support for GTableEntry + +instance GColumns gseq x => GColumns gseq (D1 f x) where + gColumns p t (M1 x) = gColumns p t x + +instance GTableConstraintColumns be db x => GTableConstraintColumns be db (D1 f x) where + gTableConstraintsColumns db tbl (M1 x) = gTableConstraintsColumns db tbl x + +instance GColumns gseq x => GColumns gseq (C1 f x) where + gColumns p t (M1 x) = gColumns p t x + +instance GTableConstraintColumns be db x => GTableConstraintColumns be db (C1 f x) where + gTableConstraintsColumns db tbl (M1 x) = gTableConstraintsColumns db tbl x + +instance (GColumns p a, GColumns p b) => GColumns p (a :*: b) where + gColumns p t (a :*: b) = gColumns p t a <> gColumns p t b + +instance (GTableConstraintColumns be db a, GTableConstraintColumns be db b) => GTableConstraintColumns be db (a :*: b) where + gTableConstraintsColumns db tbl (a :*: b) = S.union (gTableConstraintsColumns db tbl a) (gTableConstraintsColumns db tbl b) + +-- +-- Column entries +-- + +instance HasCompanionSequence ty => GColumns 'GenSequences (S1 m (K1 R (TableFieldSchema tbl ty))) where + gColumns Proxy t (M1 (K1 (TableFieldSchema name (FieldSchema ty constr)))) = + case hasCompanionSequence (Proxy @ty) t name of + Nothing -> + (M.singleton name (Column ty constr), mempty) + Just (sq, extraDefault) -> + (M.singleton name (Column ty (S.insert extraDefault constr)), uncurry M.singleton sq) + +instance GColumns 'NoGenSequences (S1 m (K1 R (TableFieldSchema tbl ty))) where + gColumns Proxy _ (M1 (K1 (TableFieldSchema name (FieldSchema ty constr)))) = + (M.singleton name (Column ty constr), mempty) + +gColumnsPK :: + TableName -> + S1 m (K1 R (TableFieldSchema tbl ty)) p -> + (Columns, Sequences) +gColumnsPK _ (M1 (K1 (TableFieldSchema name (FieldSchema ty constr)))) = + (M.singleton name (Column ty constr), mempty) + +instance + {-# OVERLAPS #-} + ( GColumns p (Rep (sub f)), + Generic (sub f) + ) => + GColumns p (S1 m (K1 R (sub f))) + where + gColumns p t (M1 (K1 e)) = gColumns p t (from e) + +-- If a PrimaryKey is referenced in another table, we do not want to recreate the \"SEQUENCE\" and +-- \"nextval\" default constraint associated with the original field. +instance + ( GColumns 'NoGenSequences (Rep (PrimaryKey tbl f)), + Generic (PrimaryKey tbl f), + Beamable (PrimaryKey tbl) + ) => + GColumns x (S1 m (K1 R (PrimaryKey tbl f))) + where + gColumns _ t (M1 (K1 e)) = gColumns (Proxy @NoGenSequences) t (from e) + +instance GTableConstraintColumns be db (S1 m (K1 R (TableFieldSchema tbl ty))) where + gTableConstraintsColumns _db _tbl (M1 (K1 _)) = S.empty + +instance + {-# OVERLAPS #-} + ( Generic (AnnotatedDatabaseSettings be db), + Generic (sub f), + GColumns 'GenSequences (Rep (sub f)), + GTableConstraintColumns be db (Rep (sub f)) + ) => + GTableConstraintColumns be db (S1 m (K1 R (sub f))) + where + gTableConstraintsColumns db tname (M1 (K1 e)) = + gTableConstraintsColumns db tname (from e) + +instance + ( Generic (AnnotatedDatabaseSettings be db), + Generic (PrimaryKey tbl f), + GColumns 'NoGenSequences (Rep (PrimaryKey tbl f)), + GTableLookupSettings sel tbl (Rep (AnnotatedDatabaseSettings be db)), + m ~ MetaSel sel su ss ds + ) => + GTableConstraintColumns be db (S1 m (K1 R (PrimaryKey tbl f))) + where + gTableConstraintsColumns db (TableName tname) (M1 (K1 e)) = + case cnames of + [] -> S.empty -- TODO: if for whatever reason we have no columns in our key, we don't generate a constraint + ColumnName cname : _ -> + S.singleton + ( ForeignKey + (tname <> "_" <> cname <> "_fkey") + reftname + (S.fromList (zip (L.sort cnames) (L.sort refcnames))) + NoAction -- TODO: what should the default be? + NoAction -- TODO: what should the default be? + ) + where + cnames :: [ColumnName] + cnames = M.keys $ fst (gColumns (Proxy @NoGenSequences) (TableName tname) (from e)) + + reftname :: TableName + refcnames :: [ColumnName] + (reftname, refcnames) = gTableLookupSettings (Proxy @sel) (Proxy @tbl) (from db) + +-- We want a type class for the table lookup, because we want to return a +-- value-level table name based on the database settings! + +-- | Lookup a table by type in the given DB settings. +-- +-- The selector name is only provided for error messages. +-- +-- Only returns if the table type is unique. +-- Returns the table name and the column names of its primary key. +class GTableLookupSettings (sel :: Maybe Symbol) (tbl :: TableKind) x where + gTableLookupSettings :: Proxy sel -> Proxy tbl -> x p -> (TableName, [ColumnName]) + +-- | Helper class that takes an additional continuation parameter 'k'. +-- +-- We treat 'k' as a type-level stack with 'U1' being the empty stack and +-- ':*:' used right-associatively to place items onto the stack. +-- +-- The reason we do not use a type-level list here is that we also need +-- a term-level representation of the continuation, and we already have +-- suitable inhabitants for 'U1' and ':*:'. +class GTableLookupTables (sel :: Maybe Symbol) (tbl :: TableKind) (x :: Type -> Type) (k :: Type -> Type) where + gTableLookupTables :: Proxy sel -> Proxy tbl -> x p -> k p -> (TableName, [ColumnName]) + +-- | We use this function to continue searching once we've already found +-- a match, and to abort if we find a second match. +class GTableLookupTablesExpectFail (sel :: Maybe Symbol) (tbl :: TableKind) (x :: Type -> Type) (k :: Type -> Type) where + gTableLookupTablesExpectFail :: Proxy sel -> Proxy tbl -> (TableName, [ColumnName]) -> x p -> k p -> (TableName, [ColumnName]) + +instance + (GTableLookupSettings sel tbl x) => + GTableLookupSettings sel tbl (D1 f x) + where + gTableLookupSettings sel tbl (M1 x) = gTableLookupSettings sel tbl x + +instance + (GTableLookupTables sel tbl x U1) => + GTableLookupSettings sel tbl (C1 f x) + where + gTableLookupSettings sel tbl (M1 x) = gTableLookupTables sel tbl x U1 + +instance + (GTableLookupTables sel tbl x k) => + GTableLookupTables sel tbl (S1 f x) k + where + gTableLookupTables sel tbl (M1 x) = gTableLookupTables sel tbl x + +instance + ( GTableLookupTables sel tbl a (b :*: k) + ) => + GTableLookupTables sel tbl (a :*: b) k + where + gTableLookupTables sel tbl (a :*: b) k = gTableLookupTables sel tbl a (b :*: k) + +instance + (GTableLookupTablesExpectFail sel tbl x k) => + GTableLookupTablesExpectFail sel tbl (S1 f x) k + where + gTableLookupTablesExpectFail sel tbl r (M1 x) = gTableLookupTablesExpectFail sel tbl r x + +instance + ( GTableLookupTablesExpectFail sel tbl a (b :*: k) + ) => + GTableLookupTablesExpectFail sel tbl (a :*: b) k + where + gTableLookupTablesExpectFail sel tbl r (a :*: b) k = gTableLookupTablesExpectFail sel tbl r a (b :*: k) + +instance + ( GTableLookupTable (TestTableEqual tbl tbl') sel tbl k, + Beamable tbl', + Beam.Table tbl' + ) => + GTableLookupTables sel tbl (K1 R (AnnotatedDatabaseEntity be db (TableEntity tbl'))) k + where + gTableLookupTables sel tbl (K1 annEntity) k = + let entity = annEntity ^. deannotate + tname = entity ^. dbEntityDescriptor . dbEntityName + cnames = pkFieldNames entity + in gTableLookupTable (Proxy @(TestTableEqual tbl tbl')) sel tbl (TableName tname, cnames) k + +-- sub-db support for GTableLookupTables + +instance + ( GTableLookupTables sel tbl (Rep (innerDB (AnnotatedDatabaseEntity be outerDB))) k, + Beam.Database be innerDB, + Generic (innerDB (AnnotatedDatabaseEntity be outerDB)) + ) => + GTableLookupTables sel tbl (K1 R (innerDB (AnnotatedDatabaseEntity be outerDB))) k + where + gTableLookupTables sel tbl (K1 subDB) k = + gTableLookupTables sel tbl (from subDB) k + +instance GTableLookupTables sel tbl x k => GTableLookupTables sel tbl (D1 f x) k where + gTableLookupTables sel tbl (M1 x) k = gTableLookupTables sel tbl x k + +instance GTableLookupTables sel tbl x k => GTableLookupTables sel tbl (C1 f x) k where + gTableLookupTables sel tbl (M1 x) k = gTableLookupTables sel tbl x k + +-- end of sub-db support for GTableLookupTables + +instance + ( GTableLookupTableExpectFail (TestTableEqual tbl tbl') sel tbl k, + Beamable tbl' + ) => + GTableLookupTablesExpectFail sel tbl (K1 R (AnnotatedDatabaseEntity be db (TableEntity tbl'))) k + where + gTableLookupTablesExpectFail sel tbl r (K1 _entity) = + gTableLookupTableExpectFail (Proxy @(TestTableEqual tbl tbl')) sel tbl r + +-- sub-db support for GTableLookupTablesExpectFail + +instance + ( GTableLookupTablesExpectFail sel tbl (Rep (innerDb (AnnotatedDatabaseEntity be outerDb))) k, + Generic (innerDb (AnnotatedDatabaseEntity be outerDb)), + Beam.Database be innerDb + ) => + GTableLookupTablesExpectFail sel tbl (K1 R (innerDb (AnnotatedDatabaseEntity be outerDb))) k + where + gTableLookupTablesExpectFail sel tbl r (K1 subDB) = + gTableLookupTablesExpectFail sel tbl r (from subDB) + +instance + ( GTableLookupTablesExpectFail sel tbl x k + ) => + GTableLookupTablesExpectFail sel tbl (D1 f x) k + where + gTableLookupTablesExpectFail sel tbl r (M1 x) = + gTableLookupTablesExpectFail sel tbl r x + +instance + ( GTableLookupTablesExpectFail sel tbl x k + ) => + GTableLookupTablesExpectFail sel tbl (C1 f x) k + where + gTableLookupTablesExpectFail sel tbl r (M1 x) = + gTableLookupTablesExpectFail sel tbl r x + +-- end of sub-db support for GTableLookupTablesExpectFail + +type family TestTableEqual (tbl1 :: TableKind) (tbl2 :: TableKind) :: Bool where + TestTableEqual tbl tbl = True + TestTableEqual _ _ = False + +class GTableLookupTable (b :: Bool) (sel :: Maybe Symbol) (tbl :: TableKind) (k :: Type -> Type) where + gTableLookupTable :: Proxy b -> Proxy sel -> Proxy tbl -> (TableName, [ColumnName]) -> k p -> (TableName, [ColumnName]) + +class GTableLookupTableExpectFail (b :: Bool) (sel :: Maybe Symbol) (tbl :: TableKind) (k :: Type -> Type) where + gTableLookupTableExpectFail :: Proxy b -> Proxy sel -> Proxy tbl -> (TableName, [ColumnName]) -> k p -> (TableName, [ColumnName]) + +instance GTableLookupTable True sel tbl U1 where + gTableLookupTable _ _ _ r _ = r + +type LookupAmbiguous (sel :: Maybe Symbol) (tbl :: TableKind) = + Text "Could not derive foreign key constraint for " :<>: ShowField sel :<>: Text "," + :$$: Text "because there are several tables of type `" :<>: ShowType tbl :<>: Text "' in the schema." + :$$: Text "In this scenario you have to manually disable the FK-discovery algorithm for all the tables " + :$$: Text "hit by such ambiguity, for example by creating your Schema via: " + :$$: Text "" + :$$: Text "fromAnnotatedDbSettings annotatedDB (Proxy @'[ 'UserDefinedFk TBL1, 'UserDefinedFk TBL2, .. ])" + :$$: Text "" + :$$: Text "Where `TBL1..n` are types referencing " :<>: ShowType tbl :<>: Text " in the schema." + :$$: Text "Once done that, you can explicitly provide manual FKs for the tables by using `foreignKeyOnPk` " + :$$: Text "when annotating your `DatabaseSettings`." + +type LookupFailed (sel :: Maybe Symbol) (tbl :: TableKind) = + Text "Could not derive foreign key constraint for " :<>: ShowField sel :<>: Text "," + :$$: Text "because there are no tables of type `" :<>: ShowType tbl :<>: Text "' in the schema." + :$$: Text "This might be because this particular " :<>: ShowField sel :<>: Text " doesn't appear anywhere " + :$$: Text "in your database, so the FK-discovery mechanism doesn't know how to reach it. Please note that " + :$$: Text "in presence of nested databases there might be more than one field with the same name referencing " + :$$: Text "different things. You might want to check you are adding or targeting the correct one." + +type family ShowField (sel :: Maybe Symbol) :: ErrorMessage where + ShowField Nothing = Text "unnamed field" + ShowField (Just sel) = Text "field `" :<>: Text sel :<>: Text "'" + +instance TypeError (LookupAmbiguous sel tbl) => GTableLookupTableExpectFail True sel tbl k where + gTableLookupTableExpectFail _ _ _ _ _ = error "impossible" + +instance (GTableLookupTablesExpectFail sel tbl k ks) => GTableLookupTable True sel tbl (k :*: ks) where + gTableLookupTable _ sel tbl r (k :*: ks) = gTableLookupTablesExpectFail sel tbl r k ks + +instance TypeError (LookupFailed sel tbl) => GTableLookupTable False sel tbl U1 where + gTableLookupTable _ _ _ _ = error "impossible" + +instance GTableLookupTableExpectFail False sel tbl U1 where + gTableLookupTableExpectFail _ _ _ r _ = r + +instance (GTableLookupTablesExpectFail sel tbl k ks) => GTableLookupTableExpectFail False sel tbl (k :*: ks) where + gTableLookupTableExpectFail _ sel tbl r (k :*: ks) = gTableLookupTablesExpectFail sel tbl r k ks + +instance GTableLookupTables sel tbl k ks => GTableLookupTable False sel tbl (k :*: ks) where + gTableLookupTable _ sel tbl _ (k :*: ks) = + gTableLookupTables sel tbl k ks diff --git a/src/Database/Beam/AutoMigrate/Postgres.hs b/src/Database/Beam/AutoMigrate/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/AutoMigrate/Postgres.hs @@ -0,0 +1,522 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Database.Beam.AutoMigrate.Postgres + ( getSchema, + ) +where + +import Control.Monad.State +import Data.Bits (shiftR, (.&.)) +import Data.ByteString (ByteString) +import Data.Foldable (asum, foldlM) +import Data.Map (Map) +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) +import Data.Set (Set) +import qualified Data.Set as S +import Data.String +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Vector as V +import Database.Beam.AutoMigrate.Types +import Database.Beam.Backend.SQL hiding (tableName) +import qualified Database.Beam.Backend.SQL.AST as AST +import qualified Database.PostgreSQL.Simple as Pg +import Database.PostgreSQL.Simple.FromField (FromField (..), fromField) +import Database.PostgreSQL.Simple.FromRow (FromRow (..), field) +import qualified Database.PostgreSQL.Simple.TypeInfo.Static as Pg +import qualified Database.PostgreSQL.Simple.Types as Pg + +-- +-- Necessary types to make working with the underlying raw SQL a bit more pleasant +-- + +data SqlRawOtherConstraintType + = SQL_raw_pk + | SQL_raw_unique + deriving (Show, Eq) + +data SqlOtherConstraint = SqlOtherConstraint + { sqlCon_name :: Text, + sqlCon_constraint_type :: SqlRawOtherConstraintType, + sqlCon_table :: TableName, + sqlCon_fk_colums :: V.Vector ColumnName + } + deriving (Show, Eq) + +instance Pg.FromRow SqlOtherConstraint where + fromRow = + SqlOtherConstraint <$> field + <*> field + <*> fmap TableName field + <*> fmap (V.map ColumnName) field + +data SqlForeignConstraint = SqlForeignConstraint + { sqlFk_foreign_table :: TableName, + sqlFk_primary_table :: TableName, + -- | The columns in the /foreign/ table. + sqlFk_fk_columns :: V.Vector ColumnName, + -- | The columns in the /current/ table. + sqlFk_pk_columns :: V.Vector ColumnName, + sqlFk_name :: Text + } + deriving (Show, Eq) + +instance Pg.FromRow SqlForeignConstraint where + fromRow = + SqlForeignConstraint <$> fmap TableName field + <*> fmap TableName field + <*> fmap (V.map ColumnName) field + <*> fmap (V.map ColumnName) field + <*> field + +instance FromField TableName where + fromField f dat = TableName <$> fromField f dat + +instance FromField ColumnName where + fromField f dat = ColumnName <$> fromField f dat + +instance FromField SqlRawOtherConstraintType where + fromField f dat = do + t <- fromField f dat + case t of + "p" -> pure SQL_raw_pk + "u" -> pure SQL_raw_unique + _ -> fail ("Unexpected costraint type: " <> t) + +-- +-- Postgres queries to extract the schema out of the DB +-- + +-- | A SQL query to select all user's queries, skipping any beam-related tables (i.e. leftovers from +-- beam-migrate, for example). +userTablesQ :: Pg.Query +userTablesQ = + fromString $ + unlines + [ "SELECT cl.oid, relname FROM pg_catalog.pg_class \"cl\" join pg_catalog.pg_namespace \"ns\" ", + "on (ns.oid = relnamespace) where nspname = any (current_schemas(false)) and relkind='r' ", + "and relname NOT LIKE 'beam_%'" + ] + +-- | Get information about default values for /all/ tables. +defaultsQ :: Pg.Query +defaultsQ = + fromString $ + unlines + [ "SELECT col.table_name::text, col.column_name::text, col.column_default::text, col.data_type::text ", + "FROM information_schema.columns col ", + "WHERE col.column_default IS NOT NULL ", + "AND col.table_schema NOT IN('information_schema', 'pg_catalog') ", + "ORDER BY col.table_name" + ] + +-- | Get information about columns for this table. Due to the fact this is a query executed for /each/ +-- table, is important this is as light as possible to keep the performance decent. +tableColumnsQ :: Pg.Query +tableColumnsQ = + fromString $ + unlines + [ "SELECT attname, atttypid, atttypmod, attnotnull, pg_catalog.format_type(atttypid, atttypmod) ", + "FROM pg_catalog.pg_attribute att ", + "WHERE att.attrelid=? AND att.attnum>0 AND att.attisdropped='f' " + ] + +-- | Get the enumeration data for all enum types in the database. +enumerationsQ :: Pg.Query +enumerationsQ = + fromString $ + unlines + [ "SELECT t.typname, t.oid, array_agg(e.enumlabel ORDER BY e.enumsortorder)", + "FROM pg_enum e JOIN pg_type t ON t.oid = e.enumtypid", + "GROUP BY t.typname, t.oid" + ] + +-- | Get the sequence data for all sequence types in the database. +sequencesQ :: Pg.Query +sequencesQ = fromString "SELECT c.relname FROM pg_class c WHERE c.relkind = 'S'" + +-- | Return all foreign key constraints for /all/ 'Table's. +foreignKeysQ :: Pg.Query +foreignKeysQ = + fromString $ + 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,", + " kcu.constraint_name as cname", + "FROM information_schema.table_constraints tco", + "JOIN information_schema.key_column_usage kcu", + " on tco.constraint_schema = kcu.constraint_schema", + " and tco.constraint_name = kcu.constraint_name", + "JOIN information_schema.referential_constraints rco", + " on tco.constraint_schema = rco.constraint_schema", + " and tco.constraint_name = rco.constraint_name", + "JOIN information_schema.key_column_usage rel_kcu", + " on rco.unique_constraint_schema = rel_kcu.constraint_schema", + " and rco.unique_constraint_name = rel_kcu.constraint_name", + " and kcu.ordinal_position = rel_kcu.ordinal_position", + "GROUP BY foreign_table, primary_table, cname" + ] + +-- | Return /all other constraints that are not FKs/ (i.e. 'PRIMARY KEY', 'UNIQUE', etc) for all the tables. +otherConstraintsQ :: Pg.Query +otherConstraintsQ = + fromString $ + unlines + [ "SELECT c.conname AS constraint_name,", + " c.contype AS constraint_type,", + " tbl.relname AS \"table\",", + " ARRAY_AGG(col.attname ORDER BY u.attposition) AS columns", + "FROM pg_constraint c", + " JOIN LATERAL UNNEST(c.conkey) WITH ORDINALITY AS u(attnum, attposition) ON TRUE", + " JOIN pg_class tbl ON tbl.oid = c.conrelid", + " JOIN pg_namespace sch ON sch.oid = tbl.relnamespace", + " JOIN pg_attribute col ON (col.attrelid = tbl.oid AND col.attnum = u.attnum)", + "WHERE c.contype = 'u' OR c.contype = 'p'", + "GROUP BY constraint_name, constraint_type, \"table\"", + "ORDER BY c.contype" + ] + +-- | Return all \"action types\" for /all/ the constraints. +referenceActionsQ :: Pg.Query +referenceActionsQ = + fromString $ + unlines + [ "SELECT c.conname, c. confdeltype, c.confupdtype FROM ", + "(SELECT r.conrelid, r.confrelid, unnest(r.conkey) AS conkey, unnest(r.confkey) AS confkey, r.conname, r.confupdtype, r.confdeltype ", + "FROM pg_catalog.pg_constraint r WHERE r.contype = 'f') AS c ", + "INNER JOIN pg_attribute a_parent ON a_parent.attnum = c.confkey AND a_parent.attrelid = c.confrelid ", + "INNER JOIN pg_class cl_parent ON cl_parent.oid = c.confrelid ", + "INNER JOIN pg_namespace sch_parent ON sch_parent.oid = cl_parent.relnamespace ", + "INNER JOIN pg_attribute a_child ON a_child.attnum = c.conkey AND a_child.attrelid = c.conrelid ", + "INNER JOIN pg_class cl_child ON cl_child.oid = c.conrelid ", + "INNER JOIN pg_namespace sch_child ON sch_child.oid = cl_child.relnamespace ", + "WHERE sch_child.nspname = current_schema() ORDER BY c.conname " + ] + +-- | Connects to a running PostgreSQL database and extract the relevant 'Schema' out of it. +getSchema :: Pg.Connection -> IO Schema +getSchema conn = do + allTableConstraints <- getAllConstraints conn + allDefaults <- getAllDefaults conn + enumerationData <- Pg.fold_ conn enumerationsQ mempty getEnumeration + sequences <- Pg.fold_ conn sequencesQ mempty getSequence + tables <- + Pg.fold_ conn userTablesQ mempty (getTable allDefaults enumerationData allTableConstraints) + pure $ Schema tables (M.fromList $ M.elems enumerationData) sequences + where + getEnumeration :: + Map Pg.Oid (EnumerationName, Enumeration) -> + (Text, Pg.Oid, V.Vector Text) -> + IO (Map Pg.Oid (EnumerationName, Enumeration)) + getEnumeration allEnums (enumName, oid, V.toList -> vals) = + pure $ M.insert oid (EnumerationName enumName, Enumeration vals) allEnums + + getSequence :: + Sequences -> + Pg.Only Text -> + IO Sequences + getSequence allSeqs (Pg.Only seqName) = + case T.splitOn "___" seqName of + [tName, cName, "seq"] -> + pure $ M.insert (SequenceName seqName) (Sequence (TableName tName) (ColumnName cName)) allSeqs + _ -> pure allSeqs + + getTable :: + AllDefaults -> + Map Pg.Oid (EnumerationName, Enumeration) -> + AllTableConstraints -> + Tables -> + (Pg.Oid, Text) -> + IO Tables + getTable allDefaults enumData allTableConstraints allTables (oid, TableName -> tName) = do + pgColumns <- Pg.query conn tableColumnsQ (Pg.Only oid) + newTable <- + Table (fromMaybe noTableConstraints (M.lookup tName allTableConstraints)) + <$> foldlM (getColumns tName enumData allDefaults) mempty pgColumns + pure $ M.insert tName newTable allTables + + getColumns :: + TableName -> + Map Pg.Oid (EnumerationName, Enumeration) -> + AllDefaults -> + Columns -> + (ByteString, Pg.Oid, Int, Bool, ByteString) -> + IO Columns + getColumns tName enumData defaultData c (attname, atttypid, atttypmod, attnotnull, format_type) = do + -- /NOTA BENE(adn)/: The atttypmod - 4 was originally taken from 'beam-migrate' + -- (see: https://github.com/tathougies/beam/blob/d87120b58373df53f075d92ce12037a98ca709ab/beam-postgres/Database/Beam/Postgres/Migrate.hs#L343) + -- but there are cases where this is not correct, for example in the case of bitstrings. + -- See for example: https://stackoverflow.com/questions/52376045/why-does-atttypmod-differ-from-character-maximum-length + let mbPrecision = + if + | atttypmod == -1 -> Nothing + | Pg.typoid Pg.bit == atttypid -> Just atttypmod + | Pg.typoid Pg.varbit == atttypid -> Just atttypmod + | otherwise -> Just (atttypmod - 4) + + let columnName = ColumnName (TE.decodeUtf8 attname) + + let mbDefault = do + x <- M.lookup tName defaultData + M.lookup columnName x + + case asum + [ pgSerialTyColumnType atttypid mbDefault, + pgTypeToColumnType atttypid mbPrecision, + pgEnumTypeToColumnType enumData atttypid + ] of + Just cType -> do + let nullConstraint = if attnotnull then S.fromList [NotNull] else mempty + let inferredConstraints = nullConstraint <> fromMaybe mempty (S.singleton <$> mbDefault) + let newColumn = Column cType inferredConstraints + pure $ M.insert columnName newColumn c + Nothing -> + fail $ + "Couldn't convert pgType " + <> show format_type + <> " of field " + <> show attname + <> " into a valid ColumnType." + +-- +-- Postgres type mapping +-- + +pgEnumTypeToColumnType :: + Map Pg.Oid (EnumerationName, Enumeration) -> + Pg.Oid -> + Maybe ColumnType +pgEnumTypeToColumnType enumData oid = + (\(n, _) -> PgSpecificType (PgEnumeration n)) <$> M.lookup oid enumData + +pgSerialTyColumnType :: + Pg.Oid -> + Maybe ColumnConstraint -> + Maybe ColumnType +pgSerialTyColumnType oid (Just (Default d)) = do + guard $ (Pg.typoid Pg.int4 == oid && "nextval" `T.isInfixOf` d && "seq" `T.isInfixOf` d) + pure $ SqlStdType intType +pgSerialTyColumnType _ _ = Nothing + +-- | Tries to convert from a Postgres' 'Oid' into 'ColumnType'. +-- Mostly taken from [beam-migrate](Database.Beam.Postgres.Migrate). +pgTypeToColumnType :: Pg.Oid -> Maybe Int -> Maybe ColumnType +pgTypeToColumnType oid width + | Pg.typoid Pg.int2 == oid = + Just (SqlStdType smallIntType) + | Pg.typoid Pg.int4 == oid = + Just (SqlStdType intType) + | Pg.typoid Pg.int8 == oid = + Just (SqlStdType bigIntType) + | Pg.typoid Pg.bpchar == oid = + Just (SqlStdType $ charType (fromIntegral <$> width) Nothing) + | Pg.typoid Pg.varchar == oid = + Just (SqlStdType $ varCharType (fromIntegral <$> width) Nothing) + | Pg.typoid Pg.bit == oid = + Just (SqlStdType $ bitType (fromIntegral <$> width)) + | Pg.typoid Pg.varbit == oid = + Just (SqlStdType $ varBitType (fromIntegral <$> width)) + | Pg.typoid Pg.numeric == oid = + let decimals = fromMaybe 0 width .&. 0xFFFF + prec = (fromMaybe 0 width `shiftR` 16) .&. 0xFFFF + in case (prec, decimals) of + (0, 0) -> Just (SqlStdType $ numericType Nothing) + (p, 0) -> Just (SqlStdType $ numericType $ Just (fromIntegral p, Nothing)) + _ -> Just (SqlStdType $ numericType (Just (fromIntegral prec, Just (fromIntegral decimals)))) + | Pg.typoid Pg.float4 == oid = + Just (SqlStdType realType) + | Pg.typoid Pg.float8 == oid = + Just (SqlStdType doubleType) + | Pg.typoid Pg.date == oid = + Just (SqlStdType dateType) + | Pg.typoid Pg.text == oid = + Just (SqlStdType characterLargeObjectType) + -- I am not sure if this is a bug in beam-core, but both 'characterLargeObjectType' and 'binaryLargeObjectType' + -- get mapped into 'AST.DataTypeCharacterLargeObject', which yields TEXT, whereas we want the latter to + -- yield bytea. + | Pg.typoid Pg.bytea == oid = + Just (SqlStdType AST.DataTypeBinaryLargeObject) + | Pg.typoid Pg.bool == oid = + Just (SqlStdType booleanType) + | Pg.typoid Pg.time == oid = + Just (SqlStdType $ timeType Nothing False) + | Pg.typoid Pg.timestamp == oid = + Just (SqlStdType $timestampType Nothing False) + | Pg.typoid Pg.timestamptz == oid = + Just (SqlStdType $ timestampType Nothing True) + | Pg.typoid Pg.json == oid = + -- json types + Just (PgSpecificType PgJson) + | Pg.typoid Pg.jsonb == oid = + Just (PgSpecificType PgJsonB) + -- range types + | Pg.typoid Pg.int4range == oid = + Just (PgSpecificType PgRangeInt4) + | Pg.typoid Pg.int8range == oid = + Just (PgSpecificType PgRangeInt8) + | Pg.typoid Pg.numrange == oid = + Just (PgSpecificType PgRangeNum) + | Pg.typoid Pg.tsrange == oid = + Just (PgSpecificType PgRangeTs) + | Pg.typoid Pg.tstzrange == oid = + Just (PgSpecificType PgRangeTsTz) + | Pg.typoid Pg.daterange == oid = + Just (PgSpecificType PgRangeDate) + | Pg.typoid Pg.uuid == oid = + Just (PgSpecificType PgUuid) + | otherwise = + Nothing + +-- +-- Constraints discovery +-- + +type AllTableConstraints = Map TableName (Set TableConstraint) + +type AllDefaults = Map TableName Defaults + +type Defaults = Map ColumnName ColumnConstraint + +-- Get all defaults values for /all/ the columns. +-- FIXME(adn) __IMPORTANT:__ This function currently __always_ attach an explicit type annotation to the +-- default value, by reading its 'date_type' field, to resolve potential ambiguities. +-- The reason for this is that we cannot reliably guarantee a convertion between default values are read +-- by postgres and values we infer on the Schema side (using the 'beam-core' machinery). In theory we +-- wouldn't need to explicitly annotate the types before generating a 'Default' constraint on the 'Schema' +-- side, but this doesn't always work. For example, if we **always** specify a \"::numeric\" annotation for +-- an 'Int', Postgres might yield \"-1::integer\" for non-positive values and simply \"-1\" for all the rest. +-- To complicate the situation /even if/ we explicitly specify the cast +-- (i.e. \"SET DEFAULT '?::character varying'), Postgres will ignore this when reading the default back. +-- What we do here is obviously not optimal, but on the other hand it's not clear to me how to solve this +-- in a meaningful and non-invasive way, for a number of reasons: +-- + +-- * For example \"beam-migrate"\ seems to resort to be using explicit serialisation for the types, although + +-- I couldn't find explicit trace if that applies for defaults explicitly. +-- (cfr. the \"Database.Beam.AutoMigrate.Serialization\" module in \"beam-migrate\"). +-- + +-- * Another big problem is __rounding__: For example if we insert as \"double precision\" the following: + +-- Default "'-0.22030397057804563'" , Postgres will round the value and return Default "'-0.220303970578046'". +-- Again, it's not clear to me how to prevent the users from shooting themselves here. +-- + +-- * Another quirk is with dates: \"beam\" renders a date like \'1864-05-10\' (note the single quotes) but + +-- Postgres strip those when reading the default value back. +-- + +-- * Range types are also tricky to infer. 'beam-core' escapes the range type name when rendering its default + +-- value, whereas Postgres annotates each individual field and yield the unquoted identifier. Compare: +-- 1. Beam: \""numrange"(0, 2, '[)')\" +-- 2. Postgres: \"numrange((0)::numeric, (2)::numeric, '[)'::text)\" +-- +getAllDefaults :: Pg.Connection -> IO AllDefaults +getAllDefaults conn = Pg.fold_ conn defaultsQ mempty (\acc -> pure . addDefault acc) + where + addDefault :: AllDefaults -> (TableName, ColumnName, Text, Text) -> AllDefaults + addDefault m (tName, colName, defValue, dataType) = + let cleanedDefault = case T.breakOn "::" defValue of + (uncasted, defMb) + | T.null defMb -> + "'" <> T.dropAround ((==) '\'') uncasted <> "'::" <> dataType + _ -> defValue + entry = M.singleton colName (Default cleanedDefault) + in M.alter + ( \case + Nothing -> Just entry + Just ss -> Just $ ss <> entry + ) + tName + m + +getAllConstraints :: Pg.Connection -> IO AllTableConstraints +getAllConstraints conn = do + allActions <- mkActions <$> Pg.query_ conn referenceActionsQ + allForeignKeys <- Pg.fold_ conn foreignKeysQ mempty (\acc -> pure . addFkConstraint allActions acc) + Pg.fold_ conn otherConstraintsQ allForeignKeys (\acc -> pure . addOtherConstraint acc) + where + addFkConstraint :: + ReferenceActions -> + AllTableConstraints -> + SqlForeignConstraint -> + AllTableConstraints + addFkConstraint actions st SqlForeignConstraint {..} = flip execState st $ do + let currentTable = sqlFk_foreign_table + let columnSet = S.fromList $ zip (V.toList sqlFk_fk_columns) (V.toList sqlFk_pk_columns) + let (onDelete, onUpdate) = + case M.lookup sqlFk_name (getActions actions) of + Nothing -> (NoAction, NoAction) + Just a -> (actionOnDelete a, actionOnUpdate a) + addTableConstraint currentTable (ForeignKey sqlFk_name sqlFk_primary_table columnSet onDelete onUpdate) + + addOtherConstraint :: + AllTableConstraints -> + SqlOtherConstraint -> + AllTableConstraints + addOtherConstraint st SqlOtherConstraint {..} = flip execState st $ do + let currentTable = sqlCon_table + 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) + +newtype ReferenceActions = ReferenceActions {getActions :: Map Text Actions} + +newtype RefEntry = RefEntry {unRefEntry :: (Text, ReferenceAction, ReferenceAction)} + +mkActions :: [RefEntry] -> ReferenceActions +mkActions = ReferenceActions . M.fromList . map ((\(a, b, c) -> (a, Actions b c)) . unRefEntry) + +instance Pg.FromRow RefEntry where + fromRow = + fmap + RefEntry + ( (,,) <$> field + <*> fmap mkAction field + <*> fmap mkAction field + ) + +data Actions = Actions + { actionOnDelete :: ReferenceAction, + actionOnUpdate :: ReferenceAction + } + +mkAction :: Text -> ReferenceAction +mkAction c = case c of + "a" -> NoAction + "r" -> Restrict + "c" -> Cascade + "n" -> SetNull + "d" -> SetDefault + _ -> error . T.unpack $ "unknown reference action type: " <> c + +-- +-- Useful combinators to add constraints for a column or table if already there. +-- + +addTableConstraint :: + TableName -> + TableConstraint -> + State AllTableConstraints () +addTableConstraint tName cns = + modify' + ( M.alter + ( \case + Nothing -> Just $ S.singleton cns + Just ss -> Just $ S.insert cns ss + ) + tName + ) diff --git a/src/Database/Beam/AutoMigrate/Schema/Gen.hs b/src/Database/Beam/AutoMigrate/Schema/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/AutoMigrate/Schema/Gen.hs @@ -0,0 +1,526 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Database.Beam.AutoMigrate.Schema.Gen + ( genSchema, + genSimilarSchemas, + SimilarSchemas (..), + shrinkSchema, + ) +where + +import Control.Monad +import Control.Monad.State.Strict +import Data.Foldable (foldlM) +import Data.Functor ((<&>)) +import Data.Functor.Identity +import Data.Int (Int16, Int32, Int64) +import qualified Data.Map.Strict as M +import Data.Proxy +import Data.Scientific (Scientific, scientific) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (Day, LocalTime, TimeOfDay) +import Data.Word +import Database.Beam.AutoMigrate (HasColumnType, defaultColumnType, sqlSingleQuoted) +import Database.Beam.AutoMigrate.Annotated (pgDefaultConstraint) +import Database.Beam.AutoMigrate.Types +import Database.Beam.Backend.SQL (HasSqlValueSyntax, timestampType) +import qualified Database.Beam.Backend.SQL.AST as AST +import Database.Beam.Backend.SQL.Types (SqlSerial (..)) +import qualified Database.Beam.Postgres as Pg +import qualified Database.Beam.Postgres.Syntax as Pg +import Database.Beam.Query (currentTimestamp_, val_) +import GHC.Generics +import Test.QuickCheck +import Test.QuickCheck.Instances.Time () +import Text.Printf (printf) + +-- +-- Arbitrary instances +-- + +instance Arbitrary Schema where + arbitrary = genSchema + shrink = shrinkSchema + +newtype SimilarSchemas = SimilarSchemas {unSchemas :: (Schema, Schema)} + deriving (Generic, Show) + +instance Arbitrary SimilarSchemas where + arbitrary = SimilarSchemas <$> genSimilarSchemas + shrink = genericShrink + +-- +-- Generators +-- + +genAlphaName :: Gen Text +genAlphaName = T.pack <$> vectorOf 10 (elements $ ['a' .. 'z'] ++ ['A' .. 'Z']) + +genName :: (Text -> a) -> Gen a +genName f = f <$> genAlphaName + +genTableName :: Gen TableName +genTableName = genName TableName + +genColumnName :: Gen ColumnName +genColumnName = genName ColumnName + +-- | Generates a \"UNIQUE\" constraint. Restricts the eligible columns to only the ones which has +-- \"standard\" SQL types, to avoid the complication of dealing with indexes. For example trying to use +-- a JSON column would have Postgres fail with an error like: +-- \"[..]data type json has no default operator class for access method btree[..]\" +genUniqueConstraint :: Columns -> Gen (Set TableConstraint) +genUniqueConstraint allCols = do + someCols <- map fst . filter isStdType . take 32 <$> listOf1 (elements $ M.toList allCols) -- indexes are capped to 32 colums. + case someCols of + [] -> pure mempty + _ -> do + constraintName <- runIdentity <$> genName Identity + pure $ S.singleton $ Unique (constraintName <> "_unique") (S.fromList someCols) + +isStdType :: (ColumnName, Column) -> Bool +isStdType (_, columnType -> SqlStdType _) = True +isStdType _ = False + +-- Generate a PK constraint. +-- /nota bene/: we have to require each and every column that compose this PK to be 'NotNull'. This is +-- important because otherwise Postgres will assume so even though we didn't generate this constraint in +-- the first place, and our roundtrip tests will fail. +-- Same consideration on the \"standard types\" applies as above (crf 'genUniqueConstraint'). +genPkConstraint :: Columns -> Gen (Set TableConstraint) +genPkConstraint allCols = do + someCols <- take 32 . filter (\x -> isStdType x && notNull x) <$> listOf1 (elements $ M.toList allCols) -- indexes are capped to 32 colums. + case someCols of + [] -> pure mempty + _ -> do + constraintName <- runIdentity <$> genName Identity + pure $ S.singleton $ PrimaryKey (constraintName <> "_pk") (S.fromList $ map fst someCols) + where + notNull :: (ColumnName, Column) -> Bool + notNull (_, col) = NotNull `S.member` columnConstraints col + +genTableConstraints :: Tables -> Columns -> Gen (Set TableConstraint) +genTableConstraints _allOtherTables ourColums = + frequency + [ (60, pure mempty), + (30, genUniqueConstraint ourColums), + (30, genPkConstraint ourColums), + (15, mappend <$> genPkConstraint ourColums <*> genUniqueConstraint ourColums) + ] + +-- Generate a 'ColumnType' alongside a possible default value. +genColumnType :: Gen (ColumnType, ColumnConstraint) +genColumnType = + oneof + [ genSqlStdType, + genPgSpecificType + -- See below why this is commented out. , _genDbEnumeration + ] + +-- | Rather than trying to generate __all__ the possible values, we restrict ourselves to only the types +-- we can conjure via the 'defaultColumnType' combinator at 'Database.Beam.AutoMigrate.Compat', and we piggyback +-- on 'beam-core' machinery in order to generate the default values. +genSqlStdType :: Gen (ColumnType, ColumnConstraint) +genSqlStdType = + oneof + [ genType arbitrary (Proxy @Int32), + genType arbitrary (Proxy @Int16), + genType arbitrary (Proxy @Int64), + genType arbitrary (Proxy @Word16), + genType arbitrary (Proxy @Word32), + genType arbitrary (Proxy @Word64), + genType genAlphaName (Proxy @Text), + genBitStringType, + -- Unfortunately subject to rounding errors if a truly arbitrary type is used. + -- For example '1.0' is rendered '1.0' by Beam but as '1' by Postgres. + genType (elements [-0.1, 3.5]) (Proxy @Double), + -- Unfortunately subject to rounding errors if a truly arbitrary type is used. + genType (pure (scientific (1 :: Integer) (1 :: Int))) (Proxy @Scientific), + genType arbitrary (Proxy @Day), + -- Unfortunately subject to rounding errors if a truly arbitrary type is used. + genType (pure (read "01:00:07.979173" :: TimeOfDay)) (Proxy @TimeOfDay), + genType arbitrary (Proxy @Bool), + -- Unfortunately subject to rounding errors if a truly arbitrary type is used. + genType (pure (read "1864-05-10 13:50:45.919197" :: LocalTime)) (Proxy @LocalTime), + -- Explicitly test for the 'CURRENT_TIMESTAMP' case. + pure (SqlStdType $ timestampType Nothing False, pgDefaultConstraint @LocalTime currentTimestamp_), + genType (fmap SqlSerial arbitrary) (Proxy @(SqlSerial Int64)) + ] + +genType :: + forall a. + ( HasColumnType a, + HasSqlValueSyntax Pg.PgValueSyntax a + ) => + Gen a -> + Proxy a -> + Gen (ColumnType, ColumnConstraint) +genType gen Proxy = + (,) <$> pure (defaultColumnType (Proxy @a)) + <*> (gen <&> (\(x :: a) -> pgDefaultConstraint $ val_ x)) + +-- | From postgres' documentation: +-- \"Bit strings are strings of 1's and 0's. They can be used to store or visualize bit masks. There are +-- two SQL bit types: bit(n) and bit varying(n), where n is a positive integer. +-- bit type data must match the length n exactly; it is an error to attempt to store shorter or longer bit +-- strings. bit varying data is of variable length up to the maximum length n; longer strings will be rejected. +-- Writing bit without a length is equivalent to bit(1), while bit varying without a length specification +-- means unlimited length.\" +-- /NOTE(and)/: This was not generated using the 'defaultsTo_' combinator, because it's unclear how +-- \"Beam\" allows the construction and handling of a 'SqlBitString', considering that it's treated +-- internally as an integer. +genBitStringType :: Gen (ColumnType, ColumnConstraint) +genBitStringType = do + varying <- arbitrary + charPrec <- elements [1 :: Word, 2, 4, 6, 8, 16, 32, 64] + string <- vectorOf (fromIntegral charPrec) (elements ['0', '1']) + let txt = sqlSingleQuoted (T.pack string) <> "::bit(" <> (T.pack . show $ charPrec) <> ")" + case varying of + False -> + pure + ( SqlStdType $ AST.DataTypeBit False (Just charPrec), + Default txt + ) + True -> + pure + ( SqlStdType $ AST.DataTypeBit True (Just 1), + Default txt + ) + +genPgSpecificType :: Gen (ColumnType, ColumnConstraint) +genPgSpecificType = + oneof + [ genType (fmap Pg.PgJSON (arbitrary @Int)) (Proxy @(Pg.PgJSON Int)), + genType (fmap Pg.PgJSONB (arbitrary @Int)) (Proxy @(Pg.PgJSONB Int)) + -- , genRangeType (Proxy @Pg.PgInt4Range) (Proxy @Int32) + -- , genRangeType (Proxy @Pg.PgInt8Range) (Proxy @Int) + -- , genRangeType (Proxy @Pg.PgInt8Range) (Proxy @Int64) + -- , genRangeType (Proxy @Pg.PgNumRange) (Proxy @Int) + -- , genRangeType (Proxy @Pg.PgNumRange) (Proxy @Word64) + -- , genRangeType (Proxy @Pg.PgRangeTs) (Proxy @LocalTime) + -- , genRangeType (Proxy @Pg.RangeDate) (Proxy @Day) + -- , PgEnumeration EnumerationName + ] + +_genRangeType :: + forall a n. + ( Ord a, + Num a, + Arbitrary a, + Pg.PgIsRange n, + HasColumnType (Pg.PgRange n a), + HasSqlValueSyntax Pg.PgValueSyntax a + ) => + Proxy n -> + Proxy a -> + Gen (ColumnType, ColumnConstraint) +_genRangeType Proxy Proxy = do + let colType = defaultColumnType (Proxy @(Pg.PgRange n a)) + lowerBoundRange <- elements [Pg.Inclusive, Pg.Exclusive] + upperBoundRange <- elements [Pg.Inclusive, Pg.Exclusive] + mbLower <- arbitrary @(Maybe a) + mbUpper <- + arbitrary @(Maybe (Positive a)) <&> \u -> case liftM2 (,) u mbLower of + Nothing -> u + Just (ub, lb) -> Just $ Positive $ (getPositive ub) + lb + 1 + let dVal = + pgDefaultConstraint $ + Pg.range_ @n @a lowerBoundRange upperBoundRange (val_ mbLower) (val_ (fmap getPositive mbUpper)) + pure $ (colType, dVal) + +-- +-- +-- UNUSED GENERATORS +-- +-- These are generators I (adn) wrote in order to hit all the possible 'AST.DataType', but ultimately we +-- are bound to only the types the user can generate via 'defaultsTo_', so we are currently not using these +-- one. If in the future new instances for 'HasColumnType' gets added, these might be handy again. +-- + +-- NOTE(adn) We currently cannot use this generator because we have no information on the DB side to +-- reconstruct the fact this was an enumeration, so any roundtrip property involving a 'DBEnumeration' will +-- fail. +_genDbEnumeration :: Gen (ColumnType, Text) +_genDbEnumeration = do + vals <- map sqlSingleQuoted <$> listOf1 genAlphaName + dVal <- elements vals + name <- genName EnumerationName + pure (DbEnumeration name (Enumeration vals), dVal) + +_defVal :: forall a. (Arbitrary a, Show a) => Proxy a -> Gen Text +_defVal Proxy = T.pack . show <$> (arbitrary :: Gen a) + +-- Postgres has \"float(8)\" which is an alias for \"double precision\", and \"float(4)\" which is +-- an alias for \"real\". +_genFloatType :: Gen (AST.DataType, Text) +_genFloatType = do + floatPrec <- elements [Nothing, Just 4, Just 8] + def <- _defVal @Float Proxy + pure (AST.DataTypeFloat floatPrec, def) + +-- real == float(8), i.e. 4 bytes. +_genRealType :: Gen (AST.DataType, Text) +_genRealType = do + v <- T.pack . printf "%.1f" <$> arbitrary @Float + pure (AST.DataTypeReal, sqlSingleQuoted v <> "::real") + +_genIntType :: Gen (AST.DataType, Text) +_genIntType = do + v <- arbitrary @Int32 + pure $ + if v < 0 + then (AST.DataTypeBigInt, sqlSingleQuoted (T.pack . show $ v) <> "::integer") + else (AST.DataTypeBigInt, T.pack . show $ v) + +_genBigIntType :: Gen (AST.DataType, Text) +_genBigIntType = do + v <- arbitrary @Integer + pure $ + if v < 0 + then (AST.DataTypeBigInt, sqlSingleQuoted (T.pack . show $ v) <> "::integer") + else (AST.DataTypeBigInt, T.pack . show $ v) + +-- | We do not render all the decimal digits to not incur in any rounding error when converting back from +-- Postgres. +_genDoublePrecisionType :: Gen (AST.DataType, Text) +_genDoublePrecisionType = do + v <- T.pack . printf "%.1f" <$> arbitrary @Double + pure (AST.DataTypeDoublePrecision, sqlSingleQuoted v <> "::double precision") + +_genNumericType :: (Maybe (Word, Maybe Word) -> AST.DataType) -> Text -> Gen (AST.DataType, Text) +_genNumericType f _cast = do + numPrec <- choose (1 :: Word, 15) + numScale <- choose (1 :: Word, numPrec) + p <- elements [Nothing, Just (numPrec, Nothing), Just (numPrec, Just numScale)] + let renderNum (a, b) = (T.pack . show $ a) <> "." <> (T.pack . show $ b) + defaultValue <- case p of + Nothing -> + oneof + [ _defVal @Int32 Proxy, + fmap renderNum ((,) <$> choose (0 :: Word, 131072) <*> choose (0 :: Word, 16383)) + ] + Just (_, Nothing) -> + oneof + [ _defVal @Int32 Proxy, + fmap + renderNum + ( (,) <$> (choose (0 :: Word, 131072)) -- `suchThat` (\x -> length (show x) <= fromIntegral numPrec)) + <*> choose (0 :: Word, 16383) + ) + ] + Just (_, Just _) -> + oneof + [ _defVal @Int32 Proxy, + fmap + renderNum + ( (,) <$> choose (0 :: Word, 131072) -- `suchThat` (\x -> length (show x) <= fromIntegral numPrec) + <*> choose (0 :: Word, 16383) -- `suchThat` (\x -> length (show x) <= fromIntegral numScale) + ) + ] + pure (f p, defaultValue) + +-- Adjust the generator to the pg-specific caveats and quirks. +_pgSimplify :: (AST.DataType, Text) -> (AST.DataType, Text) +_pgSimplify = \case + -- From the Postgres' documentation: + -- \"character without length specifier is equivalent to character(1).\" + (AST.DataTypeChar varying Nothing c, def) -> (AST.DataTypeChar varying (Just 1) c, def) + -- Postgres doesn't distinguish between \"national character varying\" and \"character varying\". + -- See . + (AST.DataTypeNationalChar varying Nothing, def) -> (AST.DataTypeChar varying (Just 1) Nothing, def) + (AST.DataTypeNationalChar varying precision, def) -> (AST.DataTypeChar varying precision Nothing, def) + -- In Postgres decimal and numeric are isomorphic. + (AST.DataTypeDecimal v, def) -> (AST.DataTypeNumeric v, def) + (AST.DataTypeFloat (Just 4), def) -> (AST.DataTypeReal, def) + (AST.DataTypeFloat (Just 8), def) -> (AST.DataTypeDoublePrecision, def) + x -> x + +-- From the Postgres' documentation: +-- \"character without length specifier is equivalent to character(1).\" +_genCharType :: (Bool -> Maybe Word -> AST.DataType) -> Gen (AST.DataType, Text) +_genCharType f = do + varying <- arbitrary + text <- genAlphaName + charPrec <- choose (1, 2048) -- 2048 is arbitrary (no pun intended) here. + case varying of + False -> pure (f False (Just charPrec), sqlSingleQuoted (T.take (fromIntegral charPrec) text) <> "::bpchar") + True -> pure (f True (Just 1), sqlSingleQuoted text <> "::character varying") + +genColumn :: Columns -> Gen Column +genColumn _allColums = do + constNum <- choose (0, 2) + (cType, dVal) <- genColumnType + constrs <- vectorOf constNum (elements [NotNull, dVal]) + pure $ Column cType (S.fromList constrs) + +genColumns :: Gen Columns +genColumns = do + colNum <- choose (1, 50) + columnNames <- vectorOf colNum genColumnName + foldlM (\acc cName -> flip (M.insert cName) acc <$> genColumn acc) mempty columnNames + +-- | Generate a new 'Table' using the already existing tables to populate the constraints. +genTable :: Tables -> Gen Table +genTable currentTables = do + cols <- genColumns + Table <$> genTableConstraints currentTables cols <*> pure cols + +genSchema :: Gen Schema +genSchema = sized $ \tableNum -> do + tableNames <- vectorOf tableNum genTableName + tbls <- foldlM (\acc tName -> flip (M.insert tName) acc <$> genTable acc) mempty tableNames + pure $ Schema tbls mempty mempty + +-- +-- Generating Schema(s) which are not too dissimilar. +-- + +data TablesEditAction + = AddTable + | DropTable + | ModifyTable + | LeaveTableAlone + +data TableEditAction + = AddColumn + | DropColumn + | ModifyColumn + | LeaveColumnAlone + +data ColumnEditAction + = ChangeType + | ChangeConstraints + | NoChange + +-- Generate two 'Schema' which are not completely different but rather have /some/ differences. +genSimilarSchemas :: Gen (Schema, Schema) +genSimilarSchemas = do + initialSchema <- genSchema + (initialSchema,) <$> fmap (\tbs -> Schema tbs mempty mempty) (similarTables (schemaTables initialSchema)) + +similarTables :: Tables -> Gen Tables +similarTables tbls = flip execStateT tbls $ + forM_ (M.toList tbls) $ \(tName, tbl) -> do + tableEditAction <- + lift $ + frequency + [ (1, pure AddTable), + (1, pure DropTable), + (1, pure ModifyTable), + (15, pure LeaveTableAlone) + ] + case tableEditAction of + AddTable -> do + s <- get + newTableName <- lift genTableName + newTable <- lift $ genTable s + modify' (M.insert newTableName newTable) + DropTable -> modify' (M.delete tName) + ModifyTable -> do + table' <- lift $ similarTable tbl + modify' (M.insert tName table') + LeaveTableAlone -> pure () + +similarTable :: Table -> Gen Table +similarTable tbl = flip execStateT tbl $ + forM_ (M.toList . tableColumns $ tbl) $ \(cName, col) -> do + tableEditAction <- + lift $ + frequency + [ (1, pure AddColumn), + (1, pure DropColumn), + (1, pure ModifyColumn), + (15, pure LeaveColumnAlone) + ] + case tableEditAction of + AddColumn -> do + s <- get + newColumnName <- lift genColumnName + newColumn <- lift $ genColumn (tableColumns s) + modify' (\st -> st {tableColumns = M.insert newColumnName newColumn (tableColumns st)}) + -- If we drop or modify a column we need to delete all constraints referencing that column. + DropColumn -> + modify' + ( \st -> + st + { tableColumns = M.delete cName (tableColumns st), + tableConstraints = deleteConstraintReferencing cName (tableConstraints st) + } + ) + ModifyColumn -> do + col' <- lift $ similarColumn col + modify' + ( \st -> + st + { tableColumns = M.insert cName col' (tableColumns st), + tableConstraints = deleteConstraintReferencing cName (tableConstraints st) + } + ) + LeaveColumnAlone -> pure () + +deleteConstraintReferencing :: ColumnName -> Set TableConstraint -> Set TableConstraint +deleteConstraintReferencing cName conss = S.filter (not . doesReference) conss + where + doesReference :: TableConstraint -> Bool + doesReference = \case + PrimaryKey _ refs -> S.member cName refs + ForeignKey _ _ refs _ _ -> let ours = S.map snd refs in S.member cName ours + Unique _ refs -> S.member cName refs + +similarColumn :: Column -> Gen Column +similarColumn col = do + editAction' <- + frequency + [ (15, pure ChangeType), + (10, pure ChangeConstraints), + (30, pure NoChange) + ] + case editAction' of + ChangeType -> do + (newType, newDef) <- genColumnType + let oldConstraints = S.filter (\c -> case c of Default _ -> False; _ -> True) (columnConstraints col) + pure $ + col + { columnType = newType, + columnConstraints = S.insert newDef oldConstraints + } + ChangeConstraints -> do + -- At the moment we cannot add a new default value as we don't have a meanigful way of + -- generating it. + let oldConstraints = columnConstraints col + let newConstraints = case S.toList oldConstraints of + [] -> S.singleton NotNull + [NotNull] -> mempty + _ -> oldConstraints + pure $ col {columnConstraints = newConstraints} + NoChange -> pure col + +-- +-- Shrinking a Schema +-- + +shrinkSchema :: Schema -> [Schema] +shrinkSchema s = + noSchema : concatMap shrinkTable (M.toList (schemaTables s)) + where + shrinkTable :: (TableName, Table) -> [Schema] + shrinkTable (tName, tbl) = + s {schemaTables = M.delete tName (schemaTables s)} : + concatMap (shrinkColumns tName tbl) (M.toList (tableColumns tbl)) + + shrinkColumns :: TableName -> Table -> (ColumnName, Column) -> [Schema] + shrinkColumns tName tbl (cName, _col) = + let tbl' = + tbl + { tableColumns = M.delete cName (tableColumns tbl), + tableConstraints = deleteConstraintReferencing cName (tableConstraints tbl) + } + in [s {schemaTables = M.insert tName tbl' (schemaTables s)}] diff --git a/src/Database/Beam/AutoMigrate/Types.hs b/src/Database/Beam/AutoMigrate/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/AutoMigrate/Types.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Database.Beam.AutoMigrate.Types where + +import Control.DeepSeq +import Control.Exception +import Data.ByteString.Lazy (ByteString) +import Data.Map (Map) +import Data.Maybe (fromMaybe) +import Data.Set (Set) +import Data.String +import Data.String.Conv (toS) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable +import Database.Beam.Backend.SQL (BeamSqlBackendSyntax) +import qualified Database.Beam.Backend.SQL.AST as AST +import Database.Beam.Postgres (Pg, Postgres) +import qualified Database.Beam.Postgres.Syntax as Syntax +import GHC.Generics hiding (to) +import Lens.Micro (Lens', lens, to, _Right) +import Lens.Micro.Extras (preview) + +-- +-- Types (sketched) +-- + +data Schema = Schema + { schemaTables :: Tables, + schemaEnumerations :: Enumerations, + schemaSequences :: Sequences + } + deriving (Show, Eq, Generic) + +instance NFData Schema + +-- +-- Enumerations +-- + +type Enumerations = Map EnumerationName Enumeration + +newtype EnumerationName = EnumerationName + { enumName :: Text + } + deriving (Show, Eq, Ord, Generic) + +newtype Enumeration = Enumeration + { enumValues :: [Text] + } + deriving (Show, Eq, Ord, Generic) + +instance NFData EnumerationName + +instance NFData Enumeration + +-- +-- Sequences +-- + +type Sequences = Map SequenceName Sequence + +newtype SequenceName = SequenceName + { seqName :: Text + } + deriving (Show, Eq, Ord, Generic) + +-- For now this type is isomorphic to unit as we don't need to support anything other than plain +-- sequences. +data Sequence = Sequence + { seqTable :: TableName, + seqColumn :: ColumnName + } + deriving (Show, Eq, Ord, Generic) + +instance NFData SequenceName + +instance NFData Sequence + +mkSequenceName :: TableName -> ColumnName -> SequenceName +mkSequenceName tname cname = SequenceName (tableName tname <> "___" <> columnName cname <> "___seq") + +parseSequenceName :: SequenceName -> Maybe (TableName, ColumnName) +parseSequenceName (SequenceName sName) = case T.splitOn "___" sName of + [tName, cName, "seq"] -> Just (TableName tName, ColumnName cName) + _ -> Nothing + +-- +-- Tables +-- + +type Tables = Map TableName Table + +newtype TableName = TableName + { tableName :: Text + } + deriving (Show, Eq, Ord, NFData, Generic) + +data Table = Table + { tableConstraints :: Set TableConstraint, + tableColumns :: Columns + } + deriving (Eq, Show, Generic) + +instance NFData Table + +type Columns = Map ColumnName Column + +newtype ColumnName = ColumnName + { columnName :: Text + } + deriving (Show, Eq, Ord, NFData, Generic) + +instance IsString ColumnName where + fromString = ColumnName . T.pack + +data Column = Column + { columnType :: ColumnType, + columnConstraints :: Set ColumnConstraint + } + deriving (Show, Eq, Generic) + +-- Manual instance as 'AST.DataType' doesn't derive 'NFData'. +instance NFData Column where + rnf c = rnf (columnConstraints c) + +-- | Basic types for columns. We piggyback on 'beam-core' SQL types for now. Albeit they are a bit more +-- specialised (i.e, SQL specific), we are less subject from their and our representation to diverge. +data ColumnType + = -- | Standard SQL types. + SqlStdType AST.DataType + | -- | Postgres specific types. + PgSpecificType PgDataType + | -- | An enumeration implemented with text-based encoding. + DbEnumeration EnumerationName Enumeration + deriving (Show, Eq, Generic) + +data PgDataType + = PgJson + | PgJsonB + | PgRangeInt4 + | PgRangeInt8 + | PgRangeNum + | PgRangeTs + | PgRangeTsTz + | PgRangeDate + | PgUuid + | PgEnumeration EnumerationName + +deriving instance Show PgDataType + +deriving instance Eq PgDataType + +deriving instance Generic PgDataType + +-- Newtype wrapper to be able to derive appropriate 'HasDefaultSqlDataType' for /Postgres/ enum types. +newtype PgEnum a + = PgEnum a + deriving (Show, Eq, Typeable, Enum, Bounded, Generic) + +-- Newtype wrapper to be able to derive appropriate 'HasDefaultSqlDataType' for /textual/ enum types. +newtype DbEnum a + = DbEnum a + deriving (Show, Eq, Typeable, Enum, Bounded, Generic) + +instance Semigroup Table where + (Table c1 t1) <> (Table c2 t2) = Table (c1 <> c2) (t1 <> t2) + +instance Monoid Table where + mempty = Table mempty mempty + +type ConstraintName = Text + +data TableConstraint + = -- | This set of 'Column's identifies the Table's 'PrimaryKey'. + PrimaryKey ConstraintName (Set ColumnName) + | -- | This set of 'Column's identifies a Table's 'ForeignKey'. This is usually found in the 'tableConstraints' + -- of the table where the foreign key is actually defined (in terms of 'REFERENCES'). + -- The set stores a (fk_column, pk_column) correspondence. + ForeignKey ConstraintName TableName (Set (ColumnName, ColumnName)) ReferenceAction {- onDelete -} ReferenceAction {- onUpdate -} + | Unique ConstraintName (Set ColumnName) + deriving (Show, Eq, Ord, Generic) + +instance NFData TableConstraint + +data ColumnConstraint + = NotNull + | Default Text {- the actual default -} + deriving (Show, Eq, Ord, Generic) + +instance NFData ColumnConstraint + +data ReferenceAction + = NoAction + | Restrict + | Cascade + | SetNull + | SetDefault + deriving (Show, Eq, Ord, Generic) + +instance NFData ReferenceAction + +-- +-- Modifying the 'Schema' +-- + +-- | A possible list of edits on a 'Schema'. +data EditAction + = TableAdded TableName Table + | TableRemoved TableName + | TableConstraintAdded TableName TableConstraint + | TableConstraintRemoved TableName TableConstraint + | ColumnAdded TableName ColumnName Column + | ColumnRemoved TableName ColumnName + | ColumnTypeChanged TableName ColumnName ColumnType {- old type -} ColumnType {- new type -} + | ColumnConstraintAdded TableName ColumnName ColumnConstraint + | ColumnConstraintRemoved TableName ColumnName ColumnConstraint + | EnumTypeAdded EnumerationName Enumeration + | EnumTypeRemoved EnumerationName + | EnumTypeValueAdded EnumerationName Text {- added value -} InsertionOrder Text {- insertion point -} + | SequenceAdded SequenceName Sequence + | SequenceRemoved SequenceName + deriving (Show, Eq) + +-- | Safety rating for a given edit. +-- +-- "Safety" is defined as some 'EditAction' that might cause data loss. +data EditSafety + = Safe + | PotentiallySlow + | Unsafe + deriving (Show, Eq, Ord) + +defaultEditSafety :: EditAction -> EditSafety +defaultEditSafety = \case + TableAdded {} -> Safe + TableRemoved {} -> Unsafe + TableConstraintAdded {} -> Safe + TableConstraintRemoved {} -> Safe + ColumnAdded {} -> Safe + ColumnRemoved {} -> Unsafe + ColumnTypeChanged {} -> Unsafe + ColumnConstraintAdded {} -> Safe + ColumnConstraintRemoved {} -> Safe + EnumTypeAdded {} -> Safe + EnumTypeRemoved {} -> Unsafe + EnumTypeValueAdded {} -> Safe + SequenceAdded {} -> Safe + SequenceRemoved {} -> Unsafe + +data EditCondition = EditCondition + { _editCondition_query :: BeamSqlBackendSyntax Postgres, + _editCondition_check :: Pg EditSafety + } + +prettyEditConditionQuery :: EditCondition -> ByteString +prettyEditConditionQuery = Syntax.pgRenderSyntaxScript . Syntax.fromPgCommand . _editCondition_query + +instance Eq EditCondition where + ec1 == ec2 = prettyEditConditionQuery ec1 == prettyEditConditionQuery ec2 + +instance Show EditCondition where + show ec = + unwords + [ "EditConditon {", + "_editCondition_query = PgCommand {", + "pgCommandType = ", + show $ Syntax.pgCommandType $ _editCondition_query ec, + "fromPgCommand = ", + toS $ prettyEditConditionQuery ec, + "},", + "_editCondition_check = ", + "}" + ] + +data Edit = Edit + { _editAction :: EditAction, + _editCondition :: Either EditCondition EditSafety + } + deriving (Show, Eq) + +editAction :: Lens' Edit EditAction +editAction = lens _editAction (\(Edit _ ec) ea -> Edit ea ec) + +editCondition :: Lens' Edit (Either EditCondition EditSafety) +editCondition = lens _editCondition (\(Edit ea _) ec -> Edit ea ec) + +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) + +defMkEdit :: EditAction -> Edit +defMkEdit = mkEditWith defaultEditSafety + +data InsertionOrder + = Before + | After + deriving (Show, Eq, Generic) + +instance NFData InsertionOrder + +-- Manual instance as 'AST.DataType' doesn't derive 'NFData'. +instance NFData EditAction where + rnf (TableAdded tName tbl) = tName `deepseq` tbl `deepseq` () + rnf (TableRemoved tName) = rnf tName + rnf (TableConstraintAdded tName tCon) = tName `deepseq` tCon `deepseq` () + rnf (TableConstraintRemoved tName tCon) = tName `deepseq` tCon `deepseq` () + rnf (ColumnAdded tName cName col) = tName `deepseq` cName `deepseq` col `deepseq` () + rnf (ColumnRemoved tName colName) = tName `deepseq` colName `deepseq` () + rnf (ColumnTypeChanged tName colName c1 c2) = c1 `seq` c2 `seq` tName `deepseq` colName `deepseq` () + rnf (ColumnConstraintAdded tName cName cCon) = tName `deepseq` cName `deepseq` cCon `deepseq` () + rnf (ColumnConstraintRemoved tName colName cCon) = tName `deepseq` colName `deepseq` cCon `deepseq` () + rnf (EnumTypeAdded eName enum) = eName `deepseq` enum `deepseq` () + rnf (EnumTypeRemoved eName) = eName `deepseq` () + rnf (EnumTypeValueAdded eName inserted order insertionPoint) = + eName `deepseq` inserted `deepseq` order `deepseq` insertionPoint `deepseq` () + rnf (SequenceAdded sName s) = sName `deepseq` s `deepseq` () + rnf (SequenceRemoved sName) = sName `deepseq` () + +-- | A possible enumerations of the reasons why a 'diff' operation might not work. +data DiffError + = -- | The diff couldn't be completed. TODO(adn) We need extra information + -- we can later on reify into the raw SQL queries users can try to run + -- themselves. + AutomaticDiffNotPossible + | -- | Postgres doesn't support removing values from an enum. + ValuesRemovedFromEnum EnumerationName [Text] + deriving (Show, Generic, Eq) + +instance Exception DiffError + +instance NFData DiffError + +-- +-- Utility functions +-- + +noSchema :: Schema +noSchema = Schema mempty mempty mempty + +noTableConstraints :: Set TableConstraint +noTableConstraints = mempty + +noColumnConstraints :: Set ColumnConstraint +noColumnConstraints = mempty diff --git a/src/Database/Beam/AutoMigrate/Util.hs b/src/Database/Beam/AutoMigrate/Util.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/AutoMigrate/Util.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Beam.AutoMigrate.Util where + +import Control.Applicative.Lift +import Control.Monad.Except +import Data.Functor.Constant +import Data.String (fromString) +import Data.Text (Text) +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 ((^.)) + +-- +-- Retrieving all the column names for a beam entity. +-- + +class HasColumnNames entity tbl where + colNames :: tbl (Beam.TableField tbl) -> (tbl (Beam.TableField tbl) -> entity) -> [ColumnName] + +instance + Beam.Beamable (PrimaryKey tbl) => + HasColumnNames (PrimaryKey tbl (Beam.TableField c)) tbl + where + colNames field fn = map ColumnName (allBeamValues (\(Columnar' x) -> x ^. fieldName) (fn field)) + +instance + Beam.Beamable (PrimaryKey tbl) => + HasColumnNames (PrimaryKey tbl (Beam.TableField c)) tbl' + where + colNames field fn = map ColumnName (allBeamValues (\(Columnar' x) -> x ^. fieldName) (fn field)) + +instance HasColumnNames (Beam.TableField tbl ty) tbl where + colNames field fn = [ColumnName (fn field ^. Beam.fieldName)] + +-- +-- General utility functions +-- + +-- | Extracts the 'TableSettings' out of the input 'DatabaseEntity'. +tableSettings :: Beam.DatabaseEntity be db (TableEntity tbl) -> TableSettings tbl +tableSettings entity = dbTableSettings $ entity ^. dbEntityDescriptor + +tableName :: Beam.Beamable tbl => Beam.DatabaseEntity be db (TableEntity tbl) -> TableName +tableName entity = TableName $ (entity ^. dbEntityDescriptor . dbEntityName) + +-- | Extracts the primary key of a table as a list of 'ColumnName'. +pkFieldNames :: + (Beamable (PrimaryKey tbl), Beam.Table tbl) => + Beam.DatabaseEntity be db (TableEntity tbl) -> + [ColumnName] +pkFieldNames entity = + map ColumnName (allBeamValues (\(Columnar' x) -> x ^. fieldName) (primaryKey . tableSettings $ entity)) + +-- | Similar to 'pkFieldNames', but it works on any entity that derives 'Beamable'. +fieldAsColumnNames :: Beamable tbl => tbl (Beam.TableField c) -> [ColumnName] +fieldAsColumnNames field = map ColumnName (allBeamValues (\(Columnar' x) -> x ^. fieldName) field) + +-- | Returns /all/ the 'ColumnName's for a given 'DatabaseEntity'. +allColumnNames :: Beamable tbl => Beam.DatabaseEntity be db (TableEntity tbl) -> [ColumnName] +allColumnNames entity = + let settings = dbTableSettings $ entity ^. dbEntityDescriptor + in map ColumnName (allBeamValues (\(Columnar' x) -> x ^. fieldName) settings) + +-- +-- Reporting multiple errors at once +-- +-- See https://teh.id.au/posts/2017/03/13/accumulating-errors/index.html + +hoistErrors :: Either e a -> Errors e a +hoistErrors e = + case e of + Left es -> + Other (Constant es) + Right a -> + Pure a + +-- | Like 'sequence', but accumulating all errors in case of at least one 'Left'. +sequenceEither :: (Monoid e, Traversable f) => f (Either e a) -> Either e (f a) +sequenceEither = + runErrors . traverse hoistErrors + +-- | Evaluate each action in sequence, accumulating all errors in case of a failure. +-- Note that this means each action will be run independently, regardless of failure. +sequenceExceptT :: + (Monad m, Monoid w, Traversable t) => + t (ExceptT w m a) -> + ExceptT w m (t a) +sequenceExceptT es = do + es' <- lift (traverse runExceptT es) + ExceptT (return (sequenceEither es')) + +-- NOTE(adn) Unfortunately these combinators are not re-exported by beam. + +sqlOptPrec :: Maybe Word -> Text +sqlOptPrec Nothing = mempty +sqlOptPrec (Just x) = "(" <> fromString (show x) <> ")" + +sqlOptCharSet :: Maybe Text -> Text +sqlOptCharSet Nothing = mempty +sqlOptCharSet (Just cs) = " CHARACTER SET " <> cs + +sqlEscaped :: Text -> Text +sqlEscaped t = "\"" <> t <> "\"" + +sqlSingleQuoted :: Text -> Text +sqlSingleQuoted t = "'" <> t <> "'" + +sqlOptNumericPrec :: Maybe (Word, Maybe Word) -> Text +sqlOptNumericPrec Nothing = mempty +sqlOptNumericPrec (Just (prec, Nothing)) = sqlOptPrec (Just prec) +sqlOptNumericPrec (Just (prec, Just dec)) = "(" <> fromString (show prec) <> ", " <> fromString (show dec) <> ")" diff --git a/src/Database/Beam/AutoMigrate/Validity.hs b/src/Database/Beam/AutoMigrate/Validity.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/AutoMigrate/Validity.hs @@ -0,0 +1,663 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ViewPatterns #-} + +module Database.Beam.AutoMigrate.Validity + ( -- * Types + Reason (..), + ApplyFailed, + ValidationFailed, + + -- * Applying edits to a 'Schema' + applyEdits, + + -- * Validing a 'Schema' + validateSchema, + validateSchemaTables, + validateSchemaEnums, + validateTableConstraint, + validateColumn, + ) +where + +import Control.Monad +import Control.Monad.Except +import Data.Bifunctor +import Data.Foldable +import qualified Data.List as L +import qualified Data.Map.Strict as M +import Data.Monoid +import qualified Data.Set as S +import Data.Text (Text) +import Database.Beam.AutoMigrate.Diff +import Database.Beam.AutoMigrate.Types + +-- | 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). +data Qualified a = Qualified TableName a deriving (Show, Eq) + +data Reason + = -- | The 'Table' we were trying to edit didn't exist. + TableDoesntExist TableName + | -- | The 'Table' we were trying to create already existed. + TableAlreadyExist TableName Table + | -- | The 'TableConstraint' we were trying to add already existed. + TableConstraintAlreadyExist TableName TableConstraint + | -- | The 'TableConstraint' we were trying to delete didn't exist. + TableConstraintDoesntExist TableName TableConstraint + | -- | The 'Column' we were trying to edit didn't exist. + ColumnDoesntExist ColumnName + | -- | The 'Column' we were trying to add already existed. + ColumnAlreadyExist ColumnName Column + | -- | The old type for the input 'Column' didn't match the type contained in the 'Edit' step. + ColumnTypeMismatch ColumnName Column ColumnType + | -- | The 'ColumnConstraint' we were trying to add already existed. + ColumnConstraintAlreadyExist (Qualified ColumnName) ColumnConstraint + | -- | The 'ColumnConstraint' we were trying to delete didn't exist. + ColumnConstraintDoesntExist (Qualified ColumnName) ColumnConstraint + | -- | The 'Enum' we were trying to edit didn't exist. + EnumDoesntExist EnumerationName + | -- | The 'Enum' we were trying to add already existed. + EnumAlreadyExist EnumerationName Enumeration + | -- | The value in this 'Enum' to be used to insert a new one before/after it didn't exist. + EnumInsertionPointDoesntExist EnumerationName Enumeration Text + | -- | The 'Sequence' we were trying to add already existed. + SequenceAlreadyExist SequenceName Sequence + | -- | The 'Sequence' we were trying to edit didn't exist. + SequenceDoesntExist SequenceName + | -- | This 'Table' references a deleted 'Column' in one of its 'TableConstraint's. + TableReferencesDeletedColumnInConstraint TableName (Qualified ColumnName) TableConstraint + | -- | This 'Column' references an 'Enum' which doesn't exist. + ColumnReferencesNonExistingEnum (Qualified ColumnName) EnumerationName + | -- | This 'Column' allows NULL values but it has been selected as a PRIMARY key. + ColumnInPrimaryKeyCantBeNull (Qualified ColumnName) + | -- | This 'Table' has a 'ForeignKey' constaint in it which references external columns which are either + -- not unique or not fields of a PRIMARY KEY. + ColumnsInFkAreNotUniqueOrPrimaryKeyFields TableName [Qualified ColumnName] + | ColumnStillReferencesSequence SequenceName (Qualified ColumnName) + | -- | This 'TableConstraint' references one or more 'Column's which don't exist. + NotAllColumnsExist TableName (S.Set ColumnName) (S.Set ColumnName) + | -- | Deleting this 'TableConstraint' would affect the selected external 'Column's and some external + -- 'TableConstraint's. + DeletedConstraintAffectsExternalTables (TableName, TableConstraint) (Qualified ColumnName, TableConstraint) + | EnumContainsDuplicateValues EnumerationName [Text] + deriving (Show, Eq) + +data ApplyFailed + = InvalidEdit Edit Reason + deriving (Show, Eq) + +data ValidationFailed + = InvalidTableConstraint TableConstraint Reason + | InvalidRemoveTable TableName Reason + | InvalidRemoveColumn (Qualified ColumnName) Reason + | InvalidRemoveEnum EnumerationName Reason + | InvalidRemoveSequence SequenceName Reason + | InvalidEnum EnumerationName Reason + | InvalidColumn (Qualified ColumnName) Reason + | InvalidRemoveColumnConstraint (Qualified ColumnName) Reason + | InvalidRemoveTableConstraint TableName Reason + deriving (Show, Eq) + +-- +-- Validating a Schema and a set of edit actions. +-- + +-- | Validate a 'Schema', returning an error in case the validation didn't succeed. We never contemplate +-- the case where any of the entities names are empty (i.e. the empty string) as that clearly indicates a +-- bug in the library, not a user error that needs to be reported. +validateSchema :: Schema -> Either [ValidationFailed] () +validateSchema s = runExcept $ do + liftEither (validateSchemaTables s) + liftEither (validateSchemaEnums s) + +-- | A 'Table' is not valid if: +-- 1. Any of its 'Column's are not valid; +-- 2. Any of its 'TableConstraint's are not valid. +validateSchemaTables :: Schema -> Either [ValidationFailed] () +validateSchemaTables s = forM_ (M.toList $ schemaTables s) validateTable + where + validateTable :: (TableName, Table) -> Either [ValidationFailed] () + validateTable (tName, tbl) = do + forM_ (tableConstraints tbl) (first (: []) . validateTableConstraint s tName tbl) + forM_ (M.toList $ tableColumns tbl) (validateColumn s tName) + +-- | Validate a 'TableConstraint', making sure referential integrity is not violated. +-- A Table constraint is valid IFF: +-- 1. For a 'PrimaryKey', all the referenced columns must exist in the 'Table'; +-- 2. For a 'Unique', all the referenced columns must exist in the 'Table'; +-- 3. For a 'ForeignKey', all the columns (both local and referenced) must exist; +-- 4. For a 'ForeignKey', the referenced columns must all be UNIQUE or PRIMARY keys. +validateTableConstraint :: Schema -> TableName -> Table -> TableConstraint -> Either ValidationFailed () +validateTableConstraint s tName tbl c = case c of + PrimaryKey _ cols | cols `S.isSubsetOf` allTblColumns -> Right () + PrimaryKey _ cols -> + Left $ InvalidTableConstraint c (NotAllColumnsExist tName (S.difference cols allTblColumns) allTblColumns) + ForeignKey _ referencedTable columnPairs _ _ -> checkFkIntegrity referencedTable columnPairs + Unique _ cols | cols `S.isSubsetOf` allTblColumns -> Right () + Unique _ cols -> + Left $ InvalidTableConstraint c (NotAllColumnsExist tName (S.difference cols allTblColumns) allTblColumns) + where + allTblColumns :: S.Set ColumnName + allTblColumns = M.keysSet . tableColumns $ tbl + + checkFkIntegrity :: TableName -> S.Set (ColumnName, ColumnName) -> Either ValidationFailed () + checkFkIntegrity referencedTable columnPairs = runExcept $ + liftEither $ + case M.lookup referencedTable (schemaTables s) of + Nothing -> throwError $ InvalidTableConstraint c (TableDoesntExist referencedTable) + Just extTbl -> do + let allExtColumns = M.keysSet (tableColumns extTbl) + let (localCols, referencedCols) = (S.map fst columnPairs, S.map snd columnPairs) + if + | not (localCols `S.isSubsetOf` allTblColumns) -> + throwError $ InvalidTableConstraint c (NotAllColumnsExist tName (S.difference localCols allTblColumns) allTblColumns) + | not (referencedCols `S.isSubsetOf` allExtColumns) -> + throwError $ InvalidTableConstraint c (NotAllColumnsExist referencedTable (S.difference referencedCols allTblColumns) allExtColumns) + | otherwise -> checkColumnsIntegrity referencedTable extTbl referencedCols + + -- Check that all these columns are either 'UNIQUE' or 'PRIMARY KEY' in the input 'Table'. + checkColumnsIntegrity :: TableName -> Table -> S.Set ColumnName -> Either ValidationFailed () + checkColumnsIntegrity extName extTbl referencedCols = + let checkConstraint extCon = case extCon of + ForeignKey {} -> Nothing + PrimaryKey _ cols | referencedCols `S.isSubsetOf` cols -> Just () + PrimaryKey {} -> Nothing + Unique _ cols | referencedCols `S.isSubsetOf` cols -> Just () + Unique {} -> Nothing + in case asum (map checkConstraint (S.toList $ tableConstraints extTbl)) of + Nothing -> + let reason = ColumnsInFkAreNotUniqueOrPrimaryKeyFields tName (map (Qualified extName) (S.toList referencedCols)) + in Left $ InvalidTableConstraint c reason + Just () -> Right () + +-- | Validate 'Column'. +-- NOTE(adn) For now in this context a 'Column' is always considered valid, /except/ if it references an +-- '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 + +-- | A 'Schema' enum is considered always valid in this context /except/ if it contains duplicate values. +validateSchemaEnums :: Schema -> Either [ValidationFailed] () +validateSchemaEnums s = forM_ (M.toList $ schemaEnumerations s) validateEnum + where + validateEnum :: (EnumerationName, Enumeration) -> Either [ValidationFailed] () + validateEnum (eName, (Enumeration vals)) = + if length vals /= length (S.fromList vals) + then Left [InvalidEnum eName (EnumContainsDuplicateValues eName vals)] + else Right () + +-- | Validate removal of a 'Table'. +-- Removing a 'Table' is valid if none of the column fields are referenced in any of the other tables. +validateRemoveTable :: Schema -> TableName -> Table -> Either ValidationFailed () +validateRemoveTable s tName tbl = do + let tableColumnNames = map (Qualified tName) $ M.keys (tableColumns tbl) + let otherTables = M.delete tName (schemaTables s) + mapM_ (checkIntegrity tableColumnNames) (M.toList otherTables) + where + checkIntegrity :: [Qualified ColumnName] -> (TableName, Table) -> Either ValidationFailed () + checkIntegrity colNames (otherTblName, otherTbl) = + case getAlt $ asum (map (lookupColumnRef otherTblName otherTbl) colNames) of + Nothing -> pure () + Just (qualifiedColName, constr) -> + let reason = TableReferencesDeletedColumnInConstraint tName qualifiedColName constr + in Left $ InvalidRemoveTable tName reason + +-- | The workhorse of the validation engine. It lookups the input 'ColumnName' in any of the constraints +-- of the input 'Table'. +lookupColumnRef :: + TableName -> + Table -> + Qualified ColumnName -> + Alt Maybe (Qualified ColumnName, TableConstraint) +lookupColumnRef thisTable (tableConstraints -> constr) (Qualified extTbl colName) = + asum (map lookupReference (S.toList constr)) + where + lookupReference :: TableConstraint -> Alt Maybe (Qualified ColumnName, TableConstraint) + lookupReference con = Alt $ case con of + PrimaryKey _ cols + | thisTable == extTbl -> + if S.member colName cols then Just (Qualified thisTable colName, con) else Nothing + PrimaryKey _ _ -> Nothing + ForeignKey _ extTbl' columnPairs _ _ -> + let (localCols, referencedCols) = (S.map fst columnPairs, S.map snd columnPairs) + in if + | S.member colName localCols && thisTable == extTbl -> Just (Qualified extTbl colName, con) + | S.member colName referencedCols && extTbl == extTbl' -> Just (Qualified extTbl colName, con) + | otherwise -> Nothing + Unique _ cols + | thisTable == extTbl -> + if S.member colName cols then Just (Qualified thisTable colName, con) else Nothing + Unique _ _ -> 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 + _ -> Nothing + +-- | Removing an 'Enum' is valid if none of the 'Schema's tables have columns of this type. +validateRemoveEnum :: Schema -> EnumerationName -> Either ValidationFailed () +validateRemoveEnum s eName = + let allTables = M.toList (schemaTables s) + in mapM_ checkIntegrity allTables + where + checkIntegrity :: (TableName, Table) -> Either ValidationFailed () + checkIntegrity (tName, tbl) = + case getAlt $ asum (map (lookupEnumRef eName) (M.toList $ tableColumns tbl)) of + Nothing -> pure () + Just colName -> + let reason = ColumnReferencesNonExistingEnum (Qualified tName colName) eName + in Left $ InvalidRemoveEnum eName reason + +-- | Checking that the removal of a 'Sequence' is valid requires us to store the 'TableName' +-- and the 'ColumnName' inside the 'Sequence' type, so that we can check in logarithmic time if this sequence +-- is still referenced by the target column. +validateRemoveSequence :: Schema -> SequenceName -> Sequence -> Either ValidationFailed () +validateRemoveSequence s sName (Sequence targetTable targetColumn) = + let mbCol = do + tbl <- M.lookup targetTable (schemaTables s) + col <- M.lookup targetColumn (tableColumns tbl) + pure $ any hasNextValConstraint (S.toList (columnConstraints col)) + in case mbCol of + Just True -> + let reason = ColumnStillReferencesSequence sName (Qualified targetTable targetColumn) + in Left $ InvalidRemoveSequence sName reason + _ -> Right () + where + hasNextValConstraint :: ColumnConstraint -> Bool + hasNextValConstraint (Default defTxt) = case parseSequenceName (SequenceName defTxt) of + Just (tName, cName) | tName == targetTable && cName == targetColumn -> True + _ -> False + hasNextValConstraint _ = False + +-- | Validate that adding a new 'TableConstraint' doesn't violate referential integrity. +validateAddTableConstraint :: Schema -> TableName -> Table -> TableConstraint -> Either ValidationFailed () +validateAddTableConstraint = validateTableConstraint + +-- | Removing a Table constraint is valid IFF: +-- 1. For a 'PrimaryKey' we need to check that none of the columns appears in any 'ForeignKey' constraints +-- of the other tables; +-- 2. For a 'Unique', we must check that none of the columns appear in any 'ForeignKey' of of the other +-- tables. +-- 3. For a 'ForeignKey', no check is necessary. +validateRemoveTableConstraint :: Schema -> TableName -> TableConstraint -> Either ValidationFailed () +validateRemoveTableConstraint s tName c = case c of + PrimaryKey _ cols -> + forM_ (M.toList allOtherTables) (checkIntegrity (map (Qualified tName) . S.toList $ cols)) + Unique _ cols -> + forM_ (M.toList allOtherTables) (checkIntegrity (map (Qualified tName) . S.toList $ cols)) + ForeignKey {} -> Right () + where + allOtherTables :: Tables + allOtherTables = M.delete tName (schemaTables s) + + checkIntegrity :: [Qualified ColumnName] -> (TableName, Table) -> Either ValidationFailed () + checkIntegrity ourColNames (extTable, tbl) = + case getAlt $ asum (map (lookupColumnRef extTable tbl) ourColNames) of + Nothing -> Right () + Just (colName, constr) -> + let reason = DeletedConstraintAffectsExternalTables (tName, c) (colName, constr) + in Left $ InvalidRemoveTableConstraint tName reason + +-- | Removing a 'Column' is valid iff the column is not referenced in any tables' constraints. +validateRemoveColumn :: Schema -> TableName -> ColumnName -> Either ValidationFailed () +validateRemoveColumn s tName colName = mapM_ checkIntegrity (M.toList (schemaTables s)) + where + checkIntegrity :: (TableName, Table) -> Either ValidationFailed () + checkIntegrity (otherTblName, otherTbl) = + case getAlt $ asum (map (lookupColumnRef otherTblName otherTbl) [Qualified tName colName]) of + Nothing -> pure () + Just (_, constr) -> + let reason = TableReferencesDeletedColumnInConstraint otherTblName (Qualified tName colName) constr + in Left $ InvalidRemoveColumn (Qualified tName colName) reason + +-- | Removing a column constraint will violate referential integrity if the constraint is 'NotNull' and +-- this column appears in the primary key. +validateRemoveColumnConstraint :: + Table -> + Qualified ColumnName -> + ColumnConstraint -> + Either ValidationFailed () +validateRemoveColumnConstraint tbl (Qualified tName colName) = \case + NotNull -> mapM_ checkIntegrity (tableConstraints tbl) + Default _ -> pure () + where + checkIntegrity :: TableConstraint -> Either ValidationFailed () + checkIntegrity constr = case constr of + PrimaryKey _ cols -> + let reason = ColumnInPrimaryKeyCantBeNull (Qualified tName colName) + in if S.member colName cols + then Left $ InvalidRemoveColumnConstraint (Qualified tName colName) reason + else Right () + ForeignKey {} -> Right () + Unique {} -> Right () + +-- | Convert a 'ValidationFailed' into an 'ApplyFailed'. +toApplyFailed :: Edit -> ValidationFailed -> ApplyFailed +toApplyFailed e (InvalidTableConstraint _ reason) = InvalidEdit e reason +toApplyFailed e (InvalidRemoveTable _ reason) = InvalidEdit e reason +toApplyFailed e (InvalidRemoveColumn _ reason) = InvalidEdit e reason +toApplyFailed e (InvalidRemoveEnum _ reason) = InvalidEdit e reason +toApplyFailed e (InvalidRemoveSequence _ reason) = InvalidEdit e reason +toApplyFailed e (InvalidEnum _ reason) = InvalidEdit e reason +toApplyFailed e (InvalidColumn _ reason) = InvalidEdit e reason +toApplyFailed e (InvalidRemoveColumnConstraint _ reason) = InvalidEdit e reason +toApplyFailed e (InvalidRemoveTableConstraint _ reason) = InvalidEdit e reason + +-- | Tries to apply a list of edits to a 'Schema' to generate a new one. Fails with an 'ApplyFailed' error +-- if the input list of 'Edit's would generate an invalid 'Schema'. +applyEdits :: [WithPriority Edit] -> Schema -> Either ApplyFailed Schema +applyEdits (sortEdits -> edits) s = foldM applyEdit s (map (fst . unPriority) edits) + +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) + +-- +-- Various combinators for specific parts of a Schema +-- + +removeTable :: Edit -> Schema -> TableName -> Table -> Either ApplyFailed (Maybe Table) +removeTable e s tName t = runExcept . withExcept (toApplyFailed e) . liftEither $ do + validateRemoveTable s tName t + pure Nothing + +addColumn :: Edit -> ColumnName -> Column -> Table -> Either ApplyFailed (Maybe Table) +addColumn e colName col tbl = liftEither $ do + columns' <- + M.alterF + ( \case + -- Constaints are added as a separate edit step. + Nothing -> Right (Just col {columnConstraints = mempty}) + Just existing -> Left (InvalidEdit e (ColumnAlreadyExist colName existing)) + ) + colName + (tableColumns tbl) + pure $ Just tbl {tableColumns = columns'} + +removeColumn :: Edit -> Schema -> ColumnName -> TableName -> Table -> Either ApplyFailed (Maybe Table) +removeColumn e s colName tName tbl = liftEither $ do + columns' <- + M.alterF + ( \case + Nothing -> Left (InvalidEdit e (ColumnDoesntExist colName)) + Just _ -> first (toApplyFailed e) (validateRemoveColumn s tName colName) >> pure Nothing + ) + colName + (tableColumns tbl) + pure $ Just tbl {tableColumns = columns'} + +changeColumnType :: + Edit -> + ColumnName -> + -- | old type + ColumnType -> + -- | new type + ColumnType -> + Column -> + Either ApplyFailed (Maybe Column) +changeColumnType e colName oldType newType col = + if columnType col /= oldType + then Left $ InvalidEdit e (ColumnTypeMismatch colName col oldType) + else pure . Just $ col {columnType = newType} + +addColumnConstraint :: + Edit -> + TableName -> + ColumnConstraint -> + ColumnName -> + Column -> + Either ApplyFailed (Maybe Column) +addColumnConstraint e tName constr colName col = + let constraints = columnConstraints col + in if S.member constr constraints + then Left (InvalidEdit e (ColumnConstraintAlreadyExist (Qualified tName colName) constr)) + else pure . Just $ col {columnConstraints = S.insert constr constraints} + +removeColumnConstraint :: + Edit -> + Table -> + TableName -> + ColumnName -> + ColumnConstraint -> + Column -> + Either ApplyFailed (Maybe Column) +removeColumnConstraint e tbl tName colName constr col = do + let constraints = columnConstraints col + constraints' <- + if S.member constr constraints + then removeConstraint constraints + else Left (InvalidEdit e (ColumnConstraintDoesntExist (Qualified tName colName) constr)) + pure . Just $ col {columnConstraints = constraints'} + where + removeConstraint :: S.Set ColumnConstraint -> Either ApplyFailed (S.Set ColumnConstraint) + removeConstraint constraints = runExcept . withExcept (toApplyFailed e) . liftEither $ do + validateRemoveColumnConstraint tbl (Qualified tName colName) constr + pure (S.delete constr constraints) + +-- | Performs an action over an existing 'Table', failing if the 'Table' doesn't exist. +withExistingTable :: + TableName -> + Edit -> + Schema -> + (Table -> Either ApplyFailed (Maybe Table)) -> + Except ApplyFailed Schema +withExistingTable tName e s action = liftEither $ do + tables' <- + M.alterF + ( \case + Nothing -> Left (InvalidEdit e (TableDoesntExist tName)) + Just table -> action table + ) + tName + (schemaTables s) + pure $ s {schemaTables = tables'} + +-- | Performs an action over an existing 'Column', failing if the 'Column' doesn't exist. +withExistingColumn :: + TableName -> + ColumnName -> + Edit -> + Schema -> + (Table -> Column -> Either ApplyFailed (Maybe Column)) -> + Except ApplyFailed Schema +withExistingColumn tName colName e s action = + withExistingTable + tName + e + s + ( \tbl -> do + columns' <- + M.alterF + ( \case + Nothing -> Left (InvalidEdit e (ColumnDoesntExist colName)) + Just existing -> action tbl existing + ) + colName + (tableColumns tbl) + pure $ Just tbl {tableColumns = columns'} + ) + +-- | Performs an action over an existing 'Enum', failing if the 'Enum' doesn't exist. +withExistingEnum :: + EnumerationName -> + Edit -> + Schema -> + (Enumeration -> Either ApplyFailed (Maybe Enumeration)) -> + Except ApplyFailed Schema +withExistingEnum eName e s action = liftEither $ do + enums' <- + M.alterF + ( \case + Nothing -> Left (InvalidEdit e (EnumDoesntExist eName)) + Just enum -> action enum + ) + eName + (schemaEnumerations s) + pure $ s {schemaEnumerations = enums'} + +-- | Performs an action over an existing 'Sequence', failing if the 'Sequence' doesn't exist. +withExistingSequence :: + SequenceName -> + Edit -> + Schema -> + (Sequence -> Either ApplyFailed (Maybe Sequence)) -> + Except ApplyFailed Schema +withExistingSequence sName e s action = liftEither $ do + seqs' <- + M.alterF + ( \case + Nothing -> Left (InvalidEdit e (SequenceDoesntExist sName)) + Just enum -> action enum + ) + sName + (schemaSequences s) + pure $ s {schemaSequences = seqs'} + +addTableConstraint :: + Edit -> + Schema -> + TableConstraint -> + TableName -> + Table -> + Either ApplyFailed (Maybe Table) +addTableConstraint e s con tName tbl = liftEither $ do + let constraints = tableConstraints tbl + constraints' <- + if S.member con constraints + then Left (InvalidEdit e (TableConstraintAlreadyExist tName con)) + else addConstraint constraints + pure $ Just tbl {tableConstraints = constraints'} + where + addConstraint :: S.Set TableConstraint -> Either ApplyFailed (S.Set TableConstraint) + addConstraint cons = runExcept . withExcept (toApplyFailed e) . liftEither $ do + validateAddTableConstraint s tName tbl con + pure $ S.insert con cons + +removeTableConstraint :: + Edit -> + Schema -> + TableConstraint -> + TableName -> + Table -> + Either ApplyFailed (Maybe Table) +removeTableConstraint e s con tName tbl = liftEither $ do + let constraints = tableConstraints tbl + constraints' <- + if S.member con constraints + then removeConstraint constraints + else Left (InvalidEdit e (TableConstraintDoesntExist tName con)) + pure $ Just tbl {tableConstraints = constraints'} + where + removeConstraint :: S.Set TableConstraint -> Either ApplyFailed (S.Set TableConstraint) + removeConstraint cons = runExcept . withExcept (toApplyFailed e) . liftEither $ do + validateRemoveTableConstraint s tName con + pure $ S.delete con cons + +removeEnum :: + Edit -> + Schema -> + EnumerationName -> + Enumeration -> + Either ApplyFailed (Maybe Enumeration) +removeEnum e s eName _ = runExcept . withExcept (toApplyFailed e) . liftEither $ do + validateRemoveEnum s eName + pure Nothing + +addValueToEnum :: + Edit -> + EnumerationName -> + -- | value to insert + Text -> + InsertionOrder -> + -- | insertion point + Text -> + Enumeration -> + Either ApplyFailed (Maybe Enumeration) +addValueToEnum e eName addedValue insOrder insPoint (Enumeration vals) = + case insOrder of + Before -> + case L.elemIndex insPoint vals of + Nothing -> Left (InvalidEdit e (EnumInsertionPointDoesntExist eName (Enumeration vals) insPoint)) + Just ix | ix == 0 -> pure . Just $ Enumeration (addedValue : vals) + Just ix -> + let (hd, tl) = L.splitAt (ix - 1) vals + in pure . Just $ Enumeration (hd <> (addedValue : tl)) + After -> + let (hd, tl) = L.break (insPoint ==) vals + in pure . Just $ Enumeration (hd <> (addedValue : tl)) + +removeSequence :: + Edit -> + Schema -> + SequenceName -> + Sequence -> + Either ApplyFailed (Maybe Sequence) +removeSequence e s sName sqss = runExcept . withExcept (toApplyFailed e) . liftEither $ do + validateRemoveSequence s sName sqss + pure Nothing diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,55 @@ +module Main where + +import qualified Data.List as L +import qualified Data.Text.Lazy as TL +import Database.Beam.AutoMigrate +import Database.Beam.AutoMigrate.Schema.Gen +import Database.Beam.AutoMigrate.Validity +import Test.Database.Beam.AutoMigrate.Arbitrary hiding ((===)) +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck as QC +import Text.Pretty.Simple (pShowNoColor) + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [properties] + +properties :: TestTree +properties = + testGroup + "Diff algorithm properties" + [ QC.testProperty "diff algoritm behaves the same as the reference implementation" $ + \(SimilarSchemas (hsSchema, dbSchema)) -> + fmap (L.sort . map show) (diffReferenceImplementation hsSchema dbSchema) + === fmap (L.sort . map show) (diff hsSchema dbSchema), + QC.testProperty "reverse applying the edits of the diff algorithm yields back the Haskell schema" $ + \(Pretty (SimilarSchemas (hsSchema, dbSchema))) -> + case diff hsSchema dbSchema of + Left e -> error (show e) + Right edits -> (sortEdits edits, dbSchema) `sameSchema` hsSchema, + QC.testProperty "reverse applying the edits of the diff algorithm yields back a valid schema" $ + \(Pretty (SimilarSchemas (hsSchema, dbSchema))) -> + case diff hsSchema dbSchema of + Left e -> error (show e) + Right edits -> + case applyEdits edits dbSchema of + Left e' -> error (show e') + Right s -> validateSchema s === Right () + ] + +sameSchema :: ([WithPriority Edit], Schema) -> Schema -> Property +sameSchema (fullEdits, dbSchema) hsSchema = + counterexample (pretty fullEdits ++ pretty schema' ++ interpret res ++ pretty hsSchema) res + where + pretty :: Show a => a -> String + pretty = TL.unpack . pShowNoColor + + schema' :: Either ApplyFailed Schema + schema' = applyEdits fullEdits dbSchema + + res = schema' == Right hsSchema + interpret True = " == " + interpret False = " /= " diff --git a/tests/Test/Database/Beam/AutoMigrate/Arbitrary.hs b/tests/Test/Database/Beam/AutoMigrate/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Database/Beam/AutoMigrate/Arbitrary.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +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) + +newtype Pretty a = Pretty {unPretty :: a} deriving (Eq, Arbitrary) + +instance Show a => Show (Pretty a) where + show = TL.unpack . pShowNoColor . unPretty + +-- | Drop-in replacement for \"QuickCheck\"'s '(===)' which pretty-prints the output. +infix 4 === + +(===) :: (Eq a, Show a) => a -> a -> Property +x === y = + counterexample (pretty x ++ interpret res ++ pretty y) res + where + pretty :: Show a => a -> String + pretty = TL.unpack . pShowNoColor + res = x == y + interpret True = " == " + interpret False = " /= "