diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,6 @@ +0.2.3: + * Support WCHAR + 0.2.2: * Accept smaller int/floats in bigger types diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 = +``` + +In Nix, this might be where 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 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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: " -- | 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 diff --git a/cbits/odbc.c b/cbits/odbc.c --- a/cbits/odbc.c +++ b/cbits/odbc.c @@ -4,14 +4,12 @@ #include #include #include -#include #include #include #include #include #include #include -#include #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; } diff --git a/odbc.cabal b/odbc.cabal --- a/odbc.cabal +++ b/odbc.cabal @@ -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 diff --git a/src/Database/ODBC/Internal.hs b/src/Database/ODBC/Internal.hs --- a/src/Database/ODBC/Internal.hs +++ b/src/Database/ODBC/Internal.hs @@ -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 +-- +-- +-- +sql_ss_length_unlimited :: SQLULEN +sql_ss_length_unlimited = 0 diff --git a/src/Database/ODBC/SQLServer.hs b/src/Database/ODBC/SQLServer.hs --- a/src/Database/ODBC/SQLServer.hs +++ b/src/Database/ODBC/SQLServer.hs @@ -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 ?" diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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