diff --git a/Database/HDBC/PostgreSQL.hs b/Database/HDBC/PostgreSQL.hs --- a/Database/HDBC/PostgreSQL.hs +++ b/Database/HDBC/PostgreSQL.hs @@ -62,9 +62,16 @@ module Database.HDBC.PostgreSQL ( - connectPostgreSQL, Connection + -- * Connecting to Databases + connectPostgreSQL, Connection, + -- * PostgreSQL Error Codes + -- + -- |When an @SqlError@ is thrown, the field @seState@ is set to one of the following + -- error codes. + module Database.HDBC.PostgreSQL.ErrorCodes, ) where import Database.HDBC.PostgreSQL.Connection(connectPostgreSQL, Connection()) +import Database.HDBC.PostgreSQL.ErrorCodes diff --git a/Database/HDBC/PostgreSQL/Connection.hsc b/Database/HDBC/PostgreSQL/Connection.hsc --- a/Database/HDBC/PostgreSQL/Connection.hsc +++ b/Database/HDBC/PostgreSQL/Connection.hsc @@ -72,6 +72,7 @@ Impl.disconnect = fdisconnect conn children, Impl.commit = fcommit conn children, Impl.rollback = frollback conn children, + Impl.runRaw = frunRaw conn children, Impl.run = frun conn children, Impl.prepare = newSth conn children, Impl.clone = connectPostgreSQL args, @@ -92,6 +93,13 @@ begin_transaction :: Conn -> ChildList -> IO () begin_transaction o children = frun o children "BEGIN" [] >> return () + +frunRaw :: Conn -> ChildList -> String -> IO () +frunRaw o children query = + do sth <- newSth o children query + executeRaw sth + finish sth + return () frun :: Conn -> ChildList -> String -> [SqlValue] -> IO Integer frun o children query args = diff --git a/Database/HDBC/PostgreSQL/ConnectionImpl.hs b/Database/HDBC/PostgreSQL/ConnectionImpl.hs --- a/Database/HDBC/PostgreSQL/ConnectionImpl.hs +++ b/Database/HDBC/PostgreSQL/ConnectionImpl.hs @@ -26,6 +26,7 @@ disconnect :: IO (), commit :: IO (), rollback :: IO (), + runRaw :: String -> IO (), run :: String -> [Types.SqlValue] -> IO Integer, prepare :: String -> IO Types.Statement, clone :: IO Connection, @@ -43,6 +44,7 @@ disconnect = disconnect commit = commit rollback = rollback + runRaw = runRaw run = run prepare = prepare clone = clone diff --git a/Database/HDBC/PostgreSQL/ErrorCodes.hs b/Database/HDBC/PostgreSQL/ErrorCodes.hs new file mode 100644 --- /dev/null +++ b/Database/HDBC/PostgreSQL/ErrorCodes.hs @@ -0,0 +1,820 @@ +-- Generated from "/usr/include/postgresql/utils/errcodes.h" (PostgreSQL 8.3). +-- +-- The following vim regexp substitutions map "errorcodes.h" to this file: +-- +-- " remove all comments +-- :%s/\v\/\*\_.{-}\*\/ +-- +-- " remove empty lines +-- :%s/^\s*\n/ +-- +-- " #defines -> functions +-- :%s/\v#define ERRCODE_(\S*)\t*/\L\1 = / +-- +-- " expand MAKE_SQLSTATE macro +-- :%s/\vMAKE_SQLSTATE\('(.)',\s*'(.)',\s*'(.)',\s*'(.)',\s*'(.)'\)/"\1\2\3\4\5"/ +-- +-- " aliases +-- :%s/\vERRCODE_(\S*)/\L\1/ +-- +-- " type signatures +-- :%s/\v^(\S*)/\r\1 :: String\r\1/ +-- +-- " to mixedCase +-- :%s/\v_(\l)/\u\1/g +-- +-- " got ride of additional whitespace +-- :%s/\s+=\s+/ = / +-- +-- " Documentation +-- :%s/\v(\a+) :: String\n\1 \= "(.*)"/-- |Is set to @\\"\2\\"@.\r\0 +-- +-- " Documentation for aliases +-- :%s/\v(\a+) :: String\n\1 \= (\a+)/-- |Same as '\2'.\r\0 +-- + +module Database.HDBC.PostgreSQL.ErrorCodes where + +-- |Is set to @\"00000\"@. +successfulCompletion :: String +successfulCompletion = "00000" + +-- |Is set to @\"01000\"@. +warning :: String +warning = "01000" + +-- |Is set to @\"0100C\"@. +warningDynamicResultSetsReturned :: String +warningDynamicResultSetsReturned = "0100C" + +-- |Is set to @\"01008\"@. +warningImplicitZeroBitPadding :: String +warningImplicitZeroBitPadding = "01008" + +-- |Is set to @\"01003\"@. +warningNullValueEliminatedInSetFunction :: String +warningNullValueEliminatedInSetFunction = "01003" + +-- |Is set to @\"01007\"@. +warningPrivilegeNotGranted :: String +warningPrivilegeNotGranted = "01007" + +-- |Is set to @\"01006\"@. +warningPrivilegeNotRevoked :: String +warningPrivilegeNotRevoked = "01006" + +-- |Is set to @\"01004\"@. +warningStringDataRightTruncation :: String +warningStringDataRightTruncation = "01004" + +-- |Is set to @\"01P01\"@. +warningDeprecatedFeature :: String +warningDeprecatedFeature = "01P01" + +-- |Is set to @\"02000\"@. +noData :: String +noData = "02000" + +-- |Is set to @\"02001\"@. +noAdditionalDynamicResultSetsReturned :: String +noAdditionalDynamicResultSetsReturned = "02001" + +-- |Is set to @\"03000\"@. +sqlStatementNotYetComplete :: String +sqlStatementNotYetComplete = "03000" + +-- |Is set to @\"08000\"@. +connectionException :: String +connectionException = "08000" + +-- |Is set to @\"08003\"@. +connectionDoesNotExist :: String +connectionDoesNotExist = "08003" + +-- |Is set to @\"08006\"@. +connectionFailure :: String +connectionFailure = "08006" + +-- |Is set to @\"08001\"@. +sqlclientUnableToEstablishSqlconnection :: String +sqlclientUnableToEstablishSqlconnection = "08001" + +-- |Is set to @\"08004\"@. +sqlserverRejectedEstablishmentOfSqlconnection :: String +sqlserverRejectedEstablishmentOfSqlconnection = "08004" + +-- |Is set to @\"08007\"@. +transactionResolutionUnknown :: String +transactionResolutionUnknown = "08007" + +-- |Is set to @\"08P01\"@. +protocolViolation :: String +protocolViolation = "08P01" + +-- |Is set to @\"09000\"@. +triggeredActionException :: String +triggeredActionException = "09000" + +-- |Is set to @\"0A000\"@. +featureNotSupported :: String +featureNotSupported = "0A000" + +-- |Is set to @\"0B000\"@. +invalidTransactionInitiation :: String +invalidTransactionInitiation = "0B000" + +-- |Is set to @\"0F000\"@. +locatorException :: String +locatorException = "0F000" + +-- |Is set to @\"0F001\"@. +lEInvalidSpecification :: String +lEInvalidSpecification = "0F001" + +-- |Is set to @\"0L000\"@. +invalidGrantor :: String +invalidGrantor = "0L000" + +-- |Is set to @\"0LP01\"@. +invalidGrantOperation :: String +invalidGrantOperation = "0LP01" + +-- |Is set to @\"0P000\"@. +invalidRoleSpecification :: String +invalidRoleSpecification = "0P000" + +-- |Is set to @\"21000\"@. +cardinalityViolation :: String +cardinalityViolation = "21000" + +-- |Is set to @\"22000\"@. +dataException :: String +dataException = "22000" + +-- |Is set to @\"2202E\"@. +arrayElementError :: String +arrayElementError = "2202E" + +-- |Same as 'arrayElementError'. +arraySubscriptError :: String +arraySubscriptError = arrayElementError + +-- |Is set to @\"22021\"@. +characterNotInRepertoire :: String +characterNotInRepertoire = "22021" + +-- |Is set to @\"22008\"@. +datetimeFieldOverflow :: String +datetimeFieldOverflow = "22008" + +-- |Same as 'datetimeFieldOverflow'. +datetimeValueOutOfRange :: String +datetimeValueOutOfRange = datetimeFieldOverflow + +-- |Is set to @\"22012\"@. +divisionByZero :: String +divisionByZero = "22012" + +-- |Is set to @\"22005\"@. +errorInAssignment :: String +errorInAssignment = "22005" + +-- |Is set to @\"2200B\"@. +escapeCharacterConflict :: String +escapeCharacterConflict = "2200B" + +-- |Is set to @\"22022\"@. +indicatorOverflow :: String +indicatorOverflow = "22022" + +-- |Is set to @\"22015\"@. +intervalFieldOverflow :: String +intervalFieldOverflow = "22015" + +-- |Is set to @\"2201E\"@. +invalidArgumentForLog :: String +invalidArgumentForLog = "2201E" + +-- |Is set to @\"2201F\"@. +invalidArgumentForPowerFunction :: String +invalidArgumentForPowerFunction = "2201F" + +-- |Is set to @\"2201G\"@. +invalidArgumentForWidthBucketFunction :: String +invalidArgumentForWidthBucketFunction = "2201G" + +-- |Is set to @\"22018\"@. +invalidCharacterValueForCast :: String +invalidCharacterValueForCast = "22018" + +-- |Is set to @\"22007\"@. +invalidDatetimeFormat :: String +invalidDatetimeFormat = "22007" + +-- |Is set to @\"22019\"@. +invalidEscapeCharacter :: String +invalidEscapeCharacter = "22019" + +-- |Is set to @\"2200D\"@. +invalidEscapeOctet :: String +invalidEscapeOctet = "2200D" + +-- |Is set to @\"22025\"@. +invalidEscapeSequence :: String +invalidEscapeSequence = "22025" + +-- |Is set to @\"22P06\"@. +nonstandardUseOfEscapeCharacter :: String +nonstandardUseOfEscapeCharacter = "22P06" + +-- |Is set to @\"22010\"@. +invalidIndicatorParameterValue :: String +invalidIndicatorParameterValue = "22010" + +-- |Is set to @\"22020\"@. +invalidLimitValue :: String +invalidLimitValue = "22020" + +-- |Is set to @\"22023\"@. +invalidParameterValue :: String +invalidParameterValue = "22023" + +-- |Is set to @\"2201B\"@. +invalidRegularExpression :: String +invalidRegularExpression = "2201B" + +-- |Is set to @\"22009\"@. +invalidTimeZoneDisplacementValue :: String +invalidTimeZoneDisplacementValue = "22009" + +-- |Is set to @\"2200C\"@. +invalidUseOfEscapeCharacter :: String +invalidUseOfEscapeCharacter = "2200C" + +-- |Is set to @\"2200G\"@. +mostSpecificTypeMismatch :: String +mostSpecificTypeMismatch = "2200G" + +-- |Is set to @\"22004\"@. +nullValueNotAllowed :: String +nullValueNotAllowed = "22004" + +-- |Is set to @\"22002\"@. +nullValueNoIndicatorParameter :: String +nullValueNoIndicatorParameter = "22002" + +-- |Is set to @\"22003\"@. +numericValueOutOfRange :: String +numericValueOutOfRange = "22003" + +-- |Is set to @\"22026\"@. +stringDataLengthMismatch :: String +stringDataLengthMismatch = "22026" + +-- |Is set to @\"22001\"@. +stringDataRightTruncation :: String +stringDataRightTruncation = "22001" + +-- |Is set to @\"22011\"@. +substringError :: String +substringError = "22011" + +-- |Is set to @\"22027\"@. +trimError :: String +trimError = "22027" + +-- |Is set to @\"22024\"@. +unterminatedCString :: String +unterminatedCString = "22024" + +-- |Is set to @\"2200F\"@. +zeroLengthCharacterString :: String +zeroLengthCharacterString = "2200F" + +-- |Is set to @\"22P01\"@. +floatingPointException :: String +floatingPointException = "22P01" + +-- |Is set to @\"22P02\"@. +invalidTextRepresentation :: String +invalidTextRepresentation = "22P02" + +-- |Is set to @\"22P03\"@. +invalidBinaryRepresentation :: String +invalidBinaryRepresentation = "22P03" + +-- |Is set to @\"22P04\"@. +badCopyFileFormat :: String +badCopyFileFormat = "22P04" + +-- |Is set to @\"22P05\"@. +untranslatableCharacter :: String +untranslatableCharacter = "22P05" + +-- |Is set to @\"2200L\"@. +notAnXmlDocument :: String +notAnXmlDocument = "2200L" + +-- |Is set to @\"2200M\"@. +invalidXmlDocument :: String +invalidXmlDocument = "2200M" + +-- |Is set to @\"2200N\"@. +invalidXmlContent :: String +invalidXmlContent = "2200N" + +-- |Is set to @\"2200S\"@. +invalidXmlComment :: String +invalidXmlComment = "2200S" + +-- |Is set to @\"2200T\"@. +invalidXmlProcessingInstruction :: String +invalidXmlProcessingInstruction = "2200T" + +-- |Is set to @\"23000\"@. +integrityConstraintViolation :: String +integrityConstraintViolation = "23000" + +-- |Is set to @\"23001\"@. +restrictViolation :: String +restrictViolation = "23001" + +-- |Is set to @\"23502\"@. +notNullViolation :: String +notNullViolation = "23502" + +-- |Is set to @\"23503\"@. +foreignKeyViolation :: String +foreignKeyViolation = "23503" + +-- |Is set to @\"23505\"@. +uniqueViolation :: String +uniqueViolation = "23505" + +-- |Is set to @\"23514\"@. +checkViolation :: String +checkViolation = "23514" + +-- |Is set to @\"24000\"@. +invalidCursorState :: String +invalidCursorState = "24000" + +-- |Is set to @\"25000\"@. +invalidTransactionState :: String +invalidTransactionState = "25000" + +-- |Is set to @\"25001\"@. +activeSqlTransaction :: String +activeSqlTransaction = "25001" + +-- |Is set to @\"25002\"@. +branchTransactionAlreadyActive :: String +branchTransactionAlreadyActive = "25002" + +-- |Is set to @\"25008\"@. +heldCursorRequiresSameIsolationLevel :: String +heldCursorRequiresSameIsolationLevel = "25008" + +-- |Is set to @\"25003\"@. +inappropriateAccessModeForBranchTransaction :: String +inappropriateAccessModeForBranchTransaction = "25003" + +-- |Is set to @\"25004\"@. +inappropriateIsolationLevelForBranchTransaction :: String +inappropriateIsolationLevelForBranchTransaction = "25004" + +-- |Is set to @\"25005\"@. +noActiveSqlTransactionForBranchTransaction :: String +noActiveSqlTransactionForBranchTransaction = "25005" + +-- |Is set to @\"25006\"@. +readOnlySqlTransaction :: String +readOnlySqlTransaction = "25006" + +-- |Is set to @\"25007\"@. +schemaAndDataStatementMixingNotSupported :: String +schemaAndDataStatementMixingNotSupported = "25007" + +-- |Is set to @\"25P01\"@. +noActiveSqlTransaction :: String +noActiveSqlTransaction = "25P01" + +-- |Is set to @\"25P02\"@. +inFailedSqlTransaction :: String +inFailedSqlTransaction = "25P02" + +-- |Is set to @\"26000\"@. +invalidSqlStatementName :: String +invalidSqlStatementName = "26000" + +-- |Is set to @\"27000\"@. +triggeredDataChangeViolation :: String +triggeredDataChangeViolation = "27000" + +-- |Is set to @\"28000\"@. +invalidAuthorizationSpecification :: String +invalidAuthorizationSpecification = "28000" + +-- |Is set to @\"2B000\"@. +dependentPrivilegeDescriptorsStillExist :: String +dependentPrivilegeDescriptorsStillExist = "2B000" + +-- |Is set to @\"2BP01\"@. +dependentObjectsStillExist :: String +dependentObjectsStillExist = "2BP01" + +-- |Is set to @\"2D000\"@. +invalidTransactionTermination :: String +invalidTransactionTermination = "2D000" + +-- |Is set to @\"2F000\"@. +sqlRoutineException :: String +sqlRoutineException = "2F000" + +-- |Is set to @\"2F005\"@. +sREFunctionExecutedNoReturnStatement :: String +sREFunctionExecutedNoReturnStatement = "2F005" + +-- |Is set to @\"2F002\"@. +sREModifyingSqlDataNotPermitted :: String +sREModifyingSqlDataNotPermitted = "2F002" + +-- |Is set to @\"2F003\"@. +sREProhibitedSqlStatementAttempted :: String +sREProhibitedSqlStatementAttempted = "2F003" + +-- |Is set to @\"2F004\"@. +sREReadingSqlDataNotPermitted :: String +sREReadingSqlDataNotPermitted = "2F004" + +-- |Is set to @\"34000\"@. +invalidCursorName :: String +invalidCursorName = "34000" + +-- |Is set to @\"38000\"@. +externalRoutineException :: String +externalRoutineException = "38000" + +-- |Is set to @\"38001\"@. +eREContainingSqlNotPermitted :: String +eREContainingSqlNotPermitted = "38001" + +-- |Is set to @\"38002\"@. +eREModifyingSqlDataNotPermitted :: String +eREModifyingSqlDataNotPermitted = "38002" + +-- |Is set to @\"38003\"@. +eREProhibitedSqlStatementAttempted :: String +eREProhibitedSqlStatementAttempted = "38003" + +-- |Is set to @\"38004\"@. +eREReadingSqlDataNotPermitted :: String +eREReadingSqlDataNotPermitted = "38004" + +-- |Is set to @\"39000\"@. +externalRoutineInvocationException :: String +externalRoutineInvocationException = "39000" + +-- |Is set to @\"39001\"@. +eRIEInvalidSqlstateReturned :: String +eRIEInvalidSqlstateReturned = "39001" + +-- |Is set to @\"39004\"@. +eRIENullValueNotAllowed :: String +eRIENullValueNotAllowed = "39004" + +-- |Is set to @\"39P01\"@. +eRIETriggerProtocolViolated :: String +eRIETriggerProtocolViolated = "39P01" + +-- |Is set to @\"39P02\"@. +eRIESrfProtocolViolated :: String +eRIESrfProtocolViolated = "39P02" + +-- |Is set to @\"3B000\"@. +savepointException :: String +savepointException = "3B000" + +-- |Is set to @\"3B001\"@. +sEInvalidSpecification :: String +sEInvalidSpecification = "3B001" + +-- |Is set to @\"3D000\"@. +invalidCatalogName :: String +invalidCatalogName = "3D000" + +-- |Is set to @\"3F000\"@. +invalidSchemaName :: String +invalidSchemaName = "3F000" + +-- |Is set to @\"40000\"@. +transactionRollback :: String +transactionRollback = "40000" + +-- |Is set to @\"40002\"@. +tRIntegrityConstraintViolation :: String +tRIntegrityConstraintViolation = "40002" + +-- |Is set to @\"40001\"@. +tRSerializationFailure :: String +tRSerializationFailure = "40001" + +-- |Is set to @\"40003\"@. +tRStatementCompletionUnknown :: String +tRStatementCompletionUnknown = "40003" + +-- |Is set to @\"40P01\"@. +tRDeadlockDetected :: String +tRDeadlockDetected = "40P01" + +-- |Is set to @\"42000\"@. +syntaxErrorOrAccessRuleViolation :: String +syntaxErrorOrAccessRuleViolation = "42000" + +-- |Is set to @\"42601\"@. +syntaxError :: String +syntaxError = "42601" + +-- |Is set to @\"42501\"@. +insufficientPrivilege :: String +insufficientPrivilege = "42501" + +-- |Is set to @\"42846\"@. +cannotCoerce :: String +cannotCoerce = "42846" + +-- |Is set to @\"42803\"@. +groupingError :: String +groupingError = "42803" + +-- |Is set to @\"42830\"@. +invalidForeignKey :: String +invalidForeignKey = "42830" + +-- |Is set to @\"42602\"@. +invalidName :: String +invalidName = "42602" + +-- |Is set to @\"42622\"@. +nameTooLong :: String +nameTooLong = "42622" + +-- |Is set to @\"42939\"@. +reservedName :: String +reservedName = "42939" + +-- |Is set to @\"42804\"@. +datatypeMismatch :: String +datatypeMismatch = "42804" + +-- |Is set to @\"42P18\"@. +indeterminateDatatype :: String +indeterminateDatatype = "42P18" + +-- |Is set to @\"42809\"@. +wrongObjectType :: String +wrongObjectType = "42809" + +-- |Is set to @\"42703\"@. +undefinedColumn :: String +undefinedColumn = "42703" + +-- |Same as 'invalidCursorName'. +undefinedCursor :: String +undefinedCursor = invalidCursorName + +-- |Same as 'invalidCatalogName'. +undefinedDatabase :: String +undefinedDatabase = invalidCatalogName + +-- |Is set to @\"42883\"@. +undefinedFunction :: String +undefinedFunction = "42883" + +-- |Same as 'invalidSqlStatementName'. +undefinedPstatement :: String +undefinedPstatement = invalidSqlStatementName + +-- |Same as 'invalidSchemaName'. +undefinedSchema :: String +undefinedSchema = invalidSchemaName + +-- |Is set to @\"42P01\"@. +undefinedTable :: String +undefinedTable = "42P01" + +-- |Is set to @\"42P02\"@. +undefinedParameter :: String +undefinedParameter = "42P02" + +-- |Is set to @\"42704\"@. +undefinedObject :: String +undefinedObject = "42704" + +-- |Is set to @\"42701\"@. +duplicateColumn :: String +duplicateColumn = "42701" + +-- |Is set to @\"42P03\"@. +duplicateCursor :: String +duplicateCursor = "42P03" + +-- |Is set to @\"42P04\"@. +duplicateDatabase :: String +duplicateDatabase = "42P04" + +-- |Is set to @\"42723\"@. +duplicateFunction :: String +duplicateFunction = "42723" + +-- |Is set to @\"42P05\"@. +duplicatePstatement :: String +duplicatePstatement = "42P05" + +-- |Is set to @\"42P06\"@. +duplicateSchema :: String +duplicateSchema = "42P06" + +-- |Is set to @\"42P07\"@. +duplicateTable :: String +duplicateTable = "42P07" + +-- |Is set to @\"42712\"@. +duplicateAlias :: String +duplicateAlias = "42712" + +-- |Is set to @\"42710\"@. +duplicateObject :: String +duplicateObject = "42710" + +-- |Is set to @\"42702\"@. +ambiguousColumn :: String +ambiguousColumn = "42702" + +-- |Is set to @\"42725\"@. +ambiguousFunction :: String +ambiguousFunction = "42725" + +-- |Is set to @\"42P08\"@. +ambiguousParameter :: String +ambiguousParameter = "42P08" + +-- |Is set to @\"42P09\"@. +ambiguousAlias :: String +ambiguousAlias = "42P09" + +-- |Is set to @\"42P10\"@. +invalidColumnReference :: String +invalidColumnReference = "42P10" + +-- |Is set to @\"42611\"@. +invalidColumnDefinition :: String +invalidColumnDefinition = "42611" + +-- |Is set to @\"42P11\"@. +invalidCursorDefinition :: String +invalidCursorDefinition = "42P11" + +-- |Is set to @\"42P12\"@. +invalidDatabaseDefinition :: String +invalidDatabaseDefinition = "42P12" + +-- |Is set to @\"42P13\"@. +invalidFunctionDefinition :: String +invalidFunctionDefinition = "42P13" + +-- |Is set to @\"42P14\"@. +invalidPstatementDefinition :: String +invalidPstatementDefinition = "42P14" + +-- |Is set to @\"42P15\"@. +invalidSchemaDefinition :: String +invalidSchemaDefinition = "42P15" + +-- |Is set to @\"42P16\"@. +invalidTableDefinition :: String +invalidTableDefinition = "42P16" + +-- |Is set to @\"42P17\"@. +invalidObjectDefinition :: String +invalidObjectDefinition = "42P17" + +-- |Is set to @\"44000\"@. +withCheckOptionViolation :: String +withCheckOptionViolation = "44000" + +-- |Is set to @\"53000\"@. +insufficientResources :: String +insufficientResources = "53000" + +-- |Is set to @\"53100\"@. +diskFull :: String +diskFull = "53100" + +-- |Is set to @\"53200\"@. +outOfMemory :: String +outOfMemory = "53200" + +-- |Is set to @\"53300\"@. +tooManyConnections :: String +tooManyConnections = "53300" + +-- |Is set to @\"54000\"@. +programLimitExceeded :: String +programLimitExceeded = "54000" + +-- |Is set to @\"54001\"@. +statementTooComplex :: String +statementTooComplex = "54001" + +-- |Is set to @\"54011\"@. +tooManyColumns :: String +tooManyColumns = "54011" + +-- |Is set to @\"54023\"@. +tooManyArguments :: String +tooManyArguments = "54023" + +-- |Is set to @\"55000\"@. +objectNotInPrerequisiteState :: String +objectNotInPrerequisiteState = "55000" + +-- |Is set to @\"55006\"@. +objectInUse :: String +objectInUse = "55006" + +-- |Is set to @\"55P02\"@. +cantChangeRuntimeParam :: String +cantChangeRuntimeParam = "55P02" + +-- |Is set to @\"55P03\"@. +lockNotAvailable :: String +lockNotAvailable = "55P03" + +-- |Is set to @\"57000\"@. +operatorIntervention :: String +operatorIntervention = "57000" + +-- |Is set to @\"57014\"@. +queryCanceled :: String +queryCanceled = "57014" + +-- |Is set to @\"57P01\"@. +adminShutdown :: String +adminShutdown = "57P01" + +-- |Is set to @\"57P02\"@. +crashShutdown :: String +crashShutdown = "57P02" + +-- |Is set to @\"57P03\"@. +cannotConnectNow :: String +cannotConnectNow = "57P03" + +-- |Is set to @\"58030\"@. +ioError :: String +ioError = "58030" + +-- |Is set to @\"58P01\"@. +undefinedFile :: String +undefinedFile = "58P01" + +-- |Is set to @\"58P02\"@. +duplicateFile :: String +duplicateFile = "58P02" + +-- |Is set to @\"F0000\"@. +configFileError :: String +configFileError = "F0000" + +-- |Is set to @\"F0001\"@. +lockFileExists :: String +lockFileExists = "F0001" + +-- |Is set to @\"P0000\"@. +plpgsqlError :: String +plpgsqlError = "P0000" + +-- |Is set to @\"P0001\"@. +raiseException :: String +raiseException = "P0001" + +-- |Is set to @\"P0002\"@. +noDataFound :: String +noDataFound = "P0002" + +-- |Is set to @\"P0003\"@. +tooManyRows :: String +tooManyRows = "P0003" + +-- |Is set to @\"XX000\"@. +internalError :: String +internalError = "XX000" + +-- |Is set to @\"XX001\"@. +dataCorrupted :: String +dataCorrupted = "XX001" + +-- |Is set to @\"XX002\"@. +indexCorrupted :: String +indexCorrupted = "XX002" diff --git a/Database/HDBC/PostgreSQL/Statement.hsc b/Database/HDBC/PostgreSQL/Statement.hsc --- a/Database/HDBC/PostgreSQL/Statement.hsc +++ b/Database/HDBC/PostgreSQL/Statement.hsc @@ -76,6 +76,7 @@ let retval = Statement {execute = fexecute sstate, executeMany = fexecutemany sstate, + executeRaw = fexecuteRaw sstate, finish = public_ffinish sstate, fetchRow = ffetchrow sstate, originalQuery = query, @@ -103,51 +104,74 @@ public_ffinish sstate -- Sets nextrowmv to -1 resptr <- pqexecParams cconn cquery (genericLength args) nullPtr cargs nullPtr nullPtr 0 - status <- pqresultStatus resptr - case status of - #{const PGRES_EMPTY_QUERY} -> - do l $ "PGRES_EMPTY_QUERY: " ++ squery sstate - pqclear_raw resptr - swapMVar (coldefmv sstate) [] - return 0 - #{const PGRES_COMMAND_OK} -> - do l $ "PGRES_COMMAND_OK: " ++ squery sstate - rowscs <- pqcmdTuples resptr - rows <- peekCString rowscs - pqclear_raw resptr - swapMVar (coldefmv sstate) [] - return $ case rows of - "" -> 0 - x -> read x - #{const PGRES_TUPLES_OK} -> - do l $ "PGRES_TUPLES_OK: " ++ squery sstate - fgetcoldef resptr >>= swapMVar (coldefmv sstate) - numrows <- pqntuples resptr - if numrows < 1 - then do pqclear_raw resptr - return 0 - else do - wrappedptr <- withRawConn (dbo sstate) - (\rawconn -> wrapstmt resptr rawconn) - fresptr <- newForeignPtr pqclearptr wrappedptr - swapMVar (nextrowmv sstate) 0 - swapMVar (stomv sstate) (Just fresptr) - return 0 - _ -> do l $ "PGRES ERROR: " ++ squery sstate - csstatusmsg <- pqresStatus status - cserrormsg <- pqresultErrorMessage resptr - - statusmsgbs <- B.packCString csstatusmsg - errormsgbs <- B.packCString cserrormsg - let statusmsg = BUTF8.toString statusmsgbs - let errormsg = BUTF8.toString errormsgbs + handleResultStatus resptr sstate =<< pqresultStatus resptr - pqclear_raw resptr - throwSqlError $ - SqlError {seState = "", - seNativeError = fromIntegral status, - seErrorMsg = "execute: " ++ statusmsg ++ - ": " ++ errormsg} +{- | Differs from fexecute in that it does not prepare its input + query, and the input query may contain multiple statements. This + is useful for issuing DDL or DML commands. -} +fexecuteRaw :: SState -> IO () +fexecuteRaw sstate = + withConn (dbo sstate) $ \cconn -> + B.useAsCString (BUTF8.fromString (squery sstate)) $ \cquery -> + do l "in fexecute" + public_ffinish sstate -- Sets nextrowmv to -1 + resptr <- pqexec cconn cquery + handleResultStatus resptr sstate =<< pqresultStatus resptr + return () + +handleResultStatus :: (Num a, Read a) => WrappedCStmt -> SState -> ResultStatus -> IO a +handleResultStatus resptr sstate status = + case status of + #{const PGRES_EMPTY_QUERY} -> + do l $ "PGRES_EMPTY_QUERY: " ++ squery sstate + pqclear_raw resptr + swapMVar (coldefmv sstate) [] + return 0 + #{const PGRES_COMMAND_OK} -> + do l $ "PGRES_COMMAND_OK: " ++ squery sstate + rowscs <- pqcmdTuples resptr + rows <- peekCString rowscs + pqclear_raw resptr + swapMVar (coldefmv sstate) [] + return $ case rows of + "" -> 0 + x -> read x + #{const PGRES_TUPLES_OK} -> + do l $ "PGRES_TUPLES_OK: " ++ squery sstate + fgetcoldef resptr >>= swapMVar (coldefmv sstate) + numrows <- pqntuples resptr + if numrows < 1 then (pqclear_raw resptr >> return 0) else + do + wrappedptr <- withRawConn (dbo sstate) + (\rawconn -> wrapstmt resptr rawconn) + fresptr <- newForeignPtr pqclearptr wrappedptr + swapMVar (nextrowmv sstate) 0 + swapMVar (stomv sstate) (Just fresptr) + return 0 + _ -> do l $ "PGRES ERROR: " ++ squery sstate + csstatusmsg <- pqresStatus status + cserrormsg <- pqresultErrorMessage resptr + + statusmsgbs <- B.packCString csstatusmsg + errormsgbs <- B.packCString cserrormsg + let statusmsg = BUTF8.toString statusmsgbs + let errormsg = BUTF8.toString errormsgbs + + state <- pqresultErrorField resptr #{const PG_DIAG_SQLSTATE} >>= peekCStringUTF8 + + pqclear_raw resptr + throwSqlError $ SqlError { seState = state + , seNativeError = fromIntegral status + , seErrorMsg = "execute: " ++ statusmsg ++ + ": " ++ errormsg} + +peekCStringUTF8 :: CString -> IO String +-- Marshal a NUL terminated C string into a Haskell string, decoding it +-- with UTF8. +peekCStringUTF8 str = fmap BUTF8.toString (B.packCString str) + + + {- General algorithm: find out how many columns we have, check the type of each to see if it's NULL. If it's not, fetch it as text and return that. -} @@ -224,6 +248,9 @@ CInt -> IO (Ptr CStmt) +foreign import ccall unsafe "libpq-fe.h PQexec" + pqexec :: (Ptr CConn) -> CString -> IO (Ptr CStmt) + foreign import ccall unsafe "hdbc-postgresql-helper.h PQclear_app" pqclear :: Ptr WrappedCStmt -> IO () @@ -243,6 +270,9 @@ foreign import ccall unsafe "libpq-fe.h PQresultErrorMessage" pqresultErrorMessage :: (Ptr CStmt) -> IO CString + +foreign import ccall unsafe "libpq-fe.h PQresultErrorField" + pqresultErrorField :: (Ptr CStmt) -> CInt -> IO CString foreign import ccall unsafe "libpq-fe.h PQntuples" pqntuples :: Ptr CStmt -> IO CInt diff --git a/Database/HDBC/PostgreSQL/Types.hs b/Database/HDBC/PostgreSQL/Types.hs --- a/Database/HDBC/PostgreSQL/Types.hs +++ b/Database/HDBC/PostgreSQL/Types.hs @@ -10,4 +10,5 @@ data CStmt = CStmt type WrappedCStmt = Ptr CStmt type Stmt = ForeignPtr WrappedCStmt +type ResultStatus = Word32 diff --git a/HDBC-postgresql.cabal b/HDBC-postgresql.cabal --- a/HDBC-postgresql.cabal +++ b/HDBC-postgresql.cabal @@ -1,12 +1,12 @@ Name: HDBC-postgresql -Version: 2.1.0.0 +Version: 2.2.0.0 License: LGPL Maintainer: John Goerzen Author: John Goerzen Copyright: Copyright (c) 2005-2009 John Goerzen license-file: COPYRIGHT extra-source-files: COPYING, hdbc-postgresql-helper.h, pgtypes.h -homepage: http://software.complete.org/hdbc-postgres +homepage: http://software.complete.org/hdbc-postgresql Category: Database synopsis: PostgreSQL driver for HDBC Description: This package provides a PostgreSQL driver for HDBC @@ -29,14 +29,11 @@ Database.HDBC.PostgreSQL.Types, Database.HDBC.PostgreSQL.Utils, Database.HDBC.PostgreSQL.Parser, - Database.HDBC.PostgreSQL.PTypeConv + Database.HDBC.PostgreSQL.PTypeConv, + Database.HDBC.PostgreSQL.ErrorCodes Extensions: ExistentialQuantification, ForeignFunctionInterface - Build-Depends: base, mtl, HDBC>=2.1.0, parsec, utf8-string, - bytestring, old-time, old-locale - if flag(splitBase) - Build-Depends: base >= 3, old-time - else - Build-Depends: base < 3 + Build-Depends: base >= 3 && < 5, mtl, HDBC>=2.2.0, parsec, utf8-string, + bytestring, old-time, old-locale, time if impl(ghc >= 6.9) Build-Depends: base >= 4 Extra-Libraries: pq @@ -59,6 +56,7 @@ Database.HDBC.PostgreSQL.Utils, Database.HDBC.PostgreSQL.Parser, Database.HDBC.PostgreSQL.PTypeConv, + Database.HDBC.PostgreSQL.ErrorCodes, SpecificDB, SpecificDBTests, TestMisc, diff --git a/testsrc/SpecificDB.hs b/testsrc/SpecificDB.hs new file mode 100644 --- /dev/null +++ b/testsrc/SpecificDB.hs @@ -0,0 +1,25 @@ +module SpecificDB where +import Database.HDBC +import Database.HDBC.PostgreSQL +import Database.HDBC.PostgreSQL.Parser(convertSQL) +import Test.HUnit + +connectDB = + handleSqlError (do dbh <- connectPostgreSQL "" + run dbh "SET client_min_messages=WARNING" [] + return dbh) + +dateTimeTypeOfSqlValue :: SqlValue -> String +dateTimeTypeOfSqlValue (SqlLocalDate _) = "date" +dateTimeTypeOfSqlValue (SqlLocalTimeOfDay _) = "time without time zone" +dateTimeTypeOfSqlValue (SqlZonedLocalTimeOfDay _ _) = "time with time zone" +dateTimeTypeOfSqlValue (SqlLocalTime _) = "timestamp without time zone" +dateTimeTypeOfSqlValue (SqlZonedTime _) = "timestamp with time zone" +dateTimeTypeOfSqlValue (SqlUTCTime _) = "timestamp with time zone" +dateTimeTypeOfSqlValue (SqlDiffTime _) = "interval" +dateTimeTypeOfSqlValue (SqlPOSIXTime _) = "numeric" +dateTimeTypeOfSqlValue (SqlEpochTime _) = "integer" +dateTimeTypeOfSqlValue (SqlTimeDiff _) = "interval" +dateTimeTypeOfSqlValue _ = "text" + +supportsFracTime = True diff --git a/testsrc/SpecificDBTests.hs b/testsrc/SpecificDBTests.hs new file mode 100644 --- /dev/null +++ b/testsrc/SpecificDBTests.hs @@ -0,0 +1,24 @@ +module SpecificDBTests where +import Database.HDBC +import Database.HDBC.PostgreSQL +import Database.HDBC.PostgreSQL.Parser(convertSQL) +import Test.HUnit + +testp inp exp = TestCase $ + case convertSQL inp of + Right x -> assertEqual "" exp x + Left y -> assertFailure $ show y + +tests = TestList + [TestLabel "empty" (testp "" ""), + TestLabel "simple" (testp "SELECT a from b WHERE c = ?" + "SELECT a from b WHERE c = $1"), + TestLabel "multi" (testp "INSERT INTO foo VALUES (?,?)" + "INSERT INTO foo VALUES ($1,$2)"), + TestLabel "literal" (testp "INSERT INTO foo VALUES ('?', '''?')" + "INSERT INTO foo VALUES ('?', '''?')"), + TestLabel "torture" + (testp "-- really?\n-- yes'?\nINSERT INTO ? VALUES ('', ?, \"?asd\", '?\\'?', '?''?', /* foo? */ /* foo /* bar */ ? */ ?)" + "-- really?\n-- yes'?\nINSERT INTO $1 VALUES ('', $2, \"?asd\", '?\\'?', '?''?', /* foo? */ /* foo /* bar */ ? */ $3)") + ] + diff --git a/testsrc/TestMisc.hs b/testsrc/TestMisc.hs new file mode 100644 --- /dev/null +++ b/testsrc/TestMisc.hs @@ -0,0 +1,180 @@ +module TestMisc(tests, setup) where +import Test.HUnit +import Database.HDBC +import TestUtils +import System.IO +import Control.Exception +import Data.Char +import Control.Monad +import qualified Data.Map as Map + +rowdata = + [[SqlInt32 0, toSql "Testing", SqlNull], + [SqlInt32 1, toSql "Foo", SqlInt32 5], + [SqlInt32 2, toSql "Bar", SqlInt32 9]] + +colnames = ["testid", "teststring", "testint"] +alrows :: [[(String, SqlValue)]] +alrows = map (zip colnames) rowdata + +setup f = dbTestCase $ \dbh -> + do run dbh "CREATE TABLE hdbctest2 (testid INTEGER PRIMARY KEY NOT NULL, teststring TEXT, testint INTEGER)" [] + sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)" + executeMany sth rowdata + commit dbh + finally (f dbh) + (do run dbh "DROP TABLE hdbctest2" [] + commit dbh + ) + +cloneTest dbh a = + do dbh2 <- clone dbh + finally (handleSqlError (a dbh2)) + (handleSqlError (disconnect dbh2)) + +testgetColumnNames = setup $ \dbh -> + do sth <- prepare dbh "SELECT * from hdbctest2" + execute sth [] + cols <- getColumnNames sth + finish sth + ["testid", "teststring", "testint"] @=? map (map toLower) cols + +testdescribeResult = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem` + ["sqlite3"])) $ + do sth <- prepare dbh "SELECT * from hdbctest2" + execute sth [] + cols <- describeResult sth + ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols + let coldata = map snd cols + assertBool "r0 type" (colType (coldata !! 0) `elem` + [SqlBigIntT, SqlIntegerT]) + assertBool "r1 type" (colType (coldata !! 1) `elem` + [SqlVarCharT, SqlLongVarCharT]) + assertBool "r2 type" (colType (coldata !! 2) `elem` + [SqlBigIntT, SqlIntegerT]) + finish sth + +testdescribeTable = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem` + ["sqlite3"])) $ + do cols <- describeTable dbh "hdbctest2" + ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols + let coldata = map snd cols + assertBool "r0 type" (colType (coldata !! 0) `elem` + [SqlBigIntT, SqlIntegerT]) + assertEqual "r0 nullable" (Just False) (colNullable (coldata !! 0)) + assertBool "r1 type" (colType (coldata !! 1) `elem` + [SqlVarCharT, SqlLongVarCharT]) + assertEqual "r1 nullable" (Just True) (colNullable (coldata !! 1)) + assertBool "r2 type" (colType (coldata !! 2) `elem` + [SqlBigIntT, SqlIntegerT]) + assertEqual "r2 nullable" (Just True) (colNullable (coldata !! 2)) + +testquickQuery = setup $ \dbh -> + do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] + rowdata @=? results + +testfetchRowAL = setup $ \dbh -> + do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" + execute sth [] + fetchRowAL sth >>= (Just (head alrows) @=?) + fetchRowAL sth >>= (Just (alrows !! 1) @=?) + fetchRowAL sth >>= (Just (alrows !! 2) @=?) + fetchRowAL sth >>= (Nothing @=?) + finish sth + +testfetchRowMap = setup $ \dbh -> + do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" + execute sth [] + fetchRowMap sth >>= (Just (Map.fromList $ head alrows) @=?) + fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 1) @=?) + fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 2) @=?) + fetchRowMap sth >>= (Nothing @=?) + finish sth + +testfetchAllRowsAL = setup $ \dbh -> + do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" + execute sth [] + fetchAllRowsAL sth >>= (alrows @=?) + +testfetchAllRowsMap = setup $ \dbh -> + do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" + execute sth [] + fetchAllRowsMap sth >>= (map (Map.fromList) alrows @=?) + +testexception = setup $ \dbh -> + catchSql (do sth <- prepare dbh "SELECT invalidcol FROM hdbctest2" + execute sth [] + assertFailure "No exception was raised" + ) + (\e -> commit dbh) + +testrowcount = setup $ \dbh -> + do r <- run dbh "UPDATE hdbctest2 SET testint = 25 WHERE testid = 20" [] + assertEqual "UPDATE with no change" 0 r + r <- run dbh "UPDATE hdbctest2 SET testint = 26 WHERE testid = 0" [] + assertEqual "UPDATE with 1 change" 1 r + r <- run dbh "UPDATE hdbctest2 SET testint = 27 WHERE testid <> 0" [] + assertEqual "UPDATE with 2 changes" 2 r + commit dbh + res <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] + assertEqual "final results" + [[SqlInt32 0, toSql "Testing", SqlInt32 26], + [SqlInt32 1, toSql "Foo", SqlInt32 27], + [SqlInt32 2, toSql "Bar", SqlInt32 27]] res + +{- Since we might be running against a live DB, we can't look at a specific +list here (though a SpecificDB test case may be able to). We can ensure +that our test table is, or is not, present, as appropriate. -} + +testgetTables1 = setup $ \dbh -> + do r <- getTables dbh + True @=? "hdbctest2" `elem` r + +testgetTables2 = dbTestCase $ \dbh -> + do r <- getTables dbh + False @=? "hdbctest2" `elem` r + +testclone = setup $ \dbho -> cloneTest dbho $ \dbh -> + do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] + rowdata @=? results + +testnulls = setup $ \dbh -> + do let dn = hdbcDriverName dbh + when (not (dn `elem` ["postgresql", "odbc"])) ( + do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)" + executeMany sth rows + finish sth + res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" [] + seq (length res) rows @=? res + ) + where rows = [[SqlInt32 100, SqlString "foo\NULbar", SqlNull], + [SqlInt32 101, SqlString "bar\NUL", SqlNull], + [SqlInt32 102, SqlString "\NUL", SqlNull], + [SqlInt32 103, SqlString "\xFF", SqlNull], + [SqlInt32 104, SqlString "regular", SqlNull]] + +testunicode = setup $ \dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)" + executeMany sth rows + finish sth + res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" [] + seq (length res) rows @=? res + where rows = [[SqlInt32 100, SqlString "foo\x263a", SqlNull], + [SqlInt32 101, SqlString "bar\x00A3", SqlNull], + [SqlInt32 102, SqlString (take 263 (repeat 'a')), SqlNull]] + +tests = TestList [TestLabel "getColumnNames" testgetColumnNames, + TestLabel "describeResult" testdescribeResult, + TestLabel "describeTable" testdescribeTable, + TestLabel "quickQuery" testquickQuery, + TestLabel "fetchRowAL" testfetchRowAL, + TestLabel "fetchRowMap" testfetchRowMap, + TestLabel "fetchAllRowsAL" testfetchAllRowsAL, + TestLabel "fetchAllRowsMap" testfetchAllRowsMap, + TestLabel "sql exception" testexception, + TestLabel "clone" testclone, + TestLabel "update rowcount" testrowcount, + TestLabel "get tables1" testgetTables1, + TestLabel "get tables2" testgetTables2, + TestLabel "nulls" testnulls, + TestLabel "unicode" testunicode] diff --git a/testsrc/TestSbasics.hs b/testsrc/TestSbasics.hs new file mode 100644 --- /dev/null +++ b/testsrc/TestSbasics.hs @@ -0,0 +1,171 @@ +module TestSbasics(tests) where +import Test.HUnit +import Data.List +import Database.HDBC +import TestUtils +import System.IO +import Control.Exception hiding (catch) + +openClosedb = sqlTestCase $ + do dbh <- connectDB + disconnect dbh + +multiFinish = dbTestCase (\dbh -> + do sth <- prepare dbh "SELECT 1 + 1" + sExecute sth [] + finish sth + finish sth + finish sth + ) + +runRawTest = dbTestCase (\dbh -> + do runRaw dbh "CREATE TABLE valid1 (a int); CREATE TABLE valid2 (a int)" + tables <- getTables dbh + assertBool "valid1 table not created!" ("valid1" `elem` tables) + assertBool "valid2 table not created!" ("valid2" `elem` tables) + ) + +runRawErrorTest = dbTestCase (\dbh -> + let expected = "ERROR: syntax error at or near \"INVALID\"" + in do err <- (runRaw dbh "CREATE TABLE valid1 (a int); INVALID" >> return "No error") `catchSql` + (return . seErrorMsg) + assertBool "Error message inappropriate" (expected `isInfixOf` err) + rollback dbh + tables <- getTables dbh + assertBool "valid1 table created!" (not $ "valid1" `elem` tables) + ) + + +basicQueries = dbTestCase (\dbh -> + do sth <- prepare dbh "SELECT 1 + 1" + sExecute sth [] + sFetchRow sth >>= (assertEqual "row 1" (Just [Just "2"])) + sFetchRow sth >>= (assertEqual "last row" Nothing) + ) + +createTable = dbTestCase (\dbh -> + do sRun dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" [] + commit dbh + ) + +dropTable = dbTestCase (\dbh -> + do sRun dbh "DROP TABLE hdbctest1" [] + commit dbh + ) + +runReplace = dbTestCase (\dbh -> + do sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1 + sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, 2, ?)" r2 + commit dbh + sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid" + sExecute sth [] + sFetchRow sth >>= (assertEqual "r1" (Just r1)) + sFetchRow sth >>= (assertEqual "r2" (Just [Just "runReplace", Just "2", + Just "2", Nothing])) + sFetchRow sth >>= (assertEqual "lastrow" Nothing) + ) + where r1 = [Just "runReplace", Just "1", Just "1234", Just "testdata"] + r2 = [Just "runReplace", Just "2", Nothing] + +executeReplace = dbTestCase (\dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)" + sExecute sth [Just "1", Just "1234", Just "Foo"] + sExecute sth [Just "2", Nothing, Just "Bar"] + commit dbh + sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid" + sExecute sth [Just "executeReplace"] + sFetchRow sth >>= (assertEqual "r1" + (Just $ map Just ["executeReplace", "1", "1234", + "Foo"])) + sFetchRow sth >>= (assertEqual "r2" + (Just [Just "executeReplace", Just "2", Nothing, + Just "Bar"])) + sFetchRow sth >>= (assertEqual "lastrow" Nothing) + ) + +testExecuteMany = dbTestCase (\dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)" + sExecuteMany sth rows + commit dbh + sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'" + sExecute sth [] + mapM_ (\r -> sFetchRow sth >>= (assertEqual "" (Just r))) rows + sFetchRow sth >>= (assertEqual "lastrow" Nothing) + ) + where rows = [map Just ["1", "1234", "foo"], + map Just ["2", "1341", "bar"], + [Just "3", Nothing, Nothing]] + +testsFetchAllRows = dbTestCase (\dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows', ?, NULL, NULL)" + sExecuteMany sth rows + commit dbh + sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid" + sExecute sth [] + results <- sFetchAllRows sth + assertEqual "" rows results + ) + where rows = map (\x -> [Just . show $ x]) [1..9] + +basicTransactions = dbTestCase (\dbh -> + do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) + sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)" + sExecute sth [Just "0"] + commit dbh + qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid" + sExecute qrysth [] + sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]]) + + -- Now try a rollback + sExecuteMany sth rows + rollback dbh + sExecute qrysth [] + sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]]) + + -- Now try another commit + sExecuteMany sth rows + commit dbh + sExecute qrysth [] + sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows)) + ) + where rows = map (\x -> [Just . show $ x]) [1..9] + +testWithTransaction = dbTestCase (\dbh -> + do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) + sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)" + sExecute sth [Just "0"] + commit dbh + qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid" + sExecute qrysth [] + sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]]) + + -- Let's try a rollback. + catch (withTransaction dbh (\_ -> do sExecuteMany sth rows + fail "Foo")) + (\_ -> return ()) + sExecute qrysth [] + sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]]) + + -- And now a commit. + withTransaction dbh (\_ -> sExecuteMany sth rows) + sExecute qrysth [] + sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows)) + ) + where rows = map (\x -> [Just . show $ x]) [1..9] + +tests = TestList + [ + TestLabel "openClosedb" openClosedb, + TestLabel "multiFinish" multiFinish, + TestLabel "runRawTest" runRawTest, + TestLabel "runRawErrorTest" runRawErrorTest, + TestLabel "basicQueries" basicQueries, + TestLabel "createTable" createTable, + TestLabel "runReplace" runReplace, + TestLabel "executeReplace" executeReplace, + TestLabel "executeMany" testExecuteMany, + TestLabel "sFetchAllRows" testsFetchAllRows, + TestLabel "basicTransactions" basicTransactions, + TestLabel "withTransaction" testWithTransaction, + TestLabel "dropTable" dropTable + ] diff --git a/testsrc/TestUtils.hs b/testsrc/TestUtils.hs new file mode 100644 --- /dev/null +++ b/testsrc/TestUtils.hs @@ -0,0 +1,25 @@ +module TestUtils(connectDB, sqlTestCase, dbTestCase, printDBInfo) where +import Database.HDBC +import Test.HUnit +import Control.Exception +import SpecificDB(connectDB) + +sqlTestCase a = + TestCase (handleSqlError a) + +dbTestCase a = + TestCase (do dbh <- connectDB + finally (handleSqlError (a dbh)) + (handleSqlError (disconnect dbh)) + ) + +printDBInfo = handleSqlError $ + do dbh <- connectDB + putStrLn "+-------------------------------------------------------------------------" + putStrLn $ "| Testing HDBC database module: " ++ hdbcDriverName dbh ++ + ", bound to client: " ++ hdbcClientVer dbh + putStrLn $ "| Proxied driver: " ++ proxiedClientName dbh ++ + ", bound to version: " ++ proxiedClientVer dbh + putStrLn $ "| Connected to server version: " ++ dbServerVer dbh + putStrLn "+-------------------------------------------------------------------------\n" + disconnect dbh diff --git a/testsrc/Testbasics.hs b/testsrc/Testbasics.hs new file mode 100644 --- /dev/null +++ b/testsrc/Testbasics.hs @@ -0,0 +1,168 @@ +module Testbasics(tests) where +import Test.HUnit +import Database.HDBC +import TestUtils +import System.IO +import Control.Exception hiding (catch) + +openClosedb = sqlTestCase $ + do dbh <- connectDB + disconnect dbh + +multiFinish = dbTestCase (\dbh -> + do sth <- prepare dbh "SELECT 1 + 1" + r <- execute sth [] + assertEqual "basic count" 0 r + finish sth + finish sth + finish sth + ) + +basicQueries = dbTestCase (\dbh -> + do sth <- prepare dbh "SELECT 1 + 1" + execute sth [] >>= (0 @=?) + r <- fetchAllRows sth + assertEqual "converted from" [["2"]] (map (map fromSql) r) + assertEqual "int32 compare" [[SqlInt32 2]] r + assertEqual "iToSql compare" [[iToSql 2]] r + assertEqual "num compare" [[toSql (2::Int)]] r + assertEqual "nToSql compare" [[nToSql (2::Int)]] r + assertEqual "string compare" [[SqlString "2"]] r + ) + +createTable = dbTestCase (\dbh -> + do run dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" [] + commit dbh + ) + +dropTable = dbTestCase (\dbh -> + do run dbh "DROP TABLE hdbctest1" [] + commit dbh + ) + +runReplace = dbTestCase (\dbh -> + do r <- run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1 + assertEqual "insert retval" 1 r + run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r2 + commit dbh + sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid" + rv2 <- execute sth [] + assertEqual "select retval" 0 rv2 + r <- fetchAllRows sth + assertEqual "" [r1, r2] r + ) + where r1 = [toSql "runReplace", iToSql 1, iToSql 1234, SqlString "testdata"] + r2 = [toSql "runReplace", iToSql 2, iToSql 2, SqlNull] + +executeReplace = dbTestCase (\dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)" + execute sth [iToSql 1, iToSql 1234, toSql "Foo"] + execute sth [SqlInt32 2, SqlNull, toSql "Bar"] + commit dbh + sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid" + execute sth [SqlString "executeReplace"] + r <- fetchAllRows sth + assertEqual "result" + [[toSql "executeReplace", iToSql 1, toSql "1234", + toSql "Foo"], + [toSql "executeReplace", iToSql 2, SqlNull, + toSql "Bar"]] + r + ) + +testExecuteMany = dbTestCase (\dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)" + executeMany sth rows + commit dbh + sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'" + execute sth [] + r <- fetchAllRows sth + assertEqual "" rows r + ) + where rows = [map toSql ["1", "1234", "foo"], + map toSql ["2", "1341", "bar"], + [toSql "3", SqlNull, SqlNull]] + +testFetchAllRows = dbTestCase (\dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows', ?, NULL, NULL)" + executeMany sth rows + commit dbh + sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid" + execute sth [] + results <- fetchAllRows sth + assertEqual "" rows results + ) + where rows = map (\x -> [iToSql x]) [1..9] + +testFetchAllRows' = dbTestCase (\dbh -> + do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows2', ?, NULL, NULL)" + executeMany sth rows + commit dbh + sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows2' ORDER BY testid" + execute sth [] + results <- fetchAllRows' sth + assertEqual "" rows results + ) + where rows = map (\x -> [iToSql x]) [1..9] + +basicTransactions = dbTestCase (\dbh -> + do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) + sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)" + execute sth [iToSql 0] + commit dbh + qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid" + execute qrysth [] + fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]]) + + -- Now try a rollback + executeMany sth rows + rollback dbh + execute qrysth [] + fetchAllRows qrysth >>= (assertEqual "rollback" [[toSql "0"]]) + + -- Now try another commit + executeMany sth rows + commit dbh + execute qrysth [] + fetchAllRows qrysth >>= (assertEqual "final commit" ([SqlString "0"]:rows)) + ) + where rows = map (\x -> [iToSql $ x]) [1..9] + +testWithTransaction = dbTestCase (\dbh -> + do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) + sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)" + execute sth [toSql "0"] + commit dbh + qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid" + execute qrysth [] + fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]]) + + -- Let's try a rollback. + catch (withTransaction dbh (\_ -> do executeMany sth rows + fail "Foo")) + (\_ -> return ()) + execute qrysth [] + fetchAllRows qrysth >>= (assertEqual "rollback" [[SqlString "0"]]) + + -- And now a commit. + withTransaction dbh (\_ -> executeMany sth rows) + execute qrysth [] + fetchAllRows qrysth >>= (assertEqual "final commit" ([iToSql 0]:rows)) + ) + where rows = map (\x -> [iToSql x]) [1..9] + +tests = TestList + [ + TestLabel "openClosedb" openClosedb, + TestLabel "multiFinish" multiFinish, + TestLabel "basicQueries" basicQueries, + TestLabel "createTable" createTable, + TestLabel "runReplace" runReplace, + TestLabel "executeReplace" executeReplace, + TestLabel "executeMany" testExecuteMany, + TestLabel "fetchAllRows" testFetchAllRows, + TestLabel "fetchAllRows'" testFetchAllRows', + TestLabel "basicTransactions" basicTransactions, + TestLabel "withTransaction" testWithTransaction, + TestLabel "dropTable" dropTable + ] diff --git a/testsrc/Tests.hs b/testsrc/Tests.hs new file mode 100644 --- /dev/null +++ b/testsrc/Tests.hs @@ -0,0 +1,34 @@ +{- arch-tag: Tests main file +Copyright (C) 2004-2005 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Tests(tests) where +import Test.HUnit +import qualified Testbasics +import qualified TestSbasics +import qualified SpecificDBTests +import qualified TestMisc +import qualified TestTime + +test1 = TestCase ("x" @=? "x") + +tests = TestList [TestLabel "test1" test1, + TestLabel "String basics" TestSbasics.tests, + TestLabel "SqlValue basics" Testbasics.tests, + TestLabel "SpecificDB" SpecificDBTests.tests, + TestLabel "Misc tests" TestMisc.tests, + TestLabel "Time tests" TestTime.tests] diff --git a/testsrc/runtests.hs b/testsrc/runtests.hs new file mode 100644 --- /dev/null +++ b/testsrc/runtests.hs @@ -0,0 +1,27 @@ +{- arch-tag: Test runner +Copyright (C) 2004 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Main where + +import Test.HUnit +import Tests +import TestUtils + +main = do printDBInfo + runTestTT tests +