-- 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