Updates to migration backends

.gitignore

@@ -1,3 +1,4 @@
+\#*
 .beam-migrate
 cabal.sandbox.config
 .cabal-sandbox
@@ -8,7 +9,7 @@ dist-newstyle
 *.db
 *.db-journal
 .#*
-#*
+\#*
 graveyard
 *.o
 *.hi

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

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

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 <https://www.postgresql.org/docs/9.5/static/libpq-connect.html#LIBPQ-CONNSTRING> 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 <https://www.postgresql.org/docs/9.5/static/libpq-connect.html#LIBPQ-CONNSTRING> 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:
 --

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