diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,208 @@ + +0.1.0.0 +======= + +Solo constructor -> MkSolo + +SQL -> Sql + +Use the same PreparedStatement and ColumnIndex types in SQLite and SQLite.Query. + +Statement renamed to PreparedStatement + +moved the bindings modules and the direct module to their own public +sublibraries. + +library renamed to "dani-sqlite" + +renamed "Database" to "Connection". + +incorporated fork of sqlite-simple! + +Removed dependency on transformers. + +Removed dependency on exceptions. + +fork! + +pre-fork +======== + +v2.3.26: + * Add support for GHC 8.8 and Stackage LTS 15+ + +v2.3.25: + * Upgrade embedded sqlite library to 3.28.0. + +v2.3.24: + * Upgrade embedded sqlite3 library to 3.24.0. + * Add faster `stepNoCB` function for statements that don't callback to Haskell functions. + * Use faster "unsafe" FFI calls for the following functions: + reset, blobOpen, blobClose, blobReopen, blobRead, blobWrite, backupStep, errcode, errmsg + as they are frequently used and don't callback to Haskell functions. + * Use faster Haskell memory allocator in blobRead function. + +v2.3.23: + * Add Semigroup instance to support GHC 8.4.1 (thanks @gwils) + * Build clean up for Android support (thanks @kmicklas) + +v2.3.22: + * Update sqlite to 3.22.0 + +v2.3.21 + * Update sqlite to 3.20.1 + * Add -DSQLITE_ENABLE_FTS5 to build options + +v2.3.20 + * Enable use of usleep (thanks @dbdbdb) + * Add sqlite3.h and sqlite3ext.h to install-includes (thanks @duog) + +v2.3.19 + * Upgrade embedded sqlite3 library to 3.15.2. + +v2.3.18 + * Upgrade embedded sqlite3 library to 3.15.0. + + * Fix regressions in the test suite that were either introduced by changes + in GHC 8 and/or stuff we missed in previous releases. + +v2.3.17 + * Use a randomly created temp file for test database when running + unit tests instead of a hardcoded file under 'dist/'. Hopefully + fixes https://github.com/IreneKnapp/direct-sqlite/issues/60 + +v2.3.16 + * Add an Eq instance for SQLError + +v2.3.15 + * Add support for the online backup API + + * Add support for incremental blob I/O + + * Add support for zeroblobs + + * Add support for enabling/disabling the shared cache mode + + * Add low-level bindings to sqlite3_wal_hook + + * Add function for retrieving the db handle from a custom function + context. + + * Add bindings for sqlite3_errcode + + * Improve Travis CI coverage to cover more GHC versions (GHC 7.4 and higher) + + * Big thanks to Mario Titas and Marcin Tolysz for the above! + +v2.3.14 + * Add custom functions, aggregates and collations. + + * Upgrade the bundled SQLite3 library to 3.8.5. + + * Add bindings for controlling whether extension loading is + enabled or disabled. + + * Bump text and bytestring versions (actually, risking it and + removing upper bounds) + +v2.3.13 + * Add support for named parameters to queries. Split this changelog into + a separate file (preserving its history). + +v2.3.12 + * Upgrade bundled SQLite3 to 3.8.4.1. + +v2.3.11 + + * Add support for URI filenames, and default to having them + on. Among other things, this enables using in-memory databases. + +v2.3.10 + + * Add support for compiling the bundled SQLite3 with URI filename + support. Specifying flags that would have affected the bundled + SQLite3 no longer causes build failure if the "systemlib" flag + is specified. + +v2.3.9 + + * Update bounds on the requirement on the "text" library. + +v2.3.8 + + * Upgrade bundled SQLite3 to 3.8.1. + +v2.3.7 + + * Fix a test failure related to 64-bit math on column indices. + +v2.3.6 + + * Re-apply the stat64 hack after upgrade to the bundled +SQLite3. Oops! + +v2.3.5 + + * Add support to compile bundled SQLite3 with full-text + search. Upgrade bundled SQLite3 to 3.7.17. + +v2.3.4 + + * Work around a linker error on some systems; add column-name + reporting. + +v2.3.3.1 + + * Upgrade bundled SQLite3 to 3.7.15.2. + +v2.3.3 + + * Add trace support, as a feature for debugging. + +v2.3.2 + + * Add execPrint, execWithCallback, and interruptibly functions. + Add bindings for sqlite3_last_insert_rowid and sqlite3_changes. + Change the Show instance of the Utf8 newtype to better match the + IsString instance. + +v2.3.1 + + * Upgrade the bundled SQLite3 to 3.7.15. Add bindings for + sqlite3_interrupt. Export Int rather than CInt. + +v2.3 + + * Mark some FFI calls "unsafe", for a substantial performance + benefit. + +v2.2.1 + + * Bump down text library version to match with the latest Haskell + Platform. + +v2.2 + + * Actually does what version 2.1 claimed to, since the author made + a mistake with git. + +v2.1 + + * Improves handling of invalid UTF-8 and changes error handling to + be more complete. It also adds a build flag to build against the + system sqlite instead of the bundled one, optionally + (disabled by default). + +v2.0 + + * Uses Text for strings instead of String. + +v1.1.0.1 + + * Switches to the Faction packaging system and makes + no other changes. + +v1.1 + + * Adds the SQLite amalgamation file (version 3.7.5) to the + project, so that there are no external dependencies. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2021, Daniel Diaz + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Daniel Diaz nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,80 @@ +dani-sqlite +============ + +An amalgamated fork of Irene Knapp's [direct-sqlite](https://github.com/IreneKnapp/direct-sqlite) and Janne Hellsten's [sqlite-simple](https://hackage.haskell.org/package/sqlite-simple). + +- Unlike **direct-sqlite**, it doesn't include the code for the C library, so +you'll have to install the library separately. + + Example of `cabal.project.local` pointing to local libs on Windows: + + package dani-sqlite + extra-include-dirs: C:/Users/somefolder/sqlite-amalgamation-3350300 + extra-lib-dirs: C:/Users/somefolder/sqlite-dll-win64-x64-3350300 + +- Requires SQLite >= 3.37.0. + +- Supports [`sqlite3_open_v2`](https://www.sqlite.org/c3ref/open.html). + +- Supports [extended result codes](https://www.sqlite.org/rescode.html). + +- Unlike **sqlite-simple**, this library doesn't have a time type. + +- Unlike **sqlite-simple**, this library doesn't have a quasiquoter. + +Links +===== + +- [FFI in the Haskell Report](https://www.haskell.org/onlinereport/haskell2010/haskellch8.html) + +- [Foreign function interface (FFI) in the GHC user guide](https://downloads.haskell.org/ghc/latest/docs/html/users_guide/exts/ffi.html) + +- [Using the latest version of SQLite with Haskell on Windows](https://danidiaz.medium.com/using-the-latest-version-of-sqlite-with-haskell-on-windows-1d6d4df2e683) + +- [Foreign Function Interface at the Haskellwiki](https://wiki.haskell.org/Foreign_Function_Interface) + +> I see very little reason to not use CApiFFI if your project doesn't need +to work on old GHCs. + +- [Writing Haskell interfaces to C code: hsc2hs](https://downloads.haskell.org/ghc/latest/docs/html/users_guide/utils.html) + +- [Using_the_FFI](https://wiki.haskell.org/GHC/Using_the_FFI). + +- [Haskell/FFI](https://en.wikibooks.org/wiki/Haskell/FFI) + +- [hsctohs](https://www.reddit.com/r/haskell/comments/tthrq0/comment/i5dpir1/) + +- [Chapter 17. Interfacing with C: the FFI](http://book.realworldhaskell.org/read/interfacing-with-c-the-ffi.html) + + > the #const keyword hsc2hs provides [...] We can bind to the constants manually, by listing the CPP symbols for them using the #const keyword + +- [Writing Haskell interfaces to C code: hsc2hs](https://downloads.haskell.org/ghc/latest/docs/html/users_guide/utils.html?highlight=hsc2hs#writing-haskell-interfaces-to-c-code-hsc2hs) + +- [Converting between `CInt` and `Int`](https://www.reddit.com/r/haskell/comments/tthrq0/monthly_hask_anything_april_2022/i60rc8l/) + + > Does that mean that I should always use functions like fromIntegral to convert between CInt and Int/Integer? + +- [Videos about the Haskell FFI](https://twitter.com/DiazCarrete/status/1518325306448388096). + +- [`foreign import capi "wrapper"`](https://gitlab.haskell.org/ghc/ghc/-/issues/21532#note_428196) + + > While the Report isn't entirely clear on this, but my understanding is that the calling convention (e.g. ccall) in a foreign import ... "wrapper" indicates the calling convention that the resulting FunPtr should expect to be invoked with. If this is true then it's not obvious what foreign import capi "wrapper" should mean; afterall capi isn't really a calling convention. Rather, it just says "delegate code generation for the call to the C compiler". However, we can't delegate like this in for a "wrapper" import, since this would be akin to writing foreign export capi, which don't support. + +- [C-language Interface Specification for SQLite](https://www.sqlite.org/capi3ref.html) + +- [parameters](https://www.sqlite.org/lang_expr.html#varparam) + + [The sqlite3_bind_parameter_name(P,N) interface returns the name of the N-th SQL parameter in the prepared statement P.](https://www.sqlite.org/c3ref/bind_parameter_name.html) + + [Return the index of an SQL parameter given its name. The index value returned is suitable for use as the second parameter to sqlite3_bind().](https://www.sqlite.org/c3ref/bind_parameter_index.html) + +- [Closing A Database Connection](https://www.sqlite.org/c3ref/close.html) + + > Ideally, applications should finalize all prepared statements, close all BLOB handles, and finish all sqlite3_backup objects associated with the sqlite3 object prior to attempting to close the object. + +Acknowledgements +================ + +- Irene Knapp and the rest of contributors to [direct-sqlite](https://github.com/IreneKnapp/direct-sqlite). +- Janne Hellsten and the rest of contributors to [sqlite-simple](https://hackage.haskell.org/package/sqlite-simple). + diff --git a/dani-sqlite.cabal b/dani-sqlite.cabal new file mode 100644 --- /dev/null +++ b/dani-sqlite.cabal @@ -0,0 +1,109 @@ +cabal-version: 3.8 +name: dani-sqlite +version: 0.1.0.0 +synopsis: Low-level binding to Sqlite3. +description: Low-level binding to Sqlite3. + UTF8 and BLOB support. + sqlite library not included. +license: BSD-3-Clause +license-file: LICENSE +copyright: Copyright (c) 2022 - 2022 Daniel Díaz +author: Daniel Díaz +maintainer: Daniel Díaz +category: Database +homepage: https://github.com/danidiaz/dani-sqlite +bug-reports: https://github.com/danidiaz/dani-sqlite/issues/new +build-type: Simple +extra-doc-files: CHANGELOG.md, + README.md +tested-with: GHC == {9.10.1, 9.12.2} + +source-repository head + type: git + location: git@github.com:danidiaz/dani-sqlite.git + +library + hs-source-dirs: lib + exposed-modules: Sqlite + Sqlite.Query + Sqlite.Query.Types + Sqlite.Query.Ok + Sqlite.Query.ToField + Sqlite.Query.ToRow + Sqlite.Query.FromField + Sqlite.Query.FromRow + Sqlite.Query.Internal + build-depends: base >= 4.16.0.0 && < 5 + , bytestring >= 0.9.2.1 && < 0.13 + , text >= 2.0 && <2.2 + , dani-sqlite:bindings + , dani-sqlite:direct + default-language: GHC2024 + ghc-options: -Wall -fwarn-tabs + +library direct + hs-source-dirs: lib-direct + exposed-modules: Sqlite.Direct + build-depends: base >= 4.16.0.0 && < 5 + , bytestring >= 0.9.2.1 && < 0.13 + , dani-sqlite:bindings + default-language: GHC2024 + ghc-options: -Wall -fwarn-tabs + visibility: public + +library bindings + hs-source-dirs: lib-bindings + exposed-modules: Sqlite.Bindings + Sqlite.Types + build-depends: base >= 4.16.0.0 && < 5 + , bytestring >= 0.9.2.1 && < 0.13 + default-language: GHC2024 + ghc-options: -Wall -fwarn-tabs + visibility: public + extra-libraries: sqlite3 + +test-suite test + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: StrictEq + hs-source-dirs: test + build-depends: base + , tasty >= 1.4.2.1 + , tasty-hunit >= 0.10.0.3 + , base16-bytestring + , bytestring + , directory + , temporary + , text + , dani-sqlite + , dani-sqlite:bindings + , dani-sqlite:direct + default-language: GHC2024 + ghc-options: -Wall -threaded -fno-warn-name-shadowing -fno-warn-unused-do-bind + +test-suite test-query + default-language: GHC2024 + type: exitcode-stdio-1.0 + + hs-source-dirs: test-query + main-is: Main.hs + other-modules: Common + , DirectSqlite + , Errors + , Fold + , ParamConv + , Query + , PreparedStatement + , TestImports + , UserInstances + , Utf8Strings + + ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind + + + build-depends: base + , base16-bytestring + , bytestring >= 0.9 + , HUnit + , dani-sqlite + , text diff --git a/lib-bindings/Sqlite/Bindings.hs b/lib-bindings/Sqlite/Bindings.hs new file mode 100644 --- /dev/null +++ b/lib-bindings/Sqlite/Bindings.hs @@ -0,0 +1,627 @@ +{-# LANGUAGE CApiFFI #-} + +module Sqlite.Bindings + ( module Sqlite.Types, + + -- * Connection management + c_sqlite3_open, + c_sqlite3_open_v2, + c_sqlite3_close, + c_sqlite3_errcode, + c_sqlite3_errmsg, + c_sqlite3_interrupt, + c_sqlite3_trace, + CTraceCallback, + mkCTraceCallback, + c_sqlite3_get_autocommit, + c_sqlite3_enable_shared_cache, + + -- * Simple query execution + + -- | + c_sqlite3_exec, + CExecCallback, + mkCExecCallback, + + -- * Statement management + c_sqlite3_prepare_v2, + c_sqlite3_db_handle, + c_sqlite3_step, + c_sqlite3_step_unsafe, + c_sqlite3_reset, + c_sqlite3_finalize, + c_sqlite3_clear_bindings, + c_sqlite3_sql, + + -- * Parameter and column information + c_sqlite3_bind_parameter_count, + c_sqlite3_bind_parameter_name, + c_sqlite3_bind_parameter_index, + c_sqlite3_column_count, + c_sqlite3_column_name, + + -- * Binding Values To Prepared Statements + + -- | + c_sqlite3_bind_blob, + c_sqlite3_bind_zeroblob, + c_sqlite3_bind_text, + c_sqlite3_bind_double, + c_sqlite3_bind_int64, + c_sqlite3_bind_null, + + -- * Result Values From A Query + + -- | + c_sqlite3_column_type, + c_sqlite3_column_bytes, + c_sqlite3_column_blob, + c_sqlite3_column_int64, + c_sqlite3_column_double, + c_sqlite3_column_text, + + -- * Result statistics + c_sqlite3_last_insert_rowid, + c_sqlite3_changes, + c_sqlite3_total_changes, + + -- * Create Or Redefine SQL Functions + c_sqlite3_create_function_v2, + CFunc, + CFuncFinal, + CFuncDestroy, + mkCFunc, + mkCFuncFinal, + mkCFuncDestroy, + c_sqlite3_user_data, + c_sqlite3_context_db_handle, + c_sqlite3_aggregate_context, + + -- * Obtaining SQL Function Parameter Values + + -- | + c_sqlite3_value_type, + c_sqlite3_value_bytes, + c_sqlite3_value_blob, + c_sqlite3_value_text, + c_sqlite3_value_int64, + c_sqlite3_value_double, + + -- * Setting The Result Of An SQL Function + + -- | + c_sqlite3_result_null, + c_sqlite3_result_blob, + c_sqlite3_result_zeroblob, + c_sqlite3_result_text, + c_sqlite3_result_int64, + c_sqlite3_result_double, + c_sqlite3_result_value, + c_sqlite3_result_error, + + -- * Define New Collating Sequences + c_sqlite3_create_collation_v2, + CCompare, + mkCCompare, + + -- * Miscellaneous + c_sqlite3_free, + c_sqlite3_free_p, + + -- * Extensions + c_sqlite3_enable_load_extension, + + -- * Write-Ahead Log Commit Hook + c_sqlite3_wal_hook, + CWalHook, + mkCWalHook, + + -- * Incremental blob I/O + c_sqlite3_blob_open, + c_sqlite3_blob_close, + c_sqlite3_blob_reopen, + c_sqlite3_blob_bytes, + c_sqlite3_blob_read, + c_sqlite3_blob_write, + + -- * Online Backup API + + -- | and + -- + c_sqlite3_backup_init, + c_sqlite3_backup_finish, + c_sqlite3_backup_step, + c_sqlite3_backup_remaining, + c_sqlite3_backup_pagecount, + ) +where + +import Foreign +import Foreign.C +import Sqlite.Types + +-- | +-- +-- This sets the @'Ptr CConnection'@ even on failure. +foreign import capi "sqlite3.h sqlite3_open" + c_sqlite3_open :: CString -> Ptr (Ptr CConnection) -> IO CError + +-- | +-- +-- This sets the @'Ptr CConnection'@ even on failure. +foreign import capi "sqlite3.h sqlite3_open_v2" + c_sqlite3_open_v2 :: CString -> Ptr (Ptr CConnection) -> COpenV2Flags -> CString -> IO CError + +-- | +foreign import capi "sqlite3.h sqlite3_close" + c_sqlite3_close :: Ptr CConnection -> IO CError + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_errcode" + c_sqlite3_errcode :: Ptr CConnection -> IO CError + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_errmsg" + c_sqlite3_errmsg :: Ptr CConnection -> IO CString + +-- | +foreign import capi "sqlite3.h sqlite3_interrupt" + c_sqlite3_interrupt :: Ptr CConnection -> IO () + +-- | +foreign import capi "sqlite3.h sqlite3_trace" + c_sqlite3_trace :: + Ptr CConnection -> + -- | Optional callback function called for each row. + FunPtr (CTraceCallback a) -> + -- | Context passed to the callback. + Ptr a -> + -- | Returns context pointer from previously. + -- registered trace. + IO (Ptr ()) + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_get_autocommit" + c_sqlite3_get_autocommit :: Ptr CConnection -> IO CInt + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_enable_shared_cache" + c_sqlite3_enable_shared_cache :: Bool -> IO CError + +-- | +foreign import capi "sqlite3.h sqlite3_exec" + c_sqlite3_exec :: + Ptr CConnection -> + -- | SQL statement, UTF-8 encoded. + CString -> + -- | Optional callback function called for each row. + FunPtr (CExecCallback a) -> + -- | Context passed to the callback. + Ptr a -> + -- | OUT: Error message string. + Ptr CString -> + IO CError + +type CExecCallback a = + Ptr a -> + -- | Number of columns, which is the number of elements in + -- the following arrays. + CColumnCount -> + -- | Array of column values, as returned by + -- 'c_sqlite3_column_text'. Null values are represented + -- as null pointers. + Ptr CString -> + -- | Array of column names + Ptr CString -> + -- | If the callback returns non-zero, then + -- 'c_sqlite3_exec' returns @SQLITE_ABORT@ + -- ('ErrorAbort'). + IO CInt + +type CTraceCallback a = + Ptr a -> + -- | UTF-8 rendering of the SQL statement text as + -- the statement first begins executing. + CString -> + IO () + +-- | A couple important things to know about callbacks from Haskell code: +-- +-- * If the callback throws an exception, apparently, the /whole program/ is +-- terminated. +-- +-- * Remember to call 'freeHaskellFunPtr' when you are done with the wrapper, +-- to avoid leaking memory. +-- +-- +foreign import ccall "wrapper" + mkCExecCallback :: CExecCallback a -> IO (FunPtr (CExecCallback a)) + +-- | +-- +foreign import ccall "wrapper" + mkCTraceCallback :: CTraceCallback a -> IO (FunPtr (CTraceCallback a)) + +-- | +-- +-- If the query contains no SQL statements, this returns @SQLITE_OK@ and sets +-- the @'Ptr' 'CStatement'@ to null. +foreign import capi "sqlite3.h sqlite3_prepare_v2" + c_sqlite3_prepare_v2 :: + Ptr CConnection -> + -- | SQL statement, UTF-8 encoded. + CString -> + -- | Maximum length of the SQL statement, + -- in bytes. If this is negative, then the + -- SQL statement is treated as a + -- NUL-terminated string. + CNumBytes -> + -- | OUT: Statement handle. This must not be null. + Ptr (Ptr CStatement) -> + -- | OUT: Pointer to unused portion of zSql. + Ptr CString -> + IO CError + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_db_handle" + c_sqlite3_db_handle :: Ptr CStatement -> IO (Ptr CConnection) + +-- | +foreign import capi "sqlite3.h sqlite3_step" + c_sqlite3_step :: Ptr CStatement -> IO CError + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_step" + c_sqlite3_step_unsafe :: Ptr CStatement -> IO CError + +-- | +-- +-- /Warning:/ If the most recent 'c_sqlite3_step' call failed, +-- this will return the corresponding error code. +foreign import capi unsafe "sqlite3.h sqlite3_reset" + c_sqlite3_reset :: Ptr CStatement -> IO CError + +-- | +-- +-- /Warning:/ If the most recent 'c_sqlite3_step' call failed, +-- this will return the corresponding error code. +foreign import capi "sqlite3.h sqlite3_finalize" + c_sqlite3_finalize :: Ptr CStatement -> IO CError + +-- | +-- +-- A look at the source reveals that this function always returns @SQLITE_OK@. +foreign import capi unsafe "sqlite3.h sqlite3_clear_bindings" + c_sqlite3_clear_bindings :: Ptr CStatement -> IO CError + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_sql" + c_sqlite3_sql :: Ptr CStatement -> IO CString + +-- | +-- +-- This returns the index of the largest (rightmost) parameter, which is not +-- necessarily the number of parameters. If numbered parameters like @?5@ +-- are used, there may be gaps in the list. +foreign import capi unsafe "sqlite3.h sqlite3_bind_parameter_count" + c_sqlite3_bind_parameter_count :: Ptr CStatement -> IO CParamIndex + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_bind_parameter_name" + c_sqlite3_bind_parameter_name :: Ptr CStatement -> CParamIndex -> IO CString + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_bind_parameter_index" + c_sqlite3_bind_parameter_index :: Ptr CStatement -> CString -> IO CParamIndex + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_column_count" + c_sqlite3_column_count :: Ptr CStatement -> IO CColumnCount + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_column_name" + c_sqlite3_column_name :: Ptr CStatement -> CColumnIndex -> IO CString + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_bind_blob" + c_sqlite3_bind_blob :: + Ptr CStatement -> + -- | Index of the SQL parameter to be set + CParamIndex -> + -- | Value to bind to the parameter. + -- + -- /Warning:/ If this pointer is @NULL@, this + -- will bind a null value, rather than an empty blob. + Ptr a -> + -- | Length, in bytes. This must not be negative. + CNumBytes -> + Ptr CDestructor -> + IO CError + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_bind_zeroblob" + c_sqlite3_bind_zeroblob :: + Ptr CStatement -> CParamIndex -> CInt -> IO CError + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_bind_text" + c_sqlite3_bind_text :: + Ptr CStatement -> + CParamIndex -> + -- | /Warning:/ If this pointer is @NULL@, this + -- will bind a null value, rather than an empty text. + CString -> + -- | Length, in bytes. If this is negative, + -- the value is treated as a NUL-terminated string. + CNumBytes -> + Ptr CDestructor -> + IO CError + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_bind_double" + c_sqlite3_bind_double :: Ptr CStatement -> CParamIndex -> Double -> IO CError + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_bind_int64" + c_sqlite3_bind_int64 :: Ptr CStatement -> CParamIndex -> Int64 -> IO CError + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_bind_null" + c_sqlite3_bind_null :: Ptr CStatement -> CParamIndex -> IO CError + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_column_type" + c_sqlite3_column_type :: Ptr CStatement -> CColumnIndex -> IO CColumnType + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_column_bytes" + c_sqlite3_column_bytes :: Ptr CStatement -> CColumnIndex -> IO CNumBytes + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_column_blob" + c_sqlite3_column_blob :: Ptr CStatement -> CColumnIndex -> IO (Ptr a) + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_column_text" + c_sqlite3_column_text :: Ptr CStatement -> CColumnIndex -> IO CString + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_column_int64" + c_sqlite3_column_int64 :: Ptr CStatement -> CColumnIndex -> IO Int64 + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_column_double" + c_sqlite3_column_double :: Ptr CStatement -> CColumnIndex -> IO Double + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_last_insert_rowid" + c_sqlite3_last_insert_rowid :: Ptr CConnection -> IO Int64 + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_changes" + c_sqlite3_changes :: Ptr CConnection -> IO CInt + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_total_changes" + c_sqlite3_total_changes :: Ptr CConnection -> IO CInt + +-- do not use unsafe import here, it might call back to haskell +-- via the CFuncDestroy argument + +-- | +foreign import capi "sqlite3.h sqlite3_create_function_v2" + c_sqlite3_create_function_v2 :: + Ptr CConnection -> + -- | Name of the function. + CString -> + -- | Number of arguments. + CArgCount -> + -- | Preferred text encoding (also used to pass flags). + CInt -> + -- | User data. + Ptr a -> + FunPtr CFunc -> + FunPtr CFunc -> + FunPtr CFuncFinal -> + FunPtr (CFuncDestroy a) -> + IO CError + +type CFunc = Ptr CContext -> CArgCount -> Ptr (Ptr CValue) -> IO () + +type CFuncFinal = Ptr CContext -> IO () + +type CFuncDestroy a = Ptr a -> IO () + +-- | +-- +foreign import ccall "wrapper" + mkCFunc :: CFunc -> IO (FunPtr CFunc) + +-- | +-- +foreign import ccall "wrapper" + mkCFuncFinal :: CFuncFinal -> IO (FunPtr CFuncFinal) + +-- | +-- +foreign import ccall "wrapper" + mkCFuncDestroy :: CFuncDestroy a -> IO (FunPtr (CFuncDestroy a)) + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_user_data" + c_sqlite3_user_data :: Ptr CContext -> IO (Ptr a) + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_context_db_handle" + c_sqlite3_context_db_handle :: Ptr CContext -> IO (Ptr CConnection) + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_aggregate_context" + c_sqlite3_aggregate_context :: Ptr CContext -> CNumBytes -> IO (Ptr a) + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_value_type" + c_sqlite3_value_type :: Ptr CValue -> IO CColumnType + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_value_bytes" + c_sqlite3_value_bytes :: Ptr CValue -> IO CNumBytes + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_value_blob" + c_sqlite3_value_blob :: Ptr CValue -> IO (Ptr a) + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_value_text" + c_sqlite3_value_text :: Ptr CValue -> IO CString + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_value_int64" + c_sqlite3_value_int64 :: Ptr CValue -> IO Int64 + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_value_double" + c_sqlite3_value_double :: Ptr CValue -> IO Double + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_result_null" + c_sqlite3_result_null :: Ptr CContext -> IO () + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_result_blob" + c_sqlite3_result_blob :: Ptr CContext -> Ptr a -> CNumBytes -> Ptr CDestructor -> IO () + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_result_zeroblob" + c_sqlite3_result_zeroblob :: Ptr CContext -> CNumBytes -> IO () + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_result_text" + c_sqlite3_result_text :: Ptr CContext -> CString -> CNumBytes -> Ptr CDestructor -> IO () + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_result_int64" + c_sqlite3_result_int64 :: Ptr CContext -> Int64 -> IO () + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_result_double" + c_sqlite3_result_double :: Ptr CContext -> Double -> IO () + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_result_value" + c_sqlite3_result_value :: Ptr CContext -> Ptr CValue -> IO () + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_result_error" + c_sqlite3_result_error :: Ptr CContext -> CString -> CNumBytes -> IO () + +-- | +foreign import capi "sqlite3.h sqlite3_create_collation_v2" + c_sqlite3_create_collation_v2 :: + Ptr CConnection -> + -- | Name of the collation. + CString -> + -- | Text encoding. + CInt -> + -- | User data. + Ptr a -> + FunPtr (CCompare a) -> + FunPtr (CFuncDestroy a) -> + IO CError + +type CCompare a = Ptr a -> CNumBytes -> CString -> CNumBytes -> CString -> IO CInt + +-- | +-- +foreign import ccall "wrapper" + mkCCompare :: CCompare a -> IO (FunPtr (CCompare a)) + +-- | +foreign import capi "sqlite3.h sqlite3_free" + c_sqlite3_free :: Ptr a -> IO () + +-- | +foreign import capi "sqlite3.h &sqlite3_free" + c_sqlite3_free_p :: FunPtr (Ptr a -> IO ()) + +-- | +foreign import capi "sqlite3.h sqlite3_enable_load_extension" + c_sqlite3_enable_load_extension :: Ptr CConnection -> Bool -> IO CError + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_wal_hook" + c_sqlite3_wal_hook :: Ptr CConnection -> FunPtr CWalHook -> Ptr a -> IO (Ptr ()) + +type CWalHook = Ptr () -> Ptr CConnection -> CString -> CInt -> IO CError + +-- | +-- +foreign import ccall "wrapper" + mkCWalHook :: CWalHook -> IO (FunPtr CWalHook) + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_blob_open" + c_sqlite3_blob_open :: + Ptr CConnection -> + -- | Database name. + CString -> + -- | Table name. + CString -> + -- | Column name. + CString -> + -- | Row ROWID. + Int64 -> + -- | Flags. + CInt -> + -- | OUT: Blob handle, will be NULL on error. + Ptr (Ptr CBlob) -> + IO CError + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_blob_close" + c_sqlite3_blob_close :: Ptr CBlob -> IO CError + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_blob_reopen" + c_sqlite3_blob_reopen :: Ptr CBlob -> Int64 -> IO CError + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_blob_bytes" + c_sqlite3_blob_bytes :: Ptr CBlob -> IO CInt + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_blob_read" + c_sqlite3_blob_read :: Ptr CBlob -> Ptr a -> CInt -> CInt -> IO CError + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_blob_write" + c_sqlite3_blob_write :: Ptr CBlob -> Ptr a -> CInt -> CInt -> IO CError + +-- | +foreign import capi "sqlite3.h sqlite3_backup_init" + c_sqlite3_backup_init :: + -- | Destination database handle. + Ptr CConnection -> + -- | Destination database name. + CString -> + -- | Source database handle. + Ptr CConnection -> + -- | Source database name. + CString -> + IO (Ptr CBackup) + +-- | +foreign import capi "sqlite3.h sqlite3_backup_finish" + c_sqlite3_backup_finish :: Ptr CBackup -> IO CError + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_backup_step" + c_sqlite3_backup_step :: Ptr CBackup -> CInt -> IO CError + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_backup_remaining" + c_sqlite3_backup_remaining :: Ptr CBackup -> IO CInt + +-- | +foreign import capi unsafe "sqlite3.h sqlite3_backup_pagecount" + c_sqlite3_backup_pagecount :: Ptr CBackup -> IO CInt diff --git a/lib-bindings/Sqlite/Types.hsc b/lib-bindings/Sqlite/Types.hsc new file mode 100644 --- /dev/null +++ b/lib-bindings/Sqlite/Types.hsc @@ -0,0 +1,663 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE BlockArguments #-} +module Sqlite.Types ( + -- * Objects + -- | + CConnection, + CStatement, + CValue, + CContext, + CBlob, + CBackup, + + -- * Enumerations + -- * Open V2 arguments + COpenV2Flags (..), + encodeOpenV2ModeAndFlags, + OpenV2Mode (..), + OpenV2Flag (..), + + -- ** Error + CError(..), + decodeError, + encodeError, + Error(..), + + -- ** ColumnType + CColumnType(..), + decodeColumnType, + encodeColumnType, + ColumnType(..), + + -- * Indices + ParamIndex(..), + ColumnIndex(..), + ColumnCount, + + -- ** Indices (FFI) + CParamIndex(..), + CColumnIndex(..), + CColumnCount, + + -- * Miscellaneous + CNumBytes(..), + CDestructor, + c_SQLITE_STATIC, + c_SQLITE_TRANSIENT, + c_SQLITE_UTF8, + + -- * Custom functions + ArgCount(..), + ArgIndex, + CArgCount(..), + c_SQLITE_DETERMINISTIC, + + -- * Conversion to and from FFI types + FFIType(..), +) where + +#include + +import Foreign.C.Types +import Foreign.Ptr +import Data.Bits (Bits, (.|.)) + +-- | +data OpenV2Mode = + OpenV2ReadOnly + | OpenV2ReadWrite + | OpenV2ReadWriteCreate + deriving (Eq, Show) + +encodeOpenV2Mode :: OpenV2Mode -> COpenV2Flags +encodeOpenV2Mode mode = COpenV2Flags $ case mode of + OpenV2ReadOnly -> #{const SQLITE_OPEN_READONLY} + OpenV2ReadWrite -> #{const SQLITE_OPEN_READWRITE} + OpenV2ReadWriteCreate -> #{const SQLITE_OPEN_READWRITE} .|. #{const SQLITE_OPEN_CREATE} + +-- | +data OpenV2Flag = + OpenV2URI + | OpenV2Memory + | OpenV2NoMutex + | OpenV2FullMutex + | OpenV2SharedCache + | OpenV2PrivateCache + | OpenV2ExtendedResultCode + | OpenV2NoFollow + deriving (Eq, Show) + +-- | +newtype COpenV2Flags = COpenV2Flags CInt + deriving stock (Eq, Show) + deriving newtype Bits + +encodeOpenV2Flag :: OpenV2Flag -> COpenV2Flags +encodeOpenV2Flag flag = COpenV2Flags $ case flag of + OpenV2URI -> #{const SQLITE_OPEN_URI} + OpenV2Memory -> #{const SQLITE_OPEN_MEMORY } + OpenV2NoMutex -> #{const SQLITE_OPEN_NOMUTEX } + OpenV2FullMutex -> #{const SQLITE_OPEN_FULLMUTEX} + OpenV2SharedCache -> #{const SQLITE_OPEN_SHAREDCACHE} + OpenV2PrivateCache -> #{const SQLITE_OPEN_PRIVATECACHE} + -- SQLITE_OPEN_EXRESCODE was added in 3.37.0 + OpenV2ExtendedResultCode -> #{const SQLITE_OPEN_EXRESCODE} + OpenV2NoFollow -> #{const SQLITE_OPEN_NOFOLLOW} + +encodeOpenV2ModeAndFlags :: OpenV2Mode -> [OpenV2Flag] -> COpenV2Flags +encodeOpenV2ModeAndFlags (encodeOpenV2Mode -> mode) (map encodeOpenV2Flag -> flags) = + mode .|. foldr (.|.) (COpenV2Flags 0) flags + +-- Result code documentation copied from + +-- | +data Error = ErrorOK -- ^ Successful result + | ErrorError -- ^ SQL error or missing database + | ErrorInternal -- ^ Internal logic error in SQLite + | ErrorPermission -- ^ Access permission denied + | ErrorAbort -- ^ Callback routine requested an abort + | ErrorBusy -- ^ The database file is locked + | ErrorLocked -- ^ A table in the database is locked + | ErrorNoMemory -- ^ A @malloc()@ failed + | ErrorReadOnly -- ^ Attempt to write a readonly database + | ErrorInterrupt -- ^ Operation terminated by @sqlite3_interrupt()@ + | ErrorIO -- ^ Some kind of disk I/O error occurred + | ErrorCorrupt -- ^ The database disk image is malformed + | ErrorNotFound -- ^ Unknown opcode in @sqlite3_file_control()@ + | ErrorFull -- ^ Insertion failed because database is full + | ErrorCan'tOpen -- ^ Unable to open the database file + | ErrorProtocol -- ^ Database lock protocol error + | ErrorEmpty -- ^ Database is empty + | ErrorSchema -- ^ The database schema changed + | ErrorTooBig -- ^ String or BLOB exceeds size limit + | ErrorConstraint -- ^ Abort due to constraint violation + | ErrorMismatch -- ^ Data type mismatch + | ErrorMisuse -- ^ Library used incorrectly + | ErrorNoLargeFileSupport -- ^ Uses OS features not supported on host + | ErrorAuthorization -- ^ Authorization denied + | ErrorFormat -- ^ Auxiliary database format error + | ErrorRange -- ^ 2nd parameter to sqlite3_bind out of range + | ErrorNotADatabase -- ^ File opened that is not a database file + | ErrorNotice -- ^ Notifications from sqlite3_log() + | ErrorWarning -- ^ Warnings from sqlite3_log() + | ErrorRow -- ^ @sqlite3_step()@ has another row ready + | ErrorDone -- ^ @sqlite3_step()@ has finished executing + -- Extended result codes. + -- https://www.sqlite.org/rescode.html + | ErrorAbortRollback + | ErrorAuthorizationUser + | ErrorBusyRecovery + | ErrorBusySnapshot + | ErrorBusyTimeout + | ErrorCan'tOpenConvPath + | ErrorCan'tOpenDirtyWAL + | ErrorCan'tOpenFullPath + | ErrorCan'tOpenIsDir + | ErrorCan'tOpenNoTempDir + | ErrorCan'tOpenSymlink + | ErrorConstraintCheck + | ErrorConstraintCommitHook + | ErrorConstraintDatatype + | ErrorConstraintForeignKey + | ErrorConstraintFunction + | ErrorConstraintNotNull + | ErrorConstraintPinned + | ErrorConstraintPrimaryKey + | ErrorConstraintRowid + | ErrorConstraintTrigger + | ErrorConstraintUnique + | ErrorConstraintVTab + | ErrorCorruptIndex + | ErrorCorruptSequence + | ErrorCorruptVTab + | ErrorMissingColSeq + | ErrorRetry + | ErrorSnapshot + | ErrorIOAccess + | ErrorIOAuth + | ErrorIOBeginAtomic + | ErrorIOBlocked + | ErrorIOCheckReservedLock + | ErrorIOCheckClose + | ErrorIOCheckCommitAtomic + | ErrorIOConvPath + | ErrorIOCorruptFS + | ErrorIOData + | ErrorIODelete + | ErrorIODeleteNOENT + | ErrorIODirClose + | ErrorIODirFSync + | ErrorIODirFStat + | ErrorIOFSync + | ErrorIOGetTempPath + | ErrorIOLock + | ErrorIOMmap + | ErrorIONoMem + | ErrorIORDLock + | ErrorIORead + | ErrorIORollbackAtomic + | ErrorIOSeek + | ErrorIOShmLock + | ErrorIOShmMap + | ErrorIOShmOpen + | ErrorIOShmSize + | ErrorIOShortRead + | ErrorIOTruncate + | ErrorIOUnlock + | ErrorIOVNode + | ErrorIOWrite + | ErrorLockedSharedCache + | ErrorLockedVTab + | ErrorNoticeRecoverRollback + | ErrorNoticeRecoverWAL + | ErrorOKLoadPermanently + | ErrorReadOnlyCan'tInit + | ErrorReadOnlyCan'tLock + | ErrorReadOnlyDBMoved + | ErrorReadOnlyDirectory + | ErrorReadRecovery + | ErrorReadRollback + | ErrorWarningAutoindex + deriving (Eq, Show) + +-- | +data ColumnType = IntegerColumn + | FloatColumn + | TextColumn + | BlobColumn + | NullColumn + deriving (Eq, Show) + +-- | +-- +-- @CConnection@ = @sqlite3@ +data CConnection + +-- | +-- +-- @CStatement@ = @sqlite3_stmt@ +data CStatement + +-- | +-- +-- @CValue@ = @sqlite3_value@ +data CValue + +-- | +-- +-- @CContext@ = @sqlite3_context@ +data CContext + +-- | +-- +-- @CBlob@ = @sqlite3_blob@ +data CBlob + +-- | +-- +-- @CBackup@ = @sqlite3_backup@ +data CBackup + +-- | Index of a parameter in a parameterized query. +-- Parameter indices start from 1. +-- +-- When a query is 'Database.SQLite3.prepare'd, SQLite allocates an +-- array indexed from 1 to the highest parameter index. For example: +-- +-- >>Right stmt <- prepare conn "SELECT ?1, ?5, ?3, ?" +-- >>bindParameterCount stmt +-- >ParamIndex 6 +-- +-- This will allocate an array indexed from 1 to 6 (@?@ takes the highest +-- preceding index plus one). The array is initialized with null values. +-- When you bind a parameter with 'Database.SQLite3.bindSQLData', it assigns a +-- new value to one of these indices. +-- +-- See for the syntax of +-- parameter placeholders, and how parameter indices are assigned. +newtype ParamIndex = ParamIndex Int + deriving (Eq, Ord, Enum, Num, Real, Integral) + +-- | This just shows the underlying integer, without the data constructor. +instance Show ParamIndex where + show (ParamIndex n) = show n + +-- | Limit min/max bounds to fit into SQLite's native parameter ranges. +instance Bounded ParamIndex where + minBound = ParamIndex (fromIntegral (minBound :: CInt)) + maxBound = ParamIndex (fromIntegral (maxBound :: CInt)) + +-- | Index of a column in a result set. Column indices start from 0. +newtype ColumnIndex = ColumnIndex Int + deriving (Eq, Ord, Enum, Num, Real, Integral) + +-- | This just shows the underlying integer, without the data constructor. +instance Show ColumnIndex where + show (ColumnIndex n) = show n + +-- | Limit min/max bounds to fit into SQLite's native parameter ranges. +instance Bounded ColumnIndex where + minBound = ColumnIndex (fromIntegral (minBound :: CInt)) + maxBound = ColumnIndex (fromIntegral (maxBound :: CInt)) + +-- | Number of columns in a result set. +type ColumnCount = ColumnIndex + +newtype CParamIndex = CParamIndex CInt + deriving (Eq, Ord, Enum, Num, Real, Integral) + +-- | This just shows the underlying integer, without the data constructor. +instance Show CParamIndex where + show (CParamIndex n) = show n + +newtype CColumnIndex = CColumnIndex CInt + deriving (Eq, Ord, Enum, Num, Real, Integral) + +-- | This just shows the underlying integer, without the data constructor. +instance Show CColumnIndex where + show (CColumnIndex n) = show n + +type CColumnCount = CColumnIndex + +newtype CNumBytes = CNumBytes CInt + deriving (Eq, Ord, Show, Enum, Num, Real, Integral) + +-- | +-- +-- @Ptr CDestructor@ = @sqlite3_destructor_type@ +data CDestructor + +-- | Tells SQLite3 that the content pointer is constant and will never change +c_SQLITE_STATIC :: Ptr CDestructor +c_SQLITE_STATIC = intPtrToPtr 0 + +-- | Tells SQLite3 to make its own private copy of the data +c_SQLITE_TRANSIENT :: Ptr CDestructor +c_SQLITE_TRANSIENT = intPtrToPtr (-1) + +c_SQLITE_UTF8 :: CInt +c_SQLITE_UTF8 = #{const SQLITE_UTF8} + +-- | Number of arguments of a user defined SQL function. +newtype ArgCount = ArgCount Int + deriving (Eq, Ord, Enum, Num, Real, Integral) + +-- | This just shows the underlying integer, without the data constructor. +instance Show ArgCount where + show (ArgCount n) = show n + +instance Bounded ArgCount where + minBound = ArgCount 0 + maxBound = ArgCount (#{const SQLITE_LIMIT_FUNCTION_ARG}) + +-- | Index of an argument to a custom function. Indices start from 0. +type ArgIndex = ArgCount + +newtype CArgCount = CArgCount CInt + deriving (Eq, Ord, Enum, Num, Real, Integral) + +-- | This just shows the underlying integer, without the data constructor. +instance Show CArgCount where + show (CArgCount n) = show n + +instance Bounded CArgCount where + minBound = CArgCount (-1) + maxBound = CArgCount #{const SQLITE_LIMIT_FUNCTION_ARG} + +-- | Tells SQLite3 that the defined custom SQL function is deterministic. +c_SQLITE_DETERMINISTIC :: CInt +c_SQLITE_DETERMINISTIC = #{const SQLITE_DETERMINISTIC} + +-- | +newtype CError = CError CInt + deriving (Eq, Show) + +-- | Note that this is a partial function. If the error code is invalid, or +-- perhaps introduced in a newer version of SQLite but this library has not +-- been updated to support it, the result is undefined. +-- +-- To be clear, if 'decodeError' fails, it is /undefined behavior/, not an +-- exception you can handle. +-- +-- Therefore, do not use direct-sqlite with a different version of SQLite than +-- the one bundled (currently, 3.24.0). If you do, ensure that 'decodeError' +-- and 'decodeColumnType' are still exhaustive. +decodeError :: CError -> Error +decodeError (CError n) = case n of + #{const SQLITE_OK} -> ErrorOK + #{const SQLITE_ERROR} -> ErrorError + #{const SQLITE_INTERNAL} -> ErrorInternal + #{const SQLITE_PERM} -> ErrorPermission + #{const SQLITE_ABORT} -> ErrorAbort + #{const SQLITE_BUSY} -> ErrorBusy + #{const SQLITE_LOCKED} -> ErrorLocked + #{const SQLITE_NOMEM} -> ErrorNoMemory + #{const SQLITE_READONLY} -> ErrorReadOnly + #{const SQLITE_INTERRUPT} -> ErrorInterrupt + #{const SQLITE_IOERR} -> ErrorIO + #{const SQLITE_CORRUPT} -> ErrorCorrupt + #{const SQLITE_NOTFOUND} -> ErrorNotFound + #{const SQLITE_FULL} -> ErrorFull + #{const SQLITE_CANTOPEN} -> ErrorCan'tOpen + #{const SQLITE_PROTOCOL} -> ErrorProtocol + #{const SQLITE_EMPTY} -> ErrorEmpty + #{const SQLITE_SCHEMA} -> ErrorSchema + #{const SQLITE_TOOBIG} -> ErrorTooBig + #{const SQLITE_CONSTRAINT} -> ErrorConstraint + #{const SQLITE_MISMATCH} -> ErrorMismatch + #{const SQLITE_MISUSE} -> ErrorMisuse + #{const SQLITE_NOLFS} -> ErrorNoLargeFileSupport + #{const SQLITE_AUTH} -> ErrorAuthorization + #{const SQLITE_FORMAT} -> ErrorFormat + #{const SQLITE_RANGE} -> ErrorRange + #{const SQLITE_NOTADB} -> ErrorNotADatabase + #{const SQLITE_NOTICE} -> ErrorNotice + #{const SQLITE_WARNING} -> ErrorWarning + #{const SQLITE_ROW} -> ErrorRow + #{const SQLITE_DONE} -> ErrorDone + -- Extended result codes. + -- https://www.sqlite.org/rescode.html + #{const SQLITE_ABORT_ROLLBACK} -> ErrorAbortRollback + #{const SQLITE_AUTH_USER} -> ErrorAuthorizationUser + #{const SQLITE_BUSY_RECOVERY} -> ErrorBusyRecovery + #{const SQLITE_BUSY_SNAPSHOT} -> ErrorBusySnapshot + #{const SQLITE_BUSY_TIMEOUT} -> ErrorBusyTimeout + #{const SQLITE_CANTOPEN_CONVPATH} -> ErrorCan'tOpenConvPath + #{const SQLITE_CANTOPEN_DIRTYWAL} -> ErrorCan'tOpenDirtyWAL + #{const SQLITE_CANTOPEN_FULLPATH} -> ErrorCan'tOpenFullPath + #{const SQLITE_CANTOPEN_ISDIR} -> ErrorCan'tOpenIsDir + #{const SQLITE_CANTOPEN_NOTEMPDIR} -> ErrorCan'tOpenNoTempDir + #{const SQLITE_CANTOPEN_SYMLINK} -> ErrorCan'tOpenSymlink + #{const SQLITE_CONSTRAINT_CHECK} -> ErrorConstraintCheck + #{const SQLITE_CONSTRAINT_COMMITHOOK} -> ErrorConstraintCommitHook + #{const SQLITE_CONSTRAINT_DATATYPE} -> ErrorConstraintDatatype + #{const SQLITE_CONSTRAINT_FOREIGNKEY} -> ErrorConstraintForeignKey + #{const SQLITE_CONSTRAINT_FUNCTION} -> ErrorConstraintFunction + #{const SQLITE_CONSTRAINT_NOTNULL} -> ErrorConstraintNotNull + #{const SQLITE_CONSTRAINT_PINNED} -> ErrorConstraintPinned + #{const SQLITE_CONSTRAINT_PRIMARYKEY} -> ErrorConstraintPrimaryKey + #{const SQLITE_CONSTRAINT_ROWID} -> ErrorConstraintRowid + #{const SQLITE_CONSTRAINT_TRIGGER} -> ErrorConstraintTrigger + #{const SQLITE_CONSTRAINT_UNIQUE} -> ErrorConstraintUnique + #{const SQLITE_CONSTRAINT_VTAB} -> ErrorConstraintVTab + #{const SQLITE_CORRUPT_INDEX} -> ErrorCorruptIndex + #{const SQLITE_CORRUPT_SEQUENCE} -> ErrorCorruptSequence + #{const SQLITE_CORRUPT_VTAB} -> ErrorCorruptVTab + #{const SQLITE_ERROR_MISSING_COLLSEQ} -> ErrorMissingColSeq + #{const SQLITE_ERROR_RETRY} -> ErrorRetry + #{const SQLITE_ERROR_SNAPSHOT} -> ErrorSnapshot + #{const SQLITE_IOERR_ACCESS} -> ErrorIOAccess + #{const SQLITE_IOERR_AUTH} -> ErrorIOAuth + #{const SQLITE_IOERR_BEGIN_ATOMIC} -> ErrorIOBeginAtomic + #{const SQLITE_IOERR_BLOCKED} -> ErrorIOBlocked + #{const SQLITE_IOERR_CHECKRESERVEDLOCK} -> ErrorIOCheckReservedLock + #{const SQLITE_IOERR_CLOSE} -> ErrorIOCheckClose + #{const SQLITE_IOERR_COMMIT_ATOMIC} -> ErrorIOCheckCommitAtomic + #{const SQLITE_IOERR_CONVPATH} -> ErrorIOConvPath + #{const SQLITE_IOERR_CORRUPTFS} -> ErrorIOCorruptFS + #{const SQLITE_IOERR_DATA} -> ErrorIOData + #{const SQLITE_IOERR_DELETE} -> ErrorIODelete + #{const SQLITE_IOERR_DELETE_NOENT} -> ErrorIODeleteNOENT + #{const SQLITE_IOERR_DIR_CLOSE} -> ErrorIODirClose + #{const SQLITE_IOERR_DIR_FSYNC} -> ErrorIODirFSync + #{const SQLITE_IOERR_FSTAT} -> ErrorIODirFStat + #{const SQLITE_IOERR_FSYNC} -> ErrorIOFSync + #{const SQLITE_IOERR_GETTEMPPATH} -> ErrorIOGetTempPath + #{const SQLITE_IOERR_LOCK} -> ErrorIOLock + #{const SQLITE_IOERR_MMAP} -> ErrorIOMmap + #{const SQLITE_IOERR_NOMEM} -> ErrorIONoMem + #{const SQLITE_IOERR_RDLOCK} -> ErrorIORDLock + #{const SQLITE_IOERR_READ} -> ErrorIORead + #{const SQLITE_IOERR_ROLLBACK_ATOMIC} -> ErrorIORollbackAtomic + #{const SQLITE_IOERR_SEEK} -> ErrorIOSeek + #{const SQLITE_IOERR_SHMLOCK} -> ErrorIOShmLock + #{const SQLITE_IOERR_SHMMAP} -> ErrorIOShmMap + #{const SQLITE_IOERR_SHMOPEN} -> ErrorIOShmOpen + #{const SQLITE_IOERR_SHMSIZE} -> ErrorIOShmSize + #{const SQLITE_IOERR_SHORT_READ} -> ErrorIOShortRead + #{const SQLITE_IOERR_TRUNCATE} -> ErrorIOTruncate + #{const SQLITE_IOERR_UNLOCK} -> ErrorIOUnlock + #{const SQLITE_IOERR_VNODE} -> ErrorIOVNode + #{const SQLITE_IOERR_WRITE} -> ErrorIOWrite + #{const SQLITE_LOCKED_SHAREDCACHE} -> ErrorLockedSharedCache + #{const SQLITE_LOCKED_VTAB} -> ErrorLockedVTab + #{const SQLITE_NOTICE_RECOVER_ROLLBACK} -> ErrorNoticeRecoverRollback + #{const SQLITE_NOTICE_RECOVER_WAL} -> ErrorNoticeRecoverWAL + #{const SQLITE_OK_LOAD_PERMANENTLY} -> ErrorOKLoadPermanently + #{const SQLITE_READONLY_CANTINIT} -> ErrorReadOnlyCan'tInit + #{const SQLITE_READONLY_CANTLOCK} -> ErrorReadOnlyCan'tLock + #{const SQLITE_READONLY_DBMOVED} -> ErrorReadOnlyDBMoved + #{const SQLITE_READONLY_DIRECTORY} -> ErrorReadOnlyDirectory + #{const SQLITE_READONLY_RECOVERY} -> ErrorReadRecovery + #{const SQLITE_READONLY_ROLLBACK} -> ErrorReadRollback + #{const SQLITE_WARNING_AUTOINDEX} -> ErrorWarningAutoindex + _ -> error $ "decodeError " ++ show n + +encodeError :: Error -> CError +encodeError err = CError $ case err of + ErrorOK -> #{const SQLITE_OK} + ErrorError -> #{const SQLITE_ERROR} + ErrorInternal -> #{const SQLITE_INTERNAL} + ErrorPermission -> #{const SQLITE_PERM} + ErrorAbort -> #{const SQLITE_ABORT} + ErrorBusy -> #{const SQLITE_BUSY} + ErrorLocked -> #{const SQLITE_LOCKED} + ErrorNoMemory -> #{const SQLITE_NOMEM} + ErrorReadOnly -> #{const SQLITE_READONLY} + ErrorInterrupt -> #{const SQLITE_INTERRUPT} + ErrorIO -> #{const SQLITE_IOERR} + ErrorCorrupt -> #{const SQLITE_CORRUPT} + ErrorNotFound -> #{const SQLITE_NOTFOUND} + ErrorFull -> #{const SQLITE_FULL} + ErrorCan'tOpen -> #{const SQLITE_CANTOPEN} + ErrorProtocol -> #{const SQLITE_PROTOCOL} + ErrorEmpty -> #{const SQLITE_EMPTY} + ErrorSchema -> #{const SQLITE_SCHEMA} + ErrorTooBig -> #{const SQLITE_TOOBIG} + ErrorConstraint -> #{const SQLITE_CONSTRAINT} + ErrorMismatch -> #{const SQLITE_MISMATCH} + ErrorMisuse -> #{const SQLITE_MISUSE} + ErrorNoLargeFileSupport -> #{const SQLITE_NOLFS} + ErrorAuthorization -> #{const SQLITE_AUTH} + ErrorFormat -> #{const SQLITE_FORMAT} + ErrorRange -> #{const SQLITE_RANGE} + ErrorNotADatabase -> #{const SQLITE_NOTADB} + ErrorNotice -> #{const SQLITE_NOTICE} + ErrorWarning -> #{const SQLITE_WARNING} + ErrorRow -> #{const SQLITE_ROW} + ErrorDone -> #{const SQLITE_DONE} + -- Extended result codes. + -- https://www.sqlite.org/rescode.html + ErrorAbortRollback -> #{const SQLITE_ABORT_ROLLBACK} + ErrorAuthorizationUser -> #{const SQLITE_AUTH_USER} + ErrorBusyRecovery -> #{const SQLITE_BUSY_RECOVERY} + ErrorBusySnapshot -> #{const SQLITE_BUSY_SNAPSHOT} + ErrorBusyTimeout -> #{const SQLITE_BUSY_TIMEOUT} + ErrorCan'tOpenConvPath -> #{const SQLITE_CANTOPEN_CONVPATH} + ErrorCan'tOpenDirtyWAL -> #{const SQLITE_CANTOPEN_DIRTYWAL} + ErrorCan'tOpenFullPath -> #{const SQLITE_CANTOPEN_FULLPATH} + ErrorCan'tOpenIsDir -> #{const SQLITE_CANTOPEN_ISDIR} + ErrorCan'tOpenNoTempDir -> #{const SQLITE_CANTOPEN_NOTEMPDIR} + ErrorCan'tOpenSymlink -> #{const SQLITE_CANTOPEN_SYMLINK} + ErrorConstraintCheck -> #{const SQLITE_CONSTRAINT_CHECK} + ErrorConstraintCommitHook -> #{const SQLITE_CONSTRAINT_COMMITHOOK} + ErrorConstraintDatatype -> #{const SQLITE_CONSTRAINT_DATATYPE} + ErrorConstraintForeignKey -> #{const SQLITE_CONSTRAINT_FOREIGNKEY} + ErrorConstraintFunction -> #{const SQLITE_CONSTRAINT_FUNCTION} + ErrorConstraintNotNull -> #{const SQLITE_CONSTRAINT_NOTNULL} + ErrorConstraintPinned -> #{const SQLITE_CONSTRAINT_PINNED} + ErrorConstraintPrimaryKey -> #{const SQLITE_CONSTRAINT_PRIMARYKEY} + ErrorConstraintRowid -> #{const SQLITE_CONSTRAINT_ROWID} + ErrorConstraintTrigger -> #{const SQLITE_CONSTRAINT_TRIGGER} + ErrorConstraintUnique -> #{const SQLITE_CONSTRAINT_UNIQUE} + ErrorConstraintVTab -> #{const SQLITE_CONSTRAINT_VTAB} + ErrorCorruptIndex -> #{const SQLITE_CORRUPT_INDEX} + ErrorCorruptSequence -> #{const SQLITE_CORRUPT_SEQUENCE} + ErrorCorruptVTab -> #{const SQLITE_CORRUPT_VTAB} + ErrorMissingColSeq -> #{const SQLITE_ERROR_MISSING_COLLSEQ} + ErrorRetry -> #{const SQLITE_ERROR_RETRY} + ErrorSnapshot -> #{const SQLITE_ERROR_SNAPSHOT} + ErrorIOAccess -> #{const SQLITE_IOERR_ACCESS} + ErrorIOAuth -> #{const SQLITE_IOERR_AUTH} + ErrorIOBeginAtomic -> #{const SQLITE_IOERR_BEGIN_ATOMIC} + ErrorIOBlocked -> #{const SQLITE_IOERR_BLOCKED} + ErrorIOCheckReservedLock -> #{const SQLITE_IOERR_CHECKRESERVEDLOCK} + ErrorIOCheckClose -> #{const SQLITE_IOERR_CLOSE} + ErrorIOCheckCommitAtomic -> #{const SQLITE_IOERR_COMMIT_ATOMIC} + ErrorIOConvPath -> #{const SQLITE_IOERR_CONVPATH} + ErrorIOCorruptFS -> #{const SQLITE_IOERR_CORRUPTFS} + ErrorIOData -> #{const SQLITE_IOERR_DATA} + ErrorIODelete -> #{const SQLITE_IOERR_DELETE} + ErrorIODeleteNOENT -> #{const SQLITE_IOERR_DELETE_NOENT} + ErrorIODirClose -> #{const SQLITE_IOERR_DIR_CLOSE} + ErrorIODirFSync -> #{const SQLITE_IOERR_DIR_FSYNC} + ErrorIODirFStat -> #{const SQLITE_IOERR_FSTAT} + ErrorIOFSync -> #{const SQLITE_IOERR_FSYNC} + ErrorIOGetTempPath -> #{const SQLITE_IOERR_GETTEMPPATH} + ErrorIOLock -> #{const SQLITE_IOERR_LOCK} + ErrorIOMmap -> #{const SQLITE_IOERR_MMAP} + ErrorIONoMem -> #{const SQLITE_IOERR_NOMEM} + ErrorIORDLock -> #{const SQLITE_IOERR_RDLOCK} + ErrorIORead -> #{const SQLITE_IOERR_READ} + ErrorIORollbackAtomic -> #{const SQLITE_IOERR_ROLLBACK_ATOMIC} + ErrorIOSeek -> #{const SQLITE_IOERR_SEEK} + ErrorIOShmLock -> #{const SQLITE_IOERR_SHMLOCK} + ErrorIOShmMap -> #{const SQLITE_IOERR_SHMMAP} + ErrorIOShmOpen -> #{const SQLITE_IOERR_SHMOPEN} + ErrorIOShmSize -> #{const SQLITE_IOERR_SHMSIZE} + ErrorIOShortRead -> #{const SQLITE_IOERR_SHORT_READ} + ErrorIOTruncate -> #{const SQLITE_IOERR_TRUNCATE} + ErrorIOUnlock -> #{const SQLITE_IOERR_UNLOCK} + ErrorIOVNode -> #{const SQLITE_IOERR_VNODE} + ErrorIOWrite -> #{const SQLITE_IOERR_WRITE} + ErrorLockedSharedCache -> #{const SQLITE_LOCKED_SHAREDCACHE} + ErrorLockedVTab -> #{const SQLITE_LOCKED_VTAB} + ErrorNoticeRecoverRollback -> #{const SQLITE_NOTICE_RECOVER_ROLLBACK} + ErrorNoticeRecoverWAL -> #{const SQLITE_NOTICE_RECOVER_WAL} + ErrorOKLoadPermanently -> #{const SQLITE_OK_LOAD_PERMANENTLY} + ErrorReadOnlyCan'tInit -> #{const SQLITE_READONLY_CANTINIT} + ErrorReadOnlyCan'tLock -> #{const SQLITE_READONLY_CANTLOCK} + ErrorReadOnlyDBMoved -> #{const SQLITE_READONLY_DBMOVED} + ErrorReadOnlyDirectory -> #{const SQLITE_READONLY_DIRECTORY} + ErrorReadRecovery -> #{const SQLITE_READONLY_RECOVERY} + ErrorReadRollback -> #{const SQLITE_READONLY_ROLLBACK} + ErrorWarningAutoindex -> #{const SQLITE_WARNING_AUTOINDEX} + +-- | +newtype CColumnType = CColumnType CInt + deriving (Eq, Show) + +-- | Note that this is a partial function. +-- See 'decodeError' for more information. +decodeColumnType :: CColumnType -> ColumnType +decodeColumnType (CColumnType n) = case n of + #{const SQLITE_INTEGER} -> IntegerColumn + #{const SQLITE_FLOAT} -> FloatColumn + #{const SQLITE_TEXT} -> TextColumn + #{const SQLITE_BLOB} -> BlobColumn + #{const SQLITE_NULL} -> NullColumn + _ -> error $ "decodeColumnType " ++ show n + +encodeColumnType :: ColumnType -> CColumnType +encodeColumnType t = CColumnType $ case t of + IntegerColumn -> #{const SQLITE_INTEGER} + FloatColumn -> #{const SQLITE_FLOAT} + TextColumn -> #{const SQLITE_TEXT} + BlobColumn -> #{const SQLITE_BLOB} + NullColumn -> #{const SQLITE_NULL} + +------------------------------------------------------------------------ +-- Conversion to and from FFI types + +-- | The "Database.SQLite3" and "Database.SQLite3.Direct" modules use +-- higher-level representations of some types than those used in the +-- FFI signatures ("Database.SQLite3.Bindings"). This typeclass +-- helps with the conversions. +class FFIType public ffi | public -> ffi, ffi -> public where + toFFI :: public -> ffi + fromFFI :: ffi -> public + +instance FFIType ParamIndex CParamIndex where + toFFI (ParamIndex n) = CParamIndex (fromIntegral n) + fromFFI (CParamIndex n) = ParamIndex (fromIntegral n) + +instance FFIType ColumnIndex CColumnIndex where + toFFI (ColumnIndex n) = CColumnIndex (fromIntegral n) + fromFFI (CColumnIndex n) = ColumnIndex (fromIntegral n) + +instance FFIType Error CError where + toFFI = encodeError + fromFFI = decodeError + +instance FFIType ColumnType CColumnType where + toFFI = encodeColumnType + fromFFI = decodeColumnType + +instance FFIType ArgCount CArgCount where + toFFI (ArgCount n) = CArgCount (fromIntegral n) + fromFFI (CArgCount n) = ArgCount (fromIntegral n) diff --git a/lib-direct/Sqlite/Direct.hs b/lib-direct/Sqlite/Direct.hs new file mode 100644 --- /dev/null +++ b/lib-direct/Sqlite/Direct.hs @@ -0,0 +1,1047 @@ +{-# LANGUAGE BlockArguments #-} + +-- | +-- This API is a slightly lower-level version of "Sqlite3". Namely: +-- +-- * It returns errors instead of throwing them. +-- +-- * It only uses cheap conversions. None of these bindings convert from +-- 'String' or 'T.Text'. +module Sqlite.Direct + ( -- * Connection management + open, + openV2, + OpenV2Flag (..), + OpenV2Mode (..), + close, + errcode, + errmsg, + setTrace, + getAutoCommit, + setSharedCacheEnabled, + + -- * Simple query execution + + -- | + exec, + execWithCallback, + ExecCallback, + + -- * Statement management + prepare, + getStatementConnection, + step, + stepNoCB, + reset, + finalize, + clearBindings, + statementSql, + + -- * Parameter and column information + bindParameterCount, + bindParameterName, + bindParameterIndex, + columnCount, + columnName, + + -- * Binding values to a prepared statement + + -- | + bindInt64, + bindDouble, + bindText, + bindBlob, + bindZeroBlob, + bindNull, + + -- * Reading the result row + + -- | + columnType, + columnInt64, + columnDouble, + columnText, + columnBlob, + + -- * control loading of extensions + setLoadExtensionEnabled, + + -- * Result statistics + lastInsertRowId, + changes, + totalChanges, + + -- * Create custom SQL functions + createFunction, + createAggregate, + deleteFunction, + + -- ** Extract function arguments + funcArgCount, + funcArgType, + funcArgInt64, + funcArgDouble, + funcArgText, + funcArgBlob, + + -- ** Set the result of a function + funcResultInt64, + funcResultDouble, + funcResultText, + funcResultBlob, + funcResultZeroBlob, + funcResultNull, + getFuncContextConnection, + + -- * Create custom collations + createCollation, + deleteCollation, + + -- * Interrupting a long-running query + interrupt, + + -- * Incremental blob I/O + blobOpen, + blobClose, + blobReopen, + blobBytes, + blobRead, + blobReadBuf, + blobWrite, + + -- * Online Backup API + + -- | and + -- + backupInit, + backupFinish, + backupStep, + backupRemaining, + backupPagecount, + + -- * Types + Connection (..), + PreparedStatement (..), + ColumnType (..), + FuncContext (..), + FuncArgs (..), + Blob (..), + Backup (..), + + -- ** Results and errors + StepResult (..), + BackupStepResult (..), + Error (..), + + -- ** Special types + Utf8 (..), + ParamIndex (..), + ColumnIndex (..), + ColumnCount, + ArgCount (..), + ArgIndex, + ) +where + +import Control.Exception as E +import Control.Monad (join, unless) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Internal qualified as BSI +import Data.ByteString.Unsafe qualified as BSU +import Data.IORef +import Foreign +import Foreign.C +import Sqlite.Bindings +import System.IO.Unsafe qualified as IOU + +newtype Connection = Connection (Ptr CConnection) + deriving (Eq, Show) + +newtype PreparedStatement = PreparedStatement (Ptr CStatement) + deriving (Eq, Show) + +data StepResult + = Row + | Done + deriving (Eq, Show) + +data BackupStepResult + = -- | There are still more pages to be copied. + BackupOK + | -- | All pages were successfully copied. + BackupDone + deriving (Eq, Show) + +-- | A 'ByteString' containing UTF8-encoded text with no NUL characters. +newtype Utf8 = Utf8 ByteString + deriving (Eq, Ord, Semigroup, Monoid) + +packUtf8 :: a -> (Utf8 -> a) -> CString -> IO a +packUtf8 n f cstr + | cstr == nullPtr = return n + | otherwise = f . Utf8 <$> BS.packCString cstr + +packCStringLen :: CString -> CNumBytes -> IO ByteString +packCStringLen cstr len = + BS.packCStringLen (cstr, fromIntegral len) + +packUtf8Array :: IO a -> (Utf8 -> IO a) -> Int -> Ptr CString -> IO [a] +packUtf8Array onNull onUtf8 count base = + peekArray count base >>= mapM (join . packUtf8 onNull onUtf8) + +-- | Like 'unsafeUseAsCStringLen', but if the string is empty, +-- never pass the callback a null pointer. +unsafeUseAsCStringLenNoNull :: ByteString -> (CString -> CNumBytes -> IO a) -> IO a +unsafeUseAsCStringLenNoNull bs cb + | BS.null bs = cb (intPtrToPtr 1) 0 + | otherwise = BSU.unsafeUseAsCStringLen bs $ \(ptr, len) -> + cb ptr (fromIntegral len) + +wrapNullablePtr :: (Ptr a -> b) -> Ptr a -> Maybe b +wrapNullablePtr f ptr + | ptr == nullPtr = Nothing + | otherwise = Just (f ptr) + +-- Convert a 'CError' to a 'Either Error', in the common case where +-- SQLITE_OK signals success and anything else signals an error. +-- +-- Note that SQLITE_OK == 0. +toResult :: a -> CError -> Either Error a +toResult a (CError 0) = Right a +toResult _ code = Left $ decodeError code + +-- Only perform the action if the 'CError' is SQLITE_OK. +toResultM :: (Monad m) => m a -> CError -> m (Either Error a) +toResultM m (CError 0) = Right <$> m +toResultM _ code = return $ Left $ decodeError code + +toStepResult :: CError -> Either Error StepResult +toStepResult code = + case decodeError code of + ErrorRow -> Right Row + ErrorDone -> Right Done + err -> Left err + +toBackupStepResult :: CError -> Either Error BackupStepResult +toBackupStepResult code = + case decodeError code of + ErrorOK -> Right BackupOK + ErrorDone -> Right BackupDone + err -> Left err + +-- | The context in which a custom SQL function is executed. +newtype FuncContext = FuncContext (Ptr CContext) + deriving (Eq, Show) + +-- | The arguments of a custom SQL function. +data FuncArgs = FuncArgs CArgCount (Ptr (Ptr CValue)) + +-- | The type of blob handles used for incremental blob I/O +data Blob = Blob Connection (Ptr CBlob) -- we include the db handle to use in + deriving (Eq, Show) -- error messages since it cannot + -- be retrieved any other way + +-- | A handle for an online backup process. +data Backup = Backup Connection (Ptr CBackup) + deriving (Eq, Show) + +-- we include the destination db handle to use in error messages since +-- it cannot be retrieved any other way + +------------------------------------------------------------------------ + +-- | +open :: Utf8 -> IO (Either (Error, Utf8) Connection) +open (Utf8 path) = + BS.useAsCString path \cpath -> + alloca \dbOutParam -> do + rc <- c_sqlite3_open cpath dbOutParam + db <- Connection <$> peek dbOutParam + -- sqlite3_open returns a sqlite3 even on failure. + -- That's where we get a more descriptive error message. + case toResult () rc of + Left err -> do + msg <- errmsg db -- This returns "out of memory" if db is null. + _ <- close db -- This is harmless if db is null. + return $ Left (err, msg) + Right () -> + if db == Connection nullPtr + then fail "sqlite3_open unexpectedly returned NULL" + else return $ Right db + +-- | +openV2 :: Maybe Utf8 -> [OpenV2Flag] -> OpenV2Mode -> Utf8 -> IO (Either (Error, Utf8) Connection) +openV2 mvfs flags mode (Utf8 path) = + case mvfs of + Nothing -> withVFSName nullPtr + Just (Utf8 vfsName) -> BS.useAsCString vfsName withVFSName + where + withVFSName cvfsName = + BS.useAsCString path \cpath -> do + alloca \dbOutParam -> do + rc <- c_sqlite3_open_v2 cpath dbOutParam (encodeOpenV2ModeAndFlags mode flags) cvfsName + db <- Connection <$> peek dbOutParam + -- sqlite3_open returns a sqlite3 even on failure. + -- That's where we get a more descriptive error message. + case toResult () rc of + Left err -> do + msg <- errmsg db -- This returns "out of memory" if db is null. + _ <- close db -- This is harmless if db is null. + return $ Left (err, msg) + Right () -> + if db == Connection nullPtr + then fail "sqlite3_open_v2 unexpectedly returned NULL" + else return $ Right db + +-- | +close :: Connection -> IO (Either Error ()) +close (Connection db) = + toResult () <$> c_sqlite3_close db + +-- | +-- +-- Cause any pending operation on the 'Database' handle to stop at its earliest +-- opportunity. This simply sets a flag and returns immediately. It does not +-- wait for the pending operation to finish. +-- +-- You'll need to compile with @-threaded@ for this to do any good. +-- Without @-threaded@, FFI calls block the whole RTS, meaning 'interrupt' +-- would never run at the same time as 'step'. +interrupt :: Connection -> IO () +interrupt (Connection db) = + c_sqlite3_interrupt db + +-- | +errcode :: Connection -> IO Error +errcode (Connection db) = + decodeError <$> c_sqlite3_errcode db + +-- | +errmsg :: Connection -> IO Utf8 +errmsg (Connection db) = + c_sqlite3_errmsg db >>= packUtf8 mempty id + +withErrorMessagePtr :: (Ptr CString -> IO CError) -> IO (Either (Error, Utf8) ()) +withErrorMessagePtr action = + alloca $ \msgPtrOut -> mask $ \restore -> do + poke msgPtrOut nullPtr + rc <- + restore (action msgPtrOut) + `onException` (peek msgPtrOut >>= c_sqlite3_free) + case toResult () rc of + Left err -> do + msgPtr <- peek msgPtrOut + if msgPtr == nullPtr + then return (Left (err, mempty)) + else do + len <- BSI.c_strlen msgPtr + fp <- newForeignPtr c_sqlite3_free_p msgPtr + let bs = BSI.fromForeignPtr (castForeignPtr fp) 0 (fromIntegral len) + return (Left (err, Utf8 bs)) + Right () -> return (Right ()) + +-- | +exec :: Connection -> Utf8 -> IO (Either (Error, Utf8) ()) +exec (Connection db) (Utf8 sql) = + BS.useAsCString sql $ \sql' -> + withErrorMessagePtr (c_sqlite3_exec db sql' nullFunPtr nullPtr) + +-- | Like 'exec', but invoke the callback for each result row. +-- +-- If the callback throws an exception, it will be rethrown by +-- 'execWithCallback'. +execWithCallback :: Connection -> Utf8 -> ExecCallback -> IO (Either (Error, Utf8) ()) +execWithCallback (Connection db) (Utf8 sql) cb = do + abortReason <- newIORef Nothing :: IO (IORef (Maybe SomeException)) + cbCache <- newIORef Nothing :: IO (IORef (Maybe ([Maybe Utf8] -> IO ()))) + -- Cache the partial application of column count and name, so if the + -- caller wants to convert them to something else, it only has to do + -- the conversions once. + + let getCallback cCount cNames = do + m <- readIORef cbCache + case m of + Nothing -> do + names <- + packUtf8Array + (fail "execWithCallback: NULL column name") + return + (fromIntegral cCount) + cNames + let !cb' = cb (fromFFI cCount) names + writeIORef cbCache $ Just cb' + return cb' + Just cb' -> return cb' + + let onExceptionAbort io = + (io >> return 0) `E.catch` \ex -> do + writeIORef abortReason $ Just ex + return 1 + + let cExecCallback _ctx cCount cValues cNames = + onExceptionAbort $ do + cb' <- getCallback cCount cNames + values <- + packUtf8Array + (return Nothing) + (return . Just) + (fromIntegral cCount) + cValues + cb' values + + BS.useAsCString sql $ \sql' -> + bracket (mkCExecCallback cExecCallback) freeHaskellFunPtr $ \pExecCallback -> do + e <- withErrorMessagePtr (c_sqlite3_exec db sql' pExecCallback nullPtr) + case e of + Left r@(ErrorAbort, _) -> do + m <- readIORef abortReason + case m of + Nothing -> return (Left r) + Just ex -> throwIO ex + r -> return r + +type ExecCallback = + -- | Number of columns, which is the number of items in + -- the following lists. This will be the same for + -- every row. + ColumnCount -> + -- | List of column names. This will be the same + -- for every row. + [Utf8] -> + -- | List of column values, as returned by 'columnText'. + [Maybe Utf8] -> + IO () + +-- | +-- +-- Enable/disable tracing of SQL execution. Tracing can be disabled +-- by setting 'Nothing' as the logger callback. +-- +-- Warning: If the logger callback throws an exception, your whole +-- program will crash. Enable only for debugging! +setTrace :: Connection -> Maybe (Utf8 -> IO ()) -> IO () +setTrace (Connection db) logger = + case logger of + Nothing -> do + _ <- c_sqlite3_trace db nullFunPtr nullPtr + return () + Just output -> do + -- NB: this FunPtr never gets freed. Shouldn't be a big deal, + -- though, since 'setTrace' is mainly for debugging, and is + -- typically only called once per application invocation. + cb <- mkCTraceCallback $ \_ctx cStr -> do + msg <- packUtf8 mempty id cStr + output msg + _ <- c_sqlite3_trace db cb nullPtr + return () + +-- | +-- +-- Return 'True' if the connection is in autocommit mode, or 'False' if a +-- transaction started with @BEGIN@ is still active. +-- +-- Be warned that some errors roll back the transaction automatically, +-- and that @ROLLBACK@ will throw an error if no transaction is active. +-- Use 'getAutoCommit' to avoid such an error: +-- +-- @ +-- autocommit <- 'getAutoCommit' conn +-- 'Control.Monad.when' (not autocommit) $ +-- 'Database.Sqlite3.exec' conn \"ROLLBACK\" +-- @ +getAutoCommit :: Connection -> IO Bool +getAutoCommit (Connection db) = + (/= 0) <$> c_sqlite3_get_autocommit db + +-- | +-- +-- Enable or disable shared cache for all future connections. +setSharedCacheEnabled :: Bool -> IO (Either Error ()) +setSharedCacheEnabled val = + toResult () <$> c_sqlite3_enable_shared_cache val + +-- | +-- +-- If the query contains no SQL statements, this returns +-- @'Right' 'Nothing'@. +prepare :: Connection -> Utf8 -> IO (Either Error (Maybe PreparedStatement)) +prepare (Connection db) (Utf8 sql) = + BS.useAsCString sql $ \sql' -> + alloca $ \statement -> + c_sqlite3_prepare_v2 db sql' (-1) statement nullPtr + >>= toResultM (wrapNullablePtr PreparedStatement <$> peek statement) + +-- | +getStatementConnection :: PreparedStatement -> IO Connection +getStatementConnection (PreparedStatement stmt) = do + db <- c_sqlite3_db_handle stmt + if db == nullPtr + then fail $ "sqlite3_db_handle(" ++ show stmt ++ ") returned NULL" + else return (Connection db) + +-- | +step :: PreparedStatement -> IO (Either Error StepResult) +step (PreparedStatement stmt) = + toStepResult <$> c_sqlite3_step stmt + +-- | +-- +-- Faster step for statements that don't callback to Haskell +-- functions (e.g. by using custom SQL functions). +stepNoCB :: PreparedStatement -> IO (Either Error StepResult) +stepNoCB (PreparedStatement stmt) = + toStepResult <$> c_sqlite3_step_unsafe stmt + +-- | +-- +-- Warning: +-- +-- * If the most recent 'step' call failed, +-- this will return the corresponding error. +-- +-- * This does not reset the bindings on a prepared statement. +-- Use 'clearBindings' to do that. +reset :: PreparedStatement -> IO (Either Error ()) +reset (PreparedStatement stmt) = + toResult () <$> c_sqlite3_reset stmt + +-- | +-- +-- /Warning:/ If the most recent 'step' call failed, +-- this will return the corresponding error. +finalize :: PreparedStatement -> IO (Either Error ()) +finalize (PreparedStatement stmt) = + toResult () <$> c_sqlite3_finalize stmt + +-- | +-- +-- Return a copy of the original SQL text used to compile the statement. +statementSql :: PreparedStatement -> IO (Maybe Utf8) +statementSql (PreparedStatement stmt) = + c_sqlite3_sql stmt >>= packUtf8 Nothing Just + +-- | +-- +-- Set all parameters in the prepared statement to null. +clearBindings :: PreparedStatement -> IO () +clearBindings (PreparedStatement stmt) = do + _ <- c_sqlite3_clear_bindings stmt + return () + +-- | +-- +-- This returns the index of the largest (rightmost) parameter. Note that this +-- is not necessarily the number of parameters. If numbered parameters like +-- @?5@ are used, there may be gaps in the list. +-- +-- See 'ParamIndex' for more information. +bindParameterCount :: PreparedStatement -> IO ParamIndex +bindParameterCount (PreparedStatement stmt) = + fromFFI <$> c_sqlite3_bind_parameter_count stmt + +-- | +bindParameterName :: PreparedStatement -> ParamIndex -> IO (Maybe Utf8) +bindParameterName (PreparedStatement stmt) idx = + c_sqlite3_bind_parameter_name stmt (toFFI idx) + >>= packUtf8 Nothing Just + +-- | +bindParameterIndex :: PreparedStatement -> Utf8 -> IO (Maybe ParamIndex) +bindParameterIndex (PreparedStatement stmt) (Utf8 name) = + BS.useAsCString name $ \name' -> do + idx <- fromFFI <$> c_sqlite3_bind_parameter_index stmt name' + return $ if idx == 0 then Nothing else Just idx + +-- | +columnCount :: PreparedStatement -> IO ColumnCount +columnCount (PreparedStatement stmt) = + fromFFI <$> c_sqlite3_column_count stmt + +-- | +columnName :: PreparedStatement -> ColumnIndex -> IO (Maybe Utf8) +columnName (PreparedStatement stmt) idx = + c_sqlite3_column_name stmt (toFFI idx) + >>= packUtf8 Nothing Just + +bindInt64 :: PreparedStatement -> ParamIndex -> Int64 -> IO (Either Error ()) +bindInt64 (PreparedStatement stmt) idx value = + toResult () <$> c_sqlite3_bind_int64 stmt (toFFI idx) value + +bindDouble :: PreparedStatement -> ParamIndex -> Double -> IO (Either Error ()) +bindDouble (PreparedStatement stmt) idx value = + toResult () <$> c_sqlite3_bind_double stmt (toFFI idx) value + +bindText :: PreparedStatement -> ParamIndex -> Utf8 -> IO (Either Error ()) +bindText (PreparedStatement stmt) idx (Utf8 value) = + unsafeUseAsCStringLenNoNull value $ \ptr len -> + toResult () + <$> c_sqlite3_bind_text stmt (toFFI idx) ptr len c_SQLITE_TRANSIENT + +bindBlob :: PreparedStatement -> ParamIndex -> ByteString -> IO (Either Error ()) +bindBlob (PreparedStatement stmt) idx value = + unsafeUseAsCStringLenNoNull value $ \ptr len -> + toResult () + <$> c_sqlite3_bind_blob stmt (toFFI idx) ptr len c_SQLITE_TRANSIENT + +bindZeroBlob :: PreparedStatement -> ParamIndex -> Int -> IO (Either Error ()) +bindZeroBlob (PreparedStatement stmt) idx len = + toResult () + <$> c_sqlite3_bind_zeroblob stmt (toFFI idx) (fromIntegral len) + +bindNull :: PreparedStatement -> ParamIndex -> IO (Either Error ()) +bindNull (PreparedStatement stmt) idx = + toResult () <$> c_sqlite3_bind_null stmt (toFFI idx) + +columnType :: PreparedStatement -> ColumnIndex -> IO ColumnType +columnType (PreparedStatement stmt) idx = + decodeColumnType <$> c_sqlite3_column_type stmt (toFFI idx) + +columnInt64 :: PreparedStatement -> ColumnIndex -> IO Int64 +columnInt64 (PreparedStatement stmt) idx = + c_sqlite3_column_int64 stmt (toFFI idx) + +columnDouble :: PreparedStatement -> ColumnIndex -> IO Double +columnDouble (PreparedStatement stmt) idx = + c_sqlite3_column_double stmt (toFFI idx) + +columnText :: PreparedStatement -> ColumnIndex -> IO Utf8 +columnText (PreparedStatement stmt) idx = do + ptr <- c_sqlite3_column_text stmt (toFFI idx) + len <- c_sqlite3_column_bytes stmt (toFFI idx) + Utf8 <$> packCStringLen ptr len + +columnBlob :: PreparedStatement -> ColumnIndex -> IO ByteString +columnBlob (PreparedStatement stmt) idx = do + ptr <- c_sqlite3_column_blob stmt (toFFI idx) + len <- c_sqlite3_column_bytes stmt (toFFI idx) + packCStringLen ptr len + +-- | +lastInsertRowId :: Connection -> IO Int64 +lastInsertRowId (Connection db) = + c_sqlite3_last_insert_rowid db + +-- | +-- +-- Return the number of rows that were changed, inserted, or deleted +-- by the most recent @INSERT@, @DELETE@, or @UPDATE@ statement. +changes :: Connection -> IO Int +changes (Connection db) = + fromIntegral <$> c_sqlite3_changes db + +-- | +-- +-- Return the total number of row changes caused by @INSERT@, @DELETE@, +-- or @UPDATE@ statements since the 'Connection' was opened. +totalChanges :: Connection -> IO Int +totalChanges (Connection db) = + fromIntegral <$> c_sqlite3_total_changes db + +-- We use CFuncPtrs to store the function pointers used in the implementation +-- of custom SQL functions so that sqlite can deallocate those pointers when +-- the function is deleted or overwritten +data CFuncPtrs = CFuncPtrs (FunPtr CFunc) (FunPtr CFunc) (FunPtr CFuncFinal) + +-- Deallocate the function pointers used to implement a custom function +-- This is only called by sqlite so we create one global FunPtr to pass to +-- sqlite +destroyCFuncPtrs :: FunPtr (CFuncDestroy ()) +destroyCFuncPtrs = IOU.unsafePerformIO $ mkCFuncDestroy destroy + where + destroy p = do + let p' = castPtrToStablePtr p + CFuncPtrs p1 p2 p3 <- deRefStablePtr p' + unless (p1 == nullFunPtr) $ freeHaskellFunPtr p1 + unless (p2 == nullFunPtr) $ freeHaskellFunPtr p2 + unless (p3 == nullFunPtr) $ freeHaskellFunPtr p3 + freeStablePtr p' +{-# NOINLINE destroyCFuncPtrs #-} + +-- | +-- +-- Create a custom SQL function or redefine the behavior of an existing +-- function. +createFunction :: + Connection -> + -- | Name of the function. + Utf8 -> + -- | Number of arguments. 'Nothing' means that the + -- function accepts any number of arguments. + Maybe ArgCount -> + -- | Is the function deterministic? + Bool -> + -- | Implementation of the function. + (FuncContext -> FuncArgs -> IO ()) -> + IO (Either Error ()) +createFunction (Connection db) (Utf8 name) nArgs isDet fun = mask_ $ do + funPtr <- mkCFunc fun' + u <- newStablePtr $ CFuncPtrs funPtr nullFunPtr nullFunPtr + BS.useAsCString name $ \namePtr -> + toResult () + <$> c_sqlite3_create_function_v2 + db + namePtr + (maybeArgCount nArgs) + flags + (castStablePtrToPtr u) + funPtr + nullFunPtr + nullFunPtr + destroyCFuncPtrs + where + flags = if isDet then c_SQLITE_DETERMINISTIC else 0 + fun' ctx nArgs' cvals = + catchAsResultError ctx $ + fun (FuncContext ctx) (FuncArgs nArgs' cvals) + +-- | Like 'createFunction' except that it creates an aggregate function. +createAggregate :: + Connection -> + -- | Name of the function. + Utf8 -> + -- | Number of arguments. + Maybe ArgCount -> + -- | Initial aggregate state. + a -> + -- | Process one row and update the aggregate state. + (FuncContext -> FuncArgs -> a -> IO a) -> + -- | Called after all rows have been processed. + -- Can be used to construct the returned value + -- from the aggregate state. + (FuncContext -> a -> IO ()) -> + IO (Either Error ()) +createAggregate (Connection db) (Utf8 name) nArgs initSt xStep xFinal = mask_ $ do + stepPtr <- mkCFunc xStep' + finalPtr <- mkCFuncFinal xFinal' + u <- newStablePtr $ CFuncPtrs nullFunPtr stepPtr finalPtr + BS.useAsCString name $ \namePtr -> + toResult () + <$> c_sqlite3_create_function_v2 + db + namePtr + (maybeArgCount nArgs) + 0 + (castStablePtrToPtr u) + nullFunPtr + stepPtr + finalPtr + destroyCFuncPtrs + where + -- we store the aggregate state in the buffer returned by + -- c_sqlite3_aggregate_context as a StablePtr pointing to an IORef that + -- contains the actual aggregate state + xStep' ctx nArgs' cvals = + catchAsResultError ctx $ do + aggCtx <- getAggregateContext ctx + aggStPtr <- peek aggCtx + aggStRef <- + if castStablePtrToPtr aggStPtr /= nullPtr + then deRefStablePtr aggStPtr + else do + aggStRef <- newIORef initSt + aggStPtr' <- newStablePtr aggStRef + poke aggCtx aggStPtr' + return aggStRef + aggSt <- readIORef aggStRef + aggSt' <- xStep (FuncContext ctx) (FuncArgs nArgs' cvals) aggSt + writeIORef aggStRef aggSt' + xFinal' ctx = do + aggCtx <- getAggregateContext ctx + aggStPtr <- peek aggCtx + if castStablePtrToPtr aggStPtr == nullPtr + then + catchAsResultError ctx $ + xFinal (FuncContext ctx) initSt + else do + catchAsResultError ctx $ do + aggStRef <- deRefStablePtr aggStPtr + aggSt <- readIORef aggStRef + xFinal (FuncContext ctx) aggSt + freeStablePtr aggStPtr + getAggregateContext ctx = + c_sqlite3_aggregate_context ctx stPtrSize + stPtrSize = fromIntegral $ sizeOf (undefined :: StablePtr ()) + +-- call c_sqlite3_result_error in the event of an error +catchAsResultError :: Ptr CContext -> IO () -> IO () +catchAsResultError ctx action = E.catch action $ \exn -> do + let msg = show (exn :: SomeException) + withCAStringLen msg $ \(ptr, len) -> + c_sqlite3_result_error ctx ptr (fromIntegral len) + +-- | Delete an SQL function (scalar or aggregate). +deleteFunction :: Connection -> Utf8 -> Maybe ArgCount -> IO (Either Error ()) +deleteFunction (Connection db) (Utf8 name) nArgs = + BS.useAsCString name $ \namePtr -> + toResult () + <$> c_sqlite3_create_function_v2 + db + namePtr + (maybeArgCount nArgs) + 0 + nullPtr + nullFunPtr + nullFunPtr + nullFunPtr + nullFunPtr + +maybeArgCount :: Maybe ArgCount -> CArgCount +maybeArgCount (Just n) = toFFI n +maybeArgCount Nothing = -1 + +funcArgCount :: FuncArgs -> ArgCount +funcArgCount (FuncArgs nArgs _) = fromIntegral nArgs + +funcArgType :: FuncArgs -> ArgIndex -> IO ColumnType +funcArgType = + extractFuncArg NullColumn (fmap decodeColumnType . c_sqlite3_value_type) + +funcArgInt64 :: FuncArgs -> ArgIndex -> IO Int64 +funcArgInt64 = extractFuncArg 0 c_sqlite3_value_int64 + +funcArgDouble :: FuncArgs -> ArgIndex -> IO Double +funcArgDouble = extractFuncArg 0 c_sqlite3_value_double + +funcArgText :: FuncArgs -> ArgIndex -> IO Utf8 +funcArgText = extractFuncArg mempty $ \cval -> do + ptr <- c_sqlite3_value_text cval + len <- c_sqlite3_value_bytes cval + Utf8 <$> packCStringLen ptr len + +funcArgBlob :: FuncArgs -> ArgIndex -> IO ByteString +funcArgBlob = extractFuncArg mempty $ \cval -> do + ptr <- c_sqlite3_value_blob cval + len <- c_sqlite3_value_bytes cval + packCStringLen ptr len + +-- the c_sqlite3_value_* family of functions don't handle null pointers, so +-- we must use a wrapper to guarantee that a sensible value is returned if +-- we are out of bounds +extractFuncArg :: a -> (Ptr CValue -> IO a) -> FuncArgs -> ArgIndex -> IO a +extractFuncArg defVal extract (FuncArgs nArgs p) idx + | 0 <= idx && idx < fromIntegral nArgs = do + cval <- peekElemOff p (fromIntegral idx) + extract cval + | otherwise = return defVal + +funcResultInt64 :: FuncContext -> Int64 -> IO () +funcResultInt64 (FuncContext ctx) value = + c_sqlite3_result_int64 ctx value + +funcResultDouble :: FuncContext -> Double -> IO () +funcResultDouble (FuncContext ctx) value = + c_sqlite3_result_double ctx value + +funcResultText :: FuncContext -> Utf8 -> IO () +funcResultText (FuncContext ctx) (Utf8 value) = + unsafeUseAsCStringLenNoNull value $ \ptr len -> + c_sqlite3_result_text ctx ptr len c_SQLITE_TRANSIENT + +funcResultBlob :: FuncContext -> ByteString -> IO () +funcResultBlob (FuncContext ctx) value = + unsafeUseAsCStringLenNoNull value $ \ptr len -> + c_sqlite3_result_blob ctx ptr len c_SQLITE_TRANSIENT + +funcResultZeroBlob :: FuncContext -> Int -> IO () +funcResultZeroBlob (FuncContext ctx) len = + c_sqlite3_result_zeroblob ctx (fromIntegral len) + +funcResultNull :: FuncContext -> IO () +funcResultNull (FuncContext ctx) = + c_sqlite3_result_null ctx + +-- | +getFuncContextConnection :: FuncContext -> IO Connection +getFuncContextConnection (FuncContext ctx) = do + db <- c_sqlite3_context_db_handle ctx + if db == nullPtr + then fail $ "sqlite3_context_db_handle(" ++ show ctx ++ ") returned NULL" + else return (Connection db) + +-- | Deallocate the function pointer to the comparison function used to +-- implement a custom collation +destroyCCompare :: CFuncDestroy () +destroyCCompare ptr = freeHaskellFunPtr ptr' + where + ptr' = castPtrToFunPtr ptr :: FunPtr (CCompare ()) + +-- | This is called by sqlite so we create one global FunPtr to pass to sqlite +destroyCComparePtr :: FunPtr (CFuncDestroy ()) +destroyCComparePtr = IOU.unsafePerformIO $ mkCFuncDestroy destroyCCompare +{-# NOINLINE destroyCComparePtr #-} + +-- | +createCollation :: + Connection -> + -- | Name of the collation. + Utf8 -> + -- | Comparison function. + (Utf8 -> Utf8 -> Ordering) -> + IO (Either Error ()) +createCollation (Connection db) (Utf8 name) cmp = mask_ $ do + cmpPtr <- mkCCompare cmp' + let u = castFunPtrToPtr cmpPtr + BS.useAsCString name $ \namePtr -> + toResult () <$> do + r <- + c_sqlite3_create_collation_v2 + db + namePtr + c_SQLITE_UTF8 + u + cmpPtr + destroyCComparePtr + -- sqlite does not call the destructor for us in case of an + -- error + unless (r == CError 0) $ + destroyCCompare $ + castFunPtrToPtr cmpPtr + return r + where + cmp' _ len1 ptr1 len2 ptr2 = handle exnHandler $ do + s1 <- Utf8 <$> packCStringLen ptr1 len1 + s2 <- Utf8 <$> packCStringLen ptr2 len2 + let c = cmp s1 s2 + evaluate (fromIntegral $ fromEnum c - 1) + exnHandler (_ :: SomeException) = return (-1) + +-- | Delete a collation. +deleteCollation :: Connection -> Utf8 -> IO (Either Error ()) +deleteCollation (Connection db) (Utf8 name) = + BS.useAsCString name $ \namePtr -> + toResult () + <$> c_sqlite3_create_collation_v2 + db + namePtr + c_SQLITE_UTF8 + nullPtr + nullFunPtr + nullFunPtr + +-- | +-- +-- Enable or disable extension loading. +setLoadExtensionEnabled :: Connection -> Bool -> IO (Either Error ()) +setLoadExtensionEnabled (Connection db) enabled = + toResult () <$> c_sqlite3_enable_load_extension db enabled + +-- | +-- +-- Open a blob for incremental I/O. +blobOpen :: + Connection -> + -- | The symbolic name of the database (e.g. "main"). + Utf8 -> + -- | The table name. + Utf8 -> + -- | The column name. + Utf8 -> + -- | The @ROWID@ of the row. + Int64 -> + -- | Open the blob for read-write. + Bool -> + IO (Either Error Blob) +blobOpen (Connection db) (Utf8 zDb) (Utf8 zTable) (Utf8 zColumn) rowid rw = + BS.useAsCString zDb $ \ptrDb -> + BS.useAsCString zTable $ \ptrTable -> + BS.useAsCString zColumn $ \ptrColumn -> + alloca $ \ptrBlob -> + c_sqlite3_blob_open db ptrDb ptrTable ptrColumn rowid flags ptrBlob + >>= toResultM (Blob (Connection db) <$> peek ptrBlob) + where + flags = if rw then 1 else 0 + +-- | +blobClose :: Blob -> IO (Either Error ()) +blobClose (Blob _ blob) = + toResult () <$> c_sqlite3_blob_close blob + +-- | +blobReopen :: + Blob -> + -- | The @ROWID@ of the row. + Int64 -> + IO (Either Error ()) +blobReopen (Blob _ blob) rowid = + toResult () <$> c_sqlite3_blob_reopen blob rowid + +-- | +blobBytes :: Blob -> IO Int +blobBytes (Blob _ blob) = + fromIntegral <$> c_sqlite3_blob_bytes blob + +-- | +blobRead :: + Blob -> + -- | Number of bytes to read. + Int -> + -- | Offset within the blob. + Int -> + IO (Either Error ByteString) +blobRead blob len offset = do + fp <- BSI.mallocByteString len + fmap (\_ -> BSI.fromForeignPtr fp 0 len) + <$> withForeignPtr fp (\p -> blobReadBuf blob p len offset) + +blobReadBuf :: Blob -> Ptr a -> Int -> Int -> IO (Either Error ()) +blobReadBuf (Blob _ blob) buf len offset = + toResult () + <$> c_sqlite3_blob_read blob buf (fromIntegral len) (fromIntegral offset) + +-- | +blobWrite :: + Blob -> + ByteString -> + -- | Offset within the blob. + Int -> + IO (Either Error ()) +blobWrite (Blob _ blob) bs offset = + BSU.unsafeUseAsCStringLen bs $ \(buf, len) -> + toResult () + <$> c_sqlite3_blob_write blob buf (fromIntegral len) (fromIntegral offset) + +-- | +backupInit :: + -- | Destination database handle. + Connection -> + -- | Destination database name. + Utf8 -> + -- | Source database handle. + Connection -> + -- | Source database name. + Utf8 -> + IO (Either Error Backup) +backupInit (Connection dstDb) (Utf8 dstName) (Connection srcDb) (Utf8 srcName) = + BS.useAsCString dstName $ \dstName' -> + BS.useAsCString srcName $ \srcName' -> do + r <- c_sqlite3_backup_init dstDb dstName' srcDb srcName' + if r == nullPtr + then Left <$> errcode (Connection dstDb) + else return (Right (Backup (Connection dstDb) r)) + +-- | +backupFinish :: Backup -> IO (Either Error ()) +backupFinish (Backup _ backup) = + toResult () + <$> c_sqlite3_backup_finish backup + +-- | +backupStep :: + Backup -> + -- | Number of pages to copy; if negative, all remaining source pages are copied. + Int -> + IO (Either Error BackupStepResult) +backupStep (Backup _ backup) pages = + toBackupStepResult + <$> c_sqlite3_backup_step backup (fromIntegral pages) + +-- | +backupRemaining :: Backup -> IO Int +backupRemaining (Backup _ backup) = + fromIntegral <$> c_sqlite3_backup_remaining backup + +-- | +backupPagecount :: Backup -> IO Int +backupPagecount (Backup _ backup) = + fromIntegral <$> c_sqlite3_backup_pagecount backup diff --git a/lib/Sqlite.hs b/lib/Sqlite.hs new file mode 100644 --- /dev/null +++ b/lib/Sqlite.hs @@ -0,0 +1,879 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} + +module Sqlite + ( -- * Connection management + open, + openV2, + openV2NoMutexReadWrite, + VFS (..), + OpenV2Flag (..), + OpenV2Mode (..), + close, + + -- * Simple query execution + + -- | + exec, + execPrint, + execWithCallback, + ExecCallback, + + -- * Statement management + prepare, + -- prepareUtf8, + step, + stepNoCB, + reset, + finalize, + clearBindings, + + -- * Parameter and column information + bindParameterCount, + bindParameterName, + columnCount, + columnName, + + -- * Binding values to a prepared statement + + -- | + bindSqlData, + bind, + bindNamed, + bindInt, + bindInt64, + bindDouble, + bindText, + bindBlob, + bindZeroBlob, + bindNull, + + -- * Reading the result row + + -- | + -- + -- Warning: 'column' and 'columns' will throw a 'DecodeError' if any @TEXT@ + -- datum contains invalid UTF-8. + column, + columns, + typedColumns, + columnType, + columnInt64, + columnDouble, + columnText, + columnBlob, + + -- * Result statistics + lastInsertRowId, + changes, + totalChanges, + + -- * Create custom Sql functions + createFunction, + createAggregate, + deleteFunction, + + -- ** Extract function arguments + funcArgCount, + funcArgType, + funcArgInt64, + funcArgDouble, + funcArgText, + funcArgBlob, + + -- ** Set the result of a function + funcResultSqlData, + funcResultInt64, + funcResultDouble, + funcResultText, + funcResultBlob, + funcResultZeroBlob, + funcResultNull, + getFuncContextConnection, + + -- * Create custom collations + createCollation, + deleteCollation, + + -- * Interrupting a long-running query + interrupt, + interruptibly, + + -- * Incremental blob I/O + blobOpen, + blobClose, + blobReopen, + blobBytes, + blobRead, + blobReadBuf, + blobWrite, + + -- * Online Backup API + + -- | and + -- + backupInit, + backupFinish, + backupStep, + backupRemaining, + backupPagecount, + + -- * Types + Connection, + PreparedStatement, + SqlData (..), + SqliteException (..), + ColumnType (..), + FuncContext, + FuncArgs, + Blob, + Backup, + + -- ** Results and errors + StepResult (..), + BackupStepResult (..), + Error (..), + + -- ** Special integers + ParamIndex (..), + ColumnIndex (..), + ColumnCount, + ArgCount (..), + ArgIndex, + ) +where + +-- Re-exported from Database.Sqlite3.Direct without modification. +-- Note that if this module were in another package, source links would not +-- be generated for these functions. + +import Control.Concurrent +import Control.Exception +import Control.Monad (when, zipWithM, zipWithM_) +import Data.ByteString (ByteString) +import Data.Int (Int64) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) +import Data.Text.Encoding.Error (UnicodeException (..), lenientDecode) +import Data.Text.IO qualified as T +import Foreign.Ptr (Ptr) +import Sqlite.Direct + ( ArgCount (..), + ArgIndex, + Backup, + BackupStepResult (..), + Blob, + ColumnCount, + ColumnIndex (..), + ColumnType (..), + Connection, + Error (..), + FuncArgs, + FuncContext, + OpenV2Flag (..), + OpenV2Mode (..), + ParamIndex (..), + PreparedStatement, + StepResult (..), + Utf8 (..), + backupPagecount, + backupRemaining, + bindParameterCount, + blobBytes, + changes, + clearBindings, + columnBlob, + columnCount, + columnDouble, + columnInt64, + columnType, + funcArgBlob, + funcArgCount, + funcArgDouble, + funcArgInt64, + funcArgType, + funcResultBlob, + funcResultDouble, + funcResultInt64, + funcResultNull, + funcResultZeroBlob, + getFuncContextConnection, + interrupt, + lastInsertRowId, + totalChanges, + ) +import Sqlite.Direct qualified as Direct +import Prelude hiding (error) + +data SqlData + = SqlInteger !Int64 + | SqlFloat !Double + | SqlText !Text + | SqlBlob !ByteString + | SqlNull + deriving (Eq, Show) + +-- | Exception thrown when Sqlite3 reports an error. +-- +-- direct-sqlite may throw other types of exceptions if you misuse the API. +data SqliteException = SqliteException + { -- | Error code returned by API call + sqliteError :: !Error, + -- | Text describing the error + sqliteErrorDetails :: Text, + -- | Indicates what action produced this error, + -- e.g. @exec \"SELECT * FROM foo\"@ + sqliteErrorContext :: Text + } + deriving (Eq) + +-- NB: SqliteException is lazy in 'sqliteErrorDetails' and 'sqliteErrorContext', +-- to defer message construction in the case where a user catches and +-- immediately handles the error. + +instance Show SqliteException where + show + SqliteException + { sqliteError = code, + sqliteErrorDetails = details, + sqliteErrorContext = context + } = + T.unpack $ + T.concat + [ "Sqlite3 returned ", + T.pack $ show code, + " while attempting to perform ", + context, + ": ", + details + ] + +instance Exception SqliteException + +fromUtf8Lenient :: Utf8 -> Text +fromUtf8Lenient (Utf8 bs) = decodeUtf8With lenientDecode bs + +-- | Like 'decodeUtf8', but substitute a custom error message if +-- decoding fails. +fromUtf8 :: String -> Utf8 -> IO Text +fromUtf8 desc utf8 = evaluate do fromUtf8' desc utf8 + +fromUtf8' :: String -> Utf8 -> Text +fromUtf8' desc (Utf8 bs) = + decodeUtf8With (\_ c -> throw (DecodeError desc c)) bs + +toUtf8 :: Text -> Utf8 +toUtf8 = Utf8 . encodeUtf8 + +data DetailSource + = DetailConnection Connection + | DetailStatement PreparedStatement + | DetailMessage Utf8 + +renderDetailSource :: DetailSource -> IO Utf8 +renderDetailSource src = case src of + DetailConnection db -> + Direct.errmsg db + DetailStatement stmt -> do + db <- Direct.getStatementConnection stmt + Direct.errmsg db + DetailMessage msg -> + return msg + +throwSqliteException :: DetailSource -> Text -> Error -> IO a +throwSqliteException detailSource context error = do + Utf8 details <- renderDetailSource detailSource + throwIO + SqliteException + { sqliteError = error, + sqliteErrorDetails = decodeUtf8With lenientDecode details, + sqliteErrorContext = context + } + +checkError :: DetailSource -> Text -> Either Error a -> IO a +checkError ds fn = either (throwSqliteException ds fn) return + +checkErrorMsg :: Text -> Either (Error, Utf8) a -> IO a +checkErrorMsg fn result = case result of + Left (err, msg) -> throwSqliteException (DetailMessage msg) fn err + Right a -> return a + +appendShow :: (Show a) => Text -> a -> Text +appendShow txt a = txt `T.append` (T.pack . show) a + +-- | +open :: + -- | Connection filename. + Text -> + IO Connection +open path = do + result <- Direct.open (toUtf8 path) + checkErrorMsg ("open " `appendShow` path) result + +-- | +openV2 :: + -- | Name of VFS module to use. + VFS -> + [OpenV2Flag] -> + OpenV2Mode -> + -- | Database filename. + Text -> + IO Connection +openV2 vfs flags mode path = do + let mvfs = case vfs of + DefaultVFS -> Nothing + VFSWithName vfsName -> Just vfsName + Direct.openV2 (toUtf8 <$> mvfs) flags mode (toUtf8 path) + >>= checkErrorMsg ("openV2 " `appendShow` path) + +-- | Typical set of arguments for a connection pool. +-- https://www.sqlite.org/threadsafe.html +-- SQLITE_OPEN_NOMUTEX flag causes the database connection to be in the multi-thread mode +-- In this mode, SQLite can be safely used by multiple threads provided that no +-- single database connection nor any object derived from database connection, +-- such as a prepared statement, is used in two or more threads at the same +-- time. +openV2NoMutexReadWrite :: + -- | Database filename. + Text -> + IO Connection +openV2NoMutexReadWrite = + Sqlite.openV2 DefaultVFS [OpenV2ExtendedResultCode, OpenV2NoMutex] OpenV2ReadWrite + +data VFS + = DefaultVFS + | VFSWithName Text + deriving (Show, Eq) + +-- | +close :: Connection -> IO () +close db = do + result <- Direct.close db + checkError (DetailConnection db) "close" result + +-- | Make it possible to interrupt the given database operation with an +-- asynchronous exception. This only works if the program is compiled with +-- base >= 4.3 and @-threaded@. +-- +-- It works by running the callback in a forked thread. If interrupted, +-- it uses 'interrupt' to try to stop the operation. +interruptibly :: Connection -> IO a -> IO a +interruptibly db io + | rtsSupportsBoundThreads = + mask \restore -> do + mv <- newEmptyMVar + tid <- forkIO do try' (restore io) >>= putMVar mv + + let interruptAndWait = + -- Don't let a second exception interrupt us. Otherwise, + -- the operation will dangle in the background, which could + -- be really bad if it uses locally-allocated resources. + uninterruptibleMask_ do + -- Tell Sqlite3 to interrupt the current query. + interrupt db + + -- Interrupt the thread in case it's blocked for some + -- other reason. + -- + -- NOTE: killThread blocks until the exception is delivered. + -- That's fine, since we're going to wait for the thread + -- to finish anyway. + killThread tid + + -- Wait for the forked thread to finish. + _ <- takeMVar mv + return () + + e <- takeMVar mv `onException` interruptAndWait + either throwIO return e + | otherwise = io + where + try' :: IO a -> IO (Either SomeException a) + try' = try + +-- | Execute zero or more Sql statements delimited by semicolons. +exec :: Connection -> Text -> IO () +exec db sql = do + result <- Direct.exec db (toUtf8 sql) + checkErrorMsg ("exec " `appendShow` sql) result + +-- | Like 'exec', but print result rows to 'System.IO.stdout'. +-- +-- This is mainly for convenience when experimenting in GHCi. +-- The output format may change in the future. +execPrint :: Connection -> Text -> IO () +execPrint !db !sql = + interruptibly db do + execWithCallback db sql do + \_count _colnames -> T.putStrLn . showValues + where + -- This mimics sqlite3's default output mode. It displays a NULL and an + -- empty string identically. + showValues = T.intercalate "|" . map (fromMaybe "") + +-- | Like 'exec', but invoke the callback for each result row. +execWithCallback :: Connection -> Text -> ExecCallback -> IO () +execWithCallback db sql cb = do + result <- Direct.execWithCallback db (toUtf8 sql) cb' + checkErrorMsg ("execWithCallback " `appendShow` sql) result + where + -- We want 'names' computed once and shared with every call. + cb' count namesUtf8 = + let names = map fromUtf8'' namesUtf8 + {-# NOINLINE names #-} + in cb count names . map (fmap fromUtf8'') + + fromUtf8'' = fromUtf8' "Database.Sqlite3.execWithCallback: Invalid UTF-8" + +type ExecCallback = + -- | Number of columns, which is the number of items in + -- the following lists. This will be the same for + -- every row. + ColumnCount -> + -- | List of column names. This will be the same + -- for every row. + [Text] -> + -- | List of column values, as returned by 'columnText'. + [Maybe Text] -> + IO () + +-- | +-- +-- Unlike 'exec', 'prepare' only executes the first statement, and ignores +-- subsequent statements. +-- +-- If the query string contains no Sql statements, this 'fail's. +prepare :: Connection -> Text -> IO PreparedStatement +prepare db sql = prepareUtf8 db (toUtf8 sql) + +-- | +-- +-- It can help to avoid redundant Utf8 to Text conversion if you already +-- have Utf8 +-- +-- If the query string contains no Sql statements, this 'fail's. +prepareUtf8 :: Connection -> Utf8 -> IO PreparedStatement +prepareUtf8 db sql = do + result <- Direct.prepare db sql + m <- checkError (DetailConnection db) ("prepare " <> fromUtf8Lenient sql) result + case m of + Nothing -> fail "Direct.Sqlite3.prepare: empty query string" + Just stmt -> return stmt + +-- | +step :: PreparedStatement -> IO StepResult +step statement = do + result <- Direct.step statement + checkError (DetailStatement statement) "step" result + +-- | +-- +-- Faster step for statements that don't callback to Haskell +-- functions (e.g. by using custom Sql functions). +stepNoCB :: PreparedStatement -> IO StepResult +stepNoCB statement = do + result <- Direct.stepNoCB statement + checkError (DetailStatement statement) "stepNoCB" result + +-- Note: sqlite3_reset and sqlite3_finalize return an error code if the most +-- recent sqlite3_step indicated an error. I think these are the only times +-- these functions return an error (barring memory corruption and misuse of the API). +-- +-- We don't replicate that behavior here. Instead, 'reset' and 'finalize' +-- discard the error. Otherwise, we would get "double jeopardy". +-- For example: +-- +-- ok <- try $ step stmt :: IO (Either SqliteException StepResult) +-- finalize stmt +-- +-- If 'finalize' threw its error, it would throw the exception the user was +-- trying to catch. +-- +-- 'reset' and 'finalize' might return a different error than the step that +-- failed, leading to more cryptic error messages [1]. But we're not +-- completely sure about this. +-- +-- [1]: https://github.com/yesodweb/persistent/issues/92#issuecomment-7806421 + +-- | +-- +-- Note that in the C API, @sqlite3_reset@ returns an error code if the most +-- recent @sqlite3_step@ indicated an error. We do not replicate that behavior +-- here. 'reset' never throws an exception. +reset :: PreparedStatement -> IO () +reset statement = do + _ <- Direct.reset statement + return () + +-- | +-- +-- Like 'reset', 'finalize' never throws an exception. +finalize :: PreparedStatement -> IO () +finalize statement = do + _ <- Direct.finalize statement + return () + +-- | +-- +-- Return the N-th Sql parameter name. +-- +-- Named parameters are returned as-is. E.g. \":v\" is returned as +-- @Just \":v\"@. Unnamed parameters, however, are converted to +-- @Nothing@. +-- +-- Note that the parameter index starts at 1, not 0. +bindParameterName :: PreparedStatement -> ParamIndex -> IO (Maybe Text) +bindParameterName stmt idx = do + m <- Direct.bindParameterName stmt idx + case m of + Nothing -> return Nothing + Just name -> Just <$> fromUtf8 desc name + where + desc = "Database.Sqlite3.bindParameterName: Invalid UTF-8" + +-- | +-- +-- Return the name of a result column. If the column index is out of range, +-- return 'Nothing'. +columnName :: PreparedStatement -> ColumnIndex -> IO (Maybe Text) +columnName stmt idx = do + m <- Direct.columnName stmt idx + case m of + Just name -> Just <$> fromUtf8 desc name + Nothing -> do + -- sqlite3_column_name only returns NULL if memory allocation fails + -- or if the column index is out of range. + count <- Direct.columnCount stmt + if idx >= 0 && idx < count + then throwIO outOfMemory + else return Nothing + where + desc = "Database.Sqlite3.columnName: Invalid UTF-8" + outOfMemory = + SqliteException + { sqliteError = ErrorNoMemory, + sqliteErrorDetails = "out of memory (sqlite3_column_name returned NULL)", + sqliteErrorContext = "column name" + } + +bindBlob :: PreparedStatement -> ParamIndex -> ByteString -> IO () +bindBlob statement parameterIndex byteString = do + result <- Direct.bindBlob statement parameterIndex byteString + checkError (DetailStatement statement) "bind blob" result + +bindZeroBlob :: PreparedStatement -> ParamIndex -> Int -> IO () +bindZeroBlob statement parameterIndex len = do + result <- Direct.bindZeroBlob statement parameterIndex len + checkError (DetailStatement statement) "bind zeroblob" result + +bindDouble :: PreparedStatement -> ParamIndex -> Double -> IO () +bindDouble statement parameterIndex datum = do + result <- Direct.bindDouble statement parameterIndex datum + checkError (DetailStatement statement) "bind double" result + +bindInt :: PreparedStatement -> ParamIndex -> Int -> IO () +bindInt statement parameterIndex datum = do + result <- Direct.bindInt64 statement parameterIndex (fromIntegral datum) + checkError (DetailStatement statement) "bind int" result + +bindInt64 :: PreparedStatement -> ParamIndex -> Int64 -> IO () +bindInt64 statement parameterIndex datum = do + result <- Direct.bindInt64 statement parameterIndex datum + checkError (DetailStatement statement) "bind int64" result + +bindNull :: PreparedStatement -> ParamIndex -> IO () +bindNull statement parameterIndex = do + result <- Direct.bindNull statement parameterIndex + checkError (DetailStatement statement) "bind null" result + +bindText :: PreparedStatement -> ParamIndex -> Text -> IO () +bindText statement parameterIndex text = do + result <- Direct.bindText statement parameterIndex (toUtf8 text) + checkError (DetailStatement statement) "bind text" result + +-- | If the index is not between 1 and 'bindParameterCount' inclusive, this +-- fails with 'ErrorRange'. Otherwise, it succeeds, even if the query skips +-- this index by using numbered parameters. +-- +-- Example: +-- +-- >> stmt <- prepare conn "SELECT ?1, ?3, ?5" +-- >> bindSqlData stmt 1 (SqlInteger 1) +-- >> bindSqlData stmt 2 (SqlInteger 2) +-- >> bindSqlData stmt 6 (SqlInteger 6) +-- >*** Exception: Sqlite3 returned ErrorRange while attempting to perform bind int64. +-- >> step stmt >> columns stmt +-- >[SqlInteger 1,SqlNull,SqlNull] +bindSqlData :: PreparedStatement -> ParamIndex -> SqlData -> IO () +bindSqlData statement idx datum = + case datum of + SqlInteger v -> bindInt64 statement idx v + SqlFloat v -> bindDouble statement idx v + SqlText v -> bindText statement idx v + SqlBlob v -> bindBlob statement idx v + SqlNull -> bindNull statement idx + +-- | Convenience function for binding values to all parameters. This will +-- 'fail' if the list has the wrong number of parameters. +bind :: PreparedStatement -> [SqlData] -> IO () +bind statement sqlData = do + ParamIndex nParams <- bindParameterCount statement + when (nParams /= length sqlData) do + fail + ( "mismatched parameter count for bind. Prepared statement " + ++ "needs " + ++ show nParams + ++ ", " + ++ show (length sqlData) + ++ " given" + ) + zipWithM_ (bindSqlData statement) [1 ..] sqlData + +-- | Convenience function for binding named values to all parameters. +-- This will 'fail' if the list has the wrong number of parameters or +-- if an unknown name is used. +-- +-- Example: +-- +-- @ +-- stmt <- prepare conn \"SELECT :foo + :bar\" +-- bindNamed stmt [(\":foo\", SqlInteger 1), (\":bar\", SqlInteger 2)] +-- @ +bindNamed :: PreparedStatement -> [(T.Text, SqlData)] -> IO () +bindNamed statement params = do + ParamIndex nParams <- bindParameterCount statement + when (nParams /= length params) do + fail + ( "mismatched parameter count for bind. Prepared statement " + ++ "needs " + ++ show nParams + ++ ", " + ++ show (length params) + ++ " given" + ) + mapM_ bindIdx params + where + bindIdx (name, val) = do + idx <- Direct.bindParameterIndex statement do toUtf8 name + case idx of + Just i -> + bindSqlData statement i val + Nothing -> + fail ("unknown named parameter " ++ show name) + +-- | This will throw a 'DecodeError' if the datum contains invalid UTF-8. +-- If this behavior is undesirable, you can use 'Direct.columnText' from +-- "Database.Sqlite3.Direct", which does not perform conversion to 'Text'. +columnText :: PreparedStatement -> ColumnIndex -> IO Text +columnText statement columnIndex = do + result <- Direct.columnText statement columnIndex + fromUtf8 "Database.Sqlite3.columnText: Invalid UTF-8" result + +column :: PreparedStatement -> ColumnIndex -> IO SqlData +column statement idx = do + theType <- columnType statement idx + typedColumn theType statement idx + +columns :: PreparedStatement -> IO [SqlData] +columns statement = do + count <- columnCount statement + mapM (column statement) [0 .. count - 1] + +typedColumn :: ColumnType -> PreparedStatement -> ColumnIndex -> IO SqlData +typedColumn theType statement idx = case theType of + IntegerColumn -> SqlInteger <$> columnInt64 statement idx + FloatColumn -> SqlFloat <$> columnDouble statement idx + TextColumn -> SqlText <$> columnText statement idx + BlobColumn -> SqlBlob <$> columnBlob statement idx + NullColumn -> return SqlNull + +-- | This avoids extra API calls using the list of column types. +-- If passed types do not correspond to the actual types, the values will be +-- converted according to the rules at . +-- If the list contains more items that number of columns, the result is undefined. +typedColumns :: PreparedStatement -> [Maybe ColumnType] -> IO [SqlData] +typedColumns statement = zipWithM f [0 ..] + where + f idx theType = case theType of + Nothing -> column statement idx + Just t -> typedColumn t statement idx + +-- | +-- +-- Create a custom Sql function or redefine the behavior of an existing +-- function. If the function is deterministic, i.e. if it always returns the +-- same result given the same input, you can set the boolean flag to let +-- @sqlite@ perform additional optimizations. +createFunction :: + Connection -> + -- | Name of the function. + Text -> + -- | Number of arguments. 'Nothing' means that the + -- function accepts any number of arguments. + Maybe ArgCount -> + -- | Is the function deterministic? + Bool -> + -- | Implementation of the function. + (FuncContext -> FuncArgs -> IO ()) -> + IO () +createFunction db name nArgs isDet fun = do + result <- Direct.createFunction db (toUtf8 name) nArgs isDet fun + checkError (DetailConnection db) ("createFunction " `appendShow` name) result + +-- | Like 'createFunction' except that it creates an aggregate function. +createAggregate :: + Connection -> + -- | Name of the function. + Text -> + -- | Number of arguments. + Maybe ArgCount -> + -- | Initial aggregate state. + a -> + -- | Process one row and update the aggregate state. + (FuncContext -> FuncArgs -> a -> IO a) -> + -- | Called after all rows have been processed. + -- Can be used to construct the returned value + -- from the aggregate state. + (FuncContext -> a -> IO ()) -> + IO () +createAggregate db name nArgs initSt xStep xFinal = do + result <- Direct.createAggregate db (toUtf8 name) nArgs initSt xStep xFinal + checkError (DetailConnection db) ("createAggregate " `appendShow` name) result + +-- | Delete an Sql function (scalar or aggregate). +deleteFunction :: Connection -> Text -> Maybe ArgCount -> IO () +deleteFunction db name nArgs = do + result <- Direct.deleteFunction db (toUtf8 name) nArgs + checkError (DetailConnection db) ("deleteFunction " `appendShow` name) result + +funcArgText :: FuncArgs -> ArgIndex -> IO Text +funcArgText args argIndex = do + result <- Direct.funcArgText args argIndex + fromUtf8 "Database.Sqlite3.funcArgText: Invalid UTF-8" result + +funcResultSqlData :: FuncContext -> SqlData -> IO () +funcResultSqlData ctx datum = + case datum of + SqlInteger v -> funcResultInt64 ctx v + SqlFloat v -> funcResultDouble ctx v + SqlText v -> funcResultText ctx v + SqlBlob v -> funcResultBlob ctx v + SqlNull -> funcResultNull ctx + +funcResultText :: FuncContext -> Text -> IO () +funcResultText ctx value = + Direct.funcResultText ctx (toUtf8 value) + +-- | +createCollation :: + Connection -> + -- | Name of the collation. + Text -> + -- | Comparison function. + (Text -> Text -> Ordering) -> + IO () +createCollation db name cmp = do + result <- Direct.createCollation db (toUtf8 name) cmp' + checkError (DetailConnection db) ("createCollation " `appendShow` name) result + where + cmp' (Utf8 s1) (Utf8 s2) = cmp (fromUtf8'' s1) (fromUtf8'' s2) + -- avoid throwing exceptions as much as possible + fromUtf8'' = decodeUtf8With lenientDecode + +-- | Delete a collation. +deleteCollation :: Connection -> Text -> IO () +deleteCollation db name = do + result <- Direct.deleteCollation db (toUtf8 name) + checkError (DetailConnection db) ("deleteCollation " `appendShow` name) result + +-- | +-- +-- Open a blob for incremental I/O. +blobOpen :: + Connection -> + -- | The symbolic name of the database (e.g. "main"). + Text -> + -- | The table name. + Text -> + -- | The column name. + Text -> + -- | The @ROWID@ of the row. + Int64 -> + -- | Open the blob for read-write. + Bool -> + IO Blob +blobOpen db zDb zTable zColumn rowid rw = do + result <- Direct.blobOpen db (toUtf8 zDb) (toUtf8 zTable) (toUtf8 zColumn) rowid rw + checkError (DetailConnection db) "blobOpen" result + +-- | +blobClose :: Blob -> IO () +blobClose blob@(Direct.Blob db _) = do + result <- Direct.blobClose blob + checkError (DetailConnection db) "blobClose" result + +-- | +blobReopen :: + Blob -> + -- | The @ROWID@ of the row. + Int64 -> + IO () +blobReopen blob@(Direct.Blob db _) rowid = do + result <- Direct.blobReopen blob rowid + checkError (DetailConnection db) "blobReopen" result + +-- | +blobRead :: + Blob -> + -- | Number of bytes to read. + Int -> + -- | Offset within the blob. + Int -> + IO ByteString +blobRead blob@(Direct.Blob db _) len offset = do + result <- Direct.blobRead blob len offset + checkError (DetailConnection db) "blobRead" result + +blobReadBuf :: Blob -> Ptr a -> Int -> Int -> IO () +blobReadBuf blob@(Direct.Blob db _) buf len offset = do + result <- Direct.blobReadBuf blob buf len offset + checkError (DetailConnection db) "blobReadBuf" result + +-- | +blobWrite :: + Blob -> + ByteString -> + -- | Offset within the blob. + Int -> + IO () +blobWrite blob@(Direct.Blob db _) bs offset = do + result <- Direct.blobWrite blob bs offset + checkError (DetailConnection db) "blobWrite" result + +backupInit :: + -- | Destination database handle. + Connection -> + -- | Destination database name. + Text -> + -- | Source database handle. + Connection -> + -- | Source database name. + Text -> + IO Backup +backupInit dstDb dstName srcDb srcName = do + result <- Direct.backupInit dstDb (toUtf8 dstName) srcDb (toUtf8 srcName) + checkError (DetailConnection dstDb) "backupInit" result + +backupFinish :: Backup -> IO () +backupFinish backup@(Direct.Backup dstDb _) = do + result <- Direct.backupFinish backup + checkError (DetailConnection dstDb) "backupFinish" result + +backupStep :: Backup -> Int -> IO BackupStepResult +backupStep backup pages = do + result <- Direct.backupStep backup pages + -- it appears that sqlite does not generate an + -- error message when sqlite3_backup_step fails + checkError (DetailMessage (toUtf8 "failed")) "backupStep" result diff --git a/lib/Sqlite/Query.hs b/lib/Sqlite/Query.hs new file mode 100644 --- /dev/null +++ b/lib/Sqlite/Query.hs @@ -0,0 +1,817 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} + +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- A 'Sql' type representing queries and statements, along with functions for +-- executing those. Serialization of parameters and deserialization of results +-- from/to common Haskell types. +module Sqlite.Query + ( -- ** Examples of use + -- $use + + -- ** The Sql type + -- $querytype + + -- ** Parameter substitution + -- $subst + + -- *** Positional parameters + -- $substpos + + -- *** Named parameters + -- $substnamed + + -- *** Type inference + -- $inference + + -- ** Substituting a single parameter + -- $only_param + + -- * Extracting results + -- $result + + -- ** Handling null values + -- $null + + -- ** Type conversions + -- $types + Sql (..), + Connection (..), + ToRow (..), + FromRow (..), + Solo (..), + (:.) (..), + SqlData (..), + PreparedStatement, + ColumnIndex (..), + NamedParam (..), + + -- * Queries that return results + select, + select_, + selectWith, + selectWith_, + selectNamed, + lastInsertRowId, + changes, + totalChanges, + + -- * Queries that stream results + fold, + fold_, + foldNamed, + + -- * Statements that do not return results + execute, + execute_, + executeMany, + executeNamed, + field, + + -- * Low-level statement API for stream access and prepared statements + openStatement, + closeStatement, + withStatement, + bind, + bindNamed, + reset, + columnName, + columnCount, + withBind, + nextRow, + foldPrepared, + + -- * Transactions + withTransaction, + withImmediateTransaction, + withExclusiveTransaction, + + -- ** Exceptions + FormatError (..), + ResultError (..), + Sqlite.SqliteException (..), + Sqlite.Error (..), + ) +where + +import Control.Exception +import Control.Monad (forM_, void, when) +import Data.Int (Int64) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Sqlite (ColumnIndex, PreparedStatement, SqlData) +import Sqlite qualified +import Sqlite.Direct (Connection) +import Sqlite.Direct qualified +import Sqlite.Query.FromField (ResultError (..)) +import Sqlite.Query.FromRow +import Sqlite.Query.Internal +import Sqlite.Query.Ok +import Sqlite.Query.ToField (ToField (..)) +import Sqlite.Query.ToRow (ToRow (..)) +import Sqlite.Query.Types + +data NamedParam where + (:=) :: (ToField v) => T.Text -> v -> NamedParam + +data TransactionType + = Deferred + | Immediate + | Exclusive + | Savepoint T.Text + +infixr 3 := + +instance Show NamedParam where + show (k := v) = show (k, toField v) + +-- | Exception thrown if a 'Sql' was malformed. +-- This may occur if the number of \'@?@\' characters in the query +-- string does not match the number of parameters provided. +data FormatError = FormatError + { fmtMessage :: String, + fmtSql :: Sql, + fmtParams :: [String] + } + deriving (Eq, Show) + +instance Exception FormatError + +unUtf8 :: Sqlite.Direct.Utf8 -> T.Text +unUtf8 (Sqlite.Direct.Utf8 bs) = TE.decodeUtf8 bs + +-- | Binds parameters to a prepared statement. Once 'nextRow' returns 'Nothing', +-- the statement must be reset with the 'reset' function before it can be +-- executed again by calling 'nextRow'. +bind :: (ToRow params) => PreparedStatement -> params -> IO () +bind stmt params = do + let qp = toRow params + stmtParamCount <- Sqlite.bindParameterCount stmt + when (length qp /= fromIntegral stmtParamCount) (throwColumnMismatch qp stmtParamCount) + mapM_ (errorCheckParamName qp) [1 .. stmtParamCount] + Sqlite.bind stmt qp + where + throwColumnMismatch qp nParams = do + templ <- getSql stmt + fmtError + ( "Sql query contains " + ++ show nParams + ++ " params, but " + ++ show (length qp) + ++ " arguments given" + ) + templ + qp + errorCheckParamName qp paramNdx = do + templ <- getSql stmt + name <- Sqlite.bindParameterName stmt paramNdx + case name of + Just n -> + fmtError + ("Only unnamed '?' query parameters are accepted, '" ++ T.unpack n ++ "' given") + templ + qp + Nothing -> return () + +-- | Binds named parameters to a prepared statement. +bindNamed :: PreparedStatement -> [NamedParam] -> IO () +bindNamed stmt params = do + stmtParamCount <- Sqlite.bindParameterCount stmt + when (length params /= fromIntegral stmtParamCount) $ throwColumnMismatch stmtParamCount + mapM_ + ( \(n := v) -> do + idx <- Sqlite.Direct.bindParameterIndex stmt (Sqlite.Direct.Utf8 . TE.encodeUtf8 $ n) + case idx of + Just i -> + Sqlite.bindSqlData stmt i (toField v) + Nothing -> do + templ <- getSql stmt + fmtError + ("Unknown named parameter '" ++ T.unpack n ++ "'") + templ + params + ) + params + where + throwColumnMismatch nParams = do + templ <- getSql stmt + fmtError + ( "Sql query contains " + ++ show nParams + ++ " params, but " + ++ show (length params) + ++ " arguments given" + ) + templ + params + +-- | Resets a statement. This does not reset bound parameters, if any, but +-- allows the statement to be reexecuted again by invoking 'nextRow'. +reset :: PreparedStatement -> IO () +reset stmt = Sqlite.reset stmt + +-- | Return the name of a a particular column in the result set of a +-- 'PreparedStatement'. Throws an 'ArrayException' if the colum index is out +-- of bounds. +-- +-- +columnName :: PreparedStatement -> ColumnIndex -> IO T.Text +columnName stmt n = Sqlite.Direct.columnName stmt n >>= takeUtf8 + where + takeUtf8 (Just s) = return $ unUtf8 s + takeUtf8 Nothing = + throwIO (IndexOutOfBounds ("Column index " ++ show n ++ " out of bounds")) + +-- | Return number of columns in the query +columnCount :: PreparedStatement -> IO ColumnIndex +columnCount stmt = Sqlite.Direct.columnCount stmt + +-- | Binds parameters to a prepared statement, and 'reset's the statement when +-- the callback completes, even in the presence of exceptions. +-- +-- Use 'withBind' to reuse prepared statements. Because it 'reset's the +-- statement /after/ each usage, it avoids a pitfall involving implicit +-- transactions. Sqlite creates an implicit transaction if you don't say +-- @BEGIN@ explicitly, and does not commit it until all active statements are +-- finished with either 'reset' or 'closeStatement'. +withBind :: (ToRow params) => PreparedStatement -> params -> IO a -> IO a +withBind stmt params io = do + bind stmt params + io `finally` reset stmt + +-- | Opens a prepared statement. A prepared statement must always be closed with +-- a corresponding call to 'closeStatement' before closing the connection. Use +-- 'nextRow' to iterate on the values returned. Once 'nextRow' returns +-- 'Nothing', you need to invoke 'reset' before reexecuting the statement again +-- with 'nextRow'. +openStatement :: Connection -> Sql -> IO PreparedStatement +openStatement conn (Sql t) = do + Sqlite.prepare conn t + +-- | Closes a prepared statement. +closeStatement :: PreparedStatement -> IO () +closeStatement stmt = Sqlite.finalize stmt + +-- | Opens a prepared statement, executes an action using this statement, and +-- closes the statement, even in the presence of exceptions. +withStatement :: Connection -> Sql -> (PreparedStatement -> IO a) -> IO a +withStatement conn query = bracket (openStatement conn query) closeStatement + +-- A version of 'withStatement' which binds parameters. +withStatementParams :: + (ToRow params) => + Connection -> + Sql -> + params -> + (PreparedStatement -> IO a) -> + IO a +withStatementParams conn template params action = + withStatement conn template $ \stmt -> + -- Don't use withBind here, there is no need to reset the parameters since + -- we're destroying the statement + bind stmt (toRow params) >> action stmt + +-- A version of 'withStatement' which binds named parameters. +withStatementNamedParams :: + Connection -> + Sql -> + [NamedParam] -> + (PreparedStatement -> IO a) -> + IO a +withStatementNamedParams conn template namedParams action = + withStatement conn template $ \stmt -> bindNamed stmt namedParams >> action stmt + +-- | Execute an @INSERT@, @UPDATE@, or other Sql query that is not +-- expected to return results. +-- +-- Throws 'FormatError' if the query could not be formatted correctly. +execute :: (ToRow q) => Connection -> Sql -> q -> IO () +execute conn template qs = + withStatementParams conn template qs $ \stmt -> + void . Sqlite.step $ stmt + +-- | Execute a multi-row @INSERT@, @UPDATE@, or other Sql query that is not +-- expected to return results. +-- +-- Throws 'FormatError' if the query could not be formatted correctly. +executeMany :: (ToRow q) => Connection -> Sql -> [q] -> IO () +executeMany conn template paramRows = withStatement conn template $ \stmt -> do + forM_ paramRows $ \params -> + withBind + stmt + params + (void . Sqlite.step $ stmt) + +-- | Perform a @SELECT@ or other Sql query that is expected to return +-- results. All results are retrieved and converted before this +-- function returns. +-- +-- When processing large results, this function will consume a lot of +-- client-side memory. Consider using 'fold' instead. +-- +-- Exceptions that may be thrown: +-- +-- * 'FormatError': the query string mismatched with given arguments. +-- +-- * 'ResultError': result conversion failed. +select :: + (ToRow q, FromRow r) => + Connection -> + Sql -> + q -> + IO [r] +select = selectWith fromRow + +-- | A version of 'query' that does not perform query substitution. +select_ :: (FromRow r) => Connection -> Sql -> IO [r] +select_ = selectWith_ fromRow + +-- | A version of 'query' that takes an explicit 'RowParser'. +selectWith :: (ToRow q) => RowParser r -> Connection -> Sql -> q -> IO [r] +selectWith fromRow_ conn templ qs = + withStatementParams conn templ qs do doFoldToList fromRow_ + +-- | A version of 'query' that does not perform query substitution and +-- takes an explicit 'RowParser'. +selectWith_ :: RowParser r -> Connection -> Sql -> IO [r] +selectWith_ fromRow_ conn query = + withStatement conn query do doFoldToList fromRow_ + +-- | A version of 'query' where the query parameters (placeholders) +-- are named. +-- +-- Example: +-- +-- @ +-- r \<- 'queryNamed' c \"SELECT * FROM posts WHERE id=:id AND date>=:date\" [\":id\" ':=' postId, \":date\" ':=' afterDate] +-- @ +selectNamed :: (FromRow r) => Connection -> Sql -> [NamedParam] -> IO [r] +selectNamed conn templ params = + withStatementNamedParams conn templ params do doFoldToList fromRow + +-- | A version of 'execute' that does not perform query substitution. +execute_ :: Connection -> Sql -> IO () +execute_ conn template = + withStatement conn template \stmt -> + void do Sqlite.step stmt + +-- | A version of 'execute' where the query parameters (placeholders) +-- are named. +executeNamed :: Connection -> Sql -> [NamedParam] -> IO () +executeNamed conn template params = + withStatementNamedParams conn template params $ \stmt -> + void $ Sqlite.step stmt + +-- | Perform a @SELECT@ or other Sql query that is expected to return results. +-- Results are converted and fed into the 'action' callback as they are being +-- retrieved from the database. +-- +-- This allows gives the possibility of processing results in constant space +-- (for instance writing them to disk). +-- +-- Exceptions that may be thrown: +-- +-- * 'FormatError': the query string mismatched with given arguments. +-- +-- * 'ResultError': result conversion failed. +fold :: + (FromRow row, ToRow params) => + Connection -> + Sql -> + params -> + (a -> row -> IO a) -> + IO a -> + IO a +fold conn query params action initalState = + withStatementParams conn query params $ \stmt -> + doFold fromRow stmt action initalState + +doFoldToList :: RowParser row -> PreparedStatement -> IO [row] +doFoldToList fromRow_ stmt = + reverse <$> doFold fromRow_ stmt (\acc e -> return (e : acc)) (pure []) + +-- | A version of 'fold' which does not perform parameter substitution. +fold_ :: + (FromRow row) => + Connection -> + Sql -> + (a -> row -> IO a) -> + IO a -> + IO a +fold_ conn query action initalState = + withStatement conn query $ \stmt -> + doFold fromRow stmt action initalState + +-- | A version of 'fold' where the query parameters (placeholders) are +-- named. +foldNamed :: + (FromRow row) => + Connection -> + Sql -> + [NamedParam] -> + (a -> row -> IO a) -> + IO a -> + IO a +foldNamed conn query params action initalState = + withStatementNamedParams conn query params $ \stmt -> + doFold fromRow stmt action initalState + +foldPrepared :: (FromRow row) => PreparedStatement -> (a -> row -> IO a) -> IO a -> IO a +foldPrepared = doFold fromRow + +doFold :: RowParser row -> PreparedStatement -> (a -> row -> IO a) -> IO a -> IO a +doFold fromRow_ stmt action initialAction = do + initialValue <- initialAction + loop initialValue + where + loop val = do + maybeNextRow <- nextRowWith fromRow_ stmt + case maybeNextRow of + Just row -> do + val' <- action val row + val' `seq` loop val' + Nothing -> return val + +-- | Extracts the next row from the prepared statement. +nextRow :: (FromRow r) => PreparedStatement -> IO (Maybe r) +nextRow = nextRowWith fromRow + +nextRowWith :: RowParser r -> PreparedStatement -> IO (Maybe r) +nextRowWith fromRow_ stmt = do + statRes <- Sqlite.step stmt + case statRes of + Sqlite.Row -> do + rowRes <- Sqlite.columns stmt + let nCols = length rowRes + row <- convertRow fromRow_ rowRes nCols + return $ Just row + Sqlite.Done -> return Nothing + +convertRow :: RowParser r -> [SqlData] -> Int -> IO r +convertRow fromRow_ rowRes ncols = do + let rw = RowParserRO ncols + case runRowParser fromRow_ rw (0, rowRes) of + Ok (val, (col, _)) + | col == ncols -> return val + | otherwise -> errorColumnMismatch (ColumnOutOfBounds col) + Errors [] -> throwIO $ ConversionFailed "" "" "unknown error" + Errors [x] -> + throw x `Control.Exception.catch` (\e -> errorColumnMismatch (e :: ColumnOutOfBounds)) + Errors xs -> throwIO $ ManyErrors xs + where + errorColumnMismatch :: ColumnOutOfBounds -> IO r + errorColumnMismatch (ColumnOutOfBounds c) = do + let vals = map (\f -> (gettypename f, ellipsis f)) rowRes + throwIO + ( ConversionFailed + (show ncols ++ " values: " ++ show vals) + ("at least " ++ show c ++ " slots in target type") + "mismatch between number of columns to convert and number in target type" + ) + + ellipsis :: SqlData -> T.Text + ellipsis sql + | T.length bs > 20 = T.take 15 bs `T.append` "[...]" + | otherwise = bs + where + bs = T.pack $ show sql + +withTransactionPrivate :: Connection -> IO a -> TransactionType -> IO a +withTransactionPrivate conn action ttype = + mask $ \restore -> do + begin + r <- restore action `onException` rollback + commit + return r + where + begin = execute_ conn $ case ttype of + Deferred -> "BEGIN TRANSACTION" + Immediate -> "BEGIN IMMEDIATE TRANSACTION" + Exclusive -> "BEGIN EXCLUSIVE TRANSACTION" + Savepoint name -> Sql $ "SAVEPOINT '" <> name <> "'" + commit = execute_ conn $ case ttype of + Savepoint name -> Sql $ "RELEASE '" <> name <> "'" + _ -> "COMMIT TRANSACTION" + rollback = execute_ conn $ case ttype of + Savepoint name -> Sql $ "ROLLBACK TO '" <> name <> "'" + _ -> "ROLLBACK TRANSACTION" + +-- | Run an IO action inside a Sql transaction started with @BEGIN IMMEDIATE +-- TRANSACTION@, which immediately blocks all other database connections from +-- writing. The default Sqlite3 @BEGIN TRANSACTION@ does not acquire the write +-- lock on @BEGIN@ nor on @SELECT@ but waits until you try to change data. If +-- the action throws any kind of an exception, the transaction will be rolled +-- back with @ROLLBACK TRANSACTION@. Otherwise the results are committed with +-- @COMMIT TRANSACTION@. +withImmediateTransaction :: Connection -> IO a -> IO a +withImmediateTransaction conn action = + withTransactionPrivate conn action Immediate + +-- | Run an IO action inside a Sql transaction started with @BEGIN EXCLUSIVE +-- TRANSACTION@, which immediately blocks all other database connections from +-- writing, and other connections from reading (exception: read_uncommitted +-- connections are allowed to read.) If the action throws any kind of an +-- exception, the transaction will be rolled back with @ROLLBACK TRANSACTION@. +-- Otherwise the results are committed with @COMMIT TRANSACTION@. +withExclusiveTransaction :: Connection -> IO a -> IO a +withExclusiveTransaction conn action = + withTransactionPrivate conn action Exclusive + +-- | Returns the rowid of the most recent successful INSERT on the +-- given database connection. +-- +-- See also . +lastInsertRowId :: Connection -> IO Int64 +lastInsertRowId = Sqlite.Direct.lastInsertRowId + +-- | +-- +-- Return the number of rows that were changed, inserted, or deleted +-- by the most recent @INSERT@, @DELETE@, or @UPDATE@ statement. +changes :: Connection -> IO Int +changes = Sqlite.Direct.changes + +-- | +-- +-- Return the total number of row changes caused by @INSERT@, @DELETE@, +-- or @UPDATE@ statements since the 'Database' was opened. +totalChanges :: Connection -> IO Int +totalChanges = Sqlite.Direct.totalChanges + +-- | Run an IO action inside a Sql transaction started with @BEGIN +-- TRANSACTION@. If the action throws any kind of an exception, the +-- transaction will be rolled back with @ROLLBACK TRANSACTION@. +-- Otherwise the results are committed with @COMMIT TRANSACTION@. +withTransaction :: Connection -> IO a -> IO a +withTransaction conn action = + withTransactionPrivate conn action Deferred + +fmtError :: (Show v) => String -> Sql -> [v] -> a +fmtError msg q xs = + throw + FormatError + { fmtMessage = msg, + fmtSql = q, + fmtParams = map show xs + } + +getSql :: Sqlite.PreparedStatement -> IO Sql +getSql stmt = + toQuery <$> Sqlite.Direct.statementSql stmt + where + toQuery = + Sql . maybe "no query string" (\(Sqlite.Direct.Utf8 s) -> TE.decodeUtf8 s) + +-- $use +-- An example that creates a table 'test', inserts a couple of rows +-- and proceeds to showcase how to update or delete rows. This +-- example also demonstrates the use of 'lastInsertRowId' (how to +-- refer to a previously inserted row) and 'executeNamed' (an easier +-- to maintain form of query parameter naming). +-- +-- >{-# LANGUAGE OverloadedStrings #-} +-- > +-- >import Control.Applicative +-- >import qualified Data.Text as T +-- >import Sqlite +-- >import Sqlite.Query +-- > +-- >data TestField = TestField Int T.Text deriving (Show) +-- > +-- >instance FromRow TestField where +-- > fromRow = TestField <$> field <*> field +-- > +-- >instance ToRow TestField where +-- > toRow (TestField id_ str) = toRow (id_, str) +-- > +-- >main :: IO () +-- >main = do +-- > conn <- open "test.db" +-- > execute_ conn "CREATE TABLE IF NOT EXISTS test (id INTEGER PRIMARY KEY, str TEXT)" +-- > execute conn "INSERT INTO test (str) VALUES (?)" (Only ("test string 2" :: String)) +-- > execute conn "INSERT INTO test (id, str) VALUES (?,?)" (TestField 13 "test string 3") +-- > rowId <- lastInsertRowId conn +-- > executeNamed conn "UPDATE test SET str = :str WHERE id = :id" [":str" := ("updated str" :: T.Text), ":id" := rowId] +-- > r <- query_ conn "SELECT * from test" :: IO [TestField] +-- > mapM_ print r +-- > execute conn "DELETE FROM test WHERE id = ?" (Only rowId) +-- > close conn + +-- $querytype +-- +-- Sql-based applications are somewhat notorious for their +-- susceptibility to attacks through the injection of maliciously +-- crafted data. The primary reason for widespread vulnerability to +-- Sql injections is that many applications are sloppy in handling +-- user data when constructing Sql queries. +-- +-- This library provides a 'Sql' type and a parameter substitution +-- facility to address both ease of use and security. A 'Sql' is a +-- @newtype@-wrapped 'Text'. It intentionally exposes a tiny API that +-- is not compatible with the 'Text' API; this makes it difficult to +-- construct queries from fragments of strings. The 'query' and +-- 'execute' functions require queries to be of type 'Sql'. +-- +-- To most easily construct a query, enable GHC's @OverloadedStrings@ +-- language extension and write your query as a normal literal string. +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Sqlite +-- > import Sqlite.Query +-- > +-- > hello = do +-- > conn <- open "test.db" +-- > [[x]] <- query_ conn "select 2 + 2" +-- > print x +-- +-- A 'Sql' value does not represent the actual query that will be +-- executed, but is a template for constructing the final query. + +-- $subst +-- +-- Since applications need to be able to construct queries with +-- parameters that change, this library uses Sqlite's parameter +-- binding query substitution capability. +-- +-- This library restricts parameter substitution to work only with +-- named parameters and positional arguments with the \"@?@\" syntax. +-- The API does not support for mixing these two types of bindings. +-- Unsupported parameters will be rejected and a 'FormatError' will be +-- thrown. +-- +-- You should always use parameter substitution instead of inlining +-- your dynamic parameters into your queries with messy string +-- concatenation. Sqlite will automatically quote and escape your +-- data into these placeholder parameters; this defeats the single +-- most common injection vector for malicious data. + +-- $substpos +-- +-- The 'Sql' template accepted by 'query', 'execute' and 'fold' can +-- contain any number of \"@?@\" characters. Both 'query' and +-- 'execute' accept a third argument, typically a tuple. When the +-- query executes, the first \"@?@\" in the template will be replaced +-- with the first element of the tuple, the second \"@?@\" with the +-- second element, and so on. This substitution happens inside the +-- native Sqlite implementation. +-- +-- For example, given the following 'Sql' template: +-- +-- > select * from user where first_name = ? and age > ? +-- +-- And a tuple of this form: +-- +-- > ("Boris" :: String, 37 :: Int) +-- +-- The query to be executed will look like this after substitution: +-- +-- > select * from user where first_name = 'Boris' and age > 37 +-- +-- If there is a mismatch between the number of \"@?@\" characters in +-- your template and the number of elements in your tuple, a +-- 'FormatError' will be thrown. +-- +-- Note that the substitution functions do not attempt to parse or +-- validate your query. It's up to you to write syntactically valid +-- Sql, and to ensure that each \"@?@\" in your query template is +-- matched with the right tuple element. + +-- $substnamed +-- +-- Named parameters are accepted by 'queryNamed', 'executeNamed' and +-- 'foldNamed'. These functions take a list of 'NamedParam's which +-- are key-value pairs binding a value to an argument name. As is the +-- case with \"@?@\" parameters, named parameters are automatically +-- escaped by the Sqlite library. The parameter names are prefixed +-- with either @:@ or @\@@, e.g. @:foo@ or @\@foo@. +-- +-- Example: +-- +-- @ +-- r \<- 'queryNamed' c \"SELECT id,text FROM posts WHERE id = :id AND date >= :date\" [\":id\" ':=' postId, \":date\" ':=' afterDate] +-- @ +-- +-- Note that you can mix different value types in the same list. +-- E.g., the following is perfectly legal: +-- +-- @ +-- [\":id\" ':=' (3 :: Int), \":str\" ':=' (\"foo\" :: String)] +-- @ +-- +-- The parameter name (or key) in the 'NamedParam' must match exactly +-- the name written in the Sql query. E.g., if you used @:foo@ in +-- your Sql statement, you need to use @\":foo\"@ as the parameter +-- key, not @\"foo\"@. Some libraries like Python's sqlite3 +-- automatically drop the @:@ character from the name. + +-- $inference +-- +-- Automated type inference means that you will often be able to avoid +-- supplying explicit type signatures for the elements of a tuple. +-- However, sometimes the compiler will not be able to infer your +-- types. Consider a case where you write a numeric literal in a +-- parameter tuple: +-- +-- > query conn "select ? + ?" (40,2) +-- +-- The above query will be rejected by the compiler, because it does +-- not know the specific numeric types of the literals @40@ and @2@. +-- This is easily fixed: +-- +-- > query conn "select ? + ?" (40 :: Double, 2 :: Double) +-- +-- The same kind of problem can arise with string literals if you have +-- the @OverloadedStrings@ language extension enabled. Again, just +-- use an explicit type signature if this happens. + +-- $only_param +-- +-- Haskell lacks a single-element tuple type, so if you have just one +-- value you want substituted into a query, what should you do? +-- +-- To represent a single value @val@ as a parameter, write a singleton +-- list @[val]@, use 'Just' @val@, or use 'Only' @val@. +-- +-- Here's an example using a singleton list: +-- +-- > execute conn "insert into users (first_name) values (?)" +-- > ["Nuala"] +-- +-- Or you can use named parameters which do not have this restriction. + +-- $result +-- +-- The 'query' and 'query_' functions return a list of values in the +-- 'FromRow' typeclass. This class performs automatic extraction +-- and type conversion of rows from a query result. +-- +-- Here is a simple example of how to extract results: +-- +-- > import qualified Data.Text as T +-- > +-- > xs <- query_ conn "select name,age from users" +-- > forM_ xs $ \(name,age) -> +-- > putStrLn $ T.unpack name ++ " is " ++ show (age :: Int) +-- +-- Notice two important details about this code: +-- +-- * The number of columns we ask for in the query template must +-- exactly match the number of elements we specify in a row of the +-- result tuple. If they do not match, a 'ResultError' exception +-- will be thrown. +-- +-- * Sometimes, the compiler needs our help in specifying types. It +-- can infer that @name@ must be a 'Text', due to our use of the +-- @unpack@ function. However, we have to tell it the type of @age@, +-- as it has no other information to determine the exact type. + +-- $null +-- +-- The type of a result tuple will look something like this: +-- +-- > (Text, Int, Int) +-- +-- Although Sql can accommodate @NULL@ as a value for any of these +-- types, Haskell cannot. If your result contains columns that may be +-- @NULL@, be sure that you use 'Maybe' in those positions of of your +-- tuple. +-- +-- > (Text, Maybe Int, Int) +-- +-- If 'query' encounters a @NULL@ in a row where the corresponding +-- Haskell type is not 'Maybe', it will throw a 'ResultError' +-- exception. + +-- $only_result +-- +-- To specify that a query returns a single-column result, use the +-- 'Only' type. +-- +-- > xs <- query_ conn "select id from users" +-- > forM_ xs $ \(Only dbid) -> {- ... -} + +-- $types +-- +-- Conversion of Sql values to Haskell values is somewhat +-- permissive. Here are the rules. +-- +-- * For numeric types, any Haskell type that can accurately represent +-- an Sqlite INTEGER is considered \"compatible\". +-- +-- * If a numeric incompatibility is found, 'query' will throw a +-- 'ResultError'. +-- +-- * Sqlite's TEXT type is always encoded in UTF-8. Thus any text +-- data coming from an Sqlite database should always be compatible +-- with Haskell 'String' and 'Text' types. +-- +-- * Sqlite's BLOB type will only be conversible to a Haskell +-- 'ByteString'. +-- +-- You can extend conversion support to your own types be adding your +-- own 'FromField' / 'ToField' instances. diff --git a/lib/Sqlite/Query/FromField.hs b/lib/Sqlite/Query/FromField.hs new file mode 100644 --- /dev/null +++ b/lib/Sqlite/Query/FromField.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE BlockArguments #-} + +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- The 'FromField' typeclass, for converting a single value in a row +-- returned by a Sql query into a more useful Haskell representation. +-- +-- A Haskell numeric type is considered to be compatible with all +-- Sqlite numeric types that are less accurate than it. For instance, +-- the Haskell 'Double' type is compatible with the Sqlite's 32-bit +-- @Int@ type because it can represent a @Int@ exactly. On the other hand, +-- since a 'Double' might lose precision if representing a 64-bit @BigInt@, +-- the two are /not/ considered compatible. +module Sqlite.Query.FromField + ( FromField (..), + FieldParser, + ResultError (..), + Field, + fieldData, + returnError, + ) +where + +import Control.Exception (Exception, SomeException (..)) +import Data.ByteString (ByteString) +import Data.ByteString.Char8 qualified as B +import Data.ByteString.Lazy qualified as LB +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Text qualified as T +import Data.Text.Lazy qualified as LT +import Data.Typeable (Typeable, typeOf) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Float (double2Float) +import Sqlite as Base +import Sqlite.Query.Internal +import Sqlite.Query.Ok +import Sqlite.Query.Types + +-- | Exception thrown if conversion from a Sql value to a Haskell +-- value fails. +data ResultError + = -- | The Sql and Haskell types are not compatible. + Incompatible + { errSqlType :: String, + errHaskellType :: String, + errMessage :: String + } + | -- | A Sql @NULL@ was encountered when the Haskell + -- type did not permit it. + UnexpectedNull + { errSqlType :: String, + errHaskellType :: String, + errMessage :: String + } + | -- | The Sql value could not be parsed, or could not + -- be represented as a valid Haskell value, or an + -- unexpected low-level error occurred (e.g. mismatch + -- between metadata and actual data in a row). + ConversionFailed + { errSqlType :: String, + errHaskellType :: String, + errMessage :: String + } + deriving (Eq, Show) + +instance Exception ResultError + +left :: (Exception a) => a -> Ok b +left = Errors . (: []) . SomeException + +type FieldParser a = Field -> Ok a + +-- | A type that may be converted from a Sql type. +class FromField a where + fromField :: FieldParser a + -- ^ Convert a Sql value to a Haskell value. + -- + -- Returns a list of exceptions if the conversion fails. In the case of + -- library instances, this will usually be a single 'ResultError', but + -- may be a 'UnicodeException'. + -- + -- Implementations of 'fromField' should not retain any references to + -- the 'Field' nor the 'ByteString' arguments after the result has + -- been evaluated to WHNF. Such a reference causes the entire + -- @LibPQ.'PQ.Result'@ to be retained. + -- + -- For example, the instance for 'ByteString' uses 'B.copy' to avoid + -- such a reference, and that using bytestring functions such as 'B.drop' + -- and 'B.takeWhile' alone will also trigger this memory leak. + +instance (FromField a) => FromField (Maybe a) where + fromField (Field SqlNull _) = pure Nothing + fromField f = Just <$> fromField f + +instance FromField Null where + fromField (Field SqlNull _) = pure Null + fromField f = returnError ConversionFailed f "data is not null" + +takeInt :: (Num a, Typeable a) => Field -> Ok a +takeInt (Field (SqlInteger i) _) = Ok . fromIntegral $ i +takeInt f = returnError ConversionFailed f "need an int" + +instance FromField Int8 where + fromField = takeInt + +instance FromField Int16 where + fromField = takeInt + +instance FromField Int32 where + fromField = takeInt + +instance FromField Int where + fromField = takeInt + +instance FromField Int64 where + fromField = takeInt + +instance FromField Integer where + fromField = takeInt + +instance FromField Word8 where + fromField = takeInt + +instance FromField Word16 where + fromField = takeInt + +instance FromField Word32 where + fromField = takeInt + +instance FromField Word64 where + fromField = takeInt + +instance FromField Word where + fromField = takeInt + +instance FromField Double where + fromField (Field (SqlFloat flt) _) = Ok flt + fromField f = returnError ConversionFailed f "expecting an SqlFloat column type" + +instance FromField Float where + fromField (Field (SqlFloat flt) _) = Ok . double2Float $ flt + fromField f = returnError ConversionFailed f "expecting an SqlFloat column type" + +instance FromField Bool where + fromField f@(Field (SqlInteger b) _) + | (b == 0) || (b == 1) = Ok (b /= 0) + | otherwise = returnError ConversionFailed f ("bool must be 0 or 1, got " ++ show b) + fromField f = returnError ConversionFailed f "expecting an SqlInteger column type" + +instance FromField T.Text where + fromField f@(Field sqlData _) = case sqlData of + SqlText v -> Ok v + SqlInteger v -> Ok $ T.pack $ show v + SqlFloat v -> Ok $ T.pack $ show v + _ -> returnError ConversionFailed f "need convertible to text" + +instance FromField LT.Text where + fromField f = LT.fromStrict <$> fromField f + +instance FromField [Char] where + fromField f = T.unpack <$> fromField f + +instance FromField ByteString where + fromField (Field (SqlBlob blb) _) = Ok blb + fromField f = returnError ConversionFailed f "expecting SqlBlob column type" + +instance FromField LB.ByteString where + fromField (Field (SqlBlob blb) _) = Ok . LB.fromChunks $ [blb] + fromField f = returnError ConversionFailed f "expecting SqlBlob column type" + +instance FromField SqlData where + fromField :: FieldParser SqlData + fromField f = Ok (fieldData f) + +fieldTypename :: Field -> String +fieldTypename = B.unpack . gettypename . result + +-- | Return the actual Sql data for a database field. This allows +-- user-defined 'FromField' instances to access the Sql data +-- associated with a field being parsed. +fieldData :: Field -> SqlData +fieldData = result + +-- | Given one of the constructors from 'ResultError', the field, +-- and an 'errMessage', this fills in the other fields in the +-- exception value and returns it in a 'Left . SomeException' +-- constructor. +returnError :: + forall a err. + (Typeable a, Exception err) => + (String -> String -> String -> err) -> + Field -> + String -> + Ok a +returnError mkErr f = + left + . mkErr + (fieldTypename f) + (show (typeOf (undefined :: a))) diff --git a/lib/Sqlite/Query/FromRow.hs b/lib/Sqlite/Query/FromRow.hs new file mode 100644 --- /dev/null +++ b/lib/Sqlite/Query/FromRow.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DefaultSignatures #-} + +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- The 'FromRow' typeclass, for converting a row of results +-- returned by a Sql query into a more useful Haskell representation. +-- +-- Predefined instances are provided for tuples containing up to ten +-- elements. +module Sqlite.Query.FromRow + ( GFromRow (..), + FromRow (..), + RowParser, + field, + fieldWith, + numFieldsRemaining, + ) +where + +import Control.Exception (SomeException (..)) +import Control.Monad (replicateM) +import GHC.Generics +import Sqlite.Query.FromField +import Sqlite.Query.Internal +import Sqlite.Query.Ok +import Sqlite.Query.Types + +-- | Generic derivation of 'FromRow'. +-- +-- Instantiating 'FromRow' can in some cases be quite tedious. Luckily +-- we can derive it generically in some cases where the type at hand +-- has a 'Generic' instance. The current implementation only works +-- for a (n-ary) product types. So we would not be able to +-- e.g. derive a 'FromRow' instance for +-- +-- @ +-- data Bool = True | False +-- @ +-- +-- We /can/, however, derive a generic instance for the @User@ type +-- (see the example in 'FromRow'). +-- +-- @since 0.4.18.1 +class GFromRow f where + gfromRow :: RowParser (f a) + +instance GFromRow U1 where + gfromRow = pure U1 + +instance (FromField a) => GFromRow (K1 i a) where + gfromRow = K1 <$> field + +instance (GFromRow a) => GFromRow (M1 i c a) where + gfromRow = M1 <$> gfromRow + +instance (GFromRow a, GFromRow b) => GFromRow (a :*: b) where + gfromRow = (:*:) <$> gfromRow <*> gfromRow + +-- | A collection type that can be converted from a sequence of fields. +-- Instances are provided for tuples up to 10 elements and lists of any length. +-- +-- Note that instances can defined outside of sqlite-simple, which is +-- often useful. For example, here's an instance for a user-defined pair: +-- +-- @ +-- data User = User { name :: String, fileQuota :: Int } +-- +-- instance 'FromRow' User where +-- fromRow = User \<$\> 'field' \<*\> 'field' +-- @ +-- +-- The number of calls to 'field' must match the number of fields returned +-- in a single row of the query result. Otherwise, a 'ConversionFailed' +-- exception will be thrown. +-- +-- Note the caveats associated with user-defined implementations of +-- 'fromRow'. +-- +-- === Generic implementation +-- +-- Since version 0.4.18.1 it is possible in some cases to derive a +-- generic implementation for 'FromRow'. With a 'Generic' instance +-- for @User@, the example above could be written: +-- +-- @ +-- instance 'FromRow' User where +-- @ +-- +-- With @-XDeriveAnyClass -XDerivingStrategies@ the same can be written: +-- +-- @ +-- deriving anyclass instance 'FromRow' User +-- @ +-- +-- For more details refer to 'GFromRow'. +class FromRow a where + fromRow :: RowParser a + default fromRow :: (Generic a) => (GFromRow (Rep a)) => RowParser a + fromRow = to <$> gfromRow + +fieldWith :: FieldParser a -> RowParser a +fieldWith fieldP = do + ncols <- asksRowParserRO nColumns + (column, remaining) <- getRowParserState + putRowParserState (column + 1, tail remaining) + if column >= ncols + then + liftOk (Errors [SomeException (ColumnOutOfBounds (column + 1))]) + else do + let r = head remaining + field' = Field r column + liftOk (fieldP field') + +field :: (FromField a) => RowParser a +field = fieldWith fromField + +numFieldsRemaining :: RowParser Int +numFieldsRemaining = do + ncols <- asksRowParserRO nColumns + (columnIdx, _) <- getRowParserState + return $! ncols - columnIdx + +instance (FromField a) => FromRow (Solo a) where + fromRow = MkSolo <$> field + +instance (FromField a, FromField b) => FromRow (a, b) where + fromRow = (,) <$> field <*> field + +instance (FromField a, FromField b, FromField c) => FromRow (a, b, c) where + fromRow = (,,) <$> field <*> field <*> field + +instance + (FromField a, FromField b, FromField c, FromField d) => + FromRow (a, b, c, d) + where + fromRow = (,,,) <$> field <*> field <*> field <*> field + +instance + (FromField a, FromField b, FromField c, FromField d, FromField e) => + FromRow (a, b, c, d, e) + where + fromRow = (,,,,) <$> field <*> field <*> field <*> field <*> field + +instance + ( FromField a, + FromField b, + FromField c, + FromField d, + FromField e, + FromField f + ) => + FromRow (a, b, c, d, e, f) + where + fromRow = + (,,,,,) + <$> field + <*> field + <*> field + <*> field + <*> field + <*> field + +instance + ( FromField a, + FromField b, + FromField c, + FromField d, + FromField e, + FromField f, + FromField g + ) => + FromRow (a, b, c, d, e, f, g) + where + fromRow = + (,,,,,,) + <$> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + +instance + ( FromField a, + FromField b, + FromField c, + FromField d, + FromField e, + FromField f, + FromField g, + FromField h + ) => + FromRow (a, b, c, d, e, f, g, h) + where + fromRow = + (,,,,,,,) + <$> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + +instance + ( FromField a, + FromField b, + FromField c, + FromField d, + FromField e, + FromField f, + FromField g, + FromField h, + FromField i + ) => + FromRow (a, b, c, d, e, f, g, h, i) + where + fromRow = + (,,,,,,,,) + <$> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + +instance + ( FromField a, + FromField b, + FromField c, + FromField d, + FromField e, + FromField f, + FromField g, + FromField h, + FromField i, + FromField j + ) => + FromRow (a, b, c, d, e, f, g, h, i, j) + where + fromRow = + (,,,,,,,,,) + <$> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + <*> field + +instance (FromField a) => FromRow [a] where + fromRow = do + n <- numFieldsRemaining + replicateM n field + +instance (FromRow a, FromRow b) => FromRow (a :. b) where + fromRow = (:.) <$> fromRow <*> fromRow diff --git a/lib/Sqlite/Query/Internal.hs b/lib/Sqlite/Query/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Sqlite/Query/Internal.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} + +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- Internal bits. This interface is less stable and can change at any time. +-- In particular this means that while the rest of the sqlite-simple +-- package endeavors to follow the package versioning policy, this module +-- does not. Also, at the moment there are things in here that aren't +-- particularly internal and are exported elsewhere; these will eventually +-- disappear from this module. +module Sqlite.Query.Internal where + +import Control.Applicative +import Control.Exception (Exception) +import Control.Monad +import Data.ByteString (ByteString) +import Data.ByteString.Char8 () +import Sqlite qualified as Base +import Sqlite.Query.Ok + +-- -- | Connection to an open database. +-- -- +-- -- You can use 'connectionHandle' to gain access to the underlying +-- -- connection. +-- -- This may be useful if you need to access some direct-sqlite +-- -- functionality that's not exposed in the sqlite-simple API. This +-- -- should be a safe thing to do although mixing both APIs is +-- -- discouraged. +-- data Connection = Connection +-- { connectionHandle :: {-# UNPACK #-} !Base.Database, +-- connectionTempNameCounter :: {-# UNPACK #-} !(IORef Word64) +-- } + +newtype ColumnOutOfBounds = ColumnOutOfBounds {errorColumnIndex :: Int} + deriving (Eq, Show) + +instance Exception ColumnOutOfBounds + +-- | A Field represents metadata about a particular field +data Field = Field + { result :: Base.SqlData, + column :: {-# UNPACK #-} !Int + } + +-- Named type for holding RowParser read-only state. Just for making +-- it easier to make sense out of types in FromRow. +newtype RowParserRO = RowParserRO {nColumns :: Int} + +type RowParserState = (Int, [Base.SqlData]) + +newtype RowParser a = RowParser {runRowParser :: RowParserRO -> RowParserState -> Ok (a, RowParserState)} + deriving (Functor) + +instance Applicative RowParser where + pure a = RowParser $ \_ s -> pure (a, s) + RowParser pf <*> RowParser pa = RowParser $ \ro s -> do + (f, s') <- pf ro s + (a, s'') <- pa ro s' + pure (f a, s'') + +instance Alternative RowParser where + empty = RowParser $ \_ _ -> empty + RowParser p1 <|> RowParser p2 = RowParser $ \ro s -> p1 ro s <|> p2 ro s + +instance Monad RowParser where + RowParser pa >>= f = RowParser $ \ro s -> do + (a, s') <- pa ro s + runRowParser (f a) ro s' + +instance MonadPlus RowParser where + mzero = empty + mplus = (<|>) + +-- | Get the read-only RowParseRO environment. +asksRowParserRO :: (RowParserRO -> a) -> RowParser a +asksRowParserRO f = RowParser $ \ro s -> pure (f ro, s) + +-- | Get the current RowParserState. +getRowParserState :: RowParser RowParserState +getRowParserState = RowParser $ \_ s -> pure (s, s) + +-- | Set the RowParserState. +putRowParserState :: RowParserState -> RowParser () +putRowParserState s = RowParser $ \_ _ -> pure ((), s) + +liftOk :: Ok a -> RowParser a +liftOk oka = RowParser $ \_ s -> do + a <- oka + pure (a, s) + +gettypename :: Base.SqlData -> ByteString +gettypename (Base.SqlInteger _) = "INTEGER" +gettypename (Base.SqlFloat _) = "FLOAT" +gettypename (Base.SqlText _) = "TEXT" +gettypename (Base.SqlBlob _) = "BLOB" +gettypename Base.SqlNull = "NULL" diff --git a/lib/Sqlite/Query/Ok.hs b/lib/Sqlite/Query/Ok.hs new file mode 100644 --- /dev/null +++ b/lib/Sqlite/Query/Ok.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE BlockArguments #-} + +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- The 'Ok' type is a simple error handler, basically equivalent to +-- @Either [SomeException]@. +-- +-- One of the primary reasons why this type was introduced is that +-- @Either SomeException@ had not been provided an instance for 'Alternative', +-- and it would have been a bad idea to provide an orphaned instance for a +-- commonly-used type and typeclass included in @base@. +-- +-- Extending the failure case to a list of 'SomeException's enables a +-- more sensible 'Alternative' instance definitions: '<|>' concatinates +-- the list of exceptions when both cases fail, and 'empty' is defined as +-- 'Errors []'. Though '<|>' one could pick one of two exceptions, and +-- throw away the other, and have 'empty' provide a generic exception, +-- this avoids cases where 'empty' overrides a more informative exception +-- and allows you to see all the different ways your computation has failed. +module Sqlite.Query.Ok where + +import Control.Applicative +import Control.Exception +import Control.Monad (MonadPlus (..)) + +-- FIXME: [SomeException] should probably be something else, maybe +-- a difference list (or a tree?) + +data Ok a = Errors [SomeException] | Ok !a + deriving (Show, Functor) + +-- | Two 'Errors' cases are considered equal, regardless of what the +-- list of exceptions looks like. +instance (Eq a) => Eq (Ok a) where + Errors _ == Errors _ = True + Ok a == Ok b = a == b + _ == _ = False + +instance Applicative Ok where + pure = Ok + + Errors es <*> _ = Errors es + _ <*> Errors es = Errors es + Ok f <*> Ok a = Ok (f a) + +instance Alternative Ok where + empty = Errors [] + + a@(Ok _) <|> _ = a + Errors _ <|> b@(Ok _) = b + Errors as <|> Errors bs = Errors (as ++ bs) + +instance MonadPlus Ok where + mzero = empty + mplus = (<|>) + +instance Monad Ok where + return = pure + + Errors es >>= _ = Errors es + Ok a >>= f = f a + +instance MonadFail Ok where + fail str = Errors [SomeException (ErrorCall str)] + +-- | a way to reify a list of exceptions into a single exception +newtype ManyErrors = ManyErrors [SomeException] + deriving (Show) + +instance Exception ManyErrors diff --git a/lib/Sqlite/Query/ToField.hs b/lib/Sqlite/Query/ToField.hs new file mode 100644 --- /dev/null +++ b/lib/Sqlite/Query/ToField.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE BlockArguments #-} + +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- The 'ToField' typeclass, for rendering a parameter to an Sqlite +-- value to be bound as a Sql query parameter. +module Sqlite.Query.ToField (ToField (..)) where + +import Data.ByteString qualified as SB +import Data.ByteString.Lazy qualified as LB +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Text qualified as T +import Data.Text.Lazy qualified as LT +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Float +import Sqlite as Base +import Sqlite.Query.Types (Null) + +-- | A type that may be used as a single parameter to a Sql query. +class ToField a where + toField :: a -> SqlData + -- ^ Prepare a value for substitution into a query string. + +instance ToField SqlData where + toField a = a + {-# INLINE toField #-} + +instance (ToField a) => ToField (Maybe a) where + toField Nothing = Base.SqlNull + toField (Just a) = toField a + {-# INLINE toField #-} + +instance ToField Null where + toField _ = Base.SqlNull + {-# INLINE toField #-} + +instance ToField Bool where + toField False = SqlInteger 0 + toField True = SqlInteger 1 + {-# INLINE toField #-} + +instance ToField Int8 where + toField = SqlInteger . fromIntegral + {-# INLINE toField #-} + +instance ToField Int16 where + toField = SqlInteger . fromIntegral + {-# INLINE toField #-} + +instance ToField Int32 where + toField = SqlInteger . fromIntegral + {-# INLINE toField #-} + +instance ToField Int where + toField = SqlInteger . fromIntegral + {-# INLINE toField #-} + +instance ToField Int64 where + toField = SqlInteger . fromIntegral + {-# INLINE toField #-} + +instance ToField Integer where + toField = SqlInteger . fromIntegral + {-# INLINE toField #-} + +instance ToField Word8 where + toField = SqlInteger . fromIntegral + {-# INLINE toField #-} + +instance ToField Word16 where + toField = SqlInteger . fromIntegral + {-# INLINE toField #-} + +instance ToField Word32 where + toField = SqlInteger . fromIntegral + {-# INLINE toField #-} + +instance ToField Word where + toField = SqlInteger . fromIntegral + {-# INLINE toField #-} + +instance ToField Word64 where + toField = SqlInteger . fromIntegral + {-# INLINE toField #-} + +instance ToField Float where + toField = SqlFloat . float2Double + {-# INLINE toField #-} + +instance ToField Double where + toField = SqlFloat + {-# INLINE toField #-} + +instance ToField SB.ByteString where + toField = SqlBlob + {-# INLINE toField #-} + +instance ToField LB.ByteString where + toField = toField . SB.concat . LB.toChunks + {-# INLINE toField #-} + +instance ToField T.Text where + toField = SqlText + {-# INLINE toField #-} + +instance ToField [Char] where + toField = SqlText . T.pack + {-# INLINE toField #-} + +instance ToField LT.Text where + toField = toField . LT.toStrict + {-# INLINE toField #-} + +-- instance ToField UTCTime where +-- toField = SqlText . T.decodeUtf8 . toByteString . utcTimeToBuilder +-- {-# INLINE toField #-} +-- +-- instance ToField Day where +-- toField = SqlText . T.decodeUtf8 . toByteString . dayToBuilder +-- {-# INLINE toField #-} + +-- TODO enable these +-- instance ToField ZonedTime where +-- toField = SqlText . zonedTimeToBuilder +-- {-# INLINE toField #-} +-- +-- instance ToField LocalTime where +-- toField = SqlText . localTimeToBuilder +-- {-# INLINE toField #-} +-- +-- instance ToField Day where +-- toField = SqlText . dayToBuilder +-- {-# INLINE toField #-} +-- +-- instance ToField TimeOfDay where +-- toField = SqlText . timeOfDayToBuilder +-- {-# INLINE toField #-} +-- +-- instance ToField UTCTimestamp where +-- toField = SqlText . utcTimestampToBuilder +-- {-# INLINE toField #-} +-- +-- instance ToField ZonedTimestamp where +-- toField = SqlText . zonedTimestampToBuilder +-- {-# INLINE toField #-} +-- +-- instance ToField LocalTimestamp where +-- toField = SqlText . localTimestampToBuilder +-- {-# INLINE toField #-} +-- +-- instance ToField Date where +-- toField = SqlText . dateToBuilder +-- {-# INLINE toField #-} diff --git a/lib/Sqlite/Query/ToRow.hs b/lib/Sqlite/Query/ToRow.hs new file mode 100644 --- /dev/null +++ b/lib/Sqlite/Query/ToRow.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} + +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- The 'ToRow' typeclass, for rendering a collection of +-- parameters to a Sql query. +-- +-- Predefined instances are provided for tuples containing up to ten +-- elements. +module Sqlite.Query.ToRow + ( GToRow (..), + ToRow (..), + ) +where + +import GHC.Generics +import Sqlite (SqlData (..)) +import Sqlite.Query.ToField (ToField (..)) +import Sqlite.Query.Types (Solo (..), (:.) (..)) + +-- | Generic derivation of 'ToRow'. For details about what can be +-- derived refer to 'Database.Sqlite.Simple.FromRow.GFromRow'. +-- +-- @since 0.4.18.1 +class GToRow f where + gtoRow :: f a -> [SqlData] + +instance GToRow U1 where + gtoRow U1 = mempty + +instance (ToField a) => GToRow (K1 i a) where + gtoRow (K1 a) = pure $ toField a + +instance (GToRow a, GToRow b) => GToRow (a :*: b) where + gtoRow (a :*: b) = gtoRow a `mappend` gtoRow b + +instance (GToRow a) => GToRow (M1 i c a) where + gtoRow (M1 a) = gtoRow a + +-- | A collection type that can be turned into a list of 'SqlData' +-- elements. +-- +-- Since version 0.4.18.1 it is possible in some cases to derive a +-- generic implementation for 'ToRow'. Refer to the documentation for +-- 'Database.Sqlite.Simple.FromRow.FromRow' to see how this can be +-- done. +class ToRow a where + toRow :: a -> [SqlData] + -- ^ 'ToField' a collection of values. + default toRow :: (Generic a) => (GToRow (Rep a)) => a -> [SqlData] + toRow a = gtoRow $ from a + +deriving instance ToRow () + +deriving instance (ToField a) => ToRow (Solo a) + +deriving instance (ToField a, ToField b) => ToRow (a, b) + +deriving instance (ToField a, ToField b, ToField c) => ToRow (a, b, c) + +deriving instance (ToField a, ToField b, ToField c, ToField d) => ToRow (a, b, c, d) + +deriving instance (ToField a, ToField b, ToField c, ToField d, ToField e) => ToRow (a, b, c, d, e) + +deriving instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f) => ToRow (a, b, c, d, e, f) + +deriving instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g) => ToRow (a, b, c, d, e, f, g) + +instance + ( ToField a, + ToField b, + ToField c, + ToField d, + ToField e, + ToField f, + ToField g, + ToField h + ) => + ToRow (a, b, c, d, e, f, g, h) + where + toRow (a, b, c, d, e, f, g, h) = + [ toField a, + toField b, + toField c, + toField d, + toField e, + toField f, + toField g, + toField h + ] + +instance + ( ToField a, + ToField b, + ToField c, + ToField d, + ToField e, + ToField f, + ToField g, + ToField h, + ToField i + ) => + ToRow (a, b, c, d, e, f, g, h, i) + where + toRow (a, b, c, d, e, f, g, h, i) = + [ toField a, + toField b, + toField c, + toField d, + toField e, + toField f, + toField g, + toField h, + toField i + ] + +instance + ( ToField a, + ToField b, + ToField c, + ToField d, + ToField e, + ToField f, + ToField g, + ToField h, + ToField i, + ToField j + ) => + ToRow (a, b, c, d, e, f, g, h, i, j) + where + toRow (a, b, c, d, e, f, g, h, i, j) = + [ toField a, + toField b, + toField c, + toField d, + toField e, + toField f, + toField g, + toField h, + toField i, + toField j + ] + +instance (ToField a) => ToRow [a] where + toRow = map toField + +instance (ToRow a, ToRow b) => ToRow (a :. b) where + toRow (a :. b) = toRow a ++ toRow b diff --git a/lib/Sqlite/Query/Types.hs b/lib/Sqlite/Query/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Sqlite/Query/Types.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE BlockArguments #-} + +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +module Sqlite.Query.Types + ( Null (..), + Solo (..), + Sql (..), + (:.) (..), + ) +where + +import Control.Arrow (first) +import Data.String (IsString (..)) +import Data.Text qualified as T +import Data.Tuple (Solo (..)) + +-- | A placeholder for the Sql @NULL@ value. +data Null = Null + deriving (Read, Show) + +instance Eq Null where + _ == _ = False + _ /= _ = False + +-- | A query string. This type is intended to make it difficult to +-- construct a Sql query by concatenating string fragments, as that is +-- an extremely common way to accidentally introduce Sql injection +-- vulnerabilities into an application. +-- +-- This type is an instance of 'IsString', so the easiest way to +-- construct a query is to enable the @OverloadedStrings@ language +-- extension and then simply write the query in double quotes. +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Database.Sqlite.Simple +-- > +-- > q :: Query +-- > q = "select ?" +-- +-- The underlying type is a 'Text', and literal Haskell strings that +-- contain Unicode characters will be correctly transformed to UTF-8. +newtype Sql = Sql + { sqlText :: T.Text + } + deriving (Eq, Ord) + +instance Show Sql where + show = show . sqlText + +instance Read Sql where + readsPrec i = fmap (first Sql) . readsPrec i + +instance IsString Sql where + fromString = Sql . T.pack + +instance Semigroup Sql where + Sql a <> Sql b = Sql (T.append a b) + {-# INLINE (<>) #-} + +instance Monoid Sql where + mempty = Sql T.empty + mappend = (<>) + {-# INLINE mappend #-} + +-- | A composite type to parse your custom data structures without +-- having to define dummy newtype wrappers every time. +-- +-- +-- > instance FromRow MyData where ... +-- +-- > instance FromRow MyData2 where ... +-- +-- +-- then I can do the following for free: +-- +-- @ +-- res <- query' c "..." +-- forM res $ \\(MyData{..} :. MyData2{..}) -> do +-- .... +-- @ +data h :. t = h :. t deriving (Eq, Ord, Show, Read) + +infixr 3 :. diff --git a/test-query/Common.hs b/test-query/Common.hs new file mode 100644 --- /dev/null +++ b/test-query/Common.hs @@ -0,0 +1,19 @@ +module Common + ( -- Note: Do not add more exports for Sqlite.Simple here. This is + -- so that we trap we by default export enough out of + -- Database.Sqlite.Simple to make it useful as a single import. + module Sqlite.Query, + module Test.HUnit, + TestEnv (..), + Solo (..), + ) +where + +import Sqlite.Query +import Test.HUnit + +data TestEnv + = TestEnv + { -- | Connection shared by all the tests + conn :: Connection + } diff --git a/test-query/DirectSqlite.hs b/test-query/DirectSqlite.hs new file mode 100644 --- /dev/null +++ b/test-query/DirectSqlite.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module DirectSqlite + ( testDirectSqlite, + ) +where + +import Common +import Control.Exception (bracket) +import Sqlite qualified as DS + +testDirectSqlite :: TestEnv -> Test +testDirectSqlite TestEnv {..} = TestCase $ do + let dsConn = conn + bracket (DS.prepare dsConn "SELECT 1+1") DS.finalize testDirect + [MkSolo (res :: Int)] <- select_ conn "SELECT 1+2" + assertEqual "1+2" 3 res + where + testDirect stmt = do + DS.Row <- DS.step stmt + res <- DS.column stmt 0 + assertEqual "1+1" (SqlInteger 2) res diff --git a/test-query/Errors.hs b/test-query/Errors.hs new file mode 100644 --- /dev/null +++ b/test-query/Errors.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Errors + ( testErrorsColumns, + testErrorsInvalidParams, + testErrorsInvalidNamedParams, + testErrorsWithStatement, + testErrorsColumnName, + testErrorsTransaction, + testErrorsImmediateTransaction, + testErrorsExclusiveTransaction, + ) +where + +import Common +import Control.Exception +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as LB +import Data.Word +import Sqlite.Query.Types (Null) + +-- The "length (show e) `seq` .." trickery below is to force evaluate +-- the contents of error messages. Another option would be to log +-- them (would be useful), but I don't know if HUnit has any logging +-- mechanisms. Just printing them as is will look like the tests are +-- hitting errors and would be confusing. +assertResultErrorCaught :: IO a -> Assertion +assertResultErrorCaught action = do + catch (action >> return False) (\(e :: ResultError) -> length (show e) `seq` return True) + >>= assertBool "assertResultError exc" + +assertFormatErrorCaught :: IO a -> Assertion +assertFormatErrorCaught action = do + catch (action >> return False) (\(e :: FormatError) -> length (show e) `seq` return True) + >>= assertBool "assertFormatError exc" + +assertSQLErrorCaught :: IO a -> Assertion +assertSQLErrorCaught action = do + catch (action >> return False) (\(e :: SqliteException) -> length (show e) `seq` return True) + >>= assertBool "assertSQLError exc" + +assertOOBCaught :: IO a -> Assertion +assertOOBCaught action = do + catch (action >> return False) (\(e :: ArrayException) -> length (show e) `seq` return True) + >>= assertBool "assertOOBCaught exc" + +testErrorsColumns :: TestEnv -> Test +testErrorsColumns TestEnv {..} = TestCase $ do + execute_ conn "CREATE TABLE cols (id INTEGER PRIMARY KEY, t TEXT)" + execute_ conn "INSERT INTO cols (t) VALUES ('test string')" + rows <- select_ conn "SELECT t FROM cols" :: IO [Solo String] + assertEqual "row count" 1 (length rows) + assertEqual "string" (MkSolo "test string") (head rows) + -- Mismatched number of output columns (selects two, dest type has 1 field) + assertResultErrorCaught (select_ conn "SELECT id,t FROM cols" :: IO [Solo Int]) + -- Same as above but the other way round (select 1, dst has two) + assertResultErrorCaught (select_ conn "SELECT id FROM cols" :: IO [(Int, String)]) + -- Mismatching types (source int,text doesn't match dst string,int + assertResultErrorCaught (select_ conn "SELECT id, t FROM cols" :: IO [(String, Int)]) + -- Mismatching types (source string doesn't match dst integer + assertResultErrorCaught (select_ conn "SELECT 'foo'" :: IO [Solo Integer]) + -- Mismatching types (sources don't match destination float/double type) + assertResultErrorCaught (select_ conn "SELECT 1" :: IO [Solo Double]) + assertResultErrorCaught (select_ conn "SELECT 'foo'" :: IO [Solo Double]) + assertResultErrorCaught (select_ conn "SELECT 1" :: IO [Solo Float]) + assertResultErrorCaught (select_ conn "SELECT 'foo'" :: IO [Solo Float]) + -- Mismatching types (sources don't match destination bool type, or is out of bounds) + assertResultErrorCaught (select_ conn "SELECT 'true'" :: IO [Solo Bool]) + assertResultErrorCaught (select_ conn "SELECT 2" :: IO [Solo Bool]) + -- Mismatching types (sources don't match destination string types (text, string) + -- It seems that these actually convert ok to text... + -- assertResultErrorCaught (select_ conn "SELECT 1" :: IO [Solo T.Text]) + -- assertResultErrorCaught (select_ conn "SELECT 1" :: IO [Solo LT.Text]) + -- assertResultErrorCaught (select_ conn "SELECT 1.0" :: IO [Solo T.Text]) + -- assertResultErrorCaught (select_ conn "SELECT 1.0" :: IO [Solo LT.Text]) + -- Mismatching types (sources don't match destination bytestring) + [MkSolo (_ :: B.ByteString)] <- select_ conn "SELECT X'3177'" + assertResultErrorCaught (select_ conn "SELECT 1" :: IO [Solo B.ByteString]) + assertResultErrorCaught (select_ conn "SELECT 1" :: IO [Solo LB.ByteString]) + assertResultErrorCaught (select_ conn "SELECT 'foo'" :: IO [Solo B.ByteString]) + assertResultErrorCaught (select_ conn "SELECT 'foo'" :: IO [Solo LB.ByteString]) + -- Trying to get a blob into a string + let d = B.pack ([0 .. 127] :: [Word8]) + execute_ conn "CREATE TABLE cols_blobs (id INTEGER, b BLOB)" + execute conn "INSERT INTO cols_blobs (id, b) VALUES (?,?)" (1 :: Int, d) + assertResultErrorCaught + ( do + [MkSolo _t1] <- select conn "SELECT b FROM cols_blobs WHERE id = ?" (MkSolo (1 :: Int)) :: IO [Solo String] + return () + ) + execute_ conn "CREATE TABLE cols_bools (id INTEGER PRIMARY KEY, b BOOLEAN)" + -- 3 = invalid value for bool, must be 0 or 1 + execute_ conn "INSERT INTO cols_bools (b) VALUES (3)" + assertResultErrorCaught + ( do + [MkSolo _t1] <- select_ conn "SELECT b FROM cols_bools" :: IO [Solo Bool] + return () + ) + [MkSolo (nullVal :: Null)] <- select_ conn "SELECT NULL" + False @=? nullVal == nullVal + False @=? nullVal /= nullVal + assertResultErrorCaught + ( do + [MkSolo (_t1 :: Null)] <- select_ conn "SELECT 1" :: IO [Solo Null] + return () + ) + +testErrorsInvalidParams :: TestEnv -> Test +testErrorsInvalidParams TestEnv {..} = TestCase $ do + execute_ conn "CREATE TABLE invparams (id INTEGER PRIMARY KEY, t TEXT)" + -- Test that only unnamed params are accepted + assertFormatErrorCaught + (execute conn "INSERT INTO invparams (t) VALUES (:v)" (MkSolo ("foo" :: String))) + assertFormatErrorCaught + (execute conn "INSERT INTO invparams (id, t) VALUES (:v,$1)" (3 :: Int, "foo" :: String)) + -- In this case, we have two bound params but only one given to + -- execute. This should cause an error. + assertFormatErrorCaught + (execute conn "INSERT INTO invparams (id, t) VALUES (?, ?)" (MkSolo (3 :: Int))) + +testErrorsInvalidNamedParams :: TestEnv -> Test +testErrorsInvalidNamedParams TestEnv {..} = TestCase $ do + -- Test that only unnamed params are accepted + assertFormatErrorCaught + (selectNamed conn "SELECT :foo" [":foox" := (1 :: Int)] :: IO [Solo Int]) + -- In this case, we have two bound params but only one given to + -- execute. This should cause an error. + assertFormatErrorCaught + (selectNamed conn "SELECT :foo + :bar" [":foo" := (1 :: Int)] :: IO [Solo Int]) + -- Can't use named params in SQL string with the unnamed query/exec variants + assertFormatErrorCaught + (select conn "SELECT :foo" (MkSolo (1 :: Int)) :: IO [Solo Int]) + +testErrorsWithStatement :: TestEnv -> Test +testErrorsWithStatement TestEnv {..} = TestCase $ do + execute_ conn "CREATE TABLE invstat (id INTEGER PRIMARY KEY, t TEXT)" + assertSQLErrorCaught $ + withStatement conn "SELECT id, t, t1 FROM invstat" $ \_stmt -> + assertFailure "Error not detected" + +testErrorsColumnName :: TestEnv -> Test +testErrorsColumnName TestEnv {..} = TestCase $ do + execute_ conn "CREATE TABLE invcolumn (id INTEGER PRIMARY KEY, t TEXT)" + assertOOBCaught $ + withStatement conn "SELECT id FROM invcolumn" $ \stmt -> + columnName stmt (ColumnIndex (-1)) >> assertFailure "Error not detected" + +testErrorsTransaction :: TestEnv -> Test +testErrorsTransaction TestEnv {..} = TestCase $ do + execute_ conn "CREATE TABLE trans (id INTEGER PRIMARY KEY, t TEXT)" + v <- withTransaction conn $ do + executeNamed conn "INSERT INTO trans (t) VALUES (:txt)" [":txt" := ("foo" :: String)] + [MkSolo r] <- select_ conn "SELECT t FROM trans" :: IO [Solo String] + return r + v @=? "foo" + e <- rowExists + True @=? e + execute_ conn "DELETE FROM trans" + e <- rowExists + False @=? e + assertFormatErrorCaught + ( withTransaction conn $ do + -- this execute should be automatically rolled back on error + executeNamed + conn + "INSERT INTO trans (t) VALUES (:txt)" + [":txt" := ("foo" :: String)] + -- intentional mistake here to hit an error & cause rollback of txn + executeNamed + conn + "INSERT INTO trans (t) VALUES (:txt)" + [":missing" := ("foo" :: String)] + ) + e <- rowExists + False @=? e + where + rowExists = do + rows <- select_ conn "SELECT t FROM trans" :: IO [Solo String] + case rows of + [MkSolo txt] -> do + "foo" @=? txt + return True + [] -> + return False + _ -> error "should have only one row" + +testErrorsImmediateTransaction :: TestEnv -> Test +testErrorsImmediateTransaction TestEnv {..} = TestCase $ do + execute_ conn "CREATE TABLE itrans (id INTEGER PRIMARY KEY, t TEXT)" + v <- withImmediateTransaction conn $ do + executeNamed conn "INSERT INTO itrans (t) VALUES (:txt)" [":txt" := ("foo" :: String)] + [MkSolo r] <- select_ conn "SELECT t FROM itrans" :: IO [Solo String] + return r + v @=? "foo" + e <- rowExists + True @=? e + execute_ conn "DELETE FROM itrans" + e <- rowExists + False @=? e + assertFormatErrorCaught + ( withImmediateTransaction conn $ do + -- this execute should be automatically rolled back on error + executeNamed + conn + "INSERT INTO itrans (t) VALUES (:txt)" + [":txt" := ("foo" :: String)] + -- intentional mistake here to hit an error & cause rollback of txn + executeNamed + conn + "INSERT INTO itrans (t) VALUES (:txt)" + [":missing" := ("foo" :: String)] + ) + e <- rowExists + False @=? e + where + rowExists = do + rows <- select_ conn "SELECT t FROM itrans" :: IO [Solo String] + case rows of + [MkSolo txt] -> do + "foo" @=? txt + return True + [] -> + return False + _ -> error "should have only one row" + +testErrorsExclusiveTransaction :: TestEnv -> Test +testErrorsExclusiveTransaction TestEnv {..} = TestCase $ do + execute_ conn "CREATE TABLE etrans (id INTEGER PRIMARY KEY, t TEXT)" + v <- withExclusiveTransaction conn $ do + executeNamed conn "INSERT INTO etrans (t) VALUES (:txt)" [":txt" := ("foo" :: String)] + [MkSolo r] <- select_ conn "SELECT t FROM etrans" :: IO [Solo String] + return r + v @=? "foo" + e <- rowExists + True @=? e + execute_ conn "DELETE FROM etrans" + e <- rowExists + False @=? e + assertFormatErrorCaught + ( withExclusiveTransaction conn $ do + -- this execute should be automatically rolled back on error + executeNamed + conn + "INSERT INTO etrans (t) VALUES (:txt)" + [":txt" := ("foo" :: String)] + -- intentional mistake here to hit an error & cause rollback of txn + executeNamed + conn + "INSERT INTO etrans (t) VALUES (:txt)" + [":missing" := ("foo" :: String)] + ) + e <- rowExists + False @=? e + where + rowExists = do + rows <- select_ conn "SELECT t FROM etrans" :: IO [Solo String] + case rows of + [MkSolo txt] -> do + "foo" @=? txt + return True + [] -> + return False + _ -> error "should have only one row" diff --git a/test-query/Fold.hs b/test-query/Fold.hs new file mode 100644 --- /dev/null +++ b/test-query/Fold.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Fold + ( testFolds, + ) +where + +import Common + +testFolds :: TestEnv -> Test +testFolds TestEnv {..} = TestCase $ do + execute_ conn "CREATE TABLE testf (id INTEGER PRIMARY KEY, t INT)" + execute_ conn "INSERT INTO testf (t) VALUES (4)" + execute_ conn "INSERT INTO testf (t) VALUES (5)" + execute_ conn "INSERT INTO testf (t) VALUES (6)" + val <- fold_ conn "SELECT id,t FROM testf" sumValues do pure ([], []) + assertEqual "fold_" val ([3, 2, 1], [6, 5, 4]) + val <- fold conn "SELECT id,t FROM testf WHERE id > ?" (MkSolo (1 :: Int)) sumValues do pure ([], []) + assertEqual "fold" val ([3, 2], [6, 5]) + val <- foldNamed conn "SELECT id,t FROM testf WHERE id > :id" [":id" := (1 :: Int)] sumValues do pure ([], []) + assertEqual "fold" val ([3, 2], [6, 5]) + where + sumValues (accId, accT) (id_ :: Int, t :: Int) = return (id_ : accId, t : accT) diff --git a/test-query/Main.hs b/test-query/Main.hs new file mode 100644 --- /dev/null +++ b/test-query/Main.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Common +import Control.Exception (bracket) +import Control.Monad (when) +import DirectSqlite +import Errors +import Fold +import ParamConv +import PreparedStatement +import Query +import Sqlite +import System.Exit (exitFailure) +import System.IO +import TestImports +import TestImports () +import UserInstances +import Utf8Strings + +tests :: [TestEnv -> Test] +tests = + [ TestLabel "Query" . testSimpleSelect, + TestLabel "Query" . testSimpleOnePlusOne, + TestLabel "Query" . testSimpleParams, + TestLabel "Query" . testSimpleInsertId, + TestLabel "Query" . testSimpleMultiInsert, + TestLabel "Query" . testSimpleQueryCov, + TestLabel "Query" . testSimpleStrings, + TestLabel "Query" . testSimpleChanges, + TestLabel "ParamConv" . testParamConvNull, + TestLabel "ParamConv" . testParamConvInt, + TestLabel "ParamConv" . testParamConvIntWidths, + TestLabel "ParamConv" . testParamConvIntWidthsFromField, + TestLabel "ParamConv" . testParamConvFloat, + TestLabel "ParamConv" . testParamConvBools, + TestLabel "ParamConv" . testParamConvToRow, + TestLabel "ParamConv" . testParamConvFromRow, + TestLabel "ParamConv" . testParamConvComposite, + TestLabel "ParamConv" . testParamNamed, + TestLabel "Errors" . testErrorsColumns, + TestLabel "Errors" . testErrorsInvalidParams, + TestLabel "Errors" . testErrorsInvalidNamedParams, + TestLabel "Errors" . testErrorsWithStatement, + TestLabel "Errors" . testErrorsColumnName, + TestLabel "Errors" . testErrorsTransaction, + TestLabel "Errors" . testErrorsImmediateTransaction, + TestLabel "Errors" . testErrorsExclusiveTransaction, + TestLabel "Utf8" . testUtf8Simplest, + TestLabel "Utf8" . testBlobs, + TestLabel "Instances" . testUserFromField, + TestLabel "Instances" . testSqlDataFromField, + TestLabel "Fold" . testFolds, + TestLabel "Statement" . testBind, + TestLabel "Statement" . testDoubleBind, + TestLabel "Statement" . testPreparedStatements, + TestLabel "Statement" . testPreparedStatementsColumnCount, + TestLabel "Direct" . testDirectSqlite, + TestLabel "Imports" . testImports + ] + +-- | Action for connecting to the database that will be used for testing. +-- +-- Note that some tests, such as Notify, use multiple connections, and assume +-- that 'testConnect' connects to the same database every time it is called. +testConnect :: IO Connection +testConnect = open ":memory:" + +withTestEnv :: (TestEnv -> IO a) -> IO a +withTestEnv cb = + withConn $ \conn -> cb TestEnv {conn = conn} + where + withConn = bracket testConnect close + +main :: IO () +main = do + mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr] + Counts {cases, tried, errors, failures} <- + withTestEnv $ \env -> runTestTT $ TestList $ map ($ env) tests + when (cases /= tried || errors /= 0 || failures /= 0) $ exitFailure diff --git a/test-query/ParamConv.hs b/test-query/ParamConv.hs new file mode 100644 --- /dev/null +++ b/test-query/ParamConv.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +#if MIN_VERSION_base(4,9,0) +{-# OPTIONS_GHC -Wno-overflowed-literals #-} +#endif + +module ParamConv + ( testParamConvNull, + testParamConvInt, + testParamConvIntWidths, + testParamConvIntWidthsFromField, + testParamConvFloat, + testParamConvBools, + testParamConvFromRow, + testParamConvToRow, + testParamConvComposite, + testParamNamed, + ) +where + +import Common +import Data.Int +import Data.Text qualified as T +import Data.Word +import Sqlite.Query.Types (Null (..)) + +one, two, three :: Int +one = 1 +two = 2 +three = 3 + +testParamConvNull :: TestEnv -> Test +testParamConvNull TestEnv {..} = TestCase $ do + execute_ conn "CREATE TABLE nulltype (id INTEGER PRIMARY KEY, t1 TEXT)" + [MkSolo r] <- (select_ conn "SELECT NULL") :: IO [Solo Null] + execute conn "INSERT INTO nulltype (id, t1) VALUES (?,?)" (one, r) + [MkSolo mr1] <- select_ conn "SELECT t1 FROM nulltype WHERE id = 1" :: IO [Solo (Maybe String)] + assertEqual "nulls" Nothing mr1 + execute conn "INSERT INTO nulltype (id, t1) VALUES (?,?)" (two, "foo" :: String) + [MkSolo mr2] <- select_ conn "SELECT t1 FROM nulltype WHERE id = 2" :: IO [Solo (Maybe String)] + assertEqual "nulls" (Just "foo") mr2 + +testParamConvInt :: TestEnv -> Test +testParamConvInt TestEnv {..} = TestCase $ do + [MkSolo r] <- (select conn "SELECT ?" (MkSolo one)) :: IO [Solo Int] + assertEqual "value" 1 r + [MkSolo r] <- (select conn "SELECT ?" (MkSolo one)) :: IO [Solo Integer] + assertEqual "value" 1 r + [MkSolo r] <- (select conn "SELECT ?+?" (one, two)) :: IO [Solo Int] + assertEqual "value" 3 r + [MkSolo r] <- (select conn "SELECT ?+?" (one, 15 :: Int64)) :: IO [Solo Int] + assertEqual "value" 16 r + [MkSolo r] <- (select conn "SELECT ?+?" (two, 14 :: Int32)) :: IO [Solo Int] + assertEqual "value" 16 r + [MkSolo r] <- (select conn "SELECT ?+?" (two, 14 :: Integer)) :: IO [Solo Int] + assertEqual "value" 16 r + -- This overflows 32-bit ints, verify that we get more than 32-bits out + [MkSolo r] <- (select conn "SELECT 255*?" (MkSolo (0x7FFFFFFF :: Int32))) :: IO [Solo Int64] + assertEqual + "> 32-bit result" + (255 * 0x7FFFFFFF :: Int64) + (fromIntegral r) + [MkSolo r] <- (select conn "SELECT 2*?" (MkSolo (0x7FFFFFFFFF :: Int64))) :: IO [Solo Int64] + assertEqual + "> 32-bit result & param" + (2 * 0x7FFFFFFFFF :: Int64) + (fromIntegral r) + [MkSolo r] <- (select_ conn "SELECT NULL") :: IO [Solo (Maybe Int)] + assertEqual "should see nothing" Nothing r + [MkSolo r] <- (select_ conn "SELECT 3") :: IO [Solo (Maybe Int)] + assertEqual "should see Just 3" (Just 3) r + [MkSolo r] <- (select conn "SELECT ?") (MkSolo (Nothing :: Maybe Int)) :: IO [Solo (Maybe Int)] + assertEqual "should see nothing" Nothing r + [MkSolo r] <- (select conn "SELECT ?") (MkSolo (Just three :: Maybe Int)) :: IO [Solo (Maybe Int)] + assertEqual "should see 4" (Just 3) r + +testParamConvIntWidths :: TestEnv -> Test +testParamConvIntWidths TestEnv {..} = TestCase $ do + [MkSolo r] <- (select conn "SELECT ?" (MkSolo (1 :: Int8))) :: IO [Solo Int] + assertEqual "value" 1 r + [MkSolo r] <- (select conn "SELECT ?" (MkSolo (257 :: Int8))) :: IO [Solo Int] -- wrap around + assertEqual "value" 1 r + [MkSolo r] <- (select conn "SELECT ?" (MkSolo (257 :: Int16))) :: IO [Solo Int] + assertEqual "value" 257 r + [MkSolo r] <- (select conn "SELECT ?" (MkSolo (258 :: Int32))) :: IO [Solo Int] + assertEqual "value" 258 r + [MkSolo r] <- (select conn "SELECT ?" (MkSolo (1 :: Word8))) :: IO [Solo Int] + assertEqual "value" 1 r + [MkSolo r] <- (select conn "SELECT ?" (MkSolo (257 :: Word8))) :: IO [Solo Int] -- wrap around + assertEqual "value" 1 r + [MkSolo r] <- (select conn "SELECT ?" (MkSolo (257 :: Word16))) :: IO [Solo Int] + assertEqual "value" 257 r + [MkSolo r] <- (select conn "SELECT ?" (MkSolo (257 :: Word32))) :: IO [Solo Int] + assertEqual "value" 257 r + [MkSolo r] <- (select conn "SELECT ?" (MkSolo (0x100000000 :: Word64))) :: IO [Solo Int] + assertEqual "value" 0x100000000 r + [MkSolo r] <- (select conn "SELECT ?" (MkSolo (1 :: Integer))) :: IO [Solo Int] + assertEqual "value" 1 r + [MkSolo r] <- (select conn "SELECT ?" (MkSolo (1 :: Word))) :: IO [Solo Int] + assertEqual "value" 1 r + +testParamConvIntWidthsFromField :: TestEnv -> Test +testParamConvIntWidthsFromField TestEnv {..} = TestCase $ do + [MkSolo r] <- (select conn "SELECT ?" (MkSolo (1 :: Int))) :: IO [Solo Int8] + assertEqual "value" 1 r + [MkSolo r] <- (select conn "SELECT ?" (MkSolo (257 :: Int))) :: IO [Solo Int8] -- wrap around + assertEqual "value" 1 r + [MkSolo r] <- (select conn "SELECT ?" (MkSolo (65536 :: Int))) :: IO [Solo Int16] -- wrap around + assertEqual "value" 0 r + [MkSolo r] <- (select conn "SELECT ?" (MkSolo (65536 :: Int))) :: IO [Solo Int32] -- wrap around + assertEqual "value" 65536 r + [MkSolo r] <- (select conn "SELECT ?" (MkSolo (258 :: Int))) :: IO [Solo Int32] + assertEqual "value" 258 r + [MkSolo r] <- (select conn "SELECT ?" (MkSolo (1 :: Int))) :: IO [Solo Word8] + assertEqual "value" 1 r + [MkSolo r] <- (select conn "SELECT ?" (MkSolo (257 :: Int))) :: IO [Solo Word8] -- wrap around + assertEqual "value" 1 r + [MkSolo r] <- (select conn "SELECT ?" (MkSolo (257 :: Int))) :: IO [Solo Word16] + assertEqual "value" 257 r + [MkSolo r] <- (select conn "SELECT ?" (MkSolo (257 :: Int))) :: IO [Solo Word32] + assertEqual "value" 257 r + [MkSolo r] <- (select conn "SELECT ?" (MkSolo (0x100000000 :: Int64))) :: IO [Solo Word64] + assertEqual "value" 0x100000000 r + [MkSolo r] <- (select conn "SELECT ?" (MkSolo (1 :: Int))) :: IO [Solo Word] + assertEqual "value" 1 r + +testParamConvFloat :: TestEnv -> Test +testParamConvFloat TestEnv {..} = TestCase $ do + [MkSolo r] <- select conn "SELECT ?" (MkSolo (1.0 :: Double)) :: IO [Solo Double] + assertEqual "value" 1.0 r + [MkSolo r] <- select conn "SELECT ?*0.25" (MkSolo (8.0 :: Double)) :: IO [Solo Double] + assertEqual "value" 2.0 r + +testParamConvBools :: TestEnv -> Test +testParamConvBools TestEnv {..} = TestCase $ do + execute_ conn "CREATE TABLE bt (id INTEGER PRIMARY KEY, b BOOLEAN)" + -- Booleans are ints with values 0 or 1 on Sqlite + execute_ conn "INSERT INTO bt (b) VALUES (0)" + execute_ conn "INSERT INTO bt (b) VALUES (1)" + [MkSolo r1, MkSolo r2] <- select_ conn "SELECT b from bt" :: IO [Solo Bool] + assertEqual "bool" False r1 + assertEqual "bool" True r2 + execute conn "INSERT INTO bt (b) VALUES (?)" (MkSolo True) + execute conn "INSERT INTO bt (b) VALUES (?)" (MkSolo False) + execute conn "INSERT INTO bt (b) VALUES (?)" (MkSolo False) + [MkSolo r3, MkSolo r4, MkSolo r5] <- + select_ conn "SELECT b from bt where id in (3, 4, 5) ORDER BY id" :: IO [Solo Bool] + assertEqual "bool" True r3 + assertEqual "bool" False r4 + assertEqual "bool" False r5 + +testParamConvFromRow :: TestEnv -> Test +testParamConvFromRow TestEnv {..} = TestCase $ do + [(1, 2)] <- select_ conn "SELECT 1,2" :: IO [(Int, Int)] + [(1, 2, 3)] <- select_ conn "SELECT 1,2,3" :: IO [(Int, Int, Int)] + [(1, 2, 3, 4)] <- select_ conn "SELECT 1,2,3,4" :: IO [(Int, Int, Int, Int)] + [(1, 2, 3, 4, 5)] <- select_ conn "SELECT 1,2,3,4,5" :: IO [(Int, Int, Int, Int, Int)] + [(1, 2, 3, 4, 5, 6)] <- select_ conn "SELECT 1,2,3,4,5,6" :: IO [(Int, Int, Int, Int, Int, Int)] + [(1, 2, 3, 4, 5, 6, 7)] <- select_ conn "SELECT 1,2,3,4,5,6,7" :: IO [(Int, Int, Int, Int, Int, Int, Int)] + [(1, 2, 3, 4, 5, 6, 7, 8)] <- select_ conn "SELECT 1,2,3,4,5,6,7,8" :: IO [(Int, Int, Int, Int, Int, Int, Int, Int)] + [(1, 2, 3, 4, 5, 6, 7, 8, 9)] <- select_ conn "SELECT 1,2,3,4,5,6,7,8,9" :: IO [(Int, Int, Int, Int, Int, Int, Int, Int, Int)] + [(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)] <- select_ conn "SELECT 1,2,3,4,5,6,7,8,9,10" :: IO [(Int, Int, Int, Int, Int, Int, Int, Int, Int, Int)] + [[1, 2, 3]] <- select_ conn "SELECT 1,2,3" :: IO [[Int]] + return () + +testParamConvToRow :: TestEnv -> Test +testParamConvToRow TestEnv {..} = TestCase $ do + [MkSolo (s :: Int)] <- select conn "SELECT 13" () + 13 @=? s + [MkSolo (s :: Int)] <- select conn "SELECT ?" (MkSolo one) + 1 @=? s + [MkSolo (s :: Int)] <- select conn "SELECT ?+?" (one, two) + (1 + 2) @=? s + [MkSolo (s :: Int)] <- select conn "SELECT ?+?+?" (one, two, three) + (1 + 2 + 3) @=? s + [MkSolo (s :: Int)] <- select conn "SELECT ?+?+?+?" (one, two, three, 4 :: Int) + (1 + 2 + 3 + 4) @=? s + [MkSolo (s :: Int)] <- select conn "SELECT ?+?+?+?+?" (one, two, three, 4 :: Int, 5 :: Int) + (1 + 2 + 3 + 4 + 5) @=? s + [MkSolo (s :: Int)] <- select conn "SELECT ?+?+?+?+?+?" (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int) + (1 + 2 + 3 + 4 + 5 + 6) @=? s + [MkSolo (s :: Int)] <- + select + conn + "SELECT ?+?+?+?+?+?+?" + (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int, 7 :: Int) + (1 + 2 + 3 + 4 + 5 + 6 + 7) @=? s + [MkSolo (s :: Int)] <- + select + conn + "SELECT ?+?+?+?+?+?+?+?" + (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int, 7 :: Int, 8 :: Int) + (1 + 2 + 3 + 4 + 5 + 6 + 7 + 8) @=? s + [MkSolo (s :: Int)] <- + select + conn + "SELECT ?+?+?+?+?+?+?+?+?" + (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int, 7 :: Int, 8 :: Int, 9 :: Int) + (1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9) @=? s + [MkSolo (s :: Int)] <- + select + conn + "SELECT ?+?+?+?+?+?+?+?+?+?" + (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int, 7 :: Int, 8 :: Int, 9 :: Int, 10 :: Int) + (1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10) @=? s + +data TestTuple = TestTuple Int64 Int64 deriving (Eq, Show) + +data TestTuple2 = TestTuple2 T.Text T.Text deriving (Eq, Show) + +instance FromRow TestTuple where + fromRow = TestTuple <$> field <*> field + +instance FromRow TestTuple2 where + fromRow = TestTuple2 <$> field <*> field + +instance ToRow TestTuple where + toRow (TestTuple a b) = [SqlInteger a, SqlInteger b] + +instance ToRow TestTuple2 where + toRow (TestTuple2 a b) = [SqlText a, SqlText b] + +testParamConvComposite :: TestEnv -> Test +testParamConvComposite TestEnv {..} = TestCase $ do + [t1] <- select_ conn "SELECT 1,2" + TestTuple 1 2 @=? t1 + [t2] <- select_ conn "SELECT 'foo','bar'" + TestTuple2 "foo" "bar" @=? t2 + [a :. b] <- select_ conn "SELECT 4,5,'baz','xyzz'" + TestTuple 4 5 :. TestTuple2 "baz" "xyzz" @=? a :. b + [TestTuple x y :. TestTuple2 z w] <- select conn "SELECT ?,?,?,?" (a :. b) + x @=? 4 + y @=? 5 + z @=? "baz" + w @=? "xyzz" + +testParamNamed :: TestEnv -> Test +testParamNamed TestEnv {..} = TestCase $ do + [MkSolo t1] <- selectNamed conn "SELECT :foo / :bar" [":foo" := two, ":bar" := one] + t1 @=? (2 :: Int) + [(t1, t2)] <- selectNamed conn "SELECT :foo,:bar" [":foo" := ("foo" :: T.Text), ":bar" := one] + t1 @=? ("foo" :: T.Text) + t2 @=? one + execute_ conn "CREATE TABLE np (id INTEGER PRIMARY KEY, b BOOLEAN)" + executeNamed conn "INSERT INTO np (b) VALUES (:b)" [":b" := True] + [MkSolo t1] <- select_ conn "SELECT b FROM np" + True @=? t1 diff --git a/test-query/PreparedStatement.hs b/test-query/PreparedStatement.hs new file mode 100644 --- /dev/null +++ b/test-query/PreparedStatement.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module PreparedStatement + ( testBind, + testDoubleBind, + testPreparedStatements, + testPreparedStatementsColumnCount, + ) +where + +import Common + ( ColumnIndex (ColumnIndex), + Solo (..), + Test (TestCase), + TestEnv (..), + assertEqual, + columnCount, + columnName, + execute_, + nextRow, + withBind, + withStatement, + (@=?), + (@?=), + ) +import Data.Maybe (fromJust) +import Sqlite qualified as Base + +testBind :: TestEnv -> Test +testBind TestEnv {..} = TestCase $ do + execute_ conn "CREATE TABLE test_bind (id INTEGER PRIMARY KEY, t TEXT)" + execute_ conn "INSERT INTO test_bind VALUES(1, 'result')" + withStatement conn "SELECT t FROM test_bind WHERE id=?" $ \stmt -> + withBind stmt [1 :: Int] $ do + row <- nextRow stmt :: IO (Maybe (Solo String)) + assertEqual "result" (MkSolo "result") (fromJust row) + +testDoubleBind :: TestEnv -> Test +testDoubleBind TestEnv {..} = TestCase $ do + execute_ conn "CREATE TABLE test_double_bind (id INTEGER PRIMARY KEY, t TEXT)" + execute_ conn "INSERT INTO test_double_bind VALUES(1, 'first result')" + execute_ conn "INSERT INTO test_double_bind VALUES(2, 'second result')" + withStatement conn "SELECT t FROM test_double_bind WHERE id=?" $ \stmt -> do + withBind stmt [1 :: Int] $ do + row <- nextRow stmt :: IO (Maybe (Solo String)) + assertEqual "first result" (MkSolo "first result") (fromJust row) + + withBind stmt [2 :: Int] $ do + row <- nextRow stmt :: IO (Maybe (Solo String)) + assertEqual "second result" (MkSolo "second result") (fromJust row) + +testPreparedStatements :: TestEnv -> Test +testPreparedStatements TestEnv {..} = TestCase $ do + execute_ conn "CREATE TABLE ps (id INTEGER PRIMARY KEY, t TEXT)" + execute_ conn "INSERT INTO ps VALUES(1, 'first result')" + execute_ conn "INSERT INTO ps VALUES(2, 'second result')" + withStatement conn "SELECT t FROM ps WHERE id=?" $ \stmt -> do + colName <- columnName stmt 0 + colName @?= "t" + elems <- mapM (queryOne stmt) [1 :: Int, 2] + ["first result" :: String, "second result"] @=? elems + where + queryOne stmt rowId = + withBind stmt (MkSolo rowId) $ do + Just (MkSolo r) <- nextRow stmt + Nothing <- nextRow stmt :: IO (Maybe (Solo String)) + return r + +testPreparedStatementsColumnCount :: TestEnv -> Test +testPreparedStatementsColumnCount TestEnv {..} = TestCase $ do + execute_ conn "CREATE TABLE ps2 (id INTEGER PRIMARY KEY, t TEXT)" + execute_ conn "INSERT INTO ps2 VALUES(1, 'first result')" + withStatement conn "SELECT t FROM ps2 WHERE id=?" $ \stmt -> do + colName <- columnName stmt 0 + colName @?= "t" + ColumnIndex colCount <- columnCount stmt + colCount @?= 1 + let baseStatment = stmt + colCountBase <- Base.columnCount baseStatment + colCountBase @?= 1 diff --git a/test-query/Query.hs b/test-query/Query.hs new file mode 100644 --- /dev/null +++ b/test-query/Query.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Query + ( testSimpleOnePlusOne, + testSimpleSelect, + testSimpleParams, + testSimpleInsertId, + testSimpleMultiInsert, + testSimpleQueryCov, + testSimpleStrings, + testSimpleChanges, + ) +where + +-- orphan IsString instance in older byteString + +import Common +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Lazy.Char8 () +import Data.Text qualified as T +import Data.Text.Lazy qualified as LT + +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ((<>)) +#endif + +-- Simplest SELECT +testSimpleOnePlusOne :: TestEnv -> Test +testSimpleOnePlusOne TestEnv {..} = TestCase $ do + rows <- select_ conn "SELECT 1+1" :: IO [Solo Int] + assertEqual "row count" 1 (length rows) + assertEqual "value" (MkSolo 2) (head rows) + +testSimpleSelect :: TestEnv -> Test +testSimpleSelect TestEnv {..} = TestCase $ do + execute_ conn "CREATE TABLE test1 (id INTEGER PRIMARY KEY, t TEXT)" + execute_ conn "INSERT INTO test1 (t) VALUES ('test string')" + rows <- select_ conn "SELECT t FROM test1" :: IO [Solo String] + assertEqual "row count" 1 (length rows) + assertEqual "string" (MkSolo "test string") (head rows) + rows <- select_ conn "SELECT id,t FROM test1" :: IO [(Int, String)] + assertEqual "int,string" (1, "test string") (head rows) + -- Add another row + execute_ conn "INSERT INTO test1 (t) VALUES ('test string 2')" + rows <- select_ conn "SELECT id,t FROM test1" :: IO [(Int, String)] + assertEqual "row count" 2 (length rows) + assertEqual "int,string" (1, "test string") (rows !! 0) + assertEqual "int,string" (2, "test string 2") (rows !! 1) + [MkSolo r] <- select_ conn "SELECT NULL" :: IO [Solo (Maybe Int)] + assertEqual "nulls" Nothing r + [MkSolo r] <- select_ conn "SELECT 1" :: IO [Solo (Maybe Int)] + assertEqual "nulls" (Just 1) r + [MkSolo r] <- select_ conn "SELECT 1.0" :: IO [Solo Double] + assertEqual "doubles" 1.0 r + [MkSolo r] <- select_ conn "SELECT 1.0" :: IO [Solo Float] + assertEqual "floats" 1.0 r + +testSimpleParams :: TestEnv -> Test +testSimpleParams TestEnv {..} = TestCase $ do + execute_ conn "CREATE TABLE testparams (id INTEGER PRIMARY KEY, t TEXT)" + execute_ conn "CREATE TABLE testparams2 (id INTEGER, t TEXT, t2 TEXT)" + [MkSolo i] <- select conn "SELECT ?" (MkSolo (42 :: Int)) :: IO [Solo Int] + assertEqual "select int param" 42 i + execute conn "INSERT INTO testparams (t) VALUES (?)" (MkSolo ("test string" :: String)) + rows <- select conn "SELECT t FROM testparams WHERE id = ?" (MkSolo (1 :: Int)) :: IO [Solo String] + assertEqual "row count" 1 (length rows) + assertEqual "string" (MkSolo "test string") (head rows) + execute_ conn "INSERT INTO testparams (t) VALUES ('test2')" + [MkSolo row] <- select conn "SELECT t FROM testparams WHERE id = ?" (MkSolo (1 :: Int)) :: IO [Solo String] + assertEqual "select params" "test string" row + [MkSolo row] <- select conn "SELECT t FROM testparams WHERE id = ?" (MkSolo (2 :: Int)) :: IO [Solo String] + assertEqual "select params" "test2" row + [MkSolo r1, MkSolo r2] <- select conn "SELECT t FROM testparams WHERE (id = ? OR id = ?)" (1 :: Int, 2 :: Int) :: IO [Solo String] + assertEqual "select params" "test string" r1 + assertEqual "select params" "test2" r2 + [MkSolo i] <- select conn "SELECT ?+?" [42 :: Int, 1 :: Int] :: IO [Solo Int] + assertEqual "select int param" 43 i + [MkSolo d] <- select conn "SELECT ?" [2.0 :: Double] :: IO [Solo Double] + assertEqual "select double param" 2.0 d + [MkSolo f] <- select conn "SELECT ?" [4.0 :: Float] :: IO [Solo Float] + assertEqual "select double param" 4.0 f + +testSimpleInsertId :: TestEnv -> Test +testSimpleInsertId TestEnv {..} = TestCase $ do + execute_ conn "CREATE TABLE test_row_id (id INTEGER PRIMARY KEY, t TEXT)" + execute conn "INSERT INTO test_row_id (t) VALUES (?)" (MkSolo ("test string" :: String)) + id1 <- lastInsertRowId conn + execute_ conn "INSERT INTO test_row_id (t) VALUES ('test2')" + id2 <- lastInsertRowId conn + 1 @=? id1 + 2 @=? id2 + rows <- select conn "SELECT t FROM test_row_id WHERE id = ?" (MkSolo (1 :: Int)) :: IO [Solo String] + 1 @=? (length rows) + (MkSolo "test string") @=? (head rows) + [MkSolo row] <- select conn "SELECT t FROM test_row_id WHERE id = ?" (MkSolo (2 :: Int)) :: IO [Solo String] + "test2" @=? row + +testSimpleMultiInsert :: TestEnv -> Test +testSimpleMultiInsert TestEnv {..} = TestCase $ do + execute_ conn "CREATE TABLE test_multi_insert (id INTEGER PRIMARY KEY, t1 TEXT, t2 TEXT)" + executeMany conn "INSERT INTO test_multi_insert (t1, t2) VALUES (?, ?)" ([("foo", "bar"), ("baz", "bat")] :: [(String, String)]) + id2 <- lastInsertRowId conn + 2 @=? id2 + + rows <- select_ conn "SELECT id,t1,t2 FROM test_multi_insert" :: IO [(Int, String, String)] + [(1, "foo", "bar"), (2, "baz", "bat")] @=? rows + +testSimpleQueryCov :: TestEnv -> Test +testSimpleQueryCov _ = TestCase $ do + let str = "SELECT 1+1" :: T.Text + q = "SELECT 1+1" :: Sql + sqlText q @=? str + show str @=? show q + q @=? ((read . show $ q) :: Sql) + q @=? q + q @=? (Sql "SELECT 1" <> Sql "+1") + q @=? foldr mappend mempty ["SELECT ", "1", "+", "1"] + True @=? q <= q + +testSimpleStrings :: TestEnv -> Test +testSimpleStrings TestEnv {..} = TestCase $ do + [MkSolo s] <- select_ conn "SELECT 'str1'" :: IO [Solo T.Text] + s @=? "str1" + [MkSolo s] <- select_ conn "SELECT 'strLazy'" :: IO [Solo LT.Text] + s @=? "strLazy" + [MkSolo s] <- select conn "SELECT ?" (MkSolo ("strP" :: T.Text)) :: IO [Solo T.Text] + s @=? "strP" + [MkSolo s] <- select conn "SELECT ?" (MkSolo ("strPLazy" :: LT.Text)) :: IO [Solo T.Text] + s @=? "strPLazy" + -- ByteStrings are blobs in sqlite storage, so use ByteString for + -- both input and output + [MkSolo s] <- select conn "SELECT ?" (MkSolo ("strBsP" :: BS.ByteString)) :: IO [Solo BS.ByteString] + s @=? "strBsP" + [MkSolo s] <- select conn "SELECT ?" (MkSolo ("strBsPLazy" :: LBS.ByteString)) :: IO [Solo BS.ByteString] + s @=? "strBsPLazy" + [MkSolo s] <- select conn "SELECT ?" (MkSolo ("strBsPLazy2" :: BS.ByteString)) :: IO [Solo LBS.ByteString] + s @=? "strBsPLazy2" + +testSimpleChanges :: TestEnv -> Test +testSimpleChanges TestEnv {..} = TestCase $ do + execute_ conn "CREATE TABLE testchanges (id INTEGER PRIMARY KEY, t TEXT)" + execute conn "INSERT INTO testchanges(t) VALUES (?)" (MkSolo ("test string" :: String)) + numChanges <- changes conn + assertEqual "changed/inserted rows" 1 numChanges + execute conn "INSERT INTO testchanges(t) VALUES (?)" (MkSolo ("test string 2" :: String)) + numChanges <- changes conn + assertEqual "changed/inserted rows" 1 numChanges + execute_ conn "UPDATE testchanges SET t = 'foo' WHERE id = 1" + numChanges <- changes conn + assertEqual "changed/inserted rows" 1 numChanges + execute_ conn "UPDATE testchanges SET t = 'foo' WHERE id = 100" + numChanges <- changes conn + assertEqual "changed/inserted rows" 0 numChanges + execute_ conn "UPDATE testchanges SET t = 'foo'" + numChanges <- changes conn + assertEqual "changed/inserted rows" 2 numChanges diff --git a/test-query/TestImports.hs b/test-query/TestImports.hs new file mode 100644 --- /dev/null +++ b/test-query/TestImports.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TestImports + ( testImports, + ) +where + +-- Test file to test that we can do most things with a single import + +import Common +import Control.Exception +import Data.Text qualified as T +import Sqlite + +data TestType = TestType Int Int Int + +-- Hook up sqlite-simple to know how to read Test rows +instance FromRow TestType where + fromRow = TestType <$> field <*> field <*> field + +test1 :: IO () +test1 = do + conn <- open ":memory:" + execute_ conn "CREATE TABLE testimp (id INTEGER PRIMARY KEY, id2 INTEGER, id3 INTEGER)" + execute_ conn "INSERT INTO testimp (id, id2, id3) VALUES (1, 2, 3)" + [_v] <- select_ conn "SELECT * FROM testimp" :: IO [TestType] + [_v] <- select conn "SELECT ?+?" (3 :: Int, 4 :: Int) :: IO [(Solo Int)] + close conn + +test2 :: Connection -> IO () +test2 conn = do + execute_ conn "CREATE TABLE testimp (id INTEGER PRIMARY KEY)" + execute_ conn "INSERT INTO testimp (id) VALUES (1)" + [MkSolo _v] <- select_ conn (Sql q) :: IO [Solo Int] + return () + where + q = T.concat ["SELECT * FROM ", "testimp"] + +test3 :: Connection -> IO () +test3 conn = do + [_v] <- select conn "SELECT ?+?" (3 :: Int, 4 :: Int) :: IO [(Solo Int)] + return () + +testImports :: TestEnv -> Test +testImports env = TestCase $ do + test1 + bracket (open ":memory:") close test2 + test3 (conn env) diff --git a/test-query/UserInstances.hs b/test-query/UserInstances.hs new file mode 100644 --- /dev/null +++ b/test-query/UserInstances.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module UserInstances + ( testUserFromField, + testSqlDataFromField, + ) +where + +import Common +import Data.Int (Int64) +import Data.Text qualified as T +import Sqlite.Query.FromField +import Sqlite.Query.Ok +import Sqlite.Query.ToField + +newtype MyType = MyType String deriving (Eq, Show) + +instance FromField MyType where + fromField f = cvt f . fieldData $ f + where + -- Prefix with "fromField " to really ensure we got here + cvt _ (SqlText s) = Ok $ MyType ("fromField " ++ (T.unpack s)) + cvt f _ = returnError ConversionFailed f "expecting SqlText type" + +instance ToField MyType where + -- Prefix with "toField " to really ensure we got here + toField (MyType s) = SqlText . T.pack $ ("toField " ++ s) + +testUserFromField :: TestEnv -> Test +testUserFromField TestEnv {..} = TestCase $ do + execute_ conn "CREATE TABLE fromfield (t TEXT)" + execute conn "INSERT INTO fromfield (t) VALUES (?)" (MkSolo ("test string" :: String)) + [MkSolo r] <- select_ conn "SELECT t FROM fromfield" :: IO [(Solo MyType)] + (MyType "fromField test string") @=? r + execute_ conn "DELETE FROM fromfield" + execute conn "INSERT INTO fromfield (t) VALUES (?)" (MkSolo (MyType "test2")) + [MkSolo r] <- select_ conn "SELECT t FROM fromfield" :: IO [(Solo String)] + "toField test2" @=? r + +testSqlDataFromField :: TestEnv -> Test +testSqlDataFromField TestEnv {..} = TestCase $ do + execute_ conn "CREATE TABLE sqldatafromfield (t TEXT, i INT, b BOOLEAN, f FLOAT)" + execute + conn + "INSERT INTO sqldatafromfield (t,i,b,f) VALUES (?,?,?,?)" + ( ( "test string" :: T.Text, + 1 :: Int64, + True :: Bool, + 1.11 :: Double + ) + ) + execute + conn + "INSERT INTO sqldatafromfield (t,i,b) VALUES (?,?,?)" + ( ( "test string2" :: T.Text, + 2 :: Int64, + False :: Bool + ) + ) + r <- select_ conn "SELECT * FROM sqldatafromfield" :: IO [[SqlData]] + let testData = + [ [ SqlText "test string", + SqlInteger 1, + SqlInteger 1, + SqlFloat 1.11 + ], + [ SqlText "test string2", + SqlInteger 2, + SqlInteger 0, + SqlNull + ] + ] + testData @=? r diff --git a/test-query/Utf8Strings.hs b/test-query/Utf8Strings.hs new file mode 100644 --- /dev/null +++ b/test-query/Utf8Strings.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Utf8Strings + ( testUtf8Simplest, + testBlobs, + ) +where + +import Common +import Data.ByteString qualified as B +import Data.Word + +testUtf8Simplest :: TestEnv -> Test +testUtf8Simplest TestEnv {..} = TestCase $ do + execute_ conn "CREATE TABLE utf (id INTEGER, t TEXT)" + execute_ conn "INSERT INTO utf (id, t) VALUES (1, 'ääöö')" + execute conn "INSERT INTO utf (id, t) VALUES (?,?)" (2 :: Int, "ääööåå" :: String) + [MkSolo t1] <- select conn "SELECT t FROM utf WHERE id = ?" (MkSolo (1 :: Int)) + assertEqual "utf8" ("ääöö" :: String) t1 + [MkSolo t2] <- select conn "SELECT t FROM utf WHERE id = ?" (MkSolo (2 :: Int)) + assertEqual "utf8" ("ääööåå" :: String) t2 + +testBlobs :: TestEnv -> Test +testBlobs TestEnv {..} = TestCase $ do + let d = B.pack ([0 .. 127] :: [Word8]) + execute_ conn "CREATE TABLE blobs (id INTEGER, b BLOB)" + execute conn "INSERT INTO blobs (id, b) VALUES (?,?)" (1 :: Int, d) + [MkSolo t1] <- select conn "SELECT b FROM blobs WHERE id = ?" (MkSolo (1 :: Int)) + assertEqual "blob" d t1 + assertEqual "blob nul char" 0 (B.index d 0) + assertEqual "blob first char" 1 (B.index d 1) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,1041 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Main where + +import Control.Concurrent +import Control.Exception +import Control.Monad (forM_, liftM3, when) +import Data.ByteString qualified as B +import Data.ByteString.Char8 qualified as B8 +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Text.Encoding.Error (UnicodeException (..), lenientDecode) +import Sqlite +import Sqlite.Direct qualified as Direct +import StrictEq +import System.Directory (doesFileExist, removeFile) +import System.IO +import System.IO.Error (isUserError) +import System.Timeout (timeout) +import Test.Tasty +import Test.Tasty.HUnit + +data TestEnv = TestEnv + { -- | Connection shared by all the tests + conn :: Connection, + -- | Bracket for spawning an additional connection. + -- This connection will be isolated from others. + withConn :: forall a. (Connection -> IO a) -> IO a, + -- | Like 'withConn', but every invocation shares the same Connection. + withConnShared :: forall a. (Connection -> IO a) -> IO a + } + +regressionTests :: [IO TestEnv -> TestTree] +regressionTests = + [ testCase "Exec" . testExec, + testCase "ExecCallback" . testExecCallback, + testCase "Simple" . testSimplest, + testCase "Prepare" . testPrepare, + testCase "CloseBusy" . testCloseBusy, + testCase "Params" . testBind, + testCase "Params" . testBindParamCounts, + testCase "Params" . testBindParamName, + testCase "Params" . testBindErrorValidation, + testCase "Params" . testNamedBindParams, + testCase "Columns" . testColumns, + testCase "TypedColumns" . testTypedColumns, + testCase "ColumnName" . testColumnName, + testCase "Errors" . testErrors, + testCase "Integrity" . testIntegrity, + testCase "DecodeError" . testDecodeError, + testCase "ResultStats" . testResultStats, + testCase "GetAutoCommit" . testGetAutoCommit, + testCase "Debug" . testStatementSql, + testCase "Debug" . testTracing, + testCase "CustomFunc" . testCustomFunction, + testCase "CustomFuncErr" . testCustomFunctionError, + testCase "CustomAggr" . testCustomAggragate, + testCase "CustomColl" . testCustomCollation, + testCase "IncrBlobIO" . testIncrementalBlobIO, + testCase "MultiRowInsert" . testMultiRowInsert + ] + ++ ( if rtsSupportsBoundThreads + then + [ testCase "Interrupt" . testInterrupt + ] + else [] + ) + +assertFail :: IO a -> Assertion +assertFail action = + shouldFail action >>= assertBool "assertFail" + +-- | Return 'True' if the IO action throws a 'userError', +-- which happens when 'fail' is used. +shouldFail :: IO a -> IO Bool +shouldFail action = do + r <- try action + case r of + Left e -> return $ isUserError e + Right _ -> return False + +withStmt :: Connection -> Text -> (PreparedStatement -> IO a) -> IO a +withStmt conn sql = bracket (prepare conn sql) finalize + +testExec :: IO TestEnv -> Assertion +testExec envIO = do + TestEnv {..} <- envIO + exec conn "" + exec conn " " + exec conn ";" + exec conn " ; ; ; ; ; " + exec conn "--" + Left SqliteException {sqliteError = ErrorError} <- try $ exec conn "/*" + -- sqlite3_exec does not allow "/*" to be terminated by end of input, + -- but says it's fine. + exec conn ";--\n;/**/" + withConn $ \conn -> do + -- Make sure all the statements passed to exec are executed. + -- Test a little value conversion while we're at it. + exec + conn + "CREATE TABLE foo (n FLOAT, t TEXT); \ + \INSERT INTO foo VALUES (3.5, null); \ + \INSERT INTO foo VALUES (null, 'Ự₦ⓘ₡ợ₫ḝ'); \ + \INSERT INTO foo VALUES (null, ''); \ + \INSERT INTO foo VALUES (null, 'null'); \ + \INSERT INTO foo VALUES (null, null)" + withStmt conn ("SELECT * FROM foo") $ \stmt -> do + Row <- step stmt + [SqlFloat 3.5, SqlNull] <- columns stmt + Row <- step stmt + [SqlNull, SqlText "Ự₦ⓘ₡ợ₫ḝ"] <- columns stmt + Row <- step stmt + [SqlNull, SqlText ""] <- columns stmt + Row <- step stmt + [SqlNull, SqlText "null"] <- columns stmt + Row <- step stmt + [SqlNull, SqlNull] <- columns stmt + Done <- step stmt + return () + +data Ex = Ex + deriving (Show) + +instance Exception Ex + +testExecCallback :: IO TestEnv -> Assertion +testExecCallback envIO = do + TestEnv {..} <- envIO + withConn $ \conn -> do + chan <- newChan + let exec' sql = execWithCallback conn sql $ \c n v -> writeChan chan (c, n, v) + exec' + "CREATE TABLE foo (a INT, b TEXT); \ + \INSERT INTO foo VALUES (1, 'a'); \ + \INSERT INTO foo VALUES (2, 'b'); \ + \INSERT INTO foo VALUES (3, null); \ + \INSERT INTO foo VALUES (null, 'd'); " + + exec' "SELECT 1, 2, 3" + (3, ["1", "2", "3"], [Just "1", Just "2", Just "3"]) <- readChan chan + + exec' "SELECT null" + (1, ["null"], [Nothing]) <- readChan chan + + exec' "SELECT * FROM foo" + (2, ["a", "b"], [Just "1", Just "a"]) <- readChan chan + (2, ["a", "b"], [Just "2", Just "b"]) <- readChan chan + (2, ["a", "b"], [Just "3", Nothing]) <- readChan chan + (2, ["a", "b"], [Nothing, Just "d"]) <- readChan chan + + exec' "SELECT * FROM foo WHERE a < 0; SELECT 123" + (1, ["123"], [Just "123"]) <- readChan chan + + exec' "SELECT rowid, f.a, f.b, a || b FROM foo AS f" + (4, ["rowid", "a", "b", "a || b"], [Just "1", Just "1", Just "a", Just "1a"]) <- readChan chan + (4, ["rowid", "a", "b", "a || b"], [Just "2", Just "2", Just "b", Just "2b"]) <- readChan chan + (4, ["rowid", "a", "b", "a || b"], [Just "3", Just "3", Nothing, Nothing]) <- readChan chan + (4, ["rowid", "a", "b", "a || b"], [Just "4", Nothing, Just "d", Nothing]) <- readChan chan + + Left Ex <- try $ execWithCallback conn "SELECT 1" $ \_ _ _ -> throwIO Ex + + return () + +testTracing :: IO TestEnv -> Assertion +testTracing envIO = do + TestEnv {..} <- envIO + withConn $ \conn -> do + chan <- newChan + let logger m = writeChan chan m + Direct.setTrace conn (Just logger) + withStmt conn "SELECT null" $ \stmt -> do + Row <- step stmt + res <- columns stmt + Done <- step stmt + assertEqual "tracing" [SqlNull] res + Direct.Utf8 msg <- readChan chan + assertEqual "tracing" "SELECT null" msg + withStmt conn "SELECT 1+?" $ \stmt -> do + bind stmt [SqlInteger 2] + Row <- step stmt + Done <- step stmt + reset stmt + bind stmt [SqlInteger 3] + Row <- step stmt + Done <- step stmt + Direct.Utf8 msg <- readChan chan + assertEqual "tracing" "SELECT 1+2" msg + Direct.Utf8 msg <- readChan chan + assertEqual "tracing" "SELECT 1+3" msg + -- Check that disabling works too + Direct.setTrace conn Nothing + reset stmt + bind stmt [SqlInteger 3] + Row <- step stmt + Done <- step stmt + writeChan chan (Direct.Utf8 "empty") + Direct.Utf8 msg <- readChan chan + assertEqual "tracing" "empty" msg + +-- Simplest SELECT +testSimplest :: IO TestEnv -> Assertion +testSimplest envIO = do + TestEnv {..} <- envIO + stmt <- prepare conn "SELECT 1+1" + Row <- step stmt + res <- column stmt 0 + Done <- step stmt + finalize stmt + assertEqual "1+1" (SqlInteger 2) res + +testPrepare :: IO TestEnv -> Assertion +testPrepare envIO = do + TestEnv {..} <- envIO + True <- shouldFail $ prepare conn "" + True <- shouldFail $ prepare conn ";" + withConn $ \conn -> do + withStmt + conn + "CREATE TABLE foo (a INT, b INT); \ + \INSERT INTO foo VALUES (1, 2); \ + \INSERT INTO foo VALUES (3, 4)" + $ \stmt -> do + Done <- step stmt + return () + withStmt + conn + "BEGIN; INSERT INTO foo VALUES (5, 6); COMMIT" + $ \stmt -> do + Done <- step stmt + return () + withStmt + conn + "SELECT * FROM foo" + $ \stmt -> do + Done <- step stmt -- No row was inserted, because only the CREATE TABLE + -- statement was run. The rest was ignored. + return () + Left SqliteException {sqliteError = ErrorError} <- try $ exec conn "BEGIN" + -- We're in a transaction already, so this fails. + exec conn "COMMIT" + return () + +testCloseBusy :: IO TestEnv -> Assertion +testCloseBusy _ = do + conn <- open ":memory:" + stmt <- prepare conn "SELECT 1" + Left SqliteException {sqliteError = ErrorBusy} <- try $ close conn + finalize stmt + close conn + +testBind :: IO TestEnv -> Assertion +testBind envIO = do + TestEnv {..} <- envIO + bracket (prepare conn "SELECT ?") finalize testBind1 + bracket (prepare conn "SELECT ?+?") finalize testBind2 + bracket (prepare conn "SELECT ?,?") finalize testBind3 + where + testBind1 stmt = do + let params = [SqlInteger 3] + bind stmt params + Row <- step stmt + res <- columns stmt + Done <- step stmt + assertEqual "single param" params res + + testBind2 stmt = do + let params = [SqlInteger 1, SqlInteger 1] + bind stmt params + Row <- step stmt + res <- columns stmt + Done <- step stmt + assertEqual "two params param" [SqlInteger 2] res + + testBind3 stmt = do + let len = 7 + bs = B.replicate len 0 + bindBlob stmt 1 bs + bindZeroBlob stmt 2 len + Row <- step stmt + res <- columns stmt + Done <- step stmt + assertEqual "blob vs. zeroblob" [SqlBlob bs, SqlBlob bs] res + +-- Test bindParameterCount +testBindParamCounts :: IO TestEnv -> Assertion +testBindParamCounts envIO = do + TestEnv {..} <- envIO + let testCase label query expected = + bracket (prepare conn query) finalize bindParameterCount + >>= assertEqual label expected + testCase "single $a" "SELECT $a" 1 + testCase "3 unique ?NNNs" "SELECT (?1+?1+?1+?2+?3)" 3 + testCase "3 positional" "SELECT (?+?+?)" 3 + testCase "5 params, 2 gaps" "SELECT ?3, ?5, ?1" 5 + testCase "6 params, gaps & auto" "SELECT ?3, ?5, ?1, ?" 6 + testCase "8 params, auto & overlap" "SELECT ?, ?5, ?, ?2, ?, ?6, ?" 8 + -- 8 because ? grabs an index one greater than the highest index of all + -- previous parameters, not just the most recent index. + testCase "0 placeholders" "SELECT 1" 0 + +-- Test bindParameterName +testBindParamName :: IO TestEnv -> Assertion +testBindParamName envIO = do + TestEnv {..} <- envIO + bracket (prepare conn "SELECT :v + :v2") finalize (testNames [Just ":v", Just ":v2"]) + bracket (prepare conn "SELECT ?1 + ?1") finalize (testNames [Just "?1"]) + bracket (prepare conn "SELECT ?1 + ?2") finalize (testNames [Just "?1", Just "?2"]) + bracket (prepare conn "SELECT ? + ?") finalize (testNames [Nothing, Nothing]) + bracket (prepare conn "SELECT $1 + $2") finalize (testNames [Just "$1", Just "$2"]) + where + testNames names stmt = do + count <- bindParameterCount stmt + assertEqual "count match" count (fromIntegral $ length names) + mapM_ + ( \(ndx, expecting) -> do + name <- bindParameterName stmt ndx + assertEqual "name match" expecting name + ) + $ zip [1 ..] names + +testBindErrorValidation :: IO TestEnv -> Assertion +testBindErrorValidation envIO = do + TestEnv {..} <- envIO + bracket (prepare conn "SELECT ?") finalize (assertFail . testException1) + bracket (prepare conn "SELECT ?") finalize (assertFail . testException2) + where + -- Invalid use, one param in q string, none given + testException1 stmt = bind stmt [] + -- Invalid use, one param in q string, 2 given + testException2 stmt = bind stmt [SqlInteger 1, SqlInteger 2] + +testNamedBindParams :: IO TestEnv -> Assertion +testNamedBindParams envIO = do + TestEnv {..} <- envIO + withConn $ \conn -> do + withStmt conn "SELECT :foo / :bar" $ \stmt -> do + -- Test that we get something back for known names + Just fooIdx <- Direct.bindParameterIndex stmt (toUtf8 ":foo") + Just barIdx <- Direct.bindParameterIndex stmt (toUtf8 ":bar") + -- Test that we get Nothing back for unknown names + Nothing <- Direct.bindParameterIndex stmt (toUtf8 "intentionally_undefined") + Right () <- Direct.bindInt64 stmt fooIdx 4 + Right () <- Direct.bindInt64 stmt barIdx 2 + Row <- step stmt + 1 <- columnCount stmt + [SqlInteger 2] <- columns stmt + Done <- step stmt + return () + withStmt conn "SELECT @n1+@n2" $ \stmt -> do + -- Test that we get something back for known names + Just _n1 <- Direct.bindParameterIndex stmt (toUtf8 "@n1") + Just _n2 <- Direct.bindParameterIndex stmt (toUtf8 "@n2") + -- Here's where things get confusing.. You can't mix different + -- types of :/$/@ parameter conventions. + Nothing <- Direct.bindParameterIndex stmt (toUtf8 ":n1") + Nothing <- Direct.bindParameterIndex stmt (toUtf8 ":n2") + return () + withStmt conn "SELECT :foo / :bar,:t" $ \stmt -> do + bindNamed stmt [(":t", SqlText "txt"), (":foo", SqlInteger 6), (":bar", SqlInteger 2)] + Row <- step stmt + 2 <- columnCount stmt + [SqlInteger 3, SqlText "txt"] <- columns stmt + Done <- step stmt + return () + +testColumns :: IO TestEnv -> Assertion +testColumns envIO = do + TestEnv {..} <- envIO + withConn $ \conn -> do + withStmt conn "CREATE TABLE foo (a INT)" command + withStmt conn "SELECT * FROM foo" $ \stmt -> do + 1 <- columnCount stmt + exec conn "ALTER TABLE foo ADD COLUMN b INT" + Done <- step stmt + 2 <- columnCount stmt + return () + withStmt conn "SELECT * FROM foo" $ \stmt -> do + 2 <- columnCount stmt + Done <- step stmt + 2 <- columnCount stmt + return () + withStmt conn "INSERT INTO foo VALUES (1, 2)" command + withStmt conn "SELECT * FROM foo" $ \stmt -> do + 2 <- columnCount stmt + Row <- step stmt + 2 <- columnCount stmt + [SqlInteger 1, SqlInteger 2] <- columns stmt + Done <- step stmt + 2 <- columnCount stmt + return () + withStmt conn "INSERT INTO foo VALUES (3, 4)" command + withStmt conn "INSERT INTO foo VALUES (5, 6)" command + withStmt conn "SELECT * FROM foo" $ \stmt -> do + 2 <- columnCount stmt + exec conn "ALTER TABLE foo ADD COLUMN c INT" + Row <- step stmt + 3 <- columnCount stmt + [SqlInteger 1, SqlInteger 2, SqlNull] <- columns stmt + exec conn "ALTER TABLE foo ADD COLUMN d INT NOT NULL DEFAULT 42" + -- ignored by this prepared statement, now that it has stepped. + Row <- step stmt + 3 <- columnCount stmt + [SqlInteger 3, SqlInteger 4, SqlNull] <- columns stmt + Row <- step stmt + 3 <- columnCount stmt + [SqlInteger 5, SqlInteger 6, SqlNull] <- columns stmt + Done <- step stmt + 3 <- columnCount stmt + reset stmt + 3 <- columnCount stmt -- The prepared statement *still* doesn't know + -- about the new column. + Row <- step stmt + 4 <- columnCount stmt -- That's better. + [SqlInteger 1, SqlInteger 2, SqlNull, SqlInteger 42] <- columns stmt + return () + where + command stmt = do + 0 <- columnCount stmt + Done <- step stmt + 0 <- columnCount stmt + return () + +testTypedColumns :: IO TestEnv -> Assertion +testTypedColumns envIO = do + TestEnv {..} <- envIO + withConn $ \conn -> do + withStmt conn "CREATE TABLE foo (a INT, b INT)" command + withStmt conn "INSERT INTO foo VALUES (1, 2)" command + withStmt conn "INSERT INTO foo VALUES (3, 4)" command + withStmt conn "SELECT * FROM foo" $ \stmt -> do + Row <- step stmt + 2 <- columnCount stmt + [SqlInteger 1, SqlInteger 2] <- typedColumns stmt [Nothing, Nothing] + Row <- step stmt + 2 <- columnCount stmt + [SqlInteger 3, SqlInteger 4] <- typedColumns stmt [Just IntegerColumn, Just IntegerColumn] + Done <- step stmt + 2 <- columnCount stmt + return () + withStmt conn "SELECT * FROM foo" $ \stmt -> do + Row <- step stmt + 2 <- columnCount stmt + [SqlText "1", SqlText "2"] <- typedColumns stmt [Just TextColumn, Just TextColumn] + Row <- step stmt + 2 <- columnCount stmt + [SqlFloat 3.0, SqlFloat 4.0] <- typedColumns stmt [Just FloatColumn, Just FloatColumn] + Done <- step stmt + 2 <- columnCount stmt + return () + where + command stmt = do + 0 <- columnCount stmt + Done <- step stmt + 0 <- columnCount stmt + return () + +testColumnName :: IO TestEnv -> Assertion +testColumnName envIO = do + TestEnv {..} <- envIO + withConn $ \conn -> do + exec conn "CREATE TABLE foo (id INTEGER PRIMARY KEY, abc TEXT, \"123\" REAL, über INT)" + exec conn "INSERT INTO foo (abc, \"123\", über) VALUES ('hello', 3.14, 456)" + + withStmt conn "SELECT id AS id, abc AS x, \"123\" AS y, über AS ü FROM foo" $ + \stmt -> do + let checkNames = do + 4 <- columnCount stmt + Nothing <- columnName stmt (-1) + Just "id" <- columnName stmt 0 + Just "x" <- columnName stmt 1 + Just "y" <- columnName stmt 2 + Just "ü" <- columnName stmt 3 + Nothing <- columnName stmt 4 + Nothing <- columnName stmt minBound + Nothing <- columnName stmt maxBound + return () + checkNames + Row <- step stmt + checkNames + [SqlInteger 1, SqlText "hello", SqlFloat 3.14, SqlInteger 456] <- columns stmt + Done <- step stmt + checkNames + + -- Column names without AS clauses may change in future versions of Sqlite. + -- This test will fail if they do. + withStmt conn "SELECT * FROM foo" $ \stmt -> do + 4 <- columnCount stmt + Nothing <- columnName stmt (-1) + Just "id" <- columnName stmt 0 + Just "abc" <- columnName stmt 1 + Just "123" <- columnName stmt 2 + Just "über" <- columnName stmt 3 + Nothing <- columnName stmt 4 + Nothing <- columnName stmt minBound + Nothing <- columnName stmt maxBound + return () + +-- Testing for specific error codes: +-- +-- * ErrorConstraint +-- +-- * ErrorRange +-- +-- * ErrorLocked + +-- * ErrorBusy +testErrors :: IO TestEnv -> Assertion +testErrors envIO = do + TestEnv {..} <- envIO + withConn $ \conn -> do + exec conn "CREATE TABLE foo (n INT UNIQUE)" + exec conn "INSERT INTO foo VALUES (3)" + expectError ErrorConstraint $ + exec conn "INSERT INTO foo VALUES (3)" + + -- Multiple NULLs are allowed when there's a UNIQUE constraint + exec conn "INSERT INTO foo VALUES (null)" + exec conn "INSERT INTO foo VALUES (null)" + + exec conn "CREATE TABLE bar (n INT NOT NULL)" + expectError ErrorConstraint $ + exec conn "INSERT INTO bar VALUES (null)" + + withStmt conn "SELECT ?" $ \stmt -> do + forM_ [-1, 0, 2] $ \i -> do + expectError ErrorRange $ bindSqlData stmt i $ SqlInteger 42 + expectError ErrorRange $ bindSqlData stmt i SqlNull + bindSqlData stmt 1 $ SqlInteger 42 + Row <- step stmt + + -- If column index is out of range, it returns SqlNull. + -- This may or may not be the desired behavior, but at least we know. + SqlNull <- column stmt (-1) + SqlNull <- column stmt 1 + + SqlInteger 42 <- column stmt 0 + return () + + withStmt conn "SELECT 1" $ \stmt -> do + forM_ [-1, 0, 1, 2] $ \i -> do + expectError ErrorRange $ bindSqlData stmt i $ SqlInteger 42 + expectError ErrorRange $ bindSqlData stmt i SqlNull + bind stmt [] -- This should succeed. Don't whine that there aren't any + -- parameters to bind! + Row <- step stmt + SqlInteger 1 <- column stmt 0 + return () + + withStmt conn "SELECT :bar" $ \stmt -> do + shouldFail $ bindNamed stmt [(":missing", SqlInteger 42)] + bindNamed stmt [(":bar", SqlInteger 1)] + Row <- step stmt + SqlInteger 1 <- column stmt 0 + return () + + withStmt conn "SELECT ?5" $ \stmt -> do + forM_ [-1, 0, 6, 7] $ \i -> do + expectError ErrorRange $ bindSqlData stmt i $ SqlInteger 42 + expectError ErrorRange $ bindSqlData stmt i SqlNull + bind stmt $ map SqlInteger [1 .. 5] + -- This succeeds, even though 1..4 aren't used. + Row <- step stmt + [SqlInteger 5] <- columns stmt + return () + + -- Need to access the database with multiple connections. + -- "BEGIN; ROLLBACK" causes running statements in the same connection to + -- throw SqlITE_ABORT. + withConnShared $ \conn -> do + foo123456 conn + withStmt conn "SELECT * FROM foo" $ \stmt -> do + -- "DROP TABLE foo" should succeed, since the statement + -- isn't running yet. + exec conn "DROP TABLE foo" + foo123456 conn + + Row <- step stmt + 2 <- columnCount stmt + [SqlInteger 1, SqlInteger 2] <- columns stmt + + -- "DROP TABLE foo" should fail, now that the statement is running. + expectError ErrorLocked $ exec conn "DROP TABLE foo" + withConnShared $ \conn -> do + expectError ErrorBusy $ exec conn "DROP TABLE foo" + + -- Apparently, we can pretend to drop the table, but we get ErrorBusy + -- if we try to actually COMMIT it. + exec conn "BEGIN; DROP TABLE foo" + expectError ErrorBusy $ exec conn "COMMIT" + + exec conn "ROLLBACK" + + Row <- step stmt + 2 <- columnCount stmt + [SqlInteger 3, SqlInteger 4] <- columns stmt + Row <- step stmt + 2 <- columnCount stmt + [SqlInteger 5, SqlInteger 6] <- columns stmt + + expectError ErrorLocked $ exec conn "DROP TABLE foo" + withConnShared $ \conn -> + expectError ErrorBusy $ exec conn "DROP TABLE foo" + + Done <- step stmt + 2 <- columnCount stmt + exec conn "DROP TABLE foo" + + -- Regular 'reset' throws away the error. Make sure sqlite3_reset did + -- not return an error because foo is now gone. sqlite3_reset should + -- only return an error if the most recent 'step' failed. + Right () <- Direct.reset stmt + + -- But trying to 'step' again should fail. + Left SqliteException {sqliteError = err} <- try $ step stmt + assertBool + "Step after table vanishes should fail with SqlITE_ERROR or SqlITE_SCHEMA" + ( err == ErrorError + || err == ErrorSchema -- Sqlite 3.7.13 + -- Sqlite 3.6.22 + ) + where + expectError err io = do + Left SqliteException {sqliteError = err'} <- try io + assertEqual "testErrors: expectError" err err' + + foo123456 conn = + exec + conn + "CREATE TABLE foo (a INT, b INT); \ + \INSERT INTO foo VALUES (1, 2); \ + \INSERT INTO foo VALUES (3, 4); \ + \INSERT INTO foo VALUES (5, 6)" + +-- Make sure data stored in a table comes back as-is. +testIntegrity :: IO TestEnv -> Assertion +testIntegrity envIO = do + TestEnv {..} <- envIO + withConn $ \conn -> do + exec conn "CREATE TABLE foo (i INT, f FLOAT, t TEXT, b BLOB, n TEXT)" + withStmt conn "INSERT INTO foo VALUES (?, ?, ?, ?, ?)" $ \insert -> + withStmt conn "SELECT * FROM foo" $ \select -> do + let test = testWith (===) + + testWith f values = do + exec conn "DELETE FROM foo" + + reset insert + bind insert values + Done <- step insert + + reset select + Row <- step select + values' <- columns select + Done <- step select + + return $ f values values' + + True <- test [SqlInteger 0, SqlFloat 0.0, SqlText T.empty, SqlBlob B.empty, SqlNull] + True <- test [SqlInteger minBound, SqlFloat (-1 / 0), SqlText "\0", SqlBlob (B8.pack "\0"), SqlNull] + True <- test [SqlInteger maxBound, SqlFloat (1 / 0), SqlText "\1114111", SqlBlob ("\255"), SqlNull] + + -- Sqlite3 turns NaN into SqlNull. + True <- + testWith + (\_old new -> new === [SqlNull, SqlNull, SqlNull, SqlNull, SqlNull]) + [SqlNull, SqlFloat (0 / 0), SqlNull, SqlNull, SqlNull] + + return () + +testDecodeError :: IO TestEnv -> Assertion +testDecodeError envIO = do + TestEnv {..} <- envIO + withStmt conn "SELECT ?" $ \stmt -> do + Right () <- Direct.bindText stmt 1 invalidUtf8 + Row <- step stmt + Left (DecodeError "Database.Sqlite3.columnText: Invalid UTF-8" _) <- + try $ column stmt 0 + return () + + -- Verify the assertion that Sqlite3 does not validate UTF-8, by writing the + -- data to a table on disk and reading it back. + withConnShared $ \conn -> do + exec conn "CREATE TABLE testDecodeError (a TEXT)" + withStmt conn "INSERT INTO testDecodeError VALUES (?)" $ \stmt -> do + Right () <- Direct.bindText stmt 1 invalidUtf8 + Done <- step stmt + return () + withConnShared $ \conn -> do + withStmt conn "SELECT * FROM testDecodeError" $ \stmt -> do + Row <- step stmt + TextColumn <- columnType stmt 0 + txt <- Direct.columnText stmt 0 + assertEqual "testDecodeError: Database altered our invalid UTF-8" (fromUtf8Lenient invalidUtf8) (fromUtf8Lenient txt) + Left (DecodeError "Database.Sqlite3.columnText: Invalid UTF-8" _) <- + try $ columnText stmt 0 + Done <- step stmt + return () + where + invalidUtf8 = Direct.Utf8 $ B.pack [0x80] + +testResultStats :: IO TestEnv -> Assertion +testResultStats envIO = do + TestEnv {..} <- envIO + withConn $ \conn -> do + (0, 0, 0) <- stats conn + exec conn "CREATE TABLE tbl (n INTEGER PRIMARY KEY)" + (0, 0, 0) <- stats conn + exec conn "INSERT INTO tbl DEFAULT VALUES" + (1, 1, 1) <- stats conn + exec conn "INSERT INTO tbl VALUES (123)" + (123, 1, 2) <- stats conn + exec conn "INSERT INTO tbl VALUES (9223372036854775807)" + (maxBound, 1, 3) <- stats conn + exec conn "INSERT INTO tbl DEFAULT VALUES" -- picks a rowid at random + (rowid, 1, 4) <- stats conn + True <- return $ (`notElem` [1, 123, maxBound]) rowid + exec conn "UPDATE tbl SET rowid=rowid+1 WHERE rowid=1 OR rowid=123" + (_, 2, 6) <- stats conn + Left SqliteException {sqliteError = ErrorConstraint} <- + try $ exec conn "UPDATE tbl SET rowid=4" + exec conn "DELETE FROM tbl" + (_, 4, 10) <- stats conn + return () + where + stats conn = + liftM3 + (,,) + (lastInsertRowId conn) + (changes conn) + (Direct.totalChanges conn) + +testGetAutoCommit :: IO TestEnv -> Assertion +testGetAutoCommit envIO = do + TestEnv {..} <- envIO + withConn $ \conn -> do + True <- Direct.getAutoCommit conn + exec conn "BEGIN" + False <- Direct.getAutoCommit conn + Left (ErrorError, _) <- Direct.exec conn (toUtf8 "BEGIN") + False <- Direct.getAutoCommit conn + + exec conn "ROLLBACK" + True <- Direct.getAutoCommit conn + Left (ErrorError, _) <- Direct.exec conn (toUtf8 "ROLLBACK") + True <- Direct.getAutoCommit conn + + -- This commented (because it failed) test seems to check that after a "database + -- or disk is full" type of error, the transaction is rolled back and we return + -- to autocommit mode. + -- + -- But the documentation seems to say that the rollback *might* happen in those + -- cases, not that it *always* happens: + -- https://www.sqlite.org/lang_transaction.html + -- https://www.sqlite.org/c3ref/get_autocommit.html + -- + -- exec conn "BEGIN" + -- False <- Direct.getAutoCommit conn + -- Left (ErrorFull, _) <- + -- Direct.exec + -- conn + -- "PRAGMA max_page_count=1; CREATE TABLE foo (a INT)" + -- True <- Direct.getAutoCommit conn + -- Left (ErrorError, _) <- Direct.exec conn "ROLLBACK" + + return () + +testStatementSql :: IO TestEnv -> Assertion +testStatementSql envIO = do + TestEnv {..} <- envIO + let q1 = "SELECT 1+1" + withStmt conn q1 $ \stmt -> do + Just (Direct.Utf8 sql1) <- Direct.statementSql stmt + T.encodeUtf8 q1 @=? sql1 + +testCustomFunction :: IO TestEnv -> Assertion +testCustomFunction envIO = do + TestEnv {..} <- envIO + withConn $ \conn -> do + createFunction conn "repeat" (Just 2) True repeatString + withStmt conn "SELECT repeat(3,'abc')" $ \stmt -> do + Row <- step stmt + [SqlText "abcabcabc"] <- columns stmt + Done <- step stmt + return () + deleteFunction conn "repeat" (Just 2) + Left SqliteException {sqliteError = ErrorError} <- + try $ exec conn "SELECT repeat(3,'abc')" + return () + where + repeatString ctx args = do + n <- funcArgInt64 args 0 + s <- funcArgText args 1 + funcResultText ctx $ T.concat $ replicate (fromIntegral n) s + +testCustomFunctionError :: IO TestEnv -> Assertion +testCustomFunctionError envIO = do + TestEnv {..} <- envIO + withConn $ \conn -> do + createFunction conn "fail" (Just 0) True throwError + Left SqliteException {..} <- try $ exec conn "SELECT fail()" + -- Match only the first 13 characters of the error message here. The + -- error message coming from the use of "error" nowadays contains + -- fragments of the callstack and not just the string we gave it. + assertBool + "Catch exception" + (sqliteError == ErrorError && T.take 13 sqliteErrorDetails == "error message") + where + throwError _ _ = error "error message" + +testCustomAggragate :: IO TestEnv -> Assertion +testCustomAggragate envIO = do + TestEnv {..} <- envIO + withConn $ \conn -> do + exec conn "CREATE TABLE tbl (n INT)" + exec conn "INSERT INTO tbl(n) VALUES (12), (-3), (7)" + createAggregate conn "mysum" (Just 1) 0 mySumStep funcResultInt64 + withStmt conn "SELECT mysum(n) FROM tbl" $ \stmt -> do + Row <- step stmt + [SqlInteger 16] <- columns stmt + Done <- step stmt + return () + deleteFunction conn "mysum" (Just 1) + Left SqliteException {sqliteError = ErrorError} <- + try $ exec conn "SELECT mysum(n) FROM tbl" + return () + where + mySumStep _ args s = do + n <- funcArgInt64 args 0 + return (s + n) + +testCustomCollation :: IO TestEnv -> Assertion +testCustomCollation envIO = do + TestEnv {..} <- envIO + withConn $ \conn -> do + exec conn "CREATE TABLE tbl (n TEXT)" + exec conn "INSERT INTO tbl(n) VALUES ('dog'),('mouse'),('ox'),('cat')" + createCollation conn "len" cmpLen + withStmt conn "SELECT * FROM tbl ORDER BY n COLLATE len" $ \stmt -> do + Row <- step stmt + [SqlText "ox"] <- columns stmt + Row <- step stmt + [SqlText "cat"] <- columns stmt + Row <- step stmt + [SqlText "dog"] <- columns stmt + Row <- step stmt + [SqlText "mouse"] <- columns stmt + Done <- step stmt + return () + deleteCollation conn "len" + Left SqliteException {sqliteError = ErrorError} <- + try $ exec conn "SELECT * FROM tbl ORDER BY n COLLATE len" + return () + where + -- order by length first, then by lexicographical order + cmpLen s1 s2 = compare (T.length s1) (T.length s2) <> compare s1 s2 + +testIncrementalBlobIO :: IO TestEnv -> Assertion +testIncrementalBlobIO envIO = do + TestEnv {..} <- envIO + withConn $ \conn -> do + exec conn "CREATE TABLE tbl (n BLOB)" + exec conn "INSERT INTO tbl(rowid,n) VALUES (1,'abcdefg')" + blob <- blobOpen conn "main" "tbl" "n" 1 True + l <- blobBytes blob + assertEqual "blobBytes" 7 l + s <- blobRead blob 4 2 + assertEqual "blobRead" "cdef" s + blobWrite blob "BC" 1 + blobClose blob + withStmt conn "SELECT n FROM tbl" $ \stmt -> do + Row <- step stmt + s' <- columnBlob stmt 0 + assertEqual "blobWrite" "aBCdefg" s' + +testInterrupt :: IO TestEnv -> Assertion +testInterrupt envIO = do + TestEnv {..} <- envIO + withConn $ \conn -> do + exec conn "CREATE TABLE tbl (n INT)" + + withStmt conn "INSERT INTO tbl VALUES (?)" $ \stmt -> do + exec conn "BEGIN" + forM_ [1 .. 200] $ \i -> do + reset stmt + bind stmt [SqlInteger i] + Done <- step stmt + return () + exec conn "COMMIT" + + stmt <- prepare conn tripleSum + _ <- forkIO $ threadDelay 100000 >> interrupt conn + Left ErrorInterrupt <- Direct.step stmt + Left ErrorInterrupt <- Direct.finalize stmt + + Nothing <- timeout 100000 $ interruptibly conn $ exec conn tripleSum + + return () + where + tripleSum = "SELECT sum(a.n + b.n + c.n) FROM tbl as a, tbl as b, tbl as c" + +testMultiRowInsert :: IO TestEnv -> Assertion +testMultiRowInsert envIO = do + TestEnv {..} <- envIO + withConn $ \conn -> do + exec conn "CREATE TABLE foo (a INT, b INT)" + result <- try $ exec conn "INSERT INTO foo VALUES (1,2), (3,4)" + case result of + Left SqliteException {sqliteError = ErrorError} -> + assertFailure "Installed Sqlite3 does not support multi-row INSERT via the VALUES clause" + Left e -> + assertFailure $ show e + Right () -> do + -- Make sure multi-row insert actually worked + 2 <- changes conn + withStmt conn "SELECT * FROM foo" $ \stmt -> do + Row <- step stmt + [SqlInteger 1, SqlInteger 2] <- columns stmt + Row <- step stmt + [SqlInteger 3, SqlInteger 4] <- columns stmt + Done <- step stmt + return () + +testOpenV2CanNotCreate :: IO FilePath -> Assertion +testOpenV2CanNotCreate filepathIO = do + filepath <- filepathIO + Left SqliteException {sqliteError = ErrorCan'tOpen} <- try do + db <- openV2 DefaultVFS [] OpenV2ReadOnly (T.pack filepath) + close db + Left SqliteException {sqliteError = ErrorCan'tOpen} <- try do + db <- openV2 DefaultVFS [] OpenV2ReadWrite (T.pack filepath) + close db + do + db <- openV2 DefaultVFS [] OpenV2ReadWriteCreate (T.pack filepath) + close db + pure () + +testExtendedResultCodes :: IO FilePath -> Assertion +testExtendedResultCodes filepathIO = do + filepath <- filepathIO + db <- openV2 DefaultVFS [] OpenV2ReadWrite (T.pack filepath) + Left SqliteException {sqliteError = ErrorConstraint} <- try do + exec + db + "CREATE TABLE test_ercs (t TEXT PRIMARY KEY); \ + \INSERT INTO test_ercs VALUES ('val1'); \ + \INSERT INTO test_ercs VALUES ('val1');" + db <- openV2 DefaultVFS [OpenV2ExtendedResultCode] OpenV2ReadWrite (T.pack filepath) + Left SqliteException {sqliteError = ErrorConstraintPrimaryKey} <- try do + exec + db + "CREATE TABLE test_ercs_2 (t TEXT PRIMARY KEY); \ + \INSERT INTO test_ercs_2 VALUES ('val1'); \ + \INSERT INTO test_ercs_2 VALUES ('val1');" + close db + +withDatabaseFile :: + -- | Parent directory to create the file in + FilePath -> + -- | File name template + String -> + (FilePath -> IO ()) -> + (IO FilePath -> TestTree) -> + TestTree +withDatabaseFile dirpath template prepare = + withResource allocFile deallocFile + where + allocFile = do + (filepath, handle) <- openTempFile dirpath template + hClose handle + -- We only need the name. Tests will create the file, if needed. + removeFile filepath + prepare filepath + pure filepath + deallocFile filepath = do + exists <- doesFileExist filepath + when exists $ removeFile filepath + +withTestEnv :: IO FilePath -> (IO TestEnv -> TestTree) -> TestTree +withTestEnv tempDbFilePathIO = + withResource allocEnv deallocEnv + where + allocEnv = do + conn <- open ":memory:" + pure $ + TestEnv + { conn, + withConn, + withConnShared = \callback -> do + tempDbFilePath <- tempDbFilePathIO + withConnPath (T.pack tempDbFilePath) callback + } + deallocEnv TestEnv {conn} = do + close conn + withConn = withConnPath ":memory:" + withConnPath path cb = do + conn <- open path + r <- cb conn `onException` Direct.close conn + -- If the callback throws an exception, try to close the DB. + -- If closing fails (usually due to open 'Statement's), + -- throw the original error, not the error produced by 'close'. + -- Direct.close returns the error rather than throwing it. + close conn + return r + +main :: IO () +main = do + defaultMain $ + testGroup + "All" + [ withDatabaseFile + "." + "direct-sqlite-test-database" + ( \filepath -> + do + db <- open (T.pack filepath) + close db + ) + \tempDbNameIO -> + withTestEnv tempDbNameIO \envIO -> do + testGroup "OldTests" $ ($ envIO) <$> regressionTests, + withDatabaseFile + "." + "direct-sqlite-test-database-open-v2" + (\_ -> pure ()) + \tempDbNameIO -> + testGroup + "openV2" + [ testCase "openV2 can't create if create mode not set" $ testOpenV2CanNotCreate tempDbNameIO, + testCase "extended result codes are returned when flag is set" $ testExtendedResultCodes tempDbNameIO + ] + ] + +toUtf8 :: Text -> Direct.Utf8 +toUtf8 = Direct.Utf8 . T.encodeUtf8 + +fromUtf8Lenient :: Direct.Utf8 -> Text +fromUtf8Lenient (Direct.Utf8 bs) = T.decodeUtf8With lenientDecode bs diff --git a/test/StrictEq.hs b/test/StrictEq.hs new file mode 100644 --- /dev/null +++ b/test/StrictEq.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +module StrictEq + ( StrictEq (..), + (/==), + ) +where + +import Data.ByteString (ByteString) +import Data.Int (Int64) +import Data.Text (Text) +import Foreign.C +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable +import Sqlite +import System.IO.Unsafe (unsafePerformIO) + +foreign import capi unsafe "string.h memcmp" + c_memcmp :: Ptr a -> Ptr a -> CSize -> IO CInt + +-- | Variant of Eq that compares Double based on raw representation, +-- rather than applying IEEE 754 coercion rules. +class StrictEq a where + (===) :: a -> a -> Bool + +(/==) :: (StrictEq a) => a -> a -> Bool +(/==) a b = not (a === b) + +instance StrictEq Double where + a === b = unsafePerformIO $ + alloca $ \aptr -> + alloca $ \bptr -> do + poke aptr a + poke bptr b + rc <- c_memcmp aptr bptr (fromIntegral $ sizeOf a) + return (rc == 0) + +instance StrictEq Int64 where + a === b = a == b + +instance StrictEq Text where + a === b = a == b + +instance StrictEq ByteString where + a === b = a == b + +instance (StrictEq a) => StrictEq [a] where + [] === [] = True + (x : xs) === (y : ys) = x === y && xs === ys + _ === _ = False + +instance StrictEq SqlData where + SqlInteger a === SqlInteger b = a === b + SqlFloat a === SqlFloat b = a === b + SqlText a === SqlText b = a === b + SqlBlob a === SqlBlob b = a === b + SqlNull === SqlNull = True + _ === _ = False