sqlcli 0.2.0.1 → 0.2.1.0
raw patch · 6 files changed
+289/−189 lines, 6 files
Files
- ChangeLog +22/−0
- NEWS +10/−0
- README.md +27/−3
- sqlcli.cabal +18/−10
- src/SQL/CLI.hs +6/−7
- src/SQL/CLI/Utils.hs +206/−169
ChangeLog view
@@ -1,3 +1,25 @@+2020-04-11 Mihai Giurgeanu <mihai.giurgeanu@gmail.com>++ * stack.yaml (resolver): change to lts-9.21++ * src/SQL/CLI/Utils.hs (peekMaybeCol): change logsrc to logSrc'.+ Remove import of Control.Logging.log.+ Use OverloadedStrings extension for computing the log's source.+ Replace every log call with a debugS call.++2020-04-03 Mihai Giurgeanu <mihai.giurgeanu@gmail.com>++ * README.md: add more information about using the library.++2019-03-13 Mihai Giurgeanu <mihai.giurgeanu@gmail.com>++ * src/SQL/CLI.hs (SQLINTEGER): change definition of SQLINTEGER to CLong for ODBC also.+ (SQLHANDLE): define SQLHANDLE for Windows as Ptr () (that is void *). Make it SQLINTEGER for other platforms.++2019-03-02 Mihai Giurgeanu <mihai.giurgeanu@gmail.com>++ * stack.yaml (extra-deps): use latest logging-3.0.5+ 2018-03-17 Mihai Giurgeanu <mihai.giurgeanu@gmail.com> * sqlcli.cabal (Flag ODBC): enable ODBC flag by default
+ NEWS view
@@ -0,0 +1,10 @@+sqlcli NEWS - history of user-visible changes+=============================================++Release 0.2.1.0+----------------++* Use DEBUG message instead of INFO and add a source of log message+ containing the name of the function that creates the message.+* Fix "access violation" exception on Windows 64 bit platforms.+* Add more info to the README file.
README.md view
@@ -1,11 +1,35 @@ # sqlcli -A library wrapping X/Open's SQL/CLI specification for C bindings.+[NEWS](https://hub.darcs.net/mihaigiurgeanu/sqlcli/browse/NEWS) +A library wrapping X/Open's SQL/CLI specification for C bindings. This+project aims to become the de facto library for implementing+ODBC database access in Haskell.++The most available implementation of the SQL/CLI standard is+ODBC 3.0. You need the SQL/CLI documentation or+[ODBC Programmer's Refference](https://docs.microsoft.com/en-us/sql/odbc/reference/odbc-programmer-s-reference?view=sql-server-ver15)+in order to know how to use the functions in this package.++ODBC is a super set of the SQL/CLI specification. All calls in the+SQL/CLI are supported by the ODBC drivers. You can use this library+to connect to databases to support ODBC. The library is tested with+Oracle and Postgres ODBC drivers.++If you want to connect to ODBC, you should also use the calls and+definitios of the sqlcli-odbc package.+ The `SQL.CLI` module contains all the foreign function calls, constants-and types defined by the SQL/CLI specificaition. +and types defined by the SQL/CLI specificaition. You can this module,+but it is rather low level. A better choice would be to start working+with the calls in the `SQL.CLI.Utils` module. -`SQL.CLI.Utils` module contains wrappers to SQL/CLI function calls +`SQL.CLI.Utils` module contains wrappers to SQL/CLI function calls that make easier to treat the error cases and deal with the SQL/CLI diagnostic as well as other useful constructs in calling SQL/CLI API. +## Change Log++We are using the [GNU guides](https://www.gnu.org/prep/standards/html_node/Documentation.html#Documentation)+for documenting the changes in our project. You can see the summary of+changes in the [NEWS](https://hub.darcs.net/mihaigiurgeanu/sqlcli/browse/NEWS).
sqlcli.cabal view
@@ -1,14 +1,18 @@ name: sqlcli-version: 0.2.0.1-synopsis: Sql Call-Level Interface bindings for Haskell.-description: Provides bindings to SQL/CLI C API, importing- all foreign functions defined in the specifications,- defining types and constants used in the specification.- - Also it provides some wrapers to the foreign C calls and+version: 0.2.1.0+synopsis: High quality SQL/CLI and ODBC C function bindings.+description: See [NEWS](https://hub.darcs.net/mihaigiurgeanu/sqlcli/browse/NEWS)+ for the ChangeLog.++ Provides bindings to all the SQL/CLI C API standard.+ SQL/CLI C API is a subset of ODBC.++ This package also contains Haskell wrapers to the foreign C calls and utilities to make using the SQL/CLI easier for the Haskell programmer.- ++ You can use this to acces any database through ODBC.+ homepage: http://hub.darcs.net/mihaigiurgeanu/sqlcli license: BSD3 license-file: LICENSE@@ -17,7 +21,7 @@ copyright: 2017 Mihai Giurgeanu category: Database build-type: Simple-extra-source-files: README.md, ChangeLog+extra-source-files: README.md, ChangeLog, NEWS cabal-version: >=1.10 Flag ODBC@@ -37,11 +41,15 @@ other-extensions: CPP, ForeignFunctionInterface if flag(odbc)- cpp-options: -DODBC if os(windows) extra-libraries: odbc32+ if arch(x86_64)+ cpp-options: -DODBC -D_WIN64+ else+ cpp-options: -DODBC -DWIN32 else extra-libraries: odbc+ cpp-options: -DODBC source-repository head
src/SQL/CLI.hs view
@@ -8,13 +8,7 @@ -- 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@@ -33,7 +27,12 @@ -- generic data structures -- we use SQLHANDLE type to be compatible with ODBC definitions-type SQLHANDLE = CLong+#if ((defined WIN32) || (defined _WIN64))+type SQLHANDLE = Ptr ()+#else+type SQLHANDLE = SQLINTEGER+#endif+ type SQLHENV = SQLHANDLE type SQLHDBC = SQLHANDLE type SQLHSTMT = SQLHANDLE
src/SQL/CLI/Utils.hs view
@@ -1,4 +1,5 @@ -- Provides a more convenient way to use SQLCLI API from Haskell +{-# LANGUAGE OverloadedStrings #-} module SQL.CLI.Utils where import Prelude hiding (fail, log) @@ -6,7 +7,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Fail (MonadFail, fail) -import Control.Logging (log, debugS) +import Control.Logging (debugS) import System.IO (hPutStrLn, stderr) @@ -19,6 +20,7 @@ import Data.String (IsString(fromString)) import Data.Text (Text) import Data.List (insert) +import Data.Semigroup ((<>)) import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) import Control.Monad.Trans.Reader (ReaderT, asks) @@ -88,8 +90,8 @@ SQLLEN, SQLULEN) -logsrc :: Text -logsrc = fromString "SQL.CLI.Utils" +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 @@ -162,25 +164,25 @@ -- 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 - column_name_fld <- asks sql_cli_flds_column_name - data_type_fld <- asks sql_cli_flds_data_type - type_name_fld <- asks sql_cli_flds_type_name - column_size_fld <- asks sql_cli_flds_column_size - buffer_length_fld <- asks sql_cli_flds_buffer_length - decimal_digits_fld <- asks sql_cli_flds_decimal_digits - num_prec_radix_fld <- asks sql_cli_flds_num_prec_radix - nullable_fld <- asks sql_cli_flds_nullable - remarks_fld <- asks sql_cli_flds_remarks - column_def_fld <- asks sql_cli_flds_column_def - datetime_code_fld <- asks sql_cli_flds_datetime_code + 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 + column_name_fld <- asks sql_cli_flds_column_name + data_type_fld <- asks sql_cli_flds_data_type + type_name_fld <- asks sql_cli_flds_type_name + column_size_fld <- asks sql_cli_flds_column_size + buffer_length_fld <- asks sql_cli_flds_buffer_length + decimal_digits_fld <- asks sql_cli_flds_decimal_digits + num_prec_radix_fld <- asks sql_cli_flds_num_prec_radix + nullable_fld <- asks sql_cli_flds_nullable + remarks_fld <- asks sql_cli_flds_remarks + column_def_fld <- asks sql_cli_flds_column_def + datetime_code_fld <- asks sql_cli_flds_datetime_code char_octet_length_fld <- asks sql_cli_flds_char_octet_length - ordinal_position_fld <- asks sql_cli_flds_ordinal_position - is_nullable_fld <- asks sql_cli_flds_is_nullable + ordinal_position_fld <- asks sql_cli_flds_ordinal_position + is_nullable_fld <- asks sql_cli_flds_is_nullable - + cols <- liftIO $ allocaBytes 129 (\ p_table_cat -> @@ -297,11 +299,12 @@ 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" + liftIO $ debugS logSrc' $ fromString "reading columns info records" forAllRecords hstmt readColumnInfo []))))))))))))))))))))))))))) liftIO $ freeHandle sql_handle_stmt hstmt maybe (fail "collectColumnsInfo failed") return cols - + where + logSrc' = logSrc <> ("collectColumnsInfo'" :: Text) -- | Checks if a table exists on the current connection. @@ -315,8 +318,8 @@ exists <- fetch tables_stmt liftIO $ freeHandle sql_handle_stmt tables_stmt return exists - + -- SQLCLI wrappers -- | wrapper to SQL/CLI function EndTran; it creates a monadic action to call @@ -333,22 +336,24 @@ 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 $ debugS logSrc' $ 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 $ debugS logSrc' $ 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 + liftIO $ debugS logSrc' $ 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 $ debugS logSrc' $ fromString err liftIO $ displayDiagInfo handleType handle fail err - + where + logSrc' = logSrc <> "endTran" + -- | 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 @@ -359,21 +364,23 @@ 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 $ debugS logSrc' $ 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 $ debugS logSrc' $ 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 + liftIO $ debugS logSrc' $ 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 $ debugS logSrc' $ fromString err liftIO $ displayDiagInfo sql_handle_dbc hdbc fail err + where + logSrc' = logSrc <> "setConnectAttr" -- | wrapper for SQL/CLI function SetDescField; it creates a monadic action -- that calls the API function, logs diagnostic on standard output and fails @@ -391,21 +398,23 @@ 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 $ debugS logSrc' $ 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 $ debugS logSrc' $ 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 + liftIO $ debugS logSrc' $ 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 $ debugS logSrc' $ fromString err liftIO $ displayDiagInfo sql_handle_desc hdesc fail err + where + logSrc' = logSrc <> "setDescField" -- | wrapper for SQL/CLI function GetDescField; it creates a monadic action -- that calls the API function, logs disgnostic on standard output and @@ -424,22 +433,24 @@ 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 $ debugS logSrc' $ 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 $ debugS logSrc' $ 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 + liftIO $ debugS logSrc' $ 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 $ debugS logSrc' $ fromString err liftIO $ displayDiagInfo sql_handle_desc hdesc fail err - + where + logSrc' = logSrc <> "getDescField" + -- | 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 @@ -460,21 +471,23 @@ 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 $ debugS logSrc' $ 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 $ debugS logSrc' $ 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 + liftIO $ debugS logSrc' $ 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 $ debugS logSrc' $ fromString err liftIO $ displayDiagInfo sql_handle_desc hdesc fail err + where + logSrc' = logSrc <> "setDescRec" -- | 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 @@ -486,9 +499,9 @@ -> 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 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 @@ -497,25 +510,27 @@ x | x == sql_success -> return () | x == sql_error -> do let err = "call to SQL/CLI function GetDescRec failed" - liftIO $ log $ fromString err + liftIO $ debugS logSrc' $ 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 $ debugS logSrc' $ 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 + liftIO $ debugS logSrc' $ 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 + liftIO $ debugS logSrc' $ 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 + liftIO $ debugS logSrc' $ fromString err fail err + where + logSrc' = logSrc <> "getDescRec" -- | wrapper for SQL/CLI function NumResultCols; it fails if the API call fails and -- it displays diagnostic information on the standard error @@ -528,21 +543,23 @@ case result of x | x == sql_success -> cols | x == sql_error -> do - log $ fromString "call to SQL/CLI function NumResultCols failed" + debugS logSrc' $ 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" + debugS logSrc' $ 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" + debugS logSrc' $ 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) + debugS logSrc' $ fromString $ "unexpected value returned by a call to NumResultCols: " ++ (show x) displayDiagInfo sql_handle_stmt hstmt return Nothing ) maybe (fail "numResultCols failed") return cols + where + logSrc' = logSrc <> "numResultCols" -- | helper function to get the value of a `Storable` statement attribute getStorableStmtAttr :: (MonadIO m, MonadFail m, Storable a) => SQLHSTMT -> SQLINTEGER -> m a @@ -569,21 +586,23 @@ 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 $ debugS logSrc' $ 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 $ debugS logSrc' $ 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 + liftIO $ debugS logSrc' $ 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 $ debugS logSrc' $ fromString err liftIO $ displayDiagInfo sql_handle_stmt hstmt fail err + where + logSrc' = logSrc <> "getStmtAttr" -- | wrapper for SQL/CLI function, BindParam; it displayes diagnostics on standard error bindParam :: (MonadIO m, MonadFail m) => SQLHSTMT -- ^ statement handle @@ -601,22 +620,22 @@ x | x == sql_success -> return () | x == sql_error -> do let err = "Error binding parameter " ++ (show paramno) - liftIO $ log $ fromString err + liftIO $ debugS logSrc' $ 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 $ debugS logSrc' $ 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 + liftIO $ debugS logSrc' $ fromString err fail err | otherwise -> do let err = "binding parameter " ++ (show paramno) ++ " returned unexepcted result: " ++ (show x) - liftIO $ log $ fromString err + liftIO $ debugS logSrc' $ fromString err liftIO $ displayDiagInfo sql_handle_stmt hstmt fail err - + where logSrc' = logSrc <> "bindParam" -- | wrapper for PutData SQL/CLI api call; it displays diagnostics on standard error putData :: (MonadIO m, MonadFail m) => SQLHSTMT -> Ptr a -> SQLLEN -> m () @@ -626,21 +645,22 @@ 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 $ debugS logSrc' $ 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 $ debugS logSrc' $ 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 + liftIO $ debugS logSrc' $ fromString err fail err | otherwise -> do let err = "call to SQL/CLI function PutData returned unexpected result: " ++ (show x) - liftIO $ log $ fromString err + liftIO $ debugS logSrc' $ fromString err liftIO $ displayDiagInfo sql_handle_stmt hstmt fail err + where logSrc' = logSrc <> "putData" -- | 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 @@ -661,25 +681,26 @@ paramData hstmt f | x == sql_error -> do let err = "call to SQL/CLI function ParamData failed" - liftIO $ log $ fromString err + liftIO $ debugS logSrc' $ 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 $ debugS logSrc' $ 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 $ debugS logSrc' $ 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 + liftIO $ debugS logSrc' $ 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 $ debugS logSrc' $ fromString err liftIO $ displayDiagInfo sql_handle_stmt hstmt fail err + where logSrc' = logSrc <> "paramData" -- | wrapper for Prepare SQL/CLI API call prepare :: (MonadIO m, MonadFail m) => SQLHSTMT -> String -> m () @@ -690,22 +711,23 @@ x | x == sql_success -> return () | x == sql_error -> do let err = "Failed preparing statement: " ++ sql - liftIO $ log $ fromString err + liftIO $ debugS logSrc' $ 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 + debugS logSrc' $ 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 + liftIO $ debugS logSrc' $ 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 $ debugS logSrc' $ fromString err liftIO $ displayDiagInfo sql_handle_stmt hstmt fail err - + where logSrc' = logSrc <> "prepare" + -- | 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'; @@ -721,27 +743,28 @@ 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 $ debugS logSrc' $ 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 $ debugS logSrc' $ 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 + liftIO $ debugS logSrc' $ fromString err fail err | x == sql_no_data -> do - liftIO $ log $ fromString "'Execute' returned SQL_NO_DATA" + liftIO $ debugS logSrc' $ 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 $ debugS logSrc' $ fromString err liftIO $ displayDiagInfo sql_handle_stmt hstmt fail err + where logSrc' = logSrc <> "execute" -- | concise information about a column of a result set, mapping -- the result of SQL CLI API call DescribeCol @@ -780,22 +803,22 @@ case result of x | x == sql_success -> readInfo | x == sql_success_with_info -> do - log $ fromString "More information returned by DescribeCol" + debugS logSrc' $ fromString "More information returned by DescribeCol" displayDiagInfo sql_handle_stmt hstmt readInfo | x == sql_error -> do - log $ fromString "Error calling DescribeCol" + debugS logSrc' $ fromString "Error calling DescribeCol" displayDiagInfo sql_handle_stmt hstmt return Nothing | x == sql_invalid_handle -> do - log $ fromString "Invalid handle calling DescribeCol" + debugS logSrc' $ fromString "Invalid handle calling DescribeCol" return Nothing | otherwise -> do - log $ fromString $ "Unexpected result returned by the call to DescribeCol: " ++ (show x) + debugS logSrc' $ fromString $ "Unexpected result returned by the call to DescribeCol: " ++ (show x) displayDiagInfo sql_handle_stmt hstmt - return Nothing)))))) + return Nothing)))))) maybe (fail $ "describeCol " ++ (show colnum) ++ " failed") return info - + where logSrc' = logSrc <> "describe col" -- | wrapper for SQL CLI Columns API call columns :: (MonadIO m, MonadFail m) => SQLHSTMT -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> m () @@ -816,20 +839,21 @@ case result of x | x == sql_success -> return () | x == sql_error -> do - liftIO $ log $ fromString "Error calling Columns" + liftIO $ debugS logSrc' $ fromString "Error calling Columns" liftIO $ displayDiagInfo sql_handle_stmt hstmt fail "Columns failed" | x == sql_success_with_info -> do - liftIO $ log $ fromString "Columns returned more info" + liftIO $ debugS logSrc' $ fromString "Columns returned more info" liftIO $ displayDiagInfo sql_handle_stmt hstmt | x == sql_invalid_handle -> do - liftIO $ log $ fromString "Invalid statement handle passed to Columns call" + liftIO $ debugS logSrc' $ fromString "Invalid statement handle passed to Columns call" fail "Columns failed" | otherwise -> do - liftIO $ log $ fromString "Unexpected return code returned by call to Columns. Trying to display diagnostic info:" + liftIO $ debugS logSrc' $ fromString "Unexpected return code returned by call to Columns. Trying to display diagnostic info:" liftIO $ displayDiagInfo sql_handle_stmt hstmt fail "Columns failed" - + where logSrc' = logSrc <> "columns" + -- | wrapper for SQL CLI Tables API call tables :: (MonadIO m, MonadFail m) => SQLHSTMT -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> m () tables hstmt catalogName schemaName tableName tableType = do @@ -851,21 +875,22 @@ x | x == sql_success -> return () | x == sql_error -> do liftIO $ do - log $ fromString "Error calling Tables" + debugS logSrc' $ fromString "Error calling Tables" displayDiagInfo sql_handle_stmt hstmt fail "Tables failed" | x == sql_success_with_info -> do liftIO $ do - log $ fromString "Tables returned more info" + debugS logSrc' $ fromString "Tables returned more info" displayDiagInfo sql_handle_stmt hstmt | x == sql_invalid_handle -> do - liftIO $ log $ fromString "Invalid handle calling Tables" + liftIO $ debugS logSrc' $ fromString "Invalid handle calling Tables" fail "Tables failed" | otherwise -> do liftIO $ do - log $ fromString $ "Tables returned unexpected result: " ++ (show x) + debugS logSrc' $ fromString $ "Tables returned unexpected result: " ++ (show x) displayDiagInfo sql_handle_stmt hstmt fail "Tables failed" + where logSrc' = logSrc <> "tables" -- | applies a function through all the records in a statment, passing an accumulator value and -- combining the actions returned by the function @@ -897,10 +922,10 @@ -- | 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: --- +-- -- * more -- * end --- +-- -- 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 -> SQLLEN -> Ptr SQLLEN -> m a -> m a -> m a @@ -909,39 +934,39 @@ case result of x | x == sql_success -> end | x == sql_invalid_handle -> do - liftIO $ log $ fromString "Invalid handle when calling GetData" + liftIO $ debugS logSrc' $ fromString "Invalid handle when calling GetData" fail "GetData failed" | x == sql_error -> do liftIO $ do - log $ fromString "Error calling GetData" + debugS logSrc' $ fromString "Error calling GetData" displayDiagInfo sql_handle_stmt hstmt fail "GetData failed" | x == sql_no_data -> do - liftIO $ log $ fromString "GetData -> no data available" + liftIO $ debugS logSrc' $ fromString "GetData -> no data available" fail "GetData failed" | x == sql_success_with_info -> do moreData <- isMoreData lenOrInd <- liftIO $ peek p_lenOrInd if moreData then if lenOrInd == sql_null_data || lenOrInd <= bufLen - then do liftIO $ log $ fromString "GetData returned 01004, but no more data is available" + then do liftIO $ debugS logSrc' $ 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" + else do liftIO $ debugS logSrc' $ fromString "More data but no 01004 diagnostic record found" more | otherwise -> do liftIO $ do - log $ fromString $ "GetData returned unexpected result: " ++ (show x) + debugS logSrc' $ 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 if recs < 0 - then do liftIO $ log $ fromString $ "GetData - wrong diag info records: " ++ (show recs) + then do liftIO $ debugS logSrc' $ 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 $ @@ -950,18 +975,18 @@ drec <- x if sqlstate drec == "01004" then return True - else do liftIO $ log $ fromString $ "GetData warning: <" ++ (show $ sqlstate drec) ++ ">" + else do liftIO $ debugS logSrc' $ fromString $ "GetData warning: <" ++ (show $ sqlstate drec) ++ ">" liftIO $ displayDiagRec drec hasMoreDataRecord xs in hasMoreDataRecord diags return $ maybe False id isMoreData' - + logSrc' = logSrc <> "getDataAndRun" -- | 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. --- --- If an error occurs, the monadic action fails, displaying the error diagnostics on +-- +-- If an error occurs, the monadic action fails, displaying the error diagnostics on -- the standard error. fetch :: (MonadIO m, MonadFail m) => SQLHSTMT -> m Bool fetch hstmt = fetchAndRun hstmt (return True) (return False) @@ -970,7 +995,7 @@ -- 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 @@ -988,7 +1013,7 @@ -- -- 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 @@ -997,24 +1022,25 @@ case result of x | x == sql_success -> fetchedaction | x == sql_error -> do - liftIO $ log $ fromString "Error fetching record" + liftIO $ debugS logSrc' $ fromString "Error fetching record" liftIO $ displayDiagInfo sql_handle_stmt hstmt failaction "Fetch failed" | x == sql_invalid_handle -> do - liftIO $ log $ fromString "Invalid handle when fetching record" + liftIO $ debugS logSrc' $ fromString "Invalid handle when fetching record" failaction "Fetch failed due to invalid handle" | x == sql_no_data -> do - liftIO $ log $ fromString "All records have been fetched" + liftIO $ debugS logSrc' $ fromString "All records have been fetched" endaction | x == sql_success_with_info -> do - liftIO $ log $ fromString "More diagnostic info returned for record" + liftIO $ debugS logSrc' $ fromString "More diagnostic info returned for record" liftIO $ displayDiagInfo sql_handle_stmt hstmt fetchedaction | otherwise -> do - liftIO $ log $ fromString $ "Fetch returned unexepected result: " ++ (show x) + liftIO $ debugS logSrc' $ fromString $ "Fetch returned unexepected result: " ++ (show x) liftIO $ displayDiagInfo sql_handle_stmt hstmt failaction "Fetch failed" - + where logSrc' = logSrc <> "fetchAndRunWithFail" + -- | helper function to bind a SMALLINT column bindSmallIntCol :: (MonadIO m, MonadFail m) => SQLHSTMT -- ^ statement handle @@ -1053,21 +1079,22 @@ x | x == sql_success -> return () | x == sql_error -> do liftIO $ do - log $ fromString $ "Error binding column " ++ (show colNum) + debugS logSrc' $ fromString $ "Error binding column " ++ (show colNum) displayDiagInfo sql_handle_stmt hstmt fail "Binding column failed" | x == sql_success_with_info -> do liftIO $ do - log $ fromString $ "Binding col " ++ (show colNum) ++ " returned warnings:" + debugS logSrc' $ fromString $ "Binding col " ++ (show colNum) ++ " returned warnings:" displayDiagInfo sql_handle_stmt hstmt | x == sql_invalid_handle -> do - liftIO $ log $ fromString $ "Invalid handle when binding column " ++ (show colNum) + liftIO $ debugS logSrc' $ fromString $ "Invalid handle when binding column " ++ (show colNum) fail "Binding column failed" | otherwise -> do liftIO $ do - log $ fromString $ "Invalid result when binding column " ++ (show colNum) + debugS logSrc' $ fromString $ "Invalid result when binding column " ++ (show colNum) displayDiagInfo sql_handle_stmt hstmt fail "Biniding column failed" + where logSrc' = logSrc <> "bindCol" -- | wrapper for SQL CLI ExecDirect API call; if an error occurs, the -- computation exits displaying diagnostics on the standard error. @@ -1085,39 +1112,40 @@ result <- liftIO $ withCStringLen sqlstr (\(sql, sqlLen) -> sqlexecdirect hstmt (castPtr sql) (fromIntegral sqlLen)) case result of - x | x == sql_success -> liftIO $ log $ fromString "sql statement executed" + x | x == sql_success -> liftIO $ debugS logSrc' $ fromString "sql statement executed" | x == sql_success_with_info -> liftIO $ do - log $ fromString "Execution of sql returned more info" + debugS logSrc' $ fromString "Execution of sql returned more info" displayDiagInfo sql_handle_stmt hstmt | x == sql_error -> do liftIO $ do - log $ fromString "Execution of sql returned error" + debugS logSrc' $ fromString "Execution of sql returned error" displayDiagInfo sql_handle_stmt hstmt fail "execute sql statement failed" | x == sql_invalid_handle -> do liftIO $ do - log $ fromString "Invaild statement handle" + debugS logSrc' $ fromString "Invaild statement handle" displayDiagInfo sql_handle_stmt hstmt fail "execute statemnt failed" | x == sql_need_data -> feeddata | x == sql_no_data -> do - liftIO $ log $ fromString "Execution of statement returned no data" + liftIO $ debugS logSrc' $ fromString "Execution of statement returned no data" fail "execute statement failed" | otherwise -> do liftIO $ do - log $ fromString $ "Execute statement returned unexpected result: " ++ (show x) + debugS logSrc' $ fromString $ "Execute statement returned unexpected result: " ++ (show x) displayDiagInfo sql_handle_stmt hstmt fail "Execute statement failed" + where logSrc' = logSrc <> "execDirect" -- | utility function that allocates a database connection handle and connects to -- the database. --- +-- -- On success, the computation returns the handle to the database conncection. --- +-- -- 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 $ log $ fromString $ "connect to server " ++ server + liftIO $ debugS logSrc' $ fromString $ "connect to server " ++ server hdbc <- allocHandle sql_handle_dbc henv result <- liftIO $ withCStringLen server (\(p_server, serverLen) -> withCStringLen user @@ -1126,25 +1154,26 @@ case result of x | x == sql_success -> return hdbc | x == sql_success_with_info -> do - liftIO $ log $ fromString $ "connect to server " ++ server ++ " returned warnings:" + liftIO $ debugS logSrc' $ fromString $ "connect to server " ++ server ++ " returned warnings:" liftIO $ displayDiagInfo sql_handle_dbc hdbc return hdbc | x == sql_error -> do - liftIO $ log $ fromString $ "connection to server " ++ server ++ " failed:" + liftIO $ debugS logSrc' $ 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 $ log $ fromString $ "connection to server " ++ server ++ " failed because of invalid handle" + liftIO $ debugS logSrc' $ fromString $ "connection to server " ++ server ++ " failed because of invalid handle" fail $ "connection to server " ++ server ++ " failed because of invalid handle" | otherwise -> do liftIO $ do - log $ fromString $ "Unexpected response code got from connecting to server " ++ server ++ ": " ++ (show x) - log $ fromString "Trying to extract diagnostic info:" + debugS logSrc' $ fromString $ "Unexpected response code got from connecting to server " ++ server ++ ": " ++ (show x) + debugS logSrc' $ fromString "Trying to extract diagnostic info:" displayDiagInfo sql_handle_dbc hdbc - log $ fromString "Try call disconnect on the connection handle, to make sure we release all resources" + debugS logSrc' $ 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) + where logSrc' = logSrc <> "connect" -- | wrapper for SQL CLI Disconnect API call; displays diagnostics -- on the standard error. @@ -1154,18 +1183,19 @@ case result of x | x == sql_success -> return () | x == sql_success_with_info -> do - log $ fromString "disconnect returned warnings:" + debugS logSrc' $ fromString "disconnect returned warnings:" displayDiagInfo sql_handle_dbc hdbc | x == sql_error -> do - log $ fromString "disconnect failed:" + debugS logSrc' $ fromString "disconnect failed:" displayDiagInfo sql_handle_dbc hdbc | x == sql_invalid_handle -> do - log $ fromString "disconnect failed because of invalid handle" + debugS logSrc' $ fromString "disconnect failed because of invalid handle" | otherwise -> do - log $ fromString "Unexpected response code got from Disconnect function" - log $ fromString "Trying to extract diagnostic info:" + debugS logSrc' $ fromString "Unexpected response code got from Disconnect function" + debugS logSrc' $ fromString "Trying to extract diagnostic info:" displayDiagInfo sql_handle_dbc hdbc freeHandle sql_handle_dbc hdbc + where logSrc' = logSrc <> "disconnect" -- | wrapper to SQL CLI AllocHandle API call; it displays diagnostics info -- on the standard error and fails if the handle could not be allocated @@ -1178,15 +1208,15 @@ case result of x | x == sql_success -> Just <$> peek p_handle | x == sql_invalid_handle -> do - log $ fromString $ "alloc handle failed because of invalid parent handle, for handle type " ++ (show handleType) + debugS logSrc' $ fromString $ "alloc handle failed because of invalid parent handle, for handle type " ++ (show handleType) displayDiagnostic return Nothing | x == sql_error -> do - log $ fromString $ "alloc handle failed with error for handle type " ++ (show handleType) + debugS logSrc' $ fromString $ "alloc handle failed with error for handle type " ++ (show handleType) displayDiagnostic return Nothing | otherwise -> do - log $ fromString $ "alloc handle returned unexpected result for handle type " ++ (show handleType) ++ ": " ++ (show x) + debugS logSrc' $ fromString $ "alloc handle returned unexpected result for handle type " ++ (show handleType) ++ ": " ++ (show x) displayDiagnostic return Nothing where displayDiagnostic = if handleType == sql_handle_env @@ -1197,8 +1227,9 @@ | 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 - + maybe (fail $ "AllocHandle failed for handle type " ++ (show handleType)) return handle + where logSrc' = logSrc <> "allocHandle" + -- | wrapper for SQL CLI FreeHandle API call; it displays diagnostics -- on the standard error; it does not fail freeHandle :: SQLSMALLINT -> SQLHANDLE -> IO () @@ -1207,15 +1238,16 @@ case result of x | x == sql_success -> return () | x == sql_error -> do - log $ fromString $ "Error freeing handle of type " ++ (show handleType) + debugS logSrc' $ fromString $ "Error freeing handle of type " ++ (show handleType) displayDiagInfo handleType handle | x == sql_invalid_handle -> do - log $ fromString "FreeHandle failed because of invalid handle" + debugS logSrc' $ fromString "FreeHandle failed because of invalid handle" displayDiagInfo handleType handle | otherwise -> do - log $ fromString $ "FreeHandle returned unexpected result " ++ (show x) - log $ fromString "Trying to get diagnostic info on FreeHandle:" + debugS logSrc' $ fromString $ "FreeHandle returned unexpected result " ++ (show x) + debugS logSrc' $ fromString "Trying to get diagnostic info on FreeHandle:" displayDiagInfo handleType handle + where logSrc' = logSrc <> "freeHandle" -- | create an 'IO' action that displays diagnostic records for a given handle on the -- standard error; this action will not fail @@ -1227,20 +1259,22 @@ displayDiagInfo' :: (MonadIO m, MonadFail m) => SQLSMALLINT -> SQLHANDLE -> m () displayDiagInfo' handleType handle = do recs <- getCountOfDiagRecs handleType handle - liftIO $ log $ fromString $ "there " + liftIO $ debugS logSrc' $ 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 $ log $ fromString $ "Diagnostic record " ++ (show i) + liftIO $ debugS logSrc' $ fromString $ "Diagnostic record " ++ (show i) r <- getDiagRec handleType handle i liftIO $ displayDiagRec r in sequence_ diags + where logSrc' = logSrc <> "displayDiagInfo'" -- | 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) +displayDiagRec r = debugS logSrc' $ fromString $ (show $ diagrec_i r) ++ ": " ++ (sqlstate r) ++ " - " ++ (show $ nativeError r) ++ " - " ++ (messageText r) + where logSrc' = logSrc <> "displayDiagRec" -- | 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 @@ -1253,19 +1287,20 @@ case result of x | x == sql_success -> Just <$> peek ptrRecs | x == sql_invalid_handle -> do - log $ fromString $ "Count of diagnostic records could not be retrieved due to an invalid handle, for handle type: " ++ (show handleType) + debugS logSrc' $ 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 - log $ fromString $ "Count of diagnostic records could not be retrieved because wrong arguments were passed to GetDiagField function, for handle type" ++ (show handleType) + debugS logSrc' $ 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 - log $ fromString $ "No diagnostic data available for handle type: " ++ (show handleType) + debugS logSrc' $ fromString $ "No diagnostic data available for handle type: " ++ (show handleType) return $ Just 0 | otherwise -> do - log $ fromString $ "Getting the number of diagnostic records returned unexpected return code for handle type " ++ (show handleType) ++ ": " ++ (show x) + debugS logSrc' $ 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 - + where logSrc' = logSrc <> "getCountOfDiagRecs" + -- | information in a diagnostic record data DiagRecord = DiagRecord { diagrec_i :: SQLSMALLINT, @@ -1290,20 +1325,21 @@ 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 recnum l_sqlstate l_nativeErr l_messageText + return $ Just $ DiagRecord recnum l_sqlstate l_nativeErr l_messageText | x == sql_error -> do - log $ fromString $ (show recnum) ++ ": Diagnostic information could not be retrieved becuase wrong arguments passed to GetDagRec function" + debugS logSrc' $ fromString $ (show recnum) ++ ": Diagnostic information could not be retrieved becuase wrong arguments passed to GetDagRec function" return Nothing | x == sql_invalid_handle -> do - log $ fromString $ (show recnum) ++ ": Diagnosic information could not be retrieved because of wrong handler" + debugS logSrc' $ fromString $ (show recnum) ++ ": Diagnosic information could not be retrieved because of wrong handler" return Nothing | x == sql_no_data -> do - log $ fromString $ (show recnum) ++ ": No diagnostic data available" + debugS logSrc' $ fromString $ (show recnum) ++ ": No diagnostic data available" return Nothing | otherwise -> do - log $ fromString $ (show recnum) ++ ": Getting diagnostic information returned unexpected error code " ++ (show x) + debugS logSrc' $ fromString $ (show recnum) ++ ": Getting diagnostic information returned unexpected error code " ++ (show x) return Nothing)))) maybe (fail "GetDiagRec call failed") return diagrecord + where logSrc' = logSrc <> "getDiagRec" -- | helper function to allocate a 'CStringLen'; it calls the function -- received as parameter with the address of the allocated string or @@ -1320,8 +1356,9 @@ if ind == sql_null_data then return Nothing 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 + debugS logSrc' $ fromString $ "reading value of len " ++ (show ind) ++ " from buffer with len " ++ (show $ sizeOf col) + return $ Just col + where logSrc' = logSrc <> "peekMaybeCol" -- | helper function to read a nullable text column; returns Nothing if the -- column is null