diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +# 0.3.0.0 + +* Re-introduce backend parameter to `Database` class + # 0.2.0.0 First split of sqlite backend from main beam package 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,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -15,7 +16,7 @@ import Database.Beam.Backend.SQL import qualified Database.Beam.Backend.SQL.BeamExtensions as Beam import Database.Beam.Backend.URI -import Database.Beam.Query (SqlInsert(..), SqlInsertValues(..), insert) +import Database.Beam.Query (QExpr, SqlInsert(..), SqlInsertValues(..), insert) import Database.Beam.Schema.Tables ( DatabaseEntity(..) , DatabaseEntityDescriptor(..) , TableEntity) @@ -25,15 +26,14 @@ , Query(..), SQLData(..), field , execute, execute_ , withStatement, bind, nextRow - , withTransaction, query_ - , withConnection ) + , query_, open, close ) import Database.SQLite.Simple.FromField ( FromField(..), ResultError(..) , returnError, fieldData) import Database.SQLite.Simple.Internal (RowParser(RP), unRP) import Database.SQLite.Simple.Ok (Ok(..)) import Database.SQLite.Simple.Types (Null) -import Control.Exception (bracket) +import Control.Exception (bracket_, onException, mask) import Control.Monad (forM_, replicateM_) import Control.Monad.Free.Church import Control.Monad.IO.Class (MonadIO(..)) @@ -57,6 +57,14 @@ import Network.URI +#ifdef UNIX +import System.Posix.Process (getProcessID) +#elif defined(WINDOWS) +import System.Win32.Process (getCurrentProcessId) +#else +#error Need either POSIX or Win32 API for MonadBeamInsertReturning +#endif + import Text.Read (readMaybe) -- | The SQLite backend. Used to parameterize 'MonadBeam' and 'FromBackendRow' @@ -104,9 +112,6 @@ fromBackendRow = unSqliteScientific <$> fromBackendRow instance FromBackendRow Sqlite SqliteScientific -instance FromField x => FromField (Auto x) where - fromField = fmap (Auto . Just) . fromField - newtype SqliteScientific = SqliteScientific { unSqliteScientific :: Scientific } instance FromField SqliteScientific where fromField f = @@ -166,14 +171,16 @@ unRP (next True) _ -> unRP (next False) --- | URI syntax or use with 'withDbConnection'. +-- | URI syntax for use with 'withDbConnection'. See documentation for +-- 'BeamURIOpeners' for more information. sqliteUriSyntax :: c SqliteCommandSyntax Sqlite Connection SqliteM -> BeamURIOpeners c sqliteUriSyntax = mkUriOpener "sqlite:" - (\uri action -> do - let sqliteName = if null (uriPath uri) then ":memory:" else uriPath uri - withConnection sqliteName action) + (\uri -> do + let sqliteName = if null (uriPath uri) then ":memory:" else uriPath uri + hdl <- open sqliteName + pure (hdl, close hdl)) instance MonadBeam SqliteCommandSyntax Sqlite Connection SqliteM where withDatabase = withDatabaseDebug (\_ -> pure ()) @@ -236,41 +243,65 @@ -- 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 +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 + -> SqlInsertValues SqliteInsertValuesSyntax (table (QExpr SqliteExpressionSyntax s)) -> SqliteInsertReturning table insertReturning tbl@(DatabaseEntity (DatabaseTable tblNm _)) vs = - let SqlInsert s = insert tbl vs - in SqliteInsertReturning tblNm s + case insert tbl vs of + SqlInsert s -> + SqliteInsertReturning tblNm s + SqlInsertNoRows -> + SqliteInsertReturningNoRows -- | Runs a 'SqliteInsertReturning' statement and returns a result for each --- inserted row. Unfilled 'Auto' values in the table will have been filled in in --- the output. +-- inserted row. runInsertReturningList :: FromBackendRow Sqlite (table Identity) => SqliteInsertReturning table -> SqliteM [ table Identity ] +runInsertReturningList SqliteInsertReturningNoRows = pure [] runInsertReturningList (SqliteInsertReturning nm insertStmt_) = do (logger, conn) <- SqliteM ask - SqliteM . liftIO $ - withTransaction conn $ - bracket (createInsertedValuesTable conn) (dropInsertedValuesTable conn) $ \() -> - bracket (createInsertTrigger conn) (dropInsertTrigger conn) $ \() -> do - runSqliteInsert logger conn insertStmt_ - fmap (\(BeamSqliteRow r) -> r) <$> query_ conn "SELECT * FROM inserted_values" + SqliteM . liftIO $ do - where - createInsertedValuesTable conn = - execute_ conn (Query ("CREATE TEMPORARY TABLE inserted_values AS SELECT * FROM \"" <> sqliteEscape nm <> "\" LIMIT 0")) - dropInsertedValuesTable conn () = - execute_ conn (Query "DROP TABLE inserted_values") +#ifdef UNIX + processId <- fromString . show <$> getProcessID +#elif defined(WINDOWS) + processId <- fromString . show <$> getCurrentProcessId +#else +#error Need either POSIX or Win32 API for MonadBeamInsertReturning +#endif - createInsertTrigger conn = - execute_ conn (Query ("CREATE TEMPORARY TRIGGER insert_trigger AFTER INSERT ON \"" <> sqliteEscape nm <> "\" BEGIN " <> - "INSERT INTO inserted_values SELECT * FROM \"" <> sqliteEscape nm <> "\" WHERE ROWID=last_insert_rowid(); END" )) - dropInsertTrigger conn () = - execute_ conn "DROP TRIGGER insert_trigger" + let startSavepoint = + execute_ conn (Query ("SAVEPOINT insert_savepoint_" <> processId)) + rollbackToSavepoint = + execute_ conn (Query ("ROLLBACK TRANSACTION TO SAVEPOINT insert_savepoint_" <> processId)) + releaseSavepoint = + 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")) + 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" )) + dropInsertTrigger = + execute_ conn (Query ("DROP TRIGGER insert_trigger_" <> processId)) + + + mask $ \restore -> do + startSavepoint + flip onException rollbackToSavepoint . restore $ do + x <- bracket_ createInsertedValuesTable dropInsertedValuesTable $ + bracket_ createInsertTrigger dropInsertTrigger $ do + runSqliteInsert logger conn insertStmt_ + fmap (\(BeamSqliteRow r) -> r) <$> query_ conn (Query ("SELECT * FROM inserted_values_" <> processId)) + releaseSavepoint + return x 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 @@ -29,8 +29,7 @@ import Control.Monad.Reader import Database.SQLite.Simple - ( Connection, Only(..) - , open, close, query_ ) + ( Connection, open, close, query_ ) import Data.Aeson import Data.Attoparsec.Text (asciiCI, skipSpace) @@ -40,7 +39,7 @@ import Data.Char (isSpace) import Data.Int (Int64) import Data.List (sortBy) -import Data.Maybe (mapMaybe) +import Data.Maybe (mapMaybe, isJust) import Data.Monoid (Endo(..), (<>)) import Data.Ord (comparing) import Data.String (fromString) @@ -49,7 +48,7 @@ -- | Top-level 'Tool.BeamMigrationBackend' loaded dynamically by the -- @beam-migrate@ CLI tool. -migrationBackend :: Tool.BeamMigrationBackend Sqlite SqliteCommandSyntax Connection +migrationBackend :: Tool.BeamMigrationBackend SqliteCommandSyntax Sqlite Connection SqliteM migrationBackend = Tool.BeamMigrationBackend "sqlite" "For beam-sqlite, this is the path to a sqlite3 file" @@ -131,6 +130,7 @@ (Db.BeamSerializedDataType $ Db.beamSerializeJSON "sqlite" (toJSON txt)) + False Right x -> x where dtParser = charP <|> varcharP <|> @@ -139,7 +139,7 @@ doubleP <|> integerP <|> smallIntP <|> bigIntP <|> floatP <|> doubleP <|> realP <|> dateP <|> - timeP <|> timestampP <|> textP <|> + timestampP <|> timeP <|> textP <|> blobP <|> booleanP ws = A.many1 A.space @@ -184,10 +184,10 @@ intTypeP pure intType smallIntP = do - asciiCI "INT2" <|> (asciiCI "SMALL" >> ws >> intTypeP) + asciiCI "INT2" <|> (asciiCI "SMALL" >> optional ws >> intTypeP) pure smallIntType bigIntP = do - asciiCI "INT8" <|> (asciiCI "BIG" >> ws >> intTypeP) + asciiCI "INT8" <|> (asciiCI "BIG" >> optional ws >> intTypeP) pure sqliteBigIntType dateP = dateType <$ asciiCI "DATE" timeP = do @@ -236,17 +236,32 @@ getDbConstraints :: SqliteM [Db.SomeDatabasePredicate] getDbConstraints = SqliteM . ReaderT $ \(_, conn) -> do - tblNames <- query_ conn "SELECT name from sqlite_master where type='table'" + tblNames <- query_ conn "SELECT name, sql from sqlite_master where type='table'" tblPreds <- - fmap mconcat . forM tblNames $ \(Only tblName) -> do + fmap mconcat . forM tblNames $ \(tblName, sql) -> do columns <- fmap (sortBy (comparing (\(cid, _, _, _, _, _) -> cid :: Int))) $ query_ conn (fromString ("PRAGMA table_info('" <> T.unpack tblName <> "')")) let columnPreds = foldMap (\(_ ::Int, nm, typStr, notNull, _, _) -> - let dtType = parseSqliteDataType typStr + let dtType = if isAutoincrement then sqliteSerialType else parseSqliteDataType typStr + isAutoincrement = isJust (A.maybeResult (A.parse autoincrementParser sql)) + autoincrementParser = do + A.manyTill A.anyChar $ do + hadQuote <- optional (A.char '"') + A.string nm + maybe (pure ()) (\_ -> void $ A.char '"') hadQuote + A.many1 A.space + asciiCI "INTEGER" + A.many1 A.space + asciiCI "PRIMARY" + A.many1 A.space + asciiCI "KEY" + A.many1 A.space + asciiCI "AUTOINCREMENT" + notNullPred = if notNull then [ Db.SomeDatabasePredicate @@ -254,6 +269,7 @@ (Db.constraintDefinitionSyntax Nothing Db.notNullConstraintSyntax Nothing) :: Db.TableColumnHasConstraint SqliteColumnSchemaSyntax) ] else [] + in [ Db.SomeDatabasePredicate (Db.TableHasColumn tblName nm dtType :: Db.TableHasColumn SqliteColumnSchemaSyntax) ] ++ 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,8 +1,10 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-name-shadowing#-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE CPP #-} -- | SQLite implementations of the Beam SQL syntax classes -- @@ -23,7 +25,7 @@ -- * SQLite data type syntax , SqliteDataTypeSyntax(..) , sqliteTextType, sqliteBlobType - , sqliteBigIntType + , sqliteBigIntType, sqliteSerialType -- * Building and consuming 'SqliteSyntax' , fromSqliteCommand, formatSqliteInsert @@ -36,28 +38,31 @@ import Database.Beam.Backend.SQL import Database.Beam.Haskell.Syntax -import Database.Beam.Migrate.Checks import Database.Beam.Migrate.Generics 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.Migrate.Types import Database.Beam.Query import Database.Beam.Query.SQL92 import Data.ByteString (ByteString) +import qualified Data.ByteString as B import Data.ByteString.Builder import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.ByteString as B import Data.Coerce import qualified Data.DList as DL import Data.Hashable import Data.Int import Data.Maybe import Data.Monoid +import Data.Proxy (Proxy(..)) +import Data.Scientific import Data.String import qualified Data.Text as T import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL import Data.Time import Data.Word @@ -220,9 +225,12 @@ -- | SQLite syntax for column schemas in @CREATE TABLE@ or @ALTER COLUMN ... ADD -- COLUMN@ statements -newtype SqliteColumnSchemaSyntax - = SqliteColumnSchemaSyntax { fromSqliteColumnSchema :: SqliteSyntax } - deriving (Show, Eq, Hashable) +data SqliteColumnSchemaSyntax + = SqliteColumnSchemaSyntax + { fromSqliteColumnSchema :: SqliteSyntax + , sqliteIsSerialColumn :: Bool } + deriving (Show, Eq, Generic) +instance Hashable SqliteColumnSchemaSyntax instance Sql92DisplaySyntax SqliteColumnSchemaSyntax where displaySyntax = displaySyntax . fromSqliteColumnSchema @@ -234,9 +242,10 @@ { fromSqliteDataType :: SqliteSyntax , sqliteDataTypeToHs :: HsDataType , sqliteDataTypeSerialized :: BeamSerializedDataType + , sqliteDataTypeSerial :: Bool } deriving (Show, Eq, Generic) instance Hashable SqliteDataTypeSyntax where - hashWithSalt salt (SqliteDataTypeSyntax s _ _) = hashWithSalt salt s + hashWithSalt salt (SqliteDataTypeSyntax s _ _ _) = hashWithSalt salt s instance Sql92DisplaySyntax SqliteDataTypeSyntax where displaySyntax = displaySyntax . fromSqliteDataType @@ -254,7 +263,10 @@ = SqliteColumnConstraintSyntax { fromSqliteColumnConstraint :: SqlConstraintAttributesBuilder -> SqliteSyntax , sqliteColumnConstraintSerialized :: BeamSerializedConstraint } -newtype SqliteTableConstraintSyntax = SqliteTableConstraintSyntax { fromSqliteTableConstraint :: SqliteSyntax } +data SqliteTableConstraintSyntax + = SqliteTableConstraintSyntax + { fromSqliteTableConstraint :: SqliteSyntax + , sqliteTableConstraintPrimaryKey :: Maybe [ T.Text ] } data SqliteMatchTypeSyntax = SqliteMatchTypeSyntax { fromSqliteMatchType :: SqliteSyntax @@ -315,7 +327,7 @@ SqliteAlterTableSyntax $ case fromSqliteAlterTableAction action of Just alterTable -> - emit "ALTER TABLE " <> quotedIdentifier nm <> alterTable + emit "ALTER TABLE " <> quotedIdentifier nm <> emit " " <> alterTable Nothing -> emit "SELECT 1" @@ -353,11 +365,12 @@ type Sql92ColumnSchemaColumnConstraintDefinitionSyntax SqliteColumnSchemaSyntax = SqliteColumnConstraintDefinitionSyntax columnSchemaSyntax ty defVal constraints collation = - SqliteColumnSchemaSyntax $ - fromSqliteDataType ty <> - maybe mempty (\defVal -> emit " DEFAULT " <> parens (fromSqliteExpression defVal)) defVal <> - foldMap (\constraint -> emit " " <> fromSqliteColumnConstraintDefinition constraint <> emit " ") constraints <> - maybe mempty (\c -> emit " COLLATE " <> quotedIdentifier c) collation + SqliteColumnSchemaSyntax + (fromSqliteDataType ty <> + maybe mempty (\defVal -> emit " DEFAULT " <> parens (fromSqliteExpression defVal)) defVal <> + foldMap (\constraint -> emit " " <> fromSqliteColumnConstraintDefinition constraint <> emit " ") constraints <> + maybe mempty (\c -> emit " COLLATE " <> quotedIdentifier c) collation) + (if sqliteDataTypeSerial ty then True else False) instance IsSql92ColumnConstraintDefinitionSyntax SqliteColumnConstraintDefinitionSyntax where type Sql92ColumnConstraintDefinitionConstraintSyntax SqliteColumnConstraintDefinitionSyntax = SqliteColumnConstraintSyntax @@ -418,8 +431,9 @@ instance IsSql92TableConstraintSyntax SqliteTableConstraintSyntax where primaryKeyConstraintSyntax fields = - SqliteTableConstraintSyntax $ - emit "PRIMARY KEY" <> parens (commas (map quotedIdentifier fields)) + SqliteTableConstraintSyntax + (emit "PRIMARY KEY" <> parens (commas (map quotedIdentifier fields))) + (Just fields) instance IsSql92CreateTableSyntax SqliteCreateTableSyntax where type Sql92CreateTableColumnSchemaSyntax SqliteCreateTableSyntax = SqliteColumnSchemaSyntax @@ -429,50 +443,72 @@ createTableSyntax _ nm fields constraints = let fieldDefs = map mkFieldDef fields constraintDefs = map fromSqliteTableConstraint constraints + noPkConstraintDefs = map fromSqliteTableConstraint (filter (isNothing . sqliteTableConstraintPrimaryKey) constraints) + constraintPks = mapMaybe sqliteTableConstraintPrimaryKey constraints + fieldPrimaryKey = map fst (filter (sqliteIsSerialColumn . snd) fields) + mkFieldDef (fieldNm, fieldTy) = - quotedIdentifier fieldNm <> emit " " <> fromSqliteColumnSchema fieldTy + quotedIdentifier fieldNm <> emit " " <> + fromSqliteColumnSchema fieldTy - in SqliteCreateTableSyntax $ - emit "CREATE TABLE " <> quotedIdentifier nm <> parens (commas (fieldDefs <> constraintDefs)) + createWithConstraints constraintDefs' = + SqliteCreateTableSyntax $ + emit "CREATE TABLE " <> quotedIdentifier nm <> parens (commas (fieldDefs <> constraintDefs')) + normalCreateTable = createWithConstraints constraintDefs + createTableNoPkConstraint = createWithConstraints noPkConstraintDefs + in case fieldPrimaryKey of + [] -> normalCreateTable + [field] -> + case constraintPks of + [] -> error "A column claims to have a primary key, but there is no key on this table" + [[fieldPk]] + | field /= fieldPk -> error "Two columns claim to be a primary key on this table" + | otherwise -> createTableNoPkConstraint + _ -> error "There are multiple primary key constraints on this table" + _ -> error "More than one column claims to be a primary key on this table" + instance IsSql92DataTypeSyntax SqliteDataTypeSyntax where - domainType nm = SqliteDataTypeSyntax (quotedIdentifier nm) (domainType nm) (domainType nm) + domainType nm = SqliteDataTypeSyntax (quotedIdentifier nm) (domainType nm) (domainType nm) False charType prec charSet = SqliteDataTypeSyntax (emit "CHAR" <> sqliteOptPrec prec <> sqliteOptCharSet charSet) (charType prec charSet) (charType prec charSet) + False varCharType prec charSet = SqliteDataTypeSyntax (emit "VARCHAR" <> sqliteOptPrec prec <> sqliteOptCharSet charSet) (varCharType prec charSet) (varCharType prec charSet) + False nationalCharType prec = SqliteDataTypeSyntax (emit "NATIONAL CHAR" <> sqliteOptPrec prec) (nationalCharType prec) (nationalCharType prec) + False nationalVarCharType prec = SqliteDataTypeSyntax (emit "NATIONAL CHARACTER VARYING" <> sqliteOptPrec prec) (nationalVarCharType prec) (nationalVarCharType prec) - - bitType prec = SqliteDataTypeSyntax (emit "BIT" <> sqliteOptPrec prec) (bitType prec) (bitType prec) - varBitType prec = SqliteDataTypeSyntax (emit "BIT VARYING" <> sqliteOptPrec prec) (varBitType prec) (varBitType prec) + False + bitType prec = SqliteDataTypeSyntax (emit "BIT" <> sqliteOptPrec prec) (bitType prec) (bitType prec) False + varBitType prec = SqliteDataTypeSyntax (emit "BIT VARYING" <> sqliteOptPrec prec) (varBitType prec) (varBitType prec) False - numericType prec = SqliteDataTypeSyntax (emit "NUMERIC" <> sqliteOptNumericPrec prec) (numericType prec) (numericType prec) - decimalType prec = SqliteDataTypeSyntax (emit "DOUBLE" <> sqliteOptNumericPrec prec) (decimalType prec) (decimalType prec) + numericType prec = SqliteDataTypeSyntax (emit "NUMERIC" <> sqliteOptNumericPrec prec) (numericType prec) (numericType prec) False + decimalType prec = SqliteDataTypeSyntax (emit "DOUBLE" <> sqliteOptNumericPrec prec) (decimalType prec) (decimalType prec) False - intType = SqliteDataTypeSyntax (emit "INTEGER") intType intType - smallIntType = SqliteDataTypeSyntax (emit "SMALLINT") smallIntType smallIntType + intType = SqliteDataTypeSyntax (emit "INTEGER") intType intType False + smallIntType = SqliteDataTypeSyntax (emit "SMALLINT") smallIntType smallIntType False - floatType prec = SqliteDataTypeSyntax (emit "FLOAT" <> sqliteOptPrec prec) (floatType prec) (floatType prec) - doubleType = SqliteDataTypeSyntax (emit "DOUBLE PRECISION") doubleType doubleType - realType = SqliteDataTypeSyntax (emit "REAL") realType realType - dateType = SqliteDataTypeSyntax (emit "DATE") dateType dateType + floatType prec = SqliteDataTypeSyntax (emit "FLOAT" <> sqliteOptPrec prec) (floatType prec) (floatType prec) False + doubleType = SqliteDataTypeSyntax (emit "DOUBLE PRECISION") doubleType doubleType False + realType = SqliteDataTypeSyntax (emit "REAL") realType realType False + dateType = SqliteDataTypeSyntax (emit "DATE") dateType dateType False timeType prec withTz = SqliteDataTypeSyntax (emit "TIME" <> sqliteOptPrec prec <> if withTz then emit " WITH TIME ZONE" else mempty) - (timeType prec withTz) (timeType prec withTz) + (timeType prec withTz) (timeType prec withTz) False timestampType prec withTz = SqliteDataTypeSyntax (emit "TIMESTAMP" <> sqliteOptPrec prec <> if withTz then emit " WITH TIME ZONE" else mempty) - (timestampType prec withTz) (timestampType prec withTz) + (timestampType prec withTz) (timestampType prec withTz) False instance IsSql99DataTypeSyntax SqliteDataTypeSyntax where characterLargeObjectType = sqliteTextType binaryLargeObjectType = sqliteBlobType - booleanType = SqliteDataTypeSyntax (emit "BOOLEAN") booleanType booleanType + booleanType = SqliteDataTypeSyntax (emit "BOOLEAN") booleanType booleanType False arrayType _ _ = error "SQLite does not support arrayType" rowType _ = error "SQLite does not support rowType" @@ -486,18 +522,21 @@ (importSome "Data.Text" [importTyNamed "Text"])) characterLargeObjectType) characterLargeObjectType + False sqliteBlobType = SqliteDataTypeSyntax (emit "BLOB") (HsDataType (hsVarFrom "sqliteBlob" "Database.Beam.Sqlite") (HsType (tyConNamed "ByteString") (importSome "Data.ByteString" [importTyNamed "ByteString"])) binaryLargeObjectType) - binaryLargeObjectType + binaryLargeObjectType + False sqliteBigIntType = SqliteDataTypeSyntax (emit "BIGINT") - (HsDataType (hsVarFrom "sqliteBigInt" "Database.Beam.Sqlite") - (HsType (tyConNamed "Int64") - (importSome "Data.Int" [importTyNamed "Int64"])) - bigIntType) - bigIntType + (HsDataType (hsVarFrom "sqliteBigInt" "Database.Beam.Sqlite") + (HsType (tyConNamed "Int64") + (importSome "Data.Int" [importTyNamed "Int64"])) + bigIntType) + bigIntType + False instance Sql92SerializableDataTypeSyntax SqliteDataTypeSyntax where serializeDataType = fromBeamSerializedDataType . sqliteDataTypeSerialized @@ -627,12 +666,16 @@ sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) instance HasSqlValueSyntax SqliteValueSyntax Word where sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) +instance HasSqlValueSyntax SqliteValueSyntax Word8 where + sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) instance HasSqlValueSyntax SqliteValueSyntax Word16 where sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) instance HasSqlValueSyntax SqliteValueSyntax Word32 where sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) instance HasSqlValueSyntax SqliteValueSyntax Word64 where sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) +instance HasSqlValueSyntax SqliteValueSyntax Scientific where + sqlValueSyntax s = SqliteValueSyntax (emitValue (SQLText (fromString (show s)))) -- Rely on sqlites duck typing instance HasSqlValueSyntax SqliteValueSyntax Float where sqlValueSyntax f = SqliteValueSyntax (emitValue (SQLFloat (float2Double f))) instance HasSqlValueSyntax SqliteValueSyntax Double where @@ -645,12 +688,12 @@ sqlValueSyntax s = SqliteValueSyntax (emitValue (SQLText (fromString s))) instance HasSqlValueSyntax SqliteValueSyntax T.Text where sqlValueSyntax s = SqliteValueSyntax (emitValue (SQLText s)) +instance HasSqlValueSyntax SqliteValueSyntax TL.Text where + sqlValueSyntax s = SqliteValueSyntax (emitValue (SQLText (TL.toStrict s))) instance HasSqlValueSyntax SqliteValueSyntax x => HasSqlValueSyntax SqliteValueSyntax (Maybe x) where sqlValueSyntax (Just x) = sqlValueSyntax x sqlValueSyntax Nothing = sqlValueSyntax SqlNull -instance HasSqlValueSyntax SqliteValueSyntax (Maybe x) => HasSqlValueSyntax SqliteValueSyntax (Auto x) where - sqlValueSyntax (Auto x) = sqlValueSyntax x instance IsCustomSqlSyntax SqliteExpressionSyntax where newtype CustomSqlSyntax SqliteExpressionSyntax = @@ -684,10 +727,12 @@ negateE = unOp "-"; notE = unOp "NOT" isNotNullE = postFix "IS NOT NULL"; isNullE = postFix "IS NULL" - isTrueE = postFix "IS TRUE"; isNotTrueE = postFix "IS NOT TRUE" - isFalseE = postFix "IS FALSE"; isNotFalseE = postFix "IS NOT FALSE" - isUnknownE = postFix "IS UNKNOWN"; isNotUnknownE = postFix "IS NOT UNKNOWN" + -- SQLite doesn't handle tri-state booleans properly + isTrueE = postFix "IS 1"; isNotTrueE = postFix "IS NOT 1" + isFalseE = postFix "IS 0"; isNotFalseE = postFix "IS NOT 0" + isUnknownE = postFix "IS NULL"; isNotUnknownE = postFix "IS NOT NULL" + existsE select = SqliteExpressionSyntax (emit "EXISTS " <> parens (fromSqliteSelect select)) uniqueE select = SqliteExpressionSyntax (emit "UNIQUE " <> parens (fromSqliteSelect select)) @@ -714,6 +759,9 @@ bitLengthE x = SqliteExpressionSyntax (emit "BIT_LENGTH" <> parens (fromSqliteExpression x)) charLengthE x = SqliteExpressionSyntax (emit "CHAR_LENGTH" <> parens (fromSqliteExpression x)) octetLengthE x = SqliteExpressionSyntax (emit "OCTET_LENGTH" <> parens (fromSqliteExpression x)) + lowerE x = SqliteExpressionSyntax (emit "LOWER" <> parens (fromSqliteExpression x)) + 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 $ @@ -734,7 +782,7 @@ concatE [] = valueE (sqlValueSyntax ("" :: T.Text)) concatE (x:xs) = SqliteExpressionSyntax $ parens $ - foldr (\a b -> parens (fromSqliteExpression a) <> emit " || " <> parens b) (fromSqliteExpression x) xs + foldl (\a b -> a <> emit " || " <> parens (fromSqliteExpression b)) (fromSqliteExpression x) xs binOp :: ByteString -> SqliteExpressionSyntax -> SqliteExpressionSyntax -> SqliteExpressionSyntax binOp op a b = @@ -748,8 +796,8 @@ SqliteExpressionSyntax $ parens (fromSqliteExpression a) <> emit op <> - parens (maybe mempty (\q -> emit " " <> fromSqliteComparisonQuantifier q <> emit " ") quantifier <> - fromSqliteExpression b) + maybe mempty (\q -> emit " " <> fromSqliteComparisonQuantifier q <> emit " ") quantifier <> + parens (fromSqliteExpression b) unOp, postFix :: ByteString -> SqliteExpressionSyntax -> SqliteExpressionSyntax unOp op a = @@ -812,7 +860,7 @@ maybe mempty (\where_ -> emit " WHERE " <> fromSqliteExpression where_) where_ spaces, parens :: SqliteSyntax -> SqliteSyntax -spaces a = emit " " <> a <> emit " " +spaces a = emit " " <> a <> emit " " parens a = emit "(" <> a <> emit ")" commas :: [SqliteSyntax] -> SqliteSyntax @@ -820,12 +868,25 @@ commas [x] = x commas (x:xs) = x <> foldMap (emit ", " <>) xs +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 _ _ = intType + defaultSqlDataType _ False = sqliteSerialType + defaultSqlDataType _ True = intType instance HasDefaultSqlDataTypeConstraints SqliteColumnSchemaSyntax (SqlSerial Int) where - defaultSqlDataTypeConstraints _ _ False = [ FieldCheck $ \tblNm colNm -> p (TableColumnHasConstraint tblNm colNm c :: TableColumnHasConstraint SqliteColumnSchemaSyntax) ] - where c = constraintDefinitionSyntax Nothing (SqliteColumnConstraintSyntax (\_ -> emit "DEFAULT ROWID") - (BeamSerializedConstraint (beamSerializeJSON "sqlite" "serial"))) Nothing defaultSqlDataTypeConstraints _ _ _ = [] instance HasDefaultSqlDataType SqliteDataTypeSyntax ByteString where @@ -847,3 +908,33 @@ instance HasSqlValueSyntax SqliteValueSyntax Day where 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) diff --git a/beam-sqlite.cabal b/beam-sqlite.cabal --- a/beam-sqlite.cabal +++ b/beam-sqlite.cabal @@ -1,11 +1,12 @@ + name: beam-sqlite -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Beam driver for SQLite description: Beam driver for the embedded database. See for more information homepage: http://tathougies.github.io/beam/user-guide/backends/beam-sqlite/ -license: BSD3 +license: MIT license-file: LICENSE author: Travis Athougies maintainer: travis@athougies.net @@ -14,7 +15,8 @@ build-type: Simple extra-source-files: README.md extra-doc-files: ChangeLog.md -cabal-version: >=1.18 +bug-reports: https://github.com/tathougies/beam/issues +cabal-version: 1.18 library exposed-modules: Database.Beam.Sqlite @@ -23,8 +25,8 @@ Database.Beam.Sqlite.Migrate build-depends: base >=4.7 && <5, - beam-core >=0.6 && <0.7, - beam-migrate >=0.2 && <0.3, + beam-core >=0.7 && <0.8, + beam-migrate >=0.3 && <0.4, sqlite-simple >=0.4 && <0.5, text >=1.0 && <1.3, @@ -33,7 +35,7 @@ time >=1.6 && <1.10, dlist >=0.8 && <0.9, mtl >=2.1 && <2.3, - free >=4.12 && <4.13, + free >=4.12 && <5.1, scientific >=0.3 && <0.4, network-uri >=2.6 && <2.7, aeson >=0.11 && <1.3, @@ -45,6 +47,13 @@ ghc-options: -Wall if flag(werror) ghc-options: -Werror + + if os(windows) + cpp-options: -DWINDOWS + build-depends: Win32 >=2.4 && <2.8 + if os(freebsd) || os(netbsd) || os(darwin) || os(linux) || os(solaris) + cpp-options: -DUNIX + build-depends: unix >=2.0 && <2.8 flag werror description: Enable -Werror during development