-- Provides a more convenient way to use SQLCLI API from Haskell {-# LANGUAGE OverloadedStrings #-} module SQL.CLI.Utils where import Prelude hiding (fail, log) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Fail (MonadFail, fail) import Control.Logging (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, poke) import Foreign.Ptr (nullPtr, castPtr, Ptr) import Data.Maybe (maybe) 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) import SQL.CLI (sqlallochandle, sqlfreehandle, sqlgetdiagfield, sqlgetdiagrec, sqlconnect, 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, sql_success, sql_success_with_info, sql_invalid_handle, sql_no_data, sql_need_data, sql_max_message_length, sql_null_data, 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, 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 sql_cli_flds_table_schem :: SQLSMALLINT, -- ^ position of TABLE_SCHEM column in the resultset returned by Columns API call sql_cli_flds_table_name :: SQLSMALLINT, -- ^ position of TABLE_NAME column in the resultset returned by Columns API call sql_cli_flds_column_name :: SQLSMALLINT, -- ^ position of COLUMN_NAME column in the resultset returned by Columns API call sql_cli_flds_data_type :: SQLSMALLINT, -- ^ position of DATA_TYPE column in the resultset returned by Columns API call sql_cli_flds_type_name :: SQLSMALLINT, -- ^ position of TYPE_NAME column in the resultset returned by Columns API call sql_cli_flds_column_size :: SQLSMALLINT, -- ^ position of COLUMN_SIZE column in the resultset returned by Columns API call sql_cli_flds_buffer_length :: SQLSMALLINT, -- ^ position of BUFFER_LENGTH column in the resultset returned by Columns API call sql_cli_flds_decimal_digits :: SQLSMALLINT, -- ^ position of DECIMAL_DIGITS column in the resultset returned by Columns API call sql_cli_flds_num_prec_radix :: SQLSMALLINT, -- ^ position of NUM_PREC_RADIX column in the resultset returned by Columns API call sql_cli_flds_nullable :: SQLSMALLINT, -- ^ position of NULLABLE column in the resultset returned by Columns API call sql_cli_flds_remarks :: SQLSMALLINT, -- ^ position of REMARKS column in the resultset returned by Columns API call sql_cli_flds_column_def :: SQLSMALLINT, -- ^ position of COLUMN_DEF column in the resultset returned by Columns API call sql_cli_flds_datetime_code :: SQLSMALLINT, -- ^ position of DATETIME_CODE column in the resultset returned by Columns API call sql_cli_flds_char_octet_length :: SQLSMALLINT, -- ^ position of CHAR_OCTET_LENGTH column in the resultset returned by Columns API call sql_cli_flds_ordinal_position :: SQLSMALLINT, -- ^ position of ORDINAL_POSITION column in the resultset returned by Columns API call sql_cli_flds_is_nullable :: SQLSMALLINT -- ^ position of IS_NULLABLE column in the resultset returned by Columns API call } -- | information about column in the database; the meaning of fields is detailed -- in the SQL CLI specification in the documenation of Columns API call data ColumnInfo = ColumnInfo { ci_TableCat :: Maybe String, ci_TableSchem :: String, ci_TableName :: String, ci_ColumnName :: String, ci_DataType :: SQLSMALLINT, ci_TypeName :: String, ci_ColumnSize :: Maybe SQLINTEGER, ci_BufferLength :: Maybe SQLINTEGER, ci_DecimalDigits :: Maybe SQLSMALLINT, ci_NumPrecRadix :: Maybe SQLSMALLINT, ci_Nullable :: SQLSMALLINT, ci_Remarks :: Maybe String, ci_ColumnDef :: Maybe String, ci_DatetimeCode :: Maybe SQLINTEGER, ci_CharOctetLength :: Maybe SQLINTEGER, ci_OrdinalPosition :: SQLINTEGER, ci_IsNullable :: Maybe String } 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 -- ^ 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 (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 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 cols <- liftIO $ allocaBytes 129 (\ p_table_cat -> alloca (\ p_table_cat_ind -> allocaBytes 129 (\ p_table_schem -> allocaBytes 129 (\ p_table_name -> allocaBytes 129 (\ p_column_name -> alloca (\ p_data_type -> allocaBytes 129 (\ p_type_name -> alloca (\ p_column_size -> alloca (\ p_column_size_ind -> alloca ( \ p_buffer_length -> alloca (\ p_buffer_length_ind -> alloca (\ p_decimal_digits -> alloca (\ p_decimal_digits_ind -> alloca (\ p_num_prec_radix -> alloca (\ p_num_prec_radix_ind -> alloca (\ p_nullable -> allocaBytes 255 (\ p_remarks -> alloca (\ p_remarks_ind -> allocaBytes 255 (\ p_column_def -> alloca (\ p_column_def_ind -> alloca (\ p_datetime_code -> alloca (\ p_datetime_code_ind -> alloca (\ p_char_octet_length -> alloca (\ p_char_octet_length_ind -> alloca (\ p_ordinal_position -> allocaBytes 255 (\ p_is_nullable -> alloca (\ p_is_nullable_ind -> let readColumnInfo :: [ColumnInfo] -> MaybeT IO [ColumnInfo] readColumnInfo cols' = do col <- liftIO $ ColumnInfo <$> (peekMaybeTextCol p_table_cat p_table_cat_ind) <*> (peekCString p_table_schem) <*> (peekCString p_table_name) <*> (peekCString p_column_name) <*> (peek p_data_type) <*> (peekCString p_type_name) <*> (peekMaybeCol p_column_size p_column_size_ind) <*> (peekMaybeCol p_buffer_length p_buffer_length_ind) <*> (peekMaybeCol p_decimal_digits p_decimal_digits_ind) <*> (peekMaybeCol p_num_prec_radix p_num_prec_radix_ind) <*> (peek p_nullable) <*> (peekMaybeTextCol p_remarks p_remarks_ind) <*> (peekMaybeTextCol p_column_def p_column_def_ind) <*> (peekMaybeCol p_datetime_code p_datetime_code_ind) <*> (peekMaybeCol p_char_octet_length p_char_octet_length_ind) <*> (peek p_ordinal_position) <*> (peekMaybeTextCol p_is_nullable p_is_nullable_ind) 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 bindVarcharCol hstmt table_name_fld p_table_name 129 nullPtr bindVarcharCol hstmt column_name_fld p_column_name 129 nullPtr bindSmallIntCol hstmt data_type_fld p_data_type nullPtr bindVarcharCol hstmt type_name_fld p_type_name 129 nullPtr bindIntegerCol hstmt column_size_fld p_column_size p_column_size_ind bindIntegerCol hstmt buffer_length_fld p_buffer_length p_buffer_length_ind bindSmallIntCol hstmt decimal_digits_fld p_decimal_digits p_decimal_digits_ind bindSmallIntCol hstmt num_prec_radix_fld p_num_prec_radix p_num_prec_radix_ind bindSmallIntCol hstmt nullable_fld p_nullable nullPtr bindVarcharCol hstmt remarks_fld p_remarks 255 p_remarks_ind bindVarcharCol hstmt column_def_fld p_column_def 255 p_column_def_ind bindIntegerCol hstmt datetime_code_fld p_datetime_code p_datetime_code_ind 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 $ 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. 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 (Just schemaName) (Just tableName) Nothing 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 -- 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 $ debugS logSrc' $ fromString err liftIO $ displayDiagInfo handleType handle fail err | x == sql_success_with_info -> do 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 $ 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 $ 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 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 $ debugS logSrc' $ fromString err liftIO $ displayDiagInfo sql_handle_dbc hdbc fail err | x == sql_success_with_info -> do 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 $ 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 $ 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 -- 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 $ debugS logSrc' $ fromString err liftIO $ displayDiagInfo sql_handle_desc hdesc fail err | x == sql_success_with_info -> do 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 $ 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 $ 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 -- 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 $ debugS logSrc' $ fromString err liftIO $ displayDiagInfo sql_handle_desc hdesc fail err | x == sql_success_with_info -> do 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 $ 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 $ 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 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 $ debugS logSrc' $ fromString err liftIO $ displayDiagInfo sql_handle_desc hdesc fail err | x == sql_success_with_info -> do 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 $ 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 $ 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 -- 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 $ 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 $ 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 $ 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 $ 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 $ 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 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 debugS logSrc' $ fromString "call to SQL/CLI function NumResultCols failed" displayDiagInfo sql_handle_stmt hstmt return Nothing | x == sql_success_with_info -> do debugS logSrc' $ fromString "call to SQL/CLI function NumResultColss returned warnings" displayDiagInfo sql_handle_stmt hstmt cols | x == sql_invalid_handle -> do debugS logSrc' $ fromString "invalid handle given to call to SQL/CLI function NumResultCols" return Nothing | otherwise -> do 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 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 $ debugS logSrc' $ fromString err liftIO $ displayDiagInfo sql_handle_stmt hstmt fail err | x == sql_success_with_info -> do 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 $ 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 $ 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 -> 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 $ debugS logSrc' $ fromString err liftIO $ displayDiagInfo sql_handle_stmt hstmt fail err | x == sql_success_with_info -> do 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 $ debugS logSrc' $ fromString err fail err | otherwise -> do let err = "binding parameter " ++ (show paramno) ++ " returned unexepcted result: " ++ (show x) 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 () 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 $ debugS logSrc' $ fromString err liftIO $ displayDiagInfo sql_handle_stmt hstmt fail err | x == sql_success_with_info -> do 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 $ debugS logSrc' $ fromString err fail err | otherwise -> do let err = "call to SQL/CLI function PutData returned unexpected result: " ++ (show x) 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 -- 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 $ debugS logSrc' $ fromString err liftIO $ displayDiagInfo sql_handle_stmt hstmt fail err | x == sql_success -> return () | x == sql_success_with_info -> do liftIO $ debugS logSrc' $ fromString "(ParamData) statement executed but generated warnings" liftIO $ displayDiagInfo sql_handle_stmt hstmt | x == sql_no_data -> do 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 $ debugS logSrc' $ fromString err fail err | otherwise -> do let err = "unexpected result returned by a call to SQL/CLI function ParamData: " ++ (show x) 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 () 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 $ debugS logSrc' $ fromString err liftIO $ displayDiagInfo sql_handle_stmt hstmt fail err | x == sql_success_with_info -> liftIO $ do 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 $ 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 $ 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'; -- 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 $ 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 $ 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 $ debugS logSrc' $ fromString err fail err | x == sql_no_data -> do 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 $ 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 data ConciseColInfo = ConciseColInfo { cci_ColumnName :: String, cci_DataType :: SQLSMALLINT, cci_ColumnSize :: SQLULEN, cci_DecimalDigits :: SQLSMALLINT, cci_Nullable :: Bool } -- | wrapper for DescribeCol SQL CLI API call describeCol :: (MonadIO m, MonadFail m) => SQLHSTMT -> SQLSMALLINT -> m ConciseColInfo describeCol hstmt colnum = do info <- liftIO $ allocaBytes 255 (\ p_columnName -> alloca (\ p_nameLength -> alloca (\ p_dataType -> alloca (\ p_columnSize -> alloca (\ p_decimalDigits -> alloca (\ p_nullable -> do result <- sqldescribecol hstmt colnum p_columnName 255 p_nameLength p_dataType p_columnSize p_decimalDigits p_nullable let readInfo = Just <$> do nameLength <- peek p_nameLength nullable <- peek p_nullable ConciseColInfo <$> peekCStringLen (castPtr p_columnName, fromIntegral nameLength) <*> peek p_dataType <*> peek p_columnSize <*> peek p_decimalDigits <*> (return $ if nullable == sql_no_nulls then False else True) case result of x | x == sql_success -> readInfo | x == sql_success_with_info -> do debugS logSrc' $ fromString "More information returned by DescribeCol" displayDiagInfo sql_handle_stmt hstmt readInfo | x == sql_error -> do debugS logSrc' $ fromString "Error calling DescribeCol" displayDiagInfo sql_handle_stmt hstmt return Nothing | x == sql_invalid_handle -> do debugS logSrc' $ fromString "Invalid handle calling DescribeCol" return Nothing | otherwise -> do debugS logSrc' $ 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 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 () columns hstmt catalogName schemaName tableName columnName = do result <- liftIO $ withMaybeCStringLen catalogName (\ (p_catalogName, catalogNameLen) -> withMaybeCStringLen schemaName (\ (p_schemaName, schemaNameLen) -> withMaybeCStringLen tableName (\ (p_tableName, tableNameLen) -> withMaybeCStringLen columnName (\ (p_columnName, columnNameLen) -> sqlcolumns hstmt (castPtr p_catalogName) (fromIntegral catalogNameLen) (castPtr p_schemaName) (fromIntegral schemaNameLen) (castPtr p_tableName) (fromIntegral tableNameLen) (castPtr p_columnName) (fromIntegral columnNameLen))))) case result of x | x == sql_success -> return () | x == sql_error -> do liftIO $ debugS logSrc' $ fromString "Error calling Columns" liftIO $ displayDiagInfo sql_handle_stmt hstmt fail "Columns failed" | x == sql_success_with_info -> do liftIO $ debugS logSrc' $ fromString "Columns returned more info" liftIO $ displayDiagInfo sql_handle_stmt hstmt | x == sql_invalid_handle -> do liftIO $ debugS logSrc' $ fromString "Invalid statement handle passed to Columns call" fail "Columns failed" | otherwise -> do 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 result <- liftIO $ withMaybeCStringLen catalogName (\ (p_catalogName, catalogNameLen) -> withMaybeCStringLen schemaName ( \ (p_schemaName, schemaNameLen) -> withMaybeCStringLen tableName ( \ (p_tableName, tableNameLen) -> withMaybeCStringLen tableType ( \ (p_tableType, tableTypeLen) -> sqltables hstmt (castPtr p_catalogName) (fromIntegral catalogNameLen) (castPtr p_schemaName) (fromIntegral schemaNameLen) (castPtr p_tableName) (fromIntegral tableNameLen) (castPtr p_tableType) (fromIntegral tableTypeLen))))) case result of x | x == sql_success -> return () | x == sql_error -> do liftIO $ do debugS logSrc' $ fromString "Error calling Tables" displayDiagInfo sql_handle_stmt hstmt fail "Tables failed" | x == sql_success_with_info -> do liftIO $ do debugS logSrc' $ fromString "Tables returned more info" displayDiagInfo sql_handle_stmt hstmt | x == sql_invalid_handle -> do liftIO $ debugS logSrc' $ fromString "Invalid handle calling Tables" fail "Tables failed" | otherwise -> do liftIO $ do 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 forAllRecords :: (MonadIO m, MonadFail m) => SQLHSTMT -> (a -> m a) -> a -> m a 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 -> 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 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 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 $ debugS logSrc' $ fromString "Invalid handle when calling GetData" fail "GetData failed" | x == sql_error -> do liftIO $ do debugS logSrc' $ fromString "Error calling GetData" displayDiagInfo sql_handle_stmt hstmt fail "GetData failed" | x == sql_no_data -> do 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 $ 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 $ debugS logSrc' $ fromString "More data but no 01004 diagnostic record found" more | otherwise -> do liftIO $ do 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 $ 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 $ let hasMoreDataRecord [] = return False hasMoreDataRecord (x:xs) = do drec <- x if sqlstate drec == "01004" then return True 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 -- the standard error. fetch :: (MonadIO m, MonadFail m) => SQLHSTMT -> m Bool 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. 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 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 -> fetchedaction | x == sql_error -> do liftIO $ debugS logSrc' $ fromString "Error fetching record" liftIO $ displayDiagInfo sql_handle_stmt hstmt failaction "Fetch failed" | x == sql_invalid_handle -> do liftIO $ debugS logSrc' $ fromString "Invalid handle when fetching record" failaction "Fetch failed due to invalid handle" | x == sql_no_data -> do liftIO $ debugS logSrc' $ fromString "All records have been fetched" endaction | x == sql_success_with_info -> do liftIO $ debugS logSrc' $ fromString "More diagnostic info returned for record" liftIO $ displayDiagInfo sql_handle_stmt hstmt fetchedaction | otherwise -> do 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 -> SQLSMALLINT -- ^ column number (starting with 1) -> Ptr SQLSMALLINT -- ^ buffer to receive the value -> 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 -- | helper function to bind an INTEGER column bindIntegerCol :: (MonadIO m, MonadFail m) => SQLHSTMT -- ^ statement handle -> SQLSMALLINT -- ^ column number (starting with 1) -> Ptr SQLINTEGER -- ^ buffer to receive the value -> 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 -- | helper function to bind a VARCHAR column. The buffer length parameter must include the -- NULL terminating character of the 'CString'. bindVarcharCol :: (MonadIO m, MonadFail m) => SQLHSTMT -- ^ statement handle -> SQLSMALLINT -- ^ column number (starting with 1) -> CString -- ^ buffer to receive the null terminated text data -> 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 -> 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 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 debugS logSrc' $ fromString $ "Binding col " ++ (show colNum) ++ " returned warnings:" displayDiagInfo sql_handle_stmt hstmt | x == sql_invalid_handle -> do liftIO $ debugS logSrc' $ fromString $ "Invalid handle when binding column " ++ (show colNum) fail "Binding column failed" | otherwise -> do liftIO $ do 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. -- -- 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 $ debugS logSrc' $ fromString "sql statement executed" | x == sql_success_with_info -> liftIO $ do debugS logSrc' $ fromString "Execution of sql returned more info" displayDiagInfo sql_handle_stmt hstmt | x == sql_error -> do liftIO $ do 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 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 $ debugS logSrc' $ fromString "Execution of statement returned no data" fail "execute statement failed" | otherwise -> do liftIO $ do 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 $ debugS logSrc' $ fromString $ "connect to server " ++ server hdbc <- allocHandle sql_handle_dbc henv result <- liftIO $ withCStringLen server (\(p_server, serverLen) -> withCStringLen user (\(p_user, userLen) -> withCStringLen pass (\(p_pass, passLen) -> sqlconnect hdbc (castPtr p_server) (fromIntegral serverLen) (castPtr p_user) (fromIntegral userLen) (castPtr p_pass) (fromIntegral passLen)))) case result of x | x == sql_success -> return hdbc | x == sql_success_with_info -> do liftIO $ debugS logSrc' $ fromString $ "connect to server " ++ server ++ " returned warnings:" liftIO $ displayDiagInfo sql_handle_dbc hdbc return hdbc | x == sql_error -> do 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 $ 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 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 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. disconnect :: SQLHDBC -> IO () disconnect hdbc = do result <- sqldisconnect hdbc case result of x | x == sql_success -> return () | x == sql_success_with_info -> do debugS logSrc' $ fromString "disconnect returned warnings:" displayDiagInfo sql_handle_dbc hdbc | x == sql_error -> do debugS logSrc' $ fromString "disconnect failed:" displayDiagInfo sql_handle_dbc hdbc | x == sql_invalid_handle -> do debugS logSrc' $ fromString "disconnect failed because of invalid handle" | otherwise -> do 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 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 debugS logSrc' $ fromString $ "alloc handle failed because of invalid parent handle, for handle type " ++ (show handleType) displayDiagnostic return Nothing | x == sql_error -> do debugS logSrc' $ fromString $ "alloc handle failed with error for handle type " ++ (show handleType) displayDiagnostic return Nothing | otherwise -> do 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 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 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 () freeHandle handleType handle = do result <- sqlfreehandle handleType handle case result of x | x == sql_success -> return () | x == sql_error -> do debugS logSrc' $ fromString $ "Error freeing handle of type " ++ (show handleType) displayDiagInfo handleType handle | x == sql_invalid_handle -> do debugS logSrc' $ fromString "FreeHandle failed because of invalid handle" displayDiagInfo handleType handle | otherwise -> do 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 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 -> SQLHANDLE -> m () displayDiagInfo' handleType handle = do recs <- getCountOfDiagRecs handleType handle 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 $ 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 = 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 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 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 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 debugS logSrc' $ fromString $ "No diagnostic data available for handle type: " ++ (show handleType) return $ Just 0 | otherwise -> do 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, sqlstate :: String, nativeError :: SQLINTEGER, messageText :: String } -- | 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 -> SQLHANDLE -> SQLSMALLINT -> m DiagRecord getDiagRec handleType handle recnum = do diagrecord <- liftIO $ allocaBytes 5 (\p_sqlstate -> alloca (\p_nativeErr -> allocaBytes sql_max_message_length (\p_messageText -> alloca (\p_textLen -> do result <- sqlgetdiagrec handleType handle recnum p_sqlstate p_nativeErr p_messageText sql_max_message_length p_textLen case result of x | x == sql_success -> do l_sqlstate <- (map (toEnum . fromIntegral)) <$> (sequence [peekElemOff p_sqlstate j | j <- [0..4]]) 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 | x == sql_error -> do 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 debugS logSrc' $ fromString $ (show recnum) ++ ": Diagnosic information could not be retrieved because of wrong handler" return Nothing | x == sql_no_data -> do debugS logSrc' $ fromString $ (show recnum) ++ ": No diagnostic data available" return Nothing | otherwise -> do 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 -- with a null pointer if no string was received as input (i.e. 'Nothing') withMaybeCStringLen :: Maybe String -> (CStringLen -> IO a) -> IO a withMaybeCStringLen Nothing f = f (nullPtr, 0) withMaybeCStringLen (Just s) f = withCStringLen s f -- | helper function to read a nullable column; returns Nothing if the -- column is null 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 do col <- peek p_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 peekMaybeTextCol :: CString -> Ptr SQLLEN -> IO (Maybe String) peekMaybeTextCol p_col p_ind = do ind <- peek p_ind if ind == sql_null_data then return Nothing else Just <$> peekCString p_col