diff --git a/README.md b/README.md index a652bfb6..d650cc52 100644 --- a/README.md +++ b/README.md @@ -120,3 +120,7 @@ to enabled_backends: - beam-sqlite ``` + +## Pagila example + +See [Pagila example in `beam-postgres/examples`](beam-postgres/examples/). diff --git a/beam-migrate/Database/Beam/Migrate/Simple.hs b/beam-migrate/Database/Beam/Migrate/Simple.hs index d8776351..1bbe5ad8 100644 --- a/beam-migrate/Database/Beam/Migrate/Simple.hs +++ b/beam-migrate/Database/Beam/Migrate/Simple.hs @@ -6,6 +6,7 @@ module Database.Beam.Migrate.Simple , simpleSchema , simpleMigration , runSimpleMigration + , backendMigrationStepsScript , backendMigrationScript , VerificationResult(..) @@ -338,15 +339,25 @@ runSimpleMigration :: MonadBeam be m runSimpleMigration runner hdl = runner hdl . mapM_ runNoReturn +-- | Given a function to convert a command to a 'String', produce a script that +-- will execute the given migration steps. Usually, the function you provide +-- eventually calls 'displaySyntax' to render the command. +backendMigrationStepsScript :: BeamSqlBackend be + => (BeamSqlBackendSyntax be -> String) + -> MigrationSteps be () a + -> String +backendMigrationStepsScript render migSteps = + migrateScript ((++"\n") . T.unpack) ((++"\n") . render) migSteps + -- | Given a function to convert a command to a 'String', produce a script that -- will execute the given migration. Usually, the function you provide --- eventually calls 'displaySyntax' to rendere the command. +-- eventually calls 'displaySyntax' to render the command. backendMigrationScript :: BeamSqlBackend be => (BeamSqlBackendSyntax be -> String) -> Migration be a -> String backendMigrationScript render mig = - migrateScript ((++"\n") . T.unpack) ((++"\n") . render) (migrationStep "Migration Script" (\() -> mig)) + backendMigrationStepsScript render (migrationStep "Migration Script" (\() -> mig)) -- | Given a 'BeamMigrationBackend', get a string representing a Haskell module -- that would be a good starting point for further development. diff --git a/beam-postgres/examples/app/Main.hs b/beam-postgres/examples/app/Main.hs new file mode 100644 index 00000000..8bdd8fe6 --- /dev/null +++ b/beam-postgres/examples/app/Main.hs @@ -0,0 +1,26 @@ +module Main where + +import Database.Beam.Migrate (stepNames) +import Database.Beam.Migrate.Simple (backendMigrationStepsScript) +import Database.Beam.Postgres.Syntax (pgRenderSyntaxScript, fromPgCommand, pgCommandType) +import Database.Beam.Postgres (Postgres) +import Database.Beam.Backend.SQL ( BeamSqlBackendSyntax ) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import Data.Text (unpack) +import Pagila.Schema (allMigrationSteps) + +main :: IO () +main = do + putStrLn "Migration steps:" + mapM_ (putStrLn . unpack) (stepNames allMigrationSteps) + putStrLn "-------------" + putStrLn "For each migration step, the sequence of SQL scripts:" + let + renderer :: BeamSqlBackendSyntax Postgres -> String + renderer syntax = "SQL command type: " <> commandType <> "\n" + <> "SQL script: \n" <> sqlScript + where + commandType = show . pgCommandType $ syntax + sqlScript = TL.unpack . TL.decodeUtf8 . pgRenderSyntaxScript . fromPgCommand $ syntax + putStrLn $ backendMigrationStepsScript renderer allMigrationSteps diff --git a/beam-postgres/examples/app/RunMigration.hs b/beam-postgres/examples/app/RunMigration.hs new file mode 100644 index 00000000..15b98453 --- /dev/null +++ b/beam-postgres/examples/app/RunMigration.hs @@ -0,0 +1,27 @@ +module RunMigration where + +import Prelude +import Database.PostgreSQL.Simple (connect, close, ConnectInfo(..)) +import Pagila.Schema (migrateDB) + +-- https://hackage.haskell.org/package/postgresql-simple-0.7.0.0/docs/Database-PostgreSQL-Simple.html#t:ConnectInfo +connInfo :: ConnectInfo +connInfo = ConnectInfo "localhost" (read "5432") "postgres" "foo" "postgres" + +main :: IO () +main = do + putStrLn "Pagila migration" + + putStrLn "**This will overwrite data in your Postgres instance**" + putStrLn "Type 'migrate' to proceed." + x <- getLine + + if x == "migrate" then do + putStrLn "Running migration..." + c <- connect connInfo + + _ <- migrateDB c + + close c + else do + putStrLn "Input was not 'migrate'; quitting" diff --git a/beam-postgres/examples/pagila.cabal b/beam-postgres/examples/pagila.cabal index cefa0494..aea26dab 100644 --- a/beam-postgres/examples/pagila.cabal +++ b/beam-postgres/examples/pagila.cabal @@ -22,12 +22,42 @@ library scientific, bytestring, text, + generic-random, + QuickCheck, + quickcheck-instances, postgresql-simple, beam-core, beam-postgres, beam-migrate hs-source-dirs: src - + +executable pagila-print + import: warnings + main-is: Main.hs + build-depends: base, + pagila, + text, + bytestring, + beam-core, + beam-postgres, + beam-migrate + hs-source-dirs: app + default-language: Haskell2010 + +executable pagila-migration + import: warnings + main-is: RunMigration.hs + ghc-options: -main-is RunMigration + build-depends: base, + pagila, + text, + bytestring, + beam-core, + beam-postgres, + beam-migrate, + postgresql-simple + hs-source-dirs: app + default-language: Haskell2010 test-suite pagila-test import: warnings diff --git a/beam-postgres/examples/readme.md b/beam-postgres/examples/readme.md new file mode 100644 index 00000000..e2c68532 --- /dev/null +++ b/beam-postgres/examples/readme.md @@ -0,0 +1,30 @@ +# Pagila example + +There are two executables: + +### 1. `cabal run pagila-print` +`cabal run pagila-print` to see rendering of Postgres migration. This converts the Haskell to SQL statements and prints these to the console. + +### 2. Destructive: apply migration to Postgres instance + +Hard-code your Postgres connection parameters into `app/RunMigration.hs` `connInfo`. +Then `cabal run pagila-migration`. *This will overwrite your Postgres data*. + +The result will be the Pagila database schema in your Postgres instance: +``` +postgres=# \d + List of relations + Schema | Name | Type | Owner +--------+-------------------------------+----------+---------- + public | actor | table | postgres + public | actor_actor_id_seq | sequence | postgres + public | address | table | postgres + public | address_address_id_seq | sequence | postgres + public | beam_migration | table | postgres + public | beam_version | table | postgres + public | category | table | postgres +. +. +. +``` + diff --git a/beam-postgres/examples/src/Pagila/Schema.hs b/beam-postgres/examples/src/Pagila/Schema.hs index 17c3bc49..c2118297 100644 --- a/beam-postgres/examples/src/Pagila/Schema.hs +++ b/beam-postgres/examples/src/Pagila/Schema.hs @@ -1,23 +1,82 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Pagila.Schema ( module Pagila.Schema.V0002 - , migration, db ) where + , allMigrationSteps, migrateDB, dbSettings, dbSettings' ) where + +import Database.PostgreSQL.Simple import Pagila.Schema.V0002 hiding (migration) -import qualified Pagila.Schema.V0001 as V0001 (migration) -import qualified Pagila.Schema.V0002 as V0002 (migration) +import qualified Pagila.Schema.V0001 as V0001 +import qualified Pagila.Schema.V0002 as V0002 import Control.Arrow ( (>>>) ) -import Database.Beam (DatabaseSettings) +import Test.QuickCheck.Gen (Gen, sample') +import Test.QuickCheck.Arbitrary (arbitrary) + +import Database.Beam (DatabaseSettings, liftIO, insert, insertValues, runInsert) import Database.Beam.Migrate.Types ( CheckedDatabaseSettings, MigrationSteps, unCheckDatabase , evaluateDatabase, migrationStep) -import Database.Beam.Postgres (Postgres) +import Database.Beam.Postgres (Postgres, runBeamPostgresDebug) +import Database.Beam.Migrate.Simple (BringUpToDateHooks, bringUpToDateWithHooks, defaultUpToDateHooks, runIrreversibleHook) +import qualified Database.Beam.Postgres.Migrate as Pg + +firstMigrationStep :: MigrationSteps Postgres () (CheckedDatabaseSettings Postgres V0001.PagilaDb) +firstMigrationStep = migrationStep "Initial commit" V0001.migration + +secondMigrationStep :: MigrationSteps Postgres (CheckedDatabaseSettings Postgres V0001.PagilaDb) (CheckedDatabaseSettings Postgres V0002.PagilaDb) +secondMigrationStep = migrationStep "Add film actor, inventory, rental table" V0002.migration + +allMigrationSteps :: MigrationSteps Postgres () (CheckedDatabaseSettings Postgres V0002.PagilaDb) +allMigrationSteps = firstMigrationStep >>> secondMigrationStep + +dbSettings :: DatabaseSettings Postgres V0001.PagilaDb +dbSettings = unCheckDatabase (evaluateDatabase firstMigrationStep) + +dbSettings' :: DatabaseSettings Postgres V0002.PagilaDb +dbSettings' = unCheckDatabase (evaluateDatabase allMigrationSteps) + +allowDestructive :: (MonadFail m) => BringUpToDateHooks m +allowDestructive = + defaultUpToDateHooks + { runIrreversibleHook = return True + } + +{- | + Run two migrations: V0001 and V0002. + After V0001 migration, insert randomly generated countries and staff. + This demonstrates the V0002 migration will not delete that data. +-} +migrateDB :: Connection -> IO (Maybe (CheckedDatabaseSettings Postgres V0002.PagilaDb)) +migrateDB conn = runBeamPostgresDebug putStrLn conn $ do + + -- Run migration V0001 + mx :: Maybe (CheckedDatabaseSettings Postgres V0001.PagilaDb) <- bringUpToDateWithHooks allowDestructive Pg.migrationBackend firstMigrationStep + + case mx of + -- if migration V0001 succeeded, proceed. + Just (_ :: CheckedDatabaseSettings Postgres V0001.PagilaDb) -> do + -- generate random countries + randomCountries :: [V0001.Country] <- liftIO + . fmap (zipWith (\i country -> country { V0001.countryId = i }) [1..]) + $ sample' (arbitrary :: Gen V0001.Country) + runInsert $ insert (V0001.country dbSettings) $ insertValues randomCountries + + -- generate random V0001 Staff + randomStaff :: [V0001.Staff] <- + liftIO + . fmap (zipWith (\i staff -> staff { V0001.staffId = i }) [1..]) + . fmap (fmap (\staffMember -> staffMember { V0001.staffPicture = Nothing } )) -- overwrite picture with null + $ sample' (arbitrary :: Gen V0001.Staff) -migration :: MigrationSteps Postgres () (CheckedDatabaseSettings Postgres Pagila.Schema.V0002.PagilaDb) -migration = migrationStep "Initial commit" V0001.migration >>> - migrationStep "Add film actor, inventory, rental table" V0002.migration + runInsert $ insert (V0001.staff dbSettings) $ insertValues randomStaff -db :: DatabaseSettings Postgres Pagila.Schema.V0002.PagilaDb -db = unCheckDatabase (evaluateDatabase migration) + {- Run migrations V0001 (redundantly) and V0002. + The V0002 migration will add staff `salary` field, among other changes. + See 'Pagila.Schema.V0002.migrateToNewStaffWithSalary'. + -} + bringUpToDateWithHooks allowDestructive Pg.migrationBackend allMigrationSteps + Nothing -> + pure Nothing diff --git a/beam-postgres/examples/src/Pagila/Schema/V0001.hs b/beam-postgres/examples/src/Pagila/Schema/V0001.hs index b00163e1..3a2a8841 100644 --- a/beam-postgres/examples/src/Pagila/Schema/V0001.hs +++ b/beam-postgres/examples/src/Pagila/Schema/V0001.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE RecordWildCards #-} @@ -7,6 +8,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} module Pagila.Schema.V0001 where -- TODO explicit module exports @@ -59,6 +62,9 @@ import Data.Text (Text) import Data.ByteString (ByteString) import Data.Time.LocalTime (LocalTime) import Data.Scientific (Scientific) +import Test.QuickCheck ( Arbitrary(arbitrary) ) +import Generic.Random ( genericArbitrary, uniform ) +import Test.QuickCheck.Instances () -- Address table @@ -73,9 +79,12 @@ data AddressT f , addressPhone :: Columnar f Text , addressLastUpdate :: Columnar f LocalTime } deriving Generic + type Address = AddressT Identity deriving instance Show Address deriving instance Eq Address +instance Arbitrary Address where + arbitrary = genericArbitrary uniform instance Table AddressT where data PrimaryKey AddressT f = AddressId (Columnar f (SqlSerial Int32)) deriving Generic @@ -84,6 +93,11 @@ type AddressId = PrimaryKey AddressT Identity deriving instance Show AddressId deriving instance Eq AddressId +instance Arbitrary (SqlSerial Int32) where + arbitrary = genericArbitrary uniform +instance Arbitrary AddressId where + arbitrary = genericArbitrary uniform -- should be fixed at 1 + -- City table data CityT f @@ -96,6 +110,8 @@ data CityT f type City = CityT Identity deriving instance Show City deriving instance Eq City +instance Arbitrary City where + arbitrary = genericArbitrary uniform instance Table CityT where data PrimaryKey CityT f = CityId (Columnar f Int32) deriving Generic @@ -103,6 +119,8 @@ instance Table CityT where type CityId = PrimaryKey CityT Identity deriving instance Show CityId deriving instance Eq CityId +instance Arbitrary CityId where + arbitrary = genericArbitrary uniform -- should be fixed at 1 -- Country table @@ -115,6 +133,8 @@ data CountryT f type Country = CountryT Identity deriving instance Show Country deriving instance Eq Country +instance Arbitrary Country where + arbitrary = genericArbitrary uniform instance Table CountryT where data PrimaryKey CountryT f = CountryId (Columnar f Int32) deriving Generic @@ -122,6 +142,8 @@ instance Table CountryT where type CountryId = PrimaryKey CountryT Identity deriving instance Show CountryId deriving instance Eq CountryId +instance Arbitrary CountryId where + arbitrary = genericArbitrary uniform -- should be fixed at 1 -- Actor @@ -134,6 +156,8 @@ data ActorT f } deriving Generic type Actor = ActorT Identity deriving instance Show Actor; deriving instance Eq Actor +instance Arbitrary Actor where + arbitrary = genericArbitrary uniform instance Table ActorT where data PrimaryKey ActorT f = ActorId (Columnar f (SqlSerial Int32)) @@ -141,6 +165,8 @@ instance Table ActorT where primaryKey = ActorId . actorId type ActorId = PrimaryKey ActorT Identity deriving instance Show ActorId; deriving instance Eq ActorId +instance Arbitrary ActorId where + arbitrary = genericArbitrary uniform -- Category @@ -152,12 +178,16 @@ data CategoryT f } deriving Generic type Category = CategoryT Identity deriving instance Show Category; deriving instance Eq Category +instance Arbitrary Category where + arbitrary = genericArbitrary uniform instance Table CategoryT where data PrimaryKey CategoryT f = CategoryId (Columnar f Int32) deriving Generic primaryKey = CategoryId . categoryId type CategoryId = PrimaryKey CategoryT Identity deriving instance Show CategoryId; deriving instance Eq CategoryId +instance Arbitrary CategoryId where + arbitrary = genericArbitrary uniform -- Customer @@ -175,6 +205,8 @@ data CustomerT f } deriving Generic type Customer = CustomerT Identity deriving instance Show Customer; deriving instance Eq Customer +instance Arbitrary Customer where + arbitrary = genericArbitrary uniform instance Table CustomerT where data PrimaryKey CustomerT f = CustomerId (Columnar f (SqlSerial Int32)) @@ -182,6 +214,8 @@ instance Table CustomerT where primaryKey = CustomerId . customerId type CustomerId = PrimaryKey CustomerT Identity deriving instance Show CustomerId; deriving instance Eq CustomerId +instance Arbitrary CustomerId where + arbitrary = genericArbitrary uniform -- Store @@ -200,6 +234,8 @@ instance Table StoreT where primaryKey = StoreId . storeId type StoreId = PrimaryKey StoreT Identity deriving instance Show StoreId; deriving instance Eq StoreId +instance Arbitrary StoreId where + arbitrary = genericArbitrary uniform -- Staff @@ -219,12 +255,16 @@ data StaffT f } deriving Generic type Staff = StaffT Identity deriving instance Eq Staff; deriving instance Show Staff +instance Arbitrary Staff where + arbitrary = genericArbitrary uniform instance Table StaffT where data PrimaryKey StaffT f = StaffId (Columnar f Int32) deriving Generic primaryKey = StaffId . staffId type StaffId = PrimaryKey StaffT Identity deriving instance Eq StaffId; deriving instance Show StaffId +instance Arbitrary StaffId where + arbitrary = genericArbitrary uniform -- Film @@ -246,6 +286,8 @@ data FilmT f type Film = FilmT Identity deriving instance Eq Film deriving instance Show Film +instance Arbitrary Film where + arbitrary = genericArbitrary uniform instance Table FilmT where data PrimaryKey FilmT f = FilmId (Columnar f (SqlSerial Int32)) @@ -254,6 +296,8 @@ instance Table FilmT where type FilmId = PrimaryKey FilmT Identity deriving instance Eq FilmId deriving instance Show FilmId +instance Arbitrary FilmId where + arbitrary = genericArbitrary uniform -- Film category @@ -265,6 +309,8 @@ data FilmCategoryT f } deriving Generic type FilmCategory = FilmCategoryT Identity deriving instance Eq FilmCategory; deriving instance Show FilmCategory +instance Arbitrary FilmCategory where + arbitrary = genericArbitrary uniform instance Table FilmCategoryT where data PrimaryKey FilmCategoryT f = FilmCategoryId (PrimaryKey CategoryT f) (PrimaryKey FilmT f) @@ -272,6 +318,8 @@ instance Table FilmCategoryT where primaryKey = FilmCategoryId <$> filmCategoryCategory <*> filmCategoryFilm type FilmCategoryId = PrimaryKey FilmCategoryT Identity deriving instance Eq FilmCategoryId; deriving instance Show FilmCategoryId +instance Arbitrary FilmCategoryId where + arbitrary = genericArbitrary uniform -- Language @@ -283,6 +331,8 @@ data LanguageT f } deriving Generic type Language = LanguageT Identity deriving instance Eq Language; deriving instance Show Language +instance Arbitrary Language where + arbitrary = genericArbitrary uniform instance Table LanguageT where data PrimaryKey LanguageT f = LanguageId (Columnar f (SqlSerial Int32)) @@ -290,6 +340,8 @@ instance Table LanguageT where primaryKey = LanguageId . languageId type LanguageId = PrimaryKey LanguageT Identity deriving instance Eq LanguageId; deriving instance Show LanguageId +instance Arbitrary LanguageId where + arbitrary = genericArbitrary uniform -- Pagila db @@ -414,7 +466,7 @@ migration () = do (field "email" (varchar (Just 50))) (StoreId (field "store_id" smallint notNull)) (field "active" boolean (defaultTo_ (val_ True)) notNull) - (field "username" (varchar (Just 16)) notNull) + (field "username" (varchar (Just 64)) notNull) (field "password" binaryLargeObject) lastUpdateField (field "picture" (maybeType bytea))) diff --git a/beam-postgres/examples/src/Pagila/Schema/V0002.hs b/beam-postgres/examples/src/Pagila/Schema/V0002.hs index 4d86484d..2122b2b3 100644 --- a/beam-postgres/examples/src/Pagila/Schema/V0002.hs +++ b/beam-postgres/examples/src/Pagila/Schema/V0002.hs @@ -39,6 +39,10 @@ import Database.Beam.Migrate.SQL.Tables import Data.Time.LocalTime (LocalTime) +import Test.QuickCheck +import Generic.Random +import Test.QuickCheck.Instances () + -- film actor data FilmActorT f @@ -49,6 +53,8 @@ data FilmActorT f } deriving Generic type FilmActor = FilmActorT Identity deriving instance Eq FilmActor; deriving instance Show FilmActor +instance Arbitrary FilmActor where + arbitrary = genericArbitrary uniform instance Table FilmActorT where data PrimaryKey FilmActorT f = FilmActorId (PrimaryKey V0001.ActorT f) (PrimaryKey V0001.FilmT f) @@ -56,6 +62,8 @@ instance Table FilmActorT where primaryKey fa = FilmActorId (filmActorActor fa) (filmActorFilm fa) type FilmActorId = PrimaryKey FilmActorT Identity deriving instance Eq FilmActorId; deriving instance Show FilmActorId +instance Arbitrary FilmActorId where + arbitrary = genericArbitrary uniform -- Pagila db @@ -67,6 +75,8 @@ instance Table NewStaffT where primaryKey = NewStaffId . staffId type NewStaffId = PrimaryKey NewStaffT Identity deriving instance Eq NewStaffId; deriving instance Show NewStaffId +instance Arbitrary NewStaffId where + arbitrary = genericArbitrary uniform data NewStaffT f = NewStaffT @@ -85,6 +95,9 @@ data NewStaffT f } deriving Generic type NewStaff = NewStaffT Identity deriving instance Eq NewStaff; deriving instance Show NewStaff +instance Arbitrary NewStaff where + arbitrary = genericArbitrary uniform + instance Beamable (PrimaryKey NewStaffT) instance Beamable NewStaffT diff --git a/docs/user-guide/custom-type-migration.md b/docs/user-guide/custom-type-migration.md index 601787be..396fe8ec 100644 --- a/docs/user-guide/custom-type-migration.md +++ b/docs/user-guide/custom-type-migration.md @@ -1,4 +1,4 @@ -**Note**: The code used in this guide is in `beam-postgres/examples/Pagila/Schema/CustomMigrateExample.hs`. +**Note**: The code used in this guide is in the `pagila.cabal` package, located in `beam-postgres/examples/`. `cabal run pagila` to see a rendering of the example schema. ### Using Custom Types in migration ### In Beam [Tutorial 3](https://haskell-beam.github.io/beam/tutorials/tutorial3/) we looked at marshalling custom types.