diff --git a/Database/SQLite3.hsc b/Database/SQLite3.hsc --- a/Database/SQLite3.hsc +++ b/Database/SQLite3.hsc @@ -16,6 +16,8 @@ step, reset, finalize, + bindParameterCount, + bindParameterName, bindBlob, bindDouble, bindInt, @@ -30,7 +32,8 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BSI -import qualified Data.ByteString.UTF8 as UTF8 +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Data.Typeable import Foreign import Foreign.C @@ -81,7 +84,7 @@ data SQLData = SQLInteger Int64 | SQLFloat Double - | SQLText String + | SQLText T.Text | SQLBlob BS.ByteString | SQLNull deriving (Eq, Show, Typeable) @@ -165,7 +168,7 @@ errmsg (Database database) = do message <- errmsgC database byteString <- BS.packCString message - return $ UTF8.toString byteString + return $ T.unpack $ T.decodeUtf8 byteString sqlError :: Maybe Database -> String -> Error -> IO a sqlError maybeDatabase functionName error = do @@ -182,7 +185,7 @@ openC :: CString -> Ptr (Ptr ()) -> IO Int openError :: String -> IO (Either Database Error) openError path = do - BS.useAsCString (UTF8.fromString path) + BS.useAsCString (T.encodeUtf8 $ T.pack path) (\path -> do alloca (\database -> do error <- openC path database @@ -216,7 +219,7 @@ prepareC :: Ptr () -> CString -> Int -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> IO Int prepareError :: Database -> String -> IO (Either Statement Error) prepareError (Database database) text = do - BS.useAsCString (UTF8.fromString text) + BS.useAsCString (T.encodeUtf8 $ T.pack text) (\text -> do alloca (\statement -> do error <- prepareC database text (-1) statement nullPtr @@ -273,6 +276,34 @@ ErrorOK -> return () _ -> sqlError Nothing "finalize" error + +foreign import ccall "sqlite3_bind_parameter_count" + bindParameterCountC :: Ptr () -> IO Int + +-- | Find the number SQL parameters in a prepared statement. +bindParameterCount :: Statement -> IO Int +bindParameterCount (Statement stmt) = do + bindParameterCountC stmt + +maybeNullCString :: CString -> IO (Maybe BS.ByteString) +maybeNullCString s = + if s == nullPtr then return Nothing else fmap Just (BS.packCString s) + +foreign import ccall "sqlite3_bind_parameter_name" + bindParameterNameC :: Ptr () -> Int -> IO CString + +-- | Return the N-th SQL parameter name. +-- +-- Named parameters are returned as-is. E.g. \":v\" is returned as +-- @Just \":v\"@. Unnamed parameters, however, are converted to +-- @Nothing@. +-- +-- Note that the column index starts at 1, not 0. +bindParameterName :: Statement -> Int -> IO (Maybe String) +bindParameterName (Statement stmt) colNdx = do + mn <- bindParameterNameC stmt colNdx >>= maybeNullCString + return (mn >>= return . T.unpack . T.decodeUtf8) + foreign import ccall "sqlite3_bind_blob" bindBlobC :: Ptr () -> Int -> Ptr () -> Int -> Ptr () -> IO Int bindBlobError :: Statement -> Int -> BS.ByteString -> IO Error @@ -344,16 +375,16 @@ foreign import ccall "sqlite3_bind_text" bindTextC :: Ptr () -> Int -> CString -> Int -> Ptr () -> IO Int -bindTextError :: Statement -> Int -> String -> IO Error +bindTextError :: Statement -> Int -> T.Text -> IO Error bindTextError (Statement statement) parameterIndex text = do - byteString <- return $ UTF8.fromString text + byteString <- return $ T.encodeUtf8 text size <- return $ BS.length byteString BS.useAsCString byteString (\dataC -> do error <- bindTextC statement parameterIndex dataC size (intPtrToPtr (-1)) return $ decodeError error) -bindText :: Statement -> Int -> String -> IO () +bindText :: Statement -> Int -> T.Text -> IO () bindText statement parameterIndex text = do error <- bindTextError statement parameterIndex text case error of @@ -407,11 +438,11 @@ foreign import ccall "sqlite3_column_text" columnTextC :: Ptr () -> Int -> IO CString -columnText :: Statement -> Int -> IO String +columnText :: Statement -> Int -> IO T.Text columnText (Statement statement) columnIndex = do text <- columnTextC statement columnIndex byteString <- BS.packCString text - return $ UTF8.toString byteString + return $ T.decodeUtf8 byteString foreign import ccall "sqlite3_column_count" columnCountC :: Ptr () -> IO Int diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2009 Dan Knapp +Copyright (c) 2012 Irene Knapp Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation diff --git a/direct-sqlite.cabal b/direct-sqlite.cabal --- a/direct-sqlite.cabal +++ b/direct-sqlite.cabal @@ -1,16 +1,17 @@ name: direct-sqlite -version: 1.1 -cabal-version: >= 1.6 +version: 2.0 build-type: Simple license: BSD3 license-file: LICENSE -copyright: Copyright (c) 2009 Dan Knapp -author: Dan Knapp -maintainer: dankna@gmail.com -homepage: http://www.dankna.com/software/ -bug-reports: http://www.dankna.com/issues/create/ +copyright: Copyright (c) 2012 Irene Knapp +author: Irene Knapp +maintainer: ireney.knapp@gmail.com +homepage: http://ireneknapp.com/software/ +bug-reports: http://ireneknapp.com/issues/create/ category: Database synopsis: Low-level binding to SQLite3. Includes UTF8 and BLOB support. +Cabal-version: >= 1.10 +Build-type: Simple description: This package is not very different from the other SQLite3 bindings out there, but it fixes a few deficiencies I was finding. It is not as complete as bindings-sqlite3, @@ -18,15 +19,43 @@ from the database. In particular, it supports strings encoded as UTF8, and BLOBs represented as ByteStrings. + Version 2.0 uses Text for strings instead of String. + + Version 1.1.0.1 switches to the Faction packaging system and makes no other + changes. + Version 1.1 adds the SQLite amalgamation file (version 3.7.5) to the project, so that there are no external dependencies. Source-Repository head - type: darcs - location: http://dankna.com/software/darcs/direct-sqlite/ + type: git + location: git://github.com/IreneKnapp/direct-sqlite.git Library exposed-modules: Database.SQLite3 c-sources: sqlite3.c - build-depends: bytestring, base >= 4.1 && < 5, utf8-string >= 0.3.5 + build-depends: base >= 4.1 && < 5, + bytestring >= 0.9.2.1 && < 1, + text >= 0.11.2.2 && < 1 + default-language: Haskell2010 + +test-suite test + type: exitcode-stdio-1.0 + + hs-source-dirs: test + main-is: Main.hs + + ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind + + extensions: NamedFieldPuns + , OverloadedStrings + , Rank2Types + , RecordWildCards + + build-depends: base + , base16-bytestring + , bytestring + , HUnit + , direct-sqlite + , text diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,85 @@ + +import Control.Exception (bracket) +import Control.Monad (when) +import System.Exit (exitFailure) +import System.IO +import Test.HUnit + +import Database.SQLite3 + +data TestEnv = + TestEnv { + conn :: Database + -- ^ Database shared by all the tests + , withConn :: forall a. (Database -> IO a) -> IO a + -- ^ Bracket for spawning additional connections + } + +tests :: [TestEnv -> Test] +tests = + [ TestLabel "Simple" . testSimplest + , TestLabel "Params" . testBindParamCounts + , TestLabel "Params" . testBindParamName + ] + +-- Simplest SELECT +testSimplest :: TestEnv -> Test +testSimplest TestEnv{..} = TestCase $ do + stmt <- prepare conn "SELECT 1+1" + Row <- step stmt + res <- column stmt 0 + Done <- step stmt + finalize stmt + assertEqual "1+1" (SQLInteger 2) res + +-- Test bindParameterCount +testBindParamCounts :: TestEnv -> Test +testBindParamCounts TestEnv{..} = TestCase $ do + nParams <- bracket (prepare conn "SELECT $a") finalize bindParameterCount + assertEqual "single $a" 1 nParams + nParams <- bracket (prepare conn "SELECT (?1+?1+?1+?2+?3)") finalize bindParameterCount + assertEqual "3 unique ?NNNs" 3 nParams + nParams <- bracket (prepare conn "SELECT (?+?+?)") finalize bindParameterCount + assertEqual "3 positional" 3 nParams + +-- Test bindParameterName +testBindParamName :: TestEnv -> Test +testBindParamName TestEnv{..} = TestCase $ do + bracket (prepare conn "SELECT :v + :v2") finalize (testNames [Just ":v", Just ":v2"]) + bracket (prepare conn "SELECT ?1 + ?1") finalize (testNames [Just "?1"]) + bracket (prepare conn "SELECT ?1 + ?2") finalize (testNames [Just "?1", Just "?2"]) + bracket (prepare conn "SELECT ? + ?") finalize (testNames [Nothing, Nothing]) + bracket (prepare conn "SELECT $1 + $2") finalize (testNames [Just "$1", Just "$2"]) + where + testNames names stmt = do + count <- bindParameterCount stmt + assertEqual "count match" count (length names) + mapM_ (\(ndx,expecting) -> do + name <- bindParameterName stmt ndx + assertEqual "name match" expecting name) $ zip [1..] names + +-- | 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 Database +testConnect = open ":memory:" + +withTestEnv :: (TestEnv -> IO a) -> IO a +withTestEnv cb = + withConn $ \conn -> + cb TestEnv + { conn = conn + , withConn = withConn + } + 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