sqlcli (empty) → 0.1.0.0
raw patch · 6 files changed
+1874/−0 lines, 6 filesdep +basedep +transformerssetup-changed
Dependencies added: base, transformers
Files
- LICENSE +30/−0
- README.md +11/−0
- Setup.hs +2/−0
- sqlcli.cabal +45/−0
- src/SQL/CLI.hs +1026/−0
- src/SQL/CLI/Utils.hs +760/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Mihai Giurgeanu (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,11 @@+# sqlcli++A library wrapping X/Open's SQL/CLI specification for C bindings.++The `SQL.CLI` module contains all the foreign function calls, constants+and types defined by the SQL/CLI specificaition. ++`SQL.CLI.Utils` module contains wrappers to SQL/CLI function calls +that make easier to treat the error cases and deal with the SQL/CLI+diagnostic as well as other useful constructs in calling SQL/CLI API.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ sqlcli.cabal view
@@ -0,0 +1,45 @@+name: sqlcli+version: 0.1.0.0+synopsis: Sql Call-Level Interface bindings for Haskell.+description: Provides bindings to SQL/CLI C API, importing+ all foreign functions defined in the specifications,+ defining types and constants used in the specification.+ + Also it provides some wrapers to the foreign C calls and+ utilities to make using the SQL/CLI easier for the Haskell+ programmer.+ +homepage: http://hub.darcs.net/mihaigiurgeanu/sqlcli+license: BSD3+license-file: LICENSE+author: Mihai Giurgeanu+maintainer: mihai.giurgean@gmail.com+copyright: 2017 Mihai Giurgeanu+category: Database+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++Flag ODBC+ Description: Compile against ODBC library+ Default: False+ Manual: True++library+ hs-source-dirs: src+ exposed-modules: SQL.CLI,+ SQL.CLI.Utils+ build-depends: base >= 4.7 && < 5,+ transformers >= 0.5 && < 0.6+ default-language: Haskell2010++ if flag(odbc)+ if os(windows)+ extra-libraries: odbc32+ else+ extra-libraries: odbc+++source-repository head+ type: darcs+ location: http://hub.darcs.net/mihaigiurgeanu/sqlcli
+ src/SQL/CLI.hs view
@@ -0,0 +1,1026 @@+{-# LANGUAGE ForeignFunctionInterface #-}++module SQL.CLI where++import Foreign.C.Types+import Foreign.Ptr (Ptr)+import Data.Bits ((.&.), complement)+-- API declaration data types+type SQLCHAR = CUChar+type SQLINTEGER = CLong+type SQLSMALLINT = CShort+type SQLDOUBLE = CDouble+type SQLFLOAT = CDouble+type SQLREAL = CFloat+type SQLPOINTER = Ptr ()+type SQLDATE = CUChar+type SQLTIME = CUChar+type SQLTIMESTAMP = CUChar+type SQLVARCHAR = CUChar+type SQLDECIMAL = CUChar+type SQLNUMERIC = CUChar++-- function return type+type SQLRETURN = SQLSMALLINT++-- generic data structures+type SQLHENV = SQLINTEGER+type SQLHDBC = SQLINTEGER+type SQLHSTMT = SQLINTEGER+type SQLHDESC = SQLINTEGER++-- special length/indicator values+-- The value of 'sql_null_data' should+-- not be changed; it was chosen for compatibility with the+-- ISO SQL definition of the value returned to indicate a null value. */+sql_null_data :: Num a => a+sql_null_data = -1++sql_data_at_exec :: Num a => a+sql_data_at_exec = -2++-- return values from functions+-- These codes should not be changed;+-- they were chosen for compatibility with the ISO SQL definition * of SQLCODE.+sql_success :: SQLRETURN+sql_success = 0++sql_success_with_info :: SQLRETURN+sql_success_with_info = 1++sql_no_data :: SQLRETURN+sql_no_data = 100++sql_error :: SQLRETURN+sql_error = -1++sql_invalid_handle :: SQLRETURN+sql_invalid_handle = -2++sql_need_data :: SQLRETURN+sql_need_data = 99++-- | Test for 'sql_success' or 'sql_success_with_info'+sql_succeeded :: SQLRETURN -> Bool+sql_succeeded rc = (rc .&. (complement 1)) == 0++-- flags for null-terminated strings+sql_nts :: Num a => a+sql_nts = -3+sql_ntsl :: Num a => a+sql_ntsl = -3++-- | maximum message lenth+-- Vendors may increase this constant but its value must be at lieast 512+sql_max_message_length :: Num a => a+sql_max_message_length = 512++-- | maximum identifier length+sql_max_id_length :: Num a => a+sql_max_id_length = 18+++-- date/time length constants+sql_date_len :: Num a => a+sql_date_len = 10++sql_time_len :: Num a => a+sql_time_len = 8 -- add P+1 if precision is nonzero++sql_timestamp_len :: Num a => a+sql_timestamp_len = 19 -- add P+1 if precision is nonzero++-- handle type identifiers+sql_handle_env :: Num a => a+sql_handle_env = 1++sql_handle_dbc :: Num a => a+sql_handle_dbc = 2++sql_handle_stmt :: Num a => a+sql_handle_stmt = 3++sql_handle_desc :: Num a => a+sql_handle_desc = 4++-- | environment attribute+sql_attr_output_nts :: Num a => a+sql_attr_output_nts = 10001++-- | connection attribute+sql_attr_auto_ipd :: Num a => a+sql_attr_auto_ipd = 10001++-- | connection and schema attributes+sql_attr_metadata_id :: Num a => a+sql_attr_metadata_id = 10014++-- statement attributes+sql_attr_app_row_desc :: Num a => a+sql_attr_app_row_desc = 10010++sql_attr_app_param_desc :: Num a => a+sql_attr_app_param_desc = 10011++sql_attr_imp_row_desc :: Num a => a+sql_attr_imp_row_desc = 10012++sql_attr_imp_param_desc :: Num a => a+sql_attr_imp_param_desc = 10013++sql_attr_cursor_scrollable :: Num a => a+sql_attr_cursor_scrollable = -1++sql_attr_cursor_sensitivity :: Num a => a+sql_attr_cursor_sensitivity = -2++-- identifiers of fields in the sql descriptor+sql_desc_count :: Num a => a+sql_desc_count = 1001++sql_desc_type :: Num a => a+sql_desc_type = 1002++sql_desc_length :: Num a => a+sql_desc_length = 1003++sql_desc_octet_lenth_ptr :: Num a => a+sql_desc_octet_lenth_ptr = 1004++sql_desc_precision :: Num a => a+sql_desc_precision = 1005++sql_desc_scale :: Num a => a+sql_desc_scale = 1006++sql_desc_datetime_interval_code :: Num a => a+sql_desc_datetime_interval_code = 1007++sql_desc_nullable :: Num a => a+sql_desc_nullable = 1008++sql_desc_indicator_ptr :: Num a => a+sql_desc_indicator_ptr = 1009++sql_desc_data_ptr :: Num a => a+sql_desc_data_ptr = 1010++sql_desc_name :: Num a => a+sql_desc_name = 1011++sql_desc_unnamed :: Num a => a+sql_desc_unnamed = 1012++sql_desc_octet_length :: Num a => a+sql_desc_octet_length = 1013++sql_desc_alloc_type :: Num a => a+sql_desc_alloc_type = 1099++-- identifiers of fields in the diagnostics area+sql_diag_returncode :: Num a => a+sql_diag_returncode = 1++sql_diag_number :: Num a => a+sql_diag_number = 2++sql_diag_row_count :: Num a => a+sql_diag_row_count = 3++sql_diag_sqlstate :: Num a => a+sql_diag_sqlstate = 4+++sql_diag_native :: Num a => a+sql_diag_native = 5++sql_diag_message_text :: Num a => a+sql_diag_message_text = 6++sql_diag_dynamic_function :: Num a => a+sql_diag_dynamic_function = 7++sql_diag_class_origin :: Num a => a+sql_diag_class_origin = 8++sql_diag_subclass_origin :: Num a => a+sql_diag_subclass_origin = 9++sql_diag_connection_name :: Num a => a+sql_diag_connection_name = 10++sql_diag_server_name :: Num a => a+sql_diag_server_name = 11++sql_diag_dynamic_function_code :: Num a => a+sql_diag_dynamic_function_code = 12+++-- dynamic function codes+-- These codes should not be changed;+-- they were chosen for compatibility with the ISO SQL definition * of dynamic function codes.+sql_diag_alter_table :: Num a => a+sql_diag_alter_table = 4++sql_diag_create_index :: Num a => a+sql_diag_create_index = -1++sql_diag_create_table :: Num a => a+sql_diag_create_table = 77++sql_diag_create_view :: Num a => a+sql_diag_create_view = 84++sql_diag_delete_where :: Num a => a+sql_diag_delete_where = 19++sql_diag_drop_index :: Num a => a+sql_diag_drop_index = -2++sql_diag_drop_table :: Num a => a+sql_diag_drop_table = 32++sql_diag_drop_view :: Num a => a+sql_diag_drop_view = 36++sql_diag_dynamic_delete_cursor :: Num a => a+sql_diag_dynamic_delete_cursor = 38++sql_diag_dynamic_update_cursor :: Num a => a+sql_diag_dynamic_update_cursor = 81++sql_diag_grant :: Num a => a+sql_diag_grant = 48++sql_diag_insert :: Num a => a+sql_diag_insert = 50++sql_diag_revoke :: Num a => a+sql_diag_revoke = 59++sql_diag_select_cursor :: Num a => a+sql_diag_select_cursor = 85++sql_diag_unknown_statement :: Num a => a+sql_diag_unknown_statement = 0++sql_diag_update_where :: Num a => a+sql_diag_update_where = 82++-- SQL data type codes+-- These codes should not be changed;+-- they were chosen for compatibility with the ISO SQL definition * of data type codes.+sql_char :: Num a => a+sql_char = 1++sql_numeric :: Num a => a+sql_numeric = 2++sql_decimal :: Num a => a+sql_decimal = 3++sql_integer :: Num a => a+sql_integer = 4++sql_smallint :: Num a => a+sql_smallint = 5++sql_float :: Num a => a+sql_float = 6++sql_real :: Num a => a+sql_real = 7++sql_double :: Num a => a+sql_double = 8++sql_datetime :: Num a => a+sql_datetime = 9++sql_varchar :: Num a => a+sql_varchar = 12++-- One-parameter shortcuts for date/time data types+sql_type_date :: Num a => a+sql_type_date = 91++sql_type_time :: Num a => a+sql_type_time = 92++sql_type_timestamp :: Num a => a+sql_type_timestamp = 93+++-- Statement attribute values for cursor sensitivity+sql_unspecified :: Num a => a+sql_unspecified = 0++sql_insensitive :: Num a => a+sql_insensitive = 1++sql_sensitive :: Num a => a+sql_sensitive = 2+++-- GetTypeInfo() request for all data types+sql_all_types :: Num a => a+sql_all_types = 0++ +-- Default conversion code for BindCol(), BindParam() and GetData()+sql_default :: Num a => a+sql_default = 99+++-- GetData() code indicating that the application row descriptor * specifies the data type+sql_ard_type :: Num a => a+sql_ard_type = -99+++-- SQL date/time type subcodes+-- These codes should not be changed;+-- they were chosen for compatibility with the ISO SQL definition * of date/time type subcodes.+sql_code_date :: Num a => a+sql_code_date = 1++sql_code_time :: Num a => a+sql_code_time = 2++sql_code_timestamp :: Num a => a+sql_code_timestamp = 3+++-- CLI option values+sql_false :: Num a => a+sql_false = 0++sql_true :: Num a => a+sql_true = 1+++-- values of NULLABLE field in descriptor+-- These codes should not be changed;+-- they were chosen for compatibility with the ISO SQL definition * of the NULLABLE descriptor field.+sql_no_nulls :: Num a => a+sql_no_nulls = 0++sql_nullable :: Num a => a+sql_nullable = 1+++-- Value returned by GetTypeInfo() to denote that it is+-- not known whether or not a data type supports null values+sql_nullable_unknown :: Num a => a+sql_nullable_unknown = 2+++-- Values returned by GetTypeInfo() to show WHERE clause supported+sql_pred_none :: Num a => a+sql_pred_none = 0++sql_pred_char :: Num a => a+sql_pred_char = 1++sql_pred_basic :: Num a => a+sql_pred_basic = 2+++-- values of UNNAMED field in descriptor+-- These codes should not be changed;+-- they were chosen for compatibility with the ISO SQL definition+-- of the UNNAMED descriptor field.+sql_named :: Num a => a+sql_named = 0++sql_unnamed :: Num a => a+sql_unnamed = 1+++--values of ALLOC_TYPE field in descriptor+sql_desc_alloc_auto :: Num a => a+sql_desc_alloc_auto = 1++sql_desc_alloc_user :: Num a => a+sql_desc_alloc_user = 2+++-- FreeStmt() options+sql_close :: Num a => a+sql_close = 0++sql_drop :: Num a => a+sql_drop = 1++sql_unbind :: Num a => a+sql_unbind = 2++sql_reset_params :: Num a => a+sql_reset_params = 3+++-- Codes used for FetchOrientation in FetchScroll(), and in DataSources()+sql_fetch_next :: Num a => a+sql_fetch_next = 1++sql_fetch_first :: Num a => a+sql_fetch_first = 2+++-- Other codes used for FetchOrientation in FetchScroll() */+sql_fetch_last :: Num a => a+sql_fetch_last = 3++sql_fetch_prior :: Num a => a+sql_fetch_prior = 4++sql_fetch_absolute :: Num a => a+sql_fetch_absolute = 5+sql_fetch_relative :: Num a => a+sql_fetch_relative = 6+++-- EndTran() options+sql_commit :: Num a => a+sql_commit = 0++sql_rollback :: Num a => a+sql_rollback = 1+++-- null handles returned by AllocHandle()+sql_null_henv :: Num a => a+sql_null_henv = 0++sql_null_hdbc :: Num a => a+sql_null_hdbc = 0++sql_null_hstmt :: Num a => a+sql_null_hstmt = 0++sql_null_hdesc :: Num a => a+sql_null_hdesc = 0+++-- null handle used in place of parent handle when allocating HENV+sql_null_handle :: Num a => a+sql_null_handle = 0+++-- Values that may appear in the result set of SpecialColumns()+sql_scope_currow :: Num a => a+sql_scope_currow = 0++sql_scope_transaction :: Num a => a+sql_scope_transaction = 1++sql_scope_session :: Num a => a+sql_scope_session = 2+++sql_pc_unknown :: Num a => a+sql_pc_unknown = 0++sql_pc_non_pseudo :: Num a => a+sql_pc_non_pseudo = 1++sql_pc_pseudo :: Num a => a+sql_pc_pseudo = 2+++-- Reserved value for the IdentifierType argument of SpecialColumns()+sql_row_identifier :: Num a => a+sql_row_identifier = 1+++-- Reserved values for UNIQUE argument of Statistics()+sql_index_unique :: Num a => a+sql_index_unique = 0++sql_index_all :: Num a => a+sql_index_all = 1+++-- Values that may appear in the result set of Statistics()+sql_index_clustered :: Num a => a+sql_index_clustered = 1++sql_index_hashed :: Num a => a+sql_index_hashed = 2++sql_index_other :: Num a => a+sql_index_other = 3+++-- GetFunctions() values to identify CLI functions+sql_api_sqlallocconnect :: Num a => a+sql_api_sqlallocconnect = 1++sql_api_sqlallocenv :: Num a => a+sql_api_sqlallocenv = 2++sql_api_sqlallochandle :: Num a => a+sql_api_sqlallochandle = 1001++sql_api_sqlallocstmt :: Num a => a+sql_api_sqlallocstmt = 3++sql_api_sqlbindcol :: Num a => a+sql_api_sqlbindcol = 4++sql_api_sqlbindparam :: Num a => a+sql_api_sqlbindparam = 22++sql_api_sqlcancel :: Num a => a+sql_api_sqlcancel = 5++sql_api_sqlclosecursor :: Num a => a+sql_api_sqlclosecursor = 1003++sql_api_sqlcolattribute :: Num a => a+sql_api_sqlcolattribute = 6++sql_api_sqlcolumns :: Num a => a+sql_api_sqlcolumns = 40++sql_api_sqlconnect :: Num a => a+sql_api_sqlconnect = 7++sql_api_sqlcopydesc :: Num a => a+sql_api_sqlcopydesc = 1004++sql_api_sqldatasources :: Num a => a+sql_api_sqldatasources = 57++sql_api_sqldescribecol :: Num a => a+sql_api_sqldescribecol = 8++sql_api_sqldisconnect :: Num a => a+sql_api_sqldisconnect = 9++sql_api_sqlendtran :: Num a => a+sql_api_sqlendtran = 1005++sql_api_sqlerror :: Num a => a+sql_api_sqlerror = 10++sql_api_sqlexecdirect :: Num a => a+sql_api_sqlexecdirect = 11++sql_api_sqlexecute :: Num a => a+sql_api_sqlexecute = 12++sql_api_sqlfetch :: Num a => a+sql_api_sqlfetch = 13++sql_api_sqlfetchscroll :: Num a => a+sql_api_sqlfetchscroll = 1021++sql_api_sqlfreeconnect :: Num a => a+sql_api_sqlfreeconnect = 14++sql_api_sqlfreeenv :: Num a => a+sql_api_sqlfreeenv = 15++sql_api_sqlfreehandle :: Num a => a+sql_api_sqlfreehandle = 1006++sql_api_sqlfreestmt :: Num a => a+sql_api_sqlfreestmt = 16++sql_api_sqlgetconnectattr :: Num a => a+sql_api_sqlgetconnectattr = 1007++sql_api_sqlgetconnectoption :: Num a => a+sql_api_sqlgetconnectoption = 42+ +sql_api_sqlgetcursorname :: Num a => a+sql_api_sqlgetcursorname = 17+ +sql_api_sqlgetdata :: Num a => a+sql_api_sqlgetdata = 43+ +sql_api_sqlgetdescfield :: Num a => a+sql_api_sqlgetdescfield = 1008+ +sql_api_sqlgetdescrec :: Num a => a+sql_api_sqlgetdescrec = 1009+ +sql_api_sqlgetdiagfield :: Num a => a+sql_api_sqlgetdiagfield = 1010+ +sql_api_sqlgetdiagrec :: Num a => a+sql_api_sqlgetdiagrec = 1011+ +sql_api_sqlgetenvattr :: Num a => a+sql_api_sqlgetenvattr = 1012+ +sql_api_sqlgetfunctions :: Num a => a+sql_api_sqlgetfunctions = 44+ +sql_api_sqlgetinfo :: Num a => a+sql_api_sqlgetinfo = 45+ +sql_api_sqlgetstmtattr :: Num a => a+sql_api_sqlgetstmtattr = 1014+ +sql_api_sqlgetstmtoption :: Num a => a+sql_api_sqlgetstmtoption = 46+ +sql_api_sqlgettypeinfo :: Num a => a+sql_api_sqlgettypeinfo = 47+ +sql_api_sqllanguages :: Num a => a+sql_api_sqllanguages = 2001+ +sql_api_sqlnumresultcols :: Num a => a+sql_api_sqlnumresultcols = 18+ +sql_api_sqlparamdata :: Num a => a+sql_api_sqlparamdata = 48+ +sql_api_sqlprepare :: Num a => a+sql_api_sqlprepare = 19+ +sql_api_sqlputdata :: Num a => a+sql_api_sqlputdata = 49+ +sql_api_sqlreleaseenv :: Num a => a+sql_api_sqlreleaseenv = 1015+ +sql_api_sqlrowcount :: Num a => a+sql_api_sqlrowcount = 20+ +sql_api_sqlserverinfo :: Num a => a+sql_api_sqlserverinfo = 2002+ +sql_api_sqlsetconnectattr :: Num a => a+sql_api_sqlsetconnectattr = 1016+ +sql_api_sqlsetconnectoption :: Num a => a+sql_api_sqlsetconnectoption = 50+ +sql_api_sqlsetcursorname :: Num a => a+sql_api_sqlsetcursorname = 21+ +sql_api_sqlsetdescfield :: Num a => a+sql_api_sqlsetdescfield = 1017+ +sql_api_sqlsetdescrec :: Num a => a+sql_api_sqlsetdescrec = 1018+ +sql_api_sqlsetenvattr :: Num a => a+sql_api_sqlsetenvattr = 1019+ +sql_api_sqlsetparam :: Num a => a+sql_api_sqlsetparam = 22+ +sql_api_sqlsetstmtattr :: Num a => a+sql_api_sqlsetstmtattr = 1020+ +sql_api_sqlsetstmtoption :: Num a => a+sql_api_sqlsetstmtoption = 51+ +sql_api_sqlspecialcolumns :: Num a => a+sql_api_sqlspecialcolumns = 52+ +sql_api_sqlstatistics :: Num a => a+sql_api_sqlstatistics = 53+ +sql_api_sqltables :: Num a => a+sql_api_sqltables = 54+ +sql_api_sqltransact :: Num a => a+sql_api_sqltransact = 23+++-- Information requested by GetInfo()+sql_max_driver_connections :: Num a => a+sql_max_driver_connections = 0+ +sql_max_concurrent_activities :: Num a => a+sql_max_concurrent_activities = 1+ +sql_data_source_name :: Num a => a+sql_data_source_name = 2+ +sql_fetch_direction :: Num a => a+sql_fetch_direction = 8+ +sql_server_name :: Num a => a+sql_server_name = 13+ +sql_search_pattern_escape :: Num a => a+sql_search_pattern_escape = 14+ +sql_dbms_name :: Num a => a+sql_dbms_name = 17+ +sql_dbms_ver :: Num a => a+sql_dbms_ver = 18+ +sql_accessible_tables :: Num a => a+sql_accessible_tables = 19+ +sql_cursor_commit_behavior :: Num a => a+sql_cursor_commit_behavior = 23+ +sql_data_source_read_only :: Num a => a+sql_data_source_read_only = 25+ +sql_default_txn_isolation :: Num a => a+sql_default_txn_isolation = 26+ +sql_identifier_case :: Num a => a+sql_identifier_case = 28+ +sql_identifier_quote_char :: Num a => a+sql_identifier_quote_char = 29+ +sql_max_column_name_len :: Num a => a+sql_max_column_name_len = 30+ +sql_max_cursor_name_len :: Num a => a+sql_max_cursor_name_len = 31+ +sql_max_schema_name_len :: Num a => a+sql_max_schema_name_len = 32+ +sql_max_catalog_name_len :: Num a => a+sql_max_catalog_name_len = 34+ +sql_max_table_name_len :: Num a => a+sql_max_table_name_len = 35+ +sql_scroll_concurrency :: Num a => a+sql_scroll_concurrency = 43+ +sql_txn_capable :: Num a => a+sql_txn_capable = 46+ +sql_user_name :: Num a => a+sql_user_name = 47+ +sql_txn_isolation_option :: Num a => a+sql_txn_isolation_option = 72++sql_integrity :: Num a => a+sql_integrity = 73++sql_getdata_extensions :: Num a => a+sql_getdata_extensions = 81++sql_null_collation :: Num a => a+sql_null_collation = 85++sql_alter_table :: Num a => a+sql_alter_table = 86++sql_order_by_columns_in_select :: Num a => a+sql_order_by_columns_in_select = 90++sql_special_characters :: Num a => a+sql_special_characters = 94++sql_max_columns_in_group_by :: Num a => a+sql_max_columns_in_group_by = 97++sql_max_columns_in_index :: Num a => a+sql_max_columns_in_index = 98++sql_max_columns_in_order_by :: Num a => a+sql_max_columns_in_order_by = 99++sql_max_columns_in_select :: Num a => a+sql_max_columns_in_select = 100++sql_max_columns_in_table :: Num a => a+sql_max_columns_in_table = 101++sql_max_index_size :: Num a => a+sql_max_index_size = 102++sql_max_row_size :: Num a => a+sql_max_row_size = 104++sql_max_statement_len :: Num a => a+sql_max_statement_len = 105++sql_max_tables_in_select :: Num a => a+sql_max_tables_in_select = 106++sql_max_user_name_len :: Num a => a+sql_max_user_name_len = 107++sql_oj_capabilities :: Num a => a+sql_oj_capabilities = 115++sql_xopen_cli_year :: Num a => a+sql_xopen_cli_year = 10000++sql_cursor_sensitivity :: Num a => a+sql_cursor_sensitivity = 10001++sql_describe_parameter :: Num a => a+sql_describe_parameter = 10002++sql_catalog_name :: Num a => a+sql_catalog_name = 10003++sql_collation_seq :: Num a => a+sql_collation_seq = 10004++sql_max_identifier_len :: Num a => a+sql_max_identifier_len = 10005+++-- SQL_ALTER_TABLE bitmasks+sql_at_add_column :: CLong+sql_at_add_column = 0x01++sql_at_drop_column :: CLong+sql_at_drop_column = 0x02++sql_at_alter_column :: CLong+sql_at_alter_column = 0x04++sql_at_add_constraint :: CLong+sql_at_add_constraint = 0x08++sql_at_drop_constraint :: CLong+sql_at_drop_constraint = 0x10++-- SQL_CURSOR_COMMIT_BEHAVIOR values+sql_cb_delete :: Num a => a+sql_cb_delete = 0++sql_cb_close :: Num a => a+sql_cb_close = 1++sql_cb_preserve :: Num a => a+sql_cb_preserve = 2++-- SQL_FETCH_DIRECTION bitmasks+sql_fd_fetch_next :: CLong+sql_fd_fetch_next = 0x01++sql_fd_fetch_first :: CLong+sql_fd_fetch_first = 0x02++sql_fd_fetch_last :: CLong+sql_fd_fetch_last = 0x04++sql_fd_fetch_prior :: CLong+sql_fd_fetch_prior = 0x08++sql_fd_fetch_absolute :: CLong+sql_fd_fetch_absolute = 0x10++sql_fd_fetch_relative :: CLong+sql_fd_fetch_relative = 0x20++-- SQL_GETDATA_EXTENSIONS bitmasks+sql_gd_any_column :: CLong+sql_gd_any_column = 0x01++sql_gd_any_order :: CLong+sql_gd_any_order = 0x02++-- SQL_IDENTIFIER_CASE values+sql_ic_upper :: Num a => a+sql_ic_upper = 1++sql_ic_lower :: Num a => a+sql_ic_lower = 2++sql_ic_sensitive :: Num a => a+sql_ic_sensitive = 3++sql_ic_mixed :: Num a => a+sql_ic_mixed = 4+++-- SQL_OJ_CAPABILITIES bitmasks+sql_oj_left :: CLong+sql_oj_left = 0x01++sql_oj_right :: CLong+sql_oj_right = 0x02++sql_oj_full :: CLong+sql_oj_full = 0x04++sql_oj_nested :: CLong+sql_oj_nested = 0x08++sql_oj_not_ordered :: CLong+sql_oj_not_ordered = 0x10++sql_oj_inner :: CLong+sql_oj_inner = 0x20++sql_oj_all_comparison_ops :: CLong+sql_oj_all_comparison_ops = 0x40+++-- SQL_SCROLL_CONCURRENCY bitmasks+sql_scco_read_only :: CLong+sql_scco_read_only = 0x01++sql_scco_lock :: CLong+sql_scco_lock = 0x02++sql_scco_opt_rowver :: CLong+sql_scco_opt_rowver = 0x04++sql_scco_opt_values :: CLong+sql_scco_opt_values = 0x08++-- SQL_TXN_CAPABLE values+sql_tc_none :: Num a => a+sql_tc_none = 0++sql_tc_dml :: Num a => a+sql_tc_dml = 1++sql_tc_all :: Num a => a+sql_tc_all = 2++sql_tc_ddl_commit :: Num a => a+sql_tc_ddl_commit = 3++sql_tc_ddl_ignore :: Num a => a+sql_tc_ddl_ignore = 4++-- SQL_TXN_ISOLATION_OPTION bitmasks+sql_txn_read_uncommitted :: CLong+sql_txn_read_uncommitted = 0x01++sql_txn_read_committed :: CLong+sql_txn_read_committed = 0x02++sql_txn_repeatable_read :: CLong+sql_txn_repeatable_read = 0x04++sql_txn_serializable :: CLong+sql_txn_serializable = 0x08++foreign import ccall "SQLAllocConnect" sqlallocconnect :: SQLHENV -> Ptr SQLHDBC -> IO SQLRETURN+foreign import ccall "SQLAllocEnv" sqlallocenv :: Ptr SQLHENV -> IO SQLRETURN+foreign import ccall "SQLAllocHandle" sqlallochandle :: SQLSMALLINT -> SQLINTEGER -> Ptr SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLAllocStmt" sqlallocstmt :: SQLHDBC -> Ptr SQLHSTMT -> IO SQLRETURN+foreign import ccall "SQLBindCol" sqlbindcol :: SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLINTEGER -> Ptr SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLBindParam" sqlbindparam :: SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLSMALLINT -> SQLINTEGER -> SQLSMALLINT -> SQLPOINTER -> Ptr SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLCancel" sqlcancel :: SQLHSTMT -> IO SQLRETURN+foreign import ccall "SQLCloseCursor" sqlclosecursor :: SQLHSTMT -> IO SQLRETURN+foreign import ccall "SQLColAttribute" sqlcolattribute :: SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLSMALLINT -> Ptr SQLSMALLINT -> SQLPOINTER -> IO SQLRETURN+foreign import ccall "SQLColumns" sqlcolumns :: SQLHSTMT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLConnect" sqlconnect :: SQLHDBC -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLCopyDesc" sqlopydesc :: SQLHDESC -> SQLHDESC -> IO SQLRETURN+foreign import ccall "SQLDataSources" sqldatasources :: SQLHENV -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLDescribeCol" sqldescribecol :: SQLHSTMT -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLINTEGER -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLDisconnect" sqldisconnect :: SQLHDBC -> IO SQLRETURN+foreign import ccall "SQLEndTran" sqlendtran :: SQLSMALLINT -> SQLINTEGER -> SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLError" sqlerror :: SQLHENV -> SQLHDBC -> SQLHSTMT -> Ptr SQLCHAR -> Ptr SQLINTEGER -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLExecDirect" sqlexecdirect :: SQLHSTMT -> Ptr SQLCHAR -> SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLExecute" sqexecute :: SQLHSTMT -> IO SQLRETURN+foreign import ccall "SQLFetch" sqlfetch :: SQLHSTMT -> IO SQLRETURN+foreign import ccall "SQLFetchScroll" sqlfetchscroll :: SQLHSTMT -> SQLSMALLINT -> SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLFreeConnect" sqlfreeconnect :: SQLHDBC -> IO SQLRETURN+foreign import ccall "SQLFreeEnv" sqlfreeenv :: SQLHENV -> IO SQLRETURN+foreign import ccall "SQLFreeHandle" sqlfreehandle :: SQLSMALLINT -> SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLFreeStmt" sqlfreestmt :: SQLHSTMT -> SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLGetConnectAttr" sqlgetconnectattr :: SQLHDBC -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> Ptr SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLGetConnectOption" sqlgetconnectoption :: SQLHDBC -> SQLSMALLINT -> SQLPOINTER -> IO SQLRETURN+foreign import ccall "SQLGetCursorName" sqlgetcursorname :: SQLHSTMT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLGetData" sqlgetdata :: SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLINTEGER -> Ptr SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLGetDescField" sqlgetdescfield :: SQLHDESC -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLINTEGER -> Ptr SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLGetDescRec" sqlgetdescrec :: SQLHDESC -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLINTEGER -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLGetDiagField" sqlgetdiagfield :: SQLSMALLINT -> SQLINTEGER -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLGetDiagRec" sqlgetdiagrec :: SQLSMALLINT -> SQLINTEGER -> SQLSMALLINT -> Ptr SQLCHAR -> Ptr SQLINTEGER -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLGetEnvAttr" sqlgetenvattr :: SQLHENV -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> Ptr SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLGetFunctions" sqlgetfunctions :: SQLHDBC -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLGetInfo" sqlgetinfo :: SQLHDBC -> SQLSMALLINT -> SQLPOINTER -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLGetStmtAttr" sqlgetstmtattr :: SQLHSTMT -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> Ptr SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLGetStmtOption" sqlgetstmtoption :: SQLHSTMT -> SQLSMALLINT -> SQLPOINTER -> IO SQLRETURN+foreign import ccall "SQLGetTypeInfo" sqlgettypeinfo :: SQLHSTMT -> SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLNumResultCols" sqlnumresultcols :: SQLHSTMT -> Ptr SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLParamData" sqlparamdata :: SQLHSTMT -> SQLPOINTER -> IO SQLRETURN+foreign import ccall "SQLPrepare" sqlprepare :: SQLHSTMT -> Ptr SQLCHAR -> SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLPutData" sqlputdata :: SQLHSTMT -> SQLPOINTER -> SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLRowCount" sqlrowcount :: SQLHSTMT -> Ptr SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLSetConnectAttr" sqlsetconnectattr :: SQLHDBC -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLSetConnectOption" sqlsetconnectoption :: SQLHDBC -> SQLSMALLINT -> SQLPOINTER -> IO SQLRETURN+foreign import ccall "SQLSetCursorName" sqlsetcursorname :: SQLHSTMT -> Ptr SQLCHAR -> SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLSetDescField" sqlsetdescfield :: SQLHDESC -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLSetDescRec" sqlsetdescrec :: SQLHDESC -> SQLSMALLINT -> SQLSMALLINT -> SQLSMALLINT -> SQLINTEGER -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> Ptr SQLINTEGER -> Ptr SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLSetEnvAttr" sqlsetenvattr :: SQLHENV -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> IO SQLRETURN++-- sqlsetparam is another name for sqlbindparam+foreign import ccall "SQLBindParam" sqlsetparam :: SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLSMALLINT -> SQLINTEGER -> SQLSMALLINT -> SQLPOINTER -> Ptr SQLINTEGER -> IO SQLRETURN++foreign import ccall "SQLSetStmtAttr" sqlsetstmtattr :: SQLHSTMT -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> IO SQLRETURN+foreign import ccall "SQLSetStmtOption" sqlsetstmtoption :: SQLHSTMT -> SQLSMALLINT -> SQLPOINTER -> IO SQLRETURN+foreign import ccall "SQLSpecialColumns" sqlspecialcolumns :: SQLHSTMT -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> SQLSMALLINT -> SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLStatistics" sqlstatistics :: SQLHSTMT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> SQLSMALLINT -> SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLTables" sqltables :: SQLHSTMT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> Ptr SQLCHAR -> SQLSMALLINT -> IO SQLRETURN+foreign import ccall "SQLTransact" sqltransact :: SQLHENV -> SQLHDBC -> SQLSMALLINT -> IO SQLRETURN
+ src/SQL/CLI/Utils.hs view
@@ -0,0 +1,760 @@+-- Provides a more convenient way to use SQLCLI API from Haskell +module SQL.CLI.Utils where + +import Prelude hiding (fail) + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Fail (MonadFail, fail) + +import System.IO (hPutStrLn, stderr) + +import Foreign.C.String (withCStringLen, peekCString, peekCStringLen, CStringLen, CString) +import Foreign.Marshal.Alloc (alloca, allocaBytes) +import Foreign.Storable (Storable, peek, peekElemOff, sizeOf) +import Foreign.Ptr (nullPtr, castPtr, Ptr) + +import Data.Maybe (catMaybes, maybe) + +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, + sqlbindcol, + sqlfetch, + sqlgetdata, + sqltables, + sqlcolumns, + sql_handle_env, + sql_handle_dbc, + sql_handle_stmt, + 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_no_nulls, + SQLSMALLINT, + SQLINTEGER, + SQLHENV, + SQLHDBC, + SQLHSTMT, + SQLPOINTER) + +-- | 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 Show + +-- | Read columns information for a given table on a database connection. It returns a 'ReaderT' value +-- that will get implementation dependent fieled numbers in the result set returned by Columns API call +-- from a 'SQLConfig' value. +collectColumnsInfo :: (MonadIO m, MonadFail m) => SQLHDBC -> String -> ReaderT SQLConfig m [ColumnInfo] +collectColumnsInfo hdbc tableName = do + hstmt <- allocHandle sql_handle_stmt hdbc + columns hstmt Nothing Nothing (Just tableName) Nothing + liftIO $ hPutStrLn stderr "Fetching columns info..." + + 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) + return (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 + + forAllRecords hstmt readColumnInfo []))))))))))))))))))))))))))) + liftIO $ freeHandle sql_handle_stmt hstmt + maybe (fail "collectColumnsInfo failed") return cols + + + +-- | Checks if a table exists on the current connection. +tableExists :: (MonadIO m, MonadFail m) => SQLHDBC -> String -> m Bool +tableExists hdbc tableName = do + tables_stmt <- allocHandle sql_handle_stmt hdbc + tables tables_stmt Nothing Nothing (Just tableName) Nothing + exists <- fetch tables_stmt + liftIO $ freeHandle sql_handle_stmt tables_stmt + return exists + + +-- SQLCLI wrappers + +-- | concise information about a column of a result set, mapping +-- the result of SQL CLI API call DescribeCol +data ConciseColInfo = ConciseColInfo { + cci_ColumnName :: String, + cci_DataType :: SQLSMALLINT, + cci_ColumnSize :: SQLINTEGER, + cci_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 + hPutStrLn stderr "More information returned by DescribeCol" + displayDiagInfo sql_handle_stmt hstmt + readInfo + | x == sql_error -> do + hPutStrLn stderr "Error calling DescribeCol" + displayDiagInfo sql_handle_stmt hstmt + return Nothing + | x == sql_invalid_handle -> do + hPutStrLn stderr "Invalid handle calling DescribeCol" + return Nothing + | otherwise -> do + hPutStrLn stderr $ "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 + + +-- | 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 $ hPutStrLn stderr "Error calling Columns" + liftIO $ displayDiagInfo sql_handle_stmt hstmt + fail "Columns failed" + | x == sql_success_with_info -> do + liftIO $ hPutStrLn stderr "Columns returned more info" + liftIO $ displayDiagInfo sql_handle_stmt hstmt + | x == sql_invalid_handle -> do + liftIO $ hPutStrLn stderr "Invalid statement handle passed to Columns call" + fail "Columns failed" + | otherwise -> do + liftIO $ hPutStrLn stderr "Unexpected return code returned by call to Columns. Trying to display diagnostic info:" + liftIO $ displayDiagInfo sql_handle_stmt hstmt + fail "Columns failed" + +-- | 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 + hPutStrLn stderr "Error calling Tables" + displayDiagInfo sql_handle_stmt hstmt + fail "Tables failed" + | x == sql_success_with_info -> do + liftIO $ do + hPutStrLn stderr "Tables returned more info" + displayDiagInfo sql_handle_stmt hstmt + | x == sql_invalid_handle -> do + liftIO $ hPutStrLn stderr "Invalid handle calling Tables" + fail "Tables failed" + | otherwise -> do + liftIO $ do + hPutStrLn stderr $ "Tables returned unexpected result: " ++ (show x) + displayDiagInfo sql_handle_stmt hstmt + fail "Tables failed" + +-- | applies a function through all the records in a statment, passing an accumulator value and +-- combining the actions returned by the function +forAllRecords :: (MonadIO m, MonadFail m) => SQLHSTMT -> (a -> m a) -> a -> m a +forAllRecords stmt f accum = fetchAndRun stmt (f accum >>= (\ accum' -> forAllRecords stmt f accum')) (return accum) + +-- | Read data from a column and checks the diagnostics, returning a 'True' or 'False' value inside a monadic action. +-- It returns 'True' if more data is available for read, and 'False' otherwise. It fails in 'MaybeT' 'IO' monad if +-- an error occured. It displays the diagnostics on the error on the standard error. +getData :: (MonadIO m, MonadFail m) => SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLINTEGER -> Ptr SQLINTEGER -> m Bool +getData hstmt colNum targetType p_buf bufLen p_lenOrInd = getDataAndRun hstmt colNum targetType p_buf bufLen p_lenOrInd (return True) (return False) + +-- | Read data available in a column of a fetched database record inside a monadic. It fails if +-- 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 -> SQLINTEGER -> Ptr SQLINTEGER -> m a -> m a -> m a +getDataAndRun hstmt colNum targetType p_buf bufLen p_lenOrInd more end = do + result <- liftIO $ sqlgetdata hstmt colNum targetType p_buf bufLen p_lenOrInd + case result of + x | x == sql_success -> end + | x == sql_invalid_handle -> do + liftIO $ hPutStrLn stderr "Invalid handle when calling GetData" + fail "GetData failed" + | x == sql_error -> do + liftIO $ do + hPutStrLn stderr "Error calling GetData" + displayDiagInfo sql_handle_stmt hstmt + fail "GetData failed" + | x == sql_no_data -> do + liftIO $ hPutStrLn stderr "GetData -> no data available" + fail "GetData failed" + | x == sql_success_with_info -> do + liftIO $ do + hPutStrLn stderr "GetData returned more info" + displayDiagInfo sql_handle_stmt hstmt + moreData <- isMoreData + if moreData + then more + else end + | otherwise -> do + liftIO $ do + hPutStrLn stderr $ "GetData returned unexpected result: " ++ (show x) + displayDiagInfo sql_handle_stmt hstmt + fail "GetData failed" + where isMoreData :: (MonadIO m, MonadFail m) => m Bool + isMoreData = do + recs <- getCountOfDiagRecs sql_handle_stmt hstmt + diags <- liftIO $ fmap catMaybes $ sequence [runMaybeT $ getDiagRec sql_handle_stmt hstmt (fromIntegral i) | i <- [1..recs]] + return $ any (\d -> sqlstate d == "01004") diags + +-- | 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 -- more and end -- depending on if there +-- are more records available or if the last record has been fetched. +-- +-- If an error occrus, the monadic action fails, displaying error diagnostics on the standard +-- error. +fetchAndRun :: (MonadIO m, MonadFail m) => SQLHSTMT -> m a -> m a -> m a +fetchAndRun hstmt action end = do + result <- liftIO $ sqlfetch hstmt + case result of + x | x == sql_success -> action + | x == sql_error -> do + liftIO $ do + hPutStrLn stderr "Error fetching record" + displayDiagInfo sql_handle_stmt hstmt + fail "Fetch failed" + | x == sql_invalid_handle -> do + liftIO $ hPutStrLn stderr "Invalid handle when fetching record" + fail "Fetch failed" + | x == sql_no_data -> do + liftIO $ hPutStrLn stderr "All records have been fetched" + end + | x == sql_success_with_info -> do + liftIO $ do + hPutStrLn stderr "More diagnostic info returned for record" + displayDiagInfo sql_handle_stmt hstmt + action + | otherwise -> do + liftIO $ do + hPutStrLn stderr $ "Fetch returned unexepected result: " ++ (show x) + displayDiagInfo sql_handle_stmt hstmt + fail "Fetch failed" + +-- | helper function to bind a SMALLINT column +bindSmallIntCol :: (MonadIO m, MonadFail m) => + SQLHSTMT -- ^ statement handle + -> SQLSMALLINT -- ^ column number (starting with 1) + -> Ptr SQLSMALLINT -- ^ buffer to receive the value + -> Ptr SQLINTEGER -- ^ buffer to receive the indicator or length; it can be null + -> 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 SQLINTEGER -- ^ 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 + -> SQLINTEGER -- ^ buffer length in bytes, including the null terminating character + -> Ptr SQLINTEGER -- ^ pointer to indicator or length; it can be null + -> m () +bindVarcharCol hstmt colNum p_buf buflen p_ind = bindCol hstmt colNum sql_char (castPtr p_buf) buflen p_ind + +-- | wrapper for BindCol SQL CLI API call; if an error occurs +-- the computation is stopped and diagnostics are displayed on the standard error +bindCol :: (MonadIO m, MonadFail m) => SQLHSTMT -> SQLSMALLINT -> SQLSMALLINT -> SQLPOINTER -> SQLINTEGER -> Ptr SQLINTEGER -> m () +bindCol hstmt colNum colType p_buf len_buf p_ind = do + result <- liftIO $ sqlbindcol hstmt colNum colType p_buf len_buf p_ind + case result of + x | x == sql_success -> return () + | x == sql_error -> do + liftIO $ do + hPutStrLn stderr $ "Error binding column " ++ (show colNum) + displayDiagInfo sql_handle_stmt hstmt + fail "Binding column failed" + | x == sql_success_with_info -> do + liftIO $ do + hPutStrLn stderr $ "Binding col " ++ (show colNum) ++ " returned warnings:" + displayDiagInfo sql_handle_stmt hstmt + | x == sql_invalid_handle -> do + liftIO $ hPutStrLn stderr $ "Invalid handle when binding column " ++ (show colNum) + fail "Binding column failed" + | otherwise -> do + liftIO $ do + hPutStrLn stderr $ "Invalid result when binding column " ++ (show colNum) + displayDiagInfo sql_handle_stmt hstmt + fail "Biniding column failed" + +-- | wrapper for SQL CLI ExecDirect API call; if an error occurs, the +-- computation exits displaying diagnostics on the standard error +execDirect :: (MonadIO m, MonadFail m) => SQLHSTMT -> String -> m () +execDirect hstmt sqlstr = do + result <- liftIO $ withCStringLen sqlstr + (\(sql, sqlLen) -> sqlexecdirect hstmt (castPtr sql) (fromIntegral sqlLen)) + case result of + x | x == sql_success -> liftIO $ hPutStrLn stderr "sql statement executed" + | x == sql_success_with_info -> liftIO $ do + hPutStrLn stderr "Execution of sql returned more info" + displayDiagInfo sql_handle_stmt hstmt + | x == sql_error -> do + liftIO $ do + hPutStrLn stderr "Execution of sql returned error" + displayDiagInfo sql_handle_stmt hstmt + fail "execute sql statement failed" + | x == sql_invalid_handle -> do + liftIO $ do + hPutStrLn stderr "Invaild statement handle" + displayDiagInfo sql_handle_stmt hstmt + fail "execute statemnt failed" + | x == sql_need_data -> do + liftIO $ do + hPutStrLn stderr "Unexpected NEED_DATA returned by statement execution" + displayDiagInfo sql_handle_stmt hstmt + fail "exeucute statement failed" + | x == sql_no_data -> do + liftIO $ hPutStrLn stderr "Execution of statement returned no data" + fail "execute statement failed" + | otherwise -> do + liftIO $ do + hPutStrLn stderr $ "Execute statement returned unexpected result: " ++ (show x) + displayDiagInfo sql_handle_stmt hstmt + fail "Execute statement failed" + +-- | 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 $ hPutStrLn stderr $ "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 $ hPutStrLn stderr $ "connect to server " ++ server ++ " returned warnings:" + liftIO $ displayDiagInfo sql_handle_dbc hdbc + return hdbc + | x == sql_error -> do + liftIO $ hPutStrLn stderr $ "connection to server " ++ server ++ " failed:" + liftIO $ displayDiagInfo sql_handle_dbc hdbc + liftIO $ freeHandle sql_handle_dbc hdbc + fail $ "connection to server " ++ server ++ " failed" + | x == sql_invalid_handle -> do + liftIO $ hPutStrLn stderr $ "connection to server " ++ server ++ " failed because of invalid handle" + fail $ "connection to server " ++ server ++ " failed because of invalid handle" + | otherwise -> do + liftIO $ do + hPutStrLn stderr $ "Unexpected response code got from connecting to server " ++ server ++ ": " ++ (show x) + hPutStrLn stderr "Trying to extract diagnostic info:" + displayDiagInfo sql_handle_dbc hdbc + hPutStrLn stderr "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) + +-- | 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 + hPutStrLn stderr "disconnect returned warnings:" + displayDiagInfo sql_handle_dbc hdbc + | x == sql_error -> do + hPutStrLn stderr "disconnect failed:" + displayDiagInfo sql_handle_dbc hdbc + | x == sql_invalid_handle -> do + hPutStrLn stderr "disconnect failed because of invalid handle" + | otherwise -> do + hPutStrLn stderr "Unexpected response code got from Disconnect function" + hPutStrLn stderr "Trying to extract diagnostic info:" + displayDiagInfo sql_handle_dbc hdbc + freeHandle sql_handle_dbc hdbc + +-- | wrapper to SQL CLI AllocHandle API call; it displays diagnostics info +-- on the standard error and fails if the handle could not be allocated +allocHandle :: (MonadIO m, MonadFail m) => SQLSMALLINT -> SQLINTEGER -> m SQLINTEGER +allocHandle handleType handleParent = do + handle <- liftIO $ alloca + (\p_handle -> do + result <- sqlallochandle handleType handleParent p_handle + case result of + x | x == sql_success -> Just <$> peek p_handle + | x == sql_invalid_handle -> do + hPutStrLn stderr "alloc handle failed because of invalid handler" + displayDiagnostic + return Nothing + | x == sql_error -> do + hPutStrLn stderr "alloc handle failed with error" + displayDiagnostic + return Nothing + | otherwise -> do + hPutStrLn stderr $ "alloc handle returned unexpected result" ++ (show x) + displayDiagnostic + return Nothing + where displayDiagnostic = if x == sql_handle_env + then peek p_handle >>= displayDiagInfo x + else displayDiagInfo handleType handleParent) + maybe (fail $ "AllocHandle failed for handle type " ++ (show handleType)) return handle + +-- | wrapper for SQL CLI FreeHandle API call; it displays diagnostics +-- on the standard error; it does not fail +freeHandle :: SQLSMALLINT -> SQLINTEGER -> IO () +freeHandle handleType handle = do + result <- sqlfreehandle handleType handle + case result of + x | x == sql_success -> return () + | x == sql_error -> do + hPutStrLn stderr $ "Error freeing handle of type " ++ (show handleType) + displayDiagInfo handleType handle + | x == sql_invalid_handle -> do + hPutStrLn stderr "FreeHandle failed because of invalid handle" + displayDiagInfo handleType handle + | otherwise -> do + hPutStrLn stderr $ "FreeHandle returned unexpected result " ++ (show x) + hPutStrLn stderr "Trying to get diagnostic info on FreeHandle:" + displayDiagInfo handleType handle + +-- | create an 'IO' action that displays diagnostic records for a given handle on the +-- standard error; this action will not fail +displayDiagInfo :: SQLSMALLINT -> SQLINTEGER -> IO () +displayDiagInfo handleType handle = (runMaybeT $ displayDiagInfo' handleType handle) >> return () + +-- | create a monadic action to display the diagnostic records for a given handle on the +-- standard error; it fails if an error occurs while reading diagnostic records. +displayDiagInfo' :: (MonadIO m, MonadFail m) => SQLSMALLINT -> SQLINTEGER -> m () +displayDiagInfo' handleType handle = do + recs <- getCountOfDiagRecs handleType handle + liftIO $ hPutStrLn stderr $ "there " + ++ (if recs /= 1 then "are " else "is ") + ++ (show recs) ++ " diagnostic record" + ++ (if recs /= 1 then "s" else "") + let diags = [showDiag $ fromIntegral i | i <- [1..recs]] + showDiag i = do + liftIO $ hPutStrLn stderr $ "Diagnostic record " ++ (show i) + r <- getDiagRec handleType handle i + liftIO $ hPutStrLn stderr $ (show i) ++ ": " ++ (sqlstate r) ++ " - " ++ (show $ nativeError r) ++ " - " ++ (messageText r) + in sequence_ diags + +-- | create a monadic action to read the number of the diagnostic records for a given handle; +-- it fails if an error occurs and it displays diagnostics on standard error +getCountOfDiagRecs :: (MonadIO m, MonadFail m) => SQLSMALLINT -> SQLINTEGER -> m Int +getCountOfDiagRecs handleType handle = do + recs <- liftIO $ alloca + (\ptrRecs -> do + result <- sqlgetdiagfield handleType handle 0 sql_diag_number (castPtr ptrRecs) 0 nullPtr + case result of + x | x == sql_success -> Just <$> peek ptrRecs + | x == sql_invalid_handle -> do + hPutStrLn stderr "Count of diagnostic records could not be retrieved due to an invalid handle" + return Nothing + | x == sql_error -> do + hPutStrLn stderr "Count of diagnostic records could not be retrieved because wrong arguments were passed to GetDiagField function" + return Nothing + | x == sql_no_data -> do + hPutStrLn stderr "No diagnostic data available" + return $ Just 0 + | otherwise -> do + hPutStrLn stderr $ "Getting the number of diagnostic records returned unexpected return code " ++ (show x) + return Nothing) + maybe (fail "GetDiagField api call failed when reading number of diagnostic errors") return recs + +-- | information in a diagnostic record +data DiagRecord = DiagRecord { + 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 -> SQLINTEGER -> 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 l_sqlstate l_nativeErr l_messageText + | x == sql_error -> do + hPutStrLn stderr $ (show recnum) ++ ": Diagnostic information could not be retrieved becuase wrong arguments passed to GetDagRec function" + return Nothing + | x == sql_invalid_handle -> do + hPutStrLn stderr $ (show recnum) ++ ": Diagnosic information could not be retrieved because of wrong handler" + return Nothing + | x == sql_no_data -> do + hPutStrLn stderr $ (show recnum) ++ ": No diagnostic data available" + return Nothing + | otherwise -> do + hPutStrLn stderr $ (show recnum) ++ ": Getting diagnostic information returned unexpected error code " ++ (show x) + return Nothing)))) + maybe (fail "GetDiagRec call failed") return diagrecord + +-- | 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 SQLINTEGER -> IO (Maybe a) +peekMaybeCol p_col p_ind = do + ind <- peek p_ind + if ind == sql_null_data + then return Nothing + else Just <$> peek p_col + +-- | helper function to read a nullable text column; returns Nothing if the +-- column is null +peekMaybeTextCol :: CString -> Ptr SQLINTEGER -> 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