HDBC-postgresql-2.3.2.1/0000755000000000000000000000000011724447761012761 5ustar0000000000000000HDBC-postgresql-2.3.2.1/README.txt0000644000000000000000000000114511724447761014460 0ustar0000000000000000Welcome to HDBC, Haskell Database Connectivity. This package provides a database backend driver for PostgreSQL. Please see HDBC itself for documentation on use. This package provides one function in module Database.HDBC.PostgreSQL: {- | Connect to a PostgreSQL server. See for the meaning of the connection string. -} connectPostgreSQL :: String -> IO Connection An example would be: dbh <- connectPostgreSQL "host=localhost dbname=testdb user=foo" DIFFERENCES FROM HDBC STANDARD ------------------------------ None known at this time. HDBC-postgresql-2.3.2.1/pgtypes.h0000644000000000000000000000403111724447761014623 0ustar0000000000000000/* File: pgtypes.h * * Description: See "pgtypes.c" * * Comments: See "notice.txt" for copyright and license information. * */ #ifndef __PGTYPES_H__ #define __PGTYPES_H__ /* the type numbers are defined by the OID's of the types' rows */ /* in table pg_type */ #ifdef NOT_USED #define PG_TYPE_LO ???? /* waiting for permanent type */ #endif #define MS_ACCESS_SERIAL "int identity" #define PG_TYPE_BOOL 16 #define PG_TYPE_BYTEA 17 #define PG_TYPE_CHAR 18 #define PG_TYPE_NAME 19 #define PG_TYPE_INT8 20 #define PG_TYPE_INT2 21 #define PG_TYPE_INT2VECTOR 22 #define PG_TYPE_INT4 23 #define PG_TYPE_REGPROC 24 #define PG_TYPE_TEXT 25 #define PG_TYPE_OID 26 #define PG_TYPE_TID 27 #define PG_TYPE_XID 28 #define PG_TYPE_CID 29 #define PG_TYPE_OIDVECTOR 30 #define PG_TYPE_SET 32 #define PG_TYPE_XML 142 #define PG_TYPE_XMLARRAY 143 #define PG_TYPE_CHAR2 409 #define PG_TYPE_CHAR4 410 #define PG_TYPE_CHAR8 411 #define PG_TYPE_POINT 600 #define PG_TYPE_LSEG 601 #define PG_TYPE_PATH 602 #define PG_TYPE_BOX 603 #define PG_TYPE_POLYGON 604 #define PG_TYPE_FILENAME 605 #define PG_TYPE_CIDR 650 #define PG_TYPE_FLOAT4 700 #define PG_TYPE_FLOAT8 701 #define PG_TYPE_ABSTIME 702 #define PG_TYPE_RELTIME 703 #define PG_TYPE_TINTERVAL 704 #define PG_TYPE_UNKNOWN 705 #define PG_TYPE_MONEY 790 #define PG_TYPE_OIDINT2 810 #define PG_TYPE_MACADDR 829 #define PG_TYPE_INET 869 #define PG_TYPE_OIDINT4 910 #define PG_TYPE_OIDNAME 911 #define PG_TYPE_TEXTARRAY 1009 #define PG_TYPE_BPCHARARRAY 1014 #define PG_TYPE_VARCHARARRAY 1015 #define PG_TYPE_BPCHAR 1042 #define PG_TYPE_VARCHAR 1043 #define PG_TYPE_DATE 1082 #define PG_TYPE_TIME 1083 #define PG_TYPE_TIMESTAMP_NO_TMZONE 1114 /* since 7.2 */ #define PG_TYPE_DATETIME 1184 #define PG_TYPE_TIME_WITH_TMZONE 1266 /* since 7.1 */ #define PG_TYPE_TIMESTAMP 1296 /* deprecated since 7.0 */ #define PG_TYPE_NUMERIC 1700 #define PG_TYPE_RECORD 2249 #define PG_TYPE_VOID 2278 #define INTERNAL_ASIS_TYPE (-9999) #endif HDBC-postgresql-2.3.2.1/hdbc-postgresql-helper.h0000644000000000000000000000065011724447761017511 0ustar0000000000000000#include typedef struct TAG_finalizeonce { void *encapobj; int refcount; int isfinalized; struct TAG_finalizeonce *parent; } finalizeonce; extern finalizeonce *wrapobjpg(void *obj, finalizeonce *parentobj); extern void PQfinish_app(finalizeonce *conn); extern void PQfinish_finalizer(finalizeonce *conn); extern void PQclear_app(finalizeonce *res); extern void PQclear_finalizer(finalizeonce *res); HDBC-postgresql-2.3.2.1/LICENSE0000644000000000000000000000271611724447761013774 0ustar0000000000000000Copyright (c) 2005-2011 John Goerzen 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 John Goerzen nor the names of its 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 HOLDER 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. HDBC-postgresql-2.3.2.1/HDBC-postgresql.cabal0000644000000000000000000000527711724447761016661 0ustar0000000000000000Name: HDBC-postgresql Version: 2.3.2.1 License: BSD3 Maintainer: Nicolas Wu Author: John Goerzen Copyright: Copyright (c) 2005-2011 John Goerzen license-file: LICENSE extra-source-files: LICENSE, hdbc-postgresql-helper.h, pgtypes.h, Makefile, README.txt, testsrc/TestTime.hs homepage: http://github.com/hdbc/hdbc-postgresql Category: Database synopsis: PostgreSQL driver for HDBC Description: This package provides a PostgreSQL driver for HDBC Stability: Stable Build-Type: Custom Cabal-Version: >=1.8 Flag splitBase description: Choose the new smaller, split-up package. Flag buildtests description: Build the executable to run unit tests default: False Library Exposed-Modules: Database.HDBC.PostgreSQL Other-Modules: Database.HDBC.PostgreSQL.Connection, Database.HDBC.PostgreSQL.ConnectionImpl, Database.HDBC.PostgreSQL.Statement, Database.HDBC.PostgreSQL.Types, Database.HDBC.PostgreSQL.Utils, Database.HDBC.PostgreSQL.Parser, Database.HDBC.PostgreSQL.PTypeConv, Database.HDBC.PostgreSQL.ErrorCodes Extensions: ExistentialQuantification, ForeignFunctionInterface Build-Depends: base >= 3 && < 5, mtl, HDBC>=2.2.0, parsec, utf8-string, bytestring, old-time, old-locale, time, convertible if impl(ghc >= 6.9) Build-Depends: base >= 4 Extra-Libraries: pq C-Sources: hdbc-postgresql-helper.c Include-Dirs: . GHC-Options: -O2 -Wall Executable runtests if flag(buildtests) Buildable: True Build-Depends: HUnit, QuickCheck, testpack, containers, convertible, time, old-locale, parsec, utf8-string, bytestring, old-time, base, HDBC>=2.2.6 else Buildable: False Main-Is: runtests.hs Other-Modules: Database.HDBC.PostgreSQL.Connection, Database.HDBC.PostgreSQL.ConnectionImpl, Database.HDBC.PostgreSQL.Statement, Database.HDBC.PostgreSQL.Types, Database.HDBC.PostgreSQL.Utils, Database.HDBC.PostgreSQL.Parser, Database.HDBC.PostgreSQL.PTypeConv, Database.HDBC.PostgreSQL.ErrorCodes, SpecificDB, SpecificDBTests, TestMisc, TestSbasics, TestUtils, Testbasics, Tests C-Sources: hdbc-postgresql-helper.c include-dirs: . Extra-Libraries: pq Hs-Source-Dirs: ., testsrc GHC-Options: -O2 Extensions: ExistentialQuantification, ForeignFunctionInterface source-repository head type: git location: https://github.com/hdbc/hdbc-postgresql.git HDBC-postgresql-2.3.2.1/Makefile0000644000000000000000000000165511724447761014430 0ustar0000000000000000all: setup @echo "Please use Cabal to build this package; not make." ./setup configure ./setup build setup: Setup.hs ghc --make -package Cabal -o setup Setup.hs install: setup ./setup install clean: -runghc Setup.hs clean -rm -rf html `find . -name "*.o"` `find . -name "*.hi" | grep -v debian` \ `find . -name "*~" | grep -v debian` *.a setup dist testsrc/runtests \ local-pkg doctmp -rm -rf testtmp/* testtmp* .PHONY: test test: test-ghc test-hugs @echo "" @echo "All tests pass." test-hugs: setup @echo " ****** Running hugs tests" ./setup configure -f buildtests --hugs --extra-include-dirs=/usr/lib/hugs/include ./setup build runhugs -98 +o -P$(PWD)/dist/scratch:$(PWD)/dist/scratch/programs/runtests: \ dist/scratch/programs/runtests/Main.hs test-ghc: setup @echo " ****** Building GHC tests" ./setup configure -f buildtests ./setup build @echo " ****** Running GHC tests" ./dist/build/runtests/runtests HDBC-postgresql-2.3.2.1/Setup.hs0000644000000000000000000000270611724447761014422 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple import Distribution.PackageDescription import Distribution.Version import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program import Distribution.Verbosity import Data.Char (isSpace) import Data.List (dropWhile,reverse) import Control.Monad main = defaultMainWithHooks simpleUserHooks { hookedPrograms = [pgconfigProgram], confHook = \pkg flags -> do lbi <- confHook simpleUserHooks pkg flags bi <- psqlBuildInfo lbi return lbi { localPkgDescr = updatePackageDescription (Just bi, [("runtests", bi)]) (localPkgDescr lbi) } } pgconfigProgram = (simpleProgram "pgconfig or pg_config") { programFindLocation = \verbosity -> do pgconfig <- findProgramLocation verbosity "pgconfig" pg_config <- findProgramLocation verbosity "pg_config" return (pgconfig `mplus` pg_config) } psqlBuildInfo :: LocalBuildInfo -> IO BuildInfo psqlBuildInfo lbi = do (pgconfigProg, _) <- requireProgram verbosity pgconfigProgram (withPrograms lbi) let pgconfig = rawSystemProgramStdout verbosity pgconfigProg incDir <- pgconfig ["--includedir"] libDir <- pgconfig ["--libdir"] return emptyBuildInfo { extraLibDirs = [strip libDir], includeDirs = [strip incDir] } where verbosity = normal -- honestly, this is a hack strip x = dropWhile isSpace $ reverse $ dropWhile isSpace $ reverse x HDBC-postgresql-2.3.2.1/hdbc-postgresql-helper.c0000644000000000000000000000311111724447761017477 0ustar0000000000000000#include #include #include #include "hdbc-postgresql-helper.h" /* Things can't finalize more than once. We'd like to let people call them from the app. Yet we'd also like to be able to have a ForeignPtr finalize them. So, here's a little wrapper for things. */ void PQfinish_conditional_finalizer(finalizeonce *conn); finalizeonce *wrapobjpg(void *obj, finalizeonce *parentobj) { finalizeonce *newobj; newobj = malloc(sizeof(finalizeonce)); if (newobj == NULL) { fprintf(stderr, "HDBC: could not allocate wrapper!\n"); return NULL; } newobj->isfinalized = 0; newobj->refcount = 1; newobj->encapobj = obj; newobj->parent = parentobj; if (parentobj != NULL) parentobj->refcount++; return newobj; } void PQfinish_app(finalizeonce *conn) { if (conn->isfinalized) return; PQfinish((PGconn *) (conn->encapobj)); conn->encapobj = NULL; conn->isfinalized = 1; } void PQfinish_finalizer(finalizeonce *conn) { (conn->refcount)--; PQfinish_conditional_finalizer(conn); } void PQfinish_conditional_finalizer(finalizeonce *conn) { if (conn->refcount < 1) { PQfinish_app(conn); free(conn); } } void PQclear_app(finalizeonce *res) { if (res->isfinalized) return; PQclear((PGresult *) (res->encapobj)); res->isfinalized = 1; } void PQclear_finalizer(finalizeonce *res) { PQclear_app(res); (res->refcount)--; /* Not really important since this is never a parent */ (res->parent->refcount)--; PQfinish_conditional_finalizer(res->parent); free(res); } HDBC-postgresql-2.3.2.1/testsrc/0000755000000000000000000000000011724447761014450 5ustar0000000000000000HDBC-postgresql-2.3.2.1/testsrc/SpecificDBTests.hs0000644000000000000000000000210711724447761017762 0ustar0000000000000000module 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)") ] HDBC-postgresql-2.3.2.1/testsrc/TestMisc.hs0000644000000000000000000001702011724447761016537 0ustar0000000000000000module 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] HDBC-postgresql-2.3.2.1/testsrc/TestUtils.hs0000644000000000000000000000174111724447761016747 0ustar0000000000000000module 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 HDBC-postgresql-2.3.2.1/testsrc/runtests.hs0000644000000000000000000000022311724447761016670 0ustar0000000000000000{- arch-tag: Test runner -} module Main where import Test.HUnit import Tests import TestUtils main = do printDBInfo runTestTT tests HDBC-postgresql-2.3.2.1/testsrc/TestTime.hs0000644000000000000000000000677711724447761016563 0ustar0000000000000000module TestTime(tests) where import Test.HUnit import Database.HDBC import TestUtils import Control.Exception import Data.Time import Data.Time.LocalTime import Data.Time.Clock.POSIX import Data.Maybe import Data.Convertible import SpecificDB import System.Locale(defaultTimeLocale) import Database.HDBC.Locale (iso8601DateFormat) import qualified System.Time as ST instance Eq ZonedTime where a == b = zonedTimeToUTC a == zonedTimeToUTC b && zonedTimeZone a == zonedTimeZone b testZonedTime :: ZonedTime testZonedTime = fromJust $ parseTime defaultTimeLocale (iso8601DateFormat (Just "%T %z")) "1989-08-01 15:33:01 -0500" testZonedTimeFrac :: ZonedTime testZonedTimeFrac = fromJust $ parseTime defaultTimeLocale (iso8601DateFormat (Just "%T%Q %z")) "1989-08-01 15:33:01.536 -0500" rowdata t = [[SqlInt32 100, toSql t, SqlNull]] testDTType inputdata convToSqlValue = dbTestCase $ \dbh -> do run dbh ("CREATE TABLE hdbctesttime (testid INTEGER PRIMARY KEY NOT NULL, \ \testvalue " ++ dateTimeTypeOfSqlValue value ++ ")") [] finally (testIt dbh) (do commit dbh run dbh "DROP TABLE hdbctesttime" [] commit dbh ) where testIt dbh = do run dbh "INSERT INTO hdbctesttime (testid, testvalue) VALUES (?, ?)" [iToSql 5, value] commit dbh r <- quickQuery' dbh "SELECT testid, testvalue FROM hdbctesttime" [] case r of [[testidsv, testvaluesv]] -> do assertEqual "testid" (5::Int) (fromSql testidsv) assertEqual "testvalue" inputdata (fromSql testvaluesv) value = convToSqlValue inputdata mkTest label inputdata convfunc = TestLabel label (testDTType inputdata convfunc) tests = TestList $ ((TestLabel "Non-frac" $ testIt testZonedTime) : if supportsFracTime then [TestLabel "Frac" $ testIt testZonedTimeFrac] else []) testIt baseZonedTime = TestList [mkTest "Day" baseDay toSql, mkTest "TimeOfDay" baseTimeOfDay toSql, mkTest "ZonedTimeOfDay" baseZonedTimeOfDay toSql, mkTest "LocalTime" baseLocalTime toSql, mkTest "ZonedTime" baseZonedTime toSql, mkTest "UTCTime" baseUTCTime toSql, mkTest "DiffTime" baseDiffTime toSql, mkTest "POSIXTime" basePOSIXTime posixToSql, mkTest "ClockTime" baseClockTime toSql, mkTest "CalendarTime" baseCalendarTime toSql, mkTest "TimeDiff" baseTimeDiff toSql ] where baseDay :: Day baseDay = localDay baseLocalTime baseTimeOfDay :: TimeOfDay baseTimeOfDay = localTimeOfDay baseLocalTime baseZonedTimeOfDay :: (TimeOfDay, TimeZone) baseZonedTimeOfDay = fromSql (SqlZonedTime baseZonedTime) baseLocalTime :: LocalTime baseLocalTime = zonedTimeToLocalTime baseZonedTime baseUTCTime :: UTCTime baseUTCTime = convert baseZonedTime baseDiffTime :: NominalDiffTime baseDiffTime = basePOSIXTime basePOSIXTime :: POSIXTime basePOSIXTime = convert baseZonedTime baseTimeDiff :: ST.TimeDiff baseTimeDiff = convert baseDiffTime -- No fractional parts for these two baseClockTime :: ST.ClockTime baseClockTime = convert testZonedTime baseCalendarTime :: ST.CalendarTime baseCalendarTime = convert testZonedTime HDBC-postgresql-2.3.2.1/testsrc/Tests.hs0000644000000000000000000000113011724447761016101 0ustar0000000000000000{- arch-tag: Tests main file -} 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] HDBC-postgresql-2.3.2.1/testsrc/SpecificDB.hs0000644000000000000000000000201011724447761016730 0ustar0000000000000000module 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 HDBC-postgresql-2.3.2.1/testsrc/Testbasics.hs0000644000000000000000000001504111724447761017111 0ustar0000000000000000module 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 ] HDBC-postgresql-2.3.2.1/testsrc/TestSbasics.hs0000644000000000000000000001566111724447761017244 0ustar0000000000000000module 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 ] HDBC-postgresql-2.3.2.1/Database/0000755000000000000000000000000011724447761014465 5ustar0000000000000000HDBC-postgresql-2.3.2.1/Database/HDBC/0000755000000000000000000000000011724447761015165 5ustar0000000000000000HDBC-postgresql-2.3.2.1/Database/HDBC/PostgreSQL.hs0000644000000000000000000000413711724447761017531 0ustar0000000000000000{- | Module : Database.HDBC.PostgreSQL Copyright : Copyright (C) 2005-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable HDBC driver interface for PostgreSQL 8.x Written by John Goerzen, jgoerzen\@complete.org /NOTE ON DATES AND TIMES/ The recommended correspondence between PostgreSQL date and time types and HDBC SqlValue types is: * SqlLocalDate: DATE * SqlLocalTimeOfDay: TIME WITHOUT TIME ZONE * SqlZonedLocalTimeOfDay: TIME WITH TIME ZONE * SqlLocalTime: TIMESTAMP WITHOUT TIME ZONE * SqlZonedTime: TIMESTAMP WITH TIME ZONE * SqlUTCTime: TIMESTAMP WITH TIME ZONE * SqlDiffTime: INTERVAL * SqlPOSIXTime: NUMERIC * SqlEpochTime: INTEGER * SqlTimeDiff: INTERVAL Other combinations are possible, and may even be converted automatically. The above simply represents the types that seem the most logical correspondence, and thus are tested by the HDBC-PostgreSQL test suite. -} module Database.HDBC.PostgreSQL ( -- * Connecting to Databases connectPostgreSQL, withPostgreSQL, connectPostgreSQL', withPostgreSQL', Connection, -- * Transactions begin, -- * 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, -- * Threading -- $threading ) where import Database.HDBC.PostgreSQL.Connection(connectPostgreSQL, withPostgreSQL, connectPostgreSQL', withPostgreSQL', begin, Connection()) import Database.HDBC.PostgreSQL.ErrorCodes {- $threading Provided the local libpq library is thread-safe, multiple 'Connection's may be used to have concurrent database queries. Concurrent queries issued on a single 'Connection' will be performed serially. When the local libpq library is not thread-safe (ie. it has not been compiled with --enable-thread-safety), only a single database function will be performed at a time. -} HDBC-postgresql-2.3.2.1/Database/HDBC/PostgreSQL/0000755000000000000000000000000011724447761017170 5ustar0000000000000000HDBC-postgresql-2.3.2.1/Database/HDBC/PostgreSQL/Connection.hsc0000644000000000000000000002055611724447761021776 0ustar0000000000000000-- -*- mode: haskell; -*- {-# CFILES hdbc-postgresql-helper.c #-} -- Above line for hugs {-# LANGUAGE FlexibleContexts #-} module Database.HDBC.PostgreSQL.Connection (connectPostgreSQL, withPostgreSQL, connectPostgreSQL', withPostgreSQL', Impl.begin, Impl.Connection()) where import Database.HDBC import Database.HDBC.DriverUtils import qualified Database.HDBC.PostgreSQL.ConnectionImpl as Impl import Database.HDBC.PostgreSQL.Types import Database.HDBC.PostgreSQL.Statement import Database.HDBC.PostgreSQL.PTypeConv import Foreign.C.Types import Foreign.C.String import Database.HDBC.PostgreSQL.Utils import Foreign.ForeignPtr import Foreign.Ptr import Data.Word import Data.Maybe import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as BUTF8 import Control.Monad (when) import Control.Concurrent.MVar import System.IO (stderr, hPutStrLn) import System.IO.Unsafe (unsafePerformIO) import Control.Exception(bracket) import Data.Convertible (Convertible) #include #include -- | A global lock only used when libpq is /not/ thread-safe. In that situation -- this mvar is used to serialize access to the FFI calls marked as /safe/. globalConnLock :: MVar () {-# NOINLINE globalConnLock #-} globalConnLock = unsafePerformIO $ newMVar () {- | Connect to a PostgreSQL server. See for the meaning of the connection string. -} connectPostgreSQL :: String -> IO Impl.Connection connectPostgreSQL = connectPostgreSQL_helper True connectPostgreSQL' :: String -> IO Impl.Connection connectPostgreSQL' = connectPostgreSQL_helper False connectPostgreSQL_helper :: Bool -> String -> IO Impl.Connection connectPostgreSQL_helper auto_transaction args = B.useAsCString (BUTF8.fromString args) $ \cs -> do ptr <- pqconnectdb cs threadSafe <- pqisThreadSafe ptr connLock <- if threadSafe==0 -- Also check GHC.Conc.numCapabilities here? then do hPutStrLn stderr "WARNING: libpq is not threadsafe, \ \serializing all libpq FFI calls. \ \(Consider recompiling libpq with \ \--enable-thread-safety.\n" return globalConnLock else newMVar () status <- pqstatus ptr wrappedptr <- wrapconn ptr nullPtr fptr <- newForeignPtr pqfinishptr wrappedptr case status of #{const CONNECTION_OK} -> mkConn auto_transaction args (connLock,fptr) _ -> raiseError "connectPostgreSQL" status ptr -- FIXME: environment vars may have changed, should use pgsql enquiries -- for clone. mkConn :: Bool -> String -> Conn -> IO Impl.Connection mkConn auto_transaction args conn = withConn conn $ \cconn -> do children <- newMVar [] when auto_transaction $ begin_transaction conn children protover <- pqprotocolVersion cconn serverver <- pqserverVersion cconn let clientver = #{const_str PG_VERSION} let rconn = Impl.Connection { Impl.disconnect = fdisconnect conn children, Impl.begin = if auto_transaction then return () else begin_transaction conn children, Impl.commit = fcommit auto_transaction conn children, Impl.rollback = frollback auto_transaction conn children, Impl.runRaw = frunRaw conn children, Impl.run = frun conn children, Impl.prepare = newSth conn children, Impl.clone = connectPostgreSQL args, Impl.hdbcDriverName = "postgresql", Impl.hdbcClientVer = clientver, Impl.proxiedClientName = "postgresql", Impl.proxiedClientVer = show protover, Impl.dbServerVer = show serverver, Impl.dbTransactionSupport = True, Impl.getTables = fgetTables conn children, Impl.describeTable = fdescribeTable conn children} _ <- quickQuery rconn "SET client_encoding TO utf8;" [] return rconn -- | Connect to a PostgreSQL server, and automatically disconnect -- if the handler exits normally or throws an exception. withPostgreSQL :: String -> (Impl.Connection -> IO a) -> IO a withPostgreSQL connstr = bracket (connectPostgreSQL connstr) (disconnect) withPostgreSQL' :: String -> (Impl.Connection -> IO a) -> IO a withPostgreSQL' connstr = bracket (connectPostgreSQL' connstr) (disconnect) -------------------------------------------------- -- Guts here -------------------------------------------------- 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 = do sth <- newSth o children query res <- execute sth args finish sth return res fcommit :: Bool -> Conn -> ChildList -> IO () fcommit begin o cl = do _ <- frun o cl "COMMIT" [] when begin $ begin_transaction o cl frollback :: Bool -> Conn -> ChildList -> IO () frollback begin o cl = do _ <- frun o cl "ROLLBACK" [] when begin $ begin_transaction o cl fgetTables :: (Convertible SqlValue a) => Conn -> ChildList -> IO [a] fgetTables conn children = do sth <- newSth conn children "select table_name from information_schema.tables where \ \table_schema != 'pg_catalog' AND table_schema != \ \'information_schema'" _ <- execute sth [] res1 <- fetchAllRows' sth let res = map fromSql $ concat res1 return $ seq (length res) res fdescribeTable :: Conn -> ChildList -> String -> IO [(String, SqlColDesc)] fdescribeTable o cl table = fdescribeSchemaTable o cl Nothing table fdescribeSchemaTable :: Conn -> ChildList -> Maybe String -> String -> IO [(String, SqlColDesc)] fdescribeSchemaTable o cl maybeSchema table = do sth <- newSth o cl ("SELECT attname, atttypid, attlen, format_type(atttypid, atttypmod), attnotnull " ++ "FROM pg_attribute, pg_class, pg_namespace ns " ++ "WHERE relname = ? and attnum > 0 and attisdropped IS FALSE " ++ (if isJust maybeSchema then "and ns.nspname = ? " else "") ++ "and attrelid = pg_class.oid and relnamespace = ns.oid order by attnum") let params = toSql table : (if isJust maybeSchema then [toSql $ fromJust maybeSchema] else []) _ <- execute sth params res <- fetchAllRows' sth return $ map desccol res where desccol [attname, atttypid, attlen, formattedtype, attnotnull] = (fromSql attname, colDescForPGAttr (fromSql atttypid) (fromSql attlen) (fromSql formattedtype) (fromSql attnotnull == False)) desccol x = error $ "Got unexpected result from pg_attribute: " ++ show x fdisconnect :: Conn -> ChildList -> IO () fdisconnect conn mchildren = do closeAllChildren mchildren withRawConn conn $ pqfinish foreign import ccall safe "libpq-fe.h PQconnectdb" pqconnectdb :: CString -> IO (Ptr CConn) foreign import ccall unsafe "hdbc-postgresql-helper.h wrapobjpg" wrapconn :: Ptr CConn -> Ptr WrappedCConn -> IO (Ptr WrappedCConn) foreign import ccall unsafe "libpq-fe.h PQstatus" pqstatus :: Ptr CConn -> IO #{type ConnStatusType} foreign import ccall unsafe "hdbc-postgresql-helper.h PQfinish_app" pqfinish :: Ptr WrappedCConn -> IO () foreign import ccall unsafe "hdbc-postgresql-helper.h &PQfinish_finalizer" pqfinishptr :: FunPtr (Ptr WrappedCConn -> IO ()) foreign import ccall unsafe "libpq-fe.h PQprotocolVersion" pqprotocolVersion :: Ptr CConn -> IO CInt foreign import ccall unsafe "libpq-fe.h PQserverVersion" pqserverVersion :: Ptr CConn -> IO CInt foreign import ccall unsafe "libpq.fe.h PQisthreadsafe" pqisThreadSafe :: Ptr CConn -> IO Int HDBC-postgresql-2.3.2.1/Database/HDBC/PostgreSQL/Utils.hsc0000644000000000000000000001047611724447761020777 0ustar0000000000000000{- -*- mode: haskell; -*- -} module Database.HDBC.PostgreSQL.Utils where import Foreign.C.String import Foreign.ForeignPtr import Foreign.Ptr import Database.HDBC(throwSqlError) import Database.HDBC.Types import Database.HDBC.PostgreSQL.Types import Control.Concurrent.MVar import Foreign.C.Types import Control.Exception import Foreign.Storable import Foreign.Marshal.Array import Foreign.Marshal.Alloc import Foreign.Marshal.Utils import Data.Word import qualified Data.ByteString.UTF8 as BUTF8 import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BCHAR8 #ifndef __HUGS__ -- Hugs includes this in Data.ByteString import qualified Data.ByteString.Unsafe as B #endif #include "hdbc-postgresql-helper.h" raiseError :: String -> Word32 -> (Ptr CConn) -> IO a raiseError msg code cconn = do rc <- pqerrorMessage cconn bs <- B.packCString rc let str = BUTF8.toString bs throwSqlError $ SqlError {seState = "", seNativeError = fromIntegral code, seErrorMsg = msg ++ ": " ++ str} {- This is a little hairy. We have a Conn object that is actually a finalizeonce wrapper around the real object. We use withConn to dereference the foreign pointer, and then extract the pointer to the real object from the finalizeonce struct. But, when we close the connection, we need the finalizeonce struct, so that's done by withRawConn. Ditto for statements. -} withConn :: Conn -> (Ptr CConn -> IO b) -> IO b withConn (_lock,conn) = genericUnwrap conn -- Perform the associated action with the connection lock held. -- Care must be taken with the use of this as it is *not* re-entrant. Calling it -- a second time in the same thread will cause dead-lock. -- (A better approach would be to use RLock from concurrent-extra) withConnLocked :: Conn -> (Ptr CConn -> IO b) -> IO b withConnLocked c@(lock,_) a = withConn c (\cconn -> withMVar lock (\_ -> a cconn)) withRawConn :: Conn -> (Ptr WrappedCConn -> IO b) -> IO b withRawConn (_lock,conn) = withForeignPtr conn withStmt :: Stmt -> (Ptr CStmt -> IO b) -> IO b withStmt = genericUnwrap withRawStmt :: Stmt -> (Ptr WrappedCStmt -> IO b) -> IO b withRawStmt = withForeignPtr withCStringArr0 :: [SqlValue] -> (Ptr CString -> IO a) -> IO a withCStringArr0 inp action = withAnyArr0 convfunc freefunc inp action where convfunc SqlNull = return nullPtr {- convfunc y@(SqlZonedTime _) = convfunc (SqlString $ "TIMESTAMP WITH TIME ZONE '" ++ fromSql y ++ "'") -} convfunc y@(SqlUTCTime _) = convfunc (SqlZonedTime (fromSql y)) convfunc y@(SqlEpochTime _) = convfunc (SqlZonedTime (fromSql y)) convfunc (SqlByteString x) = cstrUtf8BString (cleanUpBSNulls x) convfunc x = cstrUtf8BString (fromSql x) freefunc x = if x == nullPtr then return () else free x cleanUpBSNulls :: B.ByteString -> B.ByteString cleanUpBSNulls = B.concatMap convfunc where convfunc 0 = bsForNull convfunc x = B.singleton x bsForNull = BCHAR8.pack "\\000" withAnyArr0 :: (a -> IO (Ptr b)) -- ^ Function that transforms input data into pointer -> (Ptr b -> IO ()) -- ^ Function that frees generated data -> [a] -- ^ List of input data -> (Ptr (Ptr b) -> IO c) -- ^ Action to run with the C array -> IO c -- ^ Return value withAnyArr0 input2ptract freeact inp action = bracket (mapM input2ptract inp) (\clist -> mapM_ freeact clist) (\clist -> withArray0 nullPtr clist action) cstrUtf8BString :: B.ByteString -> IO CString cstrUtf8BString bs = do B.unsafeUseAsCStringLen bs $ \(s,len) -> do res <- mallocBytes (len+1) -- copy in copyBytes res s len -- null terminate poke (plusPtr res len) (0::CChar) -- return ptr return res genericUnwrap :: ForeignPtr (Ptr a) -> (Ptr a -> IO b) -> IO b genericUnwrap fptr action = withForeignPtr fptr (\structptr -> do objptr <- #{peek finalizeonce, encapobj} structptr action objptr ) foreign import ccall unsafe "libpq-fe.h PQerrorMessage" pqerrorMessage :: Ptr CConn -> IO CString HDBC-postgresql-2.3.2.1/Database/HDBC/PostgreSQL/Statement.hsc0000644000000000000000000003673511724447761021651 0ustar0000000000000000-- -*- mode: haskell; -*- {-# CFILES hdbc-postgresql-helper.c #-} -- Above line for hugs module Database.HDBC.PostgreSQL.Statement where import Database.HDBC.Types import Database.HDBC import Database.HDBC.PostgreSQL.Types import Database.HDBC.PostgreSQL.Utils import Foreign.C.Types import Foreign.ForeignPtr import Foreign.Ptr import Control.Concurrent.MVar import Foreign.C.String import Control.Monad import Data.List import Data.Word import Data.Ratio import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as BUTF8 import Database.HDBC.PostgreSQL.Parser(convertSQL) import Database.HDBC.DriverUtils import Database.HDBC.PostgreSQL.PTypeConv import Data.Time.Format import System.Locale l :: Monad m => t -> m () l _ = return () --l m = hPutStrLn stderr ("\n" ++ m) #include data SState = SState { stomv :: MVar (Maybe Stmt), nextrowmv :: MVar (CInt), -- -1 for no next row (empty); otherwise, next row to read. dbo :: Conn, squery :: String, coldefmv :: MVar [(String, SqlColDesc)]} -- FIXME: we currently do no prepare optimization whatsoever. newSth :: Conn -> ChildList -> String -> IO Statement newSth indbo mchildren query = do l "in newSth" newstomv <- newMVar Nothing newnextrowmv <- newMVar (-1) newcoldefmv <- newMVar [] usequery <- case convertSQL query of Left errstr -> throwSqlError $ SqlError {seState = "", seNativeError = (-1), seErrorMsg = "hdbc prepare: " ++ show errstr} Right converted -> return converted let sstate = SState {stomv = newstomv, nextrowmv = newnextrowmv, dbo = indbo, squery = usequery, coldefmv = newcoldefmv} let retval = Statement {execute = fexecute sstate, executeMany = fexecutemany sstate, executeRaw = fexecuteRaw sstate, finish = public_ffinish sstate, fetchRow = ffetchrow sstate, originalQuery = query, getColumnNames = fgetColumnNames sstate, describeResult = fdescribeResult sstate} addChild mchildren retval return retval fgetColumnNames :: SState -> IO [(String)] fgetColumnNames sstate = do c <- readMVar (coldefmv sstate) return (map fst c) fdescribeResult :: SState -> IO [(String, SqlColDesc)] fdescribeResult sstate = readMVar (coldefmv sstate) {- For now, we try to just handle things as simply as possible. FIXME lots of room for improvement here (types, etc). -} fexecute :: (Num a, Read a) => SState -> [SqlValue] -> IO a fexecute sstate args = withConnLocked (dbo sstate) $ \cconn -> B.useAsCString (BUTF8.fromString (squery sstate)) $ \cquery -> withCStringArr0 args $ \cargs -> -- wichSTringArr0 uses UTF-8 do l "in fexecute" public_ffinish sstate -- Sets nextrowmv to -1 resptr <- pqexecParams cconn cquery (genericLength args) nullPtr cargs nullPtr nullPtr 0 handleResultStatus cconn resptr sstate =<< pqresultStatus resptr {- | 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 = withConnLocked (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 cconn resptr sstate =<< pqresultStatus resptr :: IO Int return () handleResultStatus :: (Num a, Read a) => Ptr CConn -> WrappedCStmt -> SState -> ResultStatus -> IO a handleResultStatus cconn 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 _ | resptr == nullPtr -> do l $ "PGRES ERROR: " ++ squery sstate errormsg <- peekCStringUTF8 =<< pqerrorMessage cconn statusmsg <- peekCStringUTF8 =<< pqresStatus status throwSqlError $ SqlError { seState = "E" , seNativeError = fromIntegral status , seErrorMsg = "execute: " ++ statusmsg ++ ": " ++ errormsg} _ -> do l $ "PGRES ERROR: " ++ squery sstate errormsg <- peekCStringUTF8 =<< pqresultErrorMessage resptr statusmsg <- peekCStringUTF8 =<< pqresStatus status state <- peekCStringUTF8 =<< pqresultErrorField resptr #{const PG_DIAG_SQLSTATE} 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 | str == nullPtr = return "" | otherwise = 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. -} ffetchrow :: SState -> IO (Maybe [SqlValue]) ffetchrow sstate = modifyMVar (nextrowmv sstate) dofetchrow where dofetchrow (-1) = l "ffr -1" >> return ((-1), Nothing) dofetchrow nextrow = modifyMVar (stomv sstate) $ \stmt -> case stmt of Nothing -> l "ffr nos" >> return (stmt, ((-1), Nothing)) Just cmstmt -> withStmt cmstmt $ \cstmt -> do l $ "ffetchrow: " ++ show nextrow numrows <- pqntuples cstmt l $ "numrows: " ++ show numrows if nextrow >= numrows then do l "no more rows" -- Don't use public_ffinish here ffinish cmstmt return (Nothing, ((-1), Nothing)) else do l "getting stuff" ncols <- pqnfields cstmt res <- mapM (getCol cstmt nextrow) [0..(ncols - 1)] return (stmt, (nextrow + 1, Just res)) getCol p row icol = do isnull <- pqgetisnull p row icol if isnull /= 0 then return SqlNull else do text <- pqgetvalue p row icol coltype <- liftM oidToColType $ pqftype p icol s <- B.packCString text makeSqlValue coltype s fgetcoldef :: Ptr CStmt -> IO [(String, SqlColDesc)] fgetcoldef cstmt = do ncols <- pqnfields cstmt mapM desccol [0..(ncols - 1)] where desccol i = do colname <- peekCStringUTF8 =<< pqfname cstmt i coltype <- pqftype cstmt i --coloctets <- pqfsize let coldef = oidToColDef coltype return (colname, coldef) -- FIXME: needs a faster algorithm. fexecutemany :: SState -> [[SqlValue]] -> IO () fexecutemany sstate arglist = mapM_ (fexecute sstate :: [SqlValue] -> IO Int) arglist >> return () -- Finish and change state public_ffinish :: SState -> IO () public_ffinish sstate = do l "public_ffinish" _ <- swapMVar (nextrowmv sstate) (-1) modifyMVar_ (stomv sstate) worker where worker Nothing = return Nothing worker (Just sth) = ffinish sth >> return Nothing ffinish :: Stmt -> IO () ffinish p = withRawStmt p $ pqclear foreign import ccall unsafe "libpq-fe.h PQresultStatus" pqresultStatus :: (Ptr CStmt) -> IO #{type ExecStatusType} foreign import ccall safe "libpq-fe.h PQexecParams" pqexecParams :: (Ptr CConn) -> CString -> CInt -> (Ptr #{type Oid}) -> (Ptr CString) -> (Ptr CInt) -> (Ptr CInt) -> CInt -> IO (Ptr CStmt) foreign import ccall safe "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 () foreign import ccall unsafe "hdbc-postgresql-helper.h &PQclear_finalizer" pqclearptr :: FunPtr (Ptr WrappedCStmt -> IO ()) foreign import ccall unsafe "libpq-fe.h PQclear" pqclear_raw :: Ptr CStmt -> IO () foreign import ccall unsafe "hdbc-postgresql-helper.h wrapobjpg" wrapstmt :: Ptr CStmt -> Ptr WrappedCConn -> IO (Ptr WrappedCStmt) foreign import ccall unsafe "libpq-fe.h PQcmdTuples" pqcmdTuples :: Ptr CStmt -> IO CString foreign import ccall unsafe "libpq-fe.h PQresStatus" pqresStatus :: #{type ExecStatusType} -> IO CString 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 foreign import ccall unsafe "libpq-fe.h PQnfields" pqnfields :: Ptr CStmt -> IO CInt foreign import ccall unsafe "libpq-fe.h PQgetisnull" pqgetisnull :: Ptr CStmt -> CInt -> CInt -> IO CInt foreign import ccall unsafe "libpq-fe.h PQgetvalue" pqgetvalue :: Ptr CStmt -> CInt -> CInt -> IO CString foreign import ccall unsafe "libpq-fe.h PQfname" pqfname :: Ptr CStmt -> CInt -> IO CString foreign import ccall unsafe "libpq-fe.h PQftype" pqftype :: Ptr CStmt -> CInt -> IO #{type Oid} -- SqlValue construction function and helpers -- Make a SqlValue for the passed column type and string value, where it is assumed that the value represented is not the Sql null value. -- The IO Monad is required only to obtain the local timezone for interpreting date/time values without an explicit timezone. makeSqlValue :: SqlTypeId -> B.ByteString -> IO SqlValue makeSqlValue sqltypeid bstrval = let strval = BUTF8.toString bstrval in case sqltypeid of tid | tid == SqlCharT || tid == SqlVarCharT || tid == SqlLongVarCharT || tid == SqlWCharT || tid == SqlWVarCharT || tid == SqlWLongVarCharT -> return $ SqlByteString bstrval tid | tid == SqlDecimalT || tid == SqlNumericT -> return $ SqlRational (makeRationalFromDecimal strval) tid | tid == SqlSmallIntT || tid == SqlTinyIntT || tid == SqlIntegerT -> return $ SqlInt32 (read strval) SqlBigIntT -> return $ SqlInteger (read strval) tid | tid == SqlRealT || tid == SqlFloatT || tid == SqlDoubleT -> return $ SqlDouble (read strval) SqlBitT -> return $ case strval of 't':_ -> SqlBool True 'f':_ -> SqlBool False 'T':_ -> SqlBool True -- the rest of these are here "just in case", since they are legal as input 'y':_ -> SqlBool True 'Y':_ -> SqlBool True "1" -> SqlBool True _ -> SqlBool False -- Dates and Date/Times tid | tid == SqlDateT -> return $ SqlLocalDate (fromSql (toSql strval)) tid | tid == SqlTimestampWithZoneT -> return $ SqlZonedTime (fromSql (toSql (fixString strval))) -- SqlUTCDateTimeT not actually generated by PostgreSQL tid | tid == SqlTimestampT || tid == SqlUTCDateTimeT -> return $ SqlLocalTime (fromSql (toSql strval)) -- Times without dates tid | tid == SqlTimeT || tid == SqlUTCTimeT -> return $ SqlLocalTimeOfDay (fromSql (toSql strval)) tid | tid == SqlTimeWithZoneT -> (let (a, b) = case (parseTime defaultTimeLocale "%T%Q %z" timestr, parseTime defaultTimeLocale "%T%Q %z" timestr) of (Just x, Just y) -> (x, y) x -> error $ "PostgreSQL Statement.hsc: Couldn't parse " ++ strval ++ " as SqlZonedLocalTimeOfDay: " ++ show x timestr = fixString strval in return $ SqlZonedLocalTimeOfDay a b) SqlIntervalT _ -> return $ SqlDiffTime $ fromRational $ case split ':' strval of [h, m, s] -> toRational (((read h)::Integer) * 60 * 60 + ((read m)::Integer) * 60) + toRational ((read s)::Double) _ -> error $ "PostgreSQL Statement.hsc: Couldn't parse interval: " ++ strval -- TODO: For now we just map the binary types to SqlByteStrings. New SqlValue constructors are needed to handle these. tid | tid == SqlBinaryT || tid == SqlVarBinaryT || tid == SqlLongVarBinaryT -> return $ SqlByteString bstrval SqlGUIDT -> return $ SqlByteString bstrval SqlUnknownT _ -> return $ SqlByteString bstrval _ -> error $ "PostgreSQL Statement.hsc: unknown typeid: " ++ show sqltypeid -- Convert "15:33:01.536+00" to "15:33:01.536 +0000" fixString :: String -> String fixString s = let (strbase, zone) = splitAt (length s - 3) s in if (head zone) == '-' || (head zone) == '+' then strbase ++ " " ++ zone ++ "00" else -- It wasn't in the expected format; don't touch. s -- Make a rational number from a decimal string representation of the number. makeRationalFromDecimal :: String -> Rational makeRationalFromDecimal s = case elemIndex '.' s of Nothing -> toRational ((read s)::Integer) Just dotix -> let (nstr,'.':dstr) = splitAt dotix s num = (read $ nstr ++ dstr)::Integer den = 10^((genericLength dstr) :: Integer) in num % den split :: Char -> String -> [String] split delim inp = lines . map (\x -> if x == delim then '\n' else x) $ inp HDBC-postgresql-2.3.2.1/Database/HDBC/PostgreSQL/ErrorCodes.hs0000644000000000000000000004536311724447761021606 0ustar0000000000000000-- 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" HDBC-postgresql-2.3.2.1/Database/HDBC/PostgreSQL/PTypeConv.hsc0000644000000000000000000000632511724447761021564 0ustar0000000000000000-- -*- mode: haskell; -*- module Database.HDBC.PostgreSQL.PTypeConv where import Database.HDBC.ColTypes import Data.Word #include "pgtypes.h" #include colDescForPGAttr :: #{type Oid} -> Int -> String -> Bool -> SqlColDesc colDescForPGAttr atttypeid attlen formattedtype attnotnull = let coltype = oidToColType atttypeid size = if attlen == -1 then maybeExtractFirstParenthesizedNumber formattedtype else Just attlen decDigs = if coltype == SqlNumericT then maybeExtractSecondParenthesizedNumber formattedtype else Nothing in SqlColDesc { colType = coltype, colSize = size, colOctetLength = Nothing, -- not available in postgres colDecDigits = decDigs, colNullable = Just attnotnull } where maybeExtractFirstParenthesizedNumber s = case extractParenthesizedInts s of n:_ -> Just n; _ -> Nothing maybeExtractSecondParenthesizedNumber s = case extractParenthesizedInts s of _:n2:_ -> Just n2; _ -> Nothing extractParenthesizedInts :: String -> [Int] extractParenthesizedInts s = case takeWhile (/=')') $ dropWhile (/='(') s of '(':textBetweenParens -> case map fst $ reads $ "[" ++ textBetweenParens ++ "]" of l:_ -> l [] -> [] _ -> [] oidToColDef :: #{type Oid} -> SqlColDesc oidToColDef oid = SqlColDesc {colType = (oidToColType oid), colSize = Nothing, colOctetLength = Nothing, colDecDigits = Nothing, colNullable = Nothing} oidToColType :: #{type Oid} -> SqlTypeId oidToColType oid = case oid of #{const PG_TYPE_CHAR} -> SqlCharT #{const PG_TYPE_CHAR2} -> SqlCharT #{const PG_TYPE_CHAR4} -> SqlCharT #{const PG_TYPE_CHAR8} -> SqlCharT #{const PG_TYPE_NAME} -> SqlVarCharT #{const PG_TYPE_BPCHAR} -> SqlCharT #{const PG_TYPE_VARCHAR} -> SqlVarCharT #{const PG_TYPE_TEXT} -> SqlVarCharT #{const PG_TYPE_XML} -> SqlVarCharT #{const PG_TYPE_BYTEA} -> SqlVarBinaryT #{const PG_TYPE_INT2} -> SqlSmallIntT #{const PG_TYPE_OID} -> SqlIntegerT #{const PG_TYPE_XID} -> SqlIntegerT #{const PG_TYPE_INT4} -> SqlBigIntT #{const PG_TYPE_INT8} -> SqlBigIntT #{const PG_TYPE_NUMERIC} -> SqlNumericT #{const PG_TYPE_FLOAT4} -> SqlRealT #{const PG_TYPE_FLOAT8} -> SqlFloatT #{const PG_TYPE_DATE} -> SqlDateT #{const PG_TYPE_ABSTIME} -> SqlTimestampWithZoneT #{const PG_TYPE_DATETIME} -> SqlTimestampWithZoneT #{const PG_TYPE_TIMESTAMP_NO_TMZONE} -> SqlTimestampT #{const PG_TYPE_TIMESTAMP} -> SqlTimestampT #{const PG_TYPE_TIME} -> SqlTimeT #{const PG_TYPE_TIME_WITH_TMZONE} -> SqlTimeWithZoneT #{const PG_TYPE_TINTERVAL} -> SqlIntervalT SqlIntervalMonthT -- SqlIntervalMonthT chosen arbitrarily in these two. PG allows any parts #{const PG_TYPE_RELTIME} -> SqlIntervalT SqlIntervalMonthT -- of an interval (microsecond to millennium) to be specified together. 1186 -> SqlIntervalT SqlIntervalMonthT #{const PG_TYPE_BOOL} -> SqlBitT x -> SqlUnknownT (show x) HDBC-postgresql-2.3.2.1/Database/HDBC/PostgreSQL/ConnectionImpl.hs0000644000000000000000000000252611724447761022452 0ustar0000000000000000module Database.HDBC.PostgreSQL.ConnectionImpl where import qualified Database.HDBC.Types as Types import Database.HDBC.ColTypes as ColTypes data Connection = Connection { disconnect :: IO (), begin :: IO (), commit :: IO (), rollback :: IO (), runRaw :: String -> IO (), run :: String -> [Types.SqlValue] -> IO Integer, prepare :: String -> IO Types.Statement, clone :: IO Connection, hdbcDriverName :: String, hdbcClientVer :: String, proxiedClientName :: String, proxiedClientVer :: String, dbServerVer :: String, dbTransactionSupport :: Bool, getTables :: IO [String], describeTable :: String -> IO [(String, ColTypes.SqlColDesc)] } instance Types.IConnection Connection where disconnect = disconnect commit = commit rollback = rollback runRaw = runRaw run = run prepare = prepare clone = clone hdbcDriverName = hdbcDriverName hdbcClientVer = hdbcClientVer proxiedClientName = proxiedClientName proxiedClientVer = proxiedClientVer dbServerVer = dbServerVer dbTransactionSupport = dbTransactionSupport getTables = getTables describeTable = describeTable HDBC-postgresql-2.3.2.1/Database/HDBC/PostgreSQL/Types.hs0000644000000000000000000000051011724447761020624 0ustar0000000000000000module Database.HDBC.PostgreSQL.Types where import Foreign import Control.Concurrent.MVar type ConnLock = MVar () data CConn = CConn type WrappedCConn = Ptr CConn type Conn = (ConnLock, ForeignPtr WrappedCConn) data CStmt = CStmt type WrappedCStmt = Ptr CStmt type Stmt = ForeignPtr WrappedCStmt type ResultStatus = Word32 HDBC-postgresql-2.3.2.1/Database/HDBC/PostgreSQL/Parser.hs0000644000000000000000000000403611724447761020763 0ustar0000000000000000{- -*- mode: haskell; -*- -} {- PostgreSQL uses $1, $2, etc. instead of ? in query strings. So we have to do some basic parsing on these things to fix 'em up. -} module Database.HDBC.PostgreSQL.Parser where import Text.ParserCombinators.Parsec escapeseq :: GenParser Char st String escapeseq = (try $ string "''") <|> (try $ string "\\'") literal :: GenParser Char st [Char] literal = do _ <- char '\'' s <- many (escapeseq <|> (noneOf "'" >>= (\x -> return [x]))) _ <- char '\'' return $ "'" ++ (concat s) ++ "'" qidentifier :: GenParser Char st [Char] qidentifier = do _ <- char '"' s <- many (noneOf "\"") _ <- char '"' return $ "\"" ++ s ++ "\"" comment :: GenParser Char st [Char] comment = ccomment <|> linecomment ccomment :: GenParser Char st [Char] ccomment = do _ <- string "/*" c <- manyTill ((try ccomment) <|> (anyChar >>= (\x -> return [x]))) (try (string "*/")) return $ "/*" ++ concat c ++ "*/" linecomment :: GenParser Char st [Char] linecomment = do _ <- string "--" c <- many (noneOf "\n") _ <- char '\n' return $ "--" ++ c ++ "\n" -- FIXME: handle pgsql dollar-quoted constants qmark :: (Num st, Show st) => GenParser Char st [Char] qmark = do _ <- char '?' n <- getState updateState (+1) return $ "$" ++ show n escapedQmark :: GenParser Char st [Char] escapedQmark = do _ <- try (char '\\' >> char '?') return "?" statement :: (Num st, Show st) => GenParser Char st [Char] statement = do s <- many ((try escapedQmark) <|> (try qmark) <|> (try comment) <|> (try literal) <|> (try qidentifier) <|> (anyChar >>= (\x -> return [x]))) return $ concat s convertSQL :: String -> Either ParseError String convertSQL input = runParser statement (1::Integer) "" input