diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,24 @@ +# 0.5.0.0 + +======= +## Interface changes + + * Removed instances for machine-dependent ambiguous integer types `Int` and `Word` + +## Added features + + * Support for `in_` on row values + * Upsert support using `HasInsertOnConflict` + * Fix build on Android and OpenBSD + +## Bug fixes + + * Fix emitting and detection of `DECIMAL` and `DOUBLE PRECISION` types + * Fix `bitLength`, `charLength_`, and `octectLength_` by emulating with `CAST` and `LENGTH` + * Fix `runInsertReturningList` for when the database column order and beam column order disagree. + +# 0.4.0.0 + # 0.3.2.0 Add `Semigroup` instances to prepare for GHC 8.4 and Stackage nightly 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 @@ -2,6 +2,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -15,22 +16,32 @@ , insertReturning, runInsertReturningList ) where +import Prelude hiding (fail) + import Database.Beam.Backend +import Database.Beam.Backend.Internal.Compat import qualified Database.Beam.Backend.SQL.BeamExtensions as Beam import Database.Beam.Backend.URI 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(..) +import Database.Beam.Query ( SqlInsert(..), SqlInsertValues(..) , HasQBuilder(..), HasSqlEqualityCheck , HasSqlQuantifiedEqualityCheck , DataType(..) - , insert ) + , HasSqlInTable(..) + , insert, current_ ) +import Database.Beam.Query.Internal import Database.Beam.Query.SQL92 import Database.Beam.Schema.Tables ( Beamable + , Columnar'(..) , DatabaseEntity(..) - , TableEntity) + , DatabaseEntityDescriptor(..) + , TableEntity + , TableField(..) + , allBeamValues + , changeBeamRep ) import Database.Beam.Sqlite.Syntax import Database.SQLite.Simple ( Connection, ToRow(..), FromRow(..) @@ -46,13 +57,14 @@ import Control.Exception (SomeException(..), bracket_, onException, mask) import Control.Monad (forM_) -import Control.Monad.Fail (MonadFail) +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(..), StateT(..), runStateT) import Control.Monad.Trans (lift) +import Control.Monad.Writer (tell, execWriter) import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Char8 as BS @@ -66,13 +78,12 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T (decodeUtf8) import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL (decodeUtf8) import Data.Time ( LocalTime, UTCTime, Day , ZonedTime, utc, utcToLocalTime ) import Data.Typeable (cast) import Data.Word -#if !MIN_VERSION_base(4,11,0) -import Data.Semigroup -#endif +import GHC.TypeLits import Network.URI @@ -88,7 +99,7 @@ -- | The SQLite backend. Used to parameterize 'MonadBeam' and 'FromBackendRow' -- to provide support for SQLite databases. See the documentation for --- 'MonadBeam' and the for more +-- 'MonadBeam' and the for more -- information on how to use this backend. data Sqlite = Sqlite @@ -98,19 +109,24 @@ instance HasQBuilder Sqlite where buildSqlQuery = buildSql92Query' False -- SQLite does not support arbitrarily nesting UNION, INTERSECT, and EXCEPT +instance HasSqlInTable Sqlite where + inRowValuesE Proxy e es = SqliteExpressionSyntax $ mconcat + [ parens $ fromSqliteExpression e + , emit " IN " + , parens $ emit "VALUES " <> commas (map fromSqliteExpression es) + ] + instance BeamSqlBackendIsString Sqlite T.Text instance BeamSqlBackendIsString Sqlite String instance FromBackendRow Sqlite Bool instance FromBackendRow Sqlite Double instance FromBackendRow Sqlite Float -instance FromBackendRow Sqlite Int instance FromBackendRow Sqlite Int8 instance FromBackendRow Sqlite Int16 instance FromBackendRow Sqlite Int32 instance FromBackendRow Sqlite Int64 instance FromBackendRow Sqlite Integer -instance FromBackendRow Sqlite Word instance FromBackendRow Sqlite Word8 instance FromBackendRow Sqlite Word16 instance FromBackendRow Sqlite Word32 @@ -137,6 +153,9 @@ fromBackendRow = unSqliteScientific <$> fromBackendRow instance FromBackendRow Sqlite SqliteScientific +instance TypeError (PreferExplicitSize Int Int32) => FromBackendRow Sqlite Int +instance TypeError (PreferExplicitSize Word Word32) => FromBackendRow Sqlite Word + newtype SqliteScientific = SqliteScientific { unSqliteScientific :: Scientific } instance FromField SqliteScientific where fromField f = @@ -168,7 +187,7 @@ genericSerial nm = Beam.field nm (DataType sqliteSerialType) SqliteHasDefault -- | 'MonadBeam' instance inside whiche SQLite queries are run. See the --- for more information +-- for more information newtype SqliteM a = SqliteM { runSqliteM :: ReaderT (String -> IO (), Connection) IO a @@ -234,12 +253,10 @@ 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) @@ -259,7 +276,17 @@ HAS_SQLITE_EQUALITY_CHECK(Integer) HAS_SQLITE_EQUALITY_CHECK(Scientific) -instance HasDefaultSqlDataType Sqlite (SqlSerial Int) where +instance TypeError (PreferExplicitSize Int Int32) => HasSqlEqualityCheck Sqlite Int +instance TypeError (PreferExplicitSize Int Int32) => HasSqlQuantifiedEqualityCheck Sqlite Int +instance TypeError (PreferExplicitSize Word Word32) => HasSqlEqualityCheck Sqlite Word +instance TypeError (PreferExplicitSize Word Word32) => HasSqlQuantifiedEqualityCheck Sqlite Word + +class HasDefaultSqlDataType Sqlite a => IsSqliteSerialIntegerType a +instance IsSqliteSerialIntegerType Int32 +instance IsSqliteSerialIntegerType Int64 +instance TypeError (PreferExplicitSize Int Int32) => IsSqliteSerialIntegerType Int + +instance IsSqliteSerialIntegerType a => HasDefaultSqlDataType Sqlite (SqlSerial a) where defaultSqlDataType _ _ False = sqliteSerialType defaultSqlDataType _ _ True = intType @@ -322,18 +349,18 @@ runInsertReturningList = runInsertReturningList runSqliteInsert :: (String -> IO ()) -> Connection -> SqliteInsertSyntax -> IO () -runSqliteInsert logger conn (SqliteInsertSyntax tbl fields vs) +runSqliteInsert logger conn (SqliteInsertSyntax tbl fields vs onConflict) -- If all expressions are simple expressions (no default), then just | SqliteInsertExpressions es <- vs, any (any (== SqliteExpressionDefault)) es = forM_ es $ \row -> do let (fields', row') = unzip $ filter ((/= SqliteExpressionDefault) . snd) $ zip fields row - SqliteSyntax cmd vals = formatSqliteInsert tbl fields' (SqliteInsertExpressions [ row' ]) + SqliteSyntax cmd vals = formatSqliteInsertOnConflict tbl fields' (SqliteInsertExpressions [ row' ]) onConflict cmdString = BL.unpack (toLazyByteString (withPlaceholders cmd)) logger (cmdString ++ ";\n-- With values: " ++ show (D.toList vals)) execute conn (fromString cmdString) (D.toList vals) | otherwise = do - let SqliteSyntax cmd vals = formatSqliteInsert tbl fields vs + let SqliteSyntax cmd vals = formatSqliteInsertOnConflict tbl fields vs onConflict cmdString = BL.unpack (toLazyByteString (withPlaceholders cmd)) logger (cmdString ++ ";\n-- With values: " ++ show (D.toList vals)) execute conn (fromString cmdString) (D.toList vals) @@ -350,11 +377,11 @@ -- | Runs a 'SqliteInsertReturning' statement and returns a result for each -- inserted row. -runInsertReturningList :: FromBackendRow Sqlite (table Identity) +runInsertReturningList :: (Beamable table, FromBackendRow Sqlite (table Identity)) => SqlInsert Sqlite table -> SqliteM [ table Identity ] runInsertReturningList SqlInsertNoRows = pure [] -runInsertReturningList (SqlInsert _ insertStmt_@(SqliteInsertSyntax nm _ _)) = +runInsertReturningList (SqlInsert tblSettings insertStmt_@(SqliteInsertSyntax nm _ _ _)) = do (logger, conn) <- SqliteM ask SqliteM . liftIO $ do @@ -393,6 +420,92 @@ x <- bracket_ createInsertedValuesTable dropInsertedValuesTable $ bracket_ createInsertTrigger dropInsertTrigger $ do runSqliteInsert logger conn insertStmt_ - fmap (\(BeamSqliteRow r) -> r) <$> query_ conn (Query ("SELECT * FROM inserted_values_" <> processId)) + + let columns = TL.toStrict $ TL.decodeUtf8 $ + sqliteRenderSyntaxScript $ commas $ + allBeamValues (\(Columnar' projField) -> quotedIdentifier (_fieldName projField)) $ + tblSettings + + fmap (\(BeamSqliteRow r) -> r) <$> query_ conn (Query ("SELECT " <> columns <> " FROM inserted_values_" <> processId)) releaseSavepoint return x + +instance Beam.BeamHasInsertOnConflict Sqlite where + newtype SqlConflictTarget Sqlite table = SqliteConflictTarget + { unSqliteConflictTarget :: table (QExpr Sqlite QInternal) -> SqliteSyntax } + newtype SqlConflictAction Sqlite table = SqliteConflictAction + { unSqliteConflictAction :: forall s. table (QField s) -> SqliteSyntax } + + insertOnConflict + :: forall db table s. Beamable table + => DatabaseEntity Sqlite db (TableEntity table) + -> SqlInsertValues Sqlite (table (QExpr Sqlite s)) + -> Beam.SqlConflictTarget Sqlite table + -> Beam.SqlConflictAction Sqlite table + -> SqlInsert Sqlite table + insertOnConflict (DatabaseEntity dt) values target action = case values of + SqlInsertValuesEmpty -> SqlInsertNoRows + SqlInsertValues vs -> SqlInsert (dbTableSettings dt) $ + let getFieldName + :: forall a + . Columnar' (TableField table) a + -> Columnar' (QField QInternal) a + getFieldName (Columnar' fd) = + Columnar' $ QField False (dbTableCurrentName dt) $ _fieldName fd + tableFields = changeBeamRep getFieldName $ dbTableSettings dt + tellFieldName _ _ f = tell [f] >> pure f + fieldNames = execWriter $ + project' (Proxy @AnyType) (Proxy @((), T.Text)) tellFieldName tableFields + currentField + :: forall a + . Columnar' (QField QInternal) a + -> Columnar' (QExpr Sqlite QInternal) a + currentField (Columnar' f) = Columnar' $ current_ f + tableCurrent = changeBeamRep currentField tableFields + in SqliteInsertSyntax (tableNameFromEntity dt) fieldNames vs $ Just $ + SqliteOnConflictSyntax $ mconcat + [ emit "ON CONFLICT " + , unSqliteConflictTarget target tableCurrent + , emit " DO " + , unSqliteConflictAction action tableFields + ] + + anyConflict = SqliteConflictTarget $ const mempty + conflictingFields makeProjection = SqliteConflictTarget $ \table -> + parens $ commas $ map fromSqliteExpression $ + project (Proxy @Sqlite) (makeProjection table) "t" + conflictingFieldsWhere makeProjection makeWhere = + SqliteConflictTarget $ \table -> mconcat + [ unSqliteConflictTarget (Beam.conflictingFields makeProjection) table + , emit " WHERE " + , let QExpr mkE = makeWhere table + in fromSqliteExpression $ mkE "t" + ] + + onConflictDoNothing = SqliteConflictAction $ const $ emit "NOTHING" + onConflictUpdateSet makeAssignments = SqliteConflictAction $ \table -> mconcat + [ emit "UPDATE SET " + , let QAssignment assignments = makeAssignments table $ excluded table + emitAssignment (fieldName, expr) = mconcat + [ fromSqliteFieldNameSyntax fieldName + , emit " = " + , fromSqliteExpression expr + ] + in commas $ map emitAssignment assignments + ] + onConflictUpdateSetWhere makeAssignments makeWhere = + SqliteConflictAction $ \table -> mconcat + [ unSqliteConflictAction (Beam.onConflictUpdateSet makeAssignments) table + , emit " WHERE " + , let QExpr mkE = makeWhere table $ excluded table + in fromSqliteExpression $ mkE "t" + ] + +excluded + :: forall table s + . Beamable table + => table (QField s) + -> table (QExpr Sqlite s) +excluded table = changeBeamRep excludedField table + where excludedField (Columnar' (QField _ _ name)) = + Columnar' $ QExpr $ const $ fieldE $ qualifiedField "excluded" name 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 @@ -41,7 +41,7 @@ import Data.Int (Int64) import Data.List (sortBy) import Data.Maybe (mapMaybe, isJust) -import Data.Monoid (Endo(..), (<>)) +import Data.Monoid (Endo(..)) import Data.Ord (comparing) import Data.String (fromString) import qualified Data.Text as T @@ -135,7 +135,7 @@ where dtParser = charP <|> varcharP <|> ncharP <|> nvarcharP <|> - bitP <|> varbitP <|> numericP <|> + bitP <|> varbitP <|> numericP <|> decimalP <|> doubleP <|> integerP <|> smallIntP <|> bigIntP <|> floatP <|> doubleP <|> realP <|> dateP <|> @@ -170,12 +170,16 @@ numericP = do asciiCI "NUMERIC" numericType <$> numericPrecP - doubleP = do - asciiCI "DOUBLE" <|> asciiCI "DECIMAL" + decimalP = do + asciiCI "DECIMAL" decimalType <$> numericPrecP floatP = do asciiCI "FLOAT" floatType <$> precP + doubleP = do + asciiCI "DOUBLE" + optional $ skipSpace >> asciiCI "PRECISION" + pure doubleType realP = realType <$ asciiCI "REAL" intTypeP = 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 @@ -19,10 +19,12 @@ , SqliteSelectSyntax(..), SqliteInsertSyntax(..) , SqliteUpdateSyntax(..), SqliteDeleteSyntax(..) + , SqliteOnConflictSyntax(..) , SqliteInsertValuesSyntax(..) , SqliteColumnSchemaSyntax(..) , SqliteExpressionSyntax(..), SqliteValueSyntax(..) , SqliteTableNameSyntax(..) + , SqliteFieldNameSyntax(..) , SqliteAggregationSetQuantifierSyntax(..) , fromSqliteExpression @@ -33,14 +35,15 @@ , sqliteBigIntType, sqliteSerialType -- * Building and consuming 'SqliteSyntax' - , fromSqliteCommand, formatSqliteInsert + , fromSqliteCommand, formatSqliteInsert, formatSqliteInsertOnConflict - , emit, emitValue, parens + , emit, emitValue, parens, commas, quotedIdentifier , sqliteEscape, withPlaceholders , sqliteRenderSyntaxScript ) where +import Database.Beam.Backend.Internal.Compat import Database.Beam.Backend.SQL import Database.Beam.Backend.SQL.AST (ExtractField(..)) import Database.Beam.Haskell.Syntax @@ -69,6 +72,7 @@ #if !MIN_VERSION_base(4, 11, 0) import Data.Semigroup #endif +import GHC.TypeLits import Database.SQLite.Simple (SQLData(..)) @@ -176,21 +180,25 @@ -- | Convert a 'SqliteCommandSyntax' into a renderable 'SqliteSyntax' fromSqliteCommand :: SqliteCommandSyntax -> SqliteSyntax fromSqliteCommand (SqliteCommandSyntax s) = s -fromSqliteCommand (SqliteCommandInsert (SqliteInsertSyntax tbl fields values)) = - formatSqliteInsert tbl fields values +fromSqliteCommand (SqliteCommandInsert (SqliteInsertSyntax tbl fields values onConflict)) = + formatSqliteInsertOnConflict tbl fields values onConflict -- | SQLite @SELECT@ syntax newtype SqliteSelectSyntax = SqliteSelectSyntax { fromSqliteSelect :: SqliteSyntax } +-- | SQLite @ON CONFLICT@ syntax +newtype SqliteOnConflictSyntax = SqliteOnConflictSyntax { fromSqliteOnConflict :: SqliteSyntax } + -- | 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 :: !SqliteTableNameSyntax - , sqliteInsertFields :: [ T.Text ] - , sqliteInsertValues :: !SqliteInsertValuesSyntax + { sqliteInsertTable :: !SqliteTableNameSyntax + , sqliteInsertFields :: [ T.Text ] + , sqliteInsertValues :: !SqliteInsertValuesSyntax + , sqliteInsertOnConflict :: !(Maybe SqliteOnConflictSyntax) } -- | SQLite @UPDATE@ syntax @@ -295,12 +303,23 @@ -- | Format a SQLite @INSERT@ expression for the given table name, fields, and values. formatSqliteInsert :: SqliteTableNameSyntax -> [ T.Text ] -> SqliteInsertValuesSyntax -> SqliteSyntax formatSqliteInsert tblNm fields values = - emit "INSERT INTO " <> fromSqliteTableName tblNm <> parens (commas (map quotedIdentifier fields)) <> emit " " <> - case values of - SqliteInsertFromSql (SqliteSelectSyntax select) -> select - SqliteInsertExpressions es -> - emit "VALUES " <> commas (map (\row -> parens (commas (map fromSqliteExpression row)) ) es) + formatSqliteInsertOnConflict tblNm fields values Nothing +-- | Format a SQLite @INSERT@ expression for the given table name, fields, +-- values, and optionally an @ON CONFLICT@ clause. +formatSqliteInsertOnConflict :: SqliteTableNameSyntax -> [ T.Text ] -> SqliteInsertValuesSyntax -> Maybe SqliteOnConflictSyntax -> SqliteSyntax +formatSqliteInsertOnConflict tblNm fields values onConflict = mconcat + [ emit "INSERT INTO " + , fromSqliteTableName tblNm + , parens (commas (map quotedIdentifier fields)) + , emit " " + , case values of + SqliteInsertFromSql (SqliteSelectSyntax select) -> select + SqliteInsertExpressions es -> + emit "VALUES " <> commas (map (\row -> parens (commas (map fromSqliteExpression row)) ) es) + , maybe mempty ((emit " " <>) . fromSqliteOnConflict) onConflict + ] + instance IsSql92Syntax SqliteCommandSyntax where type Sql92SelectSyntax SqliteCommandSyntax = SqliteSelectSyntax type Sql92InsertSyntax SqliteCommandSyntax = SqliteInsertSyntax @@ -504,7 +523,7 @@ varBitType prec = SqliteDataTypeSyntax (emit "BIT VARYING" <> sqliteOptPrec prec) (varBitType prec) (varBitType prec) False numericType prec = SqliteDataTypeSyntax (emit "NUMERIC" <> sqliteOptNumericPrec prec) (numericType prec) (numericType prec) False - decimalType prec = SqliteDataTypeSyntax (emit "DOUBLE" <> sqliteOptNumericPrec prec) (decimalType prec) (decimalType prec) False + decimalType prec = SqliteDataTypeSyntax (emit "DECIMAL" <> sqliteOptNumericPrec prec) (decimalType prec) (decimalType prec) False intType = SqliteDataTypeSyntax (emit "INTEGER") intType intType False smallIntType = SqliteDataTypeSyntax (emit "SMALLINT") smallIntType smallIntType False @@ -671,8 +690,6 @@ ascOrdering e = SqliteOrderingSyntax (fromSqliteExpression e <> emit " ASC") descOrdering e = SqliteOrderingSyntax (fromSqliteExpression e <> emit " DESC") -instance HasSqlValueSyntax SqliteValueSyntax Int where - sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) instance HasSqlValueSyntax SqliteValueSyntax Int8 where sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) instance HasSqlValueSyntax SqliteValueSyntax Int16 where @@ -681,8 +698,6 @@ sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) instance HasSqlValueSyntax SqliteValueSyntax Int64 where 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 @@ -698,7 +713,7 @@ instance HasSqlValueSyntax SqliteValueSyntax Double where sqlValueSyntax f = SqliteValueSyntax (emitValue (SQLFloat f)) instance HasSqlValueSyntax SqliteValueSyntax Bool where - sqlValueSyntax = sqlValueSyntax . (\b -> if b then 1 else 0 :: Int) + sqlValueSyntax = sqlValueSyntax . (\b -> if b then 1 else 0 :: Int32) instance HasSqlValueSyntax SqliteValueSyntax SqlNull where sqlValueSyntax _ = SqliteValueSyntax (emit "NULL") instance HasSqlValueSyntax SqliteValueSyntax String where @@ -712,6 +727,12 @@ sqlValueSyntax (Just x) = sqlValueSyntax x sqlValueSyntax Nothing = sqlValueSyntax SqlNull +instance TypeError (PreferExplicitSize Int Int32) => HasSqlValueSyntax SqliteValueSyntax Int where + sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) + +instance TypeError (PreferExplicitSize Word Word32) => HasSqlValueSyntax SqliteValueSyntax Word where + sqlValueSyntax i = SqliteValueSyntax (emitValue (SQLInteger (fromIntegral i))) + instance IsCustomSqlSyntax SqliteExpressionSyntax where newtype CustomSqlSyntax SqliteExpressionSyntax = SqliteCustomExpressionSyntax { fromSqliteCustomExpression :: SqliteSyntax } @@ -773,9 +794,9 @@ SqliteExpressionSyntax $ emit "NULLIF" <> parens (fromSqliteExpression a <> emit ", " <> fromSqliteExpression b) absE x = SqliteExpressionSyntax (emit "ABS" <> parens (fromSqliteExpression x)) - 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)) + bitLengthE x = SqliteExpressionSyntax (emit "8 * LENGTH" <> parens (emit "CAST" <> parens (parens (fromSqliteExpression x) <> emit " AS BLOB"))) + charLengthE x = SqliteExpressionSyntax (emit "LENGTH" <> parens (fromSqliteExpression x)) + octetLengthE x = SqliteExpressionSyntax (emit "LENGTH" <> parens (emit "CAST" <> parens (parens (fromSqliteExpression x) <> emit " AS BLOB"))) lowerE x = SqliteExpressionSyntax (emit "LOWER" <> parens (fromSqliteExpression x)) upperE x = SqliteExpressionSyntax (emit "UPPER" <> parens (fromSqliteExpression x)) trimE x = SqliteExpressionSyntax (emit "TRIM" <> parens (fromSqliteExpression x)) @@ -851,7 +872,7 @@ type Sql92InsertTableNameSyntax SqliteInsertSyntax = SqliteTableNameSyntax type Sql92InsertValuesSyntax SqliteInsertSyntax = SqliteInsertValuesSyntax - insertStmt = SqliteInsertSyntax + insertStmt table fields values = SqliteInsertSyntax table fields values Nothing instance IsSql92InsertValuesSyntax SqliteInsertValuesSyntax where type Sql92InsertValuesExpressionSyntax SqliteInsertValuesSyntax = SqliteExpressionSyntax diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ SQLite is mostly standards compliant, but there are a few cases that beam-sqlite cannot handle. These cases may result in run-time errors. For more information, see -[the documentation](http://tathougies.github.io/beam/user-guide/backends/beam-sqlite/). +[the documentation](https://haskell-beam.github.io/beam/user-guide/backends/beam-sqlite/). Due to SQLite's embedded nature, there are currently no plans to get rid of these. However, proposals and PRs to fix these corner cases are welcome, where appropriate. diff --git a/beam-sqlite.cabal b/beam-sqlite.cabal --- a/beam-sqlite.cabal +++ b/beam-sqlite.cabal @@ -1,20 +1,20 @@ name: beam-sqlite -version: 0.4.0.0 +version: 0.5.0.0 synopsis: Beam driver for SQLite description: Beam driver for the embedded database. - See + See for more information -homepage: http://tathougies.github.io/beam/user-guide/backends/beam-sqlite/ +homepage: https://haskell-beam.github.io/beam/user-guide/backends/beam-sqlite/ license: MIT license-file: LICENSE author: Travis Athougies maintainer: travis@athougies.net copyright: (C) 2017-2018 Travis Athougies -category: Web +category: Database build-type: Simple extra-source-files: README.md extra-doc-files: ChangeLog.md -bug-reports: https://github.com/tathougies/beam/issues +bug-reports: https://github.com/haskell-beam/beam/issues cabal-version: 1.18 library @@ -25,13 +25,13 @@ other-modules: Database.Beam.Sqlite.SqliteSpecific build-depends: base >=4.7 && <5, - beam-core >=0.8 && <0.9, - beam-migrate >=0.4 && <0.5, + beam-core >=0.9 && <0.10, + beam-migrate >=0.5 && <0.6, sqlite-simple >=0.4 && <0.5, text >=1.0 && <1.3, bytestring >=0.10 && <0.11, - hashable >=1.2 && <1.3, + hashable >=1.2 && <1.4, time >=1.6 && <1.10, dlist >=0.8 && <0.9, mtl >=2.1 && <2.3, @@ -51,10 +51,44 @@ if os(windows) cpp-options: -DWINDOWS build-depends: Win32 >=2.4 && <2.8 - if os(freebsd) || os(netbsd) || os(darwin) || os(linux) || os(solaris) + if os(freebsd) || os(netbsd) || os(openbsd) || os(darwin) || os(linux) || os(solaris) || os(android) cpp-options: -DUNIX build-depends: unix >=2.0 && <2.8 +test-suite beam-sqlite-tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base, + beam-core, + beam-migrate, + beam-sqlite, + sqlite-simple, + tasty, + tasty-expected-failure, + tasty-hunit, + text, + time + other-modules: + Database.Beam.Sqlite.Test + Database.Beam.Sqlite.Test.Migrate + Database.Beam.Sqlite.Test.Select + default-language: Haskell2010 + default-extensions: + DeriveAnyClass, + DeriveGeneric, + FlexibleContexts, + FlexibleInstances, + LambdaCase, + MultiParamTypeClasses, + OverloadedStrings, + RankNTypes, + ScopedTypeVariables, + StandaloneDeriving, + TypeApplications, + TypeFamilies + flag werror description: Enable -Werror during development default: False @@ -62,5 +96,5 @@ source-repository head type: git - location: https://github.com/tathougies/beam.git + location: https://github.com/haskell-beam/beam.git subdir: beam-sqlite diff --git a/test/Database/Beam/Sqlite/Test.hs b/test/Database/Beam/Sqlite/Test.hs new file mode 100644 --- /dev/null +++ b/test/Database/Beam/Sqlite/Test.hs @@ -0,0 +1,9 @@ +module Database.Beam.Sqlite.Test where + +import Control.Exception +import Database.SQLite.Simple +import Test.Tasty.HUnit + +withTestDb :: (Connection -> IO a) -> IO a +withTestDb = flip catch asFailure . bracket (open ":memory:") close + where asFailure (e :: SomeException) = assertFailure $ show e diff --git a/test/Database/Beam/Sqlite/Test/Migrate.hs b/test/Database/Beam/Sqlite/Test/Migrate.hs new file mode 100644 --- /dev/null +++ b/test/Database/Beam/Sqlite/Test/Migrate.hs @@ -0,0 +1,74 @@ +module Database.Beam.Sqlite.Test.Migrate (tests) where + +import Database.SQLite.Simple +import Test.Tasty +import Test.Tasty.HUnit + +import Database.Beam +import Database.Beam.Sqlite +import Database.Beam.Sqlite.Migrate +import Database.Beam.Migrate +import Database.Beam.Migrate.Simple + +import Database.Beam.Sqlite.Test + +tests :: TestTree +tests = testGroup "Migration tests" + [ verifiesPrimaryKey + , verifiesNoPrimaryKey + ] + +newtype WithPkT f = WithPkT + { _with_pk_value :: C f Bool + } deriving (Generic, Beamable) + +instance Table WithPkT where + newtype PrimaryKey WithPkT f = Pk (C f Bool) + deriving (Generic, Beamable) + + primaryKey = Pk . _with_pk_value + +data WithPkDb entity = WithPkDb + { _with_pk :: entity (TableEntity WithPkT) + } deriving (Generic, Database Sqlite) + +withPkDbChecked :: CheckedDatabaseSettings Sqlite WithPkDb +withPkDbChecked = defaultMigratableDbSettings + +newtype WithoutPkT f = WithoutPkT + { _without_pk_value :: C f Bool + } deriving (Generic, Beamable) + +instance Table WithoutPkT where + data PrimaryKey WithoutPkT f = NoPk + deriving (Generic, Beamable) + + primaryKey _ = NoPk + +data WithoutPkDb entity = WithoutPkDb + { _without_pk :: entity (TableEntity WithoutPkT) + } deriving (Generic, Database Sqlite) + +withoutPkDbChecked :: CheckedDatabaseSettings Sqlite WithoutPkDb +withoutPkDbChecked = defaultMigratableDbSettings + +verifiesPrimaryKey :: TestTree +verifiesPrimaryKey = testCase "verifySchema correctly detects primary key" $ + withTestDb $ \conn -> do + execute_ conn "create table with_pk (with_pk_value bool not null primary key)" + testVerifySchema conn withPkDbChecked + +verifiesNoPrimaryKey :: TestTree +verifiesNoPrimaryKey = testCase "verifySchema correctly handles table with no primary key" $ + withTestDb $ \conn -> do + execute_ conn "create table without_pk (without_pk_value bool not null)" + testVerifySchema conn withoutPkDbChecked + +testVerifySchema + :: Database Sqlite db + => Connection -> CheckedDatabaseSettings Sqlite db -> Assertion +testVerifySchema conn db = + runBeamSqlite conn (verifySchema migrationBackend db) >>= \case + VerificationSucceeded -> return () + VerificationFailed failures -> + fail $ "Verification failed: " ++ show failures diff --git a/test/Database/Beam/Sqlite/Test/Select.hs b/test/Database/Beam/Sqlite/Test/Select.hs new file mode 100644 --- /dev/null +++ b/test/Database/Beam/Sqlite/Test/Select.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Database.Beam.Sqlite.Test.Select (tests) where + +import Control.Exception +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit + +import Data.Int (Int32) +import Data.Text (Text) +import Data.Time (LocalTime) + +import Database.Beam +import Database.Beam.Sqlite + +import Database.Beam.Sqlite.Test + +import Database.SQLite.Simple (execute_) + +tests :: TestTree +tests = testGroup "Selection tests" + [ expectFail testExceptValues + , testInRowValues + , testInsertReturningColumnOrder -- In select tests because the bug was with the selects + ] + +data Pair f = Pair + { _left :: C f Bool + , _right :: C f Bool + } deriving (Generic, Beamable) + +testInRowValues :: TestTree +testInRowValues = testCase "IN with row values works" $ + withTestDb $ \conn -> do + result <- runBeamSqlite conn $ runSelectReturningList $ select $ do + let p :: forall ctx s. Pair (QGenExpr ctx Sqlite s) + p = val_ $ Pair False False + return $ p `in_` [p, p] + assertEqual "result" [True] result + +-- | Regression test for +testExceptValues :: TestTree +testExceptValues = testCase "EXCEPT with VALUES works" $ + withTestDb $ \conn -> do + result <- runBeamSqlite conn $ runSelectReturningList $ select $ + values_ [as_ @Bool $ val_ True, val_ False] `except_` values_ [val_ False] + assertEqual "result" [True] result + +data TestTableT f + = TestTable + { ttId :: C f Int32 + , ttFirstName :: C f Text + , ttLastName :: C f Text + , ttAge :: C f Int32 + , ttDateJoined :: C f LocalTime + } deriving (Generic, Beamable) + +deriving instance Show (TestTableT Identity) +deriving instance Eq (TestTableT Identity) + +instance Table TestTableT where + data PrimaryKey TestTableT f = TestTableKey (C f Int32) + deriving (Generic, Beamable) + primaryKey = TestTableKey <$> ttId + +data TestTableDb entity + = TestTableDb + { dbTestTable :: entity (TableEntity TestTableT) + } deriving (Generic, Database Sqlite) + +testDatabase :: DatabaseSettings be TestTableDb +testDatabase = defaultDbSettings + +testInsertReturningColumnOrder :: TestTree +testInsertReturningColumnOrder = testCase "runInsertReturningList with mismatching column order" $ do + withTestDb $ \conn -> do + execute_ conn "CREATE TABLE test_table ( date_joined TIMESTAMP NOT NULL, first_name TEXT NOT NULL, id INT PRIMARY KEY, age INT NOT NULL, last_name TEXT NOT NULL )" + inserted <- + runBeamSqlite conn $ runInsertReturningList $ + insert (dbTestTable testDatabase) $ + insertExpressions [ TestTable 0 (concat_ [ "j", "im" ]) "smith" 19 currentTimestamp_ + , TestTable 1 "sally" "apple" ((val_ 56 + val_ 109) `div_` 5) currentTimestamp_ + , TestTable 4 "blah" "blah" (-1) currentTimestamp_ ] + + let dateJoined = ttDateJoined (head inserted) + + expected = [ TestTable 0 "jim" "smith" 19 dateJoined + , TestTable 1 "sally" "apple" 33 dateJoined + , TestTable 4 "blah" "blah" (-1) dateJoined ] + + assertEqual "insert values" inserted expected diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,12 @@ +module Main where + +import Test.Tasty + +import qualified Database.Beam.Sqlite.Test.Migrate as Migrate +import qualified Database.Beam.Sqlite.Test.Select as Select + +main :: IO () +main = defaultMain $ testGroup "beam-sqlite tests" + [ Migrate.tests + , Select.tests + ]