diff --git a/Database/Beam/Sqlite/Connection.hs b/Database/Beam/Sqlite/Connection.hs --- a/Database/Beam/Sqlite/Connection.hs +++ b/Database/Beam/Sqlite/Connection.hs @@ -1,5 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -10,17 +12,24 @@ , runBeamSqlite, runBeamSqliteDebug -- * Emulated @INSERT RETURNING@ support - , SqliteInsertReturning , insertReturning, runInsertReturningList ) where import Database.Beam.Backend -import Database.Beam.Backend.SQL import qualified Database.Beam.Backend.SQL.BeamExtensions as Beam import Database.Beam.Backend.URI -import Database.Beam.Query (QExpr, SqlInsert(..), SqlInsertValues(..), insert) -import Database.Beam.Schema.Tables ( DatabaseEntity(..) - , DatabaseEntityDescriptor(..) +import Database.Beam.Migrate.Generics +import Database.Beam.Migrate.SQL ( BeamMigrateOnlySqlBackend, FieldReturnType(..) ) +import qualified Database.Beam.Migrate.SQL as Beam +import Database.Beam.Migrate.SQL.BeamExtensions +import Database.Beam.Query ( QExpr, SqlInsert(..), SqlInsertValues(..) + , HasQBuilder(..), HasSqlEqualityCheck + , HasSqlQuantifiedEqualityCheck + , DataType(..) + , insert ) +import Database.Beam.Query.SQL92 +import Database.Beam.Schema.Tables ( Beamable + , DatabaseEntity(..) , TableEntity) import Database.Beam.Sqlite.Syntax @@ -35,26 +44,31 @@ import Database.SQLite.Simple.Ok (Ok(..)) import Database.SQLite.Simple.Types (Null) -import Control.Exception (bracket_, onException, mask) -import Control.Monad (forM_, replicateM_) +import Control.Exception (SomeException(..), bracket_, onException, mask) +import Control.Monad (forM_) import Control.Monad.Fail (MonadFail) import Control.Monad.Free.Church import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Identity (Identity) -import Control.Monad.Reader (ReaderT, MonadReader(..), runReaderT) -import Control.Monad.State.Strict (MonadState(..), runStateT) +import Control.Monad.Reader (ReaderT(..), MonadReader(..), runReaderT) +import Control.Monad.State.Strict (MonadState(..), StateT(..), runStateT) +import Control.Monad.Trans (lift) -import qualified Data.ByteString.Char8 as BS import Data.ByteString.Builder (toLazyByteString) +import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.DList as D import Data.Int +import Data.Maybe (mapMaybe) +import Data.Proxy (Proxy(..)) import Data.Scientific (Scientific) import Data.String (fromString) import qualified Data.Text as T +import qualified Data.Text.Encoding as T (decodeUtf8) import qualified Data.Text.Lazy as TL import Data.Time ( LocalTime, UTCTime, Day - , utc, utcToLocalTime ) + , ZonedTime, utc, utcToLocalTime ) +import Data.Typeable (cast) import Data.Word #if !MIN_VERSION_base(4,11,0) import Data.Semigroup @@ -81,6 +95,12 @@ instance BeamBackend Sqlite where type BackendFromField Sqlite = FromField +instance HasQBuilder Sqlite where + buildSqlQuery = buildSql92Query' False -- SQLite does not support arbitrarily nesting UNION, INTERSECT, and EXCEPT + +instance BeamSqlBackendIsString Sqlite T.Text +instance BeamSqlBackendIsString Sqlite String + instance FromBackendRow Sqlite Bool instance FromBackendRow Sqlite Double instance FromBackendRow Sqlite Float @@ -135,8 +155,18 @@ Just s' -> pure s' instance BeamSqlBackend Sqlite -instance BeamSql92Backend Sqlite +instance BeamMigrateOnlySqlBackend Sqlite +type instance BeamSqlBackendSyntax Sqlite = SqliteCommandSyntax +data SqliteHasDefault = SqliteHasDefault +instance FieldReturnType 'True 'False Sqlite resTy a => + FieldReturnType 'False 'False Sqlite resTy (SqliteHasDefault -> a) where + field' _ _ nm ty _ collation constraints SqliteHasDefault = + field' (Proxy @'True) (Proxy @'False) nm ty Nothing collation constraints + +instance BeamSqlBackendHasSerial Sqlite where + genericSerial nm = Beam.field nm (DataType sqliteSerialType) SqliteHasDefault + -- | 'MonadBeam' instance inside whiche SQLite queries are run. See the -- for more information newtype SqliteM a @@ -152,36 +182,100 @@ newtype BeamSqliteRow a = BeamSqliteRow a instance FromBackendRow Sqlite a => FromRow (BeamSqliteRow a) where - fromRow = BeamSqliteRow <$> runF (fromBackendRow :: FromBackendRowM Sqlite a) finish step + fromRow = BeamSqliteRow <$> runF fromBackendRow' finish step where + FromBackendRowM fromBackendRow' = fromBackendRow :: FromBackendRowM Sqlite a + + translateErrors :: Maybe Int -> SomeException -> Maybe SomeException + translateErrors col (SomeException e) = + case cast e of + Just (ConversionFailed { errSQLType = typeString + , errHaskellType = hsString + , errMessage = msg }) -> + Just (SomeException (BeamRowReadError col (ColumnTypeMismatch hsString typeString ("conversion failed: " ++ msg)))) + Just (UnexpectedNull {}) -> + Just (SomeException (BeamRowReadError col ColumnUnexpectedNull)) + Just (Incompatible { errSQLType = typeString + , errHaskellType = hsString + , errMessage = msg }) -> + Just (SomeException (BeamRowReadError col (ColumnTypeMismatch hsString typeString ("incompatible: " ++ msg)))) + Nothing -> Nothing + finish = pure - step :: FromBackendRowF Sqlite (RowParser a) -> RowParser a + step :: forall a'. FromBackendRowF Sqlite (RowParser a') -> RowParser a' step (ParseOneField next) = - field >>= next - step (PeekField next) = - RP $ do - ro <- ask - st <- get - case runStateT (runReaderT (unRP field) ro) st of - Ok (a, _) -> unRP (next (Just a)) - _ -> unRP (next Nothing) - step (CheckNextNNull n next) = - RP $ do - ro <- ask - st <- get - case runStateT (runReaderT (unRP (replicateM_ n (field :: RowParser Null))) ro) st of - Ok ((), st') -> - do put st' - unRP (next True) - _ -> unRP (next False) + RP $ ReaderT $ \ro -> StateT $ \st@(col, _) -> + case runStateT (runReaderT (unRP field) ro) st of + Ok (x, st') -> runStateT (runReaderT (unRP (next x)) ro) st' + Errors errs -> Errors (mapMaybe (translateErrors (Just col)) errs) + step (Alt (FromBackendRowM a) (FromBackendRowM b) next) = do + RP $ do + let RP a' = runF a finish step + RP b' = runF b finish step + st <- get + ro <- ask + case runStateT (runReaderT a' ro) st of + Ok (ra, st') -> do + put st' + unRP (next ra) + Errors aErrs -> + case runStateT (runReaderT b' ro) st of + Ok (rb, st') -> do + put st' + unRP (next rb) + Errors bErrs -> + lift (lift (Errors (aErrs ++ bErrs))) + step (FailParseWith err) = RP (lift (lift (Errors [SomeException err]))) + +-- * Equality checks +#define HAS_SQLITE_EQUALITY_CHECK(ty) \ + instance HasSqlEqualityCheck Sqlite (ty); \ + instance HasSqlQuantifiedEqualityCheck Sqlite (ty); + +HAS_SQLITE_EQUALITY_CHECK(Int) +HAS_SQLITE_EQUALITY_CHECK(Int8) +HAS_SQLITE_EQUALITY_CHECK(Int16) +HAS_SQLITE_EQUALITY_CHECK(Int32) +HAS_SQLITE_EQUALITY_CHECK(Int64) +HAS_SQLITE_EQUALITY_CHECK(Word) +HAS_SQLITE_EQUALITY_CHECK(Word8) +HAS_SQLITE_EQUALITY_CHECK(Word16) +HAS_SQLITE_EQUALITY_CHECK(Word32) +HAS_SQLITE_EQUALITY_CHECK(Word64) +HAS_SQLITE_EQUALITY_CHECK(Double) +HAS_SQLITE_EQUALITY_CHECK(Float) +HAS_SQLITE_EQUALITY_CHECK(Bool) +HAS_SQLITE_EQUALITY_CHECK(String) +HAS_SQLITE_EQUALITY_CHECK(T.Text) +HAS_SQLITE_EQUALITY_CHECK(TL.Text) +HAS_SQLITE_EQUALITY_CHECK(BS.ByteString) +HAS_SQLITE_EQUALITY_CHECK(BL.ByteString) +HAS_SQLITE_EQUALITY_CHECK(UTCTime) +HAS_SQLITE_EQUALITY_CHECK(LocalTime) +HAS_SQLITE_EQUALITY_CHECK(ZonedTime) +HAS_SQLITE_EQUALITY_CHECK(Char) +HAS_SQLITE_EQUALITY_CHECK(Integer) +HAS_SQLITE_EQUALITY_CHECK(Scientific) + +instance HasDefaultSqlDataType Sqlite (SqlSerial Int) where + defaultSqlDataType _ _ False = sqliteSerialType + defaultSqlDataType _ _ True = intType + +instance HasDefaultSqlDataType Sqlite BS.ByteString where + -- TODO we should somehow allow contsraints based on backend + defaultSqlDataType _ _ _ = sqliteBlobType + +instance HasDefaultSqlDataType Sqlite LocalTime where + defaultSqlDataType _ _ _ = timestampType Nothing False + -- | URI syntax for use with 'withDbConnection'. See documentation for -- 'BeamURIOpeners' for more information. -sqliteUriSyntax :: c SqliteCommandSyntax Sqlite Connection SqliteM +sqliteUriSyntax :: c Sqlite Connection SqliteM -> BeamURIOpeners c sqliteUriSyntax = - mkUriOpener "sqlite:" + mkUriOpener runBeamSqlite "sqlite:" (\uri -> do let sqliteName = if null (uriPath uri) then ":memory:" else uriPath uri hdl <- open sqliteName @@ -193,10 +287,7 @@ runBeamSqlite :: Connection -> SqliteM a -> IO a runBeamSqlite = runBeamSqliteDebug (\_ -> pure ()) -instance MonadBeam SqliteCommandSyntax Sqlite Connection SqliteM where - withDatabase = runBeamSqlite - withDatabaseDebug = runBeamSqliteDebug - +instance MonadBeam Sqlite SqliteM where runNoReturn (SqliteCommandSyntax (SqliteSyntax cmd vals)) = SqliteM $ do (logger, conn) <- ask @@ -227,14 +318,13 @@ , "rows from an insert, use Database.Beam.Sqlite.insertReturning " , "for emulation" ] -instance Beam.MonadBeamInsertReturning SqliteCommandSyntax Sqlite Connection SqliteM where - runInsertReturningList tbl values = - runInsertReturningList (insertReturning tbl values) +instance Beam.MonadBeamInsertReturning Sqlite SqliteM where + runInsertReturningList = runInsertReturningList runSqliteInsert :: (String -> IO ()) -> Connection -> SqliteInsertSyntax -> IO () runSqliteInsert logger conn (SqliteInsertSyntax tbl fields vs) -- If all expressions are simple expressions (no default), then just - -- run the INSERT normally + | SqliteInsertExpressions es <- vs, any (any (== SqliteExpressionDefault)) es = forM_ es $ \row -> do let (fields', row') = unzip $ filter ((/= SqliteExpressionDefault) . snd) $ zip fields row @@ -250,33 +340,21 @@ -- * emulated INSERT returning support --- | Represents an @INSERT@ statement, from which we can retrieve inserted rows. --- Beam also offers a backend-agnostic way of using this functionality in the --- 'MonadBeamInsertReturning' extension. This functionality is emulated in --- SQLite using a temporary table and a trigger. -data SqliteInsertReturning (table :: (* -> *) -> *) - = SqliteInsertReturning T.Text SqliteInsertSyntax - | SqliteInsertReturningNoRows - -- | Build a 'SqliteInsertReturning' representing inserting the given values -- into the given table. Use 'runInsertReturningList' -insertReturning :: DatabaseEntity be db (TableEntity table) - -> SqlInsertValues SqliteInsertValuesSyntax (table (QExpr SqliteExpressionSyntax s)) - -> SqliteInsertReturning table -insertReturning tbl@(DatabaseEntity (DatabaseTable tblNm _)) vs = - case insert tbl vs of - SqlInsert s -> - SqliteInsertReturning tblNm s - SqlInsertNoRows -> - SqliteInsertReturningNoRows +insertReturning :: Beamable table + => DatabaseEntity Sqlite db (TableEntity table) + -> SqlInsertValues Sqlite (table (QExpr Sqlite s)) + -> SqlInsert Sqlite table +insertReturning = insert -- | Runs a 'SqliteInsertReturning' statement and returns a result for each -- inserted row. runInsertReturningList :: FromBackendRow Sqlite (table Identity) - => SqliteInsertReturning table + => SqlInsert Sqlite table -> SqliteM [ table Identity ] -runInsertReturningList SqliteInsertReturningNoRows = pure [] -runInsertReturningList (SqliteInsertReturning nm insertStmt_) = +runInsertReturningList SqlInsertNoRows = pure [] +runInsertReturningList (SqlInsert _ insertStmt_@(SqliteInsertSyntax nm _ _)) = do (logger, conn) <- SqliteM ask SqliteM . liftIO $ do @@ -288,7 +366,9 @@ #error Need either POSIX or Win32 API for MonadBeamInsertReturning #endif - let startSavepoint = + let tableNameTxt = T.decodeUtf8 (BL.toStrict (sqliteRenderSyntaxScript (fromSqliteTableName nm))) + + startSavepoint = execute_ conn (Query ("SAVEPOINT insert_savepoint_" <> processId)) rollbackToSavepoint = execute_ conn (Query ("ROLLBACK TRANSACTION TO SAVEPOINT insert_savepoint_" <> processId)) @@ -296,13 +376,13 @@ execute_ conn (Query ("RELEASE SAVEPOINT insert_savepoint_" <> processId)) createInsertedValuesTable = - execute_ conn (Query ("CREATE TEMPORARY TABLE inserted_values_" <> processId <> " AS SELECT * FROM \"" <> sqliteEscape nm <> "\" LIMIT 0")) + execute_ conn (Query ("CREATE TEMPORARY TABLE inserted_values_" <> processId <> " AS SELECT * FROM " <> tableNameTxt <> " LIMIT 0")) dropInsertedValuesTable = execute_ conn (Query ("DROP TABLE inserted_values_" <> processId)) createInsertTrigger = - execute_ conn (Query ("CREATE TEMPORARY TRIGGER insert_trigger_" <> processId <> " AFTER INSERT ON \"" <> sqliteEscape nm <> "\" BEGIN " <> - "INSERT INTO inserted_values_" <> processId <> " SELECT * FROM \"" <> sqliteEscape nm <> "\" WHERE ROWID=last_insert_rowid(); END" )) + execute_ conn (Query ("CREATE TEMPORARY TRIGGER insert_trigger_" <> processId <> " AFTER INSERT ON " <> tableNameTxt <> " BEGIN " <> + "INSERT INTO inserted_values_" <> processId <> " SELECT * FROM " <> tableNameTxt <> " WHERE ROWID=last_insert_rowid(); END" )) dropInsertTrigger = execute_ conn (Query ("DROP TRIGGER insert_trigger_" <> processId)) 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 @@ -4,7 +4,7 @@ -- | Migrations support for SQLite databases module Database.Beam.Sqlite.Migrate ( -- * @beam-migrate@ CLI support - migrationBackend + migrationBackend, SqliteCommandSyntax -- * @beam-migrate@ utility functions , migrateScript, writeMigrationScript @@ -18,6 +18,8 @@ import qualified Database.Beam.Migrate as Db import qualified Database.Beam.Migrate.Backend as Tool import qualified Database.Beam.Migrate.Serialization as Db +import Database.Beam.Migrate.Types (QualifiedName(..)) +import qualified Database.Beam.Query.DataTypes as Db import Database.Beam.Backend.SQL import Database.Beam.Haskell.Syntax @@ -28,8 +30,7 @@ import Control.Exception import Control.Monad.Reader -import Database.SQLite.Simple - ( Connection, open, close, query_ ) +import Database.SQLite.Simple (open, close, query_) import Data.Aeson import Data.Attoparsec.Text (asciiCI, skipSpace) @@ -48,11 +49,10 @@ -- | Top-level 'Tool.BeamMigrationBackend' loaded dynamically by the -- @beam-migrate@ CLI tool. -migrationBackend :: Tool.BeamMigrationBackend SqliteCommandSyntax Sqlite Connection SqliteM +migrationBackend :: Tool.BeamMigrationBackend Sqlite SqliteM migrationBackend = Tool.BeamMigrationBackend "sqlite" "For beam-sqlite, this is the path to a sqlite3 file" - (BL.concat . migrateScript) getDbConstraints (Db.sql92Deserializers <> sqliteDataTypeDeserializers <> Db.beamCheckDeserializers) @@ -69,7 +69,7 @@ -- 'sqliteBlob', 'sqliteText', and 'sqliteBigInt'. These are compatible with the -- "typical" serialized versions of the standard 'Db.binaryLargeObject', -- 'Db.characterLargeObject', and 'Db.bigint' types. -sqliteDataTypeDeserializers :: Db.BeamDeserializers SqliteCommandSyntax +sqliteDataTypeDeserializers :: Db.BeamDeserializers Sqlite sqliteDataTypeDeserializers = Db.beamDeserializer $ \_ v -> fmap (id @SqliteDataTypeSyntax) $ @@ -86,7 +86,7 @@ -- line-by-line list of lazy 'BL'ByteString's. The output is suitable for -- inclusion in a migration script. Comments are generated giving a description -- of each migration step. -migrateScript :: Db.MigrationSteps SqliteCommandSyntax () a -> [BL.ByteString] +migrateScript :: Db.MigrationSteps Sqlite () a -> [BL.ByteString] migrateScript steps = "-- Generated by beam-sqlite beam-migrate backend\n" : "\n" : @@ -98,7 +98,7 @@ Endo ((sqliteRenderSyntaxScript (fromSqliteCommand cmd) <> ";\n"):) -- | Write the output of 'migrateScript' to a file -writeMigrationScript :: FilePath -> Db.MigrationSteps SqliteCommandSyntax () a -> IO () +writeMigrationScript :: FilePath -> Db.MigrationSteps Sqlite () a -> IO () writeMigrationScript fp steps = let stepBs = migrateScript steps in BL.writeFile fp (BL.concat stepBs) @@ -107,14 +107,14 @@ -- by 'getDbConstaints' into their equivalent in the @beam-migrate@ haskell -- syntax. Suitable for auto-generation of a haskell migration. sqlitePredConverter :: Tool.HaskellPredicateConverter -sqlitePredConverter = Tool.sql92HsPredicateConverters @SqliteColumnSchemaSyntax sqliteTypeToHs <> +sqlitePredConverter = Tool.sql92HsPredicateConverters @Sqlite sqliteTypeToHs <> Tool.hsPredicateConverter sqliteHasColumnConstraint where sqliteHasColumnConstraint (Db.TableColumnHasConstraint tblNm colNm c :: - Db.TableColumnHasConstraint SqliteColumnSchemaSyntax) + Db.TableColumnHasConstraint Sqlite) | c == Db.constraintDefinitionSyntax Nothing Db.notNullConstraintSyntax Nothing = Just (Db.SomeDatabasePredicate (Db.TableColumnHasConstraint tblNm colNm (Db.constraintDefinitionSyntax Nothing Db.notNullConstraintSyntax Nothing) :: - Db.TableColumnHasConstraint HsColumnSchema)) + Db.TableColumnHasConstraint HsMigrateBackend)) | otherwise = Nothing -- | Convert a SQLite data type to the corresponding Haskell one @@ -238,9 +238,10 @@ SqliteM . ReaderT $ \(_, conn) -> do tblNames <- query_ conn "SELECT name, sql from sqlite_master where type='table'" tblPreds <- - fmap mconcat . forM tblNames $ \(tblName, sql) -> do + fmap mconcat . forM tblNames $ \(tblNameStr, sql) -> do + let tblName = QualifiedName Nothing tblNameStr columns <- fmap (sortBy (comparing (\(cid, _, _, _, _, _) -> cid :: Int))) $ - query_ conn (fromString ("PRAGMA table_info('" <> T.unpack tblName <> "')")) + query_ conn (fromString ("PRAGMA table_info('" <> T.unpack tblNameStr <> "')")) let columnPreds = foldMap @@ -267,12 +268,12 @@ then [ Db.SomeDatabasePredicate (Db.TableColumnHasConstraint tblName nm (Db.constraintDefinitionSyntax Nothing Db.notNullConstraintSyntax Nothing) - :: Db.TableColumnHasConstraint SqliteColumnSchemaSyntax) ] + :: Db.TableColumnHasConstraint Sqlite) ] else [] in [ Db.SomeDatabasePredicate (Db.TableHasColumn tblName nm dtType :: - Db.TableHasColumn SqliteColumnSchemaSyntax) ] ++ + Db.TableHasColumn Sqlite) ] ++ notNullPred ) columns @@ -288,12 +289,12 @@ pure tblPreds -sqliteText :: Db.DataType SqliteDataTypeSyntax T.Text +sqliteText :: Db.DataType Sqlite T.Text sqliteText = Db.DataType sqliteTextType -sqliteBlob :: Db.DataType SqliteDataTypeSyntax ByteString +sqliteBlob :: Db.DataType Sqlite ByteString sqliteBlob = Db.DataType sqliteBlobType -sqliteBigInt :: Db.DataType SqliteDataTypeSyntax Int64 +sqliteBigInt :: Db.DataType Sqlite Int64 sqliteBigInt = Db.DataType sqliteBigIntType 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 @@ -11,6 +11,7 @@ import Database.Beam import Database.Beam.Backend.SQL 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 @@ -20,14 +21,13 @@ -- Joins the value in each row of the first argument, using the second -- argument as a delimiter. See 'sqliteGroupConcatOver' if you want to provide -- explicit quantification. -sqliteGroupConcat - :: ( HasSqlValueSyntax SqliteValueSyntax a - , IsSqlExpressionSyntaxStringType SqliteExpressionSyntax str - , IsSqlExpressionSyntaxStringType SqliteExpressionSyntax str2 - ) - => QExpr SqliteExpressionSyntax s a - -> QExpr SqliteExpressionSyntax s str - -> QAgg SqliteExpressionSyntax s (Maybe str2) +sqliteGroupConcat + :: ( BeamSqlBackendCanSerialize Sqlite a + , BeamSqlBackendIsString Sqlite str + , BeamSqlBackendIsString Sqlite str2 ) + => QExpr Sqlite s a + -> QExpr Sqlite s str + -> QAgg Sqlite s (Maybe str2) sqliteGroupConcat v delim = _sqliteGroupConcatOver allInGroup_ v (Just delim) @@ -35,27 +35,25 @@ -- Joins the value in each row of the first argument using ','. -- See 'sqliteGroupConcat' if you want to change the delimiter. -- Choosing a custom delimiter and quantification isn't allowed by SQLite. -sqliteGroupConcatOver - :: ( HasSqlValueSyntax SqliteValueSyntax a - , IsSqlExpressionSyntaxStringType SqliteExpressionSyntax str - ) +sqliteGroupConcatOver + :: ( BeamSqlBackendCanSerialize Sqlite a + , BeamSqlBackendIsString Sqlite str ) => Maybe SqliteAggregationSetQuantifierSyntax - -> QExpr SqliteExpressionSyntax s a - -> QAgg SqliteExpressionSyntax s (Maybe str) + -> QExpr Sqlite s a + -> QAgg Sqlite s (Maybe str) sqliteGroupConcatOver quantifier v = _sqliteGroupConcatOver quantifier v Nothing -- SQLite doesn't allow DISTINCT and a custom delimiter -_sqliteGroupConcatOver - :: ( HasSqlValueSyntax SqliteValueSyntax a - , IsSqlExpressionSyntaxStringType SqliteExpressionSyntax str - ) +_sqliteGroupConcatOver + :: ( BeamSqlBackendCanSerialize Sqlite a + , BeamSqlBackendIsString Sqlite str ) => Maybe SqliteAggregationSetQuantifierSyntax - -> QExpr SqliteExpressionSyntax s a - -> Maybe (QExpr SqliteExpressionSyntax s str2) - -> QAgg SqliteExpressionSyntax s (Maybe str) + -> QExpr Sqlite s a + -> Maybe (QExpr Sqlite s str2) + -> QAgg Sqlite s (Maybe str) _sqliteGroupConcatOver quantifier (QExpr v) delim = QExpr $ \tbl -> SqliteExpressionSyntax $ emit "group_concat" <> parens ( maybe mempty (\q -> fromSqliteAggregationSetQuantifier q <> emit " ") quantifier <> - fromSqliteExpression (v tbl) <> + fromSqliteExpression (v tbl) <> maybe mempty (\(QExpr d) -> emit ", " <> fromSqliteExpression (d tbl)) delim) 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 @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-name-shadowing#-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -21,6 +22,7 @@ , SqliteInsertValuesSyntax(..) , SqliteColumnSchemaSyntax(..) , SqliteExpressionSyntax(..), SqliteValueSyntax(..) + , SqliteTableNameSyntax(..) , SqliteAggregationSetQuantifierSyntax(..) , fromSqliteExpression @@ -40,15 +42,13 @@ ) where import Database.Beam.Backend.SQL +import Database.Beam.Backend.SQL.AST (ExtractField(..)) import Database.Beam.Haskell.Syntax -import Database.Beam.Migrate.Generics +import Database.Beam.Migrate.Checks (HasDataTypeCreatedCheck(..)) import Database.Beam.Migrate.SQL.Builder hiding (fromSqlConstraintAttributes) import Database.Beam.Migrate.SQL.SQL92 -import Database.Beam.Migrate.SQL (DataType(..), FieldReturnType(..), field) -import Database.Beam.Migrate.SQL.BeamExtensions import Database.Beam.Migrate.Serialization -import Database.Beam.Query -import Database.Beam.Query.SQL92 +import Database.Beam.Query hiding (ExtractField(..)) import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -59,7 +59,6 @@ import Data.Hashable import Data.Int import Data.Maybe -import Data.Proxy (Proxy(..)) import Data.Scientific import Data.String import qualified Data.Text as T @@ -182,19 +181,16 @@ -- | SQLite @SELECT@ syntax newtype SqliteSelectSyntax = SqliteSelectSyntax { fromSqliteSelect :: SqliteSyntax } -instance HasQBuilder SqliteSelectSyntax where - buildSqlQuery = buildSql92Query' False -- SQLite does not support arbitrarily nesting UNION, INTERSECT, and EXCEPT - -- | SQLite @INSERT@ syntax. This doesn't directly wrap 'SqliteSyntax' because -- we need to do some processing on @INSERT@ statements to deal with @AUTO -- INCREMENT@ columns. Use 'formatSqliteInsert' to turn 'SqliteInsertSyntax' -- into 'SqliteSyntax'. data SqliteInsertSyntax = SqliteInsertSyntax - { sqliteInsertTable :: T.Text + { sqliteInsertTable :: !SqliteTableNameSyntax , sqliteInsertFields :: [ T.Text ] - , sqliteInsertValues :: SqliteInsertValuesSyntax + , sqliteInsertValues :: !SqliteInsertValuesSyntax } -- | SQLite @UPDATE@ syntax @@ -212,7 +208,6 @@ instance Hashable SqliteExpressionSyntax newtype SqliteFromSyntax = SqliteFromSyntax { fromSqliteFromSyntax :: SqliteSyntax } newtype SqliteComparisonQuantifierSyntax = SqliteComparisonQuantifierSyntax { fromSqliteComparisonQuantifier :: SqliteSyntax } -newtype SqliteExtractFieldSyntax = SqliteExtractFieldSyntax { fromSqliteExtractField :: SqliteSyntax } newtype SqliteAggregationSetQuantifierSyntax = SqliteAggregationSetQuantifierSyntax { fromSqliteAggregationSetQuantifier :: SqliteSyntax } newtype SqliteProjectionSyntax = SqliteProjectionSyntax { fromSqliteProjection :: SqliteSyntax } newtype SqliteGroupingSyntax = SqliteGroupingSyntax { fromSqliteGrouping :: SqliteSyntax } @@ -287,6 +282,7 @@ newtype SqliteAlterTableActionSyntax = SqliteAlterTableActionSyntax { fromSqliteAlterTableAction :: Maybe SqliteSyntax } newtype SqliteAlterColumnActionSyntax = SqliteAlterColumnActionSyntax { fromSqliteAlterColumnAction :: Maybe SqliteSyntax } newtype SqliteDropTableSyntax = SqliteDropTableSyntax { fromSqliteDropTable :: SqliteSyntax } +newtype SqliteTableNameSyntax = SqliteTableNameSyntax { fromSqliteTableName :: SqliteSyntax } fromSqliteExpression :: SqliteExpressionSyntax -> SqliteSyntax fromSqliteExpression (SqliteExpressionSyntax s) = s @@ -297,9 +293,9 @@ sqliteRenderSyntaxScript . fromSqliteExpression -- | Format a SQLite @INSERT@ expression for the given table name, fields, and values. -formatSqliteInsert :: T.Text -> [ T.Text ] -> SqliteInsertValuesSyntax -> SqliteSyntax +formatSqliteInsert :: SqliteTableNameSyntax -> [ T.Text ] -> SqliteInsertValuesSyntax -> SqliteSyntax formatSqliteInsert tblNm fields values = - emit "INSERT INTO " <> quotedIdentifier tblNm <> parens (commas (map quotedIdentifier fields)) <> emit " " <> + emit "INSERT INTO " <> fromSqliteTableName tblNm <> parens (commas (map quotedIdentifier fields)) <> emit " " <> case values of SqliteInsertFromSql (SqliteSelectSyntax select) -> select SqliteInsertExpressions es -> @@ -325,17 +321,25 @@ alterTableCmd = SqliteCommandSyntax . fromSqliteAlterTable dropTableCmd = SqliteCommandSyntax . fromSqliteDropTable +instance IsSql92TableNameSyntax SqliteTableNameSyntax where + -- SQLite doesn't have schemas proper, but it does have attached databases, which is what we use here + tableName Nothing tbl = SqliteTableNameSyntax (quotedIdentifier tbl) + tableName (Just sch) tbl = SqliteTableNameSyntax (quotedIdentifier sch <> emit "." <> quotedIdentifier tbl) + instance IsSql92DropTableSyntax SqliteDropTableSyntax where - dropTableSyntax nm = SqliteDropTableSyntax (emit "DROP TABLE " <> quotedIdentifier nm) + type Sql92DropTableTableNameSyntax SqliteDropTableSyntax = SqliteTableNameSyntax + dropTableSyntax nm = SqliteDropTableSyntax (emit "DROP TABLE " <> fromSqliteTableName nm) + instance IsSql92AlterTableSyntax SqliteAlterTableSyntax where type Sql92AlterTableAlterTableActionSyntax SqliteAlterTableSyntax = SqliteAlterTableActionSyntax + type Sql92AlterTableTableNameSyntax SqliteAlterTableSyntax = SqliteTableNameSyntax alterTableSyntax nm action = SqliteAlterTableSyntax $ case fromSqliteAlterTableAction action of Just alterTable -> - emit "ALTER TABLE " <> quotedIdentifier nm <> emit " " <> alterTable + emit "ALTER TABLE " <> fromSqliteTableName nm <> emit " " <> alterTable Nothing -> emit "SELECT 1" @@ -447,6 +451,7 @@ type Sql92CreateTableColumnSchemaSyntax SqliteCreateTableSyntax = SqliteColumnSchemaSyntax type Sql92CreateTableTableConstraintSyntax SqliteCreateTableSyntax = SqliteTableConstraintSyntax type Sql92CreateTableOptionsSyntax SqliteCreateTableSyntax = SqliteTableOptionsSyntax + type Sql92CreateTableTableNameSyntax SqliteCreateTableSyntax = SqliteTableNameSyntax createTableSyntax _ nm fields constraints = let fieldDefs = map mkFieldDef fields @@ -462,7 +467,7 @@ createWithConstraints constraintDefs' = SqliteCreateTableSyntax $ - emit "CREATE TABLE " <> quotedIdentifier nm <> parens (commas (fieldDefs <> constraintDefs')) + emit "CREATE TABLE " <> fromSqliteTableName nm <> parens (commas (fieldDefs <> constraintDefs')) normalCreateTable = createWithConstraints constraintDefs createTableNoPkConstraint = createWithConstraints noPkConstraintDefs @@ -611,8 +616,9 @@ type Sql92FromTableSourceSyntax SqliteFromSyntax = SqliteTableSourceSyntax fromTable tableSrc Nothing = SqliteFromSyntax (fromSqliteTableSource tableSrc) - fromTable tableSrc (Just nm) = - SqliteFromSyntax (fromSqliteTableSource tableSrc <> emit " AS " <> quotedIdentifier nm) + fromTable tableSrc (Just (nm, colNms)) = + SqliteFromSyntax (fromSqliteTableSource tableSrc <> emit " AS " <> quotedIdentifier nm <> + maybe mempty (\colNms' -> parens (commas (map quotedIdentifier colNms'))) colNms) innerJoin = _join "INNER JOIN" leftJoin = _join "LEFT JOIN" @@ -641,11 +647,16 @@ quotedIdentifier a instance IsSql92TableSourceSyntax SqliteTableSourceSyntax where + type Sql92TableSourceTableNameSyntax SqliteTableSourceSyntax = SqliteTableNameSyntax type Sql92TableSourceSelectSyntax SqliteTableSourceSyntax = SqliteSelectSyntax + type Sql92TableSourceExpressionSyntax SqliteTableSourceSyntax = SqliteExpressionSyntax - tableNamed = SqliteTableSourceSyntax . quotedIdentifier + tableNamed = SqliteTableSourceSyntax . fromSqliteTableName tableFromSubSelect s = SqliteTableSourceSyntax (parens (fromSqliteSelect s)) + tableFromValues vss = SqliteTableSourceSyntax . parens $ + emit "VALUES " <> + commas (map (\vs -> parens (commas (map fromSqliteExpression vs))) vss) instance IsSql92GroupingSyntax SqliteGroupingSyntax where type Sql92GroupingExpressionSyntax SqliteGroupingSyntax = SqliteExpressionSyntax @@ -660,8 +671,6 @@ ascOrdering e = SqliteOrderingSyntax (fromSqliteExpression e <> emit " ASC") descOrdering e = SqliteOrderingSyntax (fromSqliteExpression e <> emit " DESC") -instance IsSqlExpressionSyntaxStringType SqliteExpressionSyntax T.Text -instance IsSqlExpressionSyntaxStringType SqliteExpressionSyntax String instance HasSqlValueSyntax SqliteValueSyntax Int where sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) instance HasSqlValueSyntax SqliteValueSyntax Int8 where @@ -723,7 +732,7 @@ type Sql92ExpressionFieldNameSyntax SqliteExpressionSyntax = SqliteFieldNameSyntax type Sql92ExpressionQuantifierSyntax SqliteExpressionSyntax = SqliteComparisonQuantifierSyntax type Sql92ExpressionCastTargetSyntax SqliteExpressionSyntax = SqliteDataTypeSyntax - type Sql92ExpressionExtractFieldSyntax SqliteExpressionSyntax = SqliteExtractFieldSyntax + type Sql92ExpressionExtractFieldSyntax SqliteExpressionSyntax = ExtractField addE = binOp "+"; subE = binOp "-"; mulE = binOp "*"; divE = binOp "/" modE = binOp "%"; orE = binOp "OR"; andE = binOp "AND"; likeE = binOp "LIKE" @@ -771,9 +780,7 @@ upperE x = SqliteExpressionSyntax (emit "UPPER" <> parens (fromSqliteExpression x)) trimE x = SqliteExpressionSyntax (emit "TRIM" <> parens (fromSqliteExpression x)) coalesceE es = SqliteExpressionSyntax (emit "COALESCE" <> parens (commas (map fromSqliteExpression es))) - extractE field from = - SqliteExpressionSyntax $ - emit "EXTRACT" <> parens (fromSqliteExtractField field <> emit " FROM " <> parens (fromSqliteExpression from)) + extractE = sqliteExtract castE e t = SqliteExpressionSyntax (emit "CAST" <> parens (parens (fromSqliteExpression e) <> emit " AS " <> fromSqliteDataType t)) caseE cases else_ = SqliteExpressionSyntax $ @@ -792,6 +799,12 @@ SqliteExpressionSyntax $ parens $ foldl (\a b -> a <> emit " || " <> parens (fromSqliteExpression b)) (fromSqliteExpression x) xs +instance IsSql99FunctionExpressionSyntax SqliteExpressionSyntax where + functionCallE fn args = + SqliteExpressionSyntax $ + fromSqliteExpression fn <> parens (commas (fmap fromSqliteExpression args)) + functionNameE nm = SqliteExpressionSyntax (emit (TE.encodeUtf8 nm)) + binOp :: ByteString -> SqliteExpressionSyntax -> SqliteExpressionSyntax -> SqliteExpressionSyntax binOp op a b = SqliteExpressionSyntax $ @@ -835,6 +848,7 @@ setQuantifierAll = SqliteAggregationSetQuantifierSyntax (emit "ALL") instance IsSql92InsertSyntax SqliteInsertSyntax where + type Sql92InsertTableNameSyntax SqliteInsertSyntax = SqliteTableNameSyntax type Sql92InsertValuesSyntax SqliteInsertSyntax = SqliteInsertValuesSyntax insertStmt = SqliteInsertSyntax @@ -847,12 +861,13 @@ insertFromSql = SqliteInsertFromSql instance IsSql92UpdateSyntax SqliteUpdateSyntax where + type Sql92UpdateTableNameSyntax SqliteUpdateSyntax = SqliteTableNameSyntax type Sql92UpdateFieldNameSyntax SqliteUpdateSyntax = SqliteFieldNameSyntax type Sql92UpdateExpressionSyntax SqliteUpdateSyntax = SqliteExpressionSyntax updateStmt tbl fields where_ = SqliteUpdateSyntax $ - emit "UPDATE " <> quotedIdentifier tbl <> + emit "UPDATE " <> fromSqliteTableName tbl <> (case fields of [] -> mempty _ -> emit " SET " <> @@ -860,11 +875,12 @@ maybe mempty (\where_ -> emit " WHERE " <> fromSqliteExpression where_) where_ instance IsSql92DeleteSyntax SqliteDeleteSyntax where + type Sql92DeleteTableNameSyntax SqliteDeleteSyntax = SqliteTableNameSyntax type Sql92DeleteExpressionSyntax SqliteDeleteSyntax = SqliteExpressionSyntax deleteStmt tbl Nothing where_ = SqliteDeleteSyntax $ - emit "DELETE FROM " <> quotedIdentifier tbl <> + emit "DELETE FROM " <> fromSqliteTableName tbl <> maybe mempty (\where_ -> emit " WHERE " <> fromSqliteExpression where_) where_ deleteStmt _ (Just _) _ = error "beam-sqlite: invariant failed: DELETE must not have a table alias" @@ -878,40 +894,36 @@ commas [x] = x commas (x:xs) = x <> foldMap (emit ", " <>) xs +strftimeSyntax :: SqliteExpressionSyntax -> SqliteExpressionSyntax -> [ SqliteExpressionSyntax ] -> SqliteExpressionSyntax +strftimeSyntax fmt ts mods = + functionCallE (SqliteExpressionSyntax (emit "strftime")) + (fmt:ts:mods) + +-- | SQLite does not support @EXTRACT@ directly, but we can emulate +-- the behavior if we know which field we want. +sqliteExtract :: ExtractField -> SqliteExpressionSyntax -> SqliteExpressionSyntax +sqliteExtract field from = + case field of + ExtractFieldTimeZoneHour -> error "sqliteExtract: TODO ExtractFieldTimeZoneHour" + ExtractFieldTimeZoneMinute -> error "sqliteExtract: TODO ExtractFieldTimeZoneMinute" + + ExtractFieldDateTimeYear -> extractStrftime "%Y" + ExtractFieldDateTimeMonth -> extractStrftime "%m" + ExtractFieldDateTimeDay -> extractStrftime "%d" + ExtractFieldDateTimeHour -> extractStrftime "%H" + ExtractFieldDateTimeMinute -> extractStrftime "%M" + ExtractFieldDateTimeSecond -> extractStrftime "%S" + + where + extractStrftime :: String -> SqliteExpressionSyntax + extractStrftime fmt = strftimeSyntax (valueE (sqlValueSyntax fmt)) from [] + sqliteSerialType :: SqliteDataTypeSyntax sqliteSerialType = SqliteDataTypeSyntax (emit "INTEGER PRIMARY KEY AUTOINCREMENT") intType (BeamSerializedDataType (beamSerializeJSON "sqlite" "serial")) True -data SqliteHasDefault = SqliteHasDefault -instance FieldReturnType 'True 'False SqliteColumnSchemaSyntax resTy a => - FieldReturnType 'False 'False SqliteColumnSchemaSyntax resTy (SqliteHasDefault -> a) where - field' _ _ nm ty _ collation constraints SqliteHasDefault = - field' (Proxy @'True) (Proxy @'False) nm ty Nothing collation constraints - -instance IsBeamSerialColumnSchemaSyntax SqliteColumnSchemaSyntax where - genericSerial nm = field nm (DataType sqliteSerialType) SqliteHasDefault - -instance HasDefaultSqlDataType SqliteDataTypeSyntax (SqlSerial Int) where - defaultSqlDataType _ False = sqliteSerialType - defaultSqlDataType _ True = intType -instance HasDefaultSqlDataTypeConstraints SqliteColumnSchemaSyntax (SqlSerial Int) where - defaultSqlDataTypeConstraints _ _ _ = [] - -instance HasDefaultSqlDataType SqliteDataTypeSyntax ByteString where - -- TODO we should somehow allow contsraints based on backend - defaultSqlDataType _ _ = sqliteBlobType -instance HasDefaultSqlDataTypeConstraints SqliteColumnSchemaSyntax ByteString - -instance HasDefaultSqlDataType SqliteDataTypeSyntax UTCTime where - defaultSqlDataType _ _ = timestampType Nothing False -instance HasDefaultSqlDataTypeConstraints SqliteColumnSchemaSyntax UTCTime - -instance HasDefaultSqlDataType SqliteDataTypeSyntax LocalTime where - defaultSqlDataType _ _ = timestampType Nothing False -instance HasDefaultSqlDataTypeConstraints SqliteColumnSchemaSyntax LocalTime - instance HasSqlValueSyntax SqliteValueSyntax ByteString where sqlValueSyntax bs = SqliteValueSyntax (emitValue (SQLBlob bs)) @@ -927,32 +939,5 @@ sqlValueSyntax tm = SqliteValueSyntax (emitValue (SQLText (fromString tmStr))) where tmStr = formatTime defaultTimeLocale (iso8601DateFormat Nothing) tm --- * Equality checks -#define HAS_SQLITE_EQUALITY_CHECK(ty) \ - instance HasSqlEqualityCheck SqliteExpressionSyntax (ty); \ - instance HasSqlQuantifiedEqualityCheck SqliteExpressionSyntax (ty); - -HAS_SQLITE_EQUALITY_CHECK(Int) -HAS_SQLITE_EQUALITY_CHECK(Int8) -HAS_SQLITE_EQUALITY_CHECK(Int16) -HAS_SQLITE_EQUALITY_CHECK(Int32) -HAS_SQLITE_EQUALITY_CHECK(Int64) -HAS_SQLITE_EQUALITY_CHECK(Word) -HAS_SQLITE_EQUALITY_CHECK(Word8) -HAS_SQLITE_EQUALITY_CHECK(Word16) -HAS_SQLITE_EQUALITY_CHECK(Word32) -HAS_SQLITE_EQUALITY_CHECK(Word64) -HAS_SQLITE_EQUALITY_CHECK(Double) -HAS_SQLITE_EQUALITY_CHECK(Float) -HAS_SQLITE_EQUALITY_CHECK(Bool) -HAS_SQLITE_EQUALITY_CHECK(String) -HAS_SQLITE_EQUALITY_CHECK(T.Text) -HAS_SQLITE_EQUALITY_CHECK(TL.Text) -HAS_SQLITE_EQUALITY_CHECK(B.ByteString) -HAS_SQLITE_EQUALITY_CHECK(BL.ByteString) -HAS_SQLITE_EQUALITY_CHECK(UTCTime) -HAS_SQLITE_EQUALITY_CHECK(LocalTime) -HAS_SQLITE_EQUALITY_CHECK(ZonedTime) -HAS_SQLITE_EQUALITY_CHECK(Char) -HAS_SQLITE_EQUALITY_CHECK(Integer) -HAS_SQLITE_EQUALITY_CHECK(Scientific) +instance HasDataTypeCreatedCheck SqliteDataTypeSyntax where + dataTypeHasBeenCreated _ _ = True diff --git a/beam-sqlite.cabal b/beam-sqlite.cabal --- a/beam-sqlite.cabal +++ b/beam-sqlite.cabal @@ -1,6 +1,5 @@ - name: beam-sqlite -version: 0.3.2.4 +version: 0.4.0.0 synopsis: Beam driver for SQLite description: Beam driver for the embedded database. See @@ -26,8 +25,8 @@ other-modules: Database.Beam.Sqlite.SqliteSpecific build-depends: base >=4.7 && <5, - beam-core >=0.7 && <0.8, - beam-migrate >=0.3 && <0.4, + beam-core >=0.8 && <0.9, + beam-migrate >=0.4 && <0.5, sqlite-simple >=0.4 && <0.5, text >=1.0 && <1.3,