odbc 0.0.0 → 0.0.1
raw patch · 10 files changed
+3001/−12 lines, 10 filesdep +QuickCheckdep +asyncdep +basenew-component:exe:odbc
Dependencies added: QuickCheck, async, base, bytestring, containers, deepseq, formatting, hspec, odbc, optparse-applicative, text, time, unliftio-core, weigh
Files
- LICENSE +2/−2
- README.md +83/−2
- app/Main.hs +63/−0
- bench/Space.hs +91/−0
- cbits/odbc.c +314/−0
- odbc.cabal +59/−8
- src/Database/ODBC/Conversion.hs +310/−0
- src/Database/ODBC/Internal.hs +1083/−0
- src/Database/ODBC/SQLServer.hs +458/−0
- test/Main.hs +538/−0
LICENSE view
@@ -1,4 +1,4 @@-Copyright Chris Done (c) 2018+Copyright FP Complete (c) 2017 All rights reserved. @@ -13,7 +13,7 @@ disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Chris Done nor the names of other+ * Neither the name of FP Complete nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission.
README.md view
@@ -1,3 +1,84 @@-# odbc+# odbc [](https://travis-ci.org/fpco/odbc) [](https://ci.appveyor.com/project/chrisdone/odbc-0os0b) -Currently being prepared for release, reserving the namespace here.+Haskell binding to the ODBC API, with a strong emphasis on stability,+testing and simplicity.++## Platform and database support++The following database drivers are tested against in CI:++* Microsoft SQL Server 2017++The following operating systems are tested against in CI:++* Windows [](https://ci.appveyor.com/project/chrisdone/odbc-0os0b)+* Linux [](https://travis-ci.org/fpco/odbc)++I develop and test this library on OS X, but currently do not have a+reliable way to run Microsoft SQL Server on Travis CI.++## How ODBC works++ODBC is a C API that is split into a *manager* and a *driver*.++On Windows, there is an ODBC manager that comes with the OS. On Linux+and OS X, the unixODBC package provides the same functionality.++Separately, for each database type, you have driver packages. When you+provide a connection string, like this:++```+ODBC_TEST_CONNECTION_STRING='DRIVER={ODBC Driver 13 for SQL Server};SERVER=127.0.0.1;Uid=SA;Pwd=Passw0rd;Encrypt=no'+```++The `DRIVER` tells the ODBC API which library to use. In this case,+it's the recent SQL Server driver provided by Microsoft. Then, ODBC+functions like `SQLDriverConnectW` will call that library.++## How to connect to Microsoft SQL Server++In recent years, Microsoft has released binary drivers for SQL Server+for Windows, Linux and OS X, with a guide for each operating+system. That guide for the latest and greatest official Microsoft+driver is+[here](https://docs.microsoft.com/en-us/sql/connect/odbc/linux-mac/installing-the-microsoft-odbc-driver-for-sql-server).++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+[the AppVeyor file](https://github.com/fpco/odbc/blob/master/appveyor.yml)+follows the setup instructions for Windows.++There is a test program that comes with the package called `odbc`+which accepts a connection string as its argument. You can use this to+test your connection easily.++(Use `17` instead of `13` if that's the driver you installed.)++ $ stack exec odbc 'DRIVER={ODBC Driver 13 for SQL Server};SERVER=192.168.99.101;Uid=SA;Pwd=Passw0rd;Encrypt=no'+ > create table foo (i int)+ Rows: 0+ > insert into foo values (123123123)+ Rows: 0+ > select * from foo+ 123123123+ Rows: 1++## Common issues++If you see an error like this:++ [unixODBC][Driver Manager]Can't open lib 'ODBC Driver 13 for SQL Server' : file not found++Then you might be trying to use the wrong driver. You might have+installed version `17`, so change the string to `ODBC Driver 17 for+SQL Server`.++If you see an error like this:++ [unixODBC][Driver Manager]Data source name not found and no default driver specified++This is a terrible error message. If passing your DSN via a shell+environment variable or argument, check that your input string isn't+quoted e.g. `"Driver=.."` instead of `Driver=..` due to silly shell+scripting quoting issues.
+ app/Main.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings, LambdaCase #-}++-- | A helpful client for debugging connections.++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+import Text.Printf++-- | Main entry point.+main :: IO ()+main = do+ args <- getArgs+ case args of+ [connStr] -> do+ conn <- ODBC.connect (T.pack connStr)+ repl conn+ _ -> error "usage: <connection string>"++-- | Accepts a query/command and prints any results.+repl :: ODBC.Connection -> IO ()+repl c = do+ result <- prompt+ case result of+ Nothing -> pure ()+ Just input -> do+ hSetBuffering stdout LineBuffering+ catch+ (catch+ (do count <- ODBC.stream c input output (0 :: Int)+ putStrLn ("Rows: " ++ show count))+ (\case+ UserInterrupt -> pure ()+ e -> throwIO e))+ (\(e :: ODBC.ODBCException) -> putStrLn (displayException e))+ repl c+ where+ prompt = do+ hSetBuffering stdout NoBuffering+ putStr "> "+ catch (fmap Just T.getLine) (\(_ :: IOException) -> pure Nothing)+ output count row = do+ putStrLn (intercalate ", " (map (maybe "NULL" showColumn) row))+ pure (ODBC.Continue (count + 1))+ where+ showColumn =+ \case+ 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
+ bench/Space.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}++-- | Measure space usage of the odbc library.++module Main where++import Control.Concurrent.Async+import Data.Text (Text)+import qualified Data.Text as T+import qualified Database.ODBC.Internal as Internal+import qualified Database.ODBC.SQLServer as SQLServer+import System.Environment+import Weigh++-- | Weigh maps.+main :: IO ()+main = do+ mlabels <- lookupEnv "ODBC_WEIGH_TESTS"+ case mlabels of+ Nothing ->+ mainWith+ (do setColumns [Case, Allocated, Max, Live, GCs]+ (mapM_ snd tests))+ Just labels ->+ mainWith+ (do setColumns [Case, Allocated, Max, Live, GCs]+ (mapM_ snd (filter ((flip elem (words labels)) . fst) tests)))++tests :: [(String, Weigh ())]+tests = [("connection", connection)+ ,("querying", querying)]++querying :: Weigh ()+querying =+ sequence_+ [ action+ ("Query: " ++ show n ++ " times")+ (runs+ n+ (do c <- connectWithString+ _ <-+ SQLServer.query c "SELECT 12345678, N'Hello, World!'" :: IO [( Int+ , Text)]+ Internal.close c))+ | n <- [1, 10, 20]+ ]++connection :: Weigh ()+connection = do+ sequence_+ [ action+ ("Connect/disconnect: " ++ show n ++ " times")+ (runs+ n+ (do c <- connectWithString+ Internal.close c))+ | n <- [1, 10, 20]+ ]+ sequence_+ [ action+ ("Connect/disconnect: " ++ show n ++ " n threads")+ (replicateConcurrently+ n+ (do c <- connectWithString+ Internal.close c))+ | n <- [1, 10, 20]+ ]++-- | Run n times.+runs :: Int -> IO () -> IO ()+runs 0 _ = pure ()+runs !n m = m >> runs (n-1) m++connectWithString :: IO Internal.Connection+connectWithString = do+ mconnStr <- lookupEnvUnquote "ODBC_TEST_CONNECTION_STRING"+ case mconnStr of+ Nothing ->+ error+ "Need ODBC_TEST_CONNECTION_STRING environment variable.\n\+ \Example:\n\+ \ODBC_TEST_CONNECTION_STRING='DRIVER={ODBC Driver 13 for SQL Server};SERVER=127.0.0.1;Uid=SA;Pwd=Passw0rd;Encrypt=no'"+ Just connStr -> Internal.connect (T.pack connStr)++-- | I had trouble passing in environment variables via Docker on+-- Travis without the value coming in with quotes around it.+lookupEnvUnquote :: String -> IO (Maybe [Char])+lookupEnvUnquote = fmap (fmap strip) . lookupEnv+ where strip = reverse . dropWhile (=='"') . reverse . dropWhile (=='"')
+ cbits/odbc.c view
@@ -0,0 +1,314 @@+#ifdef _WIN32+#include <windows.h>+#endif+#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+#define MAXBUFLEN 512++// Just a way of grouping together these two dependent resources. It's+// probably not a good idea to free up an environment before freeing a+// database. So, we put them together so that they can be allocated+// and freed atomically.+typedef struct EnvAndDbc {+ SQLHENV *env;+ SQLHDBC *dbc;+ char *error;+} EnvAndDbc;++char *odbc_error(EnvAndDbc *envAndDbc){+ return envAndDbc->error;+}++void odbc_ProcessLogMessages(EnvAndDbc *envAndDbc, SQLSMALLINT plm_handle_type, SQLHANDLE plm_handle, char *logstring, int ConnInd);++////////////////////////////////////////////////////////////////////////////////+// Alloc/dealloc env++SQLHENV *odbc_SQLAllocEnv(){+ SQLHENV *henv = malloc(sizeof *henv);+ *henv = SQL_NULL_HENV;+ RETCODE retcode = SQLAllocHandle (SQL_HANDLE_ENV, NULL, henv);+ if ((retcode != SQL_SUCCESS_WITH_INFO) && (retcode != SQL_SUCCESS)) {+ free(henv);+ return NULL;+ } else {+ return henv;+ }+}++void odbc_SQLFreeEnv(SQLHENV *henv){+ if(henv != NULL && *henv != SQL_NULL_HENV) {+ SQLFreeHandle(SQL_HANDLE_ENV, *henv);+ free(henv);+ }+}++RETCODE odbc_SetEnvAttr(SQLHENV *henv){+ return+ SQLSetEnvAttr(*henv, SQL_ATTR_ODBC_VERSION, (SQLPOINTER)SQL_OV_ODBC3, SQL_IS_INTEGER);+}++////////////////////////////////////////////////////////////////////////////////+// Alloc/dealloc dbc++SQLHDBC *odbc_SQLAllocDbc(SQLHENV *henv){+ SQLHDBC *hdbc = malloc(sizeof *hdbc);+ *hdbc = SQL_NULL_HDBC;+ RETCODE retcode = SQLAllocHandle (SQL_HANDLE_DBC, *henv, hdbc);+ if ((retcode != SQL_SUCCESS_WITH_INFO) && (retcode != SQL_SUCCESS)) {+ free(hdbc);+ return NULL;+ } else {+ return hdbc;+ }+}++void odbc_SQLFreeDbc(SQLHDBC *hdbc){+ if(hdbc != NULL && *hdbc != SQL_NULL_HDBC) {+ SQLFreeHandle(SQL_HANDLE_DBC, *hdbc);+ free(hdbc);+ }+}++////////////////////////////////////////////////////////////////////////////////+// Allocate/dealloc env-and-database++EnvAndDbc *odbc_AllocEnvAndDbc(){+ SQLHENV *env = odbc_SQLAllocEnv();+ if (env == NULL) {+ return NULL;+ } else {+ int retcode = odbc_SetEnvAttr(env);+ if ((retcode != SQL_SUCCESS_WITH_INFO) && (retcode != SQL_SUCCESS)) {+ free(env);+ return NULL;+ } else {+ SQLHDBC *dbc = odbc_SQLAllocDbc(env);+ if (dbc == NULL) {+ return NULL;+ } else {+ EnvAndDbc *envAndDbc = malloc(sizeof *envAndDbc);+ envAndDbc->env = env;+ envAndDbc->dbc = dbc;+ envAndDbc->error = NULL;+ return envAndDbc;+ }+ }+ }+}++void odbc_FreeEnvAndDbc(EnvAndDbc *envAndDbc){+ free(envAndDbc->error);+ odbc_SQLFreeDbc(envAndDbc->dbc);+ odbc_SQLFreeEnv(envAndDbc->env);+ free(envAndDbc);+}++////////////////////////////////////////////////////////////////////////////////+// Connect/disconnect++RETCODE odbc_SQLDriverConnect(EnvAndDbc *envAndDbc, SQLCHAR *connString, SQLSMALLINT len){+ SQLSMALLINT ignored = 0;+ RETCODE r = SQLDriverConnect(+ *(envAndDbc->dbc),+ NULL,+ connString,+ len,+ NULL,+ 0,+ &ignored,+ SQL_DRIVER_NOPROMPT);+ if (r == SQL_ERROR)+ odbc_ProcessLogMessages(envAndDbc, SQL_HANDLE_DBC, *(envAndDbc->dbc), "odbc_SQLDriverConnect", FALSE);+ return r;+}++void odbc_SQLDisconnect(EnvAndDbc *envAndDbc){+ SQLDisconnect(*(envAndDbc->dbc));+}++////////////////////////////////////////////////////////////////////////////////+// Alloc/dealloc statement++SQLHSTMT *odbc_SQLAllocStmt(EnvAndDbc *envAndDbc){+ SQLHSTMT *hstmt = malloc(sizeof *hstmt);+ *hstmt = SQL_NULL_HSTMT;+ RETCODE retcode = SQLAllocHandle (SQL_HANDLE_STMT, *(envAndDbc->dbc), hstmt);+ if ((retcode != SQL_SUCCESS_WITH_INFO) && (retcode != SQL_SUCCESS)) {+ free(hstmt);+ return NULL;+ } else {+ return hstmt;+ }+}++void odbc_SQLFreeStmt(SQLHSTMT *hstmt){+ if(hstmt != NULL && *hstmt != SQL_NULL_HSTMT) {+ SQLFreeHandle(SQL_HANDLE_STMT, *hstmt);+ free(hstmt);+ }+}++////////////////////////////////////////////////////////////////////////////////+// 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);+ return r;+}++////////////////////////////////////////////////////////////////////////////////+// Fetch row++RETCODE odbc_SQLFetch(EnvAndDbc *envAndDbc, SQLHSTMT *hstmt){+ RETCODE r = SQLFetch(*hstmt);+ if (r == SQL_ERROR) odbc_ProcessLogMessages(envAndDbc, SQL_HANDLE_STMT, *hstmt, "odbc_SQLFetch", FALSE);+ return r;+}++RETCODE odbc_SQLMoreResults(EnvAndDbc *envAndDbc, SQLHSTMT *hstmt){+ RETCODE r = SQLMoreResults(*hstmt);+ if (r == SQL_ERROR) odbc_ProcessLogMessages(envAndDbc, SQL_HANDLE_STMT, *hstmt, "odbc_SQLMoreResults", FALSE);+ return r;+}++////////////////////////////////////////////////////////////////////////////////+// Get fields++RETCODE odbc_SQLGetData(EnvAndDbc *envAndDbc,+ SQLHSTMT *hstmt,+ SQLUSMALLINT col,+ SQLSMALLINT targetType,+ SQLPOINTER buffer,+ SQLLEN bufferLen,+ SQLLEN * resultLen){+ RETCODE r = SQLGetData(*hstmt, col, targetType, buffer, bufferLen, resultLen);+ if (r == SQL_ERROR) odbc_ProcessLogMessages(envAndDbc, SQL_HANDLE_STMT, *hstmt, "odbc_SQLGetData", FALSE);+ return r;+}++SQLRETURN odbc_SQLDescribeColW(+ SQLHSTMT *StatementHandle,+ SQLUSMALLINT ColumnNumber,+ SQLWCHAR * ColumnName,+ SQLSMALLINT BufferLength,+ SQLSMALLINT * NameLengthPtr,+ SQLSMALLINT * DataTypePtr,+ SQLULEN * ColumnSizePtr,+ SQLSMALLINT * DecimalDigitsPtr,+ SQLSMALLINT * NullablePtr){+ return SQLDescribeColW(+ *StatementHandle,+ ColumnNumber,+ ColumnName,+ BufferLength,+ NameLengthPtr,+ DataTypePtr,+ ColumnSizePtr,+ DecimalDigitsPtr,+ NullablePtr);+}++////////////////////////////////////////////////////////////////////////////////+// Get columns++RETCODE odbc_SQLNumResultCols(SQLHSTMT *hstmt, SQLSMALLINT *cols){+ return SQLNumResultCols(*hstmt, cols);+}++////////////////////////////////////////////////////////////////////////////////+// Logs++void odbc_ProcessLogMessages(EnvAndDbc *envAndDbc, SQLSMALLINT plm_handle_type, SQLHANDLE plm_handle, char *logstring, int ConnInd) {+ RETCODE plm_retcode = SQL_SUCCESS;+ UCHAR plm_szSqlState[MAXBUFLEN] = "";+ SDWORD plm_pfNativeError = 0L;+ SWORD plm_pcbErrorMsg = 0;+ SQLSMALLINT plm_cRecNmbr = 1;++ // Temporary buffer for each message+ char *msg[MAXBUFLEN];++ // Reset the error buffer+ free(envAndDbc->error);+ envAndDbc->error = NULL;+ unsigned long errors_strlen = 0;++ while (plm_retcode != SQL_NO_DATA_FOUND) {+ plm_retcode = SQLGetDiagRec(plm_handle_type, plm_handle, plm_cRecNmbr,+ plm_szSqlState, &plm_pfNativeError, (SQLCHAR *)msg,+ MAXBUFLEN - 1, &plm_pcbErrorMsg);+ unsigned long msg_strlen = strlen((const char*)msg);+ // If there is something to copy, copy it onto the error buffer.+ if (msg_strlen > 0) {+ envAndDbc->error = realloc(envAndDbc->error, errors_strlen + msg_strlen + 1);+ strncpy(envAndDbc->error + errors_strlen, (const char*) msg, msg_strlen);+ errors_strlen += msg_strlen;+ }+ plm_cRecNmbr++;+ }+}++////////////////////////////////////////////////////////////////////////////////+// Accessors for DATE_STRUCT++SQLSMALLINT DATE_STRUCT_year(DATE_STRUCT *d){+ return d->year;+}+SQLUSMALLINT DATE_STRUCT_month(DATE_STRUCT *d){+ return d->month;+}+SQLUSMALLINT DATE_STRUCT_day(DATE_STRUCT *d){+ return d->day;+}++////////////////////////////////////////////////////////////////////////////////+// Accessors for TIME_STRUCT++SQLUSMALLINT TIME_STRUCT_hour(TIME_STRUCT *t){+ return t->hour;+}+SQLUSMALLINT TIME_STRUCT_minute(TIME_STRUCT *t){+ return t->minute;+}+SQLUSMALLINT TIME_STRUCT_second(TIME_STRUCT *t){+ return t->second;+}++////////////////////////////////////////////////////////////////////////////////+// Accessors for TIMESTAMP_STRUCT++SQLSMALLINT TIMESTAMP_STRUCT_year(TIMESTAMP_STRUCT *t){+ return t->year;+}+SQLUSMALLINT TIMESTAMP_STRUCT_month(TIMESTAMP_STRUCT *t){+ return t->month;+}+SQLUSMALLINT TIMESTAMP_STRUCT_day(TIMESTAMP_STRUCT *t){+ return t->day;+}+SQLUSMALLINT TIMESTAMP_STRUCT_hour(TIMESTAMP_STRUCT *t){+ return t->hour;+}+SQLUSMALLINT TIMESTAMP_STRUCT_minute(TIMESTAMP_STRUCT *t){+ return t->minute;+}+SQLUSMALLINT TIMESTAMP_STRUCT_second(TIMESTAMP_STRUCT *t){+ return t->second;+}+SQLUINTEGER TIMESTAMP_STRUCT_fraction(TIMESTAMP_STRUCT *t){+ return t->fraction;+}
odbc.cabal view
@@ -1,16 +1,67 @@ name: odbc-version: 0.0.0-synopsis: TBA-description: Currently being prepared for release, reserving the namespace here.+synopsis: Haskell binding to the ODBC API, aimed at SQL Server driver+description: Haskell binding to the ODBC API. This has been tested+ against the Microsoft SQL Server ODBC drivers. Its test+ suite runs on OS X, Windows and Linux.+copyright: FP Complete 2018+maintainer: chrisdone@fpcomplete.com+version: 0.0.1 license: BSD3 license-file: LICENSE-author: Chris Done-maintainer: chrisdone@fpcomplete.com-copyright: 2017 Chris Done-category: Database build-type: Simple extra-source-files: README.md cabal-version: >=1.10 library- default-language: Haskell2010+ hs-source-dirs: src+ ghc-options: -Wall -O2+ cc-options: -Wall -Wconversion+ exposed-modules:+ Database.ODBC.Internal+ Database.ODBC.SQLServer+ Database.ODBC.Conversion+ default-language: Haskell2010+ if os(mingw32) || os(win32)+ extra-libraries: odbc32+ else+ extra-libraries: odbc+ c-sources: cbits/odbc.c+ include-dirs: cbits+ build-depends:+ base >= 4.7 && < 5,+ deepseq,+ async,+ bytestring,+ text,+ unliftio-core,+ formatting >= 6.3.1,+ containers,+ time++executable odbc+ hs-source-dirs: app+ main-is: Main.hs+ ghc-options: -Wall -O2 -threaded+ default-language: Haskell2010+ build-depends:+ base >= 4.7 && < 5,+ odbc,+ bytestring,+ text,+ optparse-applicative++test-suite test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ build-depends: base, text, odbc, hspec, QuickCheck, bytestring, time+ ghc-options: -threaded+ hs-source-dirs: test+ main-is: Main.hs++benchmark space+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ build-depends: base, odbc, weigh, text, async+ ghc-options: -threaded -O2+ hs-source-dirs: bench+ main-is: Space.hs
+ src/Database/ODBC/Conversion.hs view
@@ -0,0 +1,310 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}++-- | Conversion conveniences.++module Database.ODBC.Conversion+ ( FromValue(..)+ , FromRow(..)+ ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as L+import Data.Functor.Identity+import Data.Text (Text)+import qualified Data.Text.Lazy as LT+import Data.Time+import Data.Word+import Database.ODBC.Internal++--------------------------------------------------------------------------------+-- Conversion from SQL++-- | Convert from a 'Value' to a regular Haskell value.+class FromValue a where+ fromValue :: Maybe Value -> Either String a+ -- ^ The 'String' is used for a helpful error message.++-- | Expect a value to be non-null.+withNonNull ::+ FromValue a => (Value -> Either String a) -> Maybe Value -> Either String a+withNonNull f =+ \case+ Nothing -> Left "Unexpected NULL for value"+ Just v -> f v++instance FromValue a => FromValue (Maybe a) where+ fromValue =+ \case+ Nothing -> pure Nothing+ Just v -> fmap Just (fromValue (Just v))++instance FromValue Value where+ fromValue = withNonNull pure++instance FromValue Text where+ fromValue =+ withNonNull+ (\case+ TextValue x -> pure (id x)+ v -> Left ("Expected Text, but got: " ++ show v))++instance FromValue LT.Text where+ fromValue =+ withNonNull+ (\case+ TextValue x -> pure (LT.fromStrict x)+ v -> Left ("Expected Text, but got: " ++ show v))++instance FromValue ByteString where+ fromValue =+ withNonNull+ (\case+ ByteStringValue x -> pure (id x)+ v -> Left ("Expected ByteString, but got: " ++ show v))++instance FromValue Binary where+ fromValue =+ withNonNull+ (\case+ BinaryValue x -> pure (id x)+ v -> Left ("Expected Binary, but got: " ++ show v))++instance FromValue L.ByteString where+ fromValue =+ withNonNull+ (\case+ ByteStringValue x -> pure (L.fromStrict x)+ v -> Left ("Expected ByteString, but got: " ++ show v))++instance FromValue Int where+ fromValue =+ withNonNull+ (\case+ IntValue x -> pure (id x)+ v -> Left ("Expected Int, but got: " ++ show v))++instance FromValue Double where+ fromValue =+ withNonNull+ (\case+ DoubleValue x -> pure (id x)+ v -> Left ("Expected Double, but got: " ++ show v))++instance FromValue Float where+ fromValue =+ withNonNull+ (\case+ FloatValue x -> pure (realToFrac x)+ v -> Left ("Expected Float, but got: " ++ show v))++instance FromValue Word8 where+ fromValue =+ withNonNull+ (\case+ ByteValue x -> pure x+ v -> Left ("Expected Byte, but got: " ++ show v))++instance FromValue Bool where+ fromValue =+ withNonNull+ (\case+ BoolValue x -> pure (id x)+ v -> Left ("Expected Bool, but got: " ++ show v))++instance FromValue Day where+ fromValue =+ withNonNull+ (\case+ DayValue x -> pure (id x)+ v -> Left ("Expected Day, but got: " ++ show v))++instance FromValue TimeOfDay where+ fromValue =+ withNonNull+ (\case+ TimeOfDayValue x -> pure (id x)+ v -> Left ("Expected TimeOfDay, but got: " ++ show v))++instance FromValue LocalTime where+ fromValue =+ withNonNull+ (\case+ LocalTimeValue x -> pure (id x)+ v -> Left ("Expected LocalTime, but got: " ++ show v))++--------------------------------------------------------------------------------+-- Producing rows++-- | For producing rows from a list of column values.+--+-- You can get a row of a single type like 'Text' or a list+-- e.g. @[Maybe Value]@ if you don't know what you're dealing with, or+-- a tuple e.g. @(Text, Int, Bool)@.+class FromRow r where+ fromRow :: [Maybe Value] -> Either String r++instance FromValue v => FromRow (Maybe v) where+ fromRow [v] = fromValue v+ fromRow _ = Left "Unexpected number of fields in row"++instance FromValue v => FromRow (Identity v) where+ fromRow [v] = fmap Identity (fromValue v)+ fromRow _ = Left "Unexpected number of fields in row"++instance FromRow [Maybe Value] where+ fromRow = pure++instance FromRow Value where+ fromRow [v] = fromValue v+ fromRow _ = Left "Unexpected number of fields in row"++instance FromRow Text where+ fromRow [v] = fromValue v+ fromRow _ = Left "Unexpected number of fields in row"++instance FromRow LT.Text where+ fromRow [v] = fromValue v+ fromRow _ = Left "Unexpected number of fields in row"++instance FromRow ByteString where+ fromRow [v] = fromValue v+ fromRow _ = Left "Unexpected number of fields in row"++instance FromRow Binary where+ fromRow [v] = fromValue v+ fromRow _ = Left "Unexpected number of fields in row"++instance FromRow L.ByteString where+ fromRow [v] = fromValue v+ fromRow _ = Left "Unexpected number of fields in row"++instance FromRow Int where+ fromRow [v] = fromValue v+ fromRow _ = Left "Unexpected number of fields in row"++instance FromRow Day where+ fromRow [v] = fromValue v+ fromRow _ = Left "Unexpected number of fields in row"++instance FromRow TimeOfDay where+ fromRow [v] = fromValue v+ fromRow _ = Left "Unexpected number of fields in row"++instance FromRow LocalTime where+ fromRow [v] = fromValue v+ fromRow _ = Left "Unexpected number of fields in row"++instance FromRow Double where+ fromRow [v] = fromValue v+ fromRow _ = Left "Unexpected number of fields in row"++instance FromRow Float where+ fromRow [v] = fromValue v+ fromRow _ = Left "Unexpected number of fields in row"++instance FromRow Word8 where+ fromRow [v] = fromValue v+ fromRow _ = Left "Unexpected number of fields in row"++instance FromRow Bool where+ fromRow [v] = fromValue v+ fromRow _ = Left "Unexpected number of fields in row"++instance (FromValue a,FromValue b) => FromRow (a,b) where+ fromRow [a,b] = (,) <$> fromValue a <*> fromValue b+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c) => FromRow (a,b,c) where+ fromRow [a,b,c] = (,,) <$> fromValue a <*> fromValue b <*> fromValue c+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c,FromValue d) => FromRow (a,b,c,d) where+ fromRow [a,b,c,d] = (,,,) <$> fromValue a <*> fromValue b <*> fromValue c <*> fromValue d+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c,FromValue d,FromValue e) => FromRow (a,b,c,d,e) where+ fromRow [a,b,c,d,e] = (,,,,) <$> fromValue a <*> fromValue b <*> fromValue c <*> fromValue d <*> fromValue e+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c,FromValue d,FromValue e,FromValue f) => FromRow (a,b,c,d,e,f) where+ fromRow [a,b,c,d,e,f] = (,,,,,) <$> fromValue a <*> fromValue b <*> fromValue c <*> fromValue d <*> fromValue e <*> fromValue f+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c,FromValue d,FromValue e,FromValue f,FromValue g) => FromRow (a,b,c,d,e,f,g) where+ fromRow [a,b,c,d,e,f,g] = (,,,,,,) <$> fromValue a <*> fromValue b <*> fromValue c <*> fromValue d <*> fromValue e <*> fromValue f <*> fromValue g+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c,FromValue d,FromValue e,FromValue f,FromValue g,FromValue h) => FromRow (a,b,c,d,e,f,g,h) where+ fromRow [a,b,c,d,e,f,g,h] = (,,,,,,,) <$> fromValue a <*> fromValue b <*> fromValue c <*> fromValue d <*> fromValue e <*> fromValue f <*> fromValue g <*> fromValue h+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c,FromValue d,FromValue e,FromValue f,FromValue g,FromValue h,FromValue i) => FromRow (a,b,c,d,e,f,g,h,i) where+ fromRow [a,b,c,d,e,f,g,h,i] = (,,,,,,,,) <$> fromValue a <*> fromValue b <*> fromValue c <*> fromValue d <*> fromValue e <*> fromValue f <*> fromValue g <*> fromValue h <*> fromValue i+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c,FromValue d,FromValue e,FromValue f,FromValue g,FromValue h,FromValue i,FromValue j) => FromRow (a,b,c,d,e,f,g,h,i,j) where+ fromRow [a,b,c,d,e,f,g,h,i,j] = (,,,,,,,,,) <$> fromValue a <*> fromValue b <*> fromValue c <*> fromValue d <*> fromValue e <*> fromValue f <*> fromValue g <*> fromValue h <*> fromValue i <*> fromValue j+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c,FromValue d,FromValue e,FromValue f,FromValue g,FromValue h,FromValue i,FromValue j,FromValue k) => FromRow (a,b,c,d,e,f,g,h,i,j,k) where+ fromRow [a,b,c,d,e,f,g,h,i,j,k] = (,,,,,,,,,,) <$> fromValue a <*> fromValue b <*> fromValue c <*> fromValue d <*> fromValue e <*> fromValue f <*> fromValue g <*> fromValue h <*> fromValue i <*> fromValue j <*> fromValue k+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c,FromValue d,FromValue e,FromValue f,FromValue g,FromValue h,FromValue i,FromValue j,FromValue k,FromValue l) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l) where+ fromRow [a,b,c,d,e,f,g,h,i,j,k,l] = (,,,,,,,,,,,) <$> fromValue a <*> fromValue b <*> fromValue c <*> fromValue d <*> fromValue e <*> fromValue f <*> fromValue g <*> fromValue h <*> fromValue i <*> fromValue j <*> fromValue k <*> fromValue l+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c,FromValue d,FromValue e,FromValue f,FromValue g,FromValue h,FromValue i,FromValue j,FromValue k,FromValue l,FromValue m) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m) where+ fromRow [a,b,c,d,e,f,g,h,i,j,k,l,m] = (,,,,,,,,,,,,) <$> fromValue a <*> fromValue b <*> fromValue c <*> fromValue d <*> fromValue e <*> fromValue f <*> fromValue g <*> fromValue h <*> fromValue i <*> fromValue j <*> fromValue k <*> fromValue l <*> fromValue m+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c,FromValue d,FromValue e,FromValue f,FromValue g,FromValue h,FromValue i,FromValue j,FromValue k,FromValue l,FromValue m,FromValue n) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where+ fromRow [a,b,c,d,e,f,g,h,i,j,k,l,m,n] = (,,,,,,,,,,,,,) <$> fromValue a <*> fromValue b <*> fromValue c <*> fromValue d <*> fromValue e <*> fromValue f <*> fromValue g <*> fromValue h <*> fromValue i <*> fromValue j <*> fromValue k <*> fromValue l <*> fromValue m <*> fromValue n+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c,FromValue d,FromValue e,FromValue f,FromValue g,FromValue h,FromValue i,FromValue j,FromValue k,FromValue l,FromValue m,FromValue n,FromValue o) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where+ fromRow [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o] = (,,,,,,,,,,,,,,) <$> fromValue a <*> fromValue b <*> fromValue c <*> fromValue d <*> fromValue e <*> fromValue f <*> fromValue g <*> fromValue h <*> fromValue i <*> fromValue j <*> fromValue k <*> fromValue l <*> fromValue m <*> fromValue n <*> fromValue o+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c,FromValue d,FromValue e,FromValue f,FromValue g,FromValue h,FromValue i,FromValue j,FromValue k,FromValue l,FromValue m,FromValue n,FromValue o,FromValue p) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where+ fromRow [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p] = (,,,,,,,,,,,,,,,) <$> fromValue a <*> fromValue b <*> fromValue c <*> fromValue d <*> fromValue e <*> fromValue f <*> fromValue g <*> fromValue h <*> fromValue i <*> fromValue j <*> fromValue k <*> fromValue l <*> fromValue m <*> fromValue n <*> fromValue o <*> fromValue p+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c,FromValue d,FromValue e,FromValue f,FromValue g,FromValue h,FromValue i,FromValue j,FromValue k,FromValue l,FromValue m,FromValue n,FromValue o,FromValue p,FromValue q) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) where+ fromRow [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q] = (,,,,,,,,,,,,,,,,) <$> fromValue a <*> fromValue b <*> fromValue c <*> fromValue d <*> fromValue e <*> fromValue f <*> fromValue g <*> fromValue h <*> fromValue i <*> fromValue j <*> fromValue k <*> fromValue l <*> fromValue m <*> fromValue n <*> fromValue o <*> fromValue p <*> fromValue q+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c,FromValue d,FromValue e,FromValue f,FromValue g,FromValue h,FromValue i,FromValue j,FromValue k,FromValue l,FromValue m,FromValue n,FromValue o,FromValue p,FromValue q,FromValue r) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) where+ fromRow [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r] = (,,,,,,,,,,,,,,,,,) <$> fromValue a <*> fromValue b <*> fromValue c <*> fromValue d <*> fromValue e <*> fromValue f <*> fromValue g <*> fromValue h <*> fromValue i <*> fromValue j <*> fromValue k <*> fromValue l <*> fromValue m <*> fromValue n <*> fromValue o <*> fromValue p <*> fromValue q <*> fromValue r+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c,FromValue d,FromValue e,FromValue f,FromValue g,FromValue h,FromValue i,FromValue j,FromValue k,FromValue l,FromValue m,FromValue n,FromValue o,FromValue p,FromValue q,FromValue r,FromValue s) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) where+ fromRow [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s] = (,,,,,,,,,,,,,,,,,,) <$> fromValue a <*> fromValue b <*> fromValue c <*> fromValue d <*> fromValue e <*> fromValue f <*> fromValue g <*> fromValue h <*> fromValue i <*> fromValue j <*> fromValue k <*> fromValue l <*> fromValue m <*> fromValue n <*> fromValue o <*> fromValue p <*> fromValue q <*> fromValue r <*> fromValue s+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c,FromValue d,FromValue e,FromValue f,FromValue g,FromValue h,FromValue i,FromValue j,FromValue k,FromValue l,FromValue m,FromValue n,FromValue o,FromValue p,FromValue q,FromValue r,FromValue s,FromValue t) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) where+ fromRow [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t] = (,,,,,,,,,,,,,,,,,,,) <$> fromValue a <*> fromValue b <*> fromValue c <*> fromValue d <*> fromValue e <*> fromValue f <*> fromValue g <*> fromValue h <*> fromValue i <*> fromValue j <*> fromValue k <*> fromValue l <*> fromValue m <*> fromValue n <*> fromValue o <*> fromValue p <*> fromValue q <*> fromValue r <*> fromValue s <*> fromValue t+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c,FromValue d,FromValue e,FromValue f,FromValue g,FromValue h,FromValue i,FromValue j,FromValue k,FromValue l,FromValue m,FromValue n,FromValue o,FromValue p,FromValue q,FromValue r,FromValue s,FromValue t,FromValue u) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u) where+ fromRow [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u] = (,,,,,,,,,,,,,,,,,,,,) <$> fromValue a <*> fromValue b <*> fromValue c <*> fromValue d <*> fromValue e <*> fromValue f <*> fromValue g <*> fromValue h <*> fromValue i <*> fromValue j <*> fromValue k <*> fromValue l <*> fromValue m <*> fromValue n <*> fromValue o <*> fromValue p <*> fromValue q <*> fromValue r <*> fromValue s <*> fromValue t <*> fromValue u+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c,FromValue d,FromValue e,FromValue f,FromValue g,FromValue h,FromValue i,FromValue j,FromValue k,FromValue l,FromValue m,FromValue n,FromValue o,FromValue p,FromValue q,FromValue r,FromValue s,FromValue t,FromValue u,FromValue v) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v) where+ fromRow [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v] = (,,,,,,,,,,,,,,,,,,,,,) <$> fromValue a <*> fromValue b <*> fromValue c <*> fromValue d <*> fromValue e <*> fromValue f <*> fromValue g <*> fromValue h <*> fromValue i <*> fromValue j <*> fromValue k <*> fromValue l <*> fromValue m <*> fromValue n <*> fromValue o <*> fromValue p <*> fromValue q <*> fromValue r <*> fromValue s <*> fromValue t <*> fromValue u <*> fromValue v+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c,FromValue d,FromValue e,FromValue f,FromValue g,FromValue h,FromValue i,FromValue j,FromValue k,FromValue l,FromValue m,FromValue n,FromValue o,FromValue p,FromValue q,FromValue r,FromValue s,FromValue t,FromValue u,FromValue v,FromValue w) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w) where+ fromRow [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w] = (,,,,,,,,,,,,,,,,,,,,,,) <$> fromValue a <*> fromValue b <*> fromValue c <*> fromValue d <*> fromValue e <*> fromValue f <*> fromValue g <*> fromValue h <*> fromValue i <*> fromValue j <*> fromValue k <*> fromValue l <*> fromValue m <*> fromValue n <*> fromValue o <*> fromValue p <*> fromValue q <*> fromValue r <*> fromValue s <*> fromValue t <*> fromValue u <*> fromValue v <*> fromValue w+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c,FromValue d,FromValue e,FromValue f,FromValue g,FromValue h,FromValue i,FromValue j,FromValue k,FromValue l,FromValue m,FromValue n,FromValue o,FromValue p,FromValue q,FromValue r,FromValue s,FromValue t,FromValue u,FromValue v,FromValue w,FromValue x) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x) where+ fromRow [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x] = (,,,,,,,,,,,,,,,,,,,,,,,) <$> fromValue a <*> fromValue b <*> fromValue c <*> fromValue d <*> fromValue e <*> fromValue f <*> fromValue g <*> fromValue h <*> fromValue i <*> fromValue j <*> fromValue k <*> fromValue l <*> fromValue m <*> fromValue n <*> fromValue o <*> fromValue p <*> fromValue q <*> fromValue r <*> fromValue s <*> fromValue t <*> fromValue u <*> fromValue v <*> fromValue w <*> fromValue x+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))++instance (FromValue a,FromValue b,FromValue c,FromValue d,FromValue e,FromValue f,FromValue g,FromValue h,FromValue i,FromValue j,FromValue k,FromValue l,FromValue m,FromValue n,FromValue o,FromValue p,FromValue q,FromValue r,FromValue s,FromValue t,FromValue u,FromValue v,FromValue w,FromValue x,FromValue y) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y) where+ fromRow [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y] = (,,,,,,,,,,,,,,,,,,,,,,,,) <$> fromValue a <*> fromValue b <*> fromValue c <*> fromValue d <*> fromValue e <*> fromValue f <*> fromValue g <*> fromValue h <*> fromValue i <*> fromValue j <*> fromValue k <*> fromValue l <*> fromValue m <*> fromValue n <*> fromValue o <*> fromValue p <*> fromValue q <*> fromValue r <*> fromValue s <*> fromValue t <*> fromValue u <*> fromValue v <*> fromValue w <*> fromValue x <*> fromValue y+ fromRow r = Left ("Unexpected number of fields in row: " ++ show (length r))
+ src/Database/ODBC/Internal.hs view
@@ -0,0 +1,1083 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ForeignFunctionInterface #-}++-- | ODBC database API.+--+-- WARNING: This API is meant as a base for more high-level APIs, such+-- as the one provided in "Database.ODBC.SQLServer". The commands here+-- are all vulerable to SQL injection attacks. See+-- <https://en.wikipedia.org/wiki/SQL_injection> for more information.+--+-- Don't use this module if you don't know what you're doing.++module Database.ODBC.Internal+ ( -- * Connect/disconnect+ connect+ , close+ , Connection+ -- * Executing queries+ , exec+ , query+ , Value(..)+ , Binary(..)+ -- * Streaming results+ , stream+ , Step(..)+ -- * Exceptions+ , ODBCException(..)+ ) where++import Control.Concurrent.Async+import Control.Concurrent.MVar+import Control.DeepSeq+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Data.ByteString (ByteString)+import qualified Data.ByteString.Unsafe as S+import Data.Coerce+import Data.Data+import Data.Int+import Data.String+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Foreign as T+import Data.Time+import Foreign hiding (void)+import Foreign.C+import GHC.Generics++--------------------------------------------------------------------------------+-- Public types++-- | Connection to a database. Use of this connection is+-- thread-safe. When garbage collected, the connection will be closed+-- if not done already.+newtype Connection = Connection+ {connectionMVar :: MVar (Maybe (ForeignPtr EnvAndDbc))}++-- | A database exception. Any of the functions in this library may+-- throw this exception type.+data ODBCException+ = UnsuccessfulReturnCode !String+ !Int16+ !String+ -- ^ An ODBC operation failed with the given return code.+ | AllocationReturnedNull !String+ -- ^ Allocating an ODBC resource failed.+ | UnknownDataType !String+ !Int16+ -- ^ An unsupported/unknown data type was returned from the ODBC+ -- driver.+ | DatabaseIsClosed !String+ -- ^ You tried to use the database connection after it was closed.+ | DatabaseAlreadyClosed+ -- ^ You attempted to 'close' the database twice.+ | NoTotalInformation !Int+ -- ^ No total length information for column.+ | DataRetrievalError !String+ -- ^ There was a general error retrieving data. String will+ -- contain the reason why.+ deriving (Typeable, Show, Eq)+instance Exception ODBCException++-- | 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'.+ | BinaryValue !Binary+ -- ^ Only a vector of bytes. Intended for binary data, not for+ -- ASCII text.+ | BoolValue !Bool+ -- ^ A simple boolean.+ | DoubleValue !Double+ -- ^ Floating point values that fit in a 'Double'.+ | FloatValue !Float+ -- ^ Floating point values that fit in a 'Float'.+ | IntValue !Int+ -- ^ Integer values that fit in an 'Int'.+ | ByteValue !Word8+ -- ^ Values that fit in one byte.+ | DayValue !Day+ -- ^ Date (year, month, day) values.+ | TimeOfDayValue !TimeOfDay+ -- ^ Time of day (hh, mm, ss + fractional) values.+ | LocalTimeValue !LocalTime+ -- ^ Local date and time.+ deriving (Eq, Show, Typeable, Ord, Generic, Data)+instance NFData Value++-- | 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@.+--+-- The 'ByteString' type is already mapped to the non-Unicode 'text'+-- type.+newtype Binary = Binary+ { unBinary :: ByteString+ } deriving (Show, Eq, Ord, Data, Generic, Typeable, NFData)++-- | A step in the streaming process for the 'stream' function.+data Step a+ = Stop !a -- ^ Stop with this value.+ | Continue !a -- ^ Continue with this value.+ deriving (Show)++--------------------------------------------------------------------------------+-- Internal types++-- | A column description.+data Column = Column+ { columnType :: !SQLSMALLINT+ , columnSize :: !SQLULEN+ , columnDigits :: !SQLSMALLINT+ , columnNull :: !SQLSMALLINT+ } deriving (Show)++--------------------------------------------------------------------------------+-- Exposed functions++-- | Connect using the given connection string.+connect ::+ MonadIO m+ => Text -- ^ An ODBC connection string.+ -> m Connection+ -- ^ A connection to the database. You should call 'close' on it+ -- when you're done. If you forget to, then the connection will only+ -- be closed when there are no more references to the 'Connection'+ -- value in your program, which might never happen. So take care.+ -- Use e.g. 'bracket' from "Control.Exception" to do the open/close+ -- pattern, which will handle exceptions.+connect string =+ withBound+ (do (ptr, envAndDbc) <-+ uninterruptibleMask_+ (do ptr <- assertNotNull "odbc_AllocEnvAndDbc" odbc_AllocEnvAndDbc+ fmap (ptr, ) (newForeignPtr odbc_FreeEnvAndDbc (coerce ptr)))+ -- Above: Allocate the environment.+ -- Below: Try to connect to the database.+ withCStringLen+ (T.unpack string)+ (\(wstring,len) ->+ uninterruptibleMask_+ (do assertSuccess+ ptr+ "odbc_SQLDriverConnect"+ (withForeignPtr+ envAndDbc+ (\dbcPtr ->+ odbc_SQLDriverConnect+ dbcPtr+ (coerce wstring)+ (fromIntegral len)))+ addForeignPtrFinalizer odbc_SQLDisconnect envAndDbc))+ -- Below: Keep the environment and the database handle in an mvar.+ mvar <- newMVar (Just envAndDbc)+ pure (Connection mvar))++-- | Close the connection. Further use of the 'Connection' will throw+-- an exception. Double closes also throw an exception to avoid+-- architectural mistakes.+close ::+ MonadIO m+ => Connection -- ^ A connection to the database.+ -> m ()+close conn =+ withBound+ (do mstate <- modifyMVar (connectionMVar conn) (pure . (Nothing, ))+ -- If an async exception comes after here, that's a pity+ -- because we wanted to free the connection now. But with+ -- regards to safety, the finalizers will take care of closing+ -- the connection and the env.+ maybe (throwIO DatabaseAlreadyClosed) finalizeForeignPtr mstate)++-- | Execute a statement on the database.+exec ::+ MonadIO m+ => Connection -- ^ A connection to the database.+ -> Text -- ^ SQL statement.+ -> m ()+exec conn string =+ withBound+ (withHDBC+ conn+ "exec"+ (\dbc -> withExecDirect dbc string (const (pure ()))))++-- | Query and return a list of rows.+query ::+ MonadIO m+ => Connection -- ^ A connection to the database.+ -> Text -- ^ SQL query.+ -> m [[Maybe 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 =+ withBound+ (withHDBC+ conn+ "query"+ (\dbc -> withExecDirect dbc string (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 -> [Maybe 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.+stream conn string step state = do+ unlift <- askUnliftIO+ withBound+ (withHDBC+ conn+ "stream"+ (\dbc ->+ withExecDirect+ dbc+ string+ (fetchIterator dbc unlift step state)))++--------------------------------------------------------------------------------+-- Internal wrapper functions++-- | Thread-safely access the connection pointer.+withHDBC :: Connection -> String -> (Ptr EnvAndDbc -> IO a) -> IO a+withHDBC conn label f =+ withMVar+ (connectionMVar conn)+ (\mfptr ->+ case mfptr of+ Nothing -> throwIO (DatabaseIsClosed label)+ Just envAndDbc -> do+ v <- withForeignPtr envAndDbc f+ touchForeignPtr envAndDbc+ pure v)++-- | Execute a query directly without preparation.+withExecDirect :: Ptr EnvAndDbc -> Text -> (forall s. SQLHSTMT s -> IO a) -> IO a+withExecDirect dbc string cont =+ withStmt+ dbc+ (\stmt -> do+ 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+withStmt hdbc =+ bracket+ (assertNotNull "odbc_SQLAllocStmt" (odbc_SQLAllocStmt hdbc))+ odbc_SQLFreeStmt++-- | Run an action in a bound thread. This is neccessary due to the+-- interaction with signals in ODBC and GHC's runtime.+withBound :: MonadIO m => IO a -> m a+withBound = liftIO . flip withAsyncBound wait++--------------------------------------------------------------------------------+-- Internal data retrieval functions++-- | Iterate over the rows in the statement.+fetchIterator ::+ Ptr EnvAndDbc+ -> UnliftIO m+ -> (state -> [Maybe Value] -> m (Step state))+ -> state+ -> SQLHSTMT s+ -> IO state+fetchIterator dbc (UnliftIO runInIO) step state0 stmt = do+ SQLSMALLINT cols <-+ liftIO+ (withMalloc+ (\sizep -> do+ assertSuccess+ dbc+ "odbc_SQLNumResultCols"+ (odbc_SQLNumResultCols stmt sizep)+ peek sizep))+ types <- mapM (describeColumn dbc stmt) [1 .. cols]+ let loop state = do+ do retcode0 <- odbc_SQLFetch dbc stmt+ if | retcode0 == sql_no_data ->+ do retcode <- odbc_SQLMoreResults dbc stmt+ if retcode == sql_success || retcode == sql_success_with_info+ then loop state+ else pure state+ | retcode0 == sql_success || retcode0 == sql_success_with_info ->+ do row <-+ sequence+ (zipWith (getData dbc stmt) [SQLUSMALLINT 1 ..] types)+ !state' <- runInIO (step state row)+ case state' of+ Stop state'' -> pure state''+ Continue state'' -> loop state''+ | otherwise ->+ throwIO+ (UnsuccessfulReturnCode+ "odbc_SQLFetch"+ (coerce retcode0)+ "Unexpected return code")+ if cols > 0+ then loop state0+ else pure state0++-- | Fetch all rows from a statement.+fetchStatementRows :: Ptr EnvAndDbc -> SQLHSTMT s -> IO [[Maybe Value]]+fetchStatementRows dbc stmt = do+ SQLSMALLINT cols <-+ withMalloc+ (\sizep -> do+ assertSuccess+ dbc+ "odbc_SQLNumResultCols"+ (odbc_SQLNumResultCols stmt sizep)+ peek sizep)+ types <- mapM (describeColumn dbc stmt) [1 .. cols]+ let loop rows = do+ do retcode0 <- odbc_SQLFetch dbc stmt+ if | retcode0 == sql_no_data ->+ do retcode <- odbc_SQLMoreResults dbc stmt+ if retcode == sql_success || retcode == sql_success_with_info+ then loop rows+ else pure (rows [])+ | retcode0 == sql_success || retcode0 == sql_success_with_info ->+ do fields <-+ sequence+ (zipWith (getData dbc stmt) [SQLUSMALLINT 1 ..] types)+ loop (rows . (fields :))+ | otherwise ->+ throwIO+ (UnsuccessfulReturnCode+ "odbc_SQLFetch"+ (coerce retcode0)+ "Unexpected return code")+ if cols > 0+ then loop id+ else pure []++-- | Describe the given column by its integer index.+describeColumn :: Ptr EnvAndDbc -> SQLHSTMT s -> Int16 -> IO Column+describeColumn dbPtr stmt i =+ T.useAsPtr+ (T.replicate 1000 (fromString "0"))+ (\namep namelen ->+ (withMalloc+ (\namelenp ->+ (withMalloc+ (\typep ->+ withMalloc+ (\sizep ->+ withMalloc+ (\digitsp ->+ withMalloc+ (\nullp -> do+ assertSuccess+ dbPtr+ "odbc_SQLDescribeColW"+ (odbc_SQLDescribeColW+ stmt+ (SQLUSMALLINT (fromIntegral i))+ (coerce namep)+ (SQLSMALLINT (fromIntegral namelen))+ namelenp+ typep+ sizep+ digitsp+ nullp)+ typ <- peek typep+ size <- peek sizep+ digits <- peek digitsp+ isnull <- peek nullp+ evaluate+ Column+ { columnType = typ+ , columnSize = size+ , columnDigits = digits+ , columnNull = isnull+ }))))))))++-- | Pull data for the given column.+getData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> Column -> IO (Maybe Value)+getData dbc stmt i col =+ if | colType == sql_longvarchar -> getBytesData dbc stmt i+ | colType == sql_varchar -> getBytesData dbc stmt i+ | colType == sql_wvarchar -> 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+ | colType == sql_bit ->+ withMalloc+ (\bitPtr -> do+ mlen <- getTypedData dbc stmt sql_c_bit i (coerce bitPtr) (SQLLEN 1)+ case mlen of+ Nothing -> pure Nothing+ Just {} ->+ fmap (Just . BoolValue . (/= (0 :: Word8))) (peek bitPtr))+ | colType == sql_double ->+ withMalloc+ (\doublePtr -> do+ mlen <-+ getTypedData dbc stmt sql_c_double i (coerce doublePtr) (SQLLEN 8)+ -- float is 8 bytes: https://technet.microsoft.com/en-us/library/ms172424(v=sql.110).aspx+ case mlen of+ Nothing -> pure Nothing+ Just {} -> do+ !d <- fmap DoubleValue (peek doublePtr)+ pure (Just d))+ | colType == sql_float ->+ withMalloc+ (\floatPtr -> do+ mlen <-+ getTypedData dbc stmt sql_c_double i (coerce floatPtr) (SQLLEN 8)+ -- SQLFLOAT is covered by SQL_C_DOUBLE: https://docs.microsoft.com/en-us/sql/odbc/reference/appendixes/c-data-types+ -- Float is 8 bytes: https://technet.microsoft.com/en-us/library/ms172424(v=sql.110).aspx+ case mlen of+ Nothing -> pure Nothing+ Just {} -> do+ !d <- fmap DoubleValue (peek floatPtr)+ pure (Just d))+ | colType == sql_real ->+ withMalloc+ (\floatPtr -> do+ mlen <-+ getTypedData dbc stmt sql_c_double i (coerce floatPtr) (SQLLEN 8)+ -- SQLFLOAT is covered by SQL_C_DOUBLE: https://docs.microsoft.com/en-us/sql/odbc/reference/appendixes/c-data-types+ -- Float is 8 bytes: https://technet.microsoft.com/en-us/library/ms172424(v=sql.110).aspx+ case mlen of+ Nothing -> pure Nothing+ Just {} -> do+ !d <-+ fmap+ (FloatValue . (realToFrac :: Double -> Float))+ (peek floatPtr)+ pure (Just d))+ | colType == sql_integer ->+ withMalloc+ (\intPtr -> do+ mlen <-+ getTypedData dbc stmt sql_c_long i (coerce intPtr) (SQLLEN 4)+ case mlen of+ Nothing -> pure Nothing+ Just {} ->+ fmap+ (Just . IntValue . fromIntegral)+ (peek (intPtr :: Ptr Int32)))+ | colType == sql_bigint ->+ withMalloc+ (\intPtr -> do+ mlen <-+ getTypedData dbc stmt sql_c_bigint i (coerce intPtr) (SQLLEN 8)+ case mlen of+ Nothing -> pure Nothing+ Just {} ->+ fmap+ (Just . IntValue . fromIntegral)+ (peek (intPtr :: Ptr Int64)))+ | colType == sql_smallint ->+ withMalloc+ (\intPtr -> do+ mlen <-+ getTypedData dbc stmt sql_c_short i (coerce intPtr) (SQLLEN 2)+ case mlen of+ Nothing -> pure Nothing+ Just {} ->+ fmap+ (Just . IntValue . fromIntegral)+ (peek (intPtr :: Ptr Int16)))+ | colType == sql_tinyint ->+ withMalloc+ (\intPtr -> do+ mlen <-+ getTypedData dbc stmt sql_c_short i (coerce intPtr) (SQLLEN 1)+ case mlen of+ Nothing -> pure Nothing+ Just {} -> fmap (Just . ByteValue) (peek (intPtr :: Ptr Word8)))+ | colType == sql_type_date ->+ withMallocBytes+ 3+ (\datePtr -> do+ mlen <-+ getTypedData dbc stmt sql_c_date i (coerce datePtr) (SQLLEN 3)+ case mlen of+ Nothing -> pure Nothing+ Just {} ->+ fmap+ (Just . DayValue)+ (fromGregorian <$>+ (fmap fromIntegral (odbc_DATE_STRUCT_year datePtr)) <*>+ (fmap fromIntegral (odbc_DATE_STRUCT_month datePtr)) <*>+ (fmap fromIntegral (odbc_DATE_STRUCT_day datePtr))))+ | colType == sql_ss_time2 ->+ withCallocBytes+ 12 -- This struct is padded to 12 bytes on both 32-bit and 64-bit operating systems.+ -- https://docs.microsoft.com/en-us/sql/relational-databases/native-client-odbc-date-time/data-type-support-for-odbc-date-and-time-improvements+ (\datePtr -> do+ mlen <-+ getTypedData+ dbc+ stmt+ sql_c_time+ i+ (coerce datePtr)+ (SQLLEN 12)+ case mlen of+ Nothing -> pure Nothing+ Just {} ->+ fmap+ (Just . TimeOfDayValue)+ (TimeOfDay <$>+ (fmap fromIntegral (odbc_TIME_STRUCT_hour datePtr)) <*>+ (fmap fromIntegral (odbc_TIME_STRUCT_minute datePtr)) <*>+ (fmap fromIntegral (odbc_TIME_STRUCT_second datePtr))))+ | colType == sql_type_timestamp ->+ withMallocBytes+ 16+ (\timestampPtr -> do+ mlen <-+ getTypedData+ dbc+ stmt+ sql_c_type_timestamp+ i+ (coerce timestampPtr)+ (SQLLEN 16)+ case mlen of+ Nothing -> pure Nothing+ Just {} ->+ fmap+ (Just . LocalTimeValue)+ (LocalTime <$>+ (fromGregorian <$>+ (fmap fromIntegral (odbc_TIMESTAMP_STRUCT_year timestampPtr)) <*>+ (fmap+ fromIntegral+ (odbc_TIMESTAMP_STRUCT_month timestampPtr)) <*>+ (fmap fromIntegral (odbc_TIMESTAMP_STRUCT_day timestampPtr))) <*>+ (TimeOfDay <$>+ (fmap fromIntegral (odbc_TIMESTAMP_STRUCT_hour timestampPtr)) <*>+ (fmap+ fromIntegral+ (odbc_TIMESTAMP_STRUCT_minute timestampPtr)) <*>+ ((+) <$>+ (fmap+ fromIntegral+ (odbc_TIMESTAMP_STRUCT_second timestampPtr)) <*>+ (fmap+ (\frac -> fromIntegral frac / 1000000000)+ (odbc_TIMESTAMP_STRUCT_fraction timestampPtr))))))+ | otherwise ->+ throwIO+ (UnknownDataType+ "getData"+ (let SQLSMALLINT n = colType+ in n))+ where+ colType = columnType col++-- | Get the column's data as a vector of CHAR.+getBytesData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO (Maybe Value)+getBytesData dbc stmt column = do+ mavailableBytes <- getSize dbc stmt sql_c_char column+ case mavailableBytes of+ Just 0 -> pure (Just (ByteStringValue mempty))+ Just availableBytes -> do+ let allocBytes = availableBytes + 1+ bufferp <- callocBytes (fromIntegral allocBytes)+ void+ (getTypedData+ dbc+ stmt+ sql_c_char+ column+ (coerce bufferp)+ (SQLLEN (fromIntegral allocBytes)))+ bs <- S.unsafePackMallocCStringLen (bufferp, fromIntegral availableBytes)+ evaluate (Just (ByteStringValue bs))+ Nothing -> pure Nothing++-- | Get the column's data as raw binary.+getBinaryData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO (Maybe Value)+getBinaryData dbc stmt column = do+ mavailableBinary <- getSize dbc stmt sql_c_binary column+ case mavailableBinary of+ Just 0 -> pure (Just (BinaryValue (Binary mempty)))+ Just availableBinary -> do+ let allocBinary = availableBinary+ bufferp <- callocBytes (fromIntegral allocBinary)+ void+ (getTypedData+ dbc+ stmt+ sql_c_binary+ column+ (coerce bufferp)+ (SQLLEN (fromIntegral allocBinary)))+ bs <- S.unsafePackMallocCStringLen (bufferp, fromIntegral availableBinary)+ evaluate (Just (BinaryValue (Binary bs)))+ Nothing -> pure Nothing++-- | Get the column's data as a text string.+getTextData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO (Maybe Value)+getTextData dbc stmt column = do+ mavailableChars <- getSize dbc stmt sql_c_wchar column+ case mavailableChars of+ Just 0 -> pure (Just (TextValue mempty))+ Nothing -> pure Nothing+ Just availableBytes -> do+ let allocBytes = availableBytes + 2+ withMallocBytes+ (fromIntegral allocBytes)+ (\bufferp -> do+ void+ (getTypedData+ dbc+ stmt+ sql_c_wchar+ column+ (coerce bufferp)+ (SQLLEN (fromIntegral allocBytes)))+ t <- T.fromPtr bufferp (fromIntegral (div availableBytes 2))+ let !v = TextValue t+ pure (Just v))++-- | Get some data into the given pointer.+getTypedData ::+ Ptr EnvAndDbc+ -> SQLHSTMT s+ -> SQLCTYPE+ -> SQLUSMALLINT+ -> SQLPOINTER+ -> SQLLEN+ -> IO (Maybe Int64)+getTypedData dbc stmt ty column bufferp bufferlen =+ withMalloc+ (\copiedPtr -> do+ assertSuccess+ dbc+ ("getTypedData ty=" ++ show ty)+ (odbc_SQLGetData dbc stmt column ty bufferp bufferlen copiedPtr)+ copiedBytes <- peek copiedPtr+ if copiedBytes == sql_null_data+ then pure Nothing+ else pure (Just (coerce copiedBytes :: Int64)))++-- | Get only the size of the data, no copying.+getSize :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLCTYPE -> SQLUSMALLINT -> IO (Maybe Int64)+getSize dbc stmt ty column =+ withMalloc+ (\availablePtr -> do+ withMalloc+ (\bufferp ->+ assertSuccess+ dbc+ "getSize"+ (odbc_SQLGetData+ dbc+ stmt+ column+ ty+ (coerce (bufferp :: Ptr CChar))+ 0+ availablePtr))+ availableBytes <- peek availablePtr+ if availableBytes == sql_null_data+ then pure Nothing+ else if availableBytes == sql_no_total+ then throwIO+ (NoTotalInformation+ (let SQLUSMALLINT i = column+ in fromIntegral i))+ else pure (Just (coerce availableBytes :: Int64)))++--------------------------------------------------------------------------------+-- Correctness checks++-- | Check that the RETCODE is successful.+assertNotNull :: (Coercible a (Ptr ())) => String -> IO a -> IO a+assertNotNull label m = do+ val <- m+ if coerce val == nullPtr+ then throwIO (AllocationReturnedNull label)+ else pure val++-- | Check that the RETCODE is successful.+assertSuccess :: Ptr EnvAndDbc -> String -> IO RETCODE -> IO ()+assertSuccess dbc label m = do+ retcode <- m+ if retcode == sql_success || retcode == sql_success_with_info+ then pure ()+ else do+ ptr <- odbc_error dbc+ string <-+ if nullPtr == ptr+ then pure ""+ else peekCString ptr+ throwIO (UnsuccessfulReturnCode label (coerce retcode) string)++-- | Check that the RETCODE is successful or no data.+assertSuccessOrNoData :: Ptr EnvAndDbc -> String -> IO RETCODE -> IO ()+assertSuccessOrNoData dbc label m = do+ retcode <- m+ if retcode == sql_success ||+ retcode == sql_success_with_info || retcode == sql_no_data+ then pure ()+ else do+ ptr <- odbc_error dbc+ string <-+ if nullPtr == ptr+ then pure ""+ else peekCString ptr+ throwIO (UnsuccessfulReturnCode label (coerce retcode) string)++--------------------------------------------------------------------------------+-- Foreign types+--+-- https://github.com/Microsoft/ODBC-Specification/blob/753d7e714b7eab9eaab4ad6105fdf4267d6ad6f6/Windows/inc/sqltypes.h++-- Opaque pointers++-- | An environment and database connection in one go.+data EnvAndDbc++-- | The handle allocated for any query.+newtype SQLHSTMT s = SQLHSTMT (Ptr (SQLHSTMT s))++-- | Used to get data.+newtype SQLPOINTER = SQLPOINTER (Ptr SQLPOINTER)++-- | A type that maps to https://docs.microsoft.com/en-us/sql/odbc/reference/appendixes/c-data-types+newtype SQLCTYPE =+ SQLCTYPE Int16+ deriving (Show, Eq, Storable, Integral, Enum, Real, Num, Ord)++-- https://github.com/Microsoft/ODBC-Specification/blob/753d7e714b7eab9eaab4ad6105fdf4267d6ad6f6/Windows/inc/sqltypes.h#L152+newtype RETCODE = RETCODE Int16+ deriving (Show, Eq)++-- https://github.com/Microsoft/ODBC-Specification/blob/753d7e714b7eab9eaab4ad6105fdf4267d6ad6f6/Windows/inc/sqltypes.h#L89+newtype SQLUSMALLINT = SQLUSMALLINT Word16 deriving (Show, Eq, Storable, Integral, Enum, Real, Num, Ord)++-- https://github.com/Microsoft/ODBC-Specification/blob/753d7e714b7eab9eaab4ad6105fdf4267d6ad6f6/Windows/inc/sqltypes.h#L52..L52+newtype SQLUCHAR = SQLUCHAR Word8 deriving (Show, Eq, Storable)++-- https://github.com/Microsoft/ODBC-Specification/blob/753d7e714b7eab9eaab4ad6105fdf4267d6ad6f6/Windows/inc/sqltypes.h#L52..L52+newtype SQLCHAR = SQLCHAR CChar deriving (Show, Eq, Storable)++-- https://github.com/Microsoft/ODBC-Specification/blob/753d7e714b7eab9eaab4ad6105fdf4267d6ad6f6/Windows/inc/sqltypes.h#L88+newtype SQLSMALLINT = SQLSMALLINT Int16 deriving (Show, Eq, Storable, Num, Integral, Enum, Ord, Real)++-- https://github.com/Microsoft/ODBC-Specification/blob/753d7e714b7eab9eaab4ad6105fdf4267d6ad6f6/Windows/inc/sqltypes.h#L64+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)++-- https://github.com/Microsoft/ODBC-Specification/blob/753d7e714b7eab9eaab4ad6105fdf4267d6ad6f6/Windows/inc/sqltypes.h#L60+newtype SQLINTEGER = SQLINTEGER Int64 deriving (Show, Eq, Storable, Num)++-- https://github.com/Microsoft/ODBC-Specification/blob/753d7e714b7eab9eaab4ad6105fdf4267d6ad6f6/Windows/inc/sqltypes.h#L61..L61+newtype SQLUINTEGER = SQLUINTEGER Word64 deriving (Show, Eq, Storable, Num, Integral, Enum, Ord, Real)++-- https://github.com/Microsoft/ODBC-Specification/blob/753d7e714b7eab9eaab4ad6105fdf4267d6ad6f6/Windows/inc/sqltypes.h#L332+newtype SQLWCHAR = SQLWCHAR CWString deriving (Show, Eq, Storable)++-- https://docs.microsoft.com/en-us/sql/odbc/reference/appendixes/c-data-types+data DATE_STRUCT++-- https://docs.microsoft.com/en-us/sql/odbc/reference/appendixes/c-data-types+data TIME_STRUCT++-- https://docs.microsoft.com/en-us/sql/odbc/reference/appendixes/c-data-types+data TIMESTAMP_STRUCT++--------------------------------------------------------------------------------+-- Foreign functions++foreign import ccall "odbc odbc_error"+ odbc_error :: Ptr EnvAndDbc -> IO (Ptr CChar)++foreign import ccall "odbc odbc_AllocEnvAndDbc"+ odbc_AllocEnvAndDbc :: IO (Ptr EnvAndDbc)++foreign import ccall "odbc &odbc_FreeEnvAndDbc"+ odbc_FreeEnvAndDbc :: FunPtr (Ptr EnvAndDbc -> IO ())++foreign import ccall "odbc odbc_SQLDriverConnect"+ odbc_SQLDriverConnect :: Ptr EnvAndDbc -> Ptr SQLCHAR -> SQLSMALLINT -> IO RETCODE++foreign import ccall "odbc &odbc_SQLDisconnect"+ odbc_SQLDisconnect :: FunPtr (Ptr EnvAndDbc -> IO ())++foreign import ccall "odbc odbc_SQLAllocStmt"+ odbc_SQLAllocStmt :: Ptr EnvAndDbc -> IO (SQLHSTMT s)++foreign import ccall "odbc odbc_SQLFreeStmt"+ odbc_SQLFreeStmt :: SQLHSTMT s -> IO ()++foreign import ccall "odbc odbc_SQLExecDirectW"+ odbc_SQLExecDirectW :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLWCHAR -> SQLINTEGER -> IO RETCODE++foreign import ccall "odbc odbc_SQLFetch"+ odbc_SQLFetch :: Ptr EnvAndDbc -> SQLHSTMT s -> IO RETCODE++foreign import ccall "odbc odbc_SQLMoreResults"+ odbc_SQLMoreResults :: Ptr EnvAndDbc -> SQLHSTMT s -> IO RETCODE++foreign import ccall "odbc odbc_SQLNumResultCols"+ odbc_SQLNumResultCols :: SQLHSTMT s -> Ptr SQLSMALLINT -> IO RETCODE++foreign import ccall "odbc odbc_SQLGetData"+ odbc_SQLGetData+ :: Ptr EnvAndDbc+ -> SQLHSTMT s+ -> SQLUSMALLINT+ -> SQLCTYPE+ -> SQLPOINTER+ -> SQLLEN+ -> Ptr SQLLEN+ -> IO RETCODE++foreign import ccall "odbc odbc_SQLDescribeColW"+ odbc_SQLDescribeColW+ :: SQLHSTMT s+ -> SQLUSMALLINT+ -> Ptr SQLWCHAR+ -> SQLSMALLINT+ -> Ptr SQLSMALLINT+ -> Ptr SQLSMALLINT+ -> Ptr SQLULEN+ -> Ptr SQLSMALLINT+ -> Ptr SQLSMALLINT+ -> IO RETCODE++foreign import ccall "odbc DATE_STRUCT_year" odbc_DATE_STRUCT_year+ :: Ptr DATE_STRUCT -> IO SQLSMALLINT++foreign import ccall "odbc DATE_STRUCT_month" odbc_DATE_STRUCT_month+ :: Ptr DATE_STRUCT -> IO SQLUSMALLINT++foreign import ccall "odbc DATE_STRUCT_day" odbc_DATE_STRUCT_day+ :: Ptr DATE_STRUCT -> IO SQLUSMALLINT++foreign import ccall "odbc TIME_STRUCT_hour" odbc_TIME_STRUCT_hour+ :: Ptr TIME_STRUCT -> IO SQLUSMALLINT+foreign import ccall "odbc TIME_STRUCT_minute" odbc_TIME_STRUCT_minute+ :: Ptr TIME_STRUCT -> IO SQLUSMALLINT+foreign import ccall "odbc TIME_STRUCT_second" odbc_TIME_STRUCT_second+ :: Ptr TIME_STRUCT -> IO SQLUSMALLINT++foreign import ccall "odbc TIMESTAMP_STRUCT_year" odbc_TIMESTAMP_STRUCT_year+ :: Ptr TIMESTAMP_STRUCT -> IO SQLSMALLINT+foreign import ccall "odbc TIMESTAMP_STRUCT_month" odbc_TIMESTAMP_STRUCT_month+ :: Ptr TIMESTAMP_STRUCT -> IO SQLUSMALLINT+foreign import ccall "odbc TIMESTAMP_STRUCT_day" odbc_TIMESTAMP_STRUCT_day+ :: Ptr TIMESTAMP_STRUCT -> IO SQLUSMALLINT+foreign import ccall "odbc TIMESTAMP_STRUCT_hour" odbc_TIMESTAMP_STRUCT_hour+ :: Ptr TIMESTAMP_STRUCT -> IO SQLUSMALLINT+foreign import ccall "odbc TIMESTAMP_STRUCT_minute" odbc_TIMESTAMP_STRUCT_minute+ :: Ptr TIMESTAMP_STRUCT -> IO SQLUSMALLINT+foreign import ccall "odbc TIMESTAMP_STRUCT_second" odbc_TIMESTAMP_STRUCT_second+ :: Ptr TIMESTAMP_STRUCT -> IO SQLUSMALLINT+foreign import ccall "odbc TIMESTAMP_STRUCT_fraction" odbc_TIMESTAMP_STRUCT_fraction+ :: Ptr TIMESTAMP_STRUCT -> IO SQLUINTEGER++--------------------------------------------------------------------------------+-- Foreign utils++withMalloc :: Storable a => (Ptr a -> IO b) -> IO b+withMalloc m = bracket malloc free m++withMallocBytes :: Int -> (Ptr a -> IO b) -> IO b+withMallocBytes n m = bracket (mallocBytes n) free m++withCallocBytes :: Int -> (Ptr a -> IO b) -> IO b+withCallocBytes n m = bracket (callocBytes n) free m++--------------------------------------------------------------------------------+-- SQL constants++-- https://github.com/Microsoft/ODBC-Specification/blob/753d7e714b7eab9eaab4ad6105fdf4267d6ad6f6/Windows/inc/sql.h#L50..L51+sql_success :: RETCODE+sql_success = RETCODE 0++sql_success_with_info :: RETCODE+sql_success_with_info = RETCODE 1++sql_no_data :: RETCODE+sql_no_data = RETCODE 100++sql_null_data :: SQLLEN+sql_null_data = (-1)++sql_no_total :: SQLLEN+sql_no_total = (-4)++--------------------------------------------------------------------------------+-- SQL data type constants++-- sql_unknown_type :: SQLSMALLINT+-- sql_unknown_type = 0++sql_char :: SQLSMALLINT+sql_char = 1++-- sql_numeric :: SQLSMALLINT+-- sql_numeric = 2++-- sql_decimal :: SQLSMALLINT+-- sql_decimal = 3++sql_integer :: SQLSMALLINT+sql_integer = 4++sql_smallint :: SQLSMALLINT+sql_smallint = 5++sql_float :: SQLSMALLINT+sql_float = 6++sql_real :: SQLSMALLINT+sql_real = 7++sql_double :: SQLSMALLINT+sql_double = 8++sql_type_date :: SQLSMALLINT+sql_type_date = 91++-- MS Driver-specific type+-- https://github.com/Microsoft/msphpsql/blob/master/source/shared/msodbcsql.h#L201+-- https://docs.microsoft.com/en-us/sql/relational-databases/native-client-odbc-date-time/data-type-support-for-odbc-date-and-time-improvements+sql_ss_time2 :: SQLSMALLINT+sql_ss_time2 = -154++-- sql_datetime :: SQLSMALLINT+-- sql_datetime = 9++sql_varchar :: SQLSMALLINT+sql_varchar = 12++sql_wchar :: SQLSMALLINT+sql_wchar = (-8)++sql_wvarchar :: SQLSMALLINT+sql_wvarchar = (-9)++sql_wlongvarchar :: SQLSMALLINT+sql_wlongvarchar = (-10)++-- sql_date :: SQLSMALLINT+-- sql_date = 9++-- sql_interval :: SQLSMALLINT+-- sql_interval = 10++sql_time :: SQLSMALLINT+sql_time = 10++-- sql_timestamp :: SQLSMALLINT+-- sql_timestamp = 11++-- https://github.com/Microsoft/ODBC-Specification/blob/753d7e714b7eab9eaab4ad6105fdf4267d6ad6f6/Windows/inc/sql.h#L225..L225+sql_type_timestamp :: SQLSMALLINT+sql_type_timestamp = 93++sql_longvarchar :: SQLSMALLINT+sql_longvarchar = (-1)++sql_binary :: SQLSMALLINT+sql_binary = (-2)++sql_varbinary :: SQLSMALLINT+sql_varbinary = (-3)++-- sql_longvarbinary :: SQLSMALLINT+-- sql_longvarbinary = (-4)++sql_bigint :: SQLSMALLINT+sql_bigint = (-5)++sql_tinyint :: SQLSMALLINT+sql_tinyint = (-6)++sql_bit :: SQLSMALLINT+sql_bit = (-7)++-- sql_guid :: SQLSMALLINT+-- sql_guid = (-11)++--------------------------------------------------------------------------------+-- C type constants++sql_c_wchar :: SQLCTYPE+sql_c_wchar = coerce sql_wchar++sql_c_char :: SQLCTYPE+sql_c_char = coerce sql_char++sql_c_binary :: SQLCTYPE+sql_c_binary = coerce sql_binary++sql_c_double :: SQLCTYPE+sql_c_double = coerce sql_double++-- sql_c_float :: SQLCTYPE+-- sql_c_float = coerce sql_double++sql_c_long :: SQLCTYPE+sql_c_long = coerce sql_integer++-- https://github.com/Microsoft/ODBC-Specification/blob/753d7e714b7eab9eaab4ad6105fdf4267d6ad6f6/Windows/inc/sqlext.h#L592+sql_c_bigint :: SQLCTYPE+sql_c_bigint = coerce (sql_bigint - 20)++-- https://github.com/Microsoft/ODBC-Specification/blob/753d7e714b7eab9eaab4ad6105fdf4267d6ad6f6/Windows/inc/sqlext.h#L593+-- sql_c_biguint :: SQLCTYPE+-- sql_c_biguint = coerce (sql_bigint - 22)++sql_c_short :: SQLCTYPE+sql_c_short = coerce sql_smallint++sql_c_bit :: SQLCTYPE+sql_c_bit = coerce sql_bit++sql_c_date :: SQLCTYPE+sql_c_date = coerce (9 :: SQLSMALLINT)++sql_c_type_timestamp :: SQLCTYPE+sql_c_type_timestamp = coerce sql_type_timestamp++sql_c_time :: SQLCTYPE+sql_c_time = coerce sql_time
+ src/Database/ODBC/SQLServer.hs view
@@ -0,0 +1,458 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}++-- | SQL Server database API.++module Database.ODBC.SQLServer+ ( -- * Building+ -- $building++ -- * Basic library usage+ -- $usage++ -- * Connect/disconnect+ Internal.connect+ , Internal.close+ , Internal.Connection++ -- * Executing queries+ , exec+ , query+ , Value(..)+ , Query+ , ToSql(..)+ , FromValue(..)+ , FromRow(..)+ , Internal.Binary(..)++ -- * Streaming results+ -- $streaming++ , stream+ , Internal.Step(..)++ -- * Exceptions+ -- $exceptions++ , Internal.ODBCException(..)++ -- * Debugging+ , renderQuery+ ) where+++import Control.DeepSeq+import Control.Exception+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Data.Char+import Data.Data+import Data.Fixed+import Data.Foldable+import Data.Int+import Data.Monoid+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Data.String+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import Data.Time+import Data.Word+import Database.ODBC.Conversion+import Database.ODBC.Internal (Value(..), Connection)+import qualified Database.ODBC.Internal as Internal+import qualified Formatting+import Formatting ((%))+import Formatting.Time as Formatting+import GHC.Generics+import Text.Printf++-- $building+--+-- You have to compile your projects using the @-threaded@ flag to+-- GHC. In your .cabal file, this would look like:+--+-- @+-- ghc-options: -threaded+-- @++-- $usage+--+-- An example program using this library:+--+-- @+-- {-\# LANGUAGE OverloadedStrings \#-}+-- import Database.ODBC+-- main :: IO ()+-- main = do+-- conn <-+-- connect+-- "DRIVER={ODBC Driver 13 for SQL Server};SERVER=192.168.99.100;Uid=SA;Pwd=Passw0rd"+-- exec conn "DROP TABLE IF EXISTS example"+-- exec conn "CREATE TABLE example (id int, name ntext, likes_tacos bit)"+-- exec conn "INSERT INTO example VALUES (1, \'Chris\', 0), (2, \'Mary\', 1)"+-- rows <- query conn "SELECT * FROM example" :: IO [[Maybe Value]]+-- print rows+-- rows2 <- query conn "SELECT * FROM example" :: IO [(Int,Text,Bool)]+-- print rows2+-- close conn+-- @+--+-- The @rows@ list contains rows of some value that could be+-- anything. The @rows2@ list contains tuples of exactly @Int@,+-- @Text@ and @Bool@. This is achieved via the 'FromRow' class.+--+-- You need the @OverloadedStrings@ extension so that you can write+-- 'Text' values for the queries and executions.+--+-- The output of this program for @rows@:+--+-- @+-- [[Just (IntValue 1),Just (TextValue \"Chris\"),Just (BoolValue False)],[Just (IntValue 2),Just (TextValue \"Mary\"),Just (BoolValue True)]]+-- @+--+-- The output for @rows2@:+--+-- @+-- [(1,\"Chris\",False),(2,\"Mary\",True)]+-- @++-- $exceptions+--+-- Proper connection handling should guarantee that a close happens at+-- the right time. Here is a better way to write it:+--+-- @+-- {-\# LANGUAGE OverloadedStrings \#-}+-- import Control.Exception+-- import Database.ODBC.SQLServer+-- main :: IO ()+-- main =+-- bracket+-- (connect+-- "DRIVER={ODBC Driver 13 for SQL Server};SERVER=192.168.99.100;Uid=SA;Pwd=Passw0rd")+-- close+-- (\\conn -> do+-- rows <- query conn "SELECT N'Hello, World!'"+-- print rows)+-- @+--+-- If an exception occurs inside the lambda, 'bracket' ensures that+-- 'close' is called.++-- $streaming+--+-- Loading all rows of a query result can be expensive and use a lot+-- of memory. Another way to load data is by fetching one row at a+-- time, called streaming.+--+-- Here's an example of finding the longest string from a set of+-- rows. It outputs @"Hello!"@. We only work on 'Text', we ignore+-- for example the @NULL@ row.+--+-- @+-- {-\# LANGUAGE OverloadedStrings, LambdaCase \#-}+-- import qualified Data.Text as T+-- import Control.Exception+-- import Database.ODBC.SQLServer+-- main :: IO ()+-- main =+-- bracket+-- (connect+-- \"DRIVER={ODBC Driver 13 for SQL Server};SERVER=192.168.99.101;Uid=SA;Pwd=Passw0rd\")+-- close+-- (\\conn -> do+-- exec conn \"DROP TABLE IF EXISTS example\"+-- exec conn \"CREATE TABLE example (name ntext)\"+-- exec+-- conn+-- \"INSERT INTO example VALUES (\'foo\'),(\'bar\'),(NULL),(\'mu\'),(\'Hello!\')\"+-- longest <-+-- stream+-- conn+-- \"SELECT * FROM example\"+-- (\\longest mtext ->+-- pure+-- (Continue+-- (maybe+-- longest+-- (\\text ->+-- if T.length text > T.length longest+-- then text+-- else longest)+-- mtext)))+-- \"\"+-- print longest)+-- @++--------------------------------------------------------------------------------+-- Types++-- | A query builder. Use 'toSql' to convert Haskell values to this+-- type safely.+--+-- It's an instance of 'IsString', so you can use @OverloadedStrings@+-- to produce plain text values e.g. @"SELECT 123"@.+--+-- It's an instance of 'Monoid', so you can append fragments together+-- with '<>' e.g. @"SELECT * FROM x WHERE id = " <> toSql 123@.+--+-- This is meant as a bare-minimum of safety and convenience.+newtype Query =+ Query (Seq Part)+ deriving (Monoid, Eq, Show, Typeable, Ord, Generic, Data)++instance NFData Query++instance IsString Query where+ fromString = Query . Seq.fromList . pure . fromString++-- | A part of a query.+data Part+ = TextPart !Text+ | ValuePart !Value+ deriving (Eq, Show, Typeable, Ord, Generic, Data)++instance NFData Part++instance IsString Part where+ fromString = TextPart . T.pack++--------------------------------------------------------------------------------+-- Conversion to SQL++-- | Handy class for converting values to a query safely.+--+-- For example: @query c (\"SELECT * FROM demo WHERE id > \" <> toSql 123)@+--+-- WARNING: Note that if you insert a value like an 'Int' (64-bit)+-- into a column that is @int@ (32-bit), then be sure that your number+-- fits inside an @int@. Try using an 'Int32' instead to be+-- sure.++-- Below next to each instance you can read which Haskell types+-- corresponds to which SQL Server type.+--+class ToSql a where+ toSql :: a -> Query++-- | Converts whatever the 'Value' is to SQL.+instance ToSql Value where+ toSql = Query . Seq.fromList . pure . ValuePart++-- | Corresponds to NTEXT (Unicode) of SQL Server.+instance ToSql Text where+ toSql = toSql . TextValue++-- | Corresponds to NTEXT (Unicode) of SQL Server.+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.+instance ToSql ByteString where+ toSql = toSql . ByteStringValue++instance ToSql Internal.Binary where+ toSql = toSql . BinaryValue++-- | Corresponds to TEXT (non-Unicode) of SQL Server. For Unicode, use+-- the 'Text' type.+instance ToSql L.ByteString where+ toSql = toSql . ByteStringValue . L.toStrict++-- | Corresponds to BIT type of SQL Server.+instance ToSql Bool where+ toSql = toSql . BoolValue++-- | Corresponds to FLOAT type of SQL Server.+instance ToSql Double where+ toSql = toSql . DoubleValue++-- | Corresponds to REAL type of SQL Server.+instance ToSql Float where+ toSql = toSql . FloatValue++-- | Corresponds to BIGINT type of SQL Server.+instance ToSql Int where+ toSql = toSql . IntValue++-- | Corresponds to SMALLINT type of SQL Server.+instance ToSql Int16 where+ toSql = toSql . IntValue . fromIntegral++-- | Corresponds to INT type of SQL Server.+instance ToSql Int32 where+ toSql = toSql . IntValue . fromIntegral++-- | Corresponds to TINYINT type of SQL Server.+instance ToSql Word8 where+ toSql = toSql . ByteValue++-- | Corresponds to DATE type of SQL Server.+instance ToSql Day where+ toSql = toSql . DayValue++-- | Corresponds to TIME type of SQL Server.+--+-- 'TimeOfDay' supports more precision than the @time@ type of SQL+-- server, so you will lose precision and not get back what you inserted.+instance ToSql TimeOfDay where+ toSql = toSql . TimeOfDayValue++-- | Corresponds to DATETIME/DATETIME2 type of SQL Server.+--+-- The 'LocalTime' type has more accuracy than the @datetime@ type and+-- the @datetime2@ types can hold; so you will lose precision when you+-- insert.+instance ToSql LocalTime where+ toSql = toSql . LocalTimeValue++--------------------------------------------------------------------------------+-- Top-level functions++-- | Query and return a list of rows.+--+-- The @row@ type is inferred based on use or type-signature. Examples+-- might be @(Int, Text, Bool)@ for concrete types, or @[Maybe Value]@+-- if you don't know ahead of time how many columns you have and their+-- type. See the top section for example use.+query ::+ (MonadIO m, FromRow row)+ => 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+ Right rows' -> pure rows'+ Left e -> liftIO (throwIO (Internal.DataRetrievalError e))++-- | Render a query to a plain text string. Useful for debugging and+-- testing.+renderQuery :: Query -> Text+renderQuery (Query ps) = (renderParts (toList ps))++-- | Stream results like a fold with the option to stop at any time.+stream ::+ (MonadIO m, MonadUnliftIO m, FromRow row)+ => Connection -- ^ A connection to the database.+ -> Query -- ^ SQL query.+ -> (state -> row -> m (Internal.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.+stream c (Query ps) cont nil =+ Internal.stream+ c+ (renderParts (toList ps))+ (\state row ->+ case fromRow row of+ Left e -> liftIO (throwIO (Internal.DataRetrievalError e))+ Right row' -> cont state row')+ nil++-- | Execute a statement on the database.+exec ::+ MonadIO m+ => Connection -- ^ A connection to the database.+ -> Query -- ^ SQL statement.+ -> m ()+exec c (Query ps) = Internal.exec c (renderParts (toList ps))++--------------------------------------------------------------------------------+-- Query building++-- | Convert a list of parts into a query.+renderParts :: [Part] -> Text+renderParts = T.concat . map renderPart++-- | Render a query part to a query.+renderPart :: Part -> Text+renderPart =+ \case+ TextPart t -> t+ ValuePart v -> renderValue v++-- | Render a value to a query.+renderValue :: Value -> Text+renderValue =+ \case+ TextValue t -> "(N'" <> T.concatMap escapeChar t <> "')"+ BinaryValue (Internal.Binary bytes) ->+ "0x" <>+ T.concat+ (map+ (Formatting.sformat+ (Formatting.left 2 '0' Formatting.%. Formatting.hex))+ (S.unpack bytes))+ ByteStringValue xs ->+ "('" <> T.concat (map escapeChar8 (S.unpack xs)) <> "')"+ BoolValue True -> "1"+ BoolValue False -> "0"+ ByteValue n -> Formatting.sformat Formatting.int n+ DoubleValue d -> Formatting.sformat Formatting.float d+ FloatValue d -> Formatting.sformat Formatting.float (realToFrac d :: Double)+ IntValue d -> Formatting.sformat Formatting.int d+ DayValue d -> Formatting.sformat ("'" % Formatting.dateDash % "'") d+ TimeOfDayValue (TimeOfDay hh mm ss) ->+ Formatting.sformat+ ("'" % Formatting.left 2 '0' % ":" % Formatting.left 2 '0' % ":" %+ Formatting.string %+ "'")+ hh+ mm+ (renderFractional ss)+ LocalTimeValue (LocalTime d (TimeOfDay hh mm ss)) ->+ Formatting.sformat+ ("'" % Formatting.dateDash % " " % Formatting.left 2 '0' % ":" %+ Formatting.left 2 '0' %+ ":" %+ Formatting.string %+ "'")+ d+ hh+ mm+ (renderFractional ss)++-- | Obviously, this is not fast. But it is correct. A faster version+-- can be written later.+renderFractional :: Pico -> String+renderFractional x = trim (printf "%.7f" (realToFrac x :: Double) :: String)+ where+ trim s =+ reverse (case dropWhile (== '0') (reverse s) of+ s'@('.':_) -> '0' : s'+ s' -> s')++-- | A very conservative character escape.+escapeChar8 :: Word8 -> Text+escapeChar8 ch =+ if allowedChar (toEnum (fromIntegral ch))+ then T.singleton (toEnum (fromIntegral ch))+ else "'+CHAR(" <> Formatting.sformat Formatting.int ch <> ")+'"++-- | A very conservative character escape.+escapeChar :: Char -> Text+escapeChar ch =+ if allowedChar ch+ then T.singleton ch+ else "'+NCHAR(" <> Formatting.sformat Formatting.int (fromEnum ch) <> ")+'"++-- | Is the character allowed to be printed unescaped? We only print a+-- small subset of ASCII just for visually debugging later+-- on. Everything else is escaped.+allowedChar :: Char -> Bool+allowedChar c = (isAlphaNum c && isAscii c) || elem c (" ,.-_" :: [Char])
+ test/Main.hs view
@@ -0,0 +1,538 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Test suite.++module Main where++import Control.Exception (try, onException, SomeException, catch, throwIO)+import Control.Monad+import Control.Monad.IO.Class+import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import Data.Char+import Data.Functor.Identity+import Data.Int+import Data.Monoid+import Data.Ratio+import Data.String+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Time+import Data.Word+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 (ToSql(..))+import qualified Database.ODBC.SQLServer as SQLServer+import System.Environment+import Test.Hspec+import Test.QuickCheck+import Test.QuickCheck.Monadic+import Text.Printf++--------------------------------------------------------------------------------+-- Tests++main :: IO ()+main = do+ mconnStr <- lookupEnvUnquote "ODBC_TEST_CONNECTION_STRING"+ putStrLn ("Using connection string: " ++ show mconnStr)+ hspec spec++spec :: Spec+spec = do+ describe+ "Database.ODBC.Internal"+ (do describe "Connectivity" connectivity+ describe "Regression tests" regressions+ describe "Data retrieval" dataRetrieval+ describe "Big data" bigData)+ describe+ "Database.ODBC.SQLServer"+ (describe "Conversion to SQL" conversionTo)++regressions :: Spec+regressions = do+ it+ "Internal.exec can return SQL_NO_DATA"+ (do c <- connectWithString+ Internal.exec c "DROP TABLE IF EXISTS wibble"+ Internal.exec c "CREATE TABLE wibble (i integer)"+ Internal.exec c "DELETE FROM wibble"+ Internal.close c)++-- | Test fields with large data like megabytes of text. Just to check+-- we don't have some kind of hard limit problem.+bigData :: Spec+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)++conversionTo :: Spec+conversionTo = do+ -- See <https://docs.microsoft.com/en-us/sql/t-sql/data-types/int-bigint-smallint-and-tinyint-transact-sql>+ describe+ "maxBound"+ (do roundtrip @Int "maxBound(Int64)" "Int" "bigint" maxBound+ roundtrip @Int "maxBound(Int32)" "Int" "int" (fromIntegral (maxBound :: Int32))+ roundtrip @Int "maxBound(Int16)" "Int" "smallint" (fromIntegral (maxBound :: Int16))+ roundtrip @Word8 "maxBound(Word8)" "Word8" "tinyint" maxBound)+ describe+ "minBound"+ (do roundtrip @Int "minBound(Int64)" "Int" "bigint" minBound+ roundtrip @Int "minBound(Int32)" "Int" "int" (fromIntegral (minBound :: Int32))+ roundtrip @Int "minBound(Int16)" "Int" "smallint" (fromIntegral (minBound :: Int16))+ roundtrip @Word8 "minBound(Word8)" "Word8" "tinyint" minBound)+ quickCheckRoundtrip @Day "Day" "date"+ quickCheckRoundtrip @LocalTime "LocalTime" "datetime2"+ quickCheckRoundtrip @TestDateTime "TestDateTime" "datetime"+ quickCheckOneway @TimeOfDay "TimeOfDay" "time"+ quickCheckRoundtrip @TestTimeOfDay "TimeOfDay" "time"+ quickCheckRoundtrip @Float "Float" "real"+ quickCheckRoundtrip @Double "Double" "float"+ quickCheckRoundtrip @Double "Float" "float"+ quickCheckRoundtrip @Word8 "Word8" "tinyint"+ quickCheckRoundtrip @Int "Int" "bigint"+ quickCheckRoundtrip @Bool "Bool" "bit"+ quickCheckRoundtrip @Text "Text" "ntext"+ quickCheckRoundtrip @Text "Text" ("nvarchar(" <> (show maxStringLen) <> ")")+ quickCheckRoundtrip @ByteString "ByteString" "text"+ quickCheckRoundtrip @ByteString "ByteString" ("varchar(" <> (show maxStringLen) <> ")")+ quickCheckRoundtrip @TestBinary "ByteString" ("binary(" <> (show maxStringLen) <> ")")+ quickCheckRoundtrip @Binary "ByteString" ("varbinary(" <> (show maxStringLen) <> ")")++connectivity :: Spec+connectivity = do+ it+ "Connect, no close"+ (do _ <- connectWithString+ shouldBe True True)+ it+ "Connect, explicit close"+ (do c <- connectWithString+ Internal.close c+ shouldBe True True)+ it+ "Double close fails"+ (shouldThrow+ (do c <- connectWithString+ Internal.close c+ Internal.close c)+ (== DatabaseAlreadyClosed))+ it+ "Connect/disconnect loop"+ (do sequence_ [connectWithString >>= Internal.close | _ <- [1 :: Int .. 10]]+ shouldBe True True)++dataRetrieval :: Spec+dataRetrieval = do+ it+ "Basic sanity check"+ (do c <- connectWithString+ Internal.exec c "DROP TABLE IF EXISTS test"+ Internal.exec+ c+ "CREATE TABLE test (int integer, text text, bool bit, nt ntext, fl float)"+ Internal.exec+ c+ "INSERT INTO test VALUES (123, 'abc', 1, 'wib', 2.415), (456, 'def', 0, 'wibble',0.9999999999999), (NULL, NULL, NULL, NULL, NULL)"+ rows <- Internal.query c "SELECT * FROM test"+ Internal.close c+ shouldBe+ rows+ [ [ Just (IntValue 123)+ , Just (ByteStringValue "abc")+ , Just (BoolValue True)+ , Just (TextValue "wib")+ , Just (DoubleValue 2.415)+ ]+ , [ Just (IntValue 456)+ , Just (ByteStringValue "def")+ , Just (BoolValue False)+ , Just (TextValue "wibble")+ , Just (DoubleValue 0.9999999999999)+ ]+ , [Nothing, Nothing, Nothing, Nothing, Nothing]+ ])+ it+ "Querying commands with no results"+ (do c <- connectWithString+ rows1 <- Internal.query c "DROP TABLE IF EXISTS no_such_table"+ rows2 <-+ Internal.stream+ c+ "DROP TABLE IF EXISTS no_such_table"+ (\s _ -> pure (Stop s))+ []+ shouldBe (rows1 ++ rows2) [])+ quickCheckInternalRoundtrip+ "Int"+ "bigint"+ (T.pack . show)+ (\case+ IntValue b -> pure b+ _ -> Nothing)+ quickCheckInternalRoundtrip+ "Double"+ "float"+ (T.pack . printf "%f")+ (\case+ DoubleValue b -> pure (realToFrac b :: Double)+ _ -> Nothing)+ quickCheckInternalRoundtrip+ "Float"+ "float"+ (T.pack . printf "%f")+ (\case+ DoubleValue b -> pure (realToFrac b :: Float)+ _ -> Nothing)+ quickCheckInternalRoundtrip+ "Float"+ "real"+ (T.pack . printf "%f")+ (\case+ FloatValue b -> pure b+ _ -> Nothing)+ quickCheckInternalRoundtrip+ "Text"+ "ntext"+ showText+ (\case+ TextValue b -> pure b+ _ -> Nothing)+ quickCheckInternalRoundtrip+ "ByteString"+ "text"+ showBytes+ (\case+ ByteStringValue b -> pure b+ _ -> Nothing)+ quickCheckInternalRoundtrip+ "Text"+ ("nvarchar(" <> T.pack (show maxStringLen) <> ")")+ showText+ (\case+ TextValue b -> pure b+ _ -> Nothing)+ quickCheckInternalRoundtrip+ "ByteString"+ ("varchar(" <> T.pack (show maxStringLen) <> ")")+ showBytes+ (\case+ ByteStringValue b -> pure b+ _ -> Nothing)+ quickCheckInternalRoundtrip+ "Bool"+ "bit"+ (\case+ True -> "1"+ False -> "0")+ (\case+ BoolValue b -> pure b+ _ -> Nothing)++--------------------------------------------------------------------------------+-- Combinators++roundtrip ::+ forall t. (Eq t, Show t, ToSql t, FromValue t)+ => String+ -> String+ -> String+ -> t+ -> Spec+roundtrip why l typ input =+ it+ ("Roundtrip " <> why <> ": HS=" <> l <> ", SQL=" <> typ)+ (do c <- connectWithString+ SQLServer.exec c "DROP TABLE IF EXISTS test"+ SQLServer.exec c ("CREATE TABLE test (f " <> fromString typ <> ")")+ let q = "INSERT INTO test VALUES (" <> toSql (input) <> ")"+ SQLServer.exec c q+ [Identity (!result)] <- SQLServer.query c "SELECT * FROM test"+ SQLServer.close c+ shouldBe result input)++quickCheckRoundtrip ::+ forall t. (Arbitrary t, Eq t, Show t, ToSql t, FromValue t)+ => String+ -> String+ -> Spec+quickCheckRoundtrip l typ =+ beforeAll+ (do c <- connectWithString+ SQLServer.exec c "DROP TABLE IF EXISTS test"+ SQLServer.exec c ("CREATE TABLE test (f " <> fromString typ <> ")")+ pure c)+ (afterAll+ SQLServer.close+ (it+ ("QuickCheck roundtrip: HS=" <> l <> ", SQL=" <> typ)+ (\c ->+ property+ (\input ->+ monadicIO+ (do SQLServer.exec c "TRUNCATE TABLE test"+ let q =+ "INSERT INTO test VALUES (" <> toSql (input :: t) <>+ ")"+ liftIO+ (catch+ (SQLServer.exec c q)+ (\e -> do+ print (e :: SomeException)+ T.putStrLn (SQLServer.renderQuery q)+ SQLServer.close c+ throwIO e))+ [Identity result] <-+ SQLServer.query c "SELECT f FROM test"+ when+ (result /= input)+ (liftIO+ (putStr+ (unlines+ [ "Expected: " ++ show input+ , "Actual: " ++ show result+ , "Query was: " ++ show q+ ])))+ monitor+ (counterexample+ (unlines+ [ "Expected: " ++ show input+ , "Actual: " ++ show result+ , "Query was: " +++ T.unpack (SQLServer.renderQuery q)+ ]))+ assert (result == input))))))++quickCheckOneway ::+ forall t. (Arbitrary t, Eq t, Show t, ToSql t, FromValue t)+ => String+ -> String+ -> Spec+quickCheckOneway l typ =+ beforeAll+ (do c <- connectWithString+ SQLServer.exec c "DROP TABLE IF EXISTS test"+ SQLServer.exec c ("CREATE TABLE test (f " <> fromString typ <> ")")+ pure c)+ (afterAll+ SQLServer.close+ (it+ ("QuickCheck one-way: HS=" <> l <> ", SQL=" <> typ)+ (\c ->+ property+ (\input ->+ monadicIO+ (do (let q = "TRUNCATE TABLE test"+ in liftIO+ (onException+ (SQLServer.exec c q)+ ((T.putStrLn (SQLServer.renderQuery q)))))+ let q =+ "INSERT INTO test VALUES (" <> toSql (input :: t) <>+ ")"+ liftIO+ (onException+ (SQLServer.exec c q)+ ((T.putStrLn (SQLServer.renderQuery q))))+ [Identity result] <-+ SQLServer.query c "SELECT f FROM test"+ monitor+ (counterexample+ (unlines+ [ "Expected: " ++ show input+ , "Actual: " ++ show (result :: t)+ , "Query was: " +++ T.unpack (SQLServer.renderQuery q)+ ]))+ assert True)))))++quickCheckInternalRoundtrip ::+ forall t. (Eq t, Show t, Arbitrary t)+ => Text+ -> Text+ -> (t -> Text)+ -> (Value -> Maybe t)+ -> Spec+quickCheckInternalRoundtrip hstype typ shower unpack =+ beforeAll+ (do c <- connectWithString+ Internal.exec c "DROP TABLE IF EXISTS test"+ Internal.exec c ("CREATE TABLE test (f " <> typ <> ")")+ pure c)+ (afterAll+ Internal.close+ (it+ ("QuickCheck roundtrip: HS=" <> T.unpack hstype <> ", SQL=" <>+ T.unpack typ)+ (\c ->+ property+ (\input ->+ monadicIO+ (do Internal.exec c "TRUNCATE TABLE test"+ let q =+ "INSERT INTO test VALUES (" <> shower input <> ")"+ rows <-+ liftIO+ (try+ (do onException+ (Internal.exec c q)+ (putStrLn "Exec failed.")+ onException+ (Internal.query c "SELECT * FROM test")+ (putStrLn "Query failed!")))+ let expected :: Either String t+ expected = Right input+ result :: Either String t+ result =+ case rows of+ Right [[Just x]] ->+ case unpack x of+ Nothing -> Left "Couldn't unpack value."+ Just v -> pure v+ Right _ ->+ Left "Invalid number of values returned."+ Left (_ :: SomeException) ->+ Left+ "Couldn't get value from row in test suite."+ when+ (result /= expected)+ (liftIO+ (putStr+ (unlines+ [ "Expected: " ++ show expected+ , "Actual: " ++ show rows+ , "Query was: " ++ show q+ , "QuickCheck value: " ++ show input+ ])))+ monitor+ (counterexample+ (unlines+ [ "Expected: " ++ show expected+ , "Actual: " ++ show rows+ , "Query was: " ++ show q+ ]))+ assert (result == expected))))))++--------------------------------------------------------------------------------+-- Helpers++showBytes :: ByteString -> Text+showBytes t = "'" <> T.pack (S8.unpack t) <> "'"++showText :: Text -> Text+showText t = "N'" <> t <> "'"++validTextChar :: Char -> Bool+validTextChar = \c -> c /= '\'' && c /= '\n' && c /= '\r'++--------------------------------------------------------------------------------+-- Constants++maxStringLen :: Int+maxStringLen = 1024++connectWithString :: IO Connection+connectWithString = do+ mconnStr <- lookupEnvUnquote "ODBC_TEST_CONNECTION_STRING"+ case mconnStr of+ Just connStr+ | not (null connStr) -> Internal.connect (T.pack connStr)+ _ ->+ error+ "Need ODBC_TEST_CONNECTION_STRING environment variable.\n\+ \Example:\n\+ \ODBC_TEST_CONNECTION_STRING='DRIVER={ODBC Driver 13 for SQL Server};SERVER=127.0.0.1;Uid=SA;Pwd=Passw0rd;Encrypt=no'"++-- | I had trouble passing in environment variables via Docker on+-- Travis without the value coming in with quotes around it.+lookupEnvUnquote :: String -> IO (Maybe [Char])+lookupEnvUnquote = fmap (fmap strip) . lookupEnv+ where strip = reverse . dropWhile (=='"') . reverse . dropWhile (=='"')++--------------------------------------------------------------------------------+-- Orphan instances++instance Arbitrary Text where+ arbitrary =+ fmap (T.filter validTextChar . T.pack . take maxStringLen) arbitrary++instance Arbitrary ByteString where+ arbitrary =+ fmap+ (S8.filter (\c -> isAscii c && validTextChar c) .+ S8.pack . take maxStringLen)+ arbitrary++instance Arbitrary Binary where+ arbitrary = fmap SQLServer.Binary arbitrary++newtype TestBinary = TestBinary Binary+ deriving (Show, Eq, Ord, SQLServer.ToSql, FromValue)++instance Arbitrary TestBinary where+ arbitrary = do+ bytes <- arbitrary+ pure+ (TestBinary+ (SQLServer.Binary+ (S.take maxStringLen (bytes <> S.replicate maxStringLen 0))))++instance Arbitrary Day where+ arbitrary = do+ offset <- choose (0, 30000)+ pure (addDays offset (fromGregorian 1753 01 01))++instance Arbitrary TimeOfDay where+ arbitrary = do+ fractional <- choose (0, 9999999) :: Gen Integer+ seconds <- choose (0, 86400)+ pure+ (timeToTimeOfDay+ (secondsToDiffTime seconds + (fromRational (fractional % 10000000))))++instance Arbitrary LocalTime where+ arbitrary = LocalTime <$> arbitrary <*> arbitraryLimited+ where+ arbitraryLimited = do+ fractional <- choose (0, 9999999) :: Gen Integer+ seconds <- choose (0, 86400)+ pure+ (timeToTimeOfDay+ (secondsToDiffTime seconds + (fromRational (fractional % 10000000))))++newtype TestDateTime = TestDateTime LocalTime+ deriving (Eq, Ord, Show, SQLServer.ToSql, FromValue)++newtype TestTimeOfDay = TestTimeOfDay TimeOfDay+ deriving (Eq, Ord, Show, SQLServer.ToSql, FromValue)++instance Arbitrary TestTimeOfDay where+ arbitrary = do+ seconds <- choose (0, 86400)+ pure (TestTimeOfDay (timeToTimeOfDay (secondsToDiffTime seconds)))++instance Arbitrary TestDateTime where+ arbitrary = fmap TestDateTime (LocalTime <$> arbitrary <*> arbitraryLimited)+ where+ arbitraryLimited = do+ fractional <- elements [993, 003, 497, 007, 000, 127] :: Gen Integer+ -- Rounded to increments of .000, .003, or .007 seconds+ -- from: https://docs.microsoft.com/en-us/sql/t-sql/data-types/datetime-transact-sql+ seconds <- choose (0, 86400)+ pure+ (timeToTimeOfDay+ (secondsToDiffTime seconds + (fromRational (fractional % 1000))))