sqlite-simple 0.4.5.2 → 0.4.6.0
raw patch · 13 files changed
+462/−82 lines, 13 filesdep ~direct-sqlite
Dependency ranges changed: direct-sqlite
Files
- Database/SQLite/Simple.hs +149/−28
- Database/SQLite/Simple/FromField.hs +32/−13
- Database/SQLite/Simple/Internal.hs +1/−1
- README.markdown +2/−0
- changelog +9/−0
- sqlite-simple.cabal +5/−5
- test/Common.hs +3/−3
- test/Errors.hs +16/−6
- test/Main.hs +13/−5
- test/ParamConv.hs +167/−4
- test/Simple.hs +35/−2
- test/TestImports.hs +28/−13
- test/UserInstances.hs +2/−2
Database/SQLite/Simple.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, GeneralizedNewtypeDeriving, ScopedTypeVariables, GADTs #-} ------------------------------------------------------------------------------ -- |@@ -22,6 +22,12 @@ -- ** Parameter substitution -- $subst + -- *** Positional parameters+ -- $substpos++ -- *** Named parameters+ -- $substnamed+ -- *** Type inference -- $inference @@ -49,6 +55,7 @@ , Base.SQLData(..) , Statement , ColumnIndex(..)+ , NamedParam(..) -- * Connections , open , close@@ -57,13 +64,16 @@ -- * Queries that return results , query , query_+ , queryNamed , lastInsertRowId -- * Queries that stream results , fold , fold_+ , foldNamed -- * Statements that do not return results , execute , execute_+ , executeNamed , field -- * Low-level statement API for stream access and prepared statements , openStatement@@ -97,6 +107,7 @@ import Database.SQLite.Simple.Internal import Database.SQLite.Simple.Ok import Database.SQLite.Simple.ToRow (ToRow(..))+import Database.SQLite.Simple.ToField (ToField(..)) import Database.SQLite.Simple.FromRow -- | An SQLite prepared statement.@@ -106,13 +117,21 @@ newtype ColumnIndex = ColumnIndex BaseD.ColumnIndex deriving (Eq, Ord, Enum, Num, Real, Integral) +data NamedParam where+ (:=) :: (ToField v) => T.Text -> v -> NamedParam++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]+ fmtMessage :: !String+ , fmtQuery :: !Query+ , fmtParams :: ![String] } deriving (Eq, Show, Typeable) instance Exception FormatError@@ -176,6 +195,30 @@ 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 ()@@ -226,20 +269,34 @@ withStatement conn query = bracket (openStatement conn query) closeStatement -- A version of 'withStatement' which binds parameters.-withStatementP :: (ToRow params) => Connection -> Query -> params -> (Statement -> IO a) -> IO a-withStatementP conn template params action =+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 =- withStatementP conn template qs $ \(Statement stmt) ->+ withStatementParams conn template qs $ \(Statement stmt) -> void . Base.step $ stmt @@ -262,7 +319,7 @@ query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r] query conn templ qs =- withStatementP conn templ qs $ \stmt ->+ withStatementParams conn templ qs $ \stmt -> doFoldToList stmt -- | A version of 'query' that does not perform query substitution.@@ -270,12 +327,25 @@ query_ conn query = withStatement conn query doFoldToList +-- | A version of 'query' where the query parameters (placeholders)+-- are named.+queryNamed :: (FromRow r) => Connection -> Query -> [NamedParam] -> IO [r]+queryNamed conn templ params =+ withStatementNamedParams conn templ params $ \stmt -> doFoldToList 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.@@ -296,7 +366,7 @@ -> (a -> row -> IO a) -> IO a fold conn query params initalState action =- withStatementP conn query params $ \stmt ->+ withStatementParams conn query params $ \stmt -> doFold stmt initalState action -- | A version of 'fold' which does not perform parameter substitution.@@ -310,6 +380,19 @@ withStatement conn query $ \stmt -> doFold 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 stmt initalState action+ doFold :: (FromRow row) => Statement -> a -> (a -> row -> IO a) -> IO a doFold stmt initState action = loop initState@@ -369,12 +452,13 @@ lastInsertRowId :: Connection -> IO Int64 lastInsertRowId (Connection c) = BaseD.lastInsertRowId c -fmtError :: String -> Query -> [Base.SQLData] -> a-fmtError msg q xs = throw FormatError {- fmtMessage = msg- , fmtQuery = q- , fmtParams = map show xs- }+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 =@@ -448,16 +532,28 @@ -- parameters that change, this library uses SQLite's parameter -- binding query substitution capability. ----- The 'Query' template accepted by 'query' and 'execute' can contain--- any number of \"@?@\" characters. Both 'query' and 'execute'--- accept a third argument, typically a tuple. When constructing the--- real query to execute, these functions replace the first \"@?@\" in--- the template with the first element of the tuple, the second--- \"@?@\" with the second element, and so on. If necessary, each--- tuple element will be quoted and escaped prior to substitution;--- this defeats the single most common injection vector for malicious--- data.+-- 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 > ?@@ -478,11 +574,34 @@ -- 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 ----- This library restricts parameter substitution to work only with--- \"@?@\" characters. SQLite natively supports several other--- syntaxes for binding query parameters. Unsupported parameters will--- be rejected and a 'FormatError' will be thrown.+-- 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 --@@ -516,6 +635,8 @@ -- -- > execute conn "insert into users (first_name) values (?)" -- > ["Nuala"]+--+-- Or you can use named parameters which do not have this restriction. -- $result --
Database/SQLite/Simple/FromField.hs view
@@ -39,11 +39,12 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB-import Data.Int (Int16, Int32, Int64)+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@@ -54,18 +55,18 @@ -- | Exception thrown if conversion from a SQL value to a Haskell -- value fails.-data ResultError = Incompatible { errSQLType :: String- , errHaskellType :: String- , errMessage :: String }+data ResultError = Incompatible { errSQLType :: !String+ , errHaskellType :: !String+ , errMessage :: !String } -- ^ The SQL and Haskell types are not compatible.- | UnexpectedNull { errSQLType :: String- , errHaskellType :: String- , errMessage :: String }+ | 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 }+ | 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@@ -109,6 +110,9 @@ 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 @@ -124,20 +128,35 @@ 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 "need a float"+ 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 "need a float"+ 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 "need a float"+ fromField f = returnError ConversionFailed f "expecting an SQLInteger column type" instance FromField T.Text where fromField (Field (SQLText txt) _) = Ok txt
Database/SQLite/Simple/Internal.hs view
@@ -43,7 +43,7 @@ -- discouraged. newtype Connection = Connection { connectionHandle :: Base.Database } -data ColumnOutOfBounds = ColumnOutOfBounds { errorColumnIndex :: Int }+data ColumnOutOfBounds = ColumnOutOfBounds { errorColumnIndex :: !Int } deriving (Eq, Show, Typeable) instance Exception ColumnOutOfBounds
README.markdown view
@@ -23,6 +23,8 @@ [](http://travis-ci.org/nurpax/sqlite-simple) +[](https://coveralls.io/r/nurpax/sqlite-simple?branch=master)+ Installation ------------
changelog view
@@ -1,3 +1,12 @@+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
sqlite-simple.cabal view
@@ -1,13 +1,13 @@ Name: sqlite-simple-Version: 0.4.5.2+Version: 0.4.6.0 Synopsis: Mid-Level SQLite client library Description: Mid-level SQLite client library, based on postgresql-simple. .- Main documentation: <docs/Database-SQLite-Simple.html Database.SQLite.Simple>+ Main documentation (with examples): <docs/Database-SQLite-Simple.html Database.SQLite.Simple> .- For more info, browse to <http://github.com/nurpax/sqlite-simple>- for examples & more information.+ You can view the project page at <http://github.com/nurpax/sqlite-simple>+ for more information. License: BSD3 License-file: LICENSE@@ -48,7 +48,7 @@ blaze-textual, bytestring >= 0.9, containers,- direct-sqlite >= 2.3.4 && < 2.4,+ direct-sqlite >= 2.3.13 && < 2.4, text >= 0.11, time, transformers
test/Common.hs view
@@ -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- , withConn :: forall a. (Connection -> IO a) -> IO a- -- ^ Bracket for spawning additional connections }
test/Errors.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} module Errors ( testErrorsColumns , testErrorsInvalidParams+ , testErrorsInvalidNamedParams , testErrorsWithStatement , testErrorsColumnName ) where@@ -17,22 +18,22 @@ assertResultErrorCaught :: IO a -> Assertion assertResultErrorCaught action = do- catch (action >> return False) (\(_ :: ResultError) -> return True) >>=+ catch (action >> return False) (\((!_) :: ResultError) -> return True) >>= assertBool "assertResultError exc" assertFormatErrorCaught :: IO a -> Assertion assertFormatErrorCaught action = do- catch (action >> return False) (\(_ :: FormatError) -> return True) >>=+ catch (action >> return False) (\((!_) :: FormatError) -> return True) >>= assertBool "assertFormatError exc" assertSQLErrorCaught :: IO a -> Assertion assertSQLErrorCaught action = do- catch (action >> return False) (\(_ :: SQLError) -> return True) >>=+ catch (action >> return False) (\((!_) :: SQLError) -> return True) >>= assertBool "assertSQLError exc" assertOOBCaught :: IO a -> Assertion assertOOBCaught action = do- catch (action >> return False) (\(_ :: ArrayException) -> return True) >>=+ catch (action >> return False) (\((!_) :: ArrayException) -> return True) >>= assertBool "assertOOBCaught exc" testErrorsColumns :: TestEnv -> Test@@ -62,7 +63,6 @@ (do [Only _t1] <- query_ conn "SELECT b FROM cols_bools" :: IO [Only Bool] return ()) - testErrorsInvalidParams :: TestEnv -> Test testErrorsInvalidParams TestEnv{..} = TestCase $ do execute_ conn "CREATE TABLE invparams (id INTEGER PRIMARY KEY, t TEXT)"@@ -75,6 +75,16 @@ -- 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]) testErrorsWithStatement :: TestEnv -> Test testErrorsWithStatement TestEnv{..} = TestCase $ do
test/Main.hs view
@@ -15,6 +15,7 @@ import Statement import Debug import DirectSqlite+import TestImports tests :: [TestEnv -> Test] tests =@@ -27,12 +28,22 @@ , TestLabel "Simple" . testSimpleUTCTime , TestLabel "Simple" . testSimpleUTCTimeTZ , TestLabel "Simple" . testSimpleUTCTimeParams+ , TestLabel "Simple" . testSimpleQueryCov+ , TestLabel "Simple" . testSimpleStrings+ , 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 "Utf8" . testUtf8Simplest@@ -44,6 +55,7 @@ , TestLabel "Statement" . testPreparedStatements , TestLabel "Debug" . testDebugTracing , TestLabel "Direct" . testDirectSqlite+ , TestLabel "Imports" . testImports ] -- | Action for connecting to the database that will be used for testing.@@ -55,11 +67,7 @@ withTestEnv :: (TestEnv -> IO a) -> IO a withTestEnv cb =- withConn $ \conn ->- cb TestEnv- { conn = conn- , withConn = withConn- }+ withConn $ \conn -> cb TestEnv { conn = conn } where withConn = bracket testConnect close
test/ParamConv.hs view
@@ -1,12 +1,24 @@+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} module ParamConv (- testParamConvInt+ testParamConvNull+ , testParamConvInt+ , testParamConvIntWidths+ , testParamConvIntWidthsFromField , testParamConvFloat , testParamConvBools- , testParamConvDateTime) where+ , testParamConvDateTime+ , testParamConvFromRow+ , testParamConvToRow+ , testParamConvComposite+ , testParamNamed) where -import Data.Int-import Data.Time+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 @@ -15,16 +27,31 @@ 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"@@ -41,6 +68,56 @@ [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]@@ -79,3 +156,89 @@ 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++
test/Simple.hs view
@@ -10,12 +10,18 @@ , testSimpleUTCTime , testSimpleUTCTimeTZ , testSimpleUTCTimeParams+ , testSimpleQueryCov+ , testSimpleStrings ) where import qualified Data.Text as T-import Data.Time (UTCTime, Day)-import Common+import qualified Data.Text.Lazy as LT+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.Time (UTCTime, Day) +import Common+ -- Simplest SELECT testSimpleOnePlusOne :: TestEnv -> Test testSimpleOnePlusOne TestEnv{..} = TestCase $ do@@ -195,3 +201,30 @@ 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+ q @=? q+ 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"
test/TestImports.hs view
@@ -1,30 +1,45 @@ -module TestImports where+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 Database.SQLite.Simple +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 -foo :: IO ()-foo = do+test1 :: IO ()+test1 = do conn <- open ":memory:"- [Only _v] <- query_ conn "SELECT * FROM test" :: IO [Only Int]- [_v] <- query_ conn "SELECT * FROM test" :: IO [(Int,Int)]- [_v] <- query_ conn "SELECT * FROM test" :: IO [TestType]- [_v] <- query conn "SELECT ?+?" (3::Int,4::Int):: IO [(Only Int)]+ 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 -foo2 :: IO ()-foo2 = do- conn <- open ":memory:"+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]- close conn+ return () where- q = T.concat ["SELECT * FROM ", "test"]+ 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)
test/UserInstances.hs view
@@ -26,8 +26,8 @@ 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)]- assertEqual "fromField" (MyType "fromField test string") r+ (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)]- assertEqual "toield" "toField test2" r+ "toField test2" @=? r