diff --git a/.gitignore b/.gitignore index 1a4a1cc1..4c3c1de2 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ +\#* .beam-migrate cabal.sandbox.config .cabal-sandbox @@ -8,7 +9,7 @@ dist-newstyle *.db *.db-journal .#* -#* +\#* graveyard *.o *.hi diff --git a/beam-migrate/Database/Beam/Migrate/Backend.hs b/beam-migrate/Database/Beam/Migrate/Backend.hs index 993fae42..2399112e 100644 --- a/beam-migrate/Database/Beam/Migrate/Backend.hs +++ b/beam-migrate/Database/Beam/Migrate/Backend.hs @@ -26,7 +26,7 @@ -- -- For an example migrate backend, see "Database.Beam.Sqlite.Migrate" module Database.Beam.Migrate.Backend - ( BeamMigrationBackend(..) + ( BeamMigrationBackend(..), BeamMigrateConnection(..) , DdlError -- * Haskell predicate conversion @@ -88,9 +88,16 @@ data BeamMigrationBackend be m where , backendFileExtension :: String , backendConvertToHaskell :: HaskellPredicateConverter , backendActionProvider :: ActionProvider be - , backendTransact :: forall a. String -> m a -> IO (Either DdlError a) + , backendRunSqlScript :: Text -> m () + , backendWithTransaction :: forall a. m a -> m a + , backendConnect :: String -> IO (BeamMigrateConnection be m) } -> BeamMigrationBackend be m +data BeamMigrateConnection be m where + BeamMigrateConnection + :: { backendRun :: forall a. m a -> IO (Either DdlError a) + , backendClose :: IO () } -> BeamMigrateConnection be m + -- | Monomorphic wrapper for use with plugin loaders that cannot handle -- polymorphism data SomeBeamMigrationBackend where diff --git a/beam-migrate/Database/Beam/Migrate/Serialization.hs b/beam-migrate/Database/Beam/Migrate/Serialization.hs index 4c971d61..94b8a8a6 100644 --- a/beam-migrate/Database/Beam/Migrate/Serialization.hs +++ b/beam-migrate/Database/Beam/Migrate/Serialization.hs @@ -25,7 +25,8 @@ module Database.Beam.Migrate.Serialization , BeamDeserializers(..) , beamDeserialize, beamDeserializeMaybe - , beamDeserializer, sql92Deserializers + , beamDeserializer, beamDeserializeJSON + , sql92Deserializers , sql99DataTypeDeserializers , sql2003BinaryAndVarBinaryDataTypeDeserializers , sql2008BigIntDataTypeDeserializers @@ -216,6 +217,15 @@ beamSerializeJSON backend v = object [ "be-specific" .= backend , "be-data" .= v ] +-- | Corresponding deserializer for 'beamSerializeJSON' +beamDeserializeJSON :: Text -> (Value -> Parser a) -> Value -> Parser a +beamDeserializeJSON backend go = + withObject "backend-specific item" $ \v -> do + be <- v .: "be-specific" + guard (be == backend) + d <- v .: "be-data" + go d + -- | Helper for serializing the precision and decimal count parameters to -- 'decimalType', etc. serializePrecAndDecimal :: Maybe (Word, Maybe Word) -> Value diff --git a/beam-postgres/Database/Beam/Postgres/Migrate.hs b/beam-postgres/Database/Beam/Postgres/Migrate.hs index 27fd406e..d337bd1d 100644 --- a/beam-postgres/Database/Beam/Postgres/Migrate.hs +++ b/beam-postgres/Database/Beam/Postgres/Migrate.hs @@ -55,7 +55,7 @@ import qualified Database.PostgreSQL.Simple.TypeInfo.Static as Pg import Control.Applicative ((<|>)) import Control.Arrow -import Control.Exception (bracket) +import Control.Exception.Lifted (mask, onException) import Control.Monad import Data.Aeson hiding (json) @@ -80,30 +80,46 @@ import GHC.Generics ( Generic ) -- | Top-level migration backend for use by @beam-migrate@ tools migrationBackend :: Tool.BeamMigrationBackend Postgres Pg migrationBackend = Tool.BeamMigrationBackend - "postgres" - (unlines [ "For beam-postgres, this is a libpq connection string which can either be a list of key value pairs or a URI" - , "" - , "For example, 'host=localhost port=5432 dbname=mydb connect_timeout=10' or 'dbname=mydb'" - , "" - , "Or use URIs, for which the general form is:" - , " postgresql://[user[:password]@][netloc][:port][/dbname][?param1=value1&...]" - , "" - , "See for more information" ]) - (liftIOWithHandle getDbConstraints) - (Db.sql92Deserializers <> Db.sql99DataTypeDeserializers <> - Db.sql2008BigIntDataTypeDeserializers <> - postgresDataTypeDeserializers <> - Db.beamCheckDeserializers) - (BCL.unpack . (<> ";") . pgRenderSyntaxScript . fromPgCommand) "postgres.sql" - pgPredConverter (mconcat [ defaultActionProvider - , defaultSchemaActionProvider - , pgExtensionActionProvider - , pgCustomEnumActionProvider - ] - ) - (\options action -> - bracket (Pg.connectPostgreSQL (fromString options)) Pg.close $ \conn -> - left show <$> withPgDebug (\_ -> pure ()) conn action) + { Tool.backendName = "postgres" + , Tool.backendConnStringExplanation = + unlines [ "For beam-postgres, this is a libpq connection string which can either be a list of key value pairs or a URI" + , "" + , "For example, 'host=localhost port=5432 dbname=mydb connect_timeout=10' or 'dbname=mydb'" + , "" + , "Or use URIs, for which the general form is:" + , " postgresql://[user[:password]@][netloc][:port][/dbname][?param1=value1&...]" + , "" + , "See for more information" ] + , Tool.backendGetDbConstraints = liftIOWithHandle getDbConstraints + , Tool.backendPredicateParsers = + Db.sql92Deserializers <> Db.sql99DataTypeDeserializers <> + Db.sql2008BigIntDataTypeDeserializers <> + postgresDataTypeDeserializers <> + Db.beamCheckDeserializers + , Tool.backendRenderSyntax = (BCL.unpack . (<> ";") . pgRenderSyntaxScript . fromPgCommand) + , Tool.backendFileExtension = "postgres.sql" + , Tool.backendConvertToHaskell = pgPredConverter + , Tool.backendActionProvider = + mconcat [ defaultActionProvider + , defaultSchemaActionProvider + , pgExtensionActionProvider + , pgCustomEnumActionProvider + ] + , Tool.backendRunSqlScript = \t -> liftIOWithHandle (\hdl -> void $ Pg.execute_ hdl (Pg.Query (TE.encodeUtf8 t))) + , Tool.backendWithTransaction = + \go -> mask $ \unmask -> do + liftIOWithHandle Pg.begin + x <- unmask go `onException` liftIOWithHandle Pg.rollback + liftIOWithHandle Pg.commit + pure x + , Tool.backendConnect = \options -> do + conn <- Pg.connectPostgreSQL (fromString options) + pure Tool.BeamMigrateConnection + { Tool.backendRun = \action -> + left show <$> withPgDebug (\_ -> pure ()) conn action + , Tool.backendClose = Pg.close conn + } + } -- | 'BeamDeserializers' for postgres-specific types: -- diff --git a/beam-sqlite/Database/Beam/Sqlite/Migrate.hs b/beam-sqlite/Database/Beam/Sqlite/Migrate.hs index de623465..e6d0b572 100644 --- a/beam-sqlite/Database/Beam/Sqlite/Migrate.hs +++ b/beam-sqlite/Database/Beam/Sqlite/Migrate.hs @@ -30,7 +30,7 @@ import Control.Exception import Control.Monad import Control.Monad.Reader -import Database.SQLite.Simple (open, close, query_) +import Database.SQLite.Simple (open, close, query_, execute_, Query(..)) import Data.Aeson import Data.Attoparsec.Text (asciiCI, skipSpace) @@ -50,19 +50,32 @@ import qualified Data.Text.Encoding as TE -- | Top-level 'Tool.BeamMigrationBackend' migrationBackend :: Tool.BeamMigrationBackend Sqlite SqliteM migrationBackend = Tool.BeamMigrationBackend - "sqlite" - "For beam-sqlite, this is the path to a sqlite3 file" - getDbConstraints - (Db.sql92Deserializers <> sqliteDataTypeDeserializers <> - Db.beamCheckDeserializers) - (BL.unpack . (<> ";") . sqliteRenderSyntaxScript . fromSqliteCommand) - "sqlite.sql" - sqlitePredConverter Db.defaultActionProvider - (\fp action -> - bracket (open fp) close $ \conn -> - catch (Right <$> runReaderT (runSqliteM action) - (\_ -> pure (), conn)) - (\e -> pure (Left (show (e :: SomeException))))) + { Tool.backendName = "sqlite" + , Tool.backendConnStringExplanation = "For beam-sqlite, this is the path to a sqlite3 file" + , Tool.backendGetDbConstraints = getDbConstraints + , Tool.backendPredicateParsers = Db.sql92Deserializers <> sqliteDataTypeDeserializers <> + Db.beamCheckDeserializers + , Tool.backendRenderSyntax = (BL.unpack . (<> ";") . sqliteRenderSyntaxScript . fromSqliteCommand) + , Tool.backendFileExtension = "sqlite.sql" + , Tool.backendConvertToHaskell = sqlitePredConverter + , Tool.backendActionProvider = Db.defaultActionProvider + , Tool.backendRunSqlScript = runSqlScript + , Tool.backendWithTransaction = + \(SqliteM go) -> + SqliteM . ReaderT $ \ctx@(pt, conn) -> + mask $ \unmask -> do + let ex q = pt (show q) >> execute_ conn q + ex "BEGIN TRANSACTION" + unmask (runReaderT go ctx <* ex "COMMIT TRANSACTION") `catch` + \(SomeException e) -> ex "ROLLBACK TRANSACTION" >> throwIO e + , Tool.backendConnect = \fp -> do + conn <- open fp + pure Tool.BeamMigrateConnection + { Tool.backendRun = \action -> + catch (Right <$> runReaderT (runSqliteM action) + (\_ -> pure (), conn)) + (\e -> pure (Left (show (e :: SomeException)))) + , Tool.backendClose = close conn } } -- | 'Db.BeamDeserializers' or SQLite specific types. Specifically, -- 'sqliteBlob', 'sqliteText', and 'sqliteBigInt'. These are compatible with the @@ -78,8 +91,13 @@ sqliteDataTypeDeserializers = "bigint" -> pure sqliteBigIntType Object o -> (fmap (\(_ :: Maybe Word) -> sqliteBlobType) (o .: "binary")) <|> - (fmap (\(_ :: Maybe Word) -> sqliteBlobType) (o .: "varbinary")) + (fmap (\(_ :: Maybe Word) -> sqliteBlobType) (o .: "varbinary")) <|> + Db.beamDeserializeJSON "sqlite" customDtParser v _ -> fail "Could not parse sqlite-specific data type" + where + customDtParser = withObject "custom data type" $ \v -> do + txt <- v .: "custom" + pure (parseSqliteDataType txt) -- | Render a series of 'Db.MigrationSteps' in the 'SqliteCommandSyntax' into a -- line-by-line list of lazy 'BL'ByteString's. The output is suitable for @@ -121,15 +139,19 @@ sqliteTypeToHs :: SqliteDataTypeSyntax -> Maybe HsDataType sqliteTypeToHs = Just . sqliteDataTypeToHs +customSqliteDataType :: T.Text -> SqliteDataTypeSyntax +customSqliteDataType txt = + SqliteDataTypeSyntax (emit (TE.encodeUtf8 txt)) + (hsErrorType ("Unknown SQLite datatype '" ++ T.unpack txt ++ "'")) + (Db.BeamSerializedDataType $ + Db.beamSerializeJSON "sqlite" + (object [ "custom" .= txt ])) + False + parseSqliteDataType :: T.Text -> SqliteDataTypeSyntax parseSqliteDataType txt = case A.parseOnly dtParser txt of - Left {} -> SqliteDataTypeSyntax (emit (TE.encodeUtf8 txt)) - (hsErrorType ("Unknown SQLite datatype '" ++ T.unpack txt ++ "'")) - (Db.BeamSerializedDataType $ - Db.beamSerializeJSON "sqlite" - (toJSON txt)) - False + Left {} -> customSqliteDataType txt Right x -> x where dtParser = charP <|> varcharP <|> @@ -226,6 +248,11 @@ parseSqliteDataType txt = asciiCI "SET" *> ws *> A.takeWhile (not . isSpace)) +runSqlScript :: T.Text -> SqliteM () +runSqlScript t = + SqliteM . ReaderT $ \(_, conn) -> + execute_ conn (Query t) + -- TODO constraints and foreign keys -- | Get a list of database predicates for the current database. This is beam's