diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,9 @@ +# 0.5.4.1 + +## Dependencies + +* Ensure that beam-sqlite uses sqlite-3.24+, which is the minimum supported version (#589). + # 0.5.4.0 ## Added features diff --git a/Database/Beam/Sqlite.hs b/Database/Beam/Sqlite.hs --- a/Database/Beam/Sqlite.hs +++ b/Database/Beam/Sqlite.hs @@ -8,6 +8,8 @@ , SqliteSelectSyntax, SqliteInsertSyntax , SqliteUpdateSyntax, SqliteDeleteSyntax + , SqliteDataTypeSyntax(..), mkSqliteDataType + , fromSqliteCommand, sqliteRenderSyntaxScript , module Database.Beam.Sqlite.SqliteSpecific diff --git a/Database/Beam/Sqlite/Migrate.hs b/Database/Beam/Sqlite/Migrate.hs --- a/Database/Beam/Sqlite/Migrate.hs +++ b/Database/Beam/Sqlite/Migrate.hs @@ -3,7 +3,7 @@ -- | Migrations support for SQLite databases module Database.Beam.Sqlite.Migrate - ( migrationBackend, SqliteCommandSyntax + ( migrationBackend, mkCustomMigrationBackend, SqliteCommandSyntax -- * @beam-migrate@ utility functions , migrateScript, writeMigrationScript @@ -30,7 +30,8 @@ import Control.Monad import Control.Monad.Reader -import Database.SQLite.Simple (open, close, query_) +import Database.SQLite.Simple (open, close, query_, execute_, connectionHandle) +import Database.SQLite3 (exec) import Data.Aeson import Data.Attoparsec.Text (asciiCI, skipSpace) @@ -49,21 +50,38 @@ -- | 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))))) +migrationBackend = mkCustomMigrationBackend empty +mkCustomMigrationBackend :: A.Parser SqliteDataTypeSyntax -> Tool.BeamMigrationBackend Sqlite SqliteM +mkCustomMigrationBackend extraParser = + Tool.BeamMigrationBackend + { Tool.backendName = "sqlite" + , Tool.backendConnStringExplanation = "For beam-sqlite, this is the path to a sqlite3 file" + , Tool.backendGetDbConstraints = getDbConstraints extraParser + , 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 -- "typical" serialized versions of the standard 'Db.binaryLargeObject', @@ -78,8 +96,13 @@ "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 empty 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 +144,19 @@ -> Maybe HsDataType sqliteTypeToHs = Just . sqliteDataTypeToHs -parseSqliteDataType :: T.Text -> SqliteDataTypeSyntax -parseSqliteDataType txt = +customSqliteDataType :: T.Text -> SqliteDataTypeSyntax +customSqliteDataType txt = + SqliteDataTypeSyntax (emit (TE.encodeUtf8 txt) <> emit "/* unknown sqlite type */") + (hsErrorType ("Unknown SQLite datatype '" ++ T.unpack txt ++ "'")) + (Db.BeamSerializedDataType $ + Db.beamSerializeJSON "sqlite" + (object [ "custom" .= txt ])) + False + +parseSqliteDataType :: A.Parser SqliteDataTypeSyntax -> T.Text -> SqliteDataTypeSyntax +parseSqliteDataType extraParser 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 <|> @@ -139,7 +166,7 @@ smallIntP <|> bigIntP <|> floatP <|> doubleP <|> realP <|> dateP <|> timestampP <|> timeP <|> textP <|> - blobP <|> booleanP + blobP <|> booleanP <|> extraParser ws = A.many1 A.space @@ -226,6 +253,12 @@ asciiCI "SET" *> ws *> A.takeWhile (not . isSpace)) +runSqlScript :: T.Text -> SqliteM () +runSqlScript t = + SqliteM . ReaderT $ \(_, conn) -> + let hdl = connectionHandle conn + in exec hdl t + -- TODO constraints and foreign keys -- | Get a list of database predicates for the current database. This is beam's @@ -236,8 +269,8 @@ -- correctly parse any type generated by beam and most SQL compliant types, but -- it may falter on databases created or managed by tools that do not follow -- these standards. -getDbConstraints :: SqliteM [Db.SomeDatabasePredicate] -getDbConstraints = +getDbConstraints :: A.Parser SqliteDataTypeSyntax -> SqliteM [Db.SomeDatabasePredicate] +getDbConstraints extraParser = SqliteM . ReaderT $ \(_, conn) -> do tblNames <- query_ conn "SELECT name, sql from sqlite_master where type='table'" tblPreds <- @@ -249,7 +282,7 @@ let columnPreds = foldMap (\(_ ::Int, nm, typStr, notNull, _, _) -> - let dtType = if isAutoincrement then sqliteSerialType else parseSqliteDataType typStr + let dtType = if isAutoincrement then sqliteSerialType else parseSqliteDataType extraParser typStr isAutoincrement = isJust (A.maybeResult (A.parse autoincrementParser sql)) autoincrementParser = do diff --git a/Database/Beam/Sqlite/SqliteSpecific.hs b/Database/Beam/Sqlite/SqliteSpecific.hs --- a/Database/Beam/Sqlite/SqliteSpecific.hs +++ b/Database/Beam/Sqlite/SqliteSpecific.hs @@ -13,9 +13,6 @@ import Database.Beam.Query.Internal import Database.Beam.Sqlite.Connection import Database.Beam.Sqlite.Syntax -#if !MIN_VERSION_base(4, 11, 0) -import Data.Semigroup -#endif -- | The SQLite @group_concat@ function. -- Joins the value in each row of the first argument, using the second diff --git a/Database/Beam/Sqlite/Syntax.hs b/Database/Beam/Sqlite/Syntax.hs --- a/Database/Beam/Sqlite/Syntax.hs +++ b/Database/Beam/Sqlite/Syntax.hs @@ -33,6 +33,7 @@ , SqliteDataTypeSyntax(..) , sqliteTextType, sqliteBlobType , sqliteBigIntType, sqliteSerialType + , mkSqliteDataType -- * Building and consuming 'SqliteSyntax' , fromSqliteCommand, formatSqliteInsert, formatSqliteInsertOnConflict @@ -51,8 +52,10 @@ import Database.Beam.Migrate.SQL.Builder hiding (fromSqlConstraintAttributes) import Database.Beam.Migrate.SQL.SQL92 import Database.Beam.Migrate.Serialization +import qualified Database.Beam.Migrate.Serialization as Db import Database.Beam.Query hiding (ExtractField(..)) +import Data.Aeson (object, (.=)) import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.ByteString.Builder @@ -70,9 +73,7 @@ import Data.Time import qualified Data.Time.Format.ISO8601 as Time import Data.Word -#if !MIN_VERSION_base(4, 11, 0) -import Data.Semigroup -#endif + import GHC.TypeLits import Database.SQLite.Simple (SQLData(..)) @@ -560,6 +561,12 @@ instance IsSql2008BigIntDataTypeSyntax SqliteDataTypeSyntax where bigIntType = sqliteBigIntType +mkSqliteDataType :: String -> SqliteDataTypeSyntax +mkSqliteDataType s = SqliteDataTypeSyntax (emit (fromString s)) (hsErrorType s) + (Db.BeamSerializedDataType $ + Db.beamSerializeJSON "sqlite" (object [ "custom" .= s ])) + False + sqliteTextType, sqliteBlobType, sqliteBigIntType :: SqliteDataTypeSyntax sqliteTextType = SqliteDataTypeSyntax (emit "TEXT") (HsDataType (hsVarFrom "sqliteText" "Database.Beam.Sqlite") @@ -710,7 +717,7 @@ instance HasSqlValueSyntax SqliteValueSyntax Int32 where sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) instance HasSqlValueSyntax SqliteValueSyntax Int64 where - sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) + sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger i)) instance HasSqlValueSyntax SqliteValueSyntax Word8 where sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) instance HasSqlValueSyntax SqliteValueSyntax Word16 where diff --git a/beam-sqlite.cabal b/beam-sqlite.cabal --- a/beam-sqlite.cabal +++ b/beam-sqlite.cabal @@ -1,5 +1,5 @@ name: beam-sqlite -version: 0.5.4.0 +version: 0.5.4.1 synopsis: Beam driver for SQLite description: Beam driver for the embedded database. See @@ -23,7 +23,7 @@ Database.Beam.Sqlite.Connection Database.Beam.Sqlite.Migrate other-modules: Database.Beam.Sqlite.SqliteSpecific - build-depends: base >=4.7 && <5, + build-depends: base >=4.11 && <5, beam-core >=0.10 && <0.11, beam-migrate >=0.5 && <0.6, @@ -41,14 +41,18 @@ network-uri >=2.6 && <2.7, aeson >=0.11 && <2.3, attoparsec >=0.13 && <0.15, - transformers-base >=0.4 && <0.5 + transformers-base >=0.4 && <0.5, + direct-sqlite >=2.3.24 default-language: Haskell2010 default-extensions: ScopedTypeVariables, OverloadedStrings, MultiParamTypeClasses, RankNTypes, FlexibleInstances, DeriveDataTypeable, DeriveGeneric, StandaloneDeriving, TypeFamilies, GADTs, OverloadedStrings, CPP, TypeApplications, FlexibleContexts, ConstraintKinds, DerivingStrategies ghc-options: -Wall + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates if flag(werror) - ghc-options: -Werror + ghc-options: -Werror test-suite beam-sqlite-tests type: exitcode-stdio-1.0