sqlcli 0.1.0.0 → 0.2.0.0
raw patch · 4 files changed
+846/−158 lines, 4 filesdep +loggingdep +text
Dependencies added: logging, text
Files
- ChangeLog +93/−0
- sqlcli.cabal +7/−3
- src/SQL/CLI.hs +43/−25
- src/SQL/CLI/Utils.hs +703/−130
+ ChangeLog view
@@ -0,0 +1,93 @@+2017-12-26 Mihai Giurgeanu <mihai.giurgeanu@gmail.com>+ * src/SQL/CLI.hs (SQLINTEGER): fix SQLINTEGER problems with ODBC on 64 bit platforms by using SQLLEN and SQLHANDLE+ Changed all definitions taking a length parameter to use SQLLEN and SQLULEN types instead of SQLINTEGER.+ +2017-11-30 Mihai Giurgeanu <mihai.giurgeanu@gmail.com>++ * src/SQL/CLI/Utils.hs (fetchAndRunWithFail): new function similar to fetchAndRun but offering control on fail conditions+ (forAllRecordsWithEndAndFail): new function similar to forAllRecords but gives control over end and fail conditions++2017-11-28 Mihai Giurgeanu <mihai.giurgeanu@gmail.com>++ * src/SQL/CLI/Utils.hs (collectColumnsInfo): refactor collectColumnsInfo into 2 functions: colllectColumnsInfo and collectColumnsInfo'++2017-11-10 Mihai Giurgeanu <mihai.giurgeanu@gmail.com>++ * src/SQL/CLI/Utils.hs (collectColumnsInfo): sort the columns list by the ordinal position of the column in the table++2017-11-09 Mihai Giurgeanu <mihai.giurgeanu@gmail.com>++ * src/SQL/CLI.hs (SQLINTEGER): changed definition of SQLINTEGER to 32 bit CInt++ * src/SQL/CLI/Utils.hs (collectColumnsInfo): clear size and buffer_length buffers after each record++2017-11-01 Mihai Giurgeanu <mihai.giurgeanu@gmail.com>++ * src/SQL/CLI/Utils.hs: use a simple logging framework instead of hPutStrLn stderr++2017-09-18 Mihai Giurgeanu <mihai.giurgeanu@gmail.com>++ * src/SQL/CLI/Utils.hs (getDataAndRun): check the lenOrInd to see if more data is available+ (getCountOfDiagRecs): initialize return buffer with 0++2017-09-17 Mihai Giurgeanu <mihai.giurgeanu@gmail.com>++ * src/SQL/CLI/Utils.hs (endTran): add EndTran wrapper+ (collectColumnsInfo): log to stderr before calling forAllRecords+ (getDataAndRun): don't display warnings on more data+ (displayDiagRec): add function displayDiagRec++2017-09-16 Mihai Giurgeanu <mihai.giurgeanu@gmail.com>++ * src/SQL/CLI/Utils.hs (setConnectAttr): add SetConnectAttr wrapper++2017-09-13 Mihai Giurgeanu <mihai.giurgeanu@gmail.com>++ * src/SQL/CLI/Utils.hs (tableExists): add schema name parameter+ (collectColumnsInfo): add schema name parameter+ (paramData): fix error when ParamData returns success+ (getCountOfDiagRecs): fix reading diagnostic records count return type+ (getDataAndRun): fix checking for more date in diagnostics++2017-09-12 Mihai Giurgeanu <mihai.giurgeanu@gmail.com>++ * src/SQL/CLI/Utils.hs (getDescField): add wrapper for GetDescField+ (setDescField): add wrapper for SetDescField+ (toCLIType): add toCLIType function++ * src/SQL/CLI.hs (sql_desc_octet_length_ptr): fix spelling++2017-09-11 Mihai Giurgeanu <mihai.giurgeanu@gmail.com>++ * src/SQL/CLI/Utils.hs (getDesRec): add wrapper for SQL/CLI function+ GetDescRec+ (setDescRec): add wrapper for SQL/CLI function SetDescRec+ (getStorableStmtAttr): add helper function, getStorableStmtAttr+ (getData): fixed doc+ (forAllData): add forAllData function++2017-09-10 Mihai Giurgeanu <mihai.giurgeanu@gmail.com>++ * src/SQL/CLI/Utils.hs (getStmtAttr): add wrapper for the SQL/CLI function+ GetStmtAttr+ (numResultCols): add wrapper for the SQL/CLI function NumResultCols++2017-09-09 Mihai Giurgeanu <mihai.giurgeanu@gmail.com>++ * src/SQL/CLI/Utils.hs (paramData): add wrapper to SQL/CLI function ParamData+ (putData): add wrapper to SQL/CLI function PutData+ (bindParam): add wrapper for SQL/CLI function BindParam++ * src/SQL/CLI.hs (sqlparamdata): change second parameter to Ptr SQLPOINTER++ * src/SQL/CLI/Utils.hs (prepare): add wrapper to Prepare SQL/CLI API call++ * src/SQL/CLI.hs (sqlexecute): fix the name of imported function++ * src/SQL/CLI/Utils.hs (execDirect): add feeddata action to supply data+ for dynamic parameters+ (execute): add wrapper for Execute SQL/CLI api call++Copyright 2017 Mihai Giurgeanu+Copying and distribution of this file, with or without modification, are+permitted provided the copyright notice and this notice are preserved.
sqlcli.cabal view
@@ -1,5 +1,5 @@ name: sqlcli-version: 0.1.0.0+version: 0.2.0.0 synopsis: Sql Call-Level Interface bindings for Haskell. description: Provides bindings to SQL/CLI C API, importing all foreign functions defined in the specifications,@@ -17,7 +17,7 @@ copyright: 2017 Mihai Giurgeanu category: Database build-type: Simple-extra-source-files: README.md+extra-source-files: README.md, ChangeLog cabal-version: >=1.10 Flag ODBC@@ -30,10 +30,14 @@ exposed-modules: SQL.CLI, SQL.CLI.Utils build-depends: base >= 4.7 && < 5,- transformers >= 0.5 && < 0.6+ transformers >= 0.5 && < 0.6,+ logging >= 3.0 && < 4,+ text >= 0.11.3.1 default-language: Haskell2010+ other-extensions: CPP, ForeignFunctionInterface if flag(odbc)+ cpp-options: -DODBC if os(windows) extra-libraries: odbc32 else
src/SQL/CLI.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ForeignFunctionInterface, CPP #-} module SQL.CLI where @@ -7,7 +7,15 @@ import Data.Bits ((.&.), complement) -- API declaration data types type SQLCHAR = CUChar++-- in ODBC, SQLINTEGER is defined as int, but in SQLCLI spec+-- it is defined as long+#ifdef ODBC+type SQLINTEGER = CInt+#else type SQLINTEGER = CLong+#endif+ type SQLSMALLINT = CShort type SQLDOUBLE = CDouble type SQLFLOAT = CDouble@@ -24,11 +32,17 @@ type SQLRETURN = SQLSMALLINT -- generic data structures-type SQLHENV = SQLINTEGER-type SQLHDBC = SQLINTEGER-type SQLHSTMT = SQLINTEGER-type SQLHDESC = SQLINTEGER+-- we use SQLHANDLE type to be compatible with ODBC definitions+type SQLHANDLE = CLong+type SQLHENV = SQLHANDLE+type SQLHDBC = SQLHANDLE+type SQLHSTMT = SQLHANDLE+type SQLHDESC = SQLHANDLE +-- using SQLLEN and SQLULEN types to be compatible with ODBC definitions+type SQLLEN = CLong+type SQLULEN = CULong+ -- special length/indicator values -- The value of 'sql_null_data' should -- not be changed; it was chosen for compatibility with the@@ -144,8 +158,8 @@ sql_desc_length :: Num a => a sql_desc_length = 1003 -sql_desc_octet_lenth_ptr :: Num a => a-sql_desc_octet_lenth_ptr = 1004+sql_desc_octet_length_ptr :: Num a => a+sql_desc_octet_length_ptr = 1004 sql_desc_precision :: Num a => a sql_desc_precision = 1005@@ -966,37 +980,41 @@ foreign import ccall "SQLAllocConnect" sqlallocconnect :: SQLHENV -> Ptr SQLHDBC -> IO SQLRETURN foreign import ccall "SQLAllocEnv" sqlallocenv :: Ptr SQLHENV -> IO SQLRETURN-foreign import ccall "SQLAllocHandle" sqlallochandle :: SQLSMALLINT -> SQLINTEGER -> Ptr SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLAllocHandle" sqlallochandle :: SQLSMALLINT -> SQLHANDLE -> Ptr SQLHANDLE -> IO SQLRETURN foreign import ccall "SQLAllocStmt" sqlallocstmt :: SQLHDBC -> Ptr SQLHSTMT -> IO SQLRETURN-foreign import ccall "SQLBindCol" sqlbindcol :: SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLINTEGER -> Ptr SQLINTEGER -> IO SQLRETURN-foreign import ccall "SQLBindParam" sqlbindparam :: SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLSMALLINT -> SQLINTEGER -> SQLSMALLINT -> SQLPOINTER -> Ptr SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLBindCol" sqlbindcol :: SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLLEN -> Ptr SQLLEN -> IO SQLRETURN+foreign import ccall "SQLBindParam" sqlbindparam :: SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLSMALLINT -> SQLULEN -> SQLSMALLINT -> SQLPOINTER -> Ptr SQLLEN -> IO SQLRETURN foreign import ccall "SQLCancel" sqlcancel :: SQLHSTMT -> IO SQLRETURN foreign import ccall "SQLCloseCursor" sqlclosecursor :: SQLHSTMT -> IO SQLRETURN+#ifdef ODBC+foreign import ccall "SQLColAttribute" sqlcolattribute :: SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLLEN -> IO SQLRETURN+#else foreign import ccall "SQLColAttribute" sqlcolattribute :: SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLSMALLINT -> Ptr SQLSMALLINT -> SQLPOINTER -> IO SQLRETURN+#endif foreign import ccall "SQLColumns" sqlcolumns :: SQLHSTMT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> IO SQLRETURN foreign import ccall "SQLConnect" sqlconnect :: SQLHDBC -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> IO SQLRETURN foreign import ccall "SQLCopyDesc" sqlopydesc :: SQLHDESC -> SQLHDESC -> IO SQLRETURN foreign import ccall "SQLDataSources" sqldatasources :: SQLHENV -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN-foreign import ccall "SQLDescribeCol" sqldescribecol :: SQLHSTMT -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLINTEGER -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLDescribeCol" sqldescribecol :: SQLHSTMT -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLULEN -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN foreign import ccall "SQLDisconnect" sqldisconnect :: SQLHDBC -> IO SQLRETURN-foreign import ccall "SQLEndTran" sqlendtran :: SQLSMALLINT -> SQLINTEGER -> SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLEndTran" sqlendtran :: SQLSMALLINT -> SQLHANDLE -> SQLSMALLINT -> IO SQLRETURN foreign import ccall "SQLError" sqlerror :: SQLHENV -> SQLHDBC -> SQLHSTMT -> Ptr SQLCHAR -> Ptr SQLINTEGER -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN foreign import ccall "SQLExecDirect" sqlexecdirect :: SQLHSTMT -> Ptr SQLCHAR -> SQLINTEGER -> IO SQLRETURN-foreign import ccall "SQLExecute" sqexecute :: SQLHSTMT -> IO SQLRETURN+foreign import ccall "SQLExecute" sqlexecute :: SQLHSTMT -> IO SQLRETURN foreign import ccall "SQLFetch" sqlfetch :: SQLHSTMT -> IO SQLRETURN-foreign import ccall "SQLFetchScroll" sqlfetchscroll :: SQLHSTMT -> SQLSMALLINT -> SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLFetchScroll" sqlfetchscroll :: SQLHSTMT -> SQLSMALLINT -> SQLLEN -> IO SQLRETURN foreign import ccall "SQLFreeConnect" sqlfreeconnect :: SQLHDBC -> IO SQLRETURN foreign import ccall "SQLFreeEnv" sqlfreeenv :: SQLHENV -> IO SQLRETURN-foreign import ccall "SQLFreeHandle" sqlfreehandle :: SQLSMALLINT -> SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLFreeHandle" sqlfreehandle :: SQLSMALLINT -> SQLHANDLE -> IO SQLRETURN foreign import ccall "SQLFreeStmt" sqlfreestmt :: SQLHSTMT -> SQLSMALLINT -> IO SQLRETURN foreign import ccall "SQLGetConnectAttr" sqlgetconnectattr :: SQLHDBC -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> Ptr SQLINTEGER -> IO SQLRETURN foreign import ccall "SQLGetConnectOption" sqlgetconnectoption :: SQLHDBC -> SQLSMALLINT -> SQLPOINTER -> IO SQLRETURN foreign import ccall "SQLGetCursorName" sqlgetcursorname :: SQLHSTMT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN-foreign import ccall "SQLGetData" sqlgetdata :: SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLINTEGER -> Ptr SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLGetData" sqlgetdata :: SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLLEN -> Ptr SQLLEN -> IO SQLRETURN foreign import ccall "SQLGetDescField" sqlgetdescfield :: SQLHDESC -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLINTEGER -> Ptr SQLINTEGER -> IO SQLRETURN-foreign import ccall "SQLGetDescRec" sqlgetdescrec :: SQLHDESC -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLINTEGER -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN-foreign import ccall "SQLGetDiagField" sqlgetdiagfield :: SQLSMALLINT -> SQLINTEGER -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN-foreign import ccall "SQLGetDiagRec" sqlgetdiagrec :: SQLSMALLINT -> SQLINTEGER -> SQLSMALLINT -> Ptr SQLCHAR -> Ptr SQLINTEGER -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLGetDescRec" sqlgetdescrec :: SQLHDESC -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLLEN -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLGetDiagField" sqlgetdiagfield :: SQLSMALLINT -> SQLHANDLE -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLGetDiagRec" sqlgetdiagrec :: SQLSMALLINT -> SQLHANDLE -> SQLSMALLINT -> Ptr SQLCHAR -> Ptr SQLINTEGER -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN foreign import ccall "SQLGetEnvAttr" sqlgetenvattr :: SQLHENV -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> Ptr SQLINTEGER -> IO SQLRETURN foreign import ccall "SQLGetFunctions" sqlgetfunctions :: SQLHDBC -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN foreign import ccall "SQLGetInfo" sqlgetinfo :: SQLHDBC -> SQLSMALLINT -> SQLPOINTER -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN@@ -1004,21 +1022,21 @@ foreign import ccall "SQLGetStmtOption" sqlgetstmtoption :: SQLHSTMT -> SQLSMALLINT -> SQLPOINTER -> IO SQLRETURN foreign import ccall "SQLGetTypeInfo" sqlgettypeinfo :: SQLHSTMT -> SQLSMALLINT -> IO SQLRETURN foreign import ccall "SQLNumResultCols" sqlnumresultcols :: SQLHSTMT -> Ptr SQLSMALLINT -> IO SQLRETURN-foreign import ccall "SQLParamData" sqlparamdata :: SQLHSTMT -> SQLPOINTER -> IO SQLRETURN+foreign import ccall "SQLParamData" sqlparamdata :: SQLHSTMT -> Ptr SQLPOINTER -> IO SQLRETURN foreign import ccall "SQLPrepare" sqlprepare :: SQLHSTMT -> Ptr SQLCHAR -> SQLINTEGER -> IO SQLRETURN-foreign import ccall "SQLPutData" sqlputdata :: SQLHSTMT -> SQLPOINTER -> SQLINTEGER -> IO SQLRETURN-foreign import ccall "SQLRowCount" sqlrowcount :: SQLHSTMT -> Ptr SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLPutData" sqlputdata :: SQLHSTMT -> SQLPOINTER -> SQLLEN -> IO SQLRETURN+foreign import ccall "SQLRowCount" sqlrowcount :: SQLHSTMT -> Ptr SQLLEN -> IO SQLRETURN foreign import ccall "SQLSetConnectAttr" sqlsetconnectattr :: SQLHDBC -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> IO SQLRETURN foreign import ccall "SQLSetConnectOption" sqlsetconnectoption :: SQLHDBC -> SQLSMALLINT -> SQLPOINTER -> IO SQLRETURN foreign import ccall "SQLSetCursorName" sqlsetcursorname :: SQLHSTMT -> Ptr SQLCHAR -> SQLSMALLINT -> IO SQLRETURN foreign import ccall "SQLSetDescField" sqlsetdescfield :: SQLHDESC -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLINTEGER -> IO SQLRETURN-foreign import ccall "SQLSetDescRec" sqlsetdescrec :: SQLHDESC -> SQLSMALLINT -> SQLSMALLINT -> SQLSMALLINT -> SQLINTEGER -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> Ptr SQLINTEGER -> Ptr SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLSetDescRec" sqlsetdescrec :: SQLHDESC -> SQLSMALLINT -> SQLSMALLINT -> SQLSMALLINT -> SQLINTEGER -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> Ptr SQLLEN -> Ptr SQLLEN -> IO SQLRETURN foreign import ccall "SQLSetEnvAttr" sqlsetenvattr :: SQLHENV -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> IO SQLRETURN -- sqlsetparam is another name for sqlbindparam-foreign import ccall "SQLBindParam" sqlsetparam :: SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLSMALLINT -> SQLINTEGER -> SQLSMALLINT -> SQLPOINTER -> Ptr SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLBindParam" sqlsetparam :: SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLSMALLINT -> SQLULEN -> SQLSMALLINT -> SQLPOINTER -> Ptr SQLLEN -> IO SQLRETURN -foreign import ccall "SQLSetStmtAttr" sqlsetstmtattr :: SQLHSTMT -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLSetStmtAttr" sqlsetstmtattr :: SQLHSTMT -> SQLINTEGER -> SQLPOINTER -> SQLULEN -> IO SQLRETURN foreign import ccall "SQLSetStmtOption" sqlsetstmtoption :: SQLHSTMT -> SQLSMALLINT -> SQLPOINTER -> IO SQLRETURN foreign import ccall "SQLSpecialColumns" sqlspecialcolumns :: SQLHSTMT -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> SQLSMALLINT -> SQLSMALLINT -> IO SQLRETURN foreign import ccall "SQLStatistics" sqlstatistics :: SQLHSTMT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> SQLSMALLINT -> SQLSMALLINT -> IO SQLRETURN
src/SQL/CLI/Utils.hs view
@@ -1,19 +1,24 @@ -- Provides a more convenient way to use SQLCLI API from Haskell module SQL.CLI.Utils where -import Prelude hiding (fail) +import Prelude hiding (fail, log) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Fail (MonadFail, fail) +import Control.Logging (log, debugS) + import System.IO (hPutStrLn, stderr) import Foreign.C.String (withCStringLen, peekCString, peekCStringLen, CStringLen, CString) import Foreign.Marshal.Alloc (alloca, allocaBytes) -import Foreign.Storable (Storable, peek, peekElemOff, sizeOf) +import Foreign.Storable (Storable, peek, peekElemOff, sizeOf, poke) import Foreign.Ptr (nullPtr, castPtr, Ptr) -import Data.Maybe (catMaybes, maybe) +import Data.Maybe (maybe) +import Data.String (IsString(fromString)) +import Data.Text (Text) +import Data.List (insert) import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) import Control.Monad.Trans.Reader (ReaderT, asks) @@ -26,14 +31,28 @@ sqldescribecol, sqldisconnect, sqlexecdirect, + sqlexecute, + sqlprepare, sqlbindcol, sqlfetch, sqlgetdata, sqltables, sqlcolumns, + sqlparamdata, + sqlputdata, + sqlbindparam, + sqlgetstmtattr, + sqlnumresultcols, + sqlgetdescrec, + sqlsetdescrec, + sqlgetdescfield, + sqlsetdescfield, + sqlsetconnectattr, + sqlendtran, sql_handle_env, sql_handle_dbc, sql_handle_stmt, + sql_handle_desc, sql_null_handle, sql_error, sql_diag_number, @@ -47,14 +66,39 @@ sql_char, sql_smallint, sql_integer, + sql_numeric, + sql_decimal, + sql_integer, + sql_smallint, + sql_float, + sql_real, + sql_double, + sql_datetime, + sql_varchar, sql_no_nulls, SQLSMALLINT, SQLINTEGER, SQLHENV, SQLHDBC, SQLHSTMT, - SQLPOINTER) + SQLHDESC, + SQLCHAR, + SQLPOINTER, + SQLHANDLE, + SQLLEN, + SQLULEN) +logsrc :: Text +logsrc = fromString "SQL.CLI.Utils" + +-- | convert an implementation type to a SQL/CLI known type; checks if the type +-- identifier is a SQL/CLI type; if not returns sql_varchar +toCLIType :: SQLSMALLINT -> SQLSMALLINT +toCLIType t = if elem t [sql_char, sql_numeric, sql_decimal, sql_integer, sql_smallint, + sql_float, sql_real, sql_double, sql_datetime, sql_varchar] + then t + else sql_char + -- | configuration values dependent on the actual CLI implementation data SQLConfig = SQLConfig { sql_cli_flds_table_cat :: SQLSMALLINT, -- ^ position of TABLE_CAT column in the resultset returned by Columns API call @@ -97,17 +141,27 @@ ci_CharOctetLength :: Maybe SQLINTEGER, ci_OrdinalPosition :: SQLINTEGER, ci_IsNullable :: Maybe String } - deriving Show + deriving (Eq, Show) +instance Ord ColumnInfo where + compare c1 c2 = compare (ci_OrdinalPosition c1) (ci_OrdinalPosition c2) + -- | Read columns information for a given table on a database connection. It returns a 'ReaderT' value -- that will get implementation dependent fieled numbers in the result set returned by Columns API call -- from a 'SQLConfig' value. -collectColumnsInfo :: (MonadIO m, MonadFail m) => SQLHDBC -> String -> ReaderT SQLConfig m [ColumnInfo] -collectColumnsInfo hdbc tableName = do +collectColumnsInfo :: (MonadIO m, MonadFail m) => SQLHDBC -- ^ connection handle + -> String -- ^ schema name + -> String -- ^ table name + -> ReaderT SQLConfig m [ColumnInfo] +collectColumnsInfo hdbc schemaName tableName = do hstmt <- allocHandle sql_handle_stmt hdbc - columns hstmt Nothing Nothing (Just tableName) Nothing - liftIO $ hPutStrLn stderr "Fetching columns info..." - + columns hstmt Nothing (Just schemaName) (Just tableName) Nothing + collectColumnsInfo' hstmt + +-- | Implements the logic of 'collectColumnsInfo' getting the handle to the statement that +-- was used to call 'sqlcolumns' on +collectColumnsInfo' :: (MonadIO m, MonadFail m) => SQLHSTMT -> ReaderT SQLConfig m [ColumnInfo] +collectColumnsInfo' hstmt = do table_cat_fld <- asks sql_cli_flds_table_cat table_schem_fld <- asks sql_cli_flds_table_schem table_name_fld <- asks sql_cli_flds_table_name @@ -202,8 +256,29 @@ <*> (peekMaybeCol p_char_octet_length p_char_octet_length_ind) <*> (peek p_ordinal_position) <*> (peekMaybeTextCol p_is_nullable p_is_nullable_ind) - return (col:cols') + liftIO $ poke p_data_type 0 + liftIO $ poke p_column_size 0 + liftIO $ poke p_buffer_length 0 + liftIO $ poke p_decimal_digits 0 + liftIO $ poke p_num_prec_radix 0 + liftIO $ poke p_nullable 0 + liftIO $ poke p_datetime_code 0 + liftIO $ poke p_char_octet_length 0 + liftIO $ poke p_ordinal_position 0 + liftIO $ poke p_table_cat_ind 0 + liftIO $ poke p_column_size_ind 0 + liftIO $ poke p_buffer_length_ind 0 + liftIO $ poke p_decimal_digits_ind 0 + liftIO $ poke p_num_prec_radix_ind 0 + liftIO $ poke p_remarks_ind 0 + liftIO $ poke p_column_def_ind 0 + liftIO $ poke p_datetime_code_ind 0 + liftIO $ poke p_char_octet_length_ind 0 + liftIO $ poke p_is_nullable_ind 0 + + return $ insert col cols' + in runMaybeT $ do bindVarcharCol hstmt table_cat_fld p_table_cat 129 p_table_cat_ind bindVarcharCol hstmt table_schem_fld p_table_schem 129 nullPtr @@ -222,7 +297,7 @@ bindIntegerCol hstmt char_octet_length_fld p_char_octet_length p_char_octet_length_ind bindIntegerCol hstmt ordinal_position_fld p_ordinal_position nullPtr bindVarcharCol hstmt is_nullable_fld p_is_nullable 255 p_is_nullable_ind - + liftIO $ log $ fromString "reading columns info records" forAllRecords hstmt readColumnInfo []))))))))))))))))))))))))))) liftIO $ freeHandle sql_handle_stmt hstmt maybe (fail "collectColumnsInfo failed") return cols @@ -230,10 +305,13 @@ -- | Checks if a table exists on the current connection. -tableExists :: (MonadIO m, MonadFail m) => SQLHDBC -> String -> m Bool -tableExists hdbc tableName = do +tableExists :: (MonadIO m, MonadFail m) => SQLHDBC -- ^ connection handle + -> String -- ^ schema name + -> String -- ^ table name + -> m Bool +tableExists hdbc schemaName tableName = do tables_stmt <- allocHandle sql_handle_stmt hdbc - tables tables_stmt Nothing Nothing (Just tableName) Nothing + tables tables_stmt Nothing (Just schemaName) (Just tableName) Nothing exists <- fetch tables_stmt liftIO $ freeHandle sql_handle_stmt tables_stmt return exists @@ -241,12 +319,436 @@ -- SQLCLI wrappers +-- | wrapper to SQL/CLI function EndTran; it creates a monadic action to call +-- the foreign API function and to log diagnostics on the standard output; it +-- fails if the API call fails +endTran :: (MonadIO m, MonadFail m) => + SQLSMALLINT -- ^ handle type + -> SQLHANDLE -- ^ handle + -> SQLSMALLINT -- ^ completion type; either sql_commit or sql_rollback + -> m () +endTran handleType handle completion = do + result <- liftIO $ sqlendtran handleType handle completion + case result of + x | x == sql_success -> return () + | x == sql_error -> do + let err = "call to SQL/CLI function EndTran failed, on handle type: " ++ (show handleType) + liftIO $ log $ fromString err + liftIO $ displayDiagInfo handleType handle + fail err + | x == sql_success_with_info -> do + liftIO $ log $ fromString $ "call to SQL/CLI function EndTran generated warnings for handle type: " ++ (show handleType) + liftIO $ displayDiagInfo handleType handle + | x == sql_invalid_handle -> do + let err = "invalid handle was given to a call to the SQL/CLI function EndTran, for handle type: " ++ (show handleType) + liftIO $ log $ fromString err + fail err + | otherwise -> do + let err = "unexpected result was returned by a call to SQL/CLI function EndTran for handleType " ++ (show handleType) ++ ": " ++ (show x) + liftIO $ log $ fromString err + liftIO $ displayDiagInfo handleType handle + fail err + +-- | wrapper for SQL/CLI function SetConnectAttr; it creates a monadic action +-- that calls the foreign API function and logs diagnostics on standard error; +-- it fails if the API call fails +setConnectAttr :: (MonadIO m, MonadFail m) => SQLHDBC -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> m () +setConnectAttr hdbc attribute value stringLen = do + result <- liftIO $ sqlsetconnectattr hdbc attribute value stringLen + case result of + x | x == sql_success -> return () + | x == sql_error -> do + let err = "call to SQL/CLI function SetConnectAttr failed for attribute: " ++ (show attribute) + liftIO $ log $ fromString err + liftIO $ displayDiagInfo sql_handle_dbc hdbc + fail err + | x == sql_success_with_info -> do + liftIO $ log $ fromString $ "call to SQL/CLI function SetConnectAttr returned warnings for attribute " ++ (show attribute) + liftIO $ displayDiagInfo sql_handle_dbc hdbc + | x == sql_invalid_handle -> do + let err = "invalid handle given to SQL/CLI function SetConnectAtr when setting attribute: " ++ (show attribute) + liftIO $ log $ fromString err + fail err + | otherwise -> do + let err = "unknown result returned by the call of SQL/CLI function SetConnectAttr for attribute " ++ (show attribute) ++ ": " ++ (show attribute) + liftIO $ log $ fromString err + liftIO $ displayDiagInfo sql_handle_dbc hdbc + fail err + +-- | wrapper for SQL/CLI function SetDescField; it creates a monadic action +-- that calls the API function, logs diagnostic on standard output and fails +-- if the API call fails +setDescField :: (MonadIO m, MonadFail m) => SQLHDESC -- ^ descriptor handle + -> SQLSMALLINT -- ^ record number + -> SQLSMALLINT -- ^ field identifier + -> Ptr a -- ^ pointer to the buffer holding the value + -> SQLINTEGER -- ^ length in octets of the value; if the field is not a string, + -- the field is ignored + -> m () +setDescField hdesc recno field pbuf buflen = do + result <- liftIO $ sqlsetdescfield hdesc recno field (castPtr pbuf) buflen + case result of + x | x == sql_success -> return () + | x == sql_error -> do + let err = "call to SQL/CLI function SetDescField failed, for record " ++ (show recno) ++ ", field " ++ (show field) + liftIO $ log $ fromString err + liftIO $ displayDiagInfo sql_handle_desc hdesc + fail err + | x == sql_success_with_info -> do + liftIO $ log $ fromString $ "call to SQL/CLI function SetDescField for record " ++ (show recno) ++ ", field " ++ (show field) ++ " generated warnings" + liftIO $ displayDiagInfo sql_handle_desc hdesc + | x == sql_invalid_handle -> do + let err = "invalid handle was given to a call to SQL/CLI function SetDescField for record " ++ (show recno) ++ ", field " ++ (show field) + liftIO $ log $ fromString err + fail err + | otherwise -> do + let err = "unexpected result code was returned by the call to SQL/CLI function SetDescField for record " ++ (show recno) ++ ", field " ++ (show field) ++ ": " ++ (show x) + liftIO $ log $ fromString err + liftIO $ displayDiagInfo sql_handle_desc hdesc + fail err + +-- | wrapper for SQL/CLI function GetDescField; it creates a monadic action +-- that calls the API function, logs disgnostic on standard output and +-- fails if the API call fails +getDescField :: (MonadIO m, MonadFail m) => SQLHDESC -- ^ descriptor handle + -> SQLSMALLINT -- ^ record number, starts with 1; when getting header fields it must be 0 + -> SQLSMALLINT -- ^ field identifier + -> Ptr a -- ^ pointer to buffer to receive the value of the field + -> SQLINTEGER -- ^ the length in bytes of the value's buffer + -> Ptr SQLINTEGER -- ^ pointer to a buffer to receive the length in octets of the value, if the + -- value si a character string; otherwise, unused + -> m () +getDescField hdesc recno field pbuf buflen plen = do + result <- liftIO $ sqlgetdescfield hdesc recno field (castPtr pbuf) buflen plen + case result of + x | x == sql_success -> return () + | x == sql_error -> do + let err = "call to SQL/CLI function GetDescField failed for record " ++ (show recno) ++", field " ++ (show field) + liftIO $ log $ fromString err + liftIO $ displayDiagInfo sql_handle_desc hdesc + fail err + | x == sql_success_with_info -> do + liftIO $ log $ fromString $ "call to SQL/CLI function for record " ++ (show recno) ++ ", field " ++ (show field) ++ " generated warnings" + liftIO $ displayDiagInfo sql_handle_desc hdesc + | x == sql_invalid_handle -> do + let err = "invalid handle was given to the call of getDescField for record " ++ (show recno) ++ ", field " ++ (show field) + liftIO $ log $ fromString err + fail err + | otherwise -> do + let err = "unexpected result code returned by the call to SQL/CLI function GetDescField for record " ++ (show recno) ++ ", field " ++ (show field) ++ ": " ++ (show x) + liftIO $ log $ fromString err + liftIO $ displayDiagInfo sql_handle_desc hdesc + fail err + +-- | wrapper for SQL/CLI function SetDescRec; it gets the same parameters as the +-- function described in the API and creates a monadic action that fails if the +-- API call fails and logs the diagnostics to standard error +setDescRec :: (MonadIO m, MonadFail m) => SQLHDESC -- ^ (input) descriptor handle + -> SQLSMALLINT -- ^ (input) record number; it starts from 1 + -> SQLSMALLINT -- ^ (input) the TYPE field for record + -> SQLSMALLINT -- ^ (input) the DATETIME_INTERVAL_CODE field, for records whose TYPE is SQL_DATETIME + -> SQLINTEGER -- ^ (input) the OCTET_LENGTH field for the record + -> SQLSMALLINT -- ^ (input) the PRECISION field for the record + -> SQLSMALLINT -- ^ (input) the SCALE field for the record + -> Ptr a -- ^ (input) DATA_PTR field for the record + -> Ptr SQLLEN -- ^ (input) OCTET_LENGTH_PTR field for the record + -> Ptr SQLLEN -- ^ (input) INDICATOR_PTR field for the record + -> m () +setDescRec hdesc recno coltype subtype len precision scale p_data p_stringlength p_indicator = do + result <- liftIO $ sqlsetdescrec hdesc recno coltype subtype len precision scale (castPtr p_data) p_stringlength p_indicator + case result of + x | x == sql_success -> return () + | x == sql_error -> do + let err = "call to SQL/CLI function SetDescRec failed for record number " ++ (show recno) + liftIO $ log $ fromString err + liftIO $ displayDiagInfo sql_handle_desc hdesc + fail err + | x == sql_success_with_info -> do + liftIO $ log $ fromString $ "call to SQL/CLI function SetDescRec generated warnings for record number " ++ (show recno) + liftIO $ displayDiagInfo sql_handle_desc hdesc + | x == sql_invalid_handle -> do + let err = "invalid handle was given to the call of SQL/CLI function SetDescRec for record number " ++ (show recno) + liftIO $ log $ fromString err + fail err + | otherwise -> do + let err = "unexpected result code (" ++ (show x) ++ ") returned by the call to SQL/CLI function SetDescRec for record number " ++ (show recno) + liftIO $ log $ fromString err + liftIO $ displayDiagInfo sql_handle_desc hdesc + fail err + +-- | wrapper for SQL/CLI function GetDescRec; it gets the same parameters as the +-- function described in the API and creates a monadic action that fails if the +-- API call fails and logs the diagnostics to standard error +getDescRec :: (MonadIO m, MonadFail m) => SQLHDESC -- ^ (input) descriptor handle + -> SQLSMALLINT -- ^ (input) record number, starts from 1 + -> Ptr SQLCHAR -- ^ (output) buffer to receive the column name + -> SQLSMALLINT -- ^ (input) name buffer length + -> Ptr SQLSMALLINT -- ^ (output) buffer to receive the actual length of the name + -> Ptr SQLSMALLINT -- ^ (output) the TYPE field of the record + -> Ptr SQLSMALLINT -- ^ (output) the DATETIME_INTERVAL_CODE field, for records whose TYPE is SQL_DATETIME + -> Ptr SQLLEN -- ^ (output) the OCTET_LENGTH field of the recorrd + -> Ptr SQLSMALLINT -- ^ (output) the PRECISION field of the record + -> Ptr SQLSMALLINT -- ^ (output) the SCALE field of the record + -> Ptr SQLSMALLINT -- ^ (output) the NULLABLE field of the record + -> m () +getDescRec hdesc recno p_colname buflen p_namelen p_type p_subtype p_length p_precision p_scale p_nullable = do + result <- liftIO $ sqlgetdescrec hdesc recno p_colname buflen p_namelen p_type p_subtype p_length p_precision p_scale p_nullable + case result of + x | x == sql_success -> return () + | x == sql_error -> do + let err = "call to SQL/CLI function GetDescRec failed" + liftIO $ log $ fromString err + liftIO $ displayDiagInfo sql_handle_desc hdesc + fail err + | x == sql_success_with_info -> do + let err = "call to SQL/CLI function GetDescRec returned warnings" + liftIO $ log $ fromString err + liftIO $ displayDiagInfo sql_handle_desc hdesc + | x == sql_invalid_handle -> do + let err = "invalid handle was given to the call of SQL/CLI functiion GetDescRec" + liftIO $ log $ fromString err + fail err + | x == sql_no_data -> do + let err = "(GetDescRec) there is no record in the descriptor for this record number: " ++ (show recno) + liftIO $ log $ fromString err + fail err + | otherwise -> do + let err = "unexpected result code was returned by the call to SQL/CLI function GetDescRec: " ++ (show x) + liftIO $ log $ fromString err + fail err + +-- | wrapper for SQL/CLI function NumResultCols; it fails if the API call fails and +-- it displays diagnostic information on the standard error +numResultCols :: (MonadIO m, MonadFail m) => SQLHSTMT -> m SQLSMALLINT +numResultCols hstmt = do + cols <- liftIO $ alloca + (\ p_cols -> do + result <- sqlnumresultcols hstmt p_cols + let cols = Just <$> peek p_cols + case result of + x | x == sql_success -> cols + | x == sql_error -> do + log $ fromString "call to SQL/CLI function NumResultCols failed" + displayDiagInfo sql_handle_stmt hstmt + return Nothing + | x == sql_success_with_info -> do + log $ fromString "call to SQL/CLI function NumResultColss returned warnings" + displayDiagInfo sql_handle_stmt hstmt + cols + | x == sql_invalid_handle -> do + log $ fromString "invalid handle given to call to SQL/CLI function NumResultCols" + return Nothing + | otherwise -> do + log $ fromString $ "unexpected value returned by a call to NumResultCols: " ++ (show x) + displayDiagInfo sql_handle_stmt hstmt + return Nothing ) + maybe (fail "numResultCols failed") return cols + +-- | helper function to get the value of a `Storable` statement attribute +getStorableStmtAttr :: (MonadIO m, MonadFail m, Storable a) => SQLHSTMT -> SQLINTEGER -> m a +getStorableStmtAttr hstmt attr = do + value <- liftIO $ alloca + (\ p_value -> runMaybeT $ do + getStmtAttr hstmt attr p_value 0 nullPtr + liftIO $ peek p_value) + maybe (fail $ "failed to get the statement's attribute value for attribute: " ++ (show attr)) return value + +-- | wrapper for SQL/CLI function GetStmtAttr; it displays diagnostic info on the +-- standard error and it fails if the call SQL/CLI call fails +getStmtAttr :: (MonadIO m, MonadFail m) => SQLHSTMT -- ^ statement handle + -> SQLINTEGER -- ^ the attribute identifier + -> Ptr a -- ^ buffer to receive the attribute's value + -> SQLINTEGER -- ^ the length of the buffer in octets, if the attribute's value + -- is string, otherwise it is unused + -> Ptr SQLINTEGER -- ^ pointer to buffer to receive the actual length of the attribute's + -- value, if it is a string value, otherwise it is unused + -> m () +getStmtAttr hstmt attribute p_buf buflen p_vallen = do + result <- liftIO $ sqlgetstmtattr hstmt attribute (castPtr p_buf) buflen p_vallen + case result of + x | x == sql_success -> return () + | x == sql_error -> do + let err = "error calling SQL/CLI function 'GetStmtAttr' for attribute " ++ (show attribute) + liftIO $ log $ fromString err + liftIO $ displayDiagInfo sql_handle_stmt hstmt + fail err + | x == sql_success_with_info -> do + liftIO $ log $ fromString $ "getting statement attribute " ++ (show attribute) ++ " returned warnings" + liftIO $ displayDiagInfo sql_handle_stmt hstmt + | x == sql_invalid_handle -> do + let err = "invalid handle was given to a call to SQL/CLI function GetStmtAttr for attribute " ++ (show attribute) + liftIO $ log $ fromString err + fail err + | otherwise -> do + let err = "unexpected result returned by a call to SQL/CLI function GetStmtAttr for attribute " ++ (show attribute) + liftIO $ log $ fromString err + liftIO $ displayDiagInfo sql_handle_stmt hstmt + fail err + +-- | wrapper for SQL/CLI function, BindParam; it displayes diagnostics on standard error +bindParam :: (MonadIO m, MonadFail m) => SQLHSTMT -- ^ statement handle + -> SQLSMALLINT -- ^ parameter number + -> SQLSMALLINT -- ^ value type + -> SQLSMALLINT -- ^ parameter type + -> SQLULEN -- ^ length precision + -> SQLSMALLINT -- ^ parameter scale + -> Ptr a -- ^ parameter value + -> Ptr SQLLEN -- ^ string length or indicator + -> m () +bindParam hstmt paramno valtype paramtype paramlenprec paramscale p_value p_strlen_or_ind = do + result <- liftIO $ sqlbindparam hstmt paramno valtype paramtype paramlenprec paramscale (castPtr p_value) p_strlen_or_ind + case result of + x | x == sql_success -> return () + | x == sql_error -> do + let err = "Error binding parameter " ++ (show paramno) + liftIO $ log $ fromString err + liftIO $ displayDiagInfo sql_handle_stmt hstmt + fail err + | x == sql_success_with_info -> do + liftIO $ log $ fromString $ "binding parameter " ++ (show paramno) ++ " returned with warnings" + liftIO $ displayDiagInfo sql_handle_stmt hstmt + | x == sql_invalid_handle -> do + let err = "biniding parameter " ++ (show paramno) ++ " was invoked with an invalid statement handler" + liftIO $ log $ fromString err + fail err + | otherwise -> do + let err = "binding parameter " ++ (show paramno) ++ " returned unexepcted result: " ++ (show x) + liftIO $ log $ fromString err + liftIO $ displayDiagInfo sql_handle_stmt hstmt + fail err + + +-- | wrapper for PutData SQL/CLI api call; it displays diagnostics on standard error +putData :: (MonadIO m, MonadFail m) => SQLHSTMT -> Ptr a -> SQLLEN -> m () +putData hstmt p_buf len = do + result <- liftIO $ sqlputdata hstmt (castPtr p_buf) len + case result of + x | x == sql_success -> return () + | x == sql_error -> do + let err = "error in the call of SQL/CLI function PutData" + liftIO $ log $ fromString err + liftIO $ displayDiagInfo sql_handle_stmt hstmt + fail err + | x == sql_success_with_info -> do + liftIO $ log $ fromString "call to SQL/CLI function PutData returned warnings" + liftIO $ displayDiagInfo sql_handle_stmt hstmt + | x == sql_invalid_handle -> do + let err = "an invalid handle was used when calling putData" + liftIO $ log $ fromString err + fail err + | otherwise -> do + let err = "call to SQL/CLI function PutData returned unexpected result: " ++ (show x) + liftIO $ log $ fromString err + liftIO $ displayDiagInfo sql_handle_stmt hstmt + fail err + +-- | wrapper for ParamData SQL/CLI API call; it gets a statement handle and a function that +-- knows how to supply parameter data; this function gets the value DATA_PTR field of the +-- record in the application parameter descriptor that relates to the dynamic parameter for +-- which the implementation requires information. +-- +-- The successful return of this call means that all parameter data has been supplied and the +-- sql statement has been executed. +paramData :: (MonadIO m, MonadFail m) => SQLHSTMT -> (SQLPOINTER -> m ()) -> m () +paramData hstmt f = do + (result, value) <- liftIO $ alloca (\ p_value -> do + result' <- sqlparamdata hstmt p_value + value' <- peek p_value + return (result', value')) + case result of + x | x == sql_need_data -> do + f value + paramData hstmt f + | x == sql_error -> do + let err = "call to SQL/CLI function ParamData failed" + liftIO $ log $ fromString err + liftIO $ displayDiagInfo sql_handle_stmt hstmt + fail err + | x == sql_success -> return () + | x == sql_success_with_info -> do + liftIO $ log $ fromString "(ParamData) statement executed but generated warnings" + liftIO $ displayDiagInfo sql_handle_stmt hstmt + | x == sql_no_data -> do + liftIO $ log $ fromString "ParamData: statement executed but returned no_data" + liftIO $ displayDiagInfo sql_handle_stmt hstmt + | x == sql_invalid_handle -> do + let err = "invalid handle has been given to paramData" + liftIO $ log $ fromString err + fail err + | otherwise -> do + let err = "unexpected result returned by a call to SQL/CLI function ParamData: " ++ (show x) + liftIO $ log $ fromString err + liftIO $ displayDiagInfo sql_handle_stmt hstmt + fail err + +-- | wrapper for Prepare SQL/CLI API call +prepare :: (MonadIO m, MonadFail m) => SQLHSTMT -> String -> m () +prepare hstmt sql = do + result <- liftIO $ withCStringLen sql + (\ (p_sql, len_sql) -> sqlprepare hstmt (castPtr p_sql) (fromIntegral len_sql)) + case result of + x | x == sql_success -> return () + | x == sql_error -> do + let err = "Failed preparing statement: " ++ sql + liftIO $ log $ fromString err + liftIO $ displayDiagInfo sql_handle_stmt hstmt + fail err + | x == sql_success_with_info -> liftIO $ do + log $ fromString $ "Statement prepared but warnings were returned: " ++ sql + displayDiagInfo sql_handle_stmt hstmt + | x == sql_invalid_handle -> do + let err = "Failed preparing statement because an invalid handle was given to 'prepare' call: " ++ sql + liftIO $ log $ fromString err + fail err + | otherwise -> do + let err = "Unexpected returned code (" ++ (show x) ++ ") was returned by 'sqlprepare' call when preparing statement: " ++ sql + liftIO $ log $ fromString err + liftIO $ displayDiagInfo sql_handle_stmt hstmt + fail err + +-- | wrapper for Execute SQL/CLI API call; it receives ab handle to +-- a prepared statement and a monadic action that should provide +-- dynamic arguments data using calls to 'sqlputdata' and 'sqlparamdata'; +-- this action will be used in the case 'sqlexecute' returns 'sql_need_data', +-- that is, if the prepared statement specifies some dynamic parameters that +-- are not described in the application parameter descriptor (for example, by +-- calling 'sqlbindparam' for that parameter); the action must provide the +-- data for parameters in the order the parameters appear in the sql statement +-- and call 'sqlparamdata' after each parameter data has been provided +execute :: (MonadIO m, MonadFail m) => SQLHSTMT -> m () -> m () +execute hstmt feeddata = do + result <- liftIO $ sqlexecute hstmt + case result of + x | x == sql_success -> return () + | x == sql_success_with_info -> do + liftIO $ log $ fromString "'Execute' API call succeded but returned more info" + liftIO $ displayDiagInfo sql_handle_stmt hstmt + | x == sql_error -> do + let err = "'Execute' API call failed" + liftIO $ log $ fromString err + liftIO $ displayDiagInfo sql_handle_stmt hstmt + fail err + | x == sql_invalid_handle -> do + let err = "'Execute' has been called with invalid statement handle" + liftIO $ log $ fromString err + fail err + | x == sql_no_data -> do + liftIO $ log $ fromString "'Execute' returned SQL_NO_DATA" + liftIO $ displayDiagInfo sql_handle_stmt hstmt + | x == sql_need_data -> do + feeddata + | otherwise -> do + let err = "'Execute' call returned unexpected result: " ++ (show x) + liftIO $ log $ fromString err + liftIO $ displayDiagInfo sql_handle_stmt hstmt + fail err + -- | concise information about a column of a result set, mapping -- the result of SQL CLI API call DescribeCol data ConciseColInfo = ConciseColInfo { cci_ColumnName :: String, cci_DataType :: SQLSMALLINT, - cci_ColumnSize :: SQLINTEGER, + cci_ColumnSize :: SQLULEN, cci_DecimalDigits :: SQLSMALLINT, cci_Nullable :: Bool } @@ -278,18 +780,18 @@ case result of x | x == sql_success -> readInfo | x == sql_success_with_info -> do - hPutStrLn stderr "More information returned by DescribeCol" + log $ fromString "More information returned by DescribeCol" displayDiagInfo sql_handle_stmt hstmt readInfo | x == sql_error -> do - hPutStrLn stderr "Error calling DescribeCol" + log $ fromString "Error calling DescribeCol" displayDiagInfo sql_handle_stmt hstmt return Nothing | x == sql_invalid_handle -> do - hPutStrLn stderr "Invalid handle calling DescribeCol" + log $ fromString "Invalid handle calling DescribeCol" return Nothing | otherwise -> do - hPutStrLn stderr $ "Unexpected result returned by the call to DescribeCol: " ++ (show x) + log $ fromString $ "Unexpected result returned by the call to DescribeCol: " ++ (show x) displayDiagInfo sql_handle_stmt hstmt return Nothing)))))) maybe (fail $ "describeCol " ++ (show colnum) ++ " failed") return info @@ -314,17 +816,17 @@ case result of x | x == sql_success -> return () | x == sql_error -> do - liftIO $ hPutStrLn stderr "Error calling Columns" + liftIO $ log $ fromString "Error calling Columns" liftIO $ displayDiagInfo sql_handle_stmt hstmt fail "Columns failed" | x == sql_success_with_info -> do - liftIO $ hPutStrLn stderr "Columns returned more info" + liftIO $ log $ fromString "Columns returned more info" liftIO $ displayDiagInfo sql_handle_stmt hstmt | x == sql_invalid_handle -> do - liftIO $ hPutStrLn stderr "Invalid statement handle passed to Columns call" + liftIO $ log $ fromString "Invalid statement handle passed to Columns call" fail "Columns failed" | otherwise -> do - liftIO $ hPutStrLn stderr "Unexpected return code returned by call to Columns. Trying to display diagnostic info:" + liftIO $ log $ fromString "Unexpected return code returned by call to Columns. Trying to display diagnostic info:" liftIO $ displayDiagInfo sql_handle_stmt hstmt fail "Columns failed" @@ -349,34 +851,50 @@ x | x == sql_success -> return () | x == sql_error -> do liftIO $ do - hPutStrLn stderr "Error calling Tables" + log $ fromString "Error calling Tables" displayDiagInfo sql_handle_stmt hstmt fail "Tables failed" | x == sql_success_with_info -> do liftIO $ do - hPutStrLn stderr "Tables returned more info" + log $ fromString "Tables returned more info" displayDiagInfo sql_handle_stmt hstmt | x == sql_invalid_handle -> do - liftIO $ hPutStrLn stderr "Invalid handle calling Tables" + liftIO $ log $ fromString "Invalid handle calling Tables" fail "Tables failed" | otherwise -> do liftIO $ do - hPutStrLn stderr $ "Tables returned unexpected result: " ++ (show x) + log $ fromString $ "Tables returned unexpected result: " ++ (show x) displayDiagInfo sql_handle_stmt hstmt fail "Tables failed" -- | applies a function through all the records in a statment, passing an accumulator value and -- combining the actions returned by the function forAllRecords :: (MonadIO m, MonadFail m) => SQLHSTMT -> (a -> m a) -> a -> m a -forAllRecords stmt f accum = fetchAndRun stmt (f accum >>= (\ accum' -> forAllRecords stmt f accum')) (return accum) +forAllRecords stmt f = forAllRecordsWithEndAndFail stmt f return (const fail) +-- | applies a function through all the records in a statment, passing an accumulator value and +-- combining the actions returned by the function; if all records have been successfully fetched, +-- the second function is called; if an error occures, the third function is called, with the error +-- message +forAllRecordsWithEndAndFail :: (MonadIO m, MonadFail m) => SQLHSTMT -> (a -> m a) -> (a -> m a) -> (a -> String -> m a) -> a -> m a +forAllRecordsWithEndAndFail stmt onRecord onEnd onFail accum = fetchAndRunWithFail stmt (onRecord accum >>= (\ accum' -> forAllRecordsWithEndAndFail stmt onRecord onEnd onFail accum')) (onEnd accum) (onFail accum) + +-- | exhaust all data of a column extracting all data chunks with GetData SQL/CLI call, and calling a function after extraction +-- of each chunk passing it an accumulator value; the function should construct a monadic action that will deal with the extracted +-- data chunk; in the end, these actions are combined in the monadic value returned by the 'forAllData' +forAllData :: (MonadIO m, MonadFail m) => SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLLEN -> Ptr SQLLEN -> (a -> m a) -> a -> m a +forAllData hstmt colNum targetType p_buf bufLen p_lenOrInd f accum = + getDataAndRun hstmt colNum targetType p_buf bufLen p_lenOrInd + (f accum >>= (\ accum' -> forAllData hstmt colNum targetType p_buf bufLen p_lenOrInd f accum')) + (f accum) + -- | Read data from a column and checks the diagnostics, returning a 'True' or 'False' value inside a monadic action. -- It returns 'True' if more data is available for read, and 'False' otherwise. It fails in 'MaybeT' 'IO' monad if -- an error occured. It displays the diagnostics on the error on the standard error. -getData :: (MonadIO m, MonadFail m) => SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLINTEGER -> Ptr SQLINTEGER -> m Bool +getData :: (MonadIO m, MonadFail m) => SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLLEN -> Ptr SQLLEN -> m Bool getData hstmt colNum targetType p_buf bufLen p_lenOrInd = getDataAndRun hstmt colNum targetType p_buf bufLen p_lenOrInd (return True) (return False) --- | Read data available in a column of a fetched database record inside a monadic. It fails if +-- | Read data available in a column of a fetched database record inside a monadic action. It fails if -- an error occurs, displaying the diagnostics on the standard error. It receives 2 monadic actions -- parameters: -- @@ -385,40 +903,60 @@ -- -- It executes the more action if there is more data available and it executes the end action if all -- data in the column has been read. -getDataAndRun :: (MonadIO m, MonadFail m) => SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLINTEGER -> Ptr SQLINTEGER -> m a -> m a -> m a +getDataAndRun :: (MonadIO m, MonadFail m) => SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLLEN -> Ptr SQLLEN -> m a -> m a -> m a getDataAndRun hstmt colNum targetType p_buf bufLen p_lenOrInd more end = do result <- liftIO $ sqlgetdata hstmt colNum targetType p_buf bufLen p_lenOrInd case result of x | x == sql_success -> end | x == sql_invalid_handle -> do - liftIO $ hPutStrLn stderr "Invalid handle when calling GetData" + liftIO $ log $ fromString "Invalid handle when calling GetData" fail "GetData failed" | x == sql_error -> do liftIO $ do - hPutStrLn stderr "Error calling GetData" + log $ fromString "Error calling GetData" displayDiagInfo sql_handle_stmt hstmt fail "GetData failed" | x == sql_no_data -> do - liftIO $ hPutStrLn stderr "GetData -> no data available" + liftIO $ log $ fromString "GetData -> no data available" fail "GetData failed" | x == sql_success_with_info -> do - liftIO $ do - hPutStrLn stderr "GetData returned more info" - displayDiagInfo sql_handle_stmt hstmt moreData <- isMoreData + lenOrInd <- liftIO $ peek p_lenOrInd if moreData - then more - else end + then if lenOrInd == sql_null_data || lenOrInd <= bufLen + then do liftIO $ log $ fromString "GetData returned 01004, but no more data is available" + end + else more + else do + if lenOrInd == sql_null_data || lenOrInd <= bufLen + then end + else do liftIO $ log $ fromString "More data but no 01004 diagnostic record found" + more | otherwise -> do liftIO $ do - hPutStrLn stderr $ "GetData returned unexpected result: " ++ (show x) + log $ fromString $ "GetData returned unexpected result: " ++ (show x) displayDiagInfo sql_handle_stmt hstmt fail "GetData failed" where isMoreData :: (MonadIO m, MonadFail m) => m Bool isMoreData = do recs <- getCountOfDiagRecs sql_handle_stmt hstmt - diags <- liftIO $ fmap catMaybes $ sequence [runMaybeT $ getDiagRec sql_handle_stmt hstmt (fromIntegral i) | i <- [1..recs]] - return $ any (\d -> sqlstate d == "01004") diags + if recs < 0 + then do liftIO $ log $ fromString $ "GetData - wrong diag info records: " ++ (show recs) + return False + else do let diags = [getDiagRec sql_handle_stmt hstmt (fromIntegral i) | i <- [1..recs]] + isMoreData' <- liftIO $ runMaybeT $ + let hasMoreDataRecord [] = return False + hasMoreDataRecord (x:xs) = do + drec <- x + if sqlstate drec == "01004" + then return True + else do liftIO $ log $ fromString $ "GetData warning: <" ++ (show $ sqlstate drec) ++ ">" + liftIO $ displayDiagRec drec + hasMoreDataRecord xs + in + hasMoreDataRecord diags + return $ maybe False id isMoreData' + -- | Create a monadic action to fetch the next record in an executed statement producing -- 'True' if there are more records available or 'False' if all the records have been read. @@ -429,44 +967,60 @@ fetch hstmt = fetchAndRun hstmt (return True) (return False) -- | Create a monadic action to fetch the next record in an excecuted statement. It, then, --- executes one of the 2 actions received as parameters -- more and end -- depending on if there --- are more records available or if the last record has been fetched. +-- executes one of the 2 actions received as parameters. If 'sqlfetch' returns a success code, +-- it executes the first action, else, if 'sql_no_data' is received as result (there were no more +-- records to fetch), it executes the second action. -- -- If an error occrus, the monadic action fails, displaying error diagnostics on the standard -- error. fetchAndRun :: (MonadIO m, MonadFail m) => SQLHSTMT -> m a -> m a -> m a -fetchAndRun hstmt action end = do +fetchAndRun hstmt fetchaction endaction = fetchAndRunWithFail hstmt fetchaction endaction fail + +-- | Create a monadic action to fetch the next record in an excecuted statement. It, then, +-- executes one of the 3 actions received as parameters depending on the result of calling +-- 'sqlfetch' function. +-- +-- If 'sqlfetch' call returns a success code, then the first action is called, that should process +-- the fetched record. +-- +-- If 'sqlfetch' returns 'sql_no_data', meaning there are no more records to fetch, the second action +-- is called that should terminate the data fetching on this statement. +-- +-- If 'sqlfetch' returns an error, the third action is executed that should process the error condition, +-- passing it the fail error message. +-- +-- If an error occrus, the monadic action fails, displaying error diagnostics on the standard +-- error. +fetchAndRunWithFail :: (MonadIO m, MonadFail m) => SQLHSTMT -> m a -> m a -> (String -> m a) -> m a +fetchAndRunWithFail hstmt fetchedaction endaction failaction = do result <- liftIO $ sqlfetch hstmt case result of - x | x == sql_success -> action + x | x == sql_success -> fetchedaction | x == sql_error -> do - liftIO $ do - hPutStrLn stderr "Error fetching record" - displayDiagInfo sql_handle_stmt hstmt - fail "Fetch failed" + liftIO $ log $ fromString "Error fetching record" + liftIO $ displayDiagInfo sql_handle_stmt hstmt + failaction "Fetch failed" | x == sql_invalid_handle -> do - liftIO $ hPutStrLn stderr "Invalid handle when fetching record" - fail "Fetch failed" + liftIO $ log $ fromString "Invalid handle when fetching record" + failaction "Fetch failed due to invalid handle" | x == sql_no_data -> do - liftIO $ hPutStrLn stderr "All records have been fetched" - end + liftIO $ log $ fromString "All records have been fetched" + endaction | x == sql_success_with_info -> do - liftIO $ do - hPutStrLn stderr "More diagnostic info returned for record" - displayDiagInfo sql_handle_stmt hstmt - action + liftIO $ log $ fromString "More diagnostic info returned for record" + liftIO $ displayDiagInfo sql_handle_stmt hstmt + fetchedaction | otherwise -> do - liftIO $ do - hPutStrLn stderr $ "Fetch returned unexepected result: " ++ (show x) - displayDiagInfo sql_handle_stmt hstmt - fail "Fetch failed" - + liftIO $ log $ fromString $ "Fetch returned unexepected result: " ++ (show x) + liftIO $ displayDiagInfo sql_handle_stmt hstmt + failaction "Fetch failed" + -- | helper function to bind a SMALLINT column bindSmallIntCol :: (MonadIO m, MonadFail m) => SQLHSTMT -- ^ statement handle -> SQLSMALLINT -- ^ column number (starting with 1) -> Ptr SQLSMALLINT -- ^ buffer to receive the value - -> Ptr SQLINTEGER -- ^ buffer to receive the indicator or length; it can be null + -> Ptr SQLLEN -- ^ buffer to receive the indicator or length; it can be null -> m () bindSmallIntCol hstmt colNum p_buf p_ind = bindCol hstmt colNum sql_smallint (castPtr p_buf) (fromIntegral $ sizeOf (undefined :: SQLSMALLINT)) p_ind @@ -475,7 +1029,7 @@ SQLHSTMT -- ^ statement handle -> SQLSMALLINT -- ^ column number (starting with 1) -> Ptr SQLINTEGER -- ^ buffer to receive the value - -> Ptr SQLINTEGER -- ^ buffer to receive the indicator or length; it can be null + -> Ptr SQLLEN -- ^ buffer to receive the indicator or length; it can be null -> m () bindIntegerCol hstmt colNum p_buf p_ind = bindCol hstmt colNum sql_integer (castPtr p_buf) (fromIntegral $ sizeOf (undefined :: SQLINTEGER)) p_ind @@ -485,68 +1039,73 @@ SQLHSTMT -- ^ statement handle -> SQLSMALLINT -- ^ column number (starting with 1) -> CString -- ^ buffer to receive the null terminated text data - -> SQLINTEGER -- ^ buffer length in bytes, including the null terminating character - -> Ptr SQLINTEGER -- ^ pointer to indicator or length; it can be null + -> SQLLEN -- ^ buffer length in bytes, including the null terminating character + -> Ptr SQLLEN -- ^ pointer to indicator or length; it can be null -> m () bindVarcharCol hstmt colNum p_buf buflen p_ind = bindCol hstmt colNum sql_char (castPtr p_buf) buflen p_ind -- | wrapper for BindCol SQL CLI API call; if an error occurs -- the computation is stopped and diagnostics are displayed on the standard error -bindCol :: (MonadIO m, MonadFail m) => SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLINTEGER -> Ptr SQLINTEGER -> m () +bindCol :: (MonadIO m, MonadFail m) => SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLLEN -> Ptr SQLLEN -> m () bindCol hstmt colNum colType p_buf len_buf p_ind = do result <- liftIO $ sqlbindcol hstmt colNum colType p_buf len_buf p_ind case result of x | x == sql_success -> return () | x == sql_error -> do liftIO $ do - hPutStrLn stderr $ "Error binding column " ++ (show colNum) + log $ fromString $ "Error binding column " ++ (show colNum) displayDiagInfo sql_handle_stmt hstmt fail "Binding column failed" | x == sql_success_with_info -> do liftIO $ do - hPutStrLn stderr $ "Binding col " ++ (show colNum) ++ " returned warnings:" + log $ fromString $ "Binding col " ++ (show colNum) ++ " returned warnings:" displayDiagInfo sql_handle_stmt hstmt | x == sql_invalid_handle -> do - liftIO $ hPutStrLn stderr $ "Invalid handle when binding column " ++ (show colNum) + liftIO $ log $ fromString $ "Invalid handle when binding column " ++ (show colNum) fail "Binding column failed" | otherwise -> do liftIO $ do - hPutStrLn stderr $ "Invalid result when binding column " ++ (show colNum) + log $ fromString $ "Invalid result when binding column " ++ (show colNum) displayDiagInfo sql_handle_stmt hstmt fail "Biniding column failed" -- | wrapper for SQL CLI ExecDirect API call; if an error occurs, the --- computation exits displaying diagnostics on the standard error -execDirect :: (MonadIO m, MonadFail m) => SQLHSTMT -> String -> m () -execDirect hstmt sqlstr = do +-- computation exits displaying diagnostics on the standard error. +-- +-- It gets 3 parameters: a handle statement, a sql string and a feed data +-- action; if 'sqlexecdirect' returns 'sql_need_data', it executes the feed +-- data action. +-- +-- The feed data action is responsible with supplying the needed data for +-- dynamic parameters by calling 'sqlputdata' and 'sqlparamdata'. See more +-- details on SQL/CLI specification for ExecDirect, PutData and ParamData API +-- calls. +execDirect :: (MonadIO m, MonadFail m) => SQLHSTMT -> String -> m () -> m () +execDirect hstmt sqlstr feeddata = do result <- liftIO $ withCStringLen sqlstr (\(sql, sqlLen) -> sqlexecdirect hstmt (castPtr sql) (fromIntegral sqlLen)) case result of - x | x == sql_success -> liftIO $ hPutStrLn stderr "sql statement executed" + x | x == sql_success -> liftIO $ log $ fromString "sql statement executed" | x == sql_success_with_info -> liftIO $ do - hPutStrLn stderr "Execution of sql returned more info" + log $ fromString "Execution of sql returned more info" displayDiagInfo sql_handle_stmt hstmt | x == sql_error -> do liftIO $ do - hPutStrLn stderr "Execution of sql returned error" + log $ fromString "Execution of sql returned error" displayDiagInfo sql_handle_stmt hstmt fail "execute sql statement failed" | x == sql_invalid_handle -> do liftIO $ do - hPutStrLn stderr "Invaild statement handle" + log $ fromString "Invaild statement handle" displayDiagInfo sql_handle_stmt hstmt fail "execute statemnt failed" - | x == sql_need_data -> do - liftIO $ do - hPutStrLn stderr "Unexpected NEED_DATA returned by statement execution" - displayDiagInfo sql_handle_stmt hstmt - fail "exeucute statement failed" + | x == sql_need_data -> feeddata | x == sql_no_data -> do - liftIO $ hPutStrLn stderr "Execution of statement returned no data" + liftIO $ log $ fromString "Execution of statement returned no data" fail "execute statement failed" | otherwise -> do liftIO $ do - hPutStrLn stderr $ "Execute statement returned unexpected result: " ++ (show x) + log $ fromString $ "Execute statement returned unexpected result: " ++ (show x) displayDiagInfo sql_handle_stmt hstmt fail "Execute statement failed" @@ -558,7 +1117,7 @@ -- On error, the computation exits, displaying diagnostics on the standard error. connect :: (MonadIO m, MonadFail m) => SQLHENV -> String -> String -> String -> m SQLHDBC connect henv server user pass = do - liftIO $ hPutStrLn stderr $ "connect to server " ++ server + liftIO $ log $ fromString $ "connect to server " ++ server hdbc <- allocHandle sql_handle_dbc henv result <- liftIO $ withCStringLen server (\(p_server, serverLen) -> withCStringLen user @@ -567,23 +1126,23 @@ case result of x | x == sql_success -> return hdbc | x == sql_success_with_info -> do - liftIO $ hPutStrLn stderr $ "connect to server " ++ server ++ " returned warnings:" + liftIO $ log $ fromString $ "connect to server " ++ server ++ " returned warnings:" liftIO $ displayDiagInfo sql_handle_dbc hdbc return hdbc | x == sql_error -> do - liftIO $ hPutStrLn stderr $ "connection to server " ++ server ++ " failed:" + liftIO $ log $ fromString $ "connection to server " ++ server ++ " failed:" liftIO $ displayDiagInfo sql_handle_dbc hdbc liftIO $ freeHandle sql_handle_dbc hdbc fail $ "connection to server " ++ server ++ " failed" | x == sql_invalid_handle -> do - liftIO $ hPutStrLn stderr $ "connection to server " ++ server ++ " failed because of invalid handle" + liftIO $ log $ fromString $ "connection to server " ++ server ++ " failed because of invalid handle" fail $ "connection to server " ++ server ++ " failed because of invalid handle" | otherwise -> do liftIO $ do - hPutStrLn stderr $ "Unexpected response code got from connecting to server " ++ server ++ ": " ++ (show x) - hPutStrLn stderr "Trying to extract diagnostic info:" + log $ fromString $ "Unexpected response code got from connecting to server " ++ server ++ ": " ++ (show x) + log $ fromString "Trying to extract diagnostic info:" displayDiagInfo sql_handle_dbc hdbc - hPutStrLn stderr "Try call disconnect on the connection handle, to make sure we release all resources" + log $ fromString "Try call disconnect on the connection handle, to make sure we release all resources" disconnect hdbc fail $ "Unexpected response code got from connecting to server " ++ server ++ ": " ++ (show x) @@ -595,109 +1154,121 @@ case result of x | x == sql_success -> return () | x == sql_success_with_info -> do - hPutStrLn stderr "disconnect returned warnings:" + log $ fromString "disconnect returned warnings:" displayDiagInfo sql_handle_dbc hdbc | x == sql_error -> do - hPutStrLn stderr "disconnect failed:" + log $ fromString "disconnect failed:" displayDiagInfo sql_handle_dbc hdbc | x == sql_invalid_handle -> do - hPutStrLn stderr "disconnect failed because of invalid handle" + log $ fromString "disconnect failed because of invalid handle" | otherwise -> do - hPutStrLn stderr "Unexpected response code got from Disconnect function" - hPutStrLn stderr "Trying to extract diagnostic info:" + log $ fromString "Unexpected response code got from Disconnect function" + log $ fromString "Trying to extract diagnostic info:" displayDiagInfo sql_handle_dbc hdbc freeHandle sql_handle_dbc hdbc -- | wrapper to SQL CLI AllocHandle API call; it displays diagnostics info -- on the standard error and fails if the handle could not be allocated -allocHandle :: (MonadIO m, MonadFail m) => SQLSMALLINT -> SQLINTEGER -> m SQLINTEGER +allocHandle :: (MonadIO m, MonadFail m) => SQLSMALLINT -> SQLHANDLE -> m SQLHANDLE allocHandle handleType handleParent = do handle <- liftIO $ alloca (\p_handle -> do + poke p_handle sql_null_handle result <- sqlallochandle handleType handleParent p_handle case result of x | x == sql_success -> Just <$> peek p_handle | x == sql_invalid_handle -> do - hPutStrLn stderr "alloc handle failed because of invalid handler" + log $ fromString $ "alloc handle failed because of invalid parent handle, for handle type " ++ (show handleType) displayDiagnostic return Nothing | x == sql_error -> do - hPutStrLn stderr "alloc handle failed with error" + log $ fromString $ "alloc handle failed with error for handle type " ++ (show handleType) displayDiagnostic return Nothing | otherwise -> do - hPutStrLn stderr $ "alloc handle returned unexpected result" ++ (show x) + log $ fromString $ "alloc handle returned unexpected result for handle type " ++ (show handleType) ++ ": " ++ (show x) displayDiagnostic return Nothing - where displayDiagnostic = if x == sql_handle_env - then peek p_handle >>= displayDiagInfo x - else displayDiagInfo handleType handleParent) + where displayDiagnostic = if handleType == sql_handle_env + then peek p_handle >>= displayDiagInfo sql_handle_env + else displayDiagInfo handleParentType handleParent + handleParentType = case handleType of + h | h == sql_handle_dbc -> sql_handle_env + | h == sql_handle_stmt -> sql_handle_dbc + | h == sql_handle_desc -> sql_handle_stmt + | otherwise -> 0) maybe (fail $ "AllocHandle failed for handle type " ++ (show handleType)) return handle -- | wrapper for SQL CLI FreeHandle API call; it displays diagnostics -- on the standard error; it does not fail -freeHandle :: SQLSMALLINT -> SQLINTEGER -> IO () +freeHandle :: SQLSMALLINT -> SQLHANDLE -> IO () freeHandle handleType handle = do result <- sqlfreehandle handleType handle case result of x | x == sql_success -> return () | x == sql_error -> do - hPutStrLn stderr $ "Error freeing handle of type " ++ (show handleType) + log $ fromString $ "Error freeing handle of type " ++ (show handleType) displayDiagInfo handleType handle | x == sql_invalid_handle -> do - hPutStrLn stderr "FreeHandle failed because of invalid handle" + log $ fromString "FreeHandle failed because of invalid handle" displayDiagInfo handleType handle | otherwise -> do - hPutStrLn stderr $ "FreeHandle returned unexpected result " ++ (show x) - hPutStrLn stderr "Trying to get diagnostic info on FreeHandle:" + log $ fromString $ "FreeHandle returned unexpected result " ++ (show x) + log $ fromString "Trying to get diagnostic info on FreeHandle:" displayDiagInfo handleType handle -- | create an 'IO' action that displays diagnostic records for a given handle on the -- standard error; this action will not fail -displayDiagInfo :: SQLSMALLINT -> SQLINTEGER -> IO () +displayDiagInfo :: SQLSMALLINT -> SQLHANDLE -> IO () displayDiagInfo handleType handle = (runMaybeT $ displayDiagInfo' handleType handle) >> return () -- | create a monadic action to display the diagnostic records for a given handle on the -- standard error; it fails if an error occurs while reading diagnostic records. -displayDiagInfo' :: (MonadIO m, MonadFail m) => SQLSMALLINT -> SQLINTEGER -> m () +displayDiagInfo' :: (MonadIO m, MonadFail m) => SQLSMALLINT -> SQLHANDLE -> m () displayDiagInfo' handleType handle = do recs <- getCountOfDiagRecs handleType handle - liftIO $ hPutStrLn stderr $ "there " + liftIO $ log $ fromString $ "there " ++ (if recs /= 1 then "are " else "is ") ++ (show recs) ++ " diagnostic record" ++ (if recs /= 1 then "s" else "") let diags = [showDiag $ fromIntegral i | i <- [1..recs]] showDiag i = do - liftIO $ hPutStrLn stderr $ "Diagnostic record " ++ (show i) + liftIO $ log $ fromString $ "Diagnostic record " ++ (show i) r <- getDiagRec handleType handle i - liftIO $ hPutStrLn stderr $ (show i) ++ ": " ++ (sqlstate r) ++ " - " ++ (show $ nativeError r) ++ " - " ++ (messageText r) + liftIO $ displayDiagRec r in sequence_ diags +-- | display a diagnostic record on standard error +displayDiagRec :: DiagRecord -> IO () +displayDiagRec r = log $ fromString $ (show $ diagrec_i r) ++ ": " ++ (sqlstate r) ++ " - " ++ (show $ nativeError r) ++ " - " ++ (messageText r) + -- | create a monadic action to read the number of the diagnostic records for a given handle; -- it fails if an error occurs and it displays diagnostics on standard error -getCountOfDiagRecs :: (MonadIO m, MonadFail m) => SQLSMALLINT -> SQLINTEGER -> m Int +getCountOfDiagRecs :: (MonadIO m, MonadFail m) => SQLSMALLINT -> SQLHANDLE -> m SQLINTEGER getCountOfDiagRecs handleType handle = do recs <- liftIO $ alloca (\ptrRecs -> do + liftIO $ poke ptrRecs 0 result <- sqlgetdiagfield handleType handle 0 sql_diag_number (castPtr ptrRecs) 0 nullPtr case result of x | x == sql_success -> Just <$> peek ptrRecs | x == sql_invalid_handle -> do - hPutStrLn stderr "Count of diagnostic records could not be retrieved due to an invalid handle" + log $ fromString $ "Count of diagnostic records could not be retrieved due to an invalid handle, for handle type: " ++ (show handleType) return Nothing | x == sql_error -> do - hPutStrLn stderr "Count of diagnostic records could not be retrieved because wrong arguments were passed to GetDiagField function" + log $ fromString $ "Count of diagnostic records could not be retrieved because wrong arguments were passed to GetDiagField function, for handle type" ++ (show handleType) return Nothing | x == sql_no_data -> do - hPutStrLn stderr "No diagnostic data available" + log $ fromString $ "No diagnostic data available for handle type: " ++ (show handleType) return $ Just 0 | otherwise -> do - hPutStrLn stderr $ "Getting the number of diagnostic records returned unexpected return code " ++ (show x) + log $ fromString $ "Getting the number of diagnostic records returned unexpected return code for handle type " ++ (show handleType) ++ ": " ++ (show x) return Nothing) maybe (fail "GetDiagField api call failed when reading number of diagnostic errors") return recs -- | information in a diagnostic record data DiagRecord = DiagRecord { + diagrec_i :: SQLSMALLINT, sqlstate :: String, nativeError :: SQLINTEGER, messageText :: String @@ -705,7 +1276,7 @@ -- | wrapper for SQL CLI GetDiagRec API call; the computation fails if an error -- occurs and it displays diagnostics on standard error -getDiagRec :: (MonadIO m, MonadFail m) => SQLSMALLINT -> SQLINTEGER -> SQLSMALLINT -> m DiagRecord +getDiagRec :: (MonadIO m, MonadFail m) => SQLSMALLINT -> SQLHANDLE -> SQLSMALLINT -> m DiagRecord getDiagRec handleType handle recnum = do diagrecord <- liftIO $ allocaBytes 5 (\p_sqlstate -> alloca @@ -719,18 +1290,18 @@ l_nativeErr <- peek p_nativeErr textLen <- fromIntegral <$> peek p_textLen l_messageText <- (map (toEnum . fromIntegral)) <$> (sequence [peekElemOff p_messageText j | j <- [0..textLen]]) - return $ Just $ DiagRecord l_sqlstate l_nativeErr l_messageText + return $ Just $ DiagRecord recnum l_sqlstate l_nativeErr l_messageText | x == sql_error -> do - hPutStrLn stderr $ (show recnum) ++ ": Diagnostic information could not be retrieved becuase wrong arguments passed to GetDagRec function" + log $ fromString $ (show recnum) ++ ": Diagnostic information could not be retrieved becuase wrong arguments passed to GetDagRec function" return Nothing | x == sql_invalid_handle -> do - hPutStrLn stderr $ (show recnum) ++ ": Diagnosic information could not be retrieved because of wrong handler" + log $ fromString $ (show recnum) ++ ": Diagnosic information could not be retrieved because of wrong handler" return Nothing | x == sql_no_data -> do - hPutStrLn stderr $ (show recnum) ++ ": No diagnostic data available" + log $ fromString $ (show recnum) ++ ": No diagnostic data available" return Nothing | otherwise -> do - hPutStrLn stderr $ (show recnum) ++ ": Getting diagnostic information returned unexpected error code " ++ (show x) + log $ fromString $ (show recnum) ++ ": Getting diagnostic information returned unexpected error code " ++ (show x) return Nothing)))) maybe (fail "GetDiagRec call failed") return diagrecord @@ -743,16 +1314,18 @@ -- | helper function to read a nullable column; returns Nothing if the -- column is null -peekMaybeCol :: (Storable a) => Ptr a -> Ptr SQLINTEGER -> IO (Maybe a) +peekMaybeCol :: (Storable a) => Ptr a -> Ptr SQLLEN -> IO (Maybe a) peekMaybeCol p_col p_ind = do ind <- peek p_ind if ind == sql_null_data then return Nothing - else Just <$> peek p_col + else do col <- peek p_col + debugS logsrc $ fromString $ "reading value of len " ++ (show ind) ++ " from buffer with len " ++ (show $ sizeOf col) + return $ Just col -- | helper function to read a nullable text column; returns Nothing if the -- column is null -peekMaybeTextCol :: CString -> Ptr SQLINTEGER -> IO (Maybe String) +peekMaybeTextCol :: CString -> Ptr SQLLEN -> IO (Maybe String) peekMaybeTextCol p_col p_ind = do ind <- peek p_ind if ind == sql_null_data