Skip to content

Commit b770765

Browse files
tathougiestathougies
committed
New stuff for migrations
1 parent 2a62be7 commit b770765

File tree

5 files changed

+107
-49
lines changed

5 files changed

+107
-49
lines changed

‎.gitignore

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
\#*
12
.beam-migrate
23
cabal.sandbox.config
34
.cabal-sandbox
@@ -8,7 +9,7 @@ dist-newstyle
89
*.db
910
*.db-journal
1011
.#*
11-
#*
12+
\#*
1213
graveyard
1314
*.o
1415
*.hi

‎beam-migrate/Database/Beam/Migrate/Backend.hs

Lines changed: 9 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -26,7 +26,7 @@
2626
--
2727
-- For an example migrate backend, see "Database.Beam.Sqlite.Migrate"
2828
module Database.Beam.Migrate.Backend
29-
( BeamMigrationBackend(..)
29+
( BeamMigrationBackend(..), BeamMigrateConnection(..)
3030
, DdlError
3131

3232
-- * Haskell predicate conversion
@@ -88,9 +88,16 @@ data BeamMigrationBackend be m where
8888
, backendFileExtension :: String
8989
, backendConvertToHaskell :: HaskellPredicateConverter
9090
, backendActionProvider :: ActionProvider be
91-
, backendTransact :: forall a. String -> m a -> IO (Either DdlError a)
91+
, backendRunSqlScript :: Text -> m ()
92+
, backendWithTransaction :: forall a. m a -> m a
93+
, backendConnect :: String -> IO (BeamMigrateConnection be m)
9294
} -> BeamMigrationBackend be m
9395

96+
data BeamMigrateConnection be m where
97+
BeamMigrateConnection
98+
:: { backendRun :: forall a. m a -> IO (Either DdlError a)
99+
, backendClose :: IO () } -> BeamMigrateConnection be m
100+
94101
-- | Monomorphic wrapper for use with plugin loaders that cannot handle
95102
-- polymorphism
96103
data SomeBeamMigrationBackend where

‎beam-migrate/Database/Beam/Migrate/Serialization.hs

Lines changed: 11 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -25,7 +25,8 @@ module Database.Beam.Migrate.Serialization
2525
, BeamDeserializers(..)
2626

2727
, beamDeserialize, beamDeserializeMaybe
28-
, beamDeserializer, sql92Deserializers
28+
, beamDeserializer, beamDeserializeJSON
29+
, sql92Deserializers
2930
, sql99DataTypeDeserializers
3031
, sql2003BinaryAndVarBinaryDataTypeDeserializers
3132
, sql2008BigIntDataTypeDeserializers
@@ -216,6 +217,15 @@ beamSerializeJSON backend v =
216217
object [ "be-specific" .= backend
217218
, "be-data" .= v ]
218219

220+
-- | Corresponding deserializer for 'beamSerializeJSON'
221+
beamDeserializeJSON :: Text -> (Value -> Parser a) -> Value -> Parser a
222+
beamDeserializeJSON backend go =
223+
withObject "backend-specific item" $ \v -> do
224+
be <- v .: "be-specific"
225+
guard (be == backend)
226+
d <- v .: "be-data"
227+
go d
228+
219229
-- | Helper for serializing the precision and decimal count parameters to
220230
-- 'decimalType', etc.
221231
serializePrecAndDecimal :: Maybe (Word, Maybe Word) -> Value

‎beam-postgres/Database/Beam/Postgres/Migrate.hs

Lines changed: 37 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -80,30 +80,43 @@ import GHC.Generics ( Generic )
8080
-- | Top-level migration backend for use by @beam-migrate@ tools
8181
migrationBackend :: Tool.BeamMigrationBackend Postgres Pg
8282
migrationBackend = Tool.BeamMigrationBackend
83-
"postgres"
84-
(unlines [ "For beam-postgres, this is a libpq connection string which can either be a list of key value pairs or a URI"
85-
, ""
86-
, "For example, 'host=localhost port=5432 dbname=mydb connect_timeout=10' or 'dbname=mydb'"
87-
, ""
88-
, "Or use URIs, for which the general form is:"
89-
, " postgresql://[user[:password]@][netloc][:port][/dbname][?param1=value1&...]"
90-
, ""
91-
, "See <https://www.postgresql.org/docs/9.5/static/libpq-connect.html#LIBPQ-CONNSTRING> for more information" ])
92-
(liftIOWithHandle getDbConstraints)
93-
(Db.sql92Deserializers <> Db.sql99DataTypeDeserializers <>
94-
Db.sql2008BigIntDataTypeDeserializers <>
95-
postgresDataTypeDeserializers <>
96-
Db.beamCheckDeserializers)
97-
(BCL.unpack . (<> ";") . pgRenderSyntaxScript . fromPgCommand) "postgres.sql"
98-
pgPredConverter (mconcat [ defaultActionProvider
99-
, defaultSchemaActionProvider
100-
, pgExtensionActionProvider
101-
, pgCustomEnumActionProvider
102-
]
103-
)
104-
(\options action ->
105-
bracket (Pg.connectPostgreSQL (fromString options)) Pg.close $ \conn ->
106-
left show <$> withPgDebug (\_ -> pure ()) conn action)
83+
{ Tool.backendName = "postgres"
84+
, Tool.backendConnStringExplanation =
85+
unlines [ "For beam-postgres, this is a libpq connection string which can either be a list of key value pairs or a URI"
86+
, ""
87+
, "For example, 'host=localhost port=5432 dbname=mydb connect_timeout=10' or 'dbname=mydb'"
88+
, ""
89+
, "Or use URIs, for which the general form is:"
90+
, " postgresql://[user[:password]@][netloc][:port][/dbname][?param1=value1&...]"
91+
, ""
92+
, "See <https://www.postgresql.org/docs/9.5/static/libpq-connect.html#LIBPQ-CONNSTRING> for more information" ]
93+
, Tool.backendGetDbConstraints = liftIOWithHandle getDbConstraints
94+
, Tool.backendPredicateParsers =
95+
Db.sql92Deserializers <> Db.sql99DataTypeDeserializers <>
96+
Db.sql2008BigIntDataTypeDeserializers <>
97+
postgresDataTypeDeserializers <>
98+
Db.beamCheckDeserializers
99+
, Tool.backendRenderSyntax = (BCL.unpack . (<> ";") . pgRenderSyntaxScript . fromPgCommand)
100+
, Tool.backendFileExtension = "postgres.sql"
101+
, Tool.backendConvertToHaskell = pgPredConverter
102+
, Tool.backendActionProvider =
103+
mconcat [ defaultActionProvider
104+
, defaultSchemaActionProvider
105+
, pgExtensionActionProvider
106+
, pgCustomEnumActionProvider
107+
]
108+
, Tool.backendRunSqlScript = \t -> liftIOWithHandle (\hdl -> void $ Pg.execute_ hdl (Pg.Query (TE.encodeUtf8 t)))
109+
, Tool.backendStartTransaction = liftIOWithHandle (void . Pg.begin)
110+
, Tool.backendCommitTransaction = liftIOWithHandle (void . Pg.commit)
111+
, Tool.backendAbortTransaction = liftIOWithHandle (void . Pg.rollback)
112+
, Tool.backendConnect = \options -> do
113+
conn <- Pg.connectPostgreSQL (fromString options)
114+
pure Tool.BeamMigrateConnection
115+
{ Tool.backendRun = \action ->
116+
left show <$> withPgDebug (\_ -> pure ()) conn action
117+
, Tool.backendClose = Pg.close conn
118+
}
119+
}
107120

108121
-- | 'BeamDeserializers' for postgres-specific types:
109122
--

‎beam-sqlite/Database/Beam/Sqlite/Migrate.hs

Lines changed: 48 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,7 @@ import Control.Exception
3030
import Control.Monad
3131
import Control.Monad.Reader
3232

33-
import Database.SQLite.Simple (open, close, query_)
33+
import Database.SQLite.Simple (open, close, query_, execute_, Query(..))
3434

3535
import Data.Aeson
3636
import Data.Attoparsec.Text (asciiCI, skipSpace)
@@ -50,19 +50,32 @@ import qualified Data.Text.Encoding as TE
5050
-- | Top-level 'Tool.BeamMigrationBackend'
5151
migrationBackend :: Tool.BeamMigrationBackend Sqlite SqliteM
5252
migrationBackend = Tool.BeamMigrationBackend
53-
"sqlite"
54-
"For beam-sqlite, this is the path to a sqlite3 file"
55-
getDbConstraints
56-
(Db.sql92Deserializers <> sqliteDataTypeDeserializers <>
57-
Db.beamCheckDeserializers)
58-
(BL.unpack . (<> ";") . sqliteRenderSyntaxScript . fromSqliteCommand)
59-
"sqlite.sql"
60-
sqlitePredConverter Db.defaultActionProvider
61-
(\fp action ->
62-
bracket (open fp) close $ \conn ->
63-
catch (Right <$> runReaderT (runSqliteM action)
64-
(\_ -> pure (), conn))
65-
(\e -> pure (Left (show (e :: SomeException)))))
53+
{ Tool.backendName = "sqlite"
54+
, Tool.backendConnStringExplanation = "For beam-sqlite, this is the path to a sqlite3 file"
55+
, Tool.backendGetDbConstraints = getDbConstraints
56+
, Tool.backendPredicateParsers = Db.sql92Deserializers <> sqliteDataTypeDeserializers <>
57+
Db.beamCheckDeserializers
58+
, Tool.backendRenderSyntax = (BL.unpack . (<> ";") . sqliteRenderSyntaxScript . fromSqliteCommand)
59+
, Tool.backendFileExtension = "sqlite.sql"
60+
, Tool.backendConvertToHaskell = sqlitePredConverter
61+
, Tool.backendActionProvider = Db.defaultActionProvider
62+
, Tool.backendRunSqlScript = runSqlScript
63+
, Tool.backendWithTransaction =
64+
\(SqliteM go) ->
65+
SqliteM . ReaderT $ \ctx@(pt, conn) ->
66+
mask $ \unmask -> do
67+
let ex q = pt (show q) >> execute_ conn q
68+
ex "BEGIN TRANSACTION"
69+
unmask (runReaderT go ctx <* ex "COMMIT TRANSACTION") `catch`
70+
\(SomeException e) -> ex "ROLLBACK TRANSACTION" >> throwIO e
71+
, Tool.backendConnect = \fp -> do
72+
conn <- open fp
73+
pure Tool.BeamMigrateConnection
74+
{ Tool.backendRun = \action ->
75+
catch (Right <$> runReaderT (runSqliteM action)
76+
(\_ -> pure (), conn))
77+
(\e -> pure (Left (show (e :: SomeException))))
78+
, Tool.backendClose = close conn } }
6679

6780
-- | 'Db.BeamDeserializers' or SQLite specific types. Specifically,
6881
-- 'sqliteBlob', 'sqliteText', and 'sqliteBigInt'. These are compatible with the
@@ -78,8 +91,13 @@ sqliteDataTypeDeserializers =
7891
"bigint" -> pure sqliteBigIntType
7992
Object o ->
8093
(fmap (\(_ :: Maybe Word) -> sqliteBlobType) (o .: "binary")) <|>
81-
(fmap (\(_ :: Maybe Word) -> sqliteBlobType) (o .: "varbinary"))
94+
(fmap (\(_ :: Maybe Word) -> sqliteBlobType) (o .: "varbinary")) <|>
95+
Db.beamDeserializeJSON "sqlite" customDtParser v
8296
_ -> fail "Could not parse sqlite-specific data type"
97+
where
98+
customDtParser = withObject "custom data type" $ \v -> do
99+
txt <- v .: "custom"
100+
pure (parseSqliteDataType txt)
83101

84102
-- | Render a series of 'Db.MigrationSteps' in the 'SqliteCommandSyntax' into a
85103
-- line-by-line list of lazy 'BL'ByteString's. The output is suitable for
@@ -121,15 +139,19 @@ sqliteTypeToHs :: SqliteDataTypeSyntax
121139
-> Maybe HsDataType
122140
sqliteTypeToHs = Just . sqliteDataTypeToHs
123141

142+
customSqliteDataType :: T.Text -> SqliteDataTypeSyntax
143+
customSqliteDataType txt =
144+
SqliteDataTypeSyntax (emit (TE.encodeUtf8 txt))
145+
(hsErrorType ("Unknown SQLite datatype '" ++ T.unpack txt ++ "'"))
146+
(Db.BeamSerializedDataType $
147+
Db.beamSerializeJSON "sqlite"
148+
(object [ "custom" .= txt ]))
149+
False
150+
124151
parseSqliteDataType :: T.Text -> SqliteDataTypeSyntax
125152
parseSqliteDataType txt =
126153
case A.parseOnly dtParser txt of
127-
Left {} -> SqliteDataTypeSyntax (emit (TE.encodeUtf8 txt))
128-
(hsErrorType ("Unknown SQLite datatype '" ++ T.unpack txt ++ "'"))
129-
(Db.BeamSerializedDataType $
130-
Db.beamSerializeJSON "sqlite"
131-
(toJSON txt))
132-
False
154+
Left {} -> customSqliteDataType txt
133155
Right x -> x
134156
where
135157
dtParser = charP <|> varcharP <|>
@@ -226,6 +248,11 @@ parseSqliteDataType txt =
226248
asciiCI "SET" *> ws *>
227249
A.takeWhile (not . isSpace))
228250

251+
runSqlScript :: T.Text -> SqliteM ()
252+
runSqlScript t =
253+
SqliteM . ReaderT $ \(_, conn) ->
254+
execute_ conn (Query t)
255+
229256
-- TODO constraints and foreign keys
230257

231258
-- | Get a list of database predicates for the current database. This is beam's

0 commit comments

Comments
 (0)