generate arbitrary data for example

beam-core/Database/Beam/Backend/SQL/Types.hs

@@ -3,14 +3,15 @@ module Database.Beam.Backend.SQL.Types where
 
 import qualified Data.Aeson as Json
 import           Data.Bits
+import           GHC.Generics
 
 data SqlNull = SqlNull
   deriving (Show, Eq, Ord, Bounded, Enum)
 newtype SqlBitString = SqlBitString Integer
   deriving (Show, Eq, Ord, Enum, Bits)
 
 newtype SqlSerial a = SqlSerial { unSerial :: a }
-  deriving (Show, Read, Eq, Ord, Num, Integral, Real, Enum)
+  deriving (Show, Read, Eq, Ord, Num, Integral, Real, Enum, Generic)
 
 instance Json.FromJSON a => Json.FromJSON (SqlSerial a) where
   parseJSON a = SqlSerial <$> Json.parseJSON a

beam-postgres/examples/app/Main.hs

@@ -8,12 +8,12 @@ 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 (migration)
+import Pagila.Schema (allMigrationSteps)
 
 main :: IO ()
 main = do
   putStrLn "Migration steps:"
-  mapM_ (putStrLn . unpack) (stepNames migration)
+  mapM_ (putStrLn . unpack) (stepNames allMigrationSteps)
   putStrLn "-------------"
   putStrLn "For each migration step, the sequence of SQL scripts:"
   let
@@ -23,4 +23,4 @@ main = do
       where
       commandType = show . pgCommandType $ syntax
       sqlScript = TL.unpack . TL.decodeUtf8 . pgRenderSyntaxScript . fromPgCommand $ syntax
-  putStrLn $ backendMigrationStepsScript renderer migration
+  putStrLn $ backendMigrationStepsScript renderer allMigrationSteps

beam-postgres/examples/pagila.cabal

@@ -22,7 +22,9 @@ library
                       scientific,
                       bytestring,
                       text,
-                      exceptions,
+                      generic-random,
+                      QuickCheck,
+                      quickcheck-instances,
                       postgresql-simple,
                       beam-core,
                       beam-postgres,

beam-postgres/examples/src/Pagila/Schema.hs

@@ -1,38 +1,82 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Pagila.Schema
   ( module Pagila.Schema.V0002
-  , migration, migrateDB, dbSettings ) 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, runBeamPostgresDebug)
 import Database.Beam.Migrate.Simple (BringUpToDateHooks, bringUpToDateWithHooks, defaultUpToDateHooks, runIrreversibleHook)
 import qualified Database.Beam.Postgres.Migrate as Pg
 
-migration :: MigrationSteps Postgres () (CheckedDatabaseSettings Postgres Pagila.Schema.V0002.PagilaDb)
-migration = migrationStep "Initial commit" V0001.migration >>>
-            migrationStep "Add film actor, inventory, rental table" V0002.migration
+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 Pagila.Schema.V0002.PagilaDb
-dbSettings = unCheckDatabase (evaluateDatabase migration)
+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
     }
 
-migrateDB :: Connection -> IO (Maybe (CheckedDatabaseSettings Postgres Pagila.Schema.V0002.PagilaDb))
-migrateDB conn =
-  runBeamPostgresDebug putStrLn conn
-    $ bringUpToDateWithHooks allowDestructive Pg.migrationBackend migration
+{- |
+  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)
+
+      runInsert $ insert (V0001.staff dbSettings) $ insertValues randomStaff
+
+      {- 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

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,13 +110,17 @@ 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
   primaryKey = CityId . cityId
 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,13 +133,17 @@ 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
   primaryKey = CountryId . countryId
 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,13 +156,17 @@ 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))
                              deriving Generic
   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,13 +205,17 @@ 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))
                                 deriving Generic
   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,13 +309,17 @@ 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)
     deriving Generic
   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,13 +331,17 @@ 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))
                                 deriving Generic
   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)))