beam-migrate 0.2.0.0 → 0.3.0.0

raw patch · 14 files changed

+627/−116 lines, 14 filesdep +uuiddep ~beam-coredep ~freedep ~haskell-src-extsPVP ok

version bump matches the API change (PVP)

Dependencies added: uuid

Dependency ranges changed: beam-core, free, haskell-src-exts, pqueue

API changes (from Hackage documentation)

Files

• ChangeLog.md +10/−2
• Database/Beam/Haskell/Syntax.hs +24/−11
• Database/Beam/Migrate.hs +4/−4
• Database/Beam/Migrate/Actions.hs +23/−20
• Database/Beam/Migrate/Backend.hs +5/−5
• Database/Beam/Migrate/Generics/Tables.hs +13/−7
• Database/Beam/Migrate/Log.hs +196/−0
• Database/Beam/Migrate/SQL/BeamExtensions.hs +1/−1
• Database/Beam/Migrate/SQL/SQL92.hs +11/−3
• Database/Beam/Migrate/SQL/Tables.hs +28/−10
• Database/Beam/Migrate/Simple.hs +221/−15
• Database/Beam/Migrate/Types.hs +76/−25
• Database/Beam/Migrate/Types/CheckedEntities.hs +5/−2
• beam-migrate.cabal +10/−11

@@ -1,5 +1,13 @@-# Revision history for beam-migrate+## 0.3.0.0 -## 0.1.0.0  -- YYYY-mm-dd+* Re-introduce backend parameter as `Database` type class+* Move beam migration log schema to beam-migrate, since many+  applications will want to easily manage a database using the+  haskell-based migrations+* Add `bringUpToDate` and `bringUpToDateWithHooks` to+  `Database.Beam.Migrate.Simple`, which can be used to bring a+  database up to date with the given migration.++## 0.2.0.0  -- 2018-01-20  * First version. Released on an unsuspecting world.

@@ -11,7 +11,7 @@ -- for us in @haskell-src-exts@. module Database.Beam.Haskell.Syntax where -import           Database.Beam hiding (lookup)+import           Database.Beam import           Database.Beam.Backend.SQL import           Database.Beam.Backend.SQL.Builder import           Database.Beam.Migrate.SQL.SQL92@@ -199,15 +199,15 @@ databaseTypeDecl entities =   Hs.DataDecl () (Hs.DataType ()) Nothing               declHead [ conDecl ]-              (Just deriving_)+              [deriving_]   where     declHead = Hs.DHApp () (Hs.DHead () (Hs.Ident () "Db"))                            (Hs.UnkindedVar () (Hs.Ident () "entity"))     conDecl = Hs.QualConDecl () Nothing Nothing                 (Hs.RecDecl () (Hs.Ident () "Db") (mkField <$> entities))-    deriving_ = Hs.Deriving () [ Hs.IRule () Nothing Nothing $-                                 Hs.IHCon () $ Hs.UnQual () $-                                 Hs.Ident () "Generic" ]+    deriving_ = Hs.Deriving () Nothing [ Hs.IRule () Nothing Nothing $+                                         Hs.IHCon () $ Hs.UnQual () $+                                         Hs.Ident () "Generic" ]      mkField entity = Hs.FieldDecl () [ Hs.Ident () (entityDbFieldName entity) ]                                      (buildHsDbField (hsEntityDbDecl entity) $@@ -358,13 +358,18 @@       backend = foldMap hsEntityBackend entities       syntax  = foldMap hsEntitySyntax entities +      backendHs = case backend of+                    HsBeamBackendNone -> error "Can't instantiate Database instance: No backend matches"+                    HsBeamBackendSingle ty _ -> hsTypeSyntax ty+                    HsBeamBackendConstrained {} -> tyVarNamed "be" -- TODO constraints+       decls = foldMap (map hsDeclSyntax . hsEntityDecls) entities ++               [ databaseTypeDecl entities                , migrationTypeDecl backend syntax []               , migrationDecl backend [] migrations entities -              , hsInstance "Database" [ tyConNamed "Db" ] []+              , hsInstance "Database" [ backendHs, tyConNamed "Db" ] []                , dbTypeDecl backend syntax               , dbDecl backend syntax [] ]@@ -468,7 +473,7 @@       imports = foldMap (\(_, ty) -> hsTypeImports (hsColumnSchemaType ty)) fields        tblDecl = Hs.DataDecl () (Hs.DataType ()) Nothing-                  tblDeclHead [ tblConDecl ] (Just deriving_)+                  tblDeclHead [ tblConDecl ] [deriving_]       tblDeclHead = Hs.DHApp () (Hs.DHead () (Hs.Ident () tyName))                                 (Hs.UnkindedVar () (Hs.Ident () "f"))       tblConDecl = Hs.QualConDecl () Nothing Nothing (Hs.RecDecl () (Hs.Ident () tyConName) tyConFieldDecls)@@ -480,7 +485,7 @@                                                    [ tyVarNamed "f"                                                    , hsTypeSyntax (hsColumnSchemaType ty) ])) fields -      deriving_ = Hs.Deriving () [ inst "Generic" ]+      deriving_ = Hs.Deriving () Nothing [ inst "Generic" ]        tblBeamable = hsInstance "Beamable" [ tyConNamed tyName ] []       tblPun = Hs.TypeDecl () (Hs.DHead () (Hs.Ident () tyConName))@@ -511,7 +516,7 @@ instance IsSql92TableConstraintSyntax HsTableConstraint where   primaryKeyConstraintSyntax fields =     HsTableConstraint $ \tblNm tblFields ->-    let primaryKeyDataDecl = Hs.InsData () (Hs.DataType ()) primaryKeyType [ primaryKeyConDecl ] (Just primaryKeyDeriving)+    let primaryKeyDataDecl = Hs.InsData () (Hs.DataType ()) primaryKeyType [ primaryKeyConDecl ] [ primaryKeyDeriving ]          tableTypeNm = tblNm <> "T"         tableTypeKeyNm = tblNm <> "Key"@@ -520,7 +525,7 @@          primaryKeyType = tyApp (tyConNamed "PrimaryKey") [ tyConNamed (T.unpack tableTypeNm), tyVarNamed "f" ]         primaryKeyConDecl  = Hs.QualConDecl () Nothing Nothing (Hs.ConDecl () (Hs.Ident () (T.unpack tableTypeKeyNm)) fieldTys)-        primaryKeyDeriving = Hs.Deriving () [ inst "Generic" ]+        primaryKeyDeriving = Hs.Deriving () Nothing [ inst "Generic" ]          primaryKeyTypeDecl = Hs.TypeDecl () (Hs.DHead () (Hs.Ident () (T.unpack tableTypeKeyNm)))                                             (tyApp (tyConNamed "PrimaryKey")@@ -597,6 +602,9 @@   charLengthE = hsApp (hsVar "charLengthE") . pure   octetLengthE = hsApp (hsVar "octetLengthE") . pure   bitLengthE = hsApp (hsVar "bitLengthE") . pure+  lowerE = hsApp (hsVar "lowerE") . pure+  upperE = hsApp (hsVar "upperE") . pure+  trimE = hsApp (hsVar "trimE") . pure    existsE = error "existsE"   uniqueE = error "uniqueE"@@ -649,6 +657,9 @@  instance HasSqlValueSyntax HsExpr Int where   sqlValueSyntax = hsInt+instance HasSqlValueSyntax HsExpr Bool where+  sqlValueSyntax True = hsVar "True"+  sqlValueSyntax False = hsVar "False"  instance IsSql92FieldNameSyntax HsExpr where   qualifiedField tbl nm = hsApp (hsVar "qualifiedField") [ hsStr tbl, hsStr nm ]@@ -856,7 +867,7 @@     instHead = foldl (Hs.IHApp ()) (Hs.IHCon () (Hs.UnQual () (Hs.Ident () (T.unpack classNm)))) params  hsDerivingInstance :: T.Text -> [ Hs.Type () ] -> Hs.Decl ()-hsDerivingInstance classNm params = Hs.DerivDecl () Nothing (Hs.IRule () Nothing Nothing instHead)+hsDerivingInstance classNm params = Hs.DerivDecl () Nothing Nothing (Hs.IRule () Nothing Nothing instHead)   where     instHead = foldl (Hs.IHApp ()) (Hs.IHCon () (Hs.UnQual () (Hs.Ident () (T.unpack classNm)))) params @@ -947,5 +958,7 @@ instance Hashable (Hs.ImportSpec ()) instance Hashable (Hs.Namespace ()) instance Hashable (Hs.CName ())+instance Hashable (Hs.DerivStrategy ())+instance Hashable (Hs.MaybePromotedName ()) instance Hashable a => Hashable (S.Set a) where   hashWithSalt s a = hashWithSalt s (S.toList a)

@@ -34,13 +34,13 @@ -- -- As one final point, @beam-migrate@ can generate schemas in any beam-supported -- SQL DDL syntax. The @beam-migrate@ module provides a DDL syntax for Haskell--- in 'Database.Beam.Haskell.Syntax'. This allows @beam-migrate@ to translate+-- in "Database.Beam.Haskell.Syntax". This allows @beam-migrate@ to translate -- predicate sets into the corresponding Haskell schema and the corresponding -- Haskell migration script. This reflection allows tool based off of -- @beam-migrate@ to support schema generation from an existing database. -- -- For more information on checked databases, see the--- 'Database.Beam.Migrate.Checks' module.+-- "Database.Beam.Migrate.Checks" module. -- -- == Migrations --@@ -58,12 +58,12 @@ -- script in a given backend syntax, or generate an appropriate -- 'DatabaseSettings' object for use with the rest of the beam ecosystem. ----- For more information in migrations see 'Database.Beam.Migrate.Types'+-- For more information in migrations see "Database.Beam.Migrate.Types" -- -- == Syntax -- -- For low-level access to the underlying SQL syntax builders, see--- 'Database.Beam.Migrate.Syntax'+-- "Database.Beam.Migrate.SQL.SQL92" -- -- == Advanced features --

@@ -127,7 +127,7 @@     -- their source (user or from previous actions)   , dbStateKey                :: !(HS.HashSet SomeDatabasePredicate)     -- ^ HS.fromMap of 'dbStateCurrentState', for maximal sharing-  , dbStateCmdSequence        :: !(Seq.Seq cmd)+  , dbStateCmdSequence        :: !(Seq.Seq (MigrationCommand cmd))     -- ^ The current sequence of commands we've committed to in this state   } deriving Show @@ -168,16 +168,13 @@ -- Given a particular starting point, the destination database is the database -- where each predicate in 'actionPreConditions' has been removed and each -- predicate in 'actionPostConditions' has been added.--------- data PotentialAction cmd   = PotentialAction   { actionPreConditions  :: !(HS.HashSet SomeDatabasePredicate)     -- ^ Preconditions that will no longer apply   , actionPostConditions :: !(HS.HashSet SomeDatabasePredicate)     -- ^ Conditions that will apply after we're done-  , actionCommands :: !(Seq.Seq cmd)+  , actionCommands :: !(Seq.Seq (MigrationCommand cmd))     -- ^ The sequence of commands that accomplish this movement in the database     -- graph. For an edge, 'actionCommands' contains one command; for a path, it     -- will contain more.@@ -276,7 +273,7 @@  -- | Action provider for SQL92 @CREATE TABLE@ actions. createTableActionProvider :: forall cmd-                           . ( Sql92SaneDdlCommandSyntax cmd+                           . ( Sql92SaneDdlCommandSyntaxMigrateOnly cmd                              , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )                           => ActionProvider cmd createTableActionProvider =@@ -319,11 +316,13 @@              cmd = createTableCmd (createTableSyntax Nothing postTblNm colsSyntax tblConstraints)              tblConstraints = [ primaryKeyConstraintSyntax primaryKey ]              colsSyntax = map (\(colNm, type_, cs) -> (colNm, columnSchemaSyntax type_ Nothing cs Nothing)) columns-         pure (PotentialAction mempty (HS.fromList postConditions) (Seq.singleton cmd) ("Create the table " <> postTblNm) createTableWeight)+         pure (PotentialAction mempty (HS.fromList postConditions)+                               (Seq.singleton (MigrationCommand cmd MigrationKeepsData))+                               ("Create the table " <> postTblNm) createTableWeight)  -- | Action provider for SQL92 @DROP TABLE@ actions dropTableActionProvider :: forall cmd-                        . ( Sql92SaneDdlCommandSyntax cmd+                        . ( Sql92SaneDdlCommandSyntaxMigrateOnly cmd                           , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )                         => ActionProvider cmd dropTableActionProvider =@@ -345,11 +344,13 @@         -- Now, collect all preconditions that may be related to the dropped table         let cmd = dropTableCmd (dropTableSyntax preTblNm)         pure ({-trace ("Dropping table " <> show preTblNm <> " would drop " <> show relatedPreds) $ -}-              PotentialAction (HS.fromList (SomeDatabasePredicate tblP:relatedPreds)) mempty (Seq.singleton cmd) ("Drop table " <> preTblNm) dropTableWeight)+              PotentialAction (HS.fromList (SomeDatabasePredicate tblP:relatedPreds)) mempty+                              (Seq.singleton (MigrationCommand cmd MigrationLosesData))+                              ("Drop table " <> preTblNm) dropTableWeight)  -- | Action provider for SQL92 @ALTER TABLE ... ADD COLUMN ...@ actions addColumnProvider :: forall cmd-                   . ( Sql92SaneDdlCommandSyntax cmd+                   . ( Sql92SaneDdlCommandSyntaxMigrateOnly cmd                      , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )                    => ActionProvider cmd addColumnProvider =@@ -369,13 +370,13 @@          let cmd = alterTableCmd (alterTableSyntax tblNm (addColumnSyntax colNm schema))              schema = columnSchemaSyntax colType Nothing [] Nothing          pure (PotentialAction mempty (HS.fromList [SomeDatabasePredicate colP])-                               (Seq.singleton cmd)+                               (Seq.singleton (MigrationCommand cmd MigrationKeepsData))                                ("Add column " <> colNm <> " to " <> tblNm)                 (addColumnWeight + fromIntegral (T.length tblNm + T.length colNm)))  -- | Action provider for SQL92 @ALTER TABLE ... DROP COLUMN ...@ actions dropColumnProvider :: forall cmd-                    . ( Sql92SaneDdlCommandSyntax cmd+                    . ( Sql92SaneDdlCommandSyntaxMigrateOnly cmd                       , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )                    => ActionProvider cmd dropColumnProvider = ActionProvider provider@@ -399,13 +400,13 @@           let cmd = alterTableCmd (alterTableSyntax tblNm (dropColumnSyntax colNm))          pure (PotentialAction (HS.fromList (SomeDatabasePredicate colP:relatedPreds)) mempty-                               (Seq.singleton cmd)+                               (Seq.singleton (MigrationCommand cmd MigrationLosesData))                                ("Drop column " <> colNm <> " from " <> tblNm)                 (dropColumnWeight + fromIntegral (T.length tblNm + T.length colNm)))  -- | Action provider for SQL92 @ALTER TABLE ... ALTER COLUMN ... SET NULL@ addColumnNullProvider :: forall cmd-                       . Sql92SaneDdlCommandSyntax cmd+                       . Sql92SaneDdlCommandSyntaxMigrateOnly cmd                       => ActionProvider cmd addColumnNullProvider = ActionProvider provider   where@@ -422,12 +423,13 @@          guard (tblNm == tblNm'' && colNm == colNm')           let cmd = alterTableCmd (alterTableSyntax tblNm (alterColumnSyntax colNm setNotNullSyntax))-         pure (PotentialAction mempty (HS.fromList [SomeDatabasePredicate colP]) (Seq.singleton cmd)+         pure (PotentialAction mempty (HS.fromList [SomeDatabasePredicate colP])+                               (Seq.singleton (MigrationCommand cmd MigrationKeepsData))                                ("Add not null constraint to " <> colNm <> " on " <> tblNm) 100)  -- | Action provider for SQL92 @ALTER TABLE ... ALTER COLUMN ... SET  NOT NULL@ dropColumnNullProvider :: forall cmd-                        . Sql92SaneDdlCommandSyntax cmd+                        . Sql92SaneDdlCommandSyntaxMigrateOnly cmd                        => ActionProvider cmd dropColumnNullProvider = ActionProvider provider   where@@ -444,7 +446,8 @@          guard (tblNm == tblNm'' && colNm == colNm')           let cmd = alterTableCmd (alterTableSyntax tblNm (alterColumnSyntax colNm setNullSyntax))-         pure (PotentialAction (HS.fromList [SomeDatabasePredicate colP]) mempty (Seq.singleton cmd)+         pure (PotentialAction (HS.fromList [SomeDatabasePredicate colP]) mempty+                               (Seq.singleton (MigrationCommand cmd MigrationKeepsData))                                ("Drop not null constraint for " <> colNm <> " on " <> tblNm) 100)  -- | Default action providers for any SQL92 compliant syntax.@@ -456,7 +459,7 @@ --  * ALTER TABLE ... ADD COLUMN ... --  * ALTER TABLE ... DROP COLUMN ... --  * ALTER TABLE ... ALTER COLUMN ... SET [NOT] NULL-defaultActionProvider :: ( Sql92SaneDdlCommandSyntax cmd+defaultActionProvider :: ( Sql92SaneDdlCommandSyntaxMigrateOnly cmd                          , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) )                       => ActionProvider cmd defaultActionProvider =@@ -492,7 +495,7 @@ -- from injecting arbitrary actions. Instead the caller is limited to choosing -- only valid actions as provided by the suppled 'ActionProvider'. data Solver cmd where-  ProvideSolution :: [cmd] -> Solver cmd+  ProvideSolution :: [ MigrationCommand cmd ] -> Solver cmd   SearchFailed    :: [ DatabaseState cmd ] -> Solver cmd   ChooseActions   :: { choosingActionsAtState :: !(DatabaseState cmd)                        -- ^ The current node we're searching at@@ -511,7 +514,7 @@  -- | Represents the final results of a search data FinalSolution cmd-  = Solved [ cmd ]+  = Solved [ MigrationCommand cmd ]     -- ^ The search found a path from the source to the destination database,     -- and has provided a set of commands that would work   | Candidates [ DatabaseState cmd ]

@@ -19,14 +19,14 @@ -- deserialize them from JSON. Finally, if your backend has custom -- 'DatabasePredicate's you will have to provide appropriate 'ActionProvider's -- to discover potential actions for your backend. See the documentation for--- 'Database.Beam.Migrate.Actions' for more information.+-- "Database.Beam.Migrate.Actions" for more information. -- -- Tools may be interested in the 'SomeBeamMigrationBackend' data type which -- provides a monomorphic type to wrap the polymorphic 'BeamMigrationBackend' -- type. Currently, @beam-migrate-cli@ uses this type to get the underlying -- 'BeamMigrationBackend' via the @hint@ package. ----- For an example migrate backend, see 'Database.Beam.Sqlite.Migrates'+-- For an example migrate backend, see "Database.Beam.Sqlite.Migrate" module Database.Beam.Migrate.Backend   ( BeamMigrationBackend(..)   , DdlError@@ -69,7 +69,7 @@ -- | Backends should create a value of this type and export it in an exposed -- module under the name 'migrationBackend'. See the module documentation for -- more details.-data BeamMigrationBackend be commandSyntax hdl where+data BeamMigrationBackend commandSyntax be hdl m where   BeamMigrationBackend ::     ( MonadBeam commandSyntax be hdl m     , Typeable be@@ -92,7 +92,7 @@     , backendConvertToHaskell :: HaskellPredicateConverter     , backendActionProvider :: ActionProvider commandSyntax     , backendTransact :: forall a. String -> m a -> IO (Either DdlError a)-    } -> BeamMigrationBackend be commandSyntax hdl+    } -> BeamMigrationBackend commandSyntax be hdl m  -- | Monomorphic wrapper for use with plugin loaders that cannot handle -- polymorphism@@ -101,7 +101,7 @@                               , IsSql92DdlCommandSyntax commandSyntax                               , IsSql92Syntax commandSyntax                               , Sql92SanityCheck commandSyntax ) =>-                              BeamMigrationBackend be commandSyntax hdl+                              BeamMigrationBackend commandSyntax be hdl m                            -> SomeBeamMigrationBackend  -- | In order to support Haskell schema generation, backends need to provide a

@@ -26,6 +26,7 @@ import Data.Text (Text) import Data.Scientific (Scientific) import Data.Time.Calendar (Day)+import Data.Time (TimeOfDay) import Data.Int import Data.Word @@ -69,6 +70,14 @@   gDefaultTblSettingsChecks syntax _ _ =     K1 (to (gDefaultTblSettingsChecks syntax (Proxy :: Proxy (Rep (embeddedTbl Identity))) True)) +instance ( Generic (embeddedTbl (Nullable (Const [FieldCheck])))+         , IsSql92DdlCommandSyntax syntax+         , GMigratableTableSettings syntax (Rep (embeddedTbl (Nullable Identity))) (Rep (embeddedTbl (Nullable (Const [FieldCheck])))) ) =>+  GMigratableTableSettings syntax (Rec0 (embeddedTbl (Nullable Identity))) (Rec0 (embeddedTbl (Nullable (Const [FieldCheck])))) where++  gDefaultTblSettingsChecks syntax _ _ =+    K1 (to (gDefaultTblSettingsChecks syntax (Proxy :: Proxy (Rep (embeddedTbl (Nullable Identity)))) True))+ -- * Nullability check  type family NullableStatus (x :: *) :: Bool where@@ -129,13 +138,6 @@                      -> dataTypeSyntax  instance (IsSql92DataTypeSyntax dataTypeSyntax, HasDefaultSqlDataType dataTypeSyntax ty) =>-  HasDefaultSqlDataType dataTypeSyntax (Auto ty) where-  defaultSqlDataType _ = defaultSqlDataType (Proxy @ty)-instance (IsSql92ColumnSchemaSyntax columnSchemaSyntax, HasDefaultSqlDataTypeConstraints columnSchemaSyntax ty) =>-  HasDefaultSqlDataTypeConstraints columnSchemaSyntax (Auto ty) where-  defaultSqlDataTypeConstraints _ = defaultSqlDataTypeConstraints (Proxy @ty)--instance (IsSql92DataTypeSyntax dataTypeSyntax, HasDefaultSqlDataType dataTypeSyntax ty) =>   HasDefaultSqlDataType dataTypeSyntax (Maybe ty) where   defaultSqlDataType _ = defaultSqlDataType (Proxy @ty) instance (IsSql92ColumnSchemaSyntax columnSchemaSyntax, HasDefaultSqlDataTypeConstraints columnSchemaSyntax ty) =>@@ -188,6 +190,10 @@ instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Day where   defaultSqlDataType _ _ = dateType instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Day++instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax TimeOfDay where+  defaultSqlDataType _ _ = timeType Nothing False+instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax TimeOfDay  instance IsSql99DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Bool where   defaultSqlDataType _ _ = booleanType

@@ -0,0 +1,196 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- | Contains a schema for beam migration tools. Used by the CLI and+-- the managed migrations support here.+module Database.Beam.Migrate.Log where++import Database.Beam+import Database.Beam.Backend.SQL+import Database.Beam.Migrate+import Database.Beam.Migrate.Backend++import Control.Monad (when)++import Data.String (fromString)+import Data.Text (Text)+import Data.Time (LocalTime)+import Data.UUID (UUID)++data LogEntryT f+  = LogEntry+  { _logEntryId       :: C f Int+  , _logEntryCommitId :: C f Text+  , _logEntryDate     :: C f LocalTime+  } deriving Generic++instance Beamable LogEntryT+type LogEntry = LogEntryT Identity+deriving instance Show LogEntry++instance Table LogEntryT where+  data PrimaryKey LogEntryT f = LogEntryKey (C f Int)+    deriving Generic+  primaryKey = LogEntryKey <$> _logEntryId++instance Beamable (PrimaryKey LogEntryT)++type LogEntryKey = PrimaryKey LogEntryT Identity+deriving instance Show LogEntryKey++newtype BeamMigrateVersionT f+  = BeamMigrateVersion+  { _beamMigrateVersion :: C f Int+  } deriving Generic++instance Beamable BeamMigrateVersionT+type BeamMigrateVersion = BeamMigrateVersionT Identity+deriving instance Show BeamMigrateVersion++instance Table BeamMigrateVersionT where+  data PrimaryKey BeamMigrateVersionT f = BeamMigrateVersionKey (C f Int)+    deriving Generic+  primaryKey = BeamMigrateVersionKey <$> _beamMigrateVersion++instance Beamable (PrimaryKey BeamMigrateVersionT)++type BeamMigrateVersionKey = PrimaryKey BeamMigrateVersionT Identity+deriving instance Show BeamMigrateVersionKey++-- Database+data BeamMigrateDb entity+  = BeamMigrateDb+  { _beamMigrateVersionTbl :: entity (TableEntity BeamMigrateVersionT)+  , _beamMigrateLogEntries :: entity (TableEntity LogEntryT)+  } deriving Generic++instance Database be BeamMigrateDb++beamMigratableDb :: forall cmd be hdl m+                  . ( Sql92SaneDdlCommandSyntax cmd+                    , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd)+                    , MonadBeam cmd be hdl m )+                 => CheckedDatabaseSettings be BeamMigrateDb+beamMigratableDb = runMigrationSilenced $ beamMigrateDbMigration @cmd @be @hdl @m++beamMigrateDb :: forall be cmd hdl m+               . ( Sql92SaneDdlCommandSyntax cmd+                 , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd)+                 , MonadBeam cmd be hdl m )+               => DatabaseSettings be BeamMigrateDb+beamMigrateDb = unCheckDatabase $ beamMigratableDb @cmd @be @hdl @m++beamMigrateDbMigration ::  forall cmd be hdl m+                        . ( Sql92SaneDdlCommandSyntax cmd+                          , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd)+                          , MonadBeam cmd be hdl m )+                       => Migration cmd (CheckedDatabaseSettings be BeamMigrateDb)+beamMigrateDbMigration =+  BeamMigrateDb <$> createTable "beam_version"+                      (BeamMigrateVersion (field "version" int notNull))+                <*> createTable "beam_migration"+                      (LogEntry (field "id" int notNull) (field "commitId" (varchar Nothing) notNull)+                                (field "date" timestamp notNull))++beamMigrateSchemaVersion :: Int+beamMigrateSchemaVersion = 1++getLatestLogEntry :: forall be cmd hdl m+                   . ( IsSql92Syntax cmd+                     , HasQBuilder (Sql92SelectSyntax cmd)+                     , Sql92ReasonableMarshaller be+                     , Sql92SanityCheck cmd+                     , Sql92SaneDdlCommandSyntax cmd+                     , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd)+                     , MonadBeam cmd be hdl m )+                  => m (Maybe LogEntry)+getLatestLogEntry =+  runSelectReturningOne (select $+                         limit_ 1 $+                         orderBy_ (desc_ . _logEntryId) $+                         all_ (_beamMigrateLogEntries (beamMigrateDb @be @cmd @hdl @m)))++updateSchemaToCurrent :: forall be cmd hdl m+                       . ( IsSql92Syntax cmd+                         , Sql92SanityCheck cmd+                         , Sql92ReasonableMarshaller be+                         , Sql92SaneDdlCommandSyntax cmd+                         , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd)+                         , MonadBeam cmd be hdl m )+                      => m ()+updateSchemaToCurrent =+  runInsert (insert (_beamMigrateVersionTbl (beamMigrateDb @be @cmd @hdl @m)) (insertValues [BeamMigrateVersion beamMigrateSchemaVersion]))++recordCommit :: forall be cmd hdl m+             . ( IsSql92Syntax cmd+               , Sql92SanityCheck cmd+               , Sql92SaneDdlCommandSyntax cmd+               , HasQBuilder (Sql92SelectSyntax cmd)+               , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd)+               , HasSqlValueSyntax (Sql92ValueSyntax cmd) Text+               , Sql92ReasonableMarshaller be+               , MonadBeam cmd be hdl m )+             => UUID -> m ()+recordCommit commitId = do+  let commitIdTxt = fromString (show commitId)++  logEntry <- getLatestLogEntry+  let nextLogEntryId = maybe 0 (succ . _logEntryId) logEntry++  runInsert (insert (_beamMigrateLogEntries (beamMigrateDb @be @cmd @hdl @m))+                    (insertExpressions+                     [ LogEntry (val_ nextLogEntryId)+                                (val_ commitIdTxt)+                                currentTimestamp_]))++-- Ensure the backend tables exist+ensureBackendTables :: forall be cmd hdl m+                     . BeamMigrationBackend cmd be hdl m+                    -> m ()+ensureBackendTables be@BeamMigrationBackend { backendGetDbConstraints = getCs } =+  do backendSchemaBuilt <- checkForBackendTables be+     if backendSchemaBuilt+       then continueMigrate+       else createSchema++  where+    doStep cmd = runNoReturn cmd++    continueMigrate = do+      maxVersion <-+        runSelectReturningOne $ select $+        aggregate_ (\v -> max_ (_beamMigrateVersion v)) $+        all_ (_beamMigrateVersionTbl (beamMigrateDb @be @cmd @hdl @m))++      case maxVersion of+        Nothing -> cleanAndCreateSchema+        Just Nothing -> cleanAndCreateSchema+        Just (Just maxVersion')+          | maxVersion' > beamMigrateSchemaVersion ->+              fail "This database is being managed by a newer version of beam-migrate"+          | maxVersion' < beamMigrateSchemaVersion ->+              fail "This database is being managed by an older version of beam-migrate, but there are no older versions"+          | otherwise -> pure ()++    cleanAndCreateSchema = do+      cs <- getCs+      let migrationLogExists = any (== p (TableExistsPredicate "beam_migration")) cs++      when migrationLogExists $ do+        Just totalCnt <-+          runSelectReturningOne $ select $+          aggregate_ (\_ -> as_ @Int countAll_) $+          all_ (_beamMigrateLogEntries (beamMigrateDb @be @cmd @hdl @m))+        when (totalCnt > 0) (fail "beam-migrate: No versioning information, but log entries present")+        runNoReturn (dropTableCmd (dropTableSyntax "beam_migration"))++      runNoReturn (dropTableCmd (dropTableSyntax "beam_version"))++      createSchema++    createSchema = do+      _ <- executeMigration doStep (beamMigrateDbMigration @cmd @be @hdl @m)+      updateSchemaToCurrent++checkForBackendTables :: BeamMigrationBackend cmd be hdl m -> m Bool+checkForBackendTables BeamMigrationBackend { backendGetDbConstraints = getCs } =+  do cs <- getCs+     pure (any (== p (TableExistsPredicate "beam_version")) cs)

@@ -31,4 +31,4 @@ --   information. class IsSql92ColumnSchemaSyntax syntax =>   IsBeamSerialColumnSchemaSyntax syntax where-  genericSerial :: FieldReturnType 'False 'False syntax (SqlSerial Int) a => Text -> a+  genericSerial :: FieldReturnType 'True 'False syntax (SqlSerial Int) a => Text -> a

@@ -15,16 +15,24 @@  -- * Convenience type synonyms --- | Command syntaxes that can be used to issue DDL commands.+-- | Syntax equalities that any reasonable DDL syntax would follow,+-- including equalities between beam-migrate and beam-core types. type Sql92SaneDdlCommandSyntax cmd =+  ( Sql92SaneDdlCommandSyntaxMigrateOnly cmd+  , Sql92ColumnSchemaExpressionSyntax (Sql92DdlCommandColumnSchemaSyntax cmd) ~+      Sql92ExpressionSyntax cmd )++-- | Syntax equalities for any reasonable DDL syntax, only including+-- types defined here.+type Sql92SaneDdlCommandSyntaxMigrateOnly cmd =   ( IsSql92DdlCommandSyntax cmd   , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd)   , Sql92SerializableConstraintDefinitionSyntax (Sql92DdlCommandConstraintDefinitionSyntax cmd)   , Typeable (Sql92DdlCommandColumnSchemaSyntax cmd)   , Sql92AlterTableColumnSchemaSyntax       (Sql92AlterTableAlterTableActionSyntax (Sql92DdlCommandAlterTableSyntax cmd)) ~-      Sql92CreateTableColumnSchemaSyntax (Sql92DdlCommandCreateTableSyntax cmd) )-+      Sql92CreateTableColumnSchemaSyntax (Sql92DdlCommandCreateTableSyntax cmd)+  )  type Sql92DdlCommandDataTypeSyntax syntax =   Sql92ColumnSchemaColumnTypeSyntax (Sql92DdlCommandColumnSchemaSyntax syntax)

@@ -2,6 +2,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Database.Beam.Migrate.SQL.Tables   ( -- * Table manipulation@@ -23,7 +24,7 @@    , field -  , defaultTo_, notNull+  , defaultTo_, notNull, unique   , int, smallint, bigint   , char, varchar, double   , characterLargeObject, binaryLargeObject, array@@ -31,7 +32,7 @@   , timestamp, timestamptz   , binary, varbinary -  , maybeType, autoType+  , maybeType      -- ** Internal classes     --    Provided without documentation for use in type signatures@@ -58,6 +59,7 @@ import Data.Typeable import Data.Time (LocalTime, TimeOfDay) import Data.Scientific (Scientific)+import qualified Data.Kind as Kind (Constraint)  import GHC.TypeLits @@ -120,14 +122,16 @@ -- | Monad representing a series of @ALTER TABLE@ statements newtype TableMigration syntax a   = TableMigration (WriterT [Sql92DdlCommandAlterTableSyntax syntax] (State (Text, [TableCheck])) a)+  deriving (Monad, Applicative, Functor)  -- | @ALTER TABLE ... RENAME TO@ command renameTableTo :: Sql92SaneDdlCommandSyntax syntax               => Text -> table ColumnMigration               -> TableMigration syntax (table ColumnMigration) renameTableTo newName oldTbl = TableMigration $ do-  (curNm, _) <- get+  (curNm, chks) <- get   tell [ alterTableSyntax curNm (renameTableToSyntax newName) ]+  put (newName, chks)   return oldTbl  -- | @ALTER TABLE ... RENAME COLUMN ... TO ...@ command@@ -268,10 +272,17 @@   = Constraint (Sql92ColumnConstraintDefinitionConstraintSyntax                 (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax)) +newtype NotNullConstraint syntax+  = NotNullConstraint (Constraint syntax)+ -- | The SQL92 @NOT NULL@ constraint-notNull :: IsSql92ColumnSchemaSyntax syntax => Constraint syntax-notNull = Constraint notNullConstraintSyntax+notNull :: IsSql92ColumnSchemaSyntax syntax => NotNullConstraint syntax+notNull = NotNullConstraint (Constraint notNullConstraintSyntax) +-- | SQL @UNIQUE@ constraint+unique :: IsSql92ColumnSchemaSyntax syntax => Constraint syntax+unique = Constraint uniqueColumnConstraintSyntax+ -- ** Data types  -- | SQL92 @INTEGER@ data type@@ -353,11 +364,6 @@ maybeType :: DataType syntax a -> DataType syntax (Maybe a) maybeType (DataType sqlTy) = DataType sqlTy --- | Wrap a 'DataType' in 'Auto'-autoType :: DataType syntax a -> DataType syntax (Auto a)-autoType (DataType sqlTy) = DataType sqlTy-- -- ** 'field' variable arity classes  class FieldReturnType (defaultGiven :: Bool) (collationGiven :: Bool) syntax resTy a | a -> syntax resTy where@@ -379,6 +385,12 @@   field' defaultGiven collationGiven nm ty default_' collation constraints (Constraint e) =     field' defaultGiven collationGiven nm ty default_' collation (constraints ++ [ constraintDefinitionSyntax Nothing e Nothing ]) +instance ( FieldReturnType defaultGiven collationGiven syntax resTy (Constraint syntax -> a)+         , IsNotNull resTy ) =>+  FieldReturnType defaultGiven collationGiven syntax resTy (NotNullConstraint syntax -> a) where+  field' defaultGiven collationGiven nm ty default_' collation constraints (NotNullConstraint c) =+    field' defaultGiven collationGiven nm ty default_' collation constraints c+ instance ( FieldReturnType 'True collationGiven syntax resTy a          , TypeError ('Text "Only one DEFAULT clause can be given per 'field' invocation") ) =>   FieldReturnType 'True collationGiven syntax resTy (DefaultValue syntax resTy -> a) where@@ -401,3 +413,9 @@     TableFieldSchema nm (FieldSchema (columnSchemaSyntax ty default_' constraints collation)) checks     where checks = [ FieldCheck (\tbl field'' -> SomeDatabasePredicate (TableHasColumn tbl field'' ty :: TableHasColumn syntax)) ] ++                    map (\cns -> FieldCheck (\tbl field'' -> SomeDatabasePredicate (TableColumnHasConstraint tbl field'' cns :: TableColumnHasConstraint syntax))) constraints++type family IsNotNull (x :: *) :: Kind.Constraint where+  IsNotNull (Maybe x) = TypeError ('Text "You used Database.Beam.Migrate.notNull on a column with type" ':$$:+                                   'ShowType (Maybe x) ':$$:+                                   'Text "Either remove 'notNull' from your migration or 'Maybe' from your table")+  IsNotNull x = ()

@@ -1,25 +1,175 @@-+{-# LANGUAGE AllowAmbiguousTypes #-} -- | Utility functions for common use cases module Database.Beam.Migrate.Simple-  ( simpleSchema, simpleMigration-  , runSimpleMigration, backendMigrationScript+  ( autoMigrate+  , simpleSchema+  , simpleMigration+  , runSimpleMigration+  , backendMigrationScript +  , VerificationResult(..)+  , verifySchema++  , createSchema++  , BringUpToDateHooks(..)+  , defaultUpToDateHooks+  , bringUpToDate, bringUpToDateWithHooks+   , module Database.Beam.Migrate.Actions   , module Database.Beam.Migrate.Types ) where -import Database.Beam-import Database.Beam.Backend.SQL-import Database.Beam.Migrate.Backend-import Database.Beam.Migrate.Types-import Database.Beam.Migrate.Actions+import           Prelude hiding (log) +import           Database.Beam+import           Database.Beam.Backend.SQL+import           Database.Beam.Migrate.Backend+import           Database.Beam.Migrate.Types+import           Database.Beam.Migrate.Actions+import           Database.Beam.Migrate.Log++import           Control.Monad.Cont+import           Control.Monad.Writer+import           Control.Monad.State++import qualified Data.HashSet as HS+import           Data.Semigroup (Max(..)) import qualified Data.Text as T +data BringUpToDateHooks m+  = BringUpToDateHooks+  { runIrreversibleHook :: m Bool+    -- ^ Called before we're about to run an irreversible migration step. Return+    -- 'True' to run the step, or 'False' to abort immediately.+  , startStepHook       :: Int -> T.Text -> m ()+    -- ^ Called at the beginning of each step with the step index and description+  , endStepHook         :: Int -> T.Text -> m ()+    -- ^ Called at the end of each step with the step index and description+  , runCommandHook      :: Int -> String -> m ()+    -- ^ Called before a command is about to run. The first argument is the step+    -- index and the second is a string representing the command about to be run.++  , queryFailedHook     :: m ()+    -- ^ Called when a query fails+  , discontinuousMigrationsHook+                        :: Int -> m ()+    -- ^ Called when the migration log has a discontinuity at the supplied index+  , logMismatchHook     :: Int -> T.Text -> T.Text -> m ()+    -- ^ The migration log at the given index is not what was expected. The+    -- first text is the actual commit id, the second, the expected+  , databaseAheadHook   :: Int -> m ()+    -- ^ The database is ahead of the given migrations. The parameter supplies+    -- the number of entries passed the given migrations the database has.+  }++-- | Default set of 'BringUpToDateHooks'. Refuses to run irreversible+-- migrations, and fails in case of error, using 'fail'.+defaultUpToDateHooks :: Monad m => BringUpToDateHooks m+defaultUpToDateHooks =+  BringUpToDateHooks+  { runIrreversibleHook = pure False+  , startStepHook       = \_ _ -> pure ()+  , endStepHook         = \_ _ -> pure ()+  , runCommandHook      = \_ _ -> pure ()+  , queryFailedHook     = fail "Log entry query fails"+  , discontinuousMigrationsHook =+      \ix -> fail ("Discontinuous migration log: missing migration at " ++ show ix)+  , logMismatchHook =+      \ix actual expected ->+        fail ("Log mismatch at index " ++ show ix ++ ":\n" +++              "  expected: " ++ T.unpack expected ++ "\n" +++              "  actual  : " ++ T.unpack actual)+  , databaseAheadHook =+      \aheadBy ->+        fail ("The database is ahead of the known schema by " ++ show aheadBy ++ " migration(s)")+  }++-- | Equivalent to calling 'bringUpToDateWithHooks' with 'defaultUpToDateHooks'.+--+-- Tries to bring the database up to date, using the database log and the given+-- 'MigrationSteps'. Fails if the migration is irreversible, or an error occurs.+bringUpToDate :: Database be db+              => BeamMigrationBackend cmd be hdl m+              -> MigrationSteps cmd () (CheckedDatabaseSettings be db)+              -> m (Maybe (CheckedDatabaseSettings be db))+bringUpToDate be@BeamMigrationBackend {} =+  bringUpToDateWithHooks defaultUpToDateHooks be++-- | Check for the beam-migrate log. If it exists, use it and the supplied+-- migrations to bring the database up-to-date. Otherwise, create the log and+-- run all migrations.+--+-- Accepts a set of hooks that can be used to customize behavior. See the+-- documentation for 'BringUpToDateHooks' for more information. Calling this+-- with 'defaultUpToDateHooks' is the same as using 'bringUpToDate'.+bringUpToDateWithHooks :: forall db cmd be hdl m+                        . Database be db+                       => BringUpToDateHooks m+                       -> BeamMigrationBackend cmd be hdl m+                       -> MigrationSteps cmd () (CheckedDatabaseSettings be db)+                       -> m (Maybe (CheckedDatabaseSettings be db))+bringUpToDateWithHooks hooks be@(BeamMigrationBackend { backendRenderSyntax = renderSyntax' }) steps = do+  ensureBackendTables be++  entries <- runSelectReturningList $ select $+             all_ (_beamMigrateLogEntries (beamMigrateDb @be @cmd @hdl @m))+  let verifyMigration :: Int -> T.Text -> Migration cmd a -> StateT [LogEntry] (WriterT (Max Int) m) a+      verifyMigration stepIx stepNm step =+        do log <- get+           case log of+             [] -> pure ()+             LogEntry actId actStepNm _:log'+               | actId == stepIx && actStepNm == stepNm ->+                   tell (Max stepIx) >> put log'+               | actId /= stepIx ->+                   lift . lift $ discontinuousMigrationsHook hooks stepIx+               | otherwise ->+                   lift . lift $ logMismatchHook hooks stepIx actStepNm stepNm+           executeMigration (\_ -> pure ()) step++  (futureEntries, Max lastCommit) <-+    runWriterT (execStateT (runMigrationSteps 0 Nothing steps verifyMigration) entries <*+                tell (Max (-1)))++  case futureEntries of+    _:_ -> databaseAheadHook hooks (length futureEntries)+    [] -> pure ()++  -- Check data loss+  shouldRunMigration <-+    flip runContT (\_ -> pure True) $+    runMigrationSteps (lastCommit + 1) Nothing steps+      (\_ _ step -> do+          case migrationDataLoss step of+            MigrationLosesData ->+              ContT $ \_ -> runIrreversibleHook hooks+            MigrationKeepsData ->+              executeMigration (\_ -> pure ()) step)++  if shouldRunMigration+    then Just <$>+         runMigrationSteps (lastCommit + 1) Nothing steps+           (\stepIx stepName step ->+              do startStepHook hooks stepIx stepName+                 ret <-+                   executeMigration+                     (\cmd -> do+                         runCommandHook hooks stepIx (renderSyntax' cmd)+                         runNoReturn cmd)+                     step++                 runInsert $ insert (_beamMigrateLogEntries (beamMigrateDb @be @cmd @hdl @m)) $+                   insertExpressions [ LogEntry (val_ stepIx) (val_ stepName) currentTimestamp_ ]+                 endStepHook hooks stepIx stepName++                 return ret)+    else pure Nothing+ -- | Attempt to find a SQL schema given an 'ActionProvider' and a checked -- database. Returns 'Nothing' if no schema could be found, which usually means -- you have chosen the wrong 'ActionProvider', or the backend you're using is -- buggy.-simpleSchema :: Database db+simpleSchema :: Database be db              => ActionProvider cmd              -> CheckedDatabaseSettings be db              -> Maybe [cmd]@@ -27,9 +177,44 @@   let allChecks = collectChecks settings       solver    = heuristicSolver provider [] allChecks   in case finalSolution solver of-       Solved cmds -> Just cmds+       Solved cmds -> Just (fmap migrationCommand cmds)        Candidates {} -> Nothing +-- | Given a 'CheckedDatabaseSettings' and a 'BeamMigrationBackend',+-- attempt to create the schema from scratch in the current database.+--+-- May 'fail' if we cannot find a schema+createSchema :: Database be db+             => BeamMigrationBackend cmd be hdl m+             -> CheckedDatabaseSettings be db+             -> m ()+createSchema BeamMigrationBackend { backendActionProvider = actions } db =+  case simpleSchema actions db of+    Nothing -> fail "createSchema: Could not determine schema"+    Just cmds ->+        mapM_ runNoReturn cmds++-- | Given a 'BeamMigrationBackend', attempt to automatically bring the current+-- database up-to-date with the given 'CheckedDatabaseSettings'. Fails (via+-- 'fail') if this involves an irreversible migration (one that may result in+-- data loss).+autoMigrate :: Database be db+            => BeamMigrationBackend cmd be hdl m+            -> CheckedDatabaseSettings be db+            -> m ()+autoMigrate BeamMigrationBackend { backendActionProvider = actions+                                 , backendGetDbConstraints = getCs }+            db =+  do actual <- getCs+     let expected = collectChecks db+     case finalSolution (heuristicSolver actions actual expected) of+       Candidates {} -> fail "autoMigrate: Could not determine migration"+       Solved cmds ->+         -- Check if any of the commands are irreversible+         case foldMap migrationCommandDataLossPossible cmds of+           MigrationKeepsData -> mapM_ (runNoReturn . migrationCommand) cmds+           _ -> fail "autoMigrate: Not performing automatic migration due to data loss"+ -- | Given a migration backend, a handle to a database, and a checked database, -- attempt to find a schema. This should always return 'Just', unless the -- backend has incomplete migrations support.@@ -37,8 +222,8 @@ -- 'BeamMigrationBackend's can usually be found in a module named -- @Database.Beam.<Backend>.Migrate@ with the name@migrationBackend@ simpleMigration :: ( MonadBeam cmd be handle m-                 ,   Database db )-                => BeamMigrationBackend be cmd handle+                 ,   Database be db )+                => BeamMigrationBackend cmd be handle m                 -> handle                 -> CheckedDatabaseSettings be db                 -> IO (Maybe [cmd])@@ -50,14 +235,35 @@       solver = heuristicSolver action pre post    case finalSolution solver of-    Solved cmds -> pure (Just cmds)+    Solved cmds -> pure (Just (fmap migrationCommand cmds))     Candidates {} -> pure Nothing +-- | Result type for 'verifySchema'+data VerificationResult+  = VerificationSucceeded+  | VerificationFailed [SomeDatabasePredicate]+  deriving Show++-- | Verify that the given, beam database matches the actual+-- schema. On success, returns 'VerificationSucceeded', on failure,+-- returns 'VerificationFailed' and a list of missing predicates.+verifySchema :: ( Database be db, MonadBeam cmd be handle m )+             => BeamMigrationBackend cmd be handle m+             -> CheckedDatabaseSettings be db+             -> m VerificationResult+verifySchema BeamMigrationBackend { backendGetDbConstraints = getConstraints } db =+  do actualSchema <- HS.fromList <$> getConstraints+     let expectedSchema = HS.fromList (collectChecks db)+         missingPredicates = expectedSchema `HS.difference` actualSchema+     if HS.null missingPredicates+       then pure VerificationSucceeded+       else pure (VerificationFailed (HS.toList missingPredicates))+ -- | Run a sequence of commands on a database-runSimpleMigration :: MonadBeam cmd be hdl m+runSimpleMigration :: forall cmd be hdl m . MonadBeam cmd be hdl m                    => hdl -> [cmd] -> IO () runSimpleMigration hdl =-  withDatabase hdl . mapM_ runNoReturn+  withDatabase @cmd @be @hdl @m hdl . mapM_ runNoReturn  -- | Given a function to convert a command to a 'String', produce a script that -- will execute the given migration. Usually, the function you provide

@@ -17,6 +17,7 @@     --     --    The functions in this section can be used to modify 'CheckedDatabaseSettings' objects.   , CheckedFieldModification+  , checkedFieldNamed    , modifyCheckedTable   , checkedTableModification@@ -36,14 +37,13 @@   , MigrationStep(..), MigrationSteps(..)   , Migration, MigrationF(..) -  , migrationStepsToMigration, runMigrationSilenced-  , runMigrationVerbose, executeMigration-  , eraseMigrationType, migrationStep, upDown+  , MigrationCommand(..), MigrationDataLoss(..) -  , migrateScript, evaluateDatabase, stepNames ) where+  , runMigrationSteps, runMigrationSilenced+  , executeMigration, eraseMigrationType, migrationStep+  , upDown, migrationDataLoss -import Database.Beam-import Database.Beam.Backend+  , migrateScript, evaluateDatabase, stepNames ) where  import Database.Beam.Migrate.Types.CheckedEntities import Database.Beam.Migrate.Types.Predicates@@ -57,12 +57,18 @@  -- * Migration types +-- | Represents a particular step in a migration data MigrationStep syntax next where     MigrationStep :: Text -> Migration syntax a -> (a -> next) -> MigrationStep syntax next deriving instance Functor (MigrationStep syntax)++-- | A series of 'MigrationStep's that take a database from the schema in @from@+-- to the one in @to@. Use the 'migrationStep' function and the arrow interface+-- to sequence 'MigrationSteps'. newtype MigrationSteps syntax from to = MigrationSteps (Kleisli (F (MigrationStep syntax)) from to)   deriving (Category, Arrow) +-- | Free monadic function for 'Migration's data MigrationF syntax next where   MigrationRunCommand     :: { _migrationUpCommand   :: syntax {-^ What to execute when applying the migration -}@@ -70,48 +76,83 @@        , _migrationNext :: next }     -> MigrationF syntax next deriving instance Functor (MigrationF syntax)++-- | A sequence of potentially reversible schema update commands type Migration syntax = F (MigrationF syntax) +-- | Information on whether a 'MigrationCommand' loses data. You can+-- monoidally combine these to get the potential data loss for a+-- sequence of commands.+data MigrationDataLoss+  = MigrationLosesData+    -- ^ The command loses data+  | MigrationKeepsData+    -- ^ The command keeps all data+  deriving Show -migrationStepsToMigration :: Int -> Maybe Int-                          -> MigrationSteps syntax () a-                          -> (forall a'. Text -> Migration syntax a' -> IO a')-                          -> IO a-migrationStepsToMigration firstIdx lastIdx (MigrationSteps steps) runMigration =+instance Monoid MigrationDataLoss where+    mempty = MigrationKeepsData+    mappend MigrationLosesData _ = MigrationLosesData+    mappend _ MigrationLosesData = MigrationLosesData+    mappend MigrationKeepsData MigrationKeepsData = MigrationKeepsData++-- | A migration command along with metadata on wheth+data MigrationCommand cmd+  = MigrationCommand+  { migrationCommand :: cmd+    -- ^ The command to run+  , migrationCommandDataLossPossible :: MigrationDataLoss+    -- ^ Information on whether the migration loses data+  } deriving Show++-- | Run the migration steps between the given indices, using a custom execution function.+runMigrationSteps :: Monad m+                  => Int -- ^ Zero-based index of the first step to run+                  -> Maybe Int -- ^ Index of the last step to run, or 'Nothing' to run every step+                  -> MigrationSteps syntax () a -- ^ The set of steps to run+                  -> (forall a'. Int -> Text -> Migration syntax a' -> m a')+                  -- ^ Callback for each step. Called with the step index, the+                  -- step description and the migration.+                  -> m a+runMigrationSteps firstIdx lastIdx (MigrationSteps steps) runMigration =   runF (runKleisli steps ()) finish step 0   where finish x _ = pure x         step (MigrationStep nm doStep next) i =           if i >= firstIdx && maybe True (i <) lastIdx-          then runMigration nm doStep >>= \x -> next x (i + 1)+          then runMigration i nm doStep >>= \x -> next x (i + 1)           else next (runMigrationSilenced doStep) (i + 1) +-- | Get the result of a migration, without running any steps runMigrationSilenced :: Migration syntax a -> a runMigrationSilenced m = runF m id step   where     step (MigrationRunCommand _ _ next) = next -runMigrationVerbose :: MonadBeam syntax be hdl m => (syntax -> String)-                    -> Migration syntax a -> m a-runMigrationVerbose renderMigrationSyntax steps =-  runF steps finish step-  where finish = pure-        step (MigrationRunCommand up _ next) =-          do liftIO (putStrLn (renderMigrationSyntax up))-             runNoReturn up-             next-+-- | Remove the explicit source and destination schemas from a 'MigrationSteps' object eraseMigrationType :: a -> MigrationSteps syntax a a' -> MigrationSteps syntax () () eraseMigrationType a (MigrationSteps steps) = MigrationSteps (arr (const a) >>> steps >>> arr (const ())) +-- | Create a 'MigrationSteps' from the given description and migration function. migrationStep :: Text -> (a -> Migration syntax a') -> MigrationSteps syntax a a' migrationStep stepName migration =     MigrationSteps (Kleisli (\a -> liftF (MigrationStep stepName (migration a) id))) +-- | Given a command in the forward direction, and an optional one in the+-- reverse direction, construct a 'Migration' that performs the given+-- command. Multiple commands can be sequenced monadically. upDown :: syntax -> Maybe syntax -> Migration syntax () upDown up down = liftF (MigrationRunCommand up down ()) -migrateScript :: forall syntax m a.-                 Monoid m => (Text -> m) -> (syntax -> m) -> MigrationSteps syntax () a -> m+-- | Given functions to render a migration step description and the underlying+-- syntax, create a script for the given 'MigrationSteps'.+migrateScript :: forall syntax m a. Monoid m+              => (Text -> m)+              -- ^ Called at the beginning of each 'MigrationStep' with the step description+              -> (syntax -> m)+              -- ^ Called for each command in the migration step+              -> MigrationSteps syntax () a+              -- ^ The set of steps to run+              -> m migrateScript renderMigrationHeader renderMigrationSyntax (MigrationSteps steps) =   runF (runKleisli steps ()) (\_ x -> x)     (\(MigrationStep header migration next) x ->@@ -131,16 +172,26 @@     doStep (MigrationRunCommand cmd _ next) =       runSyntax cmd *> next +-- | Given a migration, get the potential data loss, if it's run top-down+migrationDataLoss :: Migration syntax a -> MigrationDataLoss+migrationDataLoss go = runF go (\_ -> MigrationKeepsData)+                         (\(MigrationRunCommand _ x next) ->+                            case x of+                              Nothing -> MigrationLosesData+                              _ -> next)++-- | Run a 'MigrationSteps' without executing any of the commands against a+-- database. evaluateDatabase :: forall syntax a. MigrationSteps syntax () a -> a evaluateDatabase (MigrationSteps f) = runF (runKleisli f ()) id (\(MigrationStep _ migration next) -> next (runMigration migration))   where     runMigration :: forall a'. Migration syntax a' -> a'     runMigration migration = runF migration id (\(MigrationRunCommand _ _ next) -> next) +-- | Collect the names of all steps in hte given 'MigrationSteps' stepNames :: forall syntax a. MigrationSteps syntax () a -> [Text] stepNames (MigrationSteps f) = runF (runKleisli f ()) (\_ x -> x) (\(MigrationStep nm migration next) x -> next (runMigration migration) (x ++ [nm])) []   where     runMigration :: forall a'. Migration syntax a' -> a'     runMigration migration = runF migration id (\(MigrationRunCommand _ _ next) -> next) --- * Checked database entities

@@ -63,13 +63,13 @@  -- | Convert a 'CheckedDatabaseSettings' to a regular 'DatabaseSettings'. The -- return value is suitable for use in any regular beam query or DML statement.-unCheckDatabase :: forall be db. Database db => CheckedDatabaseSettings be db -> DatabaseSettings be db+unCheckDatabase :: forall be db. Database be db => CheckedDatabaseSettings be db -> DatabaseSettings be db unCheckDatabase db = runIdentity $ zipTables (Proxy @be) (\(CheckedDatabaseEntity x _) _ -> pure $ DatabaseEntity (unCheck x)) db db  -- | A @beam-migrate@ database schema is defined completely by the set of -- predicates that apply to it. This function allows you to access this -- definition for a 'CheckedDatabaseSettings' object.-collectChecks :: forall be db. Database db => CheckedDatabaseSettings be db -> [ SomeDatabasePredicate ]+collectChecks :: forall be db. Database be  db => CheckedDatabaseSettings be db -> [ SomeDatabasePredicate ] collectChecks db = let (_ :: CheckedDatabaseSettings be db, a) =                          runWriter $ zipTables (Proxy @be)                            (\(CheckedDatabaseEntity entity cs :: CheckedDatabaseEntity be db entityType) b ->@@ -132,6 +132,9 @@   = CheckedFieldModification       (TableField tbl a -> TableField tbl a)       ([FieldCheck] -> [FieldCheck])++checkedFieldNamed :: Text -> CheckedFieldModification tbl a+checkedFieldNamed t = CheckedFieldModification (\_ -> TableField t) id  instance IsString (CheckedFieldModification tbl a) where   fromString s = CheckedFieldModification (const . TableField . fromString $ s) id

@@ -1,8 +1,5 @@--- Initial beam-migrate.cabal generated by cabal init.  For further --- documentation, see http://haskell.org/cabal/users-guide/- name:                beam-migrate-version:             0.2.0.0+version:             0.3.0.0 synopsis:            SQL DDL support and migrations support library for Beam description:         This package provides type classes to allow backends to implement                      SQL DDL support for beam. This allows you to use beam syntax to@@ -31,7 +28,7 @@ category:            Database build-type:          Simple extra-source-files:  ChangeLog.md-cabal-version:       >=1.10+cabal-version:       1.18  library   exposed-modules:     Database.Beam.Migrate@@ -48,6 +45,8 @@                        Database.Beam.Migrate.SQL.SQL92                        Database.Beam.Migrate.SQL.BeamExtensions +                       Database.Beam.Migrate.Log+                        Database.Beam.Migrate.Generics                         Database.Beam.Migrate.Simple@@ -59,13 +58,13 @@                        Database.Beam.Migrate.SQL.Types                        Database.Beam.Migrate.Types.CheckedEntities                        Database.Beam.Migrate.Types.Predicates-  -- other-extensions:    +   build-depends:       base                 >=4.9     && <4.11,-                       beam-core            ==0.6.0.0,+                       beam-core            >=0.7     && <0.8,                        text                 >=1.2     && <1.3,                        aeson                >=0.11    && <1.3,                        bytestring           >=0.10    && <0.11,-                       free                 >=4.12    && <4.13,+                       free                 >=4.12    && <5.1,                        time                 >=1.6     && <1.10,                        mtl                  >=2.2     && <2.3,                        scientific           >=0.3     && <0.4,@@ -77,12 +76,12 @@                        deepseq              >=1.4     && <1.5,                        ghc-prim             >=0.5     && <0.6,                        containers           >=0.5     && <0.6,-                       haskell-src-exts     >=1.18    && <1.20,+                       haskell-src-exts     >=1.20    && <1.21,                        pretty               >=1.1     && <1.2,                        dependent-map        >=0.2     && <0.3,                        dependent-sum        >=0.4     && <0.5,-                       pqueue               >=1.3     && <1.4-  -- hs-source-dirs:      +                       pqueue               >=1.3     && <1.5,+                       uuid                 >=1.3     && <1.4   default-language:    Haskell2010   default-extensions:  KindSignatures, OverloadedStrings, TypeFamilies, FlexibleContexts,                        StandaloneDeriving, GADTs, DeriveFunctor, RankNTypes, ScopedTypeVariables,