diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,84 @@ -# odbc +# odbc [![Build Status](https://travis-ci.org/fpco/odbc.svg)](https://travis-ci.org/fpco/odbc) [![Build status](https://ci.appveyor.com/api/projects/status/vpn6a1pme25upbux?svg=true)](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 [![Build status](https://ci.appveyor.com/api/projects/status/vpn6a1pme25upbux?svg=true)](https://ci.appveyor.com/project/chrisdone/odbc-0os0b) +* Linux [![Build Status](https://travis-ci.org/fpco/odbc.svg)](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. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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: " + +-- | 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 diff --git a/bench/Space.hs b/bench/Space.hs new file mode 100644 --- /dev/null +++ b/bench/Space.hs @@ -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 (=='"') diff --git a/cbits/odbc.c b/cbits/odbc.c new file mode 100644 --- /dev/null +++ b/cbits/odbc.c @@ -0,0 +1,314 @@ +#ifdef _WIN32 +#include +#endif +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#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; +} diff --git a/odbc.cabal b/odbc.cabal --- a/odbc.cabal +++ b/odbc.cabal @@ -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 diff --git a/src/Database/ODBC/Conversion.hs b/src/Database/ODBC/Conversion.hs new file mode 100644 --- /dev/null +++ b/src/Database/ODBC/Conversion.hs @@ -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)) diff --git a/src/Database/ODBC/Internal.hs b/src/Database/ODBC/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/ODBC/Internal.hs @@ -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 +-- 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 diff --git a/src/Database/ODBC/SQLServer.hs b/src/Database/ODBC/SQLServer.hs new file mode 100644 --- /dev/null +++ b/src/Database/ODBC/SQLServer.hs @@ -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]) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + 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))))