odbc 0.2.2 → 0.2.5
raw patch · 8 files changed
+599/−109 lines, 8 filesdep +attoparsecdep +hashable
Dependencies added: attoparsec, hashable
Files
- CHANGELOG +3/−0
- README.md +61/−5
- app/Main.hs +54/−26
- cbits/odbc.c +34/−3
- odbc.cabal +4/−2
- src/Database/ODBC/Internal.hs +237/−49
- src/Database/ODBC/SQLServer.hs +130/−13
- test/Main.hs +76/−11
CHANGELOG view
@@ -1,3 +1,6 @@+0.2.3:+ * Support WCHAR+ 0.2.2: * Accept smaller int/floats in bigger types
README.md view
@@ -43,6 +43,8 @@ driver is [here](https://docs.microsoft.com/en-us/sql/connect/odbc/linux-mac/installing-the-microsoft-odbc-driver-for-sql-server). +You can use the [SQL Server docker image](https://hub.docker.com/_/microsoft-mssql-server) to easily run SQL Server anywhere in a few seconds.+ I have tested the OS X instructions on my own machine. [This project's Dockerfile](https://github.com/fpco/odbc/blob/master/Dockerfile) follows setup instructions for Linux, and@@ -64,15 +66,42 @@ 123123123 Rows: 1 -## Common issues+## Check your package is working -Compilation on Linux/OS X may require a `odbcss.h` header file for type/constant definitions. To get this install the freetds package:+You can spin up a SQL Server in docker and connect to it with the+trivial binary `odbc` that comes with this package: -* [Linux example](https://github.com/fpco/odbc/blob/efe81f7c17f5ff4c1cf8937577b32f049c0dd62b/Dockerfile#L15).-* On OS X you can use `brew install freetds`.+```+$ docker run --net=host -e 'ACCEPT_EULA=Y' -e 'SA_PASSWORD=Passw0rd' -d mcr.microsoft.com/mssql/server:2017-CU8-ubuntu+Unable to find image 'mcr.microsoft.com/mssql/server:2017-CU8-ubuntu' locally+2017-CU8-ubuntu: Pulling from mssql/server+4fa80d7b805d: Pull complete+484dd0f2fbdc: Pull complete+47004b22ec62: Pull complete+b70745c852a2: Pull complete+718060832ef2: Pull complete+5594e4e5950b: Pull complete+5b67719e2956: Pull complete+7d648891de3f: Pull complete+e0d1b3db20c8: Pull complete+ded313a21911: Pull complete+Digest: sha256:e1708b7d3aaf4a693ef8785f15a8b4d082939681e373c4090fd0b294d1501e57+Status: Downloaded newer image for mcr.microsoft.com/mssql/server:2017-CU8-ubuntu+ba1ad8b726c7e958bad6d2f7b051514f218c3024984f388adab2d6bb7751ea90 -Windows should already have this file.+$ stack exec odbc 'DRIVER={ODBC Driver 17 for SQL Server};SERVER=127.0.0.1;Uid=SA;Pwd=Passw0rd;Encrypt=no'+> select 2 * 3;+6+Rows: 1+>+$+``` +## Common issues+++### Can't open lib 'ODBC Driver 13 for SQL Server'+ If you see an error like this: [unixODBC][Driver Manager]Can't open lib 'ODBC Driver 13 for SQL Server' : file not found@@ -81,6 +110,25 @@ installed version `17`, so change the string to `ODBC Driver 17 for SQL Server`. +If it still says this, you might have to configure an odbcinst.ini+file:++``` yaml+[ODBC Driver 17 for SQL Server]+Driver = <driver_path>+```++In Nix, this might be where <driver_path> is the result of evaluating+`${nixpkgs.unixODBCDrivers.msodbcsql17}/lib/libmsodbcsql-17.7.so.1.1"`.++Which would need the following packages available:++* nixpkgs.freetds+* nixpklgs.unixODBC+* nixpkgs.unixODBCDrivers.msodbcsql17++### Data source name not found and no default driver specified+ If you see an error like this: [unixODBC][Driver Manager]Data source name not found and no default driver specified@@ -90,6 +138,8 @@ quoted e.g. `"Driver=.."` instead of `Driver=..` due to silly shell scripting quoting issues. +## Terminating with uncaught exception of type+ If you see an error like this on OS X with driver version 17, ```@@ -99,3 +149,9 @@ ``` use driver 13 or [see here for more detail](https://github.com/fpco/odbc/issues/17).++## Contributors++* Spencer Janssen+* Yo Eight+* Marco Z
app/Main.hs view
@@ -3,10 +3,11 @@ -- | A helpful client for debugging connections. +module Main (main) where++import qualified Data.Text.IO as T import Control.Exception-import Data.List import qualified Data.Text as T-import qualified Data.Text.IO as T import qualified Database.ODBC.Internal as ODBC import System.Environment import System.IO@@ -19,7 +20,10 @@ case args of [connStr] -> do conn <- ODBC.connect (T.pack connStr)- repl conn+ term<- hIsTerminalDevice stdin+ if term+ then repl conn+ else piped conn _ -> error "usage: <connection string>" -- | Accepts a query/command and prints any results.@@ -32,33 +36,57 @@ hSetBuffering stdout LineBuffering catch (catch- (do count <- ODBC.stream c input output (0 :: Int)+ (do (_, count) <- ODBC.stream c input output (False, 0 :: Int) putStrLn ("Rows: " ++ show count)) (\case UserInterrupt -> pure () e -> throwIO e)) (\(e :: ODBC.ODBCException) -> putStrLn (displayException e)) repl c++-- | Accepts a single input and prints any results.+piped :: ODBC.Connection -> IO ()+piped c = do+ input <- T.hGetContents stdin+ hSetBuffering stdout LineBuffering+ catch+ (catch+ (do (_, count) <- ODBC.stream c input output (False, 0 :: Int)+ putStrLn ("Rows: " ++ show count))+ (\case+ UserInterrupt -> pure ()+ e -> throwIO e))+ (\(e :: ODBC.ODBCException) -> putStrLn (displayException e))+ repl c++prompt :: IO (Maybe T.Text)+prompt = do+ hSetBuffering stdout NoBuffering+ putStr "> "+ catch (fmap Just T.getLine) (\(_ :: IOException) -> pure Nothing)++output :: (Show b, Num b) => (a, b) -> [(ODBC.Column, ODBC.Value)] -> IO (ODBC.Step (Bool, b))+output (_printedHeaders, count) rowWithHeaders = do+ T.putStrLn+ ("[row " <> T.pack (show count) <> "]\n" <>+ T.unlines+ (map+ (\(name, value) ->+ ODBC.columnName name <> ": " <> T.pack (showColumn value))+ rowWithHeaders))+ pure (ODBC.Continue (True, count + 1)) where- prompt = do- hSetBuffering stdout NoBuffering- putStr "> "- catch (fmap Just T.getLine) (\(_ :: IOException) -> pure Nothing)- output count row = do- putStrLn (intercalate ", " (map showColumn row))- pure (ODBC.Continue (count + 1))- where- showColumn =- \case- ODBC.NullValue -> "NULL"- ODBC.TextValue t -> show t- ODBC.ByteStringValue bs -> show bs- ODBC.BinaryValue bs -> show bs- ODBC.BoolValue b -> show b- ODBC.DoubleValue d -> printf "%f" d- ODBC.FloatValue d -> printf "%f" d- ODBC.IntValue i -> show i- ODBC.DayValue d -> show d- ODBC.ByteValue b -> show b- ODBC.TimeOfDayValue v -> show v- ODBC.LocalTimeValue v -> show v+ showColumn =+ \case+ ODBC.NullValue -> "NULL"+ ODBC.TextValue t -> show t+ ODBC.ByteStringValue bs -> show bs+ ODBC.BinaryValue bs -> show bs+ ODBC.BoolValue b -> show b+ ODBC.DoubleValue d -> printf "%f" d+ ODBC.FloatValue d -> printf "%f" d+ ODBC.IntValue i -> show i+ ODBC.DayValue d -> show d+ ODBC.ByteValue b -> show b+ ODBC.TimeOfDayValue v -> show v+ ODBC.LocalTimeValue v -> show v
cbits/odbc.c view
@@ -4,14 +4,12 @@ #include <sql.h> #include <sqlext.h> #include <sqltypes.h>-#include <odbcss.h> #include <stdlib.h> #include <stdio.h> #include <string.h> #include <sql.h> #include <sqlext.h> #include <sqltypes.h>-#include <odbcss.h> #define FALSE 0 #define TRUE 1@@ -162,11 +160,44 @@ } ////////////////////////////////////////////////////////////////////////////////+// Params++SQLRETURN odbc_SQLBindParameter(+ EnvAndDbc* envAndDbc,+ SQLHSTMT* statement_handle,+ SQLUSMALLINT parameter_number,+ SQLSMALLINT value_type,+ SQLSMALLINT parameter_type,+ SQLULEN column_size,+ SQLPOINTER parameter_value_ptr,+ SQLLEN buffer_length,+ SQLLEN* buffer_length_ptr+ ) {+ RETCODE r = SQLBindParameter(+ *statement_handle,+ parameter_number,+ SQL_PARAM_INPUT,+ value_type,+ parameter_type,+ column_size,+ 0,+ parameter_value_ptr,+ buffer_length,+ buffer_length_ptr+ );+ if (r == SQL_ERROR)+ odbc_ProcessLogMessages(envAndDbc, SQL_HANDLE_STMT, *statement_handle, "odbc_SQLBindParameter", FALSE);+ return r;+}++//////////////////////////////////////////////////////////////////////////////// // Execute RETCODE odbc_SQLExecDirectW(EnvAndDbc *envAndDbc, SQLHSTMT *hstmt, SQLWCHAR *stmt, SQLINTEGER len){ RETCODE r = SQLExecDirectW(*hstmt, stmt, len);- if (r == SQL_ERROR) odbc_ProcessLogMessages(envAndDbc, SQL_HANDLE_STMT, *hstmt, "odbc_SQLExecDirectW", FALSE);+ if (r == SQL_ERROR) {+ odbc_ProcessLogMessages(envAndDbc, SQL_HANDLE_STMT, *hstmt, "odbc_SQLExecDirectW", FALSE);+ } return r; }
odbc.cabal view
@@ -5,7 +5,7 @@ suite runs on OS X, Windows and Linux. copyright: FP Complete 2018 maintainer: chrisdone@fpcomplete.com-version: 0.2.2+version: 0.2.5 license: BSD3 license-file: LICENSE build-type: Simple@@ -42,7 +42,9 @@ semigroups, transformers, template-haskell,- parsec+ parsec,+ hashable,+ attoparsec executable odbc hs-source-dirs: app
src/Database/ODBC/Internal.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -31,9 +32,15 @@ , query , Value(..) , Binary(..)+ , Column(..) -- * Streaming results , stream , Step(..)+ -- * Parameters+ , execWithParams+ , queryWithParams+ , streamWithParams+ , Param(..) -- * Exceptions , ODBCException(..) ) where@@ -46,9 +53,11 @@ import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Data.ByteString (ByteString)+import qualified Data.ByteString as S import qualified Data.ByteString.Unsafe as S import Data.Coerce import Data.Data+import Data.Hashable import Data.Int import Data.String import Data.Text (Text)@@ -96,17 +105,25 @@ -- | A value used for input/output with the database. data Value = TextValue !Text- -- ^ A Unicode text value.- | ByteStringValue !ByteString- -- ^ A vector of bytes. It might be binary, or a string, but we- -- don't know the encoding. Use 'Data.Text.Encoding.decodeUtf8' if- -- the string is UTF-8 encoded, or- -- 'Data.Text.Encoding.decodeUtf16LE' if it is UTF-16 encoded. For- -- other encodings, see the Haskell text-icu package. For raw- -- binary, see 'BinaryValue'.+ -- ^ A Unicode text value. This maps to nvarchar in SQL+ -- Server. Use this for text. | BinaryValue !Binary -- ^ Only a vector of bytes. Intended for binary data, not for- -- ASCII text.+ -- ASCII text. This maps to varbinary or binary in SQL Server.+ | ByteStringValue !ByteString+ -- ^ A vector of bytes. It might be binary, or a string, but we+ -- don't know the encoding. It maps to @varchar@ in the database+ -- in SQL Server.+ --+ -- DO NOT USE THIS TYPE IF YOU CAN AVOID IT: This type does not+ -- have a reliable transmission via parameters, and therefore is+ -- encoded within the query as @CHAR(x) + ...@ where x is a+ -- character outside of alphanumeric characters.+ --+ -- If you must: Use 'Data.Text.Encoding.decodeUtf8' if the string+ -- is UTF-8 encoded, or 'Data.Text.Encoding.decodeUtf16LE' if it+ -- is UTF-16 encoded. For other encodings, see the Haskell+ -- text-icu package. For raw binary, see 'BinaryValue'. | BoolValue !Bool -- ^ A simple boolean. | DoubleValue !Double@@ -128,6 +145,35 @@ deriving (Eq, Show, Typeable, Ord, Generic, Data) instance NFData Value +instance Hashable Value where+ hashWithSalt salt =+ \case+ TextValue x -> hashWithSalt salt x+ ByteStringValue x -> hashWithSalt salt x+ BinaryValue !(Binary b) -> hashWithSalt salt b+ BoolValue x -> hashWithSalt salt x+ DoubleValue x -> hashWithSalt salt x+ FloatValue x -> hashWithSalt salt x+ IntValue x -> hashWithSalt salt x+ ByteValue x -> hashWithSalt salt x+ -- TODO: faster versions of these?+ DayValue x -> hashWithSalt salt (show x)+ TimeOfDayValue !x -> hashWithSalt salt (show x)+ LocalTimeValue x -> hashWithSalt salt (show x)+ NullValue -> hashWithSalt salt ()++-- | A parameter to a query that corresponds to a ?.+--+-- Presently we only support variable sized values like text and byte+-- vectors.+--+-- @since 0.2.4+data Param+ = TextParam !Text -- ^ See docs for 'TextValue'.+ | BinaryParam !Binary -- ^ See docs for 'BinaryValue'.+ deriving (Eq, Show, Typeable, Ord, Generic, Data)+instance NFData Param+ -- | A simple newtype wrapper around the 'ByteString' type to use when -- you want to mean the @binary@ type of SQL, and render to binary -- literals e.g. @0xFFEF01@.@@ -153,6 +199,7 @@ , columnSize :: !SQLULEN , columnDigits :: !SQLSMALLINT , columnNull :: !SQLSMALLINT+ , columnName :: !Text } deriving (Show) --------------------------------------------------------------------------------@@ -221,42 +268,66 @@ withConnection str inner = withRunInIO $ \io -> withBound $ bracket (connect str) close (\h -> io (inner h)) - -- | Execute a statement on the database. exec :: MonadIO m => Connection -- ^ A connection to the database. -> Text -- ^ SQL statement. -> m ()-exec conn string =+exec conn string = execWithParams conn string mempty++-- | Same as 'exec' but with parameters.+--+-- @since 0.2.4+execWithParams ::+ MonadIO m+ => Connection -- ^ A connection to the database.+ -> Text -- ^ SQL query with ? inside.+ -> [Param] -- ^ Params matching the ? in the query string.+ -> m ()+execWithParams conn string params = withBound (withHDBC conn "exec"- (\dbc -> withExecDirect dbc string (fetchAllResults dbc)))+ (\dbc -> withExecDirect dbc string params (fetchAllResults dbc))) -- | Query and return a list of rows. query :: MonadIO m => Connection -- ^ A connection to the database. -> Text -- ^ SQL query.- -> m [[Value]]+ -> m [[(Column, Value)]] -- ^ A strict list of rows. This list is not lazy, so if you are -- retrieving a large data set, be aware that all of it will be -- loaded into memory.-query conn string =+query conn string = queryWithParams conn string mempty++-- | Same as 'query' but with parameters.+--+-- @since 0.2.4+queryWithParams ::+ MonadIO m+ => Connection -- ^ A connection to the database.+ -> Text -- ^ SQL query with ? inside.+ -> [Param] -- ^ Params matching the ? in the query string.+ -> m [[(Column, Value)]]+ -- ^ A strict list of rows. This list is not lazy, so if you are+ -- retrieving a large data set, be aware that all of it will be+ -- loaded into memory.+queryWithParams conn string params = withBound (withHDBC conn "query"- (\dbc -> withExecDirect dbc string (fetchStatementRows dbc)))+ (\dbc -> withExecDirect dbc string params (fetchStatementRows dbc))) -- | Stream results like a fold with the option to stop at any time. stream :: (MonadIO m, MonadUnliftIO m) => Connection -- ^ A connection to the database. -> Text -- ^ SQL query.- -> (state -> [Value] -> m (Step state))+ -> (state -> [(Column, Value)] -> m (Step state)) -- ^ A stepping function that gets as input the current @state@ and -- a row, returning either a new @state@ or a final @result@. -> state@@ -264,7 +335,25 @@ -- evaluated each iteration. -> m state -- ^ Final result, produced by the stepper function.-stream conn string step state = do+stream conn string step state = streamWithParams conn string mempty step state++-- | Same as 'stream' but with parameters.+--+-- @since 0.2.4+streamWithParams ::+ (MonadIO m, MonadUnliftIO m)+ => Connection -- ^ A connection to the database.+ -> Text -- ^ SQL query with ? inside.+ -> [Param] -- ^ Params matching the ? in the query string.+ -> (state -> [(Column, Value)] -> m (Step state))+ -- ^ A stepping function that gets as input the current @state@ and+ -- a row, returning either a new @state@ or a final @result@.+ -> state+ -- ^ A state that you can use for the computation. Strictly+ -- evaluated each iteration.+ -> m state+ -- ^ Final result, produced by the stepper function.+streamWithParams conn string params step state = do unlift <- askUnliftIO withBound (withHDBC@@ -274,6 +363,7 @@ withExecDirect dbc string+ params (fetchIterator dbc unlift step state))) --------------------------------------------------------------------------------@@ -293,24 +383,27 @@ pure v) -- | Execute a query directly without preparation.-withExecDirect :: Ptr EnvAndDbc -> Text -> (forall s. SQLHSTMT s -> IO a) -> IO a-withExecDirect dbc string cont =+withExecDirect :: Ptr EnvAndDbc -> Text -> [Param] -> (forall s. SQLHSTMT s -> IO a) -> IO a+withExecDirect dbc string params cont = withStmt dbc- (\stmt -> do- void- (assertSuccessOrNoData- dbc- "odbc_SQLExecDirectW"- (T.useAsPtr- string- (\wstring len ->- odbc_SQLExecDirectW- dbc- stmt- (coerce wstring)- (fromIntegral len))))- cont stmt)+ (withBindParameters+ dbc+ params+ (\stmt -> do+ void+ (assertSuccessOrNoData+ dbc+ "odbc_SQLExecDirectW"+ (T.useAsPtr+ string+ (\wstring len ->+ odbc_SQLExecDirectW+ dbc+ stmt+ (coerce wstring)+ (fromIntegral len))))+ cont stmt)) -- | Run the function with a statement. withStmt :: Ptr EnvAndDbc -> (forall s. SQLHSTMT s -> IO a) -> IO a@@ -325,13 +418,79 @@ withBound = liftIO . flip withAsyncBound wait --------------------------------------------------------------------------------+-- Binding params++-- | With parameters bounded. The fold is needed because the malloc'd+-- lengths passed in as the last parameter to SQLBindParameter is used+-- after calling SQLBindParameter, otherwise we could've just had a+-- loop.+withBindParameters ::+ Ptr EnvAndDbc -> [Param] -> (SQLHSTMT s -> IO a) -> (SQLHSTMT s -> IO a)+withBindParameters dbc ps cont =+ foldr+ (\(parameter_number, param) -> withBindParameter dbc parameter_number param)+ cont+ (zip [1 ..] ps)++-- | Bind a param to the statement, throwing on failure.+withBindParameter ::+ Ptr EnvAndDbc+ -> SQLUSMALLINT+ -> Param+ -> (SQLHSTMT s -> IO a)+ -> SQLHSTMT s -> IO a+withBindParameter dbc parameter_number param cont statement_handle = go param+ where+ go =+ \case+ TextParam text ->+ T.useAsPtr -- Pass as wide char UTF-16.+ text+ (\ptr len_in_chars ->+ runBind+ (coerce sql_c_wchar)+ (coerce sql_wlongvarchar)+ (fromIntegral len_in_chars) -- This is the length in chars.+ (coerce ptr)+ (fromIntegral len_in_chars * 2))+ -- Note the doubling here for length as bytes, for UTF-16.+ BinaryParam (Binary binary) ->+ S.useAsCStringLen -- Pass as "raw binary".+ binary+ (\(ptr, len) ->+ runBind+ (coerce sql_c_binary)+ sql_varbinary+ sql_ss_length_unlimited -- Note the unlimited column size here.+ (coerce ptr)+ (fromIntegral len))+ runBind value_type parameter_type column_size parameter_value_ptr buffer_length =+ withMalloc+ (\buffer_length_ptr -> do+ poke buffer_length_ptr buffer_length+ assertSuccess+ dbc+ "odbc_SQLBindParameter"+ (odbc_SQLBindParameter+ dbc+ statement_handle+ parameter_number+ value_type+ parameter_type+ column_size+ parameter_value_ptr+ buffer_length+ buffer_length_ptr)+ cont statement_handle)++-------------------------------------------------------------------------------- -- Internal data retrieval functions -- | Iterate over the rows in the statement. fetchIterator :: Ptr EnvAndDbc -> UnliftIO m- -> (state -> [Value] -> m (Step state))+ -> (state -> [(Column, Value)] -> m (Step state)) -> state -> SQLHSTMT s -> IO state@@ -384,7 +543,7 @@ (fetchAllResults dbc stmt) -- | Fetch all rows from a statement.-fetchStatementRows :: Ptr EnvAndDbc -> SQLHSTMT s -> IO [[Value]]+fetchStatementRows :: Ptr EnvAndDbc -> SQLHSTMT s -> IO [[(Column,Value)]] fetchStatementRows dbc stmt = do SQLSMALLINT cols <- withMalloc@@ -450,21 +609,25 @@ size <- peek sizep digits <- peek digitsp isnull <- peek nullp+ namelen' <- peek namelenp+ name <- T.fromPtr namep (fromIntegral namelen') evaluate Column { columnType = typ , columnSize = size , columnDigits = digits , columnNull = isnull+ , columnName = name })))))))) -- | Pull data for the given column.-getData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> Column -> IO Value-getData dbc stmt i col =+getData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> Column -> IO (Column, Value)+getData dbc stmt i col = fmap (col, ) $ if | colType == sql_longvarchar -> getBytesData dbc stmt i | colType == sql_varchar -> getBytesData dbc stmt i | colType == sql_char -> getBytesData dbc stmt i | colType == sql_wvarchar -> getTextData dbc stmt i+ | colType == sql_wchar -> getTextData dbc stmt i | colType == sql_wlongvarchar -> getTextData dbc stmt i | colType == sql_binary -> getBinaryData dbc stmt i | colType == sql_varbinary -> getBinaryData dbc stmt i@@ -655,16 +818,21 @@ getGuid dbc stmt column = do uninterruptibleMask_ (do bufferp <- callocBytes odbcGuidBytes- void- (getTypedData- dbc- stmt- sql_c_binary- column- (coerce bufferp)- (SQLLEN odbcGuidBytes))- !bs <- S.unsafePackMallocCStringLen (bufferp, odbcGuidBytes)- evaluate (BinaryValue (Binary bs)))+ copiedBytes <-+ getTypedData+ dbc+ stmt+ sql_c_binary+ column+ (coerce bufferp)+ (SQLLEN odbcGuidBytes)+ case copiedBytes of+ Nothing -> do+ free bufferp+ pure NullValue+ Just {} -> do+ !bs <- S.unsafePackMallocCStringLen (bufferp, odbcGuidBytes)+ evaluate (BinaryValue (Binary bs))) -- | Get the column's data as a vector of CHAR. getBytesData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO Value@@ -808,7 +976,7 @@ ptr <- odbc_error dbc string <- if nullPtr == ptr- then pure ""+ then pure "No error message given from ODBC." else peekCString ptr throwIO (UnsuccessfulReturnCode label (coerce retcode) string) @@ -868,7 +1036,7 @@ newtype SQLLEN = SQLLEN Int64 deriving (Show, Eq, Storable, Num) -- https://github.com/Microsoft/ODBC-Specification/blob/753d7e714b7eab9eaab4ad6105fdf4267d6ad6f6/Windows/inc/sqltypes.h#L65..L65-newtype SQLULEN = SQLULEN Word64 deriving (Show, Eq, Storable)+newtype SQLULEN = SQLULEN Word64 deriving (Show, Eq, Storable, Num) -- https://github.com/Microsoft/ODBC-Specification/blob/753d7e714b7eab9eaab4ad6105fdf4267d6ad6f6/Windows/inc/sqltypes.h#L60 newtype SQLINTEGER = SQLINTEGER Int64 deriving (Show, Eq, Storable, Num)@@ -909,6 +1077,19 @@ foreign import ccall "odbc odbc_SQLAllocStmt" odbc_SQLAllocStmt :: Ptr EnvAndDbc -> IO (SQLHSTMT s) +foreign import ccall "odbc odbc_SQLBindParameter"+ odbc_SQLBindParameter+ :: Ptr EnvAndDbc -- ^ envAndDbc+ -> SQLHSTMT s -- ^ statement_handle+ -> SQLUSMALLINT -- ^ parameter_number+ -> SQLSMALLINT -- ^ value_type+ -> SQLSMALLINT -- ^ parameter_type+ -> SQLULEN -- ^ column_size+ -> SQLPOINTER -- ^ parameter_value_ptr+ -> SQLLEN -- ^ buffer_length+ -> Ptr SQLLEN -- ^ buffer_length_ptr+ -> IO RETCODE+ foreign import ccall "odbc odbc_SQLFreeStmt" odbc_SQLFreeStmt :: SQLHSTMT s -> IO () @@ -1152,3 +1333,10 @@ sql_c_time :: SQLCTYPE sql_c_time = coerce sql_time++-- Unlimited size+--+-- <https://docs.microsoft.com/en-us/sql/relational-databases/native-client-odbc-api/sqlbindparameter?view=sql-server-ver15#binding-parameters-for-sql-character-types>+-- <https://docs.rs/odbc-sys/0.6.3/odbc_sys/constant.SQL_SS_LENGTH_UNLIMITED.html>+sql_ss_length_unlimited :: SQLULEN+sql_ss_length_unlimited = 0
src/Database/ODBC/SQLServer.hs view
@@ -47,15 +47,28 @@ , Internal.ODBCException(..) + -- * Parametrized queries+ , splitQueryParametrized+ , joinQueryParametrized+ -- * Debugging , renderQuery+ , queryParts+ , Part(..)+ , renderParts+ , renderPart+ , renderValue+ , renderedAndParams ) where +import Control.Applicative import Control.DeepSeq import Control.Exception+import Control.Monad import Control.Monad.IO.Class import Control.Monad.IO.Unlift+import qualified Data.Attoparsec.Text as Atto import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L@@ -64,6 +77,7 @@ import Data.Fixed import Data.Foldable import Data.Int+import Data.Maybe import Data.Monoid (Monoid, (<>)) import Data.Semigroup (Semigroup) import Data.Sequence (Seq)@@ -75,7 +89,7 @@ import Data.Time import Data.Word import Database.ODBC.Conversion-import Database.ODBC.Internal (Value(..), Connection)+import Database.ODBC.Internal (Param(..), Value(..), Connection) import qualified Database.ODBC.Internal as Internal import qualified Formatting import Formatting ((%))@@ -294,16 +308,20 @@ instance ToSql LT.Text where toSql = toSql . TextValue . LT.toStrict --- | Corresponds to TEXT (non-Unicode) of SQL Server. For proper--- BINARY, see the 'Binary' type.+-- | AVOID THIS TYPE: Corresponds to TEXT/VARCHAR (non-Unicode) of SQL+-- Server. For proper BINARY, see the 'Binary' type. For proper text,+-- use 'Text'. instance ToSql ByteString where toSql = toSql . ByteStringValue +-- | Corresponds to TEXT/VARCHAR (non-Unicode) of SQL+-- Server. For proper BINARY, see the 'Binary' type. For proper text,+-- use 'Text'. instance ToSql Internal.Binary where toSql = toSql . BinaryValue --- | Corresponds to TEXT (non-Unicode) of SQL Server. For Unicode, use--- the 'Text' type.+-- | AVOID THIS TYPE: Corresponds to TEXT (non-Unicode) of SQL+-- Server. For Unicode, use the 'Text' type. instance ToSql L.ByteString where toSql = toSql . ByteStringValue . L.toStrict @@ -390,11 +408,12 @@ => Connection -- ^ A connection to the database. -> Query -- ^ SQL query. -> m [row]-query c (Query ps) = do- rows <- Internal.query c (renderParts (toList ps))- case mapM fromRow rows of+query c q = do+ rows <- Internal.queryWithParams c rendered params+ case mapM (fromRow . map snd) rows of Right rows' -> pure rows' Left e -> liftIO (throwIO (Internal.DataRetrievalError e))+ where (rendered, params) = renderedAndParams q -- | Render a query to a plain text string. Useful for debugging and -- testing.@@ -414,15 +433,17 @@ -- evaluated each iteration. -> m state -- ^ Final result, produced by the stepper function.-stream c (Query ps) cont nil =- Internal.stream+stream c q cont nil =+ Internal.streamWithParams c- (renderParts (toList ps))+ rendered+ params (\state row ->- case fromRow row of+ case fromRow (map snd row) of Left e -> liftIO (throwIO (Internal.DataRetrievalError e)) Right row' -> cont state row') nil+ where (rendered, params) = renderedAndParams q -- | Execute a statement on the database. exec ::@@ -430,11 +451,48 @@ => Connection -- ^ A connection to the database. -> Query -- ^ SQL statement. -> m ()-exec c (Query ps) = Internal.exec c (renderParts (toList ps))+exec c q = Internal.execWithParams c rendered params+ where+ (rendered, params) = renderedAndParams q -------------------------------------------------------------------------------- -- Query building +-- | Splits a query up into a parametrized text with ? and the params+-- used.+renderedAndParams :: Query -> (Text, [Param])+renderedAndParams q = (renderParts parts', params)+ where+ parts' =+ map+ (\case+ ValuePart v+ | Just {} <- valueToParam v -> TextPart "?"+ p -> p)+ parts+ params =+ mapMaybe+ (\case+ ValuePart v+ | Just p <- valueToParam v -> Just p+ _ -> Nothing)+ parts+ parts = toList (queryParts q)++-- | Convert a value to a parameter, if possible. Values that aren't+-- parameters will be inlined in the query string directly. SQL Server+-- is capable of caching constants, so this isn't an issue.+valueToParam :: Value -> Maybe Param+valueToParam =+ \case+ TextValue v | not (T.null v) -> pure $ TextParam v+ BinaryValue v@(Internal.Binary s) | not (S.null s) -> pure $ BinaryParam v+ _ -> Nothing++-- | Access the parts of a query.+queryParts :: Query -> Seq Part+queryParts (Query parts) = parts+ -- | Convert a list of parts into a query. renderParts :: [Part] -> Text renderParts = T.concat . map renderPart@@ -517,3 +575,62 @@ -- on. Everything else is escaped. allowedChar :: Char -> Bool allowedChar c = (isAlphaNum c && isAscii c) || elem c (" ,.-_" :: [Char])++-- | Splits a query up into a parametrized text with ? and the values+-- used.+--+-- For if you're working with an API that assumes queries and+-- parameters are separated.+--+-- @since 0.2.4+splitQueryParametrized :: Query -> (Text, [Value])+splitQueryParametrized q = (text, params)+ where+ text =+ foldMap+ (\case+ TextPart t -> t+ ValuePart {} -> "?")+ parts+ params =+ mapMaybe+ (\case+ TextPart {} -> Nothing+ ValuePart value -> pure value)+ parts+ parts = toList (queryParts q)++-- | Join a query with ? in it with the values into a Query. Checks+-- that they match.+--+-- @since 0.2.4+joinQueryParametrized :: Text -> [Value] -> Either String Query+joinQueryParametrized text0 params0 = do+ parts <- Atto.parseOnly partsParser text0+ (parts', remainingParams) <-+ foldM+ (\(q, params) ->+ \case+ TextF text -> pure (q <> pure (TextPart text), params)+ ParamF ->+ case params of+ [] -> Left "too many ? in format string or missing param"+ (v:params') -> pure (q <> pure (ValuePart v), params'))+ (mempty, params0)+ parts+ unless (null remainingParams) (Left "not enough ? or extraneous param")+ pure (Query parts')++--------------------------------------------------------------------------------+-- A simple ?-syntax parser++data FPart+ = TextF !Text+ | ParamF+ deriving (Show, Eq)++partsParser :: Atto.Parser [FPart]+partsParser = (<>) <$> fmap pure part1 <*> many (param <|> part1)+ where+ param = (Atto.char '?' *> pure ParamF) Atto.<?> "?"+ part1 = (TextF <$> Atto.takeWhile1 (/= '?')) Atto.<?> "SQL text without ?"
test/Main.hs view
@@ -28,7 +28,6 @@ import Data.Char import Data.Functor.Identity import Data.Int-import Data.Monoid import Data.Ratio import Data.String import Data.Text (Text)@@ -39,7 +38,7 @@ import Database.ODBC.Conversion (FromValue(..)) import Database.ODBC.Internal (Value (..), Connection, ODBCException(..), Step(..), Binary) import qualified Database.ODBC.Internal as Internal-import Database.ODBC.SQLServer (Datetime2(..), Smalldatetime(..), ToSql(..))+import Database.ODBC.SQLServer (splitQueryParametrized, joinQueryParametrized, Datetime2(..), Smalldatetime(..), ToSql(..)) import qualified Database.ODBC.SQLServer as SQLServer import Database.ODBC.TH (partsParser, Part(..)) import System.Environment@@ -66,7 +65,10 @@ describe "Regression tests" regressions describe "Data retrieval" dataRetrieval describe "Big data" bigData)- describe "Database.ODBC.SQLServer" (describe "Conversion to SQL" conversionTo)+ describe+ "Database.ODBC.SQLServer"+ (do describe "Conversion to SQL" conversionTo+ describe "Parametrized" parametrizedSpec) describe "Database.ODBC.TH" thparser thparser :: SpecWith ()@@ -126,6 +128,7 @@ bigData = do roundtrip @Text "2MB text" "Text" "ntext" (T.replicate (1024*1024*2) "A") roundtrip @ByteString "2MB binary" "ByteString" "text" (S.replicate (1024*1024*2) 97)+ roundtrip @Binary "2MB binary" "Binary" "varbinary(max)" (SQLServer.Binary (S.replicate 10 97)) conversionTo :: Spec conversionTo = do@@ -163,7 +166,7 @@ quickCheckRoundtrip @ByteString "ByteString" ("varchar(" <> (show maxStringLen) <> ")") quickCheckRoundtrip @TestBinary "ByteString" ("binary(" <> (show maxStringLen) <> ")") quickCheckRoundtrip @Binary "ByteString" ("varbinary(" <> (show maxStringLen) <> ")")- quickCheckRoundtripEx @TestGUID False "GUID" "uniqueidentifier"+ quickCheckRoundtrip @TestGUID "GUID" "uniqueidentifier" -- Regression tests against https://github.com/fpco/odbc/issues/30 connectivity :: Spec connectivity = do@@ -203,7 +206,7 @@ rows <- Internal.query c "SELECT * FROM test" Internal.close c shouldBe- rows+ (map (map snd) rows) [ [ (IntValue 123) , (ByteStringValue "abc") , (BoolValue True)@@ -228,7 +231,7 @@ "DROP TABLE IF EXISTS no_such_table" (\s _ -> pure (Stop s)) []- shouldBe (rows1 ++ rows2) [])+ shouldBe (map (map snd) (rows1 ++ rows2)) []) quickCheckInternalRoundtrip "Int" "bigint"@@ -364,15 +367,15 @@ (liftIO (putStr (unlines- [ "Expected: " ++ show input- , "Actual: " ++ show result+ [ "Expected: " ++ take 80 (show input)+ , "Actual: " ++ take 80 (show result) , "Query was: " ++ show q ]))) monitor (counterexample (unlines- [ "Expected: " ++ show input- , "Actual: " ++ show result+ [ "Expected: " ++ take 80 (show input)+ , "Actual: " ++ take 80 (show result) , "Query was: " ++ T.unpack (SQLServer.renderQuery q) ]))@@ -468,7 +471,7 @@ result :: Either String t result = case rows of- Right [[x]] ->+ Right [[(_,x)]] -> case unpack x of Nothing -> Left "Couldn't unpack value." Just v -> pure v@@ -531,6 +534,68 @@ lookupEnvUnquote :: String -> IO (Maybe [Char]) lookupEnvUnquote = fmap (fmap strip) . lookupEnv where strip = reverse . dropWhile (=='"') . reverse . dropWhile (=='"')++--------------------------------------------------------------------------------+-- Parametrized queries++parametrizedSpec :: Spec+parametrizedSpec = do+ it+ "splitQueryParametrized"+ (do shouldBe (splitQueryParametrized "select 123") ("select 123", [])+ shouldBe+ (splitQueryParametrized ("select " <> toSql (123 :: Int)))+ ("select ?", [IntValue 123])+ shouldBe+ (splitQueryParametrized+ ("select " <> toSql (123 :: Int) <> " from y where x = " <>+ toSql ("abc" :: Text)))+ ("select ? from y where x = ?", [IntValue 123, TextValue "abc"]))+ it+ "joinQueryParametrized"+ (do shouldBe+ (uncurry joinQueryParametrized ("?select 123", []))+ (Left "SQL text without ?: Failed reading: takeWhile1")+ shouldBe+ (uncurry joinQueryParametrized ("select 123", []))+ (Right "select 123")+ shouldBe+ (uncurry+ joinQueryParametrized+ ("select ? from y where x = ?", [IntValue 123, TextValue "abc"]))+ (Right+ ("select " <> toSql (123 :: Int) <> " from y where x = " <>+ toSql ("abc" :: Text)))+ shouldBe+ (uncurry+ joinQueryParametrized+ ("select ? from y where x = ", [IntValue 123, TextValue "abc"]))+ (Left "not enough ? or extraneous param")+ shouldBe+ (uncurry+ joinQueryParametrized+ ("select ? from y where x = ?", [IntValue 123]))+ (Left "too many ? in format string or missing param"))+ beforeAll+ connectWithString+ (afterAll+ Internal.close+ (it+ "Multiple params"+ (\c ->+ property+ (\text bytes -> do+ rows :: [[Value]] <-+ SQLServer.query+ c+ ("SELECT " <> toSql (text :: Text) <> ", " <>+ toSql (SQLServer.Binary bytes :: Binary))+ shouldBe+ rows+ [ [ TextValue text+ , BinaryValue (SQLServer.Binary bytes)+ ]+ ])))) -------------------------------------------------------------------------------- -- Orphan instances