summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJanneHellsten <>2018-03-27 07:34:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-03-27 07:34:00 (GMT)
commit814804cc56753ed53c67b2a8f7d938bab858131e (patch)
tree8a9890a659c51eb47048477c7e0c2730aeca204d
parente5405476b9ec2dc08ef405f21150758ef7ca3327 (diff)
version 0.4.15.00.4.15.0
-rw-r--r--Database/SQLite/Simple.hs1714
-rw-r--r--Database/SQLite/Simple/FromField.hs430
-rw-r--r--Database/SQLite/Simple/FromRow.hs272
-rw-r--r--Database/SQLite/Simple/Internal.hs140
-rw-r--r--Database/SQLite/Simple/Ok.hs164
-rw-r--r--Database/SQLite/Simple/Time.hs42
-rw-r--r--Database/SQLite/Simple/Time/Implementation.hs400
-rw-r--r--Database/SQLite/Simple/ToField.hs340
-rw-r--r--Database/SQLite/Simple/ToRow.hs184
-rw-r--r--Database/SQLite/Simple/Types.hs195
-rw-r--r--README.markdown228
-rw-r--r--Setup.hs10
-rw-r--r--changelog209
-rw-r--r--sqlite-simple.cabal211
-rw-r--r--test/Common.hs36
-rw-r--r--test/Debug.hs58
-rw-r--r--test/DirectSqlite.hs46
-rw-r--r--test/Errors.hs498
-rw-r--r--test/Fold.hs42
-rw-r--r--test/Main.hs170
-rw-r--r--test/ParamConv.hs488
-rw-r--r--test/Simple.hs534
-rw-r--r--test/Statement.hs132
-rw-r--r--test/TestImports.hs90
-rw-r--r--test/UserInstances.hs66
25 files changed, 3354 insertions, 3345 deletions
diff --git a/Database/SQLite/Simple.hs b/Database/SQLite/Simple.hs
index fad8a20..b7cce82 100644
--- a/Database/SQLite/Simple.hs
+++ b/Database/SQLite/Simple.hs
@@ -1,857 +1,857 @@
-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, GeneralizedNewtypeDeriving, ScopedTypeVariables, GADTs #-}
-
-------------------------------------------------------------------------------
--- |
--- Module: Database.SQLite.Simple
--- Copyright: (c) 2011 MailRank, Inc.
--- (c) 2011-2012 Leon P Smith
--- (c) 2012-2013 Janne Hellsten
--- License: BSD3
--- Maintainer: Janne Hellsten <jjhellst@gmail.com>
--- Portability: portable
---
-------------------------------------------------------------------------------
-
-module Database.SQLite.Simple (
- -- ** Examples of use
- -- $use
-
- -- ** The Query 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
-
- -- *** Conversion to/from UTCTime
- -- $utctime
-
- Query(..)
- , Connection(..)
- , ToRow(..)
- , FromRow(..)
- , Only(..)
- , (:.)(..)
- , Base.SQLData(..)
- , Statement(..)
- , ColumnIndex(..)
- , NamedParam(..)
- -- * Connections
- , open
- , close
- , withConnection
- , setTrace
- -- * Queries that return results
- , query
- , query_
- , queryWith
- , queryWith_
- , queryNamed
- , lastInsertRowId
- , changes
- , totalChanges
- -- * Queries that stream results
- , fold
- , fold_
- , foldNamed
- -- * Statements that do not return results
- , execute
- , execute_
- , executeMany
- , executeNamed
- , field
- -- * Transactions
- , withTransaction
- , withImmediateTransaction
- , withExclusiveTransaction
- -- * Low-level statement API for stream access and prepared statements
- , openStatement
- , closeStatement
- , withStatement
- , bind
- , bindNamed
- , reset
- , columnName
- , columnCount
- , withBind
- , nextRow
- -- ** Exceptions
- , FormatError(..)
- , ResultError(..)
- , Base.SQLError(..)
- , Base.Error(..)
- ) where
-
-import Control.Applicative
-import Control.Exception
-import Control.Monad (void, when, forM_)
-import Control.Monad.Trans.Reader
-import Control.Monad.Trans.State.Strict
-import Data.Int (Int64)
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as TE
-import Data.Typeable (Typeable)
-import Database.SQLite.Simple.Types
-import qualified Database.SQLite3 as Base
-import qualified Database.SQLite3.Direct as BaseD
-
-
-import Database.SQLite.Simple.FromField (ResultError(..))
-import Database.SQLite.Simple.FromRow
-import Database.SQLite.Simple.Internal
-import Database.SQLite.Simple.Ok
-import Database.SQLite.Simple.ToField (ToField(..))
-import Database.SQLite.Simple.ToRow (ToRow(..))
-
--- | An SQLite prepared statement.
-newtype Statement = Statement { unStatement :: Base.Statement }
-
--- | Index of a column in a result set. Column indices start from 0.
-newtype ColumnIndex = ColumnIndex BaseD.ColumnIndex
- deriving (Eq, Ord, Enum, Num, Real, Integral)
-
-data NamedParam where
- (:=) :: (ToField v) => T.Text -> v -> NamedParam
-
-data TransactionType = Deferred | Immediate | Exclusive
-
-infixr 3 :=
-
-instance Show NamedParam where
- show (k := v) = show (k, toField v)
-
--- | Exception thrown if a 'Query' 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
- , fmtQuery :: Query
- , fmtParams :: [String]
- } deriving (Eq, Show, Typeable)
-
-instance Exception FormatError
-
--- | Open a database connection to a given file. Will throw an
--- exception if it cannot connect.
---
--- Every 'open' must be closed with a call to 'close'.
---
--- If you specify \":memory:\" or an empty string as the input filename,
--- then a private, temporary in-memory database is created for the
--- connection. This database will vanish when you close the
--- connection.
-open :: String -> IO Connection
-open fname = Connection <$> Base.open (T.pack fname)
-
--- | Close a database connection.
-close :: Connection -> IO ()
-close (Connection c) = Base.close c
-
--- | Opens a database connection, executes an action using this connection, and
--- closes the connection, even in the presence of exceptions.
-withConnection :: String -> (Connection -> IO a) -> IO a
-withConnection connString = bracket (open connString) close
-
-unUtf8 :: BaseD.Utf8 -> T.Text
-unUtf8 (BaseD.Utf8 bs) = TE.decodeUtf8 bs
-
--- | <http://www.sqlite.org/c3ref/profile.html>
---
--- 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 may crash. Enable only for debugging!
-setTrace :: Connection -> Maybe (T.Text -> IO ()) -> IO ()
-setTrace (Connection db) logger =
- BaseD.setTrace db (fmap (\lf -> lf . unUtf8) logger)
-
--- | 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) => Statement -> params -> IO ()
-bind (Statement stmt) params = do
- let qp = toRow params
- stmtParamCount <- Base.bindParameterCount stmt
- when (length qp /= fromIntegral stmtParamCount) (throwColumnMismatch qp stmtParamCount)
- mapM_ (errorCheckParamName qp) [1..stmtParamCount]
- Base.bind stmt qp
- where
- throwColumnMismatch qp nParams = do
- templ <- getQuery stmt
- fmtError ("SQL query contains " ++ show nParams ++ " params, but " ++
- show (length qp) ++ " arguments given") templ qp
- errorCheckParamName qp paramNdx = do
- templ <- getQuery stmt
- name <- Base.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 :: Statement -> [NamedParam] -> IO ()
-bindNamed (Statement stmt) params = do
- stmtParamCount <- Base.bindParameterCount stmt
- when (length params /= fromIntegral stmtParamCount) $ throwColumnMismatch stmtParamCount
- bind stmt params
- where
- bind stmt params =
- mapM_ (\(n := v) -> do
- idx <- BaseD.bindParameterIndex stmt (BaseD.Utf8 . TE.encodeUtf8 $ n)
- case idx of
- Just i ->
- Base.bindSQLData stmt i (toField v)
- Nothing -> do
- templ <- getQuery stmt
- fmtError ("Unknown named parameter '" ++ T.unpack n ++ "'")
- templ params)
- params
-
- throwColumnMismatch nParams = do
- templ <- getQuery 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 :: Statement -> IO ()
-reset (Statement stmt) = Base.reset stmt
-
--- | Return the name of a a particular column in the result set of a
--- 'Statement'. Throws an 'ArrayException' if the colum index is out
--- of bounds.
---
--- <http://www.sqlite.org/c3ref/column_name.html>
-columnName :: Statement -> ColumnIndex -> IO T.Text
-columnName (Statement stmt) (ColumnIndex n) = BaseD.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 :: Statement -> IO ColumnIndex
-columnCount (Statement stmt) = ColumnIndex <$> BaseD.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) => Statement -> 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 -> Query -> IO Statement
-openStatement (Connection c) (Query t) = do
- stmt <- Base.prepare c t
- return $ Statement stmt
-
--- | Closes a prepared statement.
-closeStatement :: Statement -> IO ()
-closeStatement (Statement stmt) = Base.finalize stmt
-
--- | Opens a prepared statement, executes an action using this statement, and
--- closes the statement, even in the presence of exceptions.
-withStatement :: Connection -> Query -> (Statement -> IO a) -> IO a
-withStatement conn query = bracket (openStatement conn query) closeStatement
-
--- A version of 'withStatement' which binds parameters.
-withStatementParams :: (ToRow params)
- => Connection
- -> Query
- -> params
- -> (Statement -> 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
- -> Query
- -> [NamedParam]
- -> (Statement -> 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 -> Query -> q -> IO ()
-execute conn template qs =
- withStatementParams conn template qs $ \(Statement stmt) ->
- void . Base.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 -> Query -> [q] -> IO ()
-executeMany conn template paramRows = withStatement conn template $ \stmt -> do
- let Statement stmt' = stmt
- forM_ paramRows $ \params ->
- withBind stmt params
- (void . Base.step $ stmt')
-
-
-doFoldToList :: RowParser row -> Statement -> IO [row]
-doFoldToList fromRow_ stmt =
- fmap reverse $ doFold fromRow_ stmt [] (\acc e -> return (e : acc))
-
--- | 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.
-query :: (ToRow q, FromRow r)
- => Connection -> Query -> q -> IO [r]
-query = queryWith fromRow
-
--- | A version of 'query' that does not perform query substitution.
-query_ :: (FromRow r) => Connection -> Query -> IO [r]
-query_ = queryWith_ fromRow
-
--- | A version of 'query' that takes an explicit 'RowParser'.
-queryWith :: (ToRow q) => RowParser r -> Connection -> Query -> q -> IO [r]
-queryWith fromRow_ conn templ qs =
- withStatementParams conn templ qs $ \stmt -> doFoldToList fromRow_ stmt
-
--- | A version of 'query' that does not perform query substitution and
--- takes an explicit 'RowParser'.
-queryWith_ :: RowParser r -> Connection -> Query -> IO [r]
-queryWith_ fromRow_ conn query =
- withStatement conn query (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]
--- @
-queryNamed :: (FromRow r) => Connection -> Query -> [NamedParam] -> IO [r]
-queryNamed conn templ params =
- withStatementNamedParams conn templ params $ \stmt -> doFoldToList fromRow stmt
-
--- | A version of 'execute' that does not perform query substitution.
-execute_ :: Connection -> Query -> IO ()
-execute_ conn template =
- withStatement conn template $ \(Statement stmt) ->
- void $ Base.step stmt
-
--- | A version of 'execute' where the query parameters (placeholders)
--- are named.
-executeNamed :: Connection -> Query -> [NamedParam] -> IO ()
-executeNamed conn template params =
- withStatementNamedParams conn template params $ \(Statement stmt) ->
- void $ Base.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
- -> Query
- -> params
- -> a
- -> (a -> row -> IO a)
- -> IO a
-fold conn query params initalState action =
- withStatementParams conn query params $ \stmt ->
- doFold fromRow stmt initalState action
-
--- | A version of 'fold' which does not perform parameter substitution.
-fold_ :: ( FromRow row )
- => Connection
- -> Query
- -> a
- -> (a -> row -> IO a)
- -> IO a
-fold_ conn query initalState action =
- withStatement conn query $ \stmt ->
- doFold fromRow stmt initalState action
-
--- | A version of 'fold' where the query parameters (placeholders) are
--- named.
-foldNamed :: ( FromRow row )
- => Connection
- -> Query
- -> [NamedParam]
- -> a
- -> (a -> row -> IO a)
- -> IO a
-foldNamed conn query params initalState action =
- withStatementNamedParams conn query params $ \stmt ->
- doFold fromRow stmt initalState action
-
-doFold :: RowParser row -> Statement -> a -> (a -> row -> IO a) -> IO a
-doFold fromRow_ stmt initState action =
- loop initState
- 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) => Statement -> IO (Maybe r)
-nextRow = nextRowWith fromRow
-
-nextRowWith :: RowParser r -> Statement -> IO (Maybe r)
-nextRowWith fromRow_ (Statement stmt) = do
- statRes <- Base.step stmt
- case statRes of
- Base.Row -> do
- rowRes <- Base.columns stmt
- let nCols = length rowRes
- row <- convertRow fromRow_ rowRes nCols
- return $ Just row
- Base.Done -> return Nothing
-
-convertRow :: RowParser r -> [Base.SQLData] -> Int -> IO r
-convertRow fromRow_ rowRes ncols = do
- let rw = RowParseRO ncols
- case runStateT (runReaderT (unRP 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 :: Base.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 = case ttype of
- Deferred -> execute_ conn "BEGIN TRANSACTION"
- Immediate -> execute_ conn "BEGIN IMMEDIATE TRANSACTION"
- Exclusive -> execute_ conn "BEGIN EXCLUSIVE TRANSACTION"
- commit = execute_ conn "COMMIT TRANSACTION"
- rollback = execute_ conn "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 <http://www.sqlite.org/c3ref/last_insert_rowid.html>.
-lastInsertRowId :: Connection -> IO Int64
-lastInsertRowId (Connection c) = BaseD.lastInsertRowId c
-
--- | <http://www.sqlite.org/c3ref/changes.html>
---
--- 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 c) = BaseD.changes c
-
--- | <http://www.sqlite.org/c3ref/total_changes.html>
---
--- Return the total number of row changes caused by @INSERT@, @DELETE@,
--- or @UPDATE@ statements since the 'Database' was opened.
-totalChanges :: Connection -> IO Int
-totalChanges (Connection c) = BaseD.totalChanges c
-
--- | 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 -> Query -> [v] -> a
-fmtError msg q xs =
- throw FormatError {
- fmtMessage = msg
- , fmtQuery = q
- , fmtParams = map show xs
- }
-
-getQuery :: Base.Statement -> IO Query
-getQuery stmt =
- toQuery <$> BaseD.statementSql stmt
- where
- toQuery =
- Query . maybe "no query string" (\(BaseD.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 Database.SQLite.Simple
--- >import Database.SQLite.Simple.FromRow
--- >
--- >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 'Query' type and a parameter substitution
--- facility to address both ease of use and security. A 'Query' 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 'Query'.
---
--- To most easily construct a query, enable GHC's @OverloadedStrings@
--- language extension and write your query as a normal literal string.
---
--- > {-# LANGUAGE OverloadedStrings #-}
--- >
--- > import Database.SQLite.Simple
--- >
--- > hello = do
--- > conn <- open "test.db"
--- > [[x]] <- query_ conn "select 2 + 2"
--- > print x
---
--- A 'Query' 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 'Query' 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 'Query' 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.
-
--- $utctime
---
--- SQLite's datetime allows for multiple string representations of UTC
--- time. The following formats are supported for reading SQLite times
--- into Haskell UTCTime values:
---
--- * YYYY-MM-DD HH:MM
---
--- * YYYY-MM-DD HH:MM:SS
---
--- * YYYY-MM-DD HH:MM:SS.SSS
---
--- * YYYY-MM-DDTHH:MM
---
--- * YYYY-MM-DDTHH:MM:SS
---
--- * YYYY-MM-DDTHH:MM:SS.SSS
---
--- The above may also be optionally followed by a timezone indicator
--- of the form \"[+-]HH:MM\" or just \"Z\".
---
--- When Haskell UTCTime values are converted into SQLite values (e.g.,
--- parameters for a 'query'), the following format is used:
---
--- * YYYY-MM-DD HH:MM:SS.SSS
---
--- The last \".SSS\" subsecond part is dropped if it's zero. No
--- timezone indicator is used when converting from a UTCTime value
--- into an SQLite string. SQLite assumes all datetimes are in UTC
--- time.
---
--- The parser and printers are implemented in <Database-SQLite-Simple-Time.html Database.SQLite.Simple.Time>.
---
--- Read more about SQLite's time strings in <http://sqlite.org/lang_datefunc.html>
+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, GeneralizedNewtypeDeriving, ScopedTypeVariables, GADTs #-}
+
+------------------------------------------------------------------------------
+-- |
+-- Module: Database.SQLite.Simple
+-- Copyright: (c) 2011 MailRank, Inc.
+-- (c) 2011-2012 Leon P Smith
+-- (c) 2012-2013 Janne Hellsten
+-- License: BSD3
+-- Maintainer: Janne Hellsten <jjhellst@gmail.com>
+-- Portability: portable
+--
+------------------------------------------------------------------------------
+
+module Database.SQLite.Simple (
+ -- ** Examples of use
+ -- $use
+
+ -- ** The Query 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
+
+ -- *** Conversion to/from UTCTime
+ -- $utctime
+
+ Query(..)
+ , Connection(..)
+ , ToRow(..)
+ , FromRow(..)
+ , Only(..)
+ , (:.)(..)
+ , Base.SQLData(..)
+ , Statement(..)
+ , ColumnIndex(..)
+ , NamedParam(..)
+ -- * Connections
+ , open
+ , close
+ , withConnection
+ , setTrace
+ -- * Queries that return results
+ , query
+ , query_
+ , queryWith
+ , queryWith_
+ , queryNamed
+ , lastInsertRowId
+ , changes
+ , totalChanges
+ -- * Queries that stream results
+ , fold
+ , fold_
+ , foldNamed
+ -- * Statements that do not return results
+ , execute
+ , execute_
+ , executeMany
+ , executeNamed
+ , field
+ -- * Transactions
+ , withTransaction
+ , withImmediateTransaction
+ , withExclusiveTransaction
+ -- * Low-level statement API for stream access and prepared statements
+ , openStatement
+ , closeStatement
+ , withStatement
+ , bind
+ , bindNamed
+ , reset
+ , columnName
+ , columnCount
+ , withBind
+ , nextRow
+ -- ** Exceptions
+ , FormatError(..)
+ , ResultError(..)
+ , Base.SQLError(..)
+ , Base.Error(..)
+ ) where
+
+import Control.Applicative
+import Control.Exception
+import Control.Monad (void, when, forM_)
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.State.Strict
+import Data.Int (Int64)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import Data.Typeable (Typeable)
+import Database.SQLite.Simple.Types
+import qualified Database.SQLite3 as Base
+import qualified Database.SQLite3.Direct as BaseD
+
+
+import Database.SQLite.Simple.FromField (ResultError(..))
+import Database.SQLite.Simple.FromRow
+import Database.SQLite.Simple.Internal
+import Database.SQLite.Simple.Ok
+import Database.SQLite.Simple.ToField (ToField(..))
+import Database.SQLite.Simple.ToRow (ToRow(..))
+
+-- | An SQLite prepared statement.
+newtype Statement = Statement { unStatement :: Base.Statement }
+
+-- | Index of a column in a result set. Column indices start from 0.
+newtype ColumnIndex = ColumnIndex BaseD.ColumnIndex
+ deriving (Eq, Ord, Enum, Num, Real, Integral)
+
+data NamedParam where
+ (:=) :: (ToField v) => T.Text -> v -> NamedParam
+
+data TransactionType = Deferred | Immediate | Exclusive
+
+infixr 3 :=
+
+instance Show NamedParam where
+ show (k := v) = show (k, toField v)
+
+-- | Exception thrown if a 'Query' 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
+ , fmtQuery :: Query
+ , fmtParams :: [String]
+ } deriving (Eq, Show, Typeable)
+
+instance Exception FormatError
+
+-- | Open a database connection to a given file. Will throw an
+-- exception if it cannot connect.
+--
+-- Every 'open' must be closed with a call to 'close'.
+--
+-- If you specify \":memory:\" or an empty string as the input filename,
+-- then a private, temporary in-memory database is created for the
+-- connection. This database will vanish when you close the
+-- connection.
+open :: String -> IO Connection
+open fname = Connection <$> Base.open (T.pack fname)
+
+-- | Close a database connection.
+close :: Connection -> IO ()
+close (Connection c) = Base.close c
+
+-- | Opens a database connection, executes an action using this connection, and
+-- closes the connection, even in the presence of exceptions.
+withConnection :: String -> (Connection -> IO a) -> IO a
+withConnection connString = bracket (open connString) close
+
+unUtf8 :: BaseD.Utf8 -> T.Text
+unUtf8 (BaseD.Utf8 bs) = TE.decodeUtf8 bs
+
+-- | <http://www.sqlite.org/c3ref/profile.html>
+--
+-- 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 may crash. Enable only for debugging!
+setTrace :: Connection -> Maybe (T.Text -> IO ()) -> IO ()
+setTrace (Connection db) logger =
+ BaseD.setTrace db (fmap (\lf -> lf . unUtf8) logger)
+
+-- | 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) => Statement -> params -> IO ()
+bind (Statement stmt) params = do
+ let qp = toRow params
+ stmtParamCount <- Base.bindParameterCount stmt
+ when (length qp /= fromIntegral stmtParamCount) (throwColumnMismatch qp stmtParamCount)
+ mapM_ (errorCheckParamName qp) [1..stmtParamCount]
+ Base.bind stmt qp
+ where
+ throwColumnMismatch qp nParams = do
+ templ <- getQuery stmt
+ fmtError ("SQL query contains " ++ show nParams ++ " params, but " ++
+ show (length qp) ++ " arguments given") templ qp
+ errorCheckParamName qp paramNdx = do
+ templ <- getQuery stmt
+ name <- Base.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 :: Statement -> [NamedParam] -> IO ()
+bindNamed (Statement stmt) params = do
+ stmtParamCount <- Base.bindParameterCount stmt
+ when (length params /= fromIntegral stmtParamCount) $ throwColumnMismatch stmtParamCount
+ bind stmt params
+ where
+ bind stmt params =
+ mapM_ (\(n := v) -> do
+ idx <- BaseD.bindParameterIndex stmt (BaseD.Utf8 . TE.encodeUtf8 $ n)
+ case idx of
+ Just i ->
+ Base.bindSQLData stmt i (toField v)
+ Nothing -> do
+ templ <- getQuery stmt
+ fmtError ("Unknown named parameter '" ++ T.unpack n ++ "'")
+ templ params)
+ params
+
+ throwColumnMismatch nParams = do
+ templ <- getQuery 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 :: Statement -> IO ()
+reset (Statement stmt) = Base.reset stmt
+
+-- | Return the name of a a particular column in the result set of a
+-- 'Statement'. Throws an 'ArrayException' if the colum index is out
+-- of bounds.
+--
+-- <http://www.sqlite.org/c3ref/column_name.html>
+columnName :: Statement -> ColumnIndex -> IO T.Text
+columnName (Statement stmt) (ColumnIndex n) = BaseD.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 :: Statement -> IO ColumnIndex
+columnCount (Statement stmt) = ColumnIndex <$> BaseD.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) => Statement -> 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 -> Query -> IO Statement
+openStatement (Connection c) (Query t) = do
+ stmt <- Base.prepare c t
+ return $ Statement stmt
+
+-- | Closes a prepared statement.
+closeStatement :: Statement -> IO ()
+closeStatement (Statement stmt) = Base.finalize stmt
+
+-- | Opens a prepared statement, executes an action using this statement, and
+-- closes the statement, even in the presence of exceptions.
+withStatement :: Connection -> Query -> (Statement -> IO a) -> IO a
+withStatement conn query = bracket (openStatement conn query) closeStatement
+
+-- A version of 'withStatement' which binds parameters.
+withStatementParams :: (ToRow params)
+ => Connection
+ -> Query
+ -> params
+ -> (Statement -> 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
+ -> Query
+ -> [NamedParam]
+ -> (Statement -> 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 -> Query -> q -> IO ()
+execute conn template qs =
+ withStatementParams conn template qs $ \(Statement stmt) ->
+ void . Base.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 -> Query -> [q] -> IO ()
+executeMany conn template paramRows = withStatement conn template $ \stmt -> do
+ let Statement stmt' = stmt
+ forM_ paramRows $ \params ->
+ withBind stmt params
+ (void . Base.step $ stmt')
+
+
+doFoldToList :: RowParser row -> Statement -> IO [row]
+doFoldToList fromRow_ stmt =
+ fmap reverse $ doFold fromRow_ stmt [] (\acc e -> return (e : acc))
+
+-- | 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.
+query :: (ToRow q, FromRow r)
+ => Connection -> Query -> q -> IO [r]
+query = queryWith fromRow
+
+-- | A version of 'query' that does not perform query substitution.
+query_ :: (FromRow r) => Connection -> Query -> IO [r]
+query_ = queryWith_ fromRow
+
+-- | A version of 'query' that takes an explicit 'RowParser'.
+queryWith :: (ToRow q) => RowParser r -> Connection -> Query -> q -> IO [r]
+queryWith fromRow_ conn templ qs =
+ withStatementParams conn templ qs $ \stmt -> doFoldToList fromRow_ stmt
+
+-- | A version of 'query' that does not perform query substitution and
+-- takes an explicit 'RowParser'.
+queryWith_ :: RowParser r -> Connection -> Query -> IO [r]
+queryWith_ fromRow_ conn query =
+ withStatement conn query (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]
+-- @
+queryNamed :: (FromRow r) => Connection -> Query -> [NamedParam] -> IO [r]
+queryNamed conn templ params =
+ withStatementNamedParams conn templ params $ \stmt -> doFoldToList fromRow stmt
+
+-- | A version of 'execute' that does not perform query substitution.
+execute_ :: Connection -> Query -> IO ()
+execute_ conn template =
+ withStatement conn template $ \(Statement stmt) ->
+ void $ Base.step stmt
+
+-- | A version of 'execute' where the query parameters (placeholders)
+-- are named.
+executeNamed :: Connection -> Query -> [NamedParam] -> IO ()
+executeNamed conn template params =
+ withStatementNamedParams conn template params $ \(Statement stmt) ->
+ void $ Base.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
+ -> Query
+ -> params
+ -> a
+ -> (a -> row -> IO a)
+ -> IO a
+fold conn query params initalState action =
+ withStatementParams conn query params $ \stmt ->
+ doFold fromRow stmt initalState action
+
+-- | A version of 'fold' which does not perform parameter substitution.
+fold_ :: ( FromRow row )
+ => Connection
+ -> Query
+ -> a
+ -> (a -> row -> IO a)
+ -> IO a
+fold_ conn query initalState action =
+ withStatement conn query $ \stmt ->
+ doFold fromRow stmt initalState action
+
+-- | A version of 'fold' where the query parameters (placeholders) are
+-- named.
+foldNamed :: ( FromRow row )
+ => Connection
+ -> Query
+ -> [NamedParam]
+ -> a
+ -> (a -> row -> IO a)
+ -> IO a
+foldNamed conn query params initalState action =
+ withStatementNamedParams conn query params $ \stmt ->
+ doFold fromRow stmt initalState action
+
+doFold :: RowParser row -> Statement -> a -> (a -> row -> IO a) -> IO a
+doFold fromRow_ stmt initState action =
+ loop initState
+ 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) => Statement -> IO (Maybe r)
+nextRow = nextRowWith fromRow
+
+nextRowWith :: RowParser r -> Statement -> IO (Maybe r)
+nextRowWith fromRow_ (Statement stmt) = do
+ statRes <- Base.step stmt
+ case statRes of
+ Base.Row -> do
+ rowRes <- Base.columns stmt
+ let nCols = length rowRes
+ row <- convertRow fromRow_ rowRes nCols
+ return $ Just row
+ Base.Done -> return Nothing
+
+convertRow :: RowParser r -> [Base.SQLData] -> Int -> IO r
+convertRow fromRow_ rowRes ncols = do
+ let rw = RowParseRO ncols
+ case runStateT (runReaderT (unRP 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 :: Base.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 = case ttype of
+ Deferred -> execute_ conn "BEGIN TRANSACTION"
+ Immediate -> execute_ conn "BEGIN IMMEDIATE TRANSACTION"
+ Exclusive -> execute_ conn "BEGIN EXCLUSIVE TRANSACTION"
+ commit = execute_ conn "COMMIT TRANSACTION"
+ rollback = execute_ conn "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 <http://www.sqlite.org/c3ref/last_insert_rowid.html>.
+lastInsertRowId :: Connection -> IO Int64
+lastInsertRowId (Connection c) = BaseD.lastInsertRowId c
+
+-- | <http://www.sqlite.org/c3ref/changes.html>
+--
+-- 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 c) = BaseD.changes c
+
+-- | <http://www.sqlite.org/c3ref/total_changes.html>
+--
+-- Return the total number of row changes caused by @INSERT@, @DELETE@,
+-- or @UPDATE@ statements since the 'Database' was opened.
+totalChanges :: Connection -> IO Int
+totalChanges (Connection c) = BaseD.totalChanges c
+
+-- | 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 -> Query -> [v] -> a
+fmtError msg q xs =
+ throw FormatError {
+ fmtMessage = msg
+ , fmtQuery = q
+ , fmtParams = map show xs
+ }
+
+getQuery :: Base.Statement -> IO Query
+getQuery stmt =
+ toQuery <$> BaseD.statementSql stmt
+ where
+ toQuery =
+ Query . maybe "no query string" (\(BaseD.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 Database.SQLite.Simple
+-- >import Database.SQLite.Simple.FromRow
+-- >
+-- >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 'Query' type and a parameter substitution
+-- facility to address both ease of use and security. A 'Query' 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 'Query'.
+--
+-- To most easily construct a query, enable GHC's @OverloadedStrings@
+-- language extension and write your query as a normal literal string.
+--
+-- > {-# LANGUAGE OverloadedStrings #-}
+-- >
+-- > import Database.SQLite.Simple
+-- >
+-- > hello = do
+-- > conn <- open "test.db"
+-- > [[x]] <- query_ conn "select 2 + 2"
+-- > print x
+--
+-- A 'Query' 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 'Query' 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 'Query' 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.
+
+-- $utctime
+--
+-- SQLite's datetime allows for multiple string representations of UTC
+-- time. The following formats are supported for reading SQLite times
+-- into Haskell UTCTime values:
+--
+-- * YYYY-MM-DD HH:MM
+--
+-- * YYYY-MM-DD HH:MM:SS
+--
+-- * YYYY-MM-DD HH:MM:SS.SSS
+--
+-- * YYYY-MM-DDTHH:MM
+--
+-- * YYYY-MM-DDTHH:MM:SS
+--
+-- * YYYY-MM-DDTHH:MM:SS.SSS
+--
+-- The above may also be optionally followed by a timezone indicator
+-- of the form \"[+-]HH:MM\" or just \"Z\".
+--
+-- When Haskell UTCTime values are converted into SQLite values (e.g.,
+-- parameters for a 'query'), the following format is used:
+--
+-- * YYYY-MM-DD HH:MM:SS.SSS
+--
+-- The last \".SSS\" subsecond part is dropped if it's zero. No
+-- timezone indicator is used when converting from a UTCTime value
+-- into an SQLite string. SQLite assumes all datetimes are in UTC
+-- time.
+--
+-- The parser and printers are implemented in <Database-SQLite-Simple-Time.html Database.SQLite.Simple.Time>.
+--
+-- Read more about SQLite's time strings in <http://sqlite.org/lang_datefunc.html>
diff --git a/Database/SQLite/Simple/FromField.hs b/Database/SQLite/Simple/FromField.hs
index 4111317..8821d23 100644
--- a/Database/SQLite/Simple/FromField.hs
+++ b/Database/SQLite/Simple/FromField.hs
@@ -1,215 +1,215 @@
-{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-------------------------------------------------------------------------------
--- |
--- Module: Database.SQLite.Simple.FromField
--- Copyright: (c) 2011 MailRank, Inc.
--- (c) 2011-2012 Leon P Smith
--- (c) 2012-2013 Janne Hellsten
--- License: BSD3
--- Maintainer: Janne Hellsten <jjhellst@gmail.com>
--- Portability: portable
---
--- 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 Database.SQLite.Simple.FromField
- (
- FromField(..)
- , FieldParser
- , ResultError(..)
- , Field
- , fieldData
- , returnError
- ) where
-
-import Control.Applicative (Applicative, (<$>), pure)
-import Control.Exception (SomeException(..), Exception)
-import Data.ByteString (ByteString)
-import qualified Data.ByteString.Char8 as B
-import qualified Data.ByteString.Lazy as LB
-import Data.Int (Int8, Int16, Int32, Int64)
-import Data.Time (UTCTime, Day)
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as LT
-import Data.Typeable (Typeable, typeOf)
-import Data.Word (Word, Word8, Word16, Word32, Word64)
-import GHC.Float (double2Float)
-
-import Database.SQLite3 as Base
-import Database.SQLite.Simple.Types
-import Database.SQLite.Simple.Internal
-import Database.SQLite.Simple.Ok
-import Database.SQLite.Simple.Time
-
--- | Exception thrown if conversion from a SQL value to a Haskell
--- value fails.
-data ResultError = Incompatible { errSQLType :: String
- , errHaskellType :: String
- , errMessage :: String }
- -- ^ The SQL and Haskell types are not compatible.
- | UnexpectedNull { errSQLType :: String
- , errHaskellType :: String
- , errMessage :: String }
- -- ^ A SQL @NULL@ was encountered when the Haskell
- -- type did not permit it.
- | ConversionFailed { 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).
- deriving (Eq, Show, Typeable)
-
-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 (Field (SQLText txt) _) = Ok txt
- fromField f = returnError ConversionFailed f "need a text"
-
-instance FromField LT.Text where
- fromField (Field (SQLText txt) _) = Ok . LT.fromStrict $ txt
- fromField f = returnError ConversionFailed f "need a text"
-
-instance FromField [Char] where
- fromField (Field (SQLText t) _) = Ok $ T.unpack t
- fromField f = returnError ConversionFailed f "expecting SQLText column type"
-
-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 UTCTime where
- fromField f@(Field (SQLText t) _) =
- case parseUTCTime t of
- Right t -> Ok t
- Left e -> returnError ConversionFailed f ("couldn't parse UTCTime field: " ++ e)
-
- fromField f = returnError ConversionFailed f "expecting SQLText column type"
-
-
-instance FromField Day where
- fromField f@(Field (SQLText t) _) =
- case parseDay t of
- Right t -> Ok t
- Left e -> returnError ConversionFailed f ("couldn't parse Day field: " ++ e)
-
- fromField f = returnError ConversionFailed f "expecting SQLText column type"
-
-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)))
+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+------------------------------------------------------------------------------
+-- |
+-- Module: Database.SQLite.Simple.FromField
+-- Copyright: (c) 2011 MailRank, Inc.
+-- (c) 2011-2012 Leon P Smith
+-- (c) 2012-2013 Janne Hellsten
+-- License: BSD3
+-- Maintainer: Janne Hellsten <jjhellst@gmail.com>
+-- Portability: portable
+--
+-- 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 Database.SQLite.Simple.FromField
+ (
+ FromField(..)
+ , FieldParser
+ , ResultError(..)
+ , Field
+ , fieldData
+ , returnError
+ ) where
+
+import Control.Applicative (Applicative, (<$>), pure)
+import Control.Exception (SomeException(..), Exception)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy as LB
+import Data.Int (Int8, Int16, Int32, Int64)
+import Data.Time (UTCTime, Day)
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as LT
+import Data.Typeable (Typeable, typeOf)
+import Data.Word (Word, Word8, Word16, Word32, Word64)
+import GHC.Float (double2Float)
+
+import Database.SQLite3 as Base
+import Database.SQLite.Simple.Types
+import Database.SQLite.Simple.Internal
+import Database.SQLite.Simple.Ok
+import Database.SQLite.Simple.Time
+
+-- | Exception thrown if conversion from a SQL value to a Haskell
+-- value fails.
+data ResultError = Incompatible { errSQLType :: String
+ , errHaskellType :: String
+ , errMessage :: String }
+ -- ^ The SQL and Haskell types are not compatible.
+ | UnexpectedNull { errSQLType :: String
+ , errHaskellType :: String
+ , errMessage :: String }
+ -- ^ A SQL @NULL@ was encountered when the Haskell
+ -- type did not permit it.
+ | ConversionFailed { 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).
+ deriving (Eq, Show, Typeable)
+
+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 (Field (SQLText txt) _) = Ok txt
+ fromField f = returnError ConversionFailed f "need a text"
+
+instance FromField LT.Text where
+ fromField (Field (SQLText txt) _) = Ok . LT.fromStrict $ txt
+ fromField f = returnError ConversionFailed f "need a text"
+
+instance FromField [Char] where
+ fromField (Field (SQLText t) _) = Ok $ T.unpack t
+ fromField f = returnError ConversionFailed f "expecting SQLText column type"
+
+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 UTCTime where
+ fromField f@(Field (SQLText t) _) =
+ case parseUTCTime t of
+ Right t -> Ok t
+ Left e -> returnError ConversionFailed f ("couldn't parse UTCTime field: " ++ e)
+
+ fromField f = returnError ConversionFailed f "expecting SQLText column type"
+
+
+instance FromField Day where
+ fromField f@(Field (SQLText t) _) =
+ case parseDay t of
+ Right t -> Ok t
+ Left e -> returnError ConversionFailed f ("couldn't parse Day field: " ++ e)
+
+ fromField f = returnError ConversionFailed f "expecting SQLText column type"
+
+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/Database/SQLite/Simple/FromRow.hs b/Database/SQLite/Simple/FromRow.hs
index 2ae2f1a..781e8c1 100644
--- a/Database/SQLite/Simple/FromRow.hs
+++ b/Database/SQLite/Simple/FromRow.hs
@@ -1,136 +1,136 @@
-{-# LANGUAGE RecordWildCards #-}
-
-------------------------------------------------------------------------------
--- |
--- Module: Database.SQLite.Simple.FromRow
--- Copyright: (c) 2011-2012 Leon P Smith
--- (c) 2012-2013 Janne Hellsten
--- License: BSD3
--- Maintainer: Janne Hellsten <jjhellst@gmail.com>
--- Portability: portable
---
--- 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 Database.SQLite.Simple.FromRow
- ( FromRow(..)
- , RowParser
- , field
- , fieldWith
- , numFieldsRemaining
- ) where
-
-import Control.Applicative (Applicative(..), (<$>))
-import Control.Exception (SomeException(..))
-import Control.Monad (replicateM)
-import Control.Monad.Trans.State.Strict
-import Control.Monad.Trans.Reader
-import Control.Monad.Trans.Class
-
-import Database.SQLite.Simple.FromField
-import Database.SQLite.Simple.Internal
-import Database.SQLite.Simple.Ok
-import Database.SQLite.Simple.Types
-
--- | 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'.
-
-class FromRow a where
- fromRow :: RowParser a
-
-fieldWith :: FieldParser a -> RowParser a
-fieldWith fieldP = RP $ do
- ncols <- asks nColumns
- (column, remaining) <- lift get
- lift (put (column + 1, tail remaining))
- if column >= ncols
- then
- lift (lift (Errors [SomeException (ColumnOutOfBounds (column+1))]))
- else do
- let r = head remaining
- field = Field r column
- lift (lift (fieldP field))
-
-field :: FromField a => RowParser a
-field = fieldWith fromField
-
-numFieldsRemaining :: RowParser Int
-numFieldsRemaining = RP $ do
- ncols <- asks nColumns
- (columnIdx,_) <- lift get
- return $! ncols - columnIdx
-
-instance (FromField a) => FromRow (Only a) where
- fromRow = Only <$> 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
+{-# LANGUAGE RecordWildCards #-}
+
+------------------------------------------------------------------------------
+-- |
+-- Module: Database.SQLite.Simple.FromRow
+-- Copyright: (c) 2011-2012 Leon P Smith
+-- (c) 2012-2013 Janne Hellsten
+-- License: BSD3
+-- Maintainer: Janne Hellsten <jjhellst@gmail.com>
+-- Portability: portable
+--
+-- 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 Database.SQLite.Simple.FromRow
+ ( FromRow(..)
+ , RowParser
+ , field
+ , fieldWith
+ , numFieldsRemaining
+ ) where
+
+import Control.Applicative (Applicative(..), (<$>))
+import Control.Exception (SomeException(..))
+import Control.Monad (replicateM)
+import Control.Monad.Trans.State.Strict
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.Class
+
+import Database.SQLite.Simple.FromField
+import Database.SQLite.Simple.Internal
+import Database.SQLite.Simple.Ok
+import Database.SQLite.Simple.Types
+
+-- | 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'.
+
+class FromRow a where
+ fromRow :: RowParser a
+
+fieldWith :: FieldParser a -> RowParser a
+fieldWith fieldP = RP $ do
+ ncols <- asks nColumns
+ (column, remaining) <- lift get
+ lift (put (column + 1, tail remaining))
+ if column >= ncols
+ then
+ lift (lift (Errors [SomeException (ColumnOutOfBounds (column+1))]))
+ else do
+ let r = head remaining
+ field = Field r column
+ lift (lift (fieldP field))
+
+field :: FromField a => RowParser a
+field = fieldWith fromField
+
+numFieldsRemaining :: RowParser Int
+numFieldsRemaining = RP $ do
+ ncols <- asks nColumns
+ (columnIdx,_) <- lift get
+ return $! ncols - columnIdx
+
+instance (FromField a) => FromRow (Only a) where
+ fromRow = Only <$> 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/Database/SQLite/Simple/Internal.hs b/Database/SQLite/Simple/Internal.hs
index 0ed1123..75f2d38 100644
--- a/Database/SQLite/Simple/Internal.hs
+++ b/Database/SQLite/Simple/Internal.hs
@@ -1,70 +1,70 @@
-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
-------------------------------------------------------------------------------
--- |
--- Module: Database.SQLite.Simple.Internal
--- Copyright: (c) 2011-2012 Leon P Smith
--- (c) 2012-2013 Janne Hellsten
--- License: BSD3
--- Maintainer: Janne Hellsten <jjhellst@gmail.com>
--- Portability: portable
---
--- 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 Database.SQLite.Simple.Internal where
-
-import Prelude hiding (catch)
-
-import Control.Exception (Exception)
-import Control.Monad
-import Control.Applicative
-import Data.ByteString (ByteString)
-import Data.ByteString.Char8()
-import Data.Typeable (Typeable)
-import Control.Monad.Trans.State.Strict
-import Control.Monad.Trans.Reader
-
-import Database.SQLite.Simple.Ok
-import qualified Database.SQLite3 as Base
-
--- | Connection to an open database.
---
--- You can use 'connectionHandle' to gain access to the underlying
--- <http://hackage.haskell.org/package/direct-sqlite> 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.
-newtype Connection = Connection { connectionHandle :: Base.Database }
-
-data ColumnOutOfBounds = ColumnOutOfBounds { errorColumnIndex :: !Int }
- deriving (Eq, Show, Typeable)
-
-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 RowParseRO = RowParseRO { nColumns :: Int }
-
-newtype RowParser a = RP { unRP :: ReaderT RowParseRO (StateT (Int, [Base.SQLData]) Ok) a }
- deriving ( Functor, Applicative, Alternative, Monad, MonadPlus )
-
-gettypename :: Base.SQLData -> ByteString
-gettypename (Base.SQLInteger _) = "INTEGER"
-gettypename (Base.SQLFloat _) = "FLOAT"
-gettypename (Base.SQLText _) = "TEXT"
-gettypename (Base.SQLBlob _) = "BLOB"
-gettypename Base.SQLNull = "NULL"
-
+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
+------------------------------------------------------------------------------
+-- |
+-- Module: Database.SQLite.Simple.Internal
+-- Copyright: (c) 2011-2012 Leon P Smith
+-- (c) 2012-2013 Janne Hellsten
+-- License: BSD3
+-- Maintainer: Janne Hellsten <jjhellst@gmail.com>
+-- Portability: portable
+--
+-- 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 Database.SQLite.Simple.Internal where
+
+import Prelude hiding (catch)
+
+import Control.Exception (Exception)
+import Control.Monad
+import Control.Applicative
+import Data.ByteString (ByteString)
+import Data.ByteString.Char8()
+import Data.Typeable (Typeable)
+import Control.Monad.Trans.State.Strict
+import Control.Monad.Trans.Reader
+
+import Database.SQLite.Simple.Ok
+import qualified Database.SQLite3 as Base
+
+-- | Connection to an open database.
+--
+-- You can use 'connectionHandle' to gain access to the underlying
+-- <http://hackage.haskell.org/package/direct-sqlite> 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.
+newtype Connection = Connection { connectionHandle :: Base.Database }
+
+data ColumnOutOfBounds = ColumnOutOfBounds { errorColumnIndex :: !Int }
+ deriving (Eq, Show, Typeable)
+
+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 RowParseRO = RowParseRO { nColumns :: Int }
+
+newtype RowParser a = RP { unRP :: ReaderT RowParseRO (StateT (Int, [Base.SQLData]) Ok) a }
+ deriving ( Functor, Applicative, Alternative, Monad, MonadPlus )
+
+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/Database/SQLite/Simple/Ok.hs b/Database/SQLite/Simple/Ok.hs
index b8ae276..a37de6b 100644
--- a/Database/SQLite/Simple/Ok.hs
+++ b/Database/SQLite/Simple/Ok.hs
@@ -1,82 +1,82 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFunctor #-}
-
-------------------------------------------------------------------------------
--- |
--- Module: Database.SQLite.Simple.Ok
--- Copyright: (c) 2012 Leon P Smith
--- (c) 2012-2013 Janne Hellsten
--- License: BSD3
--- Maintainer: Janne Hellsten <jjhellst@gmail.com>
---
--- 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 Database.SQLite.Simple.Ok where
-
-import Control.Applicative
-import Control.Exception
-import Control.Monad(MonadPlus(..))
-import Data.Typeable
-
--- FIXME: [SomeException] should probably be something else, maybe
--- a difference list (or a tree?)
-
-data Ok a = Errors [SomeException] | Ok !a
- deriving(Show, Typeable, 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 = Ok
-
- Errors es >>= _ = Errors es
- Ok a >>= f = f a
-
- fail str = Errors [SomeException (ErrorCall str)]
-
--- | a way to reify a list of exceptions into a single exception
-
-newtype ManyErrors = ManyErrors [SomeException]
- deriving (Show, Typeable)
-
-instance Exception ManyErrors
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
+
+------------------------------------------------------------------------------
+-- |
+-- Module: Database.SQLite.Simple.Ok
+-- Copyright: (c) 2012 Leon P Smith
+-- (c) 2012-2013 Janne Hellsten
+-- License: BSD3
+-- Maintainer: Janne Hellsten <jjhellst@gmail.com>
+--
+-- 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 Database.SQLite.Simple.Ok where
+
+import Control.Applicative
+import Control.Exception
+import Control.Monad(MonadPlus(..))
+import Data.Typeable
+
+-- FIXME: [SomeException] should probably be something else, maybe
+-- a difference list (or a tree?)
+
+data Ok a = Errors [SomeException] | Ok !a
+ deriving(Show, Typeable, 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 = Ok
+
+ Errors es >>= _ = Errors es
+ Ok a >>= f = f a
+
+ fail str = Errors [SomeException (ErrorCall str)]
+
+-- | a way to reify a list of exceptions into a single exception
+
+newtype ManyErrors = ManyErrors [SomeException]
+ deriving (Show, Typeable)
+
+instance Exception ManyErrors
diff --git a/Database/SQLite/Simple/Time.hs b/Database/SQLite/Simple/Time.hs
index 7b6893f..b6f573b 100644
--- a/Database/SQLite/Simple/Time.hs
+++ b/Database/SQLite/Simple/Time.hs
@@ -1,21 +1,21 @@
-------------------------------------------------------------------------------
--- |
--- Module: Database.SQLite.Simple.Time
--- Copyright: (c) 2012 Leon P Smith
--- (c) 2012-2014 Janne Hellsten
--- License: BSD3
--- Maintainer: Janne Hellsten <jjhellst@gmail.com>
---
--- Conversions to/from Haskell 'UTCTime' and 'Day' types for SQLite3.
--- Offers better performance than direct use of time package's
--- 'read'/'show' functionality.
---
--- The parsers are heavily adapted for the specific variant of ISO 8601 that
--- SQLite uses, and the printers attempt to duplicate this syntax.
-------------------------------------------------------------------------------
-
-module Database.SQLite.Simple.Time (
- module Database.SQLite.Simple.Time.Implementation
- ) where
-
-import Database.SQLite.Simple.Time.Implementation
+------------------------------------------------------------------------------
+-- |
+-- Module: Database.SQLite.Simple.Time
+-- Copyright: (c) 2012 Leon P Smith
+-- (c) 2012-2014 Janne Hellsten
+-- License: BSD3
+-- Maintainer: Janne Hellsten <jjhellst@gmail.com>
+--
+-- Conversions to/from Haskell 'UTCTime' and 'Day' types for SQLite3.
+-- Offers better performance than direct use of time package's
+-- 'read'/'show' functionality.
+--
+-- The parsers are heavily adapted for the specific variant of ISO 8601 that
+-- SQLite uses, and the printers attempt to duplicate this syntax.
+------------------------------------------------------------------------------
+
+module Database.SQLite.Simple.Time (
+ module Database.SQLite.Simple.Time.Implementation
+ ) where
+
+import Database.SQLite.Simple.Time.Implementation
diff --git a/Database/SQLite/Simple/Time/Implementation.hs b/Database/SQLite/Simple/Time/Implementation.hs
index 6ec3168..23eced2 100644
--- a/Database/SQLite/Simple/Time/Implementation.hs
+++ b/Database/SQLite/Simple/Time/Implementation.hs
@@ -1,200 +1,200 @@
-------------------------------------------------------------------------------
--- |
--- Module: Database.SQLite.Simple.Time.Implementation
--- Copyright: (c) 2012 Leon P Smith
--- (c) 2012-2014 Janne Hellsten
--- License: BSD3
--- Maintainer: Janne Hellsten <jjhellst@gmail.com>
---
--- Adapted from Leon P Smith's code for SQLite.
---
--- See <http://sqlite.org/lang_datefunc.html> for date formats used in SQLite.
-------------------------------------------------------------------------------
-
-module Database.SQLite.Simple.Time.Implementation (
- parseUTCTime
- , parseDay
- , utcTimeToBuilder
- , dayToBuilder
- , timeOfDayToBuilder
- , timeZoneToBuilder
- ) where
-import Blaze.ByteString.Builder (Builder)
-import Blaze.ByteString.Builder.Char8 (fromChar)
-import Blaze.Text.Int (integral)
-import Control.Applicative
-import Control.Monad (when)
-import qualified Data.Attoparsec.Text as A
-import Data.Bits ((.&.))
-import Data.ByteString.Internal (w2c)
-import Data.Char (isDigit, ord)
-import Data.Fixed (Pico)
-import Data.Monoid (Monoid(..))
-import qualified Data.Text as T
-import Data.Time hiding (getTimeZone, getZonedTime)
-import Prelude hiding (take, (++))
-import Unsafe.Coerce
-
-(++) :: Monoid a => a -> a -> a
-(++) = mappend
-infixr 5 ++
-
-parseUTCTime :: T.Text -> Either String UTCTime
-parseUTCTime = A.parseOnly (getUTCTime <* A.endOfInput)
-
-parseDay :: T.Text -> Either String Day
-parseDay = A.parseOnly (getDay <* A.endOfInput)
-
-getDay :: A.Parser Day
-getDay = do
- yearStr <- A.takeWhile isDigit
- when (T.length yearStr < 4) (fail "year must consist of at least 4 digits")
-
- let !year = toNum yearStr
- _ <- A.char '-'
- month <- digits "month"
- _ <- A.char '-'
- day <- digits "day"
-
- case fromGregorianValid year month day of
- Nothing -> fail "invalid date"
- Just x -> return $! x
-
-decimal :: Fractional a => T.Text -> a
-decimal str = toNum str / 10^(T.length str)
-{-# INLINE decimal #-}
-
-getTimeOfDay :: A.Parser TimeOfDay
-getTimeOfDay = do
- hour <- digits "hours"
- _ <- A.char ':'
- minute <- digits "minutes"
- -- Allow omission of seconds. If seconds is omitted, don't try to
- -- parse the sub-second part.
- (sec,subsec)
- <- ((,) <$> (A.char ':' *> digits "seconds") <*> fract) <|> pure (0,0)
-
- let !picos' = sec + subsec
-
- case makeTimeOfDayValid hour minute picos' of
- Nothing -> fail "invalid time of day"
- Just x -> return $! x
-
- where
- fract =
- (A.char '.' *> (decimal <$> A.takeWhile1 isDigit)) <|> pure 0
-
-getTimeZone :: A.Parser TimeZone
-getTimeZone = do
- sign <- A.satisfy (\c -> c == '+' || c == '-')
- hours <- digits "timezone"
- mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0
- let !absset = 60 * hours + mins
- !offset = if sign == '+' then absset else -absset
- return $! minutesToTimeZone offset
-
-getUTCTime :: A.Parser UTCTime
-getUTCTime = do
- day <- getDay
- _ <- A.char ' ' <|> A.char 'T'
- time <- getTimeOfDay
- -- SQLite doesn't require a timezone postfix. So make that
- -- optional and default to +0. 'Z' means UTC (zulu time).
- zone <- getTimeZone <|> (A.char 'Z' *> pure utc) <|> (pure utc)
- let (!dayDelta,!time') = localToUTCTimeOfDay zone time
- let !day' = addDays dayDelta day
- let !time'' = timeOfDayToTime time'
- return (UTCTime day' time'')
-
-toNum :: Num n => T.Text -> n
-toNum = T.foldl' (\a c -> 10*a + digit c) 0
-{-# INLINE toNum #-}
-
-digit :: Num n => Char -> n
-digit c = fromIntegral (ord c .&. 0x0f)
-{-# INLINE digit #-}
-
-digits :: Num n => String -> A.Parser n
-digits msg = do
- x <- A.anyChar
- y <- A.anyChar
- if isDigit x && isDigit y
- then return $! (10 * digit x + digit y)
- else fail (msg ++ " is not 2 digits")
-{-# INLINE digits #-}
-
-dayToBuilder :: Day -> Builder
-dayToBuilder (toGregorian -> (y,m,d)) = do
- pad4 y ++ fromChar '-' ++ pad2 m ++ fromChar '-' ++ pad2 d
-
-timeOfDayToBuilder :: TimeOfDay -> Builder
-timeOfDayToBuilder (TimeOfDay h m s) = do
- pad2 h ++ fromChar ':' ++ pad2 m ++ fromChar ':' ++ showSeconds s
-
-timeZoneToBuilder :: TimeZone -> Builder
-timeZoneToBuilder tz
- | m == 0 = sign h ++ pad2 (abs h)
- | otherwise = sign h ++ pad2 (abs h) ++ fromChar ':' ++ pad2 (abs m)
- where
- (h,m) = timeZoneMinutes tz `quotRem` 60
- sign h | h >= 0 = fromChar '+'
- | otherwise = fromChar '-'
-
--- | Output YYYY-MM-DD HH:MM:SS with an optional .SSS fraction part.
--- Explicit timezone attribute is not appended as per SQLite3's
--- datetime conventions.
-utcTimeToBuilder :: UTCTime -> Builder
-utcTimeToBuilder (UTCTime day time) =
- dayToBuilder day ++ fromChar ' ' ++ timeOfDayToBuilder (timeToTimeOfDay time)
-
-showSeconds :: Pico -> Builder
-showSeconds xyz
- | yz == 0 = pad2 x
- | z == 0 = pad2 x ++ fromChar '.' ++ showD6 y
- | otherwise = pad2 x ++ fromChar '.' ++ pad6 y ++ showD6 z
- where
- -- A kludge to work around the fact that Data.Fixed isn't very fast and
- -- doesn't give me access to the MkFixed constructor.
- (x_,yz) = (unsafeCoerce xyz :: Integer) `quotRem` 1000000000000
- x = fromIntegral x_ :: Int
- (fromIntegral -> y, fromIntegral -> z) = yz `quotRem` 1000000
-
-pad6 :: Int -> Builder
-pad6 xy = let (x,y) = xy `quotRem` 1000
- in pad3 x ++ pad3 y
-
-showD6 :: Int -> Builder
-showD6 xy = case xy `quotRem` 1000 of
- (x,0) -> showD3 x
- (x,y) -> pad3 x ++ showD3 y
-
-pad3 :: Int -> Builder
-pad3 abc = let (ab,c) = abc `quotRem` 10
- (a,b) = ab `quotRem` 10
- in p a ++ p b ++ p c
-
-showD3 :: Int -> Builder
-showD3 abc = case abc `quotRem` 100 of
- (a, 0) -> p a
- (a,bc) -> case bc `quotRem` 10 of
- (b,0) -> p a ++ p b
- (b,c) -> p a ++ p b ++ p c
-
--- | p assumes its input is in the range [0..9]
-p :: Integral n => n -> Builder
-p n = fromChar (w2c (fromIntegral (n + 48)))
-{-# INLINE p #-}
-
--- | pad2 assumes its input is in the range [0..99]
-pad2 :: Integral n => n -> Builder
-pad2 n = let (a,b) = n `quotRem` 10 in p a ++ p b
-{-# INLINE pad2 #-}
-
--- | pad4 assumes its input is positive
-pad4 :: (Integral n, Show n) => n -> Builder
-pad4 abcd | abcd >= 10000 = integral abcd
- | otherwise = p a ++ p b ++ p c ++ p d
- where (ab,cd) = abcd `quotRem` 100
- (a,b) = ab `quotRem` 10
- (c,d) = cd `quotRem` 10
-{-# INLINE pad4 #-}
+------------------------------------------------------------------------------
+-- |
+-- Module: Database.SQLite.Simple.Time.Implementation
+-- Copyright: (c) 2012 Leon P Smith
+-- (c) 2012-2014 Janne Hellsten
+-- License: BSD3
+-- Maintainer: Janne Hellsten <jjhellst@gmail.com>
+--
+-- Adapted from Leon P Smith's code for SQLite.
+--
+-- See <http://sqlite.org/lang_datefunc.html> for date formats used in SQLite.
+------------------------------------------------------------------------------
+
+module Database.SQLite.Simple.Time.Implementation (
+ parseUTCTime
+ , parseDay
+ , utcTimeToBuilder
+ , dayToBuilder
+ , timeOfDayToBuilder
+ , timeZoneToBuilder
+ ) where
+import Blaze.ByteString.Builder (Builder)
+import Blaze.ByteString.Builder.Char8 (fromChar)
+import Blaze.Text.Int (integral)
+import Control.Applicative
+import Control.Monad (when)
+import qualified Data.Attoparsec.Text as A
+import Data.Bits ((.&.))
+import Data.ByteString.Internal (w2c)
+import Data.Char (isDigit, ord)
+import Data.Fixed (Pico)
+import Data.Monoid (Monoid(..))
+import qualified Data.Text as T
+import Data.Time hiding (getTimeZone, getZonedTime)
+import Prelude hiding (take, (++))
+import Unsafe.Coerce
+
+(++) :: Monoid a => a -> a -> a
+(++) = mappend
+infixr 5 ++
+
+parseUTCTime :: T.Text -> Either String UTCTime
+parseUTCTime = A.parseOnly (getUTCTime <* A.endOfInput)
+
+parseDay :: T.Text -> Either String Day
+parseDay = A.parseOnly (getDay <* A.endOfInput)
+
+getDay :: A.Parser Day
+getDay = do
+ yearStr <- A.takeWhile isDigit
+ when (T.length yearStr < 4) (fail "year must consist of at least 4 digits")
+
+ let !year = toNum yearStr
+ _ <- A.char '-'
+ month <- digits "month"
+ _ <- A.char '-'
+ day <- digits "day"
+
+ case fromGregorianValid year month day of
+ Nothing -> fail "invalid date"
+ Just x -> return $! x
+
+decimal :: Fractional a => T.Text -> a
+decimal str = toNum str / 10^(T.length str)
+{-# INLINE decimal #-}
+
+getTimeOfDay :: A.Parser TimeOfDay
+getTimeOfDay = do
+ hour <- digits "hours"
+ _ <- A.char ':'
+ minute <- digits "minutes"
+ -- Allow omission of seconds. If seconds is omitted, don't try to
+ -- parse the sub-second part.
+ (sec,subsec)
+ <- ((,) <$> (A.char ':' *> digits "seconds") <*> fract) <|> pure (0,0)
+
+ let !picos' = sec + subsec
+
+ case makeTimeOfDayValid hour minute picos' of
+ Nothing -> fail "invalid time of day"
+ Just x -> return $! x
+
+ where
+ fract =
+ (A.char '.' *> (decimal <$> A.takeWhile1 isDigit)) <|> pure 0
+
+getTimeZone :: A.Parser TimeZone
+getTimeZone = do
+ sign <- A.satisfy (\c -> c == '+' || c == '-')
+ hours <- digits "timezone"
+ mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0
+ let !absset = 60 * hours + mins
+ !offset = if sign == '+' then absset else -absset
+ return $! minutesToTimeZone offset
+
+getUTCTime :: A.Parser UTCTime
+getUTCTime = do
+ day <- getDay
+ _ <- A.char ' ' <|> A.char 'T'
+ time <- getTimeOfDay
+ -- SQLite doesn't require a timezone postfix. So make that
+ -- optional and default to +0. 'Z' means UTC (zulu time).
+ zone <- getTimeZone <|> (A.char 'Z' *> pure utc) <|> (pure utc)
+ let (!dayDelta,!time') = localToUTCTimeOfDay zone time
+ let !day' = addDays dayDelta day
+ let !time'' = timeOfDayToTime time'
+ return (UTCTime day' time'')
+
+toNum :: Num n => T.Text -> n
+toNum = T.foldl' (\a c -> 10*a + digit c) 0
+{-# INLINE toNum #-}
+
+digit :: Num n => Char -> n
+digit c = fromIntegral (ord c .&. 0x0f)
+{-# INLINE digit #-}
+
+digits :: Num n => String -> A.Parser n
+digits msg = do
+ x <- A.anyChar
+ y <- A.anyChar
+ if isDigit x && isDigit y
+ then return $! (10 * digit x + digit y)
+ else fail (msg ++ " is not 2 digits")
+{-# INLINE digits #-}
+
+dayToBuilder :: Day -> Builder
+dayToBuilder (toGregorian -> (y,m,d)) = do
+ pad4 y ++ fromChar '-' ++ pad2 m ++ fromChar '-' ++ pad2 d
+
+timeOfDayToBuilder :: TimeOfDay -> Builder
+timeOfDayToBuilder (TimeOfDay h m s) = do
+ pad2 h ++ fromChar ':' ++ pad2 m ++ fromChar ':' ++ showSeconds s
+
+timeZoneToBuilder :: TimeZone -> Builder
+timeZoneToBuilder tz
+ | m == 0 = sign h ++ pad2 (abs h)
+ | otherwise = sign h ++ pad2 (abs h) ++ fromChar ':' ++ pad2 (abs m)
+ where
+ (h,m) = timeZoneMinutes tz `quotRem` 60
+ sign h | h >= 0 = fromChar '+'
+ | otherwise = fromChar '-'
+
+-- | Output YYYY-MM-DD HH:MM:SS with an optional .SSS fraction part.
+-- Explicit timezone attribute is not appended as per SQLite3's
+-- datetime conventions.
+utcTimeToBuilder :: UTCTime -> Builder
+utcTimeToBuilder (UTCTime day time) =
+ dayToBuilder day ++ fromChar ' ' ++ timeOfDayToBuilder (timeToTimeOfDay time)
+
+showSeconds :: Pico -> Builder
+showSeconds xyz
+ | yz == 0 = pad2 x
+ | z == 0 = pad2 x ++ fromChar '.' ++ showD6 y
+ | otherwise = pad2 x ++ fromChar '.' ++ pad6 y ++ showD6 z
+ where
+ -- A kludge to work around the fact that Data.Fixed isn't very fast and
+ -- doesn't give me access to the MkFixed constructor.
+ (x_,yz) = (unsafeCoerce xyz :: Integer) `quotRem` 1000000000000
+ x = fromIntegral x_ :: Int
+ (fromIntegral -> y, fromIntegral -> z) = yz `quotRem` 1000000
+
+pad6 :: Int -> Builder
+pad6 xy = let (x,y) = xy `quotRem` 1000
+ in pad3 x ++ pad3 y
+
+showD6 :: Int -> Builder
+showD6 xy = case xy `quotRem` 1000 of
+ (x,0) -> showD3 x
+ (x,y) -> pad3 x ++ showD3 y
+
+pad3 :: Int -> Builder
+pad3 abc = let (ab,c) = abc `quotRem` 10
+ (a,b) = ab `quotRem` 10
+ in p a ++ p b ++ p c
+
+showD3 :: Int -> Builder
+showD3 abc = case abc `quotRem` 100 of
+ (a, 0) -> p a
+ (a,bc) -> case bc `quotRem` 10 of
+ (b,0) -> p a ++ p b
+ (b,c) -> p a ++ p b ++ p c
+
+-- | p assumes its input is in the range [0..9]
+p :: Integral n => n -> Builder
+p n = fromChar (w2c (fromIntegral (n + 48)))
+{-# INLINE p #-}
+
+-- | pad2 assumes its input is in the range [0..99]
+pad2 :: Integral n => n -> Builder
+pad2 n = let (a,b) = n `quotRem` 10 in p a ++ p b
+{-# INLINE pad2 #-}
+
+-- | pad4 assumes its input is positive
+pad4 :: (Integral n, Show n) => n -> Builder
+pad4 abcd | abcd >= 10000 = integral abcd
+ | otherwise = p a ++ p b ++ p c ++ p d
+ where (ab,cd) = abcd `quotRem` 100
+ (a,b) = ab `quotRem` 10
+ (c,d) = cd `quotRem` 10
+{-# INLINE pad4 #-}
diff --git a/Database/SQLite/Simple/ToField.hs b/Database/SQLite/Simple/ToField.hs
index 110c64c..194f383 100644
--- a/Database/SQLite/Simple/ToField.hs
+++ b/Database/SQLite/Simple/ToField.hs
@@ -1,170 +1,170 @@
-{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}
-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
-
-------------------------------------------------------------------------------
--- |
--- Module: Database.SQLite.Simple.ToField
--- Copyright: (c) 2011 MailRank, Inc.
--- (c) 2011-2012 Leon P Smith
--- (c) 2012-2013 Janne Hellsten
--- License: BSD3
--- Maintainer: Janne Hellsten <jjhellst@gmail.com>
--- Portability: portable
---
--- The 'ToField' typeclass, for rendering a parameter to an SQLite
--- value to be bound as a SQL query parameter.
---
-------------------------------------------------------------------------------
-
-module Database.SQLite.Simple.ToField (ToField(..)) where
-
-import Blaze.ByteString.Builder (toByteString)
-import qualified Data.ByteString as SB
-import qualified Data.ByteString.Lazy as LB
-import Data.Int (Int8, Int16, Int32, Int64)
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as LT
-import qualified Data.Text.Encoding as T
-import Data.Time (Day, UTCTime)
-import Data.Word (Word, Word8, Word16, Word32, Word64)
-import GHC.Float
-
-import Database.SQLite3 as Base
-import Database.SQLite.Simple.Types (Null)
-import Database.SQLite.Simple.Time
-
--- | 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 #-}
+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
+
+------------------------------------------------------------------------------
+-- |
+-- Module: Database.SQLite.Simple.ToField
+-- Copyright: (c) 2011 MailRank, Inc.
+-- (c) 2011-2012 Leon P Smith
+-- (c) 2012-2013 Janne Hellsten
+-- License: BSD3
+-- Maintainer: Janne Hellsten <jjhellst@gmail.com>
+-- Portability: portable
+--
+-- The 'ToField' typeclass, for rendering a parameter to an SQLite
+-- value to be bound as a SQL query parameter.
+--
+------------------------------------------------------------------------------
+
+module Database.SQLite.Simple.ToField (ToField(..)) where
+
+import Blaze.ByteString.Builder (toByteString)
+import qualified Data.ByteString as SB
+import qualified Data.ByteString.Lazy as LB
+import Data.Int (Int8, Int16, Int32, Int64)
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Encoding as T
+import Data.Time (Day, UTCTime)
+import Data.Word (Word, Word8, Word16, Word32, Word64)
+import GHC.Float
+
+import Database.SQLite3 as Base
+import Database.SQLite.Simple.Types (Null)
+import Database.SQLite.Simple.Time
+
+-- | 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/Database/SQLite/Simple/ToRow.hs b/Database/SQLite/Simple/ToRow.hs
index 1a9bba8..60e07f3 100644
--- a/Database/SQLite/Simple/ToRow.hs
+++ b/Database/SQLite/Simple/ToRow.hs
@@ -1,92 +1,92 @@
-------------------------------------------------------------------------------
--- |
--- Module: Database.SQLite.Simple.ToRow
--- Copyright: (c) 2011 MailRank, Inc.
--- (c) 2011-2012 Leon P Smith
--- (c) 2012-2013 Janne Hellsten
--- License: BSD3
--- Maintainer: Janne Hellsten <jjhellst@gmail.com>
--- Portability: portable
---
--- 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 Database.SQLite.Simple.ToRow
- (
- ToRow(..)
- ) where
-
-import Database.SQLite.Simple.ToField (ToField(..))
-import Database.SQLite.Simple.Types (Only(..), (:.)(..))
-
-import Database.SQLite3 (SQLData(..))
-
--- | A collection type that can be turned into a list of 'SQLData'
--- elements.
-class ToRow a where
- toRow :: a -> [SQLData]
- -- ^ 'ToField' a collection of values.
-
-instance ToRow () where
- toRow _ = []
-
-instance (ToField a) => ToRow (Only a) where
- toRow (Only v) = [toField v]
-
-instance (ToField a, ToField b) => ToRow (a,b) where
- toRow (a,b) = [toField a, toField b]
-
-instance (ToField a, ToField b, ToField c) => ToRow (a,b,c) where
- toRow (a,b,c) = [toField a, toField b, toField c]
-
-instance (ToField a, ToField b, ToField c, ToField d) => ToRow (a,b,c,d) where
- toRow (a,b,c,d) = [toField a, toField b, toField c, toField d]
-
-instance (ToField a, ToField b, ToField c, ToField d, ToField e)
- => ToRow (a,b,c,d,e) where
- toRow (a,b,c,d,e) =
- [toField a, toField b, toField c, toField d, toField e]
-
-instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f)
- => ToRow (a,b,c,d,e,f) where
- toRow (a,b,c,d,e,f) =
- [toField a, toField b, toField c, toField d, toField e, toField f]
-
-instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
- ToField g)
- => ToRow (a,b,c,d,e,f,g) where
- toRow (a,b,c,d,e,f,g) =
- [toField a, toField b, toField c, toField d, toField e, toField f,
- toField 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
+------------------------------------------------------------------------------
+-- |
+-- Module: Database.SQLite.Simple.ToRow
+-- Copyright: (c) 2011 MailRank, Inc.
+-- (c) 2011-2012 Leon P Smith
+-- (c) 2012-2013 Janne Hellsten
+-- License: BSD3
+-- Maintainer: Janne Hellsten <jjhellst@gmail.com>
+-- Portability: portable
+--
+-- 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 Database.SQLite.Simple.ToRow
+ (
+ ToRow(..)
+ ) where
+
+import Database.SQLite.Simple.ToField (ToField(..))
+import Database.SQLite.Simple.Types (Only(..), (:.)(..))
+
+import Database.SQLite3 (SQLData(..))
+
+-- | A collection type that can be turned into a list of 'SQLData'
+-- elements.
+class ToRow a where
+ toRow :: a -> [SQLData]
+ -- ^ 'ToField' a collection of values.
+
+instance ToRow () where
+ toRow _ = []
+
+instance (ToField a) => ToRow (Only a) where
+ toRow (Only v) = [toField v]
+
+instance (ToField a, ToField b) => ToRow (a,b) where
+ toRow (a,b) = [toField a, toField b]
+
+instance (ToField a, ToField b, ToField c) => ToRow (a,b,c) where
+ toRow (a,b,c) = [toField a, toField b, toField c]
+
+instance (ToField a, ToField b, ToField c, ToField d) => ToRow (a,b,c,d) where
+ toRow (a,b,c,d) = [toField a, toField b, toField c, toField d]
+
+instance (ToField a, ToField b, ToField c, ToField d, ToField e)
+ => ToRow (a,b,c,d,e) where
+ toRow (a,b,c,d,e) =
+ [toField a, toField b, toField c, toField d, toField e]
+
+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f)
+ => ToRow (a,b,c,d,e,f) where
+ toRow (a,b,c,d,e,f) =
+ [toField a, toField b, toField c, toField d, toField e, toField f]
+
+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
+ ToField g)
+ => ToRow (a,b,c,d,e,f,g) where
+ toRow (a,b,c,d,e,f,g) =
+ [toField a, toField b, toField c, toField d, toField e, toField f,
+ toField 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/Database/SQLite/Simple/Types.hs b/Database/SQLite/Simple/Types.hs
index 0f08b2c..70ce786 100644
--- a/Database/SQLite/Simple/Types.hs
+++ b/Database/SQLite/Simple/Types.hs
@@ -1,95 +1,100 @@
-{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}
-
-------------------------------------------------------------------------------
--- |
--- Module: Database.SQLite.Simple.Types
--- Copyright: (c) 2011 MailRank, Inc.
--- (c) 2011-2012 Leon P Smith
--- (c) 2012-2013 Janne Hellsten
--- License: BSD3
--- Maintainer: Janne Hellsten <jjhellst@gmail.com>
--- Portability: portable
---
--- Top-level module for sqlite-simple.
---
---
-------------------------------------------------------------------------------
-
-module Database.SQLite.Simple.Types
- (
- Null(..)
- , Only(..)
- , Query(..)
- , (:.)(..)
- ) where
-
-import Control.Arrow (first)
-import Data.Monoid (Monoid(..))
-import Data.String (IsString(..))
-import Data.Tuple.Only (Only(..))
-import Data.Typeable (Typeable)
-import qualified Data.Text as T
-
--- | A placeholder for the SQL @NULL@ value.
-data Null = Null
- deriving (Read, Show, Typeable)
-
-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 Query = Query {
- fromQuery :: T.Text
- } deriving (Eq, Ord, Typeable)
-
-instance Show Query where
- show = show . fromQuery
-
-instance Read Query where
- readsPrec i = fmap (first Query) . readsPrec i
-
-instance IsString Query where
- fromString = Query . T.pack
-
-instance Monoid Query where
- mempty = Query T.empty
- mappend (Query a) (Query b) = Query (T.append a b)
- {-# 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,Typeable)
-
-infixr 3 :.
+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}
+
+------------------------------------------------------------------------------
+-- |
+-- Module: Database.SQLite.Simple.Types
+-- Copyright: (c) 2011 MailRank, Inc.
+-- (c) 2011-2012 Leon P Smith
+-- (c) 2012-2013 Janne Hellsten
+-- License: BSD3
+-- Maintainer: Janne Hellsten <jjhellst@gmail.com>
+-- Portability: portable
+--
+-- Top-level module for sqlite-simple.
+--
+--
+------------------------------------------------------------------------------
+
+module Database.SQLite.Simple.Types
+ (
+ Null(..)
+ , Only(..)
+ , Query(..)
+ , (:.)(..)
+ ) where
+
+import Control.Arrow (first)
+import Data.Monoid (Monoid(..))
+import Data.Semigroup (Semigroup(..))
+import Data.String (IsString(..))
+import Data.Tuple.Only (Only(..))
+import Data.Typeable (Typeable)
+import qualified Data.Text as T
+
+-- | A placeholder for the SQL @NULL@ value.
+data Null = Null
+ deriving (Read, Show, Typeable)
+
+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 Query = Query {
+ fromQuery :: T.Text
+ } deriving (Eq, Ord, Typeable)
+
+instance Show Query where
+ show = show . fromQuery
+
+instance Read Query where
+ readsPrec i = fmap (first Query) . readsPrec i
+
+instance IsString Query where
+ fromString = Query . T.pack
+
+instance Semigroup Query where
+ Query a <> Query b = Query (T.append a b)
+ {-# INLINE (<>) #-}
+
+instance Monoid Query where
+ mempty = Query 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,Typeable)
+
+infixr 3 :.
diff --git a/README.markdown b/README.markdown
index 7f1f680..4437ede 100644
--- a/README.markdown
+++ b/README.markdown
@@ -1,114 +1,114 @@
-sqlite-simple: mid-level bindings to the sqlite database
-========================================================
-
-This library is a mid-level Haskell binding to the SQLite database.
-
-Sqlite-simple provides a convenient API to sqlite that does some level
-of automatic data conversion between the database and Haskell types.
-The API has been modeled directly after
-[postgresql-simple](http://github.com/lpsmith/postgresql-simple) which
-in turn borrows from
-[mysql-simple](https://github.com/bos/mysql-simple).
-
-[The sqlite-simple API
-reference](https://hackage.haskell.org/package/sqlite-simple/docs/Database-SQLite-Simple.html)
-contains more examples of use and information on its features.
-
-The library is well tested and stable. The library should also be
-reasonably performant. You can find its benchmark suite here:
-[db-bench](https://github.com/nurpax/db-bench). You can read more
-about sqlite-simple's expected performance in [my blog about
-sqlite-simple performance against direct-sqlite, Python and
-C](http://nurpax.github.io/posts/2013-08-17-sqlite-simple-benchmarking.html).
-
-[![Build Status](https://secure.travis-ci.org/nurpax/sqlite-simple.png)](http://travis-ci.org/nurpax/sqlite-simple)
-
-Installation
-------------
-
-You can install [sqlite-simple from Hackage](http://hackage.haskell.org/package/sqlite-simple)
-with:
-
-```
-cabal install sqlite-simple
-```
-
-A Windows user? It works but please see [this note](https://gist.github.com/3907344) on direct-sqlite Windows installation.
-
-Examples of use
----------------
-
-Create a test database by copy&pasting the below snippet to your
-shell:
-
-```
-sqlite3 test.db "CREATE TABLE test (id INTEGER PRIMARY KEY, str text);\
-INSERT INTO test (str) VALUES ('test string');"
-```
-
-..and access it in Haskell:
-
-```haskell
-{-# LANGUAGE OverloadedStrings #-}
-import Control.Applicative
-import Database.SQLite.Simple
-import Database.SQLite.Simple.FromRow
-
-data TestField = TestField Int String deriving (Show)
-
-instance FromRow TestField where
- fromRow = TestField <$> field <*> field
-
-main :: IO ()
-main = do
- conn <- open "test.db"
- execute conn "INSERT INTO test (str) VALUES (?)"
- (Only ("test string 2" :: String))
- r <- query_ conn "SELECT * from test" :: IO [TestField]
- mapM_ print r
- close conn
-```
-
-More simple usage examples can be found from [sqlite-simple unit
-tests](https://github.com/nurpax/sqlite-simple/blob/master/test/Simple.hs).
-
-
-Development
------------
-
-The development roadmap for sqlite-simple is mostly captured in the
-github issue database.
-
-I'm happy to receive bug reports, fixes, documentation enhancements,
-and other improvements.
-
-Please report bugs via the
-[github issue tracker](http://github.com/nurpax/sqlite-simple/issues).
-
-For general database issues with a Haskell focus, I recommend sending
-e-mail to the [database-devel mailing
-list](http://www.haskell.org/mailman/listinfo/database-devel).
-
-### Contributing
-
-If you send pull requests for new features, it'd be great if you could also develop unit
-tests for any such features.
-
-
-Credits
--------
-
-A lot of the code is directly borrowed from
-[mysql-simple](http://github.com/bos/mysql-simple) by Bryan O'Sullivan
-and from
-[postgresql-simple](http://github.com/lpsmith/postgresql-simple) by
-Leon P. Smith. Like Leon in postgresql-simple, I borrow code and
-documentation directly from both of these ancestor libraries.
-
-This package builds on top of the
-[direct-sqlite](http://hackage.haskell.org/package/direct-sqlite)
-package by Irene Knapp.
-
-SQLite is rather weakly-typed and thus the SQL to Haskell type
-strictness of the parent projects does not necessarily apply to this
-package.
+sqlite-simple: mid-level bindings to the sqlite database
+========================================================
+
+This library is a mid-level Haskell binding to the SQLite database.
+
+Sqlite-simple provides a convenient API to sqlite that does some level
+of automatic data conversion between the database and Haskell types.
+The API has been modeled directly after
+[postgresql-simple](http://github.com/lpsmith/postgresql-simple) which
+in turn borrows from
+[mysql-simple](https://github.com/bos/mysql-simple).
+
+[The sqlite-simple API
+reference](https://hackage.haskell.org/package/sqlite-simple/docs/Database-SQLite-Simple.html)
+contains more examples of use and information on its features.
+
+The library is well tested and stable. The library should also be
+reasonably performant. You can find its benchmark suite here:
+[db-bench](https://github.com/nurpax/db-bench). You can read more
+about sqlite-simple's expected performance in [my blog about
+sqlite-simple performance against direct-sqlite, Python and
+C](http://nurpax.github.io/posts/2013-08-17-sqlite-simple-benchmarking.html).
+
+[![Build Status](https://secure.travis-ci.org/nurpax/sqlite-simple.png)](http://travis-ci.org/nurpax/sqlite-simple)
+
+Installation
+------------
+
+You can install [sqlite-simple from Hackage](http://hackage.haskell.org/package/sqlite-simple)
+with:
+
+```
+cabal install sqlite-simple
+```
+
+A Windows user? It works but please see [this note](https://gist.github.com/3907344) on direct-sqlite Windows installation.
+
+Examples of use
+---------------
+
+Create a test database by copy&pasting the below snippet to your
+shell:
+
+```
+sqlite3 test.db "CREATE TABLE test (id INTEGER PRIMARY KEY, str text);\
+INSERT INTO test (str) VALUES ('test string');"
+```
+
+..and access it in Haskell:
+
+```haskell
+{-# LANGUAGE OverloadedStrings #-}
+import Control.Applicative
+import Database.SQLite.Simple
+import Database.SQLite.Simple.FromRow
+
+data TestField = TestField Int String deriving (Show)
+
+instance FromRow TestField where
+ fromRow = TestField <$> field <*> field
+
+main :: IO ()
+main = do
+ conn <- open "test.db"
+ execute conn "INSERT INTO test (str) VALUES (?)"
+ (Only ("test string 2" :: String))
+ r <- query_ conn "SELECT * from test" :: IO [TestField]
+ mapM_ print r
+ close conn
+```
+
+More simple usage examples can be found from [sqlite-simple unit
+tests](https://github.com/nurpax/sqlite-simple/blob/master/test/Simple.hs).
+
+
+Development
+-----------
+
+The development roadmap for sqlite-simple is mostly captured in the
+github issue database.
+
+I'm happy to receive bug reports, fixes, documentation enhancements,
+and other improvements.
+
+Please report bugs via the
+[github issue tracker](http://github.com/nurpax/sqlite-simple/issues).
+
+For general database issues with a Haskell focus, I recommend sending
+e-mail to the [database-devel mailing
+list](http://www.haskell.org/mailman/listinfo/database-devel).
+
+### Contributing
+
+If you send pull requests for new features, it'd be great if you could also develop unit
+tests for any such features.
+
+
+Credits
+-------
+
+A lot of the code is directly borrowed from
+[mysql-simple](http://github.com/bos/mysql-simple) by Bryan O'Sullivan
+and from
+[postgresql-simple](http://github.com/lpsmith/postgresql-simple) by
+Leon P. Smith. Like Leon in postgresql-simple, I borrow code and
+documentation directly from both of these ancestor libraries.
+
+This package builds on top of the
+[direct-sqlite](http://hackage.haskell.org/package/direct-sqlite)
+package by Irene Knapp.
+
+SQLite is rather weakly-typed and thus the SQL to Haskell type
+strictness of the parent projects does not necessarily apply to this
+package.
diff --git a/Setup.hs b/Setup.hs
index e8645af..14a7f90 100644
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,5 +1,5 @@
-#!/usr/bin/env runhaskell
-
-import Distribution.Simple
-
-main = defaultMain
+#!/usr/bin/env runhaskell
+
+import Distribution.Simple
+
+main = defaultMain
diff --git a/changelog b/changelog
index 74a2a75..60bd901 100644
--- a/changelog
+++ b/changelog
@@ -1,103 +1,106 @@
-0.4.14.0
- * Use @hvr's Only package for the Only single element typle type.
-
-0.4.13.0
- * Add columnCount (thanks @Shimuuar!)
- * Add withImmediateTransaction, withExclusiveTransaction (thanks @mbucc!)
- * Expose the Database.SQLite3 Statement type through Database.SQLite.Simple Statement
-
-0.4.12.1
- * Add Setup.hs (https://github.com/fpco/stackage/issues/2145)
-
-0.4.12.0
- * Add queryWith
-
-0.4.11.0
- * Add executeMany
-
-0.4.10.0
- * Expose sqlite3_changes/total_changes
-
-0.4.9.0
- * Provide queryWith_ to allow more fine-grained access to
- constructing queries.
- * Expose error data constructors (pull request #42)
- * Improve haddocks
-
-0.4.8.0
- * Export `bindNamed'
-
-0.4.7.0
- * Add `withTransaction' for running IO actions inside SQL
- transactions with automated rollback if any exceptions are thrown.
-
-0.4.6.1
- * Fix unit test build break with older bytestring versions
-
-0.4.6.0
- * Add "named parameters" variants of query & al. Named params
- allow queries like:
- res <- queryNamed conn "SELECT * FROM posts WHERE id = :id" [":id" := postId]
- * Add FromField instances for Int8, Word, Word8, Word16, Word32
- and Word64.
- * Fix typos in some type conversion error messages.
- * Improved test coverage.
-
-0.4.5.2
- * Build fix for GHC 7.4
-
-0.4.5.1
- * Docs changes - uploaded new version to Hackage to update the
- Hackage page.
-
-0.4.5.0
-
- * Various improvements to documentation. Especially UTCTime
- parsing and printing, and how it relates to SQLite datetimes is
- better documented now.
-
- * Improved date/time parsing performance by adapting Leon
- P. Smith's parsers from postgresql-simple for SQLite. UTCTime
- handling is also better defined now.
-
- * Improved query performance
- (https://github.com/nurpax/sqlite-simple/issues/23)
-
- * Improved tests for all areas touched by the above change.
-
-v0.4.4.0
-
- * Add FromField instance for Float
-
- * Improve error handling for day parsing
-
- * + with tests
-
-v0.4.1.0 - v0.4.3.0 (missed tagging v0.4.2.0)
-
- * Improvements to withBind functionality and documentation
- (see https://github.com/nurpax/sqlite-simple/pull/26)
-
- * Add columnName accessor for statements
-
- * Expose MonadPlus on RowParser
-
- * Allow access to the underlying direct-sqilte connection from an
- sqlite-simple connection
-
- * Add Data.Text.Lazy and lazy ByteString From/ToField instances
-
-v0.4.0.0
-
- * Add lastInsertRowId
-
- * Expose SQLite statements based streaming API
- (see https://github.com/nurpax/sqlite-simple/pull/22)
-
-v0.3.0.0
-
- * Add fold, fold_, withConnection
-
-v0.2.0.0 - v0.2.1.0
-
- * Optimizations to improve query rows/sec performance
+0.4.15.0
+ * Support GHC 8.4.1 (Add instance Semigroup Query) (thanks @gwils!)
+
+0.4.14.0
+ * Use @hvr's Only package for the Only single element typle type.
+
+0.4.13.0
+ * Add columnCount (thanks @Shimuuar!)
+ * Add withImmediateTransaction, withExclusiveTransaction (thanks @mbucc!)
+ * Expose the Database.SQLite3 Statement type through Database.SQLite.Simple Statement
+
+0.4.12.1
+ * Add Setup.hs (https://github.com/fpco/stackage/issues/2145)
+
+0.4.12.0
+ * Add queryWith
+
+0.4.11.0
+ * Add executeMany
+
+0.4.10.0
+ * Expose sqlite3_changes/total_changes
+
+0.4.9.0
+ * Provide queryWith_ to allow more fine-grained access to
+ constructing queries.
+ * Expose error data constructors (pull request #42)
+ * Improve haddocks
+
+0.4.8.0
+ * Export `bindNamed'
+
+0.4.7.0
+ * Add `withTransaction' for running IO actions inside SQL
+ transactions with automated rollback if any exceptions are thrown.
+
+0.4.6.1
+ * Fix unit test build break with older bytestring versions
+
+0.4.6.0
+ * Add "named parameters" variants of query & al. Named params
+ allow queries like:
+ res <- queryNamed conn "SELECT * FROM posts WHERE id = :id" [":id" := postId]
+ * Add FromField instances for Int8, Word, Word8, Word16, Word32
+ and Word64.
+ * Fix typos in some type conversion error messages.
+ * Improved test coverage.
+
+0.4.5.2
+ * Build fix for GHC 7.4
+
+0.4.5.1
+ * Docs changes - uploaded new version to Hackage to update the
+ Hackage page.
+
+0.4.5.0
+
+ * Various improvements to documentation. Especially UTCTime
+ parsing and printing, and how it relates to SQLite datetimes is
+ better documented now.
+
+ * Improved date/time parsing performance by adapting Leon
+ P. Smith's parsers from postgresql-simple for SQLite. UTCTime
+ handling is also better defined now.
+
+ * Improved query performance
+ (https://github.com/nurpax/sqlite-simple/issues/23)
+
+ * Improved tests for all areas touched by the above change.
+
+v0.4.4.0
+
+ * Add FromField instance for Float
+
+ * Improve error handling for day parsing
+
+ * + with tests
+
+v0.4.1.0 - v0.4.3.0 (missed tagging v0.4.2.0)
+
+ * Improvements to withBind functionality and documentation
+ (see https://github.com/nurpax/sqlite-simple/pull/26)
+
+ * Add columnName accessor for statements
+
+ * Expose MonadPlus on RowParser
+
+ * Allow access to the underlying direct-sqilte connection from an
+ sqlite-simple connection
+
+ * Add Data.Text.Lazy and lazy ByteString From/ToField instances
+
+v0.4.0.0
+
+ * Add lastInsertRowId
+
+ * Expose SQLite statements based streaming API
+ (see https://github.com/nurpax/sqlite-simple/pull/22)
+
+v0.3.0.0
+
+ * Add fold, fold_, withConnection
+
+v0.2.0.0 - v0.2.1.0
+
+ * Optimizations to improve query rows/sec performance
diff --git a/sqlite-simple.cabal b/sqlite-simple.cabal
index 92dc019..92c1817 100644
--- a/sqlite-simple.cabal
+++ b/sqlite-simple.cabal
@@ -1,105 +1,106 @@
-Name: sqlite-simple
-Version: 0.4.14.0
-Synopsis: Mid-Level SQLite client library
-Description:
- Mid-level SQLite client library, based on postgresql-simple.
- .
- Main documentation (with examples): <sqlite-simple/docs/Database-SQLite-Simple.html Database.SQLite.Simple>
- .
- You can view the project page at <http://github.com/nurpax/sqlite-simple>
- for more information.
-
-License: BSD3
-License-file: LICENSE
-Author: Bryan O'Sullivan, Leon P Smith, Janne Hellsten
-Maintainer: Janne Hellsten <jjhellst@gmail.com>
-Copyright: (c) 2011 MailRank, Inc.,
- (c) 2011-2012 Leon P Smith,
- (c) 2012-2014 Janne Hellsten
-Homepage: http://github.com/nurpax/sqlite-simple
-bug-reports: http://github.com/nurpax/sqlite-simple/issues
-Stability: stable
-Category: Database
-Build-type: Simple
-
-Cabal-version: >= 1.10
-
-extra-source-files: README.markdown
- changelog
-
-Library
- Default-language: Haskell2010
- Exposed-modules:
- Database.SQLite.Simple
- Database.SQLite.Simple.Ok
- Database.SQLite.Simple.FromField
- Database.SQLite.Simple.FromRow
- Database.SQLite.Simple.Internal
- Database.SQLite.Simple.ToField
- Database.SQLite.Simple.ToRow
- Database.SQLite.Simple.Types
- Database.SQLite.Simple.Time
- Database.SQLite.Simple.Time.Implementation
-
- Build-depends:
- attoparsec >= 0.10.3,
- base < 5,
- blaze-builder,
- blaze-textual,
- bytestring >= 0.9,
- containers,
- direct-sqlite >= 2.3.13 && < 2.4,
- text >= 0.11,
- time,
- transformers,
- Only >= 0.1 && < 0.1.1
-
- default-extensions:
- DoAndIfThenElse
- , OverloadedStrings
- , BangPatterns
- , ViewPatterns
- , TypeOperators
-
- ghc-options: -Wall -fno-warn-name-shadowing
-
-source-repository head
- type: git
- location: http://github.com/nurpax/sqlite-simple
-
-
-test-suite test
- default-language: Haskell2010
- type: exitcode-stdio-1.0
-
- hs-source-dirs: test
- main-is: Main.hs
- other-modules: Common
- , Debug
- , DirectSqlite
- , Errors
- , Fold
- , ParamConv
- , Simple
- , Statement
- , TestImports
- , UserInstances
- , Utf8Strings
-
- ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind
-
- default-extensions:
- NamedFieldPuns
- , OverloadedStrings
- , Rank2Types
- , RecordWildCards
-
- build-depends: base
- , base16-bytestring
- , bytestring >= 0.9
- , HUnit
- , sqlite-simple
- , direct-sqlite
- , text
- , time
-
+Name: sqlite-simple
+Version: 0.4.15.0
+Synopsis: Mid-Level SQLite client library
+Description:
+ Mid-level SQLite client library, based on postgresql-simple.
+ .
+ Main documentation (with examples): <sqlite-simple/docs/Database-SQLite-Simple.html Database.SQLite.Simple>
+ .
+ You can view the project page at <http://github.com/nurpax/sqlite-simple>
+ for more information.
+
+License: BSD3
+License-file: LICENSE
+Author: Bryan O'Sullivan, Leon P Smith, Janne Hellsten
+Maintainer: Janne Hellsten <jjhellst@gmail.com>
+Copyright: (c) 2011 MailRank, Inc.,
+ (c) 2011-2012 Leon P Smith,
+ (c) 2012-2014 Janne Hellsten
+Homepage: http://github.com/nurpax/sqlite-simple
+bug-reports: http://github.com/nurpax/sqlite-simple/issues
+Stability: stable
+Category: Database
+Build-type: Simple
+
+Cabal-version: >= 1.10
+
+extra-source-files: README.markdown
+ changelog
+
+Library
+ Default-language: Haskell2010
+ Exposed-modules:
+ Database.SQLite.Simple
+ Database.SQLite.Simple.Ok
+ Database.SQLite.Simple.FromField
+ Database.SQLite.Simple.FromRow
+ Database.SQLite.Simple.Internal
+ Database.SQLite.Simple.ToField
+ Database.SQLite.Simple.ToRow
+ Database.SQLite.Simple.Types
+ Database.SQLite.Simple.Time
+ Database.SQLite.Simple.Time.Implementation
+
+ Build-depends:
+ attoparsec >= 0.10.3,
+ base < 5,
+ blaze-builder,
+ blaze-textual,
+ bytestring >= 0.9,
+ containers,
+ direct-sqlite >= 2.3.13 && < 2.4,
+ semigroups == 0.18.*,
+ text >= 0.11,
+ time,
+ transformers,
+ Only >= 0.1 && < 0.1.1
+
+ default-extensions:
+ DoAndIfThenElse
+ , OverloadedStrings
+ , BangPatterns
+ , ViewPatterns
+ , TypeOperators
+
+ ghc-options: -Wall -fno-warn-name-shadowing
+
+source-repository head
+ type: git
+ location: http://github.com/nurpax/sqlite-simple
+
+
+test-suite test
+ default-language: Haskell2010
+ type: exitcode-stdio-1.0
+
+ hs-source-dirs: test
+ main-is: Main.hs
+ other-modules: Common
+ , Debug
+ , DirectSqlite
+ , Errors
+ , Fold
+ , ParamConv
+ , Simple
+ , Statement
+ , TestImports
+ , UserInstances
+ , Utf8Strings
+
+ ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind
+
+ default-extensions:
+ NamedFieldPuns
+ , OverloadedStrings
+ , Rank2Types
+ , RecordWildCards
+
+ build-depends: base
+ , base16-bytestring
+ , bytestring >= 0.9
+ , HUnit
+ , sqlite-simple
+ , direct-sqlite
+ , text
+ , time
+
diff --git a/test/Common.hs b/test/Common.hs
index f32a751..0794526 100644
--- a/test/Common.hs
+++ b/test/Common.hs
@@ -1,18 +1,18 @@
-
-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 Database.SQLite.Simple
- , module Test.HUnit
- , TestEnv(..)
-) where
-
-import Test.HUnit
-import Database.SQLite.Simple
-
-data TestEnv
- = TestEnv
- { conn :: Connection
- -- ^ Connection shared by all the tests
- }
+
+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 Database.SQLite.Simple
+ , module Test.HUnit
+ , TestEnv(..)
+) where
+
+import Test.HUnit
+import Database.SQLite.Simple
+
+data TestEnv
+ = TestEnv
+ { conn :: Connection
+ -- ^ Connection shared by all the tests
+ }
diff --git a/test/Debug.hs b/test/Debug.hs
index 85a0eec..1490bae 100644
--- a/test/Debug.hs
+++ b/test/Debug.hs
@@ -1,29 +1,29 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Debug (
- testDebugTracing) where
-
-import Control.Concurrent
-import Common
-
--- Simplest SELECT
-testDebugTracing :: TestEnv -> Test
-testDebugTracing TestEnv{..} = TestCase $ do
- chan <- newChan
- let logger m = writeChan chan m
- setTrace conn (Just logger)
- execute_ conn "SELECT null"
- msg <- readChan chan
- "SELECT null" @=? msg
- execute conn "SELECT 1+?" (Only (2 :: Int))
- execute conn "SELECT 1+?" (Only (3 :: Int))
- msg <- readChan chan
- "SELECT 1+2" @=? msg
- msg <- readChan chan
- "SELECT 1+3" @=? msg
- -- Check that disabling works too
- setTrace conn Nothing
- execute_ conn "SELECT null"
- writeChan chan "empty"
- msg <- readChan chan
- "empty" @=? msg
+{-# LANGUAGE OverloadedStrings #-}
+
+module Debug (
+ testDebugTracing) where
+
+import Control.Concurrent
+import Common
+
+-- Simplest SELECT
+testDebugTracing :: TestEnv -> Test
+testDebugTracing TestEnv{..} = TestCase $ do
+ chan <- newChan
+ let logger m = writeChan chan m
+ setTrace conn (Just logger)
+ execute_ conn "SELECT null"
+ msg <- readChan chan
+ "SELECT null" @=? msg
+ execute conn "SELECT 1+?" (Only (2 :: Int))
+ execute conn "SELECT 1+?" (Only (3 :: Int))
+ msg <- readChan chan
+ "SELECT 1+2" @=? msg
+ msg <- readChan chan
+ "SELECT 1+3" @=? msg
+ -- Check that disabling works too
+ setTrace conn Nothing
+ execute_ conn "SELECT null"
+ writeChan chan "empty"
+ msg <- readChan chan
+ "empty" @=? msg
diff --git a/test/DirectSqlite.hs b/test/DirectSqlite.hs
index 7ea5096..0af2245 100644
--- a/test/DirectSqlite.hs
+++ b/test/DirectSqlite.hs
@@ -1,23 +1,23 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module DirectSqlite (
- testDirectSqlite
- ) where
-
-import Common
-
-import Control.Exception (bracket)
-import qualified Database.SQLite3 as DS
-
-testDirectSqlite :: TestEnv -> Test
-testDirectSqlite TestEnv{..} = TestCase $ do
- let dsConn = connectionHandle conn
- bracket (DS.prepare dsConn "SELECT 1+1") DS.finalize testDirect
- [Only (res :: Int)] <- query_ (Connection dsConn) "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
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module DirectSqlite (
+ testDirectSqlite
+ ) where
+
+import Common
+
+import Control.Exception (bracket)
+import qualified Database.SQLite3 as DS
+
+testDirectSqlite :: TestEnv -> Test
+testDirectSqlite TestEnv{..} = TestCase $ do
+ let dsConn = connectionHandle conn
+ bracket (DS.prepare dsConn "SELECT 1+1") DS.finalize testDirect
+ [Only (res :: Int)] <- query_ (Connection dsConn) "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/Errors.hs b/test/Errors.hs
index e8cb5d0..b616b2d 100644
--- a/test/Errors.hs
+++ b/test/Errors.hs
@@ -1,249 +1,249 @@
-{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}
-
-module Errors (
- testErrorsColumns
- , testErrorsInvalidParams
- , testErrorsInvalidNamedParams
- , testErrorsWithStatement
- , testErrorsColumnName
- , testErrorsTransaction
- , testErrorsImmediateTransaction
- , testErrorsExclusiveTransaction
- ) where
-
-import Prelude hiding (catch)
-import Control.Exception
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as LB
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as LT
-import Data.Word
-import Data.Time (Day, UTCTime)
-
-import Common
-import Database.SQLite.Simple.Types (Null)
-import Database.SQLite3 (SQLError)
-
--- 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 :: SQLError) -> 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 <- query_ conn "SELECT t FROM cols" :: IO [Only String]
- assertEqual "row count" 1 (length rows)
- assertEqual "string" (Only "test string") (head rows)
- -- Mismatched number of output columns (selects two, dest type has 1 field)
- assertResultErrorCaught (query_ conn "SELECT id,t FROM cols" :: IO [Only Int])
- -- Same as above but the other way round (select 1, dst has two)
- assertResultErrorCaught (query_ conn "SELECT id FROM cols" :: IO [(Int, String)])
- -- Mismatching types (source int,text doesn't match dst string,int
- assertResultErrorCaught (query_ conn "SELECT id, t FROM cols" :: IO [(String, Int)])
- -- Mismatching types (source string doesn't match dst integer
- assertResultErrorCaught (query_ conn "SELECT 'foo'" :: IO [Only Integer])
- -- Mismatching types (sources don't match destination float/double type)
- assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only Double])
- assertResultErrorCaught (query_ conn "SELECT 'foo'" :: IO [Only Double])
- assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only Float])
- assertResultErrorCaught (query_ conn "SELECT 'foo'" :: IO [Only Float])
- -- Mismatching types (sources don't match destination bool type, or is out of bounds)
- assertResultErrorCaught (query_ conn "SELECT 'true'" :: IO [Only Bool])
- assertResultErrorCaught (query_ conn "SELECT 2" :: IO [Only Bool])
- -- Mismatching types (sources don't match destination string types (text, string)
- assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only T.Text])
- assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only LT.Text])
- assertResultErrorCaught (query_ conn "SELECT 1.0" :: IO [Only T.Text])
- assertResultErrorCaught (query_ conn "SELECT 1.0" :: IO [Only LT.Text])
- -- Mismatching types (sources don't match destination string types (time/date)
- assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only UTCTime])
- assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only Day])
- -- Mismatching types (sources don't match destination bytestring)
- [Only (_ :: B.ByteString)] <- query_ conn "SELECT X'3177'"
- assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only B.ByteString])
- assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only LB.ByteString])
- assertResultErrorCaught (query_ conn "SELECT 'foo'" :: IO [Only B.ByteString])
- assertResultErrorCaught (query_ conn "SELECT 'foo'" :: IO [Only 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 [Only _t1] <- query conn "SELECT b FROM cols_blobs WHERE id = ?" (Only (1 :: Int)) :: IO [Only 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 [Only _t1] <- query_ conn "SELECT b FROM cols_bools" :: IO [Only Bool]
- return ())
- [Only (nullVal :: Null)] <- query_ conn "SELECT NULL"
- False @=? nullVal == nullVal
- False @=? nullVal /= nullVal
- assertResultErrorCaught
- (do [Only (_t1 :: Null)] <- query_ conn "SELECT 1" :: IO [Only 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)" (Only ("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 (?, ?)" (Only (3::Int)))
-
-testErrorsInvalidNamedParams :: TestEnv -> Test
-testErrorsInvalidNamedParams TestEnv{..} = TestCase $ do
- -- Test that only unnamed params are accepted
- assertFormatErrorCaught
- (queryNamed conn "SELECT :foo" [":foox" := (1 :: Int)] :: IO [Only Int])
- -- In this case, we have two bound params but only one given to
- -- execute. This should cause an error.
- assertFormatErrorCaught
- (queryNamed conn "SELECT :foo + :bar" [":foo" := (1 :: Int)] :: IO [Only Int])
- -- Can't use named params in SQL string with the unnamed query/exec variants
- assertFormatErrorCaught
- (query conn "SELECT :foo" (Only (1 :: Int)) :: IO [Only 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)]
- [Only r] <- query_ conn "SELECT t FROM trans" :: IO [Only 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 <- query_ conn "SELECT t FROM trans" :: IO [Only String]
- case rows of
- [Only 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)]
- [Only r] <- query_ conn "SELECT t FROM itrans" :: IO [Only 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 <- query_ conn "SELECT t FROM itrans" :: IO [Only String]
- case rows of
- [Only 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)]
- [Only r] <- query_ conn "SELECT t FROM etrans" :: IO [Only 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 <- query_ conn "SELECT t FROM etrans" :: IO [Only String]
- case rows of
- [Only txt] -> do
- "foo" @=? txt
- return True
- [] ->
- return False
- _ -> error "should have only one row"
+{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}
+
+module Errors (
+ testErrorsColumns
+ , testErrorsInvalidParams
+ , testErrorsInvalidNamedParams
+ , testErrorsWithStatement
+ , testErrorsColumnName
+ , testErrorsTransaction
+ , testErrorsImmediateTransaction
+ , testErrorsExclusiveTransaction
+ ) where
+
+import Prelude hiding (catch)
+import Control.Exception
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as LB
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as LT
+import Data.Word
+import Data.Time (Day, UTCTime)
+
+import Common
+import Database.SQLite.Simple.Types (Null)
+import Database.SQLite3 (SQLError)
+
+-- 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 :: SQLError) -> 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 <- query_ conn "SELECT t FROM cols" :: IO [Only String]
+ assertEqual "row count" 1 (length rows)
+ assertEqual "string" (Only "test string") (head rows)
+ -- Mismatched number of output columns (selects two, dest type has 1 field)
+ assertResultErrorCaught (query_ conn "SELECT id,t FROM cols" :: IO [Only Int])
+ -- Same as above but the other way round (select 1, dst has two)
+ assertResultErrorCaught (query_ conn "SELECT id FROM cols" :: IO [(Int, String)])
+ -- Mismatching types (source int,text doesn't match dst string,int
+ assertResultErrorCaught (query_ conn "SELECT id, t FROM cols" :: IO [(String, Int)])
+ -- Mismatching types (source string doesn't match dst integer
+ assertResultErrorCaught (query_ conn "SELECT 'foo'" :: IO [Only Integer])
+ -- Mismatching types (sources don't match destination float/double type)
+ assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only Double])
+ assertResultErrorCaught (query_ conn "SELECT 'foo'" :: IO [Only Double])
+ assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only Float])
+ assertResultErrorCaught (query_ conn "SELECT 'foo'" :: IO [Only Float])
+ -- Mismatching types (sources don't match destination bool type, or is out of bounds)
+ assertResultErrorCaught (query_ conn "SELECT 'true'" :: IO [Only Bool])
+ assertResultErrorCaught (query_ conn "SELECT 2" :: IO [Only Bool])
+ -- Mismatching types (sources don't match destination string types (text, string)
+ assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only T.Text])
+ assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only LT.Text])
+ assertResultErrorCaught (query_ conn "SELECT 1.0" :: IO [Only T.Text])
+ assertResultErrorCaught (query_ conn "SELECT 1.0" :: IO [Only LT.Text])
+ -- Mismatching types (sources don't match destination string types (time/date)
+ assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only UTCTime])
+ assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only Day])
+ -- Mismatching types (sources don't match destination bytestring)
+ [Only (_ :: B.ByteString)] <- query_ conn "SELECT X'3177'"
+ assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only B.ByteString])
+ assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only LB.ByteString])
+ assertResultErrorCaught (query_ conn "SELECT 'foo'" :: IO [Only B.ByteString])
+ assertResultErrorCaught (query_ conn "SELECT 'foo'" :: IO [Only 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 [Only _t1] <- query conn "SELECT b FROM cols_blobs WHERE id = ?" (Only (1 :: Int)) :: IO [Only 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 [Only _t1] <- query_ conn "SELECT b FROM cols_bools" :: IO [Only Bool]
+ return ())
+ [Only (nullVal :: Null)] <- query_ conn "SELECT NULL"
+ False @=? nullVal == nullVal
+ False @=? nullVal /= nullVal
+ assertResultErrorCaught
+ (do [Only (_t1 :: Null)] <- query_ conn "SELECT 1" :: IO [Only 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)" (Only ("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 (?, ?)" (Only (3::Int)))
+
+testErrorsInvalidNamedParams :: TestEnv -> Test
+testErrorsInvalidNamedParams TestEnv{..} = TestCase $ do
+ -- Test that only unnamed params are accepted
+ assertFormatErrorCaught
+ (queryNamed conn "SELECT :foo" [":foox" := (1 :: Int)] :: IO [Only Int])
+ -- In this case, we have two bound params but only one given to
+ -- execute. This should cause an error.
+ assertFormatErrorCaught
+ (queryNamed conn "SELECT :foo + :bar" [":foo" := (1 :: Int)] :: IO [Only Int])
+ -- Can't use named params in SQL string with the unnamed query/exec variants
+ assertFormatErrorCaught
+ (query conn "SELECT :foo" (Only (1 :: Int)) :: IO [Only 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)]
+ [Only r] <- query_ conn "SELECT t FROM trans" :: IO [Only 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 <- query_ conn "SELECT t FROM trans" :: IO [Only String]
+ case rows of
+ [Only 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)]
+ [Only r] <- query_ conn "SELECT t FROM itrans" :: IO [Only 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 <- query_ conn "SELECT t FROM itrans" :: IO [Only String]
+ case rows of
+ [Only 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)]
+ [Only r] <- query_ conn "SELECT t FROM etrans" :: IO [Only 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 <- query_ conn "SELECT t FROM etrans" :: IO [Only String]
+ case rows of
+ [Only txt] -> do
+ "foo" @=? txt
+ return True
+ [] ->
+ return False
+ _ -> error "should have only one row"
diff --git a/test/Fold.hs b/test/Fold.hs
index 7e8bf39..f959957 100644
--- a/test/Fold.hs
+++ b/test/Fold.hs
@@ -1,21 +1,21 @@
-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
-
-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
- assertEqual "fold_" ([3,2,1], [6,5,4]) val
- val <- fold conn "SELECT id,t FROM testf WHERE id > ?" (Only (1 :: Int)) ([],[]) sumValues
- assertEqual "fold" ([3,2], [6,5]) val
- val <- foldNamed conn "SELECT id,t FROM testf WHERE id > :id" [":id" := (1 :: Int)] ([],[]) sumValues
- assertEqual "fold" ([3,2], [6,5]) val
- where
- sumValues (accId, accT) (id_ :: Int, t :: Int) = return $ (id_ : accId, t : accT)
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
+
+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
+ assertEqual "fold_" ([3,2,1], [6,5,4]) val
+ val <- fold conn "SELECT id,t FROM testf WHERE id > ?" (Only (1 :: Int)) ([],[]) sumValues
+ assertEqual "fold" ([3,2], [6,5]) val
+ val <- foldNamed conn "SELECT id,t FROM testf WHERE id > :id" [":id" := (1 :: Int)] ([],[]) sumValues
+ assertEqual "fold" ([3,2], [6,5]) val
+ where
+ sumValues (accId, accT) (id_ :: Int, t :: Int) = return $ (id_ : accId, t : accT)
diff --git a/test/Main.hs b/test/Main.hs
index f9e3bd5..7368087 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -1,85 +1,85 @@
-
-import Common
-import Control.Exception (bracket)
-import Control.Monad (when)
-import System.Exit (exitFailure)
-import System.IO
-
-import Debug
-import DirectSqlite
-import Errors
-import Fold
-import ParamConv
-import Simple
-import Statement
-import TestImports()
-import TestImports
-import UserInstances
-import Utf8Strings
-
-tests :: [TestEnv -> Test]
-tests =
- [ TestLabel "Simple" . testSimpleSelect
- , TestLabel "Simple" . testSimpleOnePlusOne
- , TestLabel "Simple" . testSimpleParams
- , TestLabel "Simple" . testSimpleTime
- , TestLabel "Simple" . testSimpleTimeFract
- , TestLabel "Simple" . testSimpleInsertId
- , TestLabel "Simple" . testSimpleMultiInsert
- , TestLabel "Simple" . testSimpleUTCTime
- , TestLabel "Simple" . testSimpleUTCTimeTZ
- , TestLabel "Simple" . testSimpleUTCTimeParams
- , TestLabel "Simple" . testSimpleQueryCov
- , TestLabel "Simple" . testSimpleStrings
- , TestLabel "Simple" . testSimpleChanges
- , TestLabel "ParamConv" . testParamConvNull
- , TestLabel "ParamConv" . testParamConvInt
- , TestLabel "ParamConv" . testParamConvIntWidths
- , TestLabel "ParamConv" . testParamConvIntWidthsFromField
- , TestLabel "ParamConv" . testParamConvFloat
- , TestLabel "ParamConv" . testParamConvDateTime
- , 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 "Fold" . testFolds
- , TestLabel "Statement" . testBind
- , TestLabel "Statement" . testDoubleBind
- , TestLabel "Statement" . testPreparedStatements
- , TestLabel "Statement" . testPreparedStatementsColumnCount
- , TestLabel "Debug" . testDebugTracing
- , 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
+
+import Common
+import Control.Exception (bracket)
+import Control.Monad (when)
+import System.Exit (exitFailure)
+import System.IO
+
+import Debug
+import DirectSqlite
+import Errors
+import Fold
+import ParamConv
+import Simple
+import Statement
+import TestImports()
+import TestImports
+import UserInstances
+import Utf8Strings
+
+tests :: [TestEnv -> Test]
+tests =
+ [ TestLabel "Simple" . testSimpleSelect
+ , TestLabel "Simple" . testSimpleOnePlusOne
+ , TestLabel "Simple" . testSimpleParams
+ , TestLabel "Simple" . testSimpleTime
+ , TestLabel "Simple" . testSimpleTimeFract
+ , TestLabel "Simple" . testSimpleInsertId
+ , TestLabel "Simple" . testSimpleMultiInsert
+ , TestLabel "Simple" . testSimpleUTCTime
+ , TestLabel "Simple" . testSimpleUTCTimeTZ
+ , TestLabel "Simple" . testSimpleUTCTimeParams
+ , TestLabel "Simple" . testSimpleQueryCov
+ , TestLabel "Simple" . testSimpleStrings
+ , TestLabel "Simple" . testSimpleChanges
+ , TestLabel "ParamConv" . testParamConvNull
+ , TestLabel "ParamConv" . testParamConvInt
+ , TestLabel "ParamConv" . testParamConvIntWidths
+ , TestLabel "ParamConv" . testParamConvIntWidthsFromField
+ , TestLabel "ParamConv" . testParamConvFloat
+ , TestLabel "ParamConv" . testParamConvDateTime
+ , 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 "Fold" . testFolds
+ , TestLabel "Statement" . testBind
+ , TestLabel "Statement" . testDoubleBind
+ , TestLabel "Statement" . testPreparedStatements
+ , TestLabel "Statement" . testPreparedStatementsColumnCount
+ , TestLabel "Debug" . testDebugTracing
+ , 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/ParamConv.hs b/test/ParamConv.hs
index 2111a0c..ccbc3aa 100644
--- a/test/ParamConv.hs
+++ b/test/ParamConv.hs
@@ -1,244 +1,244 @@
-{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
-
-module ParamConv (
- testParamConvNull
- , testParamConvInt
- , testParamConvIntWidths
- , testParamConvIntWidthsFromField
- , testParamConvFloat
- , testParamConvBools
- , testParamConvDateTime
- , testParamConvFromRow
- , testParamConvToRow
- , testParamConvComposite
- , testParamNamed) where
-
-import Control.Applicative
-import Data.Int
-import Data.Word
-import Data.Time
-import qualified Data.Text as T
-import Database.SQLite.Simple.Types (Null(..))
-
-import Common
-
-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)"
- [Only r] <- (query_ conn "SELECT NULL") :: IO [Only Null]
- execute conn "INSERT INTO nulltype (id, t1) VALUES (?,?)" (one, r)
- [Only mr1] <- query_ conn "SELECT t1 FROM nulltype WHERE id = 1" :: IO [Only (Maybe String)]
- assertEqual "nulls" Nothing mr1
- execute conn "INSERT INTO nulltype (id, t1) VALUES (?,?)" (two, "foo" :: String)
- [mr2] <- query_ conn "SELECT t1 FROM nulltype WHERE id = 2" :: IO [Only (Maybe String)]
- assertEqual "nulls" (Just "foo") (fromOnly mr2)
-
-testParamConvInt :: TestEnv -> Test
-testParamConvInt TestEnv{..} = TestCase $ do
- [Only r] <- (query conn "SELECT ?" (Only one)) :: IO [Only Int]
- assertEqual "value" 1 r
- [Only r] <- (query conn "SELECT ?" (Only one)) :: IO [Only Integer]
- assertEqual "value" 1 r
- [Only r] <- (query conn "SELECT ?+?" (one, two)) :: IO [Only Int]
- assertEqual "value" 3 r
- [Only r] <- (query conn "SELECT ?+?" (one, 15 :: Int64)) :: IO [Only Int]
- assertEqual "value" 16 r
- [Only r] <- (query conn "SELECT ?+?" (two, 14 :: Int32)) :: IO [Only Int]
- assertEqual "value" 16 r
- [Only r] <- (query conn "SELECT ?+?" (two, 14 :: Integer)) :: IO [Only Int]
- assertEqual "value" 16 r
- -- This overflows 32-bit ints, verify that we get more than 32-bits out
- [Only r] <- (query conn "SELECT 255*?" (Only (0x7FFFFFFF :: Int32))) :: IO [Only Int64]
- assertEqual "> 32-bit result"
- (255*0x7FFFFFFF :: Int64) (fromIntegral r)
- [Only r] <- (query conn "SELECT 2*?" (Only (0x7FFFFFFFFF :: Int64))) :: IO [Only Int64]
- assertEqual "> 32-bit result & param"
- (2*0x7FFFFFFFFF :: Int64) (fromIntegral r)
- [Only r] <- (query_ conn "SELECT NULL") :: IO [Only (Maybe Int)]
- assertEqual "should see nothing" Nothing r
- [Only r] <- (query_ conn "SELECT 3") :: IO [Only (Maybe Int)]
- assertEqual "should see Just 3" (Just 3) r
- [Only r] <- (query conn "SELECT ?") (Only (Nothing :: Maybe Int)) :: IO [Only (Maybe Int)]
- assertEqual "should see nothing" Nothing r
- [Only r] <- (query conn "SELECT ?") (Only (Just three :: Maybe Int)) :: IO [Only (Maybe Int)]
- assertEqual "should see 4" (Just 3) r
-
-testParamConvIntWidths :: TestEnv -> Test
-testParamConvIntWidths TestEnv{..} = TestCase $ do
- [Only r] <- (query conn "SELECT ?" (Only (1 :: Int8))) :: IO [Only Int]
- assertEqual "value" 1 r
- [Only r] <- (query conn "SELECT ?" (Only (257 :: Int8))) :: IO [Only Int] -- wrap around
- assertEqual "value" 1 r
- [Only r] <- (query conn "SELECT ?" (Only (257 :: Int16))) :: IO [Only Int]
- assertEqual "value" 257 r
- [Only r] <- (query conn "SELECT ?" (Only (258 :: Int32))) :: IO [Only Int]
- assertEqual "value" 258 r
- [Only r] <- (query conn "SELECT ?" (Only (1 :: Word8))) :: IO [Only Int]
- assertEqual "value" 1 r
- [Only r] <- (query conn "SELECT ?" (Only (257 :: Word8))) :: IO [Only Int] -- wrap around
- assertEqual "value" 1 r
- [Only r] <- (query conn "SELECT ?" (Only (257 :: Word16))) :: IO [Only Int]
- assertEqual "value" 257 r
- [Only r] <- (query conn "SELECT ?" (Only (257 :: Word32))) :: IO [Only Int]
- assertEqual "value" 257 r
- [Only r] <- (query conn "SELECT ?" (Only (0x100000000 :: Word64))) :: IO [Only Int]
- assertEqual "value" 0x100000000 r
- [Only r] <- (query conn "SELECT ?" (Only (1 :: Integer))) :: IO [Only Int]
- assertEqual "value" 1 r
- [Only r] <- (query conn "SELECT ?" (Only (1 :: Word))) :: IO [Only Int]
- assertEqual "value" 1 r
-
-testParamConvIntWidthsFromField :: TestEnv -> Test
-testParamConvIntWidthsFromField TestEnv{..} = TestCase $ do
- [Only r] <- (query conn "SELECT ?" (Only (1 :: Int))) :: IO [Only Int8]
- assertEqual "value" 1 r
- [Only r] <- (query conn "SELECT ?" (Only (257 :: Int))) :: IO [Only Int8] -- wrap around
- assertEqual "value" 1 r
- [Only r] <- (query conn "SELECT ?" (Only (65536 :: Int))) :: IO [Only Int16] -- wrap around
- assertEqual "value" 0 r
- [Only r] <- (query conn "SELECT ?" (Only (65536 :: Int))) :: IO [Only Int32] -- wrap around
- assertEqual "value" 65536 r
- [Only r] <- (query conn "SELECT ?" (Only (258 :: Int))) :: IO [Only Int32]
- assertEqual "value" 258 r
- [Only r] <- (query conn "SELECT ?" (Only (1 :: Int))) :: IO [Only Word8]
- assertEqual "value" 1 r
- [Only r] <- (query conn "SELECT ?" (Only (257 :: Int))) :: IO [Only Word8] -- wrap around
- assertEqual "value" 1 r
- [Only r] <- (query conn "SELECT ?" (Only (257 :: Int))) :: IO [Only Word16]
- assertEqual "value" 257 r
- [Only r] <- (query conn "SELECT ?" (Only (257 :: Int))) :: IO [Only Word32]
- assertEqual "value" 257 r
- [Only r] <- (query conn "SELECT ?" (Only (0x100000000 :: Int64))) :: IO [Only Word64]
- assertEqual "value" 0x100000000 r
- [Only r] <- (query conn "SELECT ?" (Only (1 :: Int))) :: IO [Only Word]
- assertEqual "value" 1 r
-
-testParamConvFloat :: TestEnv -> Test
-testParamConvFloat TestEnv{..} = TestCase $ do
- [Only r] <- query conn "SELECT ?" (Only (1.0 :: Double)) :: IO [Only Double]
- assertEqual "value" 1.0 r
- [Only r] <- query conn "SELECT ?*0.25" (Only (8.0 :: Double)) :: IO [Only Double]
- assertEqual "value" 2.0 r
-
-testParamConvDateTime :: TestEnv -> Test
-testParamConvDateTime TestEnv{..} = TestCase $ do
- execute_ conn "CREATE TABLE dt (id INTEGER PRIMARY KEY, t1 DATE, t2 TIMESTAMP)"
- execute_ conn "INSERT INTO dt (t1, t2) VALUES (date('now'), datetime('now'))"
- _rows <- query_ conn "SELECT t1,t2 from dt" :: IO [(Day, UTCTime)]
- -- TODO should _rows be forced to make sure parsers kick on the
- -- returned data?
- execute conn "INSERT INTO dt (t1,t2) VALUES (?,?)"
- (read "2012-08-12" :: Day, read "2012-08-12 01:01:01" :: UTCTime)
- [_,(t1,t2)] <- query_ conn "SELECT t1,t2 from dt" :: IO [(Day, UTCTime)]
- assertEqual "day" (read "2012-08-12" :: Day) t1
- assertEqual "day" (read "2012-08-12 01:01:01" :: UTCTime) t2
-
-
-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)"
- [Only r1, Only r2] <- query_ conn "SELECT b from bt" :: IO [Only Bool]
- assertEqual "bool" False r1
- assertEqual "bool" True r2
- execute conn "INSERT INTO bt (b) VALUES (?)" (Only True)
- execute conn "INSERT INTO bt (b) VALUES (?)" (Only False)
- execute conn "INSERT INTO bt (b) VALUES (?)" (Only False)
- [Only r3, Only r4, Only r5] <-
- query_ conn "SELECT b from bt where id in (3, 4, 5) ORDER BY id" :: IO [Only Bool]
- assertEqual "bool" True r3
- assertEqual "bool" False r4
- assertEqual "bool" False r5
-
-testParamConvFromRow :: TestEnv -> Test
-testParamConvFromRow TestEnv{..} = TestCase $ do
- [(1,2)] <- query_ conn "SELECT 1,2" :: IO [(Int,Int)]
- [(1,2,3)] <- query_ conn "SELECT 1,2,3" :: IO [(Int,Int,Int)]
- [(1,2,3,4)] <- query_ conn "SELECT 1,2,3,4" :: IO [(Int,Int,Int,Int)]
- [(1,2,3,4,5)] <- query_ conn "SELECT 1,2,3,4,5" :: IO [(Int,Int,Int,Int,Int)]
- [(1,2,3,4,5,6)] <- query_ conn "SELECT 1,2,3,4,5,6" :: IO [(Int,Int,Int,Int,Int,Int)]
- [(1,2,3,4,5,6,7)] <- query_ 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)] <- query_ 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)] <- query_ 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)] <- query_ 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]] <- query_ conn "SELECT 1,2,3" :: IO [[Int]]
- return ()
-
-testParamConvToRow :: TestEnv -> Test
-testParamConvToRow TestEnv{..} = TestCase $ do
- [Only (s :: Int)] <- query conn "SELECT 13" ()
- 13 @=? s
- [Only (s :: Int)] <- query conn "SELECT ?" (Only one)
- 1 @=? s
- [Only (s :: Int)] <- query conn "SELECT ?+?" (one, two)
- (1+2) @=? s
- [Only (s :: Int)] <- query conn "SELECT ?+?+?" (one, two, three)
- (1+2+3) @=? s
- [Only (s :: Int)] <- query conn "SELECT ?+?+?+?" (one, two, three, 4 :: Int)
- (1+2+3+4) @=? s
- [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?" (one, two, three, 4 :: Int, 5 :: Int)
- (1+2+3+4+5) @=? s
- [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?+?" (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int)
- (1+2+3+4+5+6) @=? s
- [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?+?+?"
- (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int, 7 :: Int)
- (1+2+3+4+5+6+7) @=? s
- [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?+?+?+?"
- (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int, 7 :: Int, 8 :: Int)
- (1+2+3+4+5+6+7+8) @=? s
- [Only (s :: Int)] <- query 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
- [Only (s :: Int)] <- query 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] <- query_ conn "SELECT 1,2"
- TestTuple 1 2 @=? t1
- [t2] <- query_ conn "SELECT 'foo','bar'"
- TestTuple2 "foo" "bar" @=? t2
- [a :. b] <- query_ conn "SELECT 4,5,'baz','xyzz'"
- TestTuple 4 5 :. TestTuple2 "baz" "xyzz" @=? a :. b
- [TestTuple x y :. TestTuple2 z w] <- query conn "SELECT ?,?,?,?" (a :. b)
- x @=? 4
- y @=? 5
- z @=? "baz"
- w @=? "xyzz"
-
-testParamNamed :: TestEnv -> Test
-testParamNamed TestEnv{..} = TestCase $ do
- [Only t1] <- queryNamed conn "SELECT :foo / :bar" [":foo" := two, ":bar" := one]
- t1 @=? (2 :: Int)
- [(t1,t2)] <- queryNamed 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]
- [Only t1] <- query_ conn "SELECT b FROM np"
- True @=? t1
-
-
+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
+
+module ParamConv (
+ testParamConvNull
+ , testParamConvInt
+ , testParamConvIntWidths
+ , testParamConvIntWidthsFromField
+ , testParamConvFloat
+ , testParamConvBools
+ , testParamConvDateTime
+ , testParamConvFromRow
+ , testParamConvToRow
+ , testParamConvComposite
+ , testParamNamed) where
+
+import Control.Applicative
+import Data.Int
+import Data.Word
+import Data.Time
+import qualified Data.Text as T
+import Database.SQLite.Simple.Types (Null(..))
+
+import Common
+
+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)"
+ [Only r] <- (query_ conn "SELECT NULL") :: IO [Only Null]
+ execute conn "INSERT INTO nulltype (id, t1) VALUES (?,?)" (one, r)
+ [Only mr1] <- query_ conn "SELECT t1 FROM nulltype WHERE id = 1" :: IO [Only (Maybe String)]
+ assertEqual "nulls" Nothing mr1
+ execute conn "INSERT INTO nulltype (id, t1) VALUES (?,?)" (two, "foo" :: String)
+ [mr2] <- query_ conn "SELECT t1 FROM nulltype WHERE id = 2" :: IO [Only (Maybe String)]
+ assertEqual "nulls" (Just "foo") (fromOnly mr2)
+
+testParamConvInt :: TestEnv -> Test
+testParamConvInt TestEnv{..} = TestCase $ do
+ [Only r] <- (query conn "SELECT ?" (Only one)) :: IO [Only Int]
+ assertEqual "value" 1 r
+ [Only r] <- (query conn "SELECT ?" (Only one)) :: IO [Only Integer]
+ assertEqual "value" 1 r
+ [Only r] <- (query conn "SELECT ?+?" (one, two)) :: IO [Only Int]
+ assertEqual "value" 3 r
+ [Only r] <- (query conn "SELECT ?+?" (one, 15 :: Int64)) :: IO [Only Int]
+ assertEqual "value" 16 r
+ [Only r] <- (query conn "SELECT ?+?" (two, 14 :: Int32)) :: IO [Only Int]
+ assertEqual "value" 16 r
+ [Only r] <- (query conn "SELECT ?+?" (two, 14 :: Integer)) :: IO [Only Int]
+ assertEqual "value" 16 r
+ -- This overflows 32-bit ints, verify that we get more than 32-bits out
+ [Only r] <- (query conn "SELECT 255*?" (Only (0x7FFFFFFF :: Int32))) :: IO [Only Int64]
+ assertEqual "> 32-bit result"
+ (255*0x7FFFFFFF :: Int64) (fromIntegral r)
+ [Only r] <- (query conn "SELECT 2*?" (Only (0x7FFFFFFFFF :: Int64))) :: IO [Only Int64]
+ assertEqual "> 32-bit result & param"
+ (2*0x7FFFFFFFFF :: Int64) (fromIntegral r)
+ [Only r] <- (query_ conn "SELECT NULL") :: IO [Only (Maybe Int)]
+ assertEqual "should see nothing" Nothing r
+ [Only r] <- (query_ conn "SELECT 3") :: IO [Only (Maybe Int)]
+ assertEqual "should see Just 3" (Just 3) r
+ [Only r] <- (query conn "SELECT ?") (Only (Nothing :: Maybe Int)) :: IO [Only (Maybe Int)]
+ assertEqual "should see nothing" Nothing r
+ [Only r] <- (query conn "SELECT ?") (Only (Just three :: Maybe Int)) :: IO [Only (Maybe Int)]
+ assertEqual "should see 4" (Just 3) r
+
+testParamConvIntWidths :: TestEnv -> Test
+testParamConvIntWidths TestEnv{..} = TestCase $ do
+ [Only r] <- (query conn "SELECT ?" (Only (1 :: Int8))) :: IO [Only Int]
+ assertEqual "value" 1 r
+ [Only r] <- (query conn "SELECT ?" (Only (257 :: Int8))) :: IO [Only Int] -- wrap around
+ assertEqual "value" 1 r
+ [Only r] <- (query conn "SELECT ?" (Only (257 :: Int16))) :: IO [Only Int]
+ assertEqual "value" 257 r
+ [Only r] <- (query conn "SELECT ?" (Only (258 :: Int32))) :: IO [Only Int]
+ assertEqual "value" 258 r
+ [Only r] <- (query conn "SELECT ?" (Only (1 :: Word8))) :: IO [Only Int]
+ assertEqual "value" 1 r
+ [Only r] <- (query conn "SELECT ?" (Only (257 :: Word8))) :: IO [Only Int] -- wrap around
+ assertEqual "value" 1 r
+ [Only r] <- (query conn "SELECT ?" (Only (257 :: Word16))) :: IO [Only Int]
+ assertEqual "value" 257 r
+ [Only r] <- (query conn "SELECT ?" (Only (257 :: Word32))) :: IO [Only Int]
+ assertEqual "value" 257 r
+ [Only r] <- (query conn "SELECT ?" (Only (0x100000000 :: Word64))) :: IO [Only Int]
+ assertEqual "value" 0x100000000 r
+ [Only r] <- (query conn "SELECT ?" (Only (1 :: Integer))) :: IO [Only Int]
+ assertEqual "value" 1 r
+ [Only r] <- (query conn "SELECT ?" (Only (1 :: Word))) :: IO [Only Int]
+ assertEqual "value" 1 r
+
+testParamConvIntWidthsFromField :: TestEnv -> Test
+testParamConvIntWidthsFromField TestEnv{..} = TestCase $ do
+ [Only r] <- (query conn "SELECT ?" (Only (1 :: Int))) :: IO [Only Int8]
+ assertEqual "value" 1 r
+ [Only r] <- (query conn "SELECT ?" (Only (257 :: Int))) :: IO [Only Int8] -- wrap around
+ assertEqual "value" 1 r
+ [Only r] <- (query conn "SELECT ?" (Only (65536 :: Int))) :: IO [Only Int16] -- wrap around
+ assertEqual "value" 0 r
+ [Only r] <- (query conn "SELECT ?" (Only (65536 :: Int))) :: IO [Only Int32] -- wrap around
+ assertEqual "value" 65536 r
+ [Only r] <- (query conn "SELECT ?" (Only (258 :: Int))) :: IO [Only Int32]
+ assertEqual "value" 258 r
+ [Only r] <- (query conn "SELECT ?" (Only (1 :: Int))) :: IO [Only Word8]
+ assertEqual "value" 1 r
+ [Only r] <- (query conn "SELECT ?" (Only (257 :: Int))) :: IO [Only Word8] -- wrap around
+ assertEqual "value" 1 r
+ [Only r] <- (query conn "SELECT ?" (Only (257 :: Int))) :: IO [Only Word16]
+ assertEqual "value" 257 r
+ [Only r] <- (query conn "SELECT ?" (Only (257 :: Int))) :: IO [Only Word32]
+ assertEqual "value" 257 r
+ [Only r] <- (query conn "SELECT ?" (Only (0x100000000 :: Int64))) :: IO [Only Word64]
+ assertEqual "value" 0x100000000 r
+ [Only r] <- (query conn "SELECT ?" (Only (1 :: Int))) :: IO [Only Word]
+ assertEqual "value" 1 r
+
+testParamConvFloat :: TestEnv -> Test
+testParamConvFloat TestEnv{..} = TestCase $ do
+ [Only r] <- query conn "SELECT ?" (Only (1.0 :: Double)) :: IO [Only Double]
+ assertEqual "value" 1.0 r
+ [Only r] <- query conn "SELECT ?*0.25" (Only (8.0 :: Double)) :: IO [Only Double]
+ assertEqual "value" 2.0 r
+
+testParamConvDateTime :: TestEnv -> Test
+testParamConvDateTime TestEnv{..} = TestCase $ do
+ execute_ conn "CREATE TABLE dt (id INTEGER PRIMARY KEY, t1 DATE, t2 TIMESTAMP)"
+ execute_ conn "INSERT INTO dt (t1, t2) VALUES (date('now'), datetime('now'))"
+ _rows <- query_ conn "SELECT t1,t2 from dt" :: IO [(Day, UTCTime)]
+ -- TODO should _rows be forced to make sure parsers kick on the
+ -- returned data?
+ execute conn "INSERT INTO dt (t1,t2) VALUES (?,?)"
+ (read "2012-08-12" :: Day, read "2012-08-12 01:01:01" :: UTCTime)
+ [_,(t1,t2)] <- query_ conn "SELECT t1,t2 from dt" :: IO [(Day, UTCTime)]
+ assertEqual "day" (read "2012-08-12" :: Day) t1
+ assertEqual "day" (read "2012-08-12 01:01:01" :: UTCTime) t2
+
+
+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)"
+ [Only r1, Only r2] <- query_ conn "SELECT b from bt" :: IO [Only Bool]
+ assertEqual "bool" False r1
+ assertEqual "bool" True r2
+ execute conn "INSERT INTO bt (b) VALUES (?)" (Only True)
+ execute conn "INSERT INTO bt (b) VALUES (?)" (Only False)
+ execute conn "INSERT INTO bt (b) VALUES (?)" (Only False)
+ [Only r3, Only r4, Only r5] <-
+ query_ conn "SELECT b from bt where id in (3, 4, 5) ORDER BY id" :: IO [Only Bool]
+ assertEqual "bool" True r3
+ assertEqual "bool" False r4
+ assertEqual "bool" False r5
+
+testParamConvFromRow :: TestEnv -> Test
+testParamConvFromRow TestEnv{..} = TestCase $ do
+ [(1,2)] <- query_ conn "SELECT 1,2" :: IO [(Int,Int)]
+ [(1,2,3)] <- query_ conn "SELECT 1,2,3" :: IO [(Int,Int,Int)]
+ [(1,2,3,4)] <- query_ conn "SELECT 1,2,3,4" :: IO [(Int,Int,Int,Int)]
+ [(1,2,3,4,5)] <- query_ conn "SELECT 1,2,3,4,5" :: IO [(Int,Int,Int,Int,Int)]
+ [(1,2,3,4,5,6)] <- query_ conn "SELECT 1,2,3,4,5,6" :: IO [(Int,Int,Int,Int,Int,Int)]
+ [(1,2,3,4,5,6,7)] <- query_ 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)] <- query_ 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)] <- query_ 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)] <- query_ 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]] <- query_ conn "SELECT 1,2,3" :: IO [[Int]]
+ return ()
+
+testParamConvToRow :: TestEnv -> Test
+testParamConvToRow TestEnv{..} = TestCase $ do
+ [Only (s :: Int)] <- query conn "SELECT 13" ()
+ 13 @=? s
+ [Only (s :: Int)] <- query conn "SELECT ?" (Only one)
+ 1 @=? s
+ [Only (s :: Int)] <- query conn "SELECT ?+?" (one, two)
+ (1+2) @=? s
+ [Only (s :: Int)] <- query conn "SELECT ?+?+?" (one, two, three)
+ (1+2+3) @=? s
+ [Only (s :: Int)] <- query conn "SELECT ?+?+?+?" (one, two, three, 4 :: Int)
+ (1+2+3+4) @=? s
+ [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?" (one, two, three, 4 :: Int, 5 :: Int)
+ (1+2+3+4+5) @=? s
+ [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?+?" (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int)
+ (1+2+3+4+5+6) @=? s
+ [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?+?+?"
+ (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int, 7 :: Int)
+ (1+2+3+4+5+6+7) @=? s
+ [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?+?+?+?"
+ (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int, 7 :: Int, 8 :: Int)
+ (1+2+3+4+5+6+7+8) @=? s
+ [Only (s :: Int)] <- query 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
+ [Only (s :: Int)] <- query 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] <- query_ conn "SELECT 1,2"
+ TestTuple 1 2 @=? t1
+ [t2] <- query_ conn "SELECT 'foo','bar'"
+ TestTuple2 "foo" "bar" @=? t2
+ [a :. b] <- query_ conn "SELECT 4,5,'baz','xyzz'"
+ TestTuple 4 5 :. TestTuple2 "baz" "xyzz" @=? a :. b
+ [TestTuple x y :. TestTuple2 z w] <- query conn "SELECT ?,?,?,?" (a :. b)
+ x @=? 4
+ y @=? 5
+ z @=? "baz"
+ w @=? "xyzz"
+
+testParamNamed :: TestEnv -> Test
+testParamNamed TestEnv{..} = TestCase $ do
+ [Only t1] <- queryNamed conn "SELECT :foo / :bar" [":foo" := two, ":bar" := one]
+ t1 @=? (2 :: Int)
+ [(t1,t2)] <- queryNamed 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]
+ [Only t1] <- query_ conn "SELECT b FROM np"
+ True @=? t1
+
+
diff --git a/test/Simple.hs b/test/Simple.hs
index 29c23e7..23002a4 100644
--- a/test/Simple.hs
+++ b/test/Simple.hs
@@ -1,267 +1,267 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Simple (
- testSimpleOnePlusOne
- , testSimpleSelect
- , testSimpleParams
- , testSimpleTime
- , testSimpleTimeFract
- , testSimpleInsertId
- , testSimpleMultiInsert
- , testSimpleUTCTime
- , testSimpleUTCTimeTZ
- , testSimpleUTCTimeParams
- , testSimpleQueryCov
- , testSimpleStrings
- , testSimpleChanges
- ) where
-
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as LBS
--- orphan IsString instance in older byteString
-import Data.ByteString.Lazy.Char8 ()
-import Data.Monoid ((<>), mappend, mempty)
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as LT
-import Data.Time (UTCTime, Day)
-
-import Common
-
--- Simplest SELECT
-testSimpleOnePlusOne :: TestEnv -> Test
-testSimpleOnePlusOne TestEnv{..} = TestCase $ do
- rows <- query_ conn "SELECT 1+1" :: IO [Only Int]
- assertEqual "row count" 1 (length rows)
- assertEqual "value" (Only 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 <- query_ conn "SELECT t FROM test1" :: IO [Only String]
- assertEqual "row count" 1 (length rows)
- assertEqual "string" (Only "test string") (head rows)
- rows <- query_ 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 <- query_ 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)
- [Only r] <- query_ conn "SELECT NULL" :: IO [Only (Maybe Int)]
- assertEqual "nulls" Nothing r
- [Only r] <- query_ conn "SELECT 1" :: IO [Only (Maybe Int)]
- assertEqual "nulls" (Just 1) r
- [Only r] <- query_ conn "SELECT 1.0" :: IO [Only Double]
- assertEqual "doubles" 1.0 r
- [Only r] <- query_ conn "SELECT 1.0" :: IO [Only 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)"
- [Only i] <- query conn "SELECT ?" (Only (42 :: Int)) :: IO [Only Int]
- assertEqual "select int param" 42 i
- execute conn "INSERT INTO testparams (t) VALUES (?)" (Only ("test string" :: String))
- rows <- query conn "SELECT t FROM testparams WHERE id = ?" (Only (1 :: Int)) :: IO [Only String]
- assertEqual "row count" 1 (length rows)
- assertEqual "string" (Only "test string") (head rows)
- execute_ conn "INSERT INTO testparams (t) VALUES ('test2')"
- [Only row] <- query conn "SELECT t FROM testparams WHERE id = ?" (Only (1 :: Int)) :: IO [Only String]
- assertEqual "select params" "test string" row
- [Only row] <- query conn "SELECT t FROM testparams WHERE id = ?" (Only (2 :: Int)) :: IO [Only String]
- assertEqual "select params" "test2" row
- [Only r1, Only r2] <- query conn "SELECT t FROM testparams WHERE (id = ? OR id = ?)" (1 :: Int, 2 :: Int) :: IO [Only String]
- assertEqual "select params" "test string" r1
- assertEqual "select params" "test2" r2
- [Only i] <- query conn "SELECT ?+?" [42 :: Int, 1 :: Int] :: IO [Only Int]
- assertEqual "select int param" 43 i
- [Only d] <- query conn "SELECT ?" [2.0 :: Double] :: IO [Only Double]
- assertEqual "select double param" 2.0 d
- [Only f] <- query conn "SELECT ?" [4.0 :: Float] :: IO [Only Float]
- assertEqual "select double param" 4.0 f
-
-testSimpleTime :: TestEnv -> Test
-testSimpleTime TestEnv{..} = TestCase $ do
- let timestr = "2012-08-20 20:19:58"
- time = read timestr :: UTCTime
- execute_ conn "CREATE TABLE time (t TIMESTAMP)"
- execute conn "INSERT INTO time (t) VALUES (?)" (Only time)
- [Only t] <- query_ conn "SELECT * FROM time" :: IO [Only UTCTime]
- assertEqual "UTCTime conv" time t
- [Only t] <- query conn "SELECT * FROM time WHERE t = ?" (Only time) :: IO [Only UTCTime]
- assertEqual "UTCTime conv2" time t
- -- Try inserting timestamp directly as a string
- execute_ conn "CREATE TABLE time2 (t TIMESTAMP)"
- execute_ conn (Query (T.concat ["INSERT INTO time2 (t) VALUES ('", T.pack timestr, "')"]))
- [Only t] <- query_ conn "SELECT * FROM time2" :: IO [Only UTCTime]
- assertEqual "UTCTime" time t
- rows <- query conn "SELECT * FROM time2 WHERE t = ?" (Only time) :: IO [Only UTCTime]
- assertEqual "should see one row result" 1 (length rows)
- assertEqual "UTCTime" time t
- -- Days
- let daystr = "2013-08-21"
- day = read daystr :: Day
- [Only day'] <- query_ conn (Query (T.concat ["SELECT '", T.pack daystr, "'"]))
- day @?= day'
- [Only day''] <- query conn "SELECT ?" (Only day)
- day @?= day''
- -- database timestamp -> day conversion is treated as an error, but
- -- try converting a timestamp to a date and see we get it back ok
- [Only dayx] <- query_ conn "SELECT date('2013-08-21 08:00:03.256887')"
- day @?= dayx
-
-testSimpleTimeFract :: TestEnv -> Test
-testSimpleTimeFract TestEnv{..} = TestCase $ do
- let timestr = "2012-08-17 08:00:03.256887"
- time = read timestr :: UTCTime
- -- Try inserting timestamp directly as a string
- execute_ conn "CREATE TABLE timefract (t TIMESTAMP)"
- execute_ conn (Query (T.concat ["INSERT INTO timefract (t) VALUES ('", T.pack timestr, "')"]))
- [Only t] <- query_ conn "SELECT * FROM timefract" :: IO [Only UTCTime]
- assertEqual "UTCTime" time t
- rows <- query conn "SELECT * FROM timefract WHERE t = ?" (Only time) :: IO [Only UTCTime]
- assertEqual "should see one row result" 1 (length rows)
-
-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 (?)" (Only ("test string" :: String))
- id1 <- lastInsertRowId conn
- execute_ conn "INSERT INTO test_row_id (t) VALUES ('test2')"
- id2 <- lastInsertRowId conn
- 1 @=? id1
- 2 @=? id2
- rows <- query conn "SELECT t FROM test_row_id WHERE id = ?" (Only (1 :: Int)) :: IO [Only String]
- 1 @=? (length rows)
- (Only "test string") @=? (head rows)
- [Only row] <- query conn "SELECT t FROM test_row_id WHERE id = ?" (Only (2 :: Int)) :: IO [Only 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 <- query_ conn "SELECT id,t1,t2 FROM test_multi_insert" :: IO [(Int, String, String)]
- [(1, "foo", "bar"), (2, "baz", "bat")] @=? rows
-
-testSimpleUTCTime :: TestEnv -> Test
-testSimpleUTCTime TestEnv{..} = TestCase $ do
- -- Time formats understood by sqlite: http://sqlite.org/lang_datefunc.html
- let timestrs = [ "2012-08-17 13:25"
- , "2012-08-17 13:25:44"
- , "2012-08-17 13:25:44.123"
- ]
- timestrsWithT = map (T.map (\c -> if c == ' ' then 'T' else c)) timestrs
- execute_ conn "CREATE TABLE utctimes (t TIMESTAMP)"
- mapM_ (\t -> execute conn "INSERT INTO utctimes (t) VALUES (?)" (Only t)) timestrs
- mapM_ (\t -> execute conn "INSERT INTO utctimes (t) VALUES (?)" (Only t)) timestrsWithT
- dates <- query_ conn "SELECT t from utctimes" :: IO [Only UTCTime]
- mapM_ matchDates (zip (timestrs ++ timestrsWithT) dates)
- let zulu = "2012-08-17 13:25"
- [d] <- query conn "SELECT ?" (Only (T.append zulu "Z"))
- matchDates (zulu, d)
- let zulu = "2012-08-17 13:25:00"
- [d] <- query conn "SELECT ?" (Only (T.append zulu "Z"))
- matchDates (zulu, d)
- where
- matchDates (str,(Only date)) = do
- -- Remove 'T' when reading in to Haskell
- let t = read (makeReadable str) :: UTCTime
- t @=? date
-
- makeReadable s =
- let s' = if T.length s < T.length "YYYY-MM-DD HH:MM:SS" then T.append s ":00" else s
- in T.unpack . T.replace "T" " " $ s'
-
-testSimpleUTCTimeTZ :: TestEnv -> Test
-testSimpleUTCTimeTZ TestEnv{..} = TestCase $ do
- -- Time formats understood by sqlite: http://sqlite.org/lang_datefunc.html
- let timestrs = [ "2013-02-03 13:00:00-02:00"
- , "2013-02-03 13:00:00-01:00"
- , "2013-02-03 13:00:00-03:00"
- , "2013-02-03 13:00:00Z"
- , "2013-02-03 13:00:00+00:00"
- , "2013-02-03 13:00:00+03:00"
- , "2013-02-03 13:00:00+02:00"
- , "2013-02-03 13:00:00+04:00"
- ]
- execute_ conn "CREATE TABLE utctimestz (t TIMESTAMP)"
- mapM_ (\t -> execute conn "INSERT INTO utctimestz (t) VALUES (?)" (Only t)) timestrs
- dates <- query_ conn "SELECT t from utctimestz" :: IO [Only UTCTime]
- mapM_ matchDates (zip (timestrs) dates)
- where
- matchDates (str,(Only date)) = do
- -- Remove 'T' when reading in to Haskell
- let t = read . T.unpack $ str :: UTCTime
- t @=? date
-
-testSimpleUTCTimeParams :: TestEnv -> Test
-testSimpleUTCTimeParams TestEnv{..} = TestCase $ do
- let times = [ "2012-08-17 08:00:03"
- , "2012-08-17 08:00:03.2"
- , "2012-08-17 08:00:03.256"
- , "2012-08-17 08:00:03.4192"
- ]
- -- Try inserting timestamp directly as a string
- mapM_ assertResult times
- where
- assertResult tstr = do
- let utct = read . T.unpack $ tstr :: UTCTime
- [Only t] <- query conn "SELECT ?" (Only utct) :: IO [Only T.Text]
- assertEqual "UTCTime" tstr t
-
-testSimpleQueryCov :: TestEnv -> Test
-testSimpleQueryCov TestEnv{..} = TestCase $ do
- let str = "SELECT 1+1" :: T.Text
- q = "SELECT 1+1" :: Query
- fromQuery q @=? str
- show str @=? show q
- q @=? ((read . show $ q) :: Query)
- q @=? q
- q @=? (Query "SELECT 1" <> Query "+1")
- q @=? foldr mappend mempty ["SELECT ", "1", "+", "1"]
- True @=? q <= q
-
-testSimpleStrings :: TestEnv -> Test
-testSimpleStrings TestEnv{..} = TestCase $ do
- [Only s] <- query_ conn "SELECT 'str1'" :: IO [Only T.Text]
- s @=? "str1"
- [Only s] <- query_ conn "SELECT 'strLazy'" :: IO [Only LT.Text]
- s @=? "strLazy"
- [Only s] <- query conn "SELECT ?" (Only ("strP" :: T.Text)) :: IO [Only T.Text]
- s @=? "strP"
- [Only s] <- query conn "SELECT ?" (Only ("strPLazy" :: LT.Text)) :: IO [Only T.Text]
- s @=? "strPLazy"
- -- ByteStrings are blobs in sqlite storage, so use ByteString for
- -- both input and output
- [Only s] <- query conn "SELECT ?" (Only ("strBsP" :: BS.ByteString)) :: IO [Only BS.ByteString]
- s @=? "strBsP"
- [Only s] <- query conn "SELECT ?" (Only ("strBsPLazy" :: LBS.ByteString)) :: IO [Only BS.ByteString]
- s @=? "strBsPLazy"
- [Only s] <- query conn "SELECT ?" (Only ("strBsPLazy2" :: BS.ByteString)) :: IO [Only 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 (?)" (Only ("test string" :: String))
- numChanges <- changes conn
- assertEqual "changed/inserted rows" 1 numChanges
- execute conn "INSERT INTO testchanges(t) VALUES (?)" (Only ("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
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simple (
+ testSimpleOnePlusOne
+ , testSimpleSelect
+ , testSimpleParams
+ , testSimpleTime
+ , testSimpleTimeFract
+ , testSimpleInsertId
+ , testSimpleMultiInsert
+ , testSimpleUTCTime
+ , testSimpleUTCTimeTZ
+ , testSimpleUTCTimeParams
+ , testSimpleQueryCov
+ , testSimpleStrings
+ , testSimpleChanges
+ ) where
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+-- orphan IsString instance in older byteString
+import Data.ByteString.Lazy.Char8 ()
+import Data.Monoid ((<>), mappend, mempty)
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as LT
+import Data.Time (UTCTime, Day)
+
+import Common
+
+-- Simplest SELECT
+testSimpleOnePlusOne :: TestEnv -> Test
+testSimpleOnePlusOne TestEnv{..} = TestCase $ do
+ rows <- query_ conn "SELECT 1+1" :: IO [Only Int]
+ assertEqual "row count" 1 (length rows)
+ assertEqual "value" (Only 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 <- query_ conn "SELECT t FROM test1" :: IO [Only String]
+ assertEqual "row count" 1 (length rows)
+ assertEqual "string" (Only "test string") (head rows)
+ rows <- query_ 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 <- query_ 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)
+ [Only r] <- query_ conn "SELECT NULL" :: IO [Only (Maybe Int)]
+ assertEqual "nulls" Nothing r
+ [Only r] <- query_ conn "SELECT 1" :: IO [Only (Maybe Int)]
+ assertEqual "nulls" (Just 1) r
+ [Only r] <- query_ conn "SELECT 1.0" :: IO [Only Double]
+ assertEqual "doubles" 1.0 r
+ [Only r] <- query_ conn "SELECT 1.0" :: IO [Only 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)"
+ [Only i] <- query conn "SELECT ?" (Only (42 :: Int)) :: IO [Only Int]
+ assertEqual "select int param" 42 i
+ execute conn "INSERT INTO testparams (t) VALUES (?)" (Only ("test string" :: String))
+ rows <- query conn "SELECT t FROM testparams WHERE id = ?" (Only (1 :: Int)) :: IO [Only String]
+ assertEqual "row count" 1 (length rows)
+ assertEqual "string" (Only "test string") (head rows)
+ execute_ conn "INSERT INTO testparams (t) VALUES ('test2')"
+ [Only row] <- query conn "SELECT t FROM testparams WHERE id = ?" (Only (1 :: Int)) :: IO [Only String]
+ assertEqual "select params" "test string" row
+ [Only row] <- query conn "SELECT t FROM testparams WHERE id = ?" (Only (2 :: Int)) :: IO [Only String]
+ assertEqual "select params" "test2" row
+ [Only r1, Only r2] <- query conn "SELECT t FROM testparams WHERE (id = ? OR id = ?)" (1 :: Int, 2 :: Int) :: IO [Only String]
+ assertEqual "select params" "test string" r1
+ assertEqual "select params" "test2" r2
+ [Only i] <- query conn "SELECT ?+?" [42 :: Int, 1 :: Int] :: IO [Only Int]
+ assertEqual "select int param" 43 i
+ [Only d] <- query conn "SELECT ?" [2.0 :: Double] :: IO [Only Double]
+ assertEqual "select double param" 2.0 d
+ [Only f] <- query conn "SELECT ?" [4.0 :: Float] :: IO [Only Float]
+ assertEqual "select double param" 4.0 f
+
+testSimpleTime :: TestEnv -> Test
+testSimpleTime TestEnv{..} = TestCase $ do
+ let timestr = "2012-08-20 20:19:58"
+ time = read timestr :: UTCTime
+ execute_ conn "CREATE TABLE time (t TIMESTAMP)"
+ execute conn "INSERT INTO time (t) VALUES (?)" (Only time)
+ [Only t] <- query_ conn "SELECT * FROM time" :: IO [Only UTCTime]
+ assertEqual "UTCTime conv" time t
+ [Only t] <- query conn "SELECT * FROM time WHERE t = ?" (Only time) :: IO [Only UTCTime]
+ assertEqual "UTCTime conv2" time t
+ -- Try inserting timestamp directly as a string
+ execute_ conn "CREATE TABLE time2 (t TIMESTAMP)"
+ execute_ conn (Query (T.concat ["INSERT INTO time2 (t) VALUES ('", T.pack timestr, "')"]))
+ [Only t] <- query_ conn "SELECT * FROM time2" :: IO [Only UTCTime]
+ assertEqual "UTCTime" time t
+ rows <- query conn "SELECT * FROM time2 WHERE t = ?" (Only time) :: IO [Only UTCTime]
+ assertEqual "should see one row result" 1 (length rows)
+ assertEqual "UTCTime" time t
+ -- Days
+ let daystr = "2013-08-21"
+ day = read daystr :: Day
+ [Only day'] <- query_ conn (Query (T.concat ["SELECT '", T.pack daystr, "'"]))
+ day @?= day'
+ [Only day''] <- query conn "SELECT ?" (Only day)
+ day @?= day''
+ -- database timestamp -> day conversion is treated as an error, but
+ -- try converting a timestamp to a date and see we get it back ok
+ [Only dayx] <- query_ conn "SELECT date('2013-08-21 08:00:03.256887')"
+ day @?= dayx
+
+testSimpleTimeFract :: TestEnv -> Test
+testSimpleTimeFract TestEnv{..} = TestCase $ do
+ let timestr = "2012-08-17 08:00:03.256887"
+ time = read timestr :: UTCTime
+ -- Try inserting timestamp directly as a string
+ execute_ conn "CREATE TABLE timefract (t TIMESTAMP)"
+ execute_ conn (Query (T.concat ["INSERT INTO timefract (t) VALUES ('", T.pack timestr, "')"]))
+ [Only t] <- query_ conn "SELECT * FROM timefract" :: IO [Only UTCTime]
+ assertEqual "UTCTime" time t
+ rows <- query conn "SELECT * FROM timefract WHERE t = ?" (Only time) :: IO [Only UTCTime]
+ assertEqual "should see one row result" 1 (length rows)
+
+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 (?)" (Only ("test string" :: String))
+ id1 <- lastInsertRowId conn
+ execute_ conn "INSERT INTO test_row_id (t) VALUES ('test2')"
+ id2 <- lastInsertRowId conn
+ 1 @=? id1
+ 2 @=? id2
+ rows <- query conn "SELECT t FROM test_row_id WHERE id = ?" (Only (1 :: Int)) :: IO [Only String]
+ 1 @=? (length rows)
+ (Only "test string") @=? (head rows)
+ [Only row] <- query conn "SELECT t FROM test_row_id WHERE id = ?" (Only (2 :: Int)) :: IO [Only 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 <- query_ conn "SELECT id,t1,t2 FROM test_multi_insert" :: IO [(Int, String, String)]
+ [(1, "foo", "bar"), (2, "baz", "bat")] @=? rows
+
+testSimpleUTCTime :: TestEnv -> Test
+testSimpleUTCTime TestEnv{..} = TestCase $ do
+ -- Time formats understood by sqlite: http://sqlite.org/lang_datefunc.html
+ let timestrs = [ "2012-08-17 13:25"
+ , "2012-08-17 13:25:44"
+ , "2012-08-17 13:25:44.123"
+ ]
+ timestrsWithT = map (T.map (\c -> if c == ' ' then 'T' else c)) timestrs
+ execute_ conn "CREATE TABLE utctimes (t TIMESTAMP)"
+ mapM_ (\t -> execute conn "INSERT INTO utctimes (t) VALUES (?)" (Only t)) timestrs
+ mapM_ (\t -> execute conn "INSERT INTO utctimes (t) VALUES (?)" (Only t)) timestrsWithT
+ dates <- query_ conn "SELECT t from utctimes" :: IO [Only UTCTime]
+ mapM_ matchDates (zip (timestrs ++ timestrsWithT) dates)
+ let zulu = "2012-08-17 13:25"
+ [d] <- query conn "SELECT ?" (Only (T.append zulu "Z"))
+ matchDates (zulu, d)
+ let zulu = "2012-08-17 13:25:00"
+ [d] <- query conn "SELECT ?" (Only (T.append zulu "Z"))
+ matchDates (zulu, d)
+ where
+ matchDates (str,(Only date)) = do
+ -- Remove 'T' when reading in to Haskell
+ let t = read (makeReadable str) :: UTCTime
+ t @=? date
+
+ makeReadable s =
+ let s' = if T.length s < T.length "YYYY-MM-DD HH:MM:SS" then T.append s ":00" else s
+ in T.unpack . T.replace "T" " " $ s'
+
+testSimpleUTCTimeTZ :: TestEnv -> Test
+testSimpleUTCTimeTZ TestEnv{..} = TestCase $ do
+ -- Time formats understood by sqlite: http://sqlite.org/lang_datefunc.html
+ let timestrs = [ "2013-02-03 13:00:00-02:00"
+ , "2013-02-03 13:00:00-01:00"
+ , "2013-02-03 13:00:00-03:00"
+ , "2013-02-03 13:00:00Z"
+ , "2013-02-03 13:00:00+00:00"
+ , "2013-02-03 13:00:00+03:00"
+ , "2013-02-03 13:00:00+02:00"
+ , "2013-02-03 13:00:00+04:00"
+ ]
+ execute_ conn "CREATE TABLE utctimestz (t TIMESTAMP)"
+ mapM_ (\t -> execute conn "INSERT INTO utctimestz (t) VALUES (?)" (Only t)) timestrs
+ dates <- query_ conn "SELECT t from utctimestz" :: IO [Only UTCTime]
+ mapM_ matchDates (zip (timestrs) dates)
+ where
+ matchDates (str,(Only date)) = do
+ -- Remove 'T' when reading in to Haskell
+ let t = read . T.unpack $ str :: UTCTime
+ t @=? date
+
+testSimpleUTCTimeParams :: TestEnv -> Test
+testSimpleUTCTimeParams TestEnv{..} = TestCase $ do
+ let times = [ "2012-08-17 08:00:03"
+ , "2012-08-17 08:00:03.2"
+ , "2012-08-17 08:00:03.256"
+ , "2012-08-17 08:00:03.4192"
+ ]
+ -- Try inserting timestamp directly as a string
+ mapM_ assertResult times
+ where
+ assertResult tstr = do
+ let utct = read . T.unpack $ tstr :: UTCTime
+ [Only t] <- query conn "SELECT ?" (Only utct) :: IO [Only T.Text]
+ assertEqual "UTCTime" tstr t
+
+testSimpleQueryCov :: TestEnv -> Test
+testSimpleQueryCov TestEnv{..} = TestCase $ do
+ let str = "SELECT 1+1" :: T.Text
+ q = "SELECT 1+1" :: Query
+ fromQuery q @=? str
+ show str @=? show q
+ q @=? ((read . show $ q) :: Query)
+ q @=? q
+ q @=? (Query "SELECT 1" <> Query "+1")
+ q @=? foldr mappend mempty ["SELECT ", "1", "+", "1"]
+ True @=? q <= q
+
+testSimpleStrings :: TestEnv -> Test
+testSimpleStrings TestEnv{..} = TestCase $ do
+ [Only s] <- query_ conn "SELECT 'str1'" :: IO [Only T.Text]
+ s @=? "str1"
+ [Only s] <- query_ conn "SELECT 'strLazy'" :: IO [Only LT.Text]
+ s @=? "strLazy"
+ [Only s] <- query conn "SELECT ?" (Only ("strP" :: T.Text)) :: IO [Only T.Text]
+ s @=? "strP"
+ [Only s] <- query conn "SELECT ?" (Only ("strPLazy" :: LT.Text)) :: IO [Only T.Text]
+ s @=? "strPLazy"
+ -- ByteStrings are blobs in sqlite storage, so use ByteString for
+ -- both input and output
+ [Only s] <- query conn "SELECT ?" (Only ("strBsP" :: BS.ByteString)) :: IO [Only BS.ByteString]
+ s @=? "strBsP"
+ [Only s] <- query conn "SELECT ?" (Only ("strBsPLazy" :: LBS.ByteString)) :: IO [Only BS.ByteString]
+ s @=? "strBsPLazy"
+ [Only s] <- query conn "SELECT ?" (Only ("strBsPLazy2" :: BS.ByteString)) :: IO [Only 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 (?)" (Only ("test string" :: String))
+ numChanges <- changes conn
+ assertEqual "changed/inserted rows" 1 numChanges
+ execute conn "INSERT INTO testchanges(t) VALUES (?)" (Only ("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/Statement.hs b/test/Statement.hs
index e395c98..e82ea33 100644
--- a/test/Statement.hs
+++ b/test/Statement.hs
@@ -1,66 +1,66 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Statement (
- testBind
- , testDoubleBind
- , testPreparedStatements
- , testPreparedStatementsColumnCount
- ) where
-
-import Common
-import Data.Maybe(fromJust)
-
-import qualified Database.SQLite3 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 (Only String))
- assertEqual "result" (Only "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 (Only String))
- assertEqual "first result" (Only "first result") (fromJust row)
-
- withBind stmt [2::Int] $ do
- row <- nextRow stmt :: IO (Maybe (Only String))
- assertEqual "second result" (Only "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 (Only rowId) $ do
- Just (Only r) <- nextRow stmt
- Nothing <- nextRow stmt :: IO (Maybe (Only 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 = unStatement stmt
- colCountBase <- Base.columnCount baseStatment
- colCountBase @?= 1
+{-# LANGUAGE OverloadedStrings #-}
+
+module Statement (
+ testBind
+ , testDoubleBind
+ , testPreparedStatements
+ , testPreparedStatementsColumnCount
+ ) where
+
+import Common
+import Data.Maybe(fromJust)
+
+import qualified Database.SQLite3 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 (Only String))
+ assertEqual "result" (Only "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 (Only String))
+ assertEqual "first result" (Only "first result") (fromJust row)
+
+ withBind stmt [2::Int] $ do
+ row <- nextRow stmt :: IO (Maybe (Only String))
+ assertEqual "second result" (Only "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 (Only rowId) $ do
+ Just (Only r) <- nextRow stmt
+ Nothing <- nextRow stmt :: IO (Maybe (Only 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 = unStatement stmt
+ colCountBase <- Base.columnCount baseStatment
+ colCountBase @?= 1
diff --git a/test/TestImports.hs b/test/TestImports.hs
index cfdbbf5..31a5d32 100644
--- a/test/TestImports.hs
+++ b/test/TestImports.hs
@@ -1,45 +1,45 @@
-
-module TestImports (
- testImports
- ) where
-
--- Test file to test that we can do most things with a single import
-import Control.Applicative
-import qualified Data.Text as T
-
-import Common
-
-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] <- query_ conn "SELECT * FROM testimp" :: IO [TestType]
- [_v] <- query conn "SELECT ?+?" (3::Int,4::Int) :: IO [(Only 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)"
- [Only _v] <- query_ conn (Query q) :: IO [Only Int]
- return ()
- where
- q = T.concat ["SELECT * FROM ", "testimp"]
-
-test3 :: Connection -> IO ()
-test3 conn = do
- [_v] <- query conn "SELECT ?+?" (3::Int,4::Int) :: IO [(Only Int)]
- return ()
-
-testImports :: TestEnv -> Test
-testImports env = TestCase $ do
- test1
- withConnection ":memory:" test2
- test3 (conn env)
+
+module TestImports (
+ testImports
+ ) where
+
+-- Test file to test that we can do most things with a single import
+import Control.Applicative
+import qualified Data.Text as T
+
+import Common
+
+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] <- query_ conn "SELECT * FROM testimp" :: IO [TestType]
+ [_v] <- query conn "SELECT ?+?" (3::Int,4::Int) :: IO [(Only 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)"
+ [Only _v] <- query_ conn (Query q) :: IO [Only Int]
+ return ()
+ where
+ q = T.concat ["SELECT * FROM ", "testimp"]
+
+test3 :: Connection -> IO ()
+test3 conn = do
+ [_v] <- query conn "SELECT ?+?" (3::Int,4::Int) :: IO [(Only Int)]
+ return ()
+
+testImports :: TestEnv -> Test
+testImports env = TestCase $ do
+ test1
+ withConnection ":memory:" test2
+ test3 (conn env)
diff --git a/test/UserInstances.hs b/test/UserInstances.hs
index eb5bccb..e2c3a84 100644
--- a/test/UserInstances.hs
+++ b/test/UserInstances.hs
@@ -1,33 +1,33 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-
-module UserInstances (testUserFromField) where
-
-import Common
-import Data.Typeable (Typeable)
-import qualified Data.Text as T
-import Database.SQLite.Simple.FromField
-import Database.SQLite.Simple.Ok
-import Database.SQLite.Simple.ToField
-
-newtype MyType = MyType String deriving (Eq, Show, Typeable)
-
-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 (?)" (Only ("test string" :: String))
- [Only r] <- query_ conn "SELECT t FROM fromfield" :: IO [(Only MyType)]
- (MyType "fromField test string") @=? r
- execute_ conn "DELETE FROM fromfield"
- execute conn "INSERT INTO fromfield (t) VALUES (?)" (Only (MyType "test2"))
- [Only r] <- query_ conn "SELECT t FROM fromfield" :: IO [(Only String)]
- "toField test2" @=? r
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module UserInstances (testUserFromField) where
+
+import Common
+import Data.Typeable (Typeable)
+import qualified Data.Text as T
+import Database.SQLite.Simple.FromField
+import Database.SQLite.Simple.Ok
+import Database.SQLite.Simple.ToField
+
+newtype MyType = MyType String deriving (Eq, Show, Typeable)
+
+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 (?)" (Only ("test string" :: String))
+ [Only r] <- query_ conn "SELECT t FROM fromfield" :: IO [(Only MyType)]
+ (MyType "fromField test string") @=? r
+ execute_ conn "DELETE FROM fromfield"
+ execute conn "INSERT INTO fromfield (t) VALUES (?)" (Only (MyType "test2"))
+ [Only r] <- query_ conn "SELECT t FROM fromfield" :: IO [(Only String)]
+ "toField test2" @=? r