From 1b353fa8d16311728e17ddb81ab438b6f24b002f Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Wed, 12 Feb 2025 16:18:18 -0300 Subject: [PATCH] fix --- src/Codd.hs | 184 ++++++++++++++++++++++++---------------------------- 1 file changed, 85 insertions(+), 99 deletions(-) diff --git a/src/Codd.hs b/src/Codd.hs index a9c1be03..b06e0eee 100644 --- a/src/Codd.hs +++ b/src/Codd.hs @@ -1,117 +1,103 @@ module Codd - ( ApplyResult (..), - SchemasPair (..), - CoddSettings (..), - VerifySchemas (..), - applyMigrations, - applyMigrationsNoCheck, - ) -where + ( ApplyResult(..) + , SchemasPair(..) + , CoddSettings(..) + , VerifySchemas(..) + , applyMigrations + , applyMigrationsNoCheck + ) where -import Codd.Environment (CoddSettings (..)) -import Codd.Internal - ( collectAndApplyMigrations, - laxCheckLastAction, - strictCheckLastAction, - ) -import Codd.Logging (CoddLogger) -import Codd.Parsing - ( AddedSqlMigration, - EnvVars, - hoistAddedSqlMigration, - ) -import Codd.Query - ( InTxnT, - NotInTxn, - ) -import Codd.Representations - ( DbRep, - readRepsFromDisk, - ) -import Control.Monad.IO.Unlift (MonadUnliftIO) -import Control.Monad.Trans (lift) -import Control.Monad.Trans.Resource (MonadThrow) -import Data.Time (DiffTime) -import qualified Database.PostgreSQL.Simple as DB -import UnliftIO.Resource - ( ResourceT, - runResourceT, - ) -import Prelude hiding (readFile) +import Codd.Environment ( CoddSettings(..) ) +import Codd.Internal ( collectAndApplyMigrations + , laxCheckLastAction + , strictCheckLastAction + ) +import Codd.Logging ( CoddLogger ) +import Codd.Parsing ( AddedSqlMigration + , EnvVars + , hoistAddedSqlMigration + ) +import Codd.Query ( InTxnT + , NotInTxn + ) +import Codd.Representations ( DbRep + , readRepsFromDisk + ) +import Control.Monad.IO.Unlift ( MonadUnliftIO ) +import Control.Monad.Trans ( lift ) +import Control.Monad.Trans.Resource ( MonadThrow ) +import Data.Time ( DiffTime ) +import qualified Database.PostgreSQL.Simple as DB +import Prelude hiding ( readFile ) +import UnliftIO.Resource ( ResourceT + , runResourceT + ) data VerifySchemas = LaxCheck | StrictCheck - deriving stock (Show) + deriving stock (Show) data SchemasPair = SchemasPair - { expectedSchemas :: DbRep, - databaseSchemas :: DbRep - } - + { expectedSchemas :: DbRep + , databaseSchemas :: DbRep + } data ApplyResult = SchemasDiffer SchemasPair | SchemasMatch DbRep | SchemasNotVerified -- | Collects pending migrations from disk and applies them all, returning -- the Database's schema if they're not the ones expected or a success result otherwise. -- Throws an exception if a migration fails or if schemas mismatch and strict-checking is enabled. -applyMigrations :: - (MonadUnliftIO m, CoddLogger m, MonadThrow m, EnvVars m, NotInTxn m) => - CoddSettings -> - -- | Instead of collecting migrations from disk according to codd settings, use these if they're defined. - Maybe [AddedSqlMigration m] -> - DiffTime -> - VerifySchemas -> - m ApplyResult -applyMigrations dbInfo@CoddSettings {onDiskReps} mOverrideMigs connectTimeout checkSchemas = - case checkSchemas of - StrictCheck -> do - eh <- either readRepsFromDisk pure onDiskReps - runResourceT $ - collectAndApplyMigrations - (strictCheckLastAction dbInfo eh) - dbInfo - (map (hoistAddedSqlMigration lift) <$> mOverrideMigs) - connectTimeout - pure $ SchemasMatch eh - LaxCheck -> do - eh <- either readRepsFromDisk pure onDiskReps - dbCksums <- - runResourceT $ - collectAndApplyMigrations - (laxCheckLastAction dbInfo eh) - dbInfo - (map (hoistAddedSqlMigration lift) <$> mOverrideMigs) - connectTimeout +applyMigrations + :: (MonadUnliftIO m, CoddLogger m, MonadThrow m, EnvVars m, NotInTxn m) + => CoddSettings + -> Maybe [AddedSqlMigration m] + -- ^ Instead of collecting migrations from disk according to codd settings, use these if they're defined. + -> DiffTime + -> VerifySchemas + -> m ApplyResult +applyMigrations dbInfo@CoddSettings { onDiskReps } mOverrideMigs connectTimeout checkSchemas + = case checkSchemas of + StrictCheck -> do + eh <- either readRepsFromDisk pure onDiskReps + runResourceT $ collectAndApplyMigrations + (strictCheckLastAction dbInfo eh) + dbInfo + (map (hoistAddedSqlMigration lift) <$> mOverrideMigs) + connectTimeout + pure $ SchemasMatch eh + LaxCheck -> do + eh <- either readRepsFromDisk pure onDiskReps + dbCksums <- runResourceT $ collectAndApplyMigrations + (laxCheckLastAction dbInfo eh) + dbInfo + (map (hoistAddedSqlMigration lift) <$> mOverrideMigs) + connectTimeout - if dbCksums /= eh - then - pure $ - SchemasDiffer $ - SchemasPair - { expectedSchemas = eh, - databaseSchemas = dbCksums - } - else pure $ SchemasMatch eh + if dbCksums /= eh + then pure $ SchemasDiffer $ SchemasPair + { expectedSchemas = eh + , databaseSchemas = dbCksums + } + else pure $ SchemasMatch eh -- | Collects pending migrations from disk and applies them all. -- Does not verify schemas but allows a function that runs in the same transaction as the last migrations -- iff all migrations are in-txn or separately after the last migration otherwise. -- Throws an exception if a migration fails. -applyMigrationsNoCheck :: - ( MonadUnliftIO m, - CoddLogger m, - MonadThrow m, - EnvVars m, - NotInTxn m, - txn ~ InTxnT (ResourceT m) - ) => - CoddSettings -> - -- | Instead of collecting migrations from disk according to codd settings, use these if they're defined. - Maybe [AddedSqlMigration m] -> - DiffTime -> - (DB.Connection -> txn a) -> - m a +applyMigrationsNoCheck + :: ( MonadUnliftIO m + , CoddLogger m + , MonadThrow m + , EnvVars m + , NotInTxn m + , txn ~ InTxnT (ResourceT m) + ) + => CoddSettings + -> Maybe [AddedSqlMigration m] + -- ^ Instead of collecting migrations from disk according to codd settings, use these if they're defined. + -> DiffTime + -> (DB.Connection -> txn a) + -> m a applyMigrationsNoCheck dbInfo mOverrideMigs connectTimeout finalFunc = - collectAndApplyMigrations - (\_migBlocks conn -> finalFunc conn) - dbInfo - mOverrideMigs - connectTimeout + collectAndApplyMigrations (\_migBlocks conn -> finalFunc conn) + dbInfo + mOverrideMigs + connectTimeout