HDBC-postgresql 1.1.3.0 → 1.1.4.0
raw patch · 8 files changed
+994/−22 lines, 8 filesdep +old-timedep ~basesetup-changed
Dependencies added: old-time
Dependency ranges changed: base
Files
- Database/HDBC/PostgreSQL/Connection.hs +168/−0
- Database/HDBC/PostgreSQL/PTypeConv.hs +136/−0
- Database/HDBC/PostgreSQL/Statement.hs +443/−0
- Database/HDBC/PostgreSQL/Utils.hs +99/−0
- HDBC-postgresql.cabal +30/−20
- Setup.lhs +36/−2
- hdbc-postgresql-helper.h +16/−0
- pgtypes.h +66/−0
+ Database/HDBC/PostgreSQL/Connection.hs view
@@ -0,0 +1,168 @@+{-# OPTIONS_GHC -optc-D__HUGS__ #-}+{-# INCLUDE <libpq-fe.h> #-}+{-# INCLUDE <pg_config.h> #-}+{-# LINE 1 "Database/HDBC/PostgreSQL/Connection.hsc" #-}+-- -*- mode: haskell; -*-+{-# LINE 2 "Database/HDBC/PostgreSQL/Connection.hsc" #-}+{-# CFILES hdbc-postgresql-helper.c #-}+-- Above line for hugs+{-+Copyright (C) 2005-2006 John Goerzen <jgoerzen@complete.org>++ This library is free software; you can redistribute it and/or+ modify it under the terms of the GNU Lesser General Public+ License as published by the Free Software Foundation; either+ version 2.1 of the License, or (at your option) any later version.++ This library 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+ Lesser General Public License for more details.++ You should have received a copy of the GNU Lesser General Public+ License along with this library; if not, write to the Free Software+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA+-}++module Database.HDBC.PostgreSQL.Connection+ (connectPostgreSQL, Impl.Connection())+ where++import Database.HDBC.Types+import Database.HDBC+import Database.HDBC.DriverUtils+import Database.HDBC.ColTypes+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 Foreign.Marshal+import Foreign.Storable+import Database.HDBC.PostgreSQL.Utils+import Foreign.ForeignPtr+import Foreign.Ptr+import Data.Word+import Data.Maybe+import Control.Concurrent.MVar+++{-# LINE 46 "Database/HDBC/PostgreSQL/Connection.hsc" #-}++{-# LINE 47 "Database/HDBC/PostgreSQL/Connection.hsc" #-}++{- | Connect to a PostgreSQL server.++See <http://www.postgresql.org/docs/8.1/static/libpq.html#LIBPQ-CONNECT> for the meaning+of the connection string. -}+connectPostgreSQL :: String -> IO Impl.Connection+connectPostgreSQL args = withCString args $+ \cs -> do ptr <- pqconnectdb cs+ status <- pqstatus ptr+ wrappedptr <- wrapconn ptr nullPtr+ fptr <- newForeignPtr pqfinishptr wrappedptr+ case status of+ 0 -> mkConn args fptr+{-# LINE 60 "Database/HDBC/PostgreSQL/Connection.hsc" #-}+ _ -> raiseError "connectPostgreSQL" status ptr++-- FIXME: environment vars may have changed, should use pgsql enquiries+-- for clone.+mkConn :: String -> Conn -> IO Impl.Connection+mkConn args conn = withConn conn $+ \cconn -> + do children <- newMVar []+ begin_transaction conn children+ protover <- pqprotocolVersion cconn+ serverver <- pqserverVersion cconn+ let clientver = "8.2.5"+{-# LINE 72 "Database/HDBC/PostgreSQL/Connection.hsc" #-}+ return $ Impl.Connection {+ Impl.disconnect = fdisconnect conn children,+ Impl.commit = fcommit conn children,+ Impl.rollback = frollback 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}++--------------------------------------------------+-- Guts here+--------------------------------------------------++begin_transaction :: Conn -> ChildList -> IO ()+begin_transaction o children = frun o children "BEGIN" [] >> return ()++frun o children query args =+ do sth <- newSth o children query+ res <- execute sth args+ finish sth+ return res++fcommit o cl = do frun o cl "COMMIT" []+ begin_transaction o cl+frollback o cl = do frun o cl "ROLLBACK" []+ begin_transaction o cl++fgetTables conn children =+ do sth <- newSth conn children "select table_name from information_schema.tables where table_schema = 'public'"+ execute sth []+ res1 <- fetchAllRows' sth+ let res = map fromSql $ concat res1+ return $ seq (length res) res++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 == 'f'))+ desccol x =+ error $ "Got unexpected result from pg_attribute: " ++ show x+ ++fdisconnect conn mchildren = + do closeAllChildren mchildren+ withRawConn conn $ pqfinish++foreign import ccall unsafe "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 Word32+{-# LINE 147 "Database/HDBC/PostgreSQL/Connection.hsc" #-}++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
+ Database/HDBC/PostgreSQL/PTypeConv.hs view
@@ -0,0 +1,136 @@+{-# OPTIONS_GHC -optc-D__HUGS__ #-}+{-# INCLUDE "pgtypes.h" #-}+{-# INCLUDE <libpq-fe.h> #-}+{-# LINE 1 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+-- -*- mode: haskell; -*-+{-# LINE 2 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+{-+Copyright (C) 2006 John Goerzen <jgoerzen@complete.org>++ This library is free software; you can redistribute it and/or+ modify it under the terms of the GNU Lesser General Public+ License as published by the Free Software Foundation; either+ version 2.1 of the License, or (at your option) any later version.++ This library 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+ Lesser General Public License for more details.++ You should have received a copy of the GNU Lesser General Public+ License along with this library; if not, write to the Free Software+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA+-}++module Database.HDBC.PostgreSQL.PTypeConv where+import Database.HDBC.ColTypes+import Data.Word+import Data.Int+++{-# LINE 26 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}++{-# LINE 27 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+++colDescForPGAttr :: Word32 -> Int -> String -> Bool -> SqlColDesc+{-# LINE 30 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+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 n1:n2:_ -> Just n2; _ -> Nothing++ extractParenthesizedInts :: String -> [Int]+ extractParenthesizedInts s =+ case takeWhile (/=')') $ dropWhile (/='(') s of+ '(':textBetweenParens ->+ case map fst $ reads $ "[" ++ textBetweenParens ++ "]" of+ l:_ -> l+ [] -> []+ _ -> []++++oidToColDef :: Word32 -> SqlColDesc+{-# LINE 62 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+oidToColDef oid =+ SqlColDesc {colType = (oidToColType oid),+ colSize = Nothing,+ colOctetLength = Nothing,+ colDecDigits = Nothing,+ colNullable = Nothing}++oidToColType :: Word32 -> SqlTypeId+{-# LINE 70 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+oidToColType oid =+ case oid of+ 18 -> SqlCharT+{-# LINE 73 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 409 -> SqlCharT+{-# LINE 74 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 410 -> SqlCharT+{-# LINE 75 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 411 -> SqlCharT+{-# LINE 76 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 19 -> SqlVarCharT+{-# LINE 77 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 1042 -> SqlCharT+{-# LINE 78 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 1043 -> SqlVarCharT+{-# LINE 79 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 25 -> SqlVarCharT+{-# LINE 80 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 17 -> SqlVarBinaryT+{-# LINE 81 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 21 -> SqlSmallIntT+{-# LINE 82 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 26 -> SqlIntegerT+{-# LINE 83 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 28 -> SqlIntegerT+{-# LINE 84 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 23 -> SqlBigIntT+{-# LINE 85 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 20 -> SqlBigIntT+{-# LINE 86 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 1700 -> SqlNumericT+{-# LINE 87 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 700 -> SqlRealT+{-# LINE 88 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 701 -> SqlFloatT+{-# LINE 89 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 1082 -> SqlDateT+{-# LINE 90 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 702 -> SqlTimestampT+{-# LINE 91 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 1184 -> SqlTimestampT+{-# LINE 92 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 1114 -> SqlTimestampT+{-# LINE 93 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 1296 -> SqlTimestampT+{-# LINE 94 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 1083 -> SqlTimeT+{-# LINE 95 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 1266 -> SqlTimeT+{-# LINE 96 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 704 -> SqlIntervalT SqlIntervalMonthT -- SqlIntervalMonthT chosen arbitrarily in these two. PG allows any parts+{-# LINE 97 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 703 -> SqlIntervalT SqlIntervalMonthT -- of an interval (microsecond to millennium) to be specified together.+{-# LINE 98 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ 16 -> SqlBitT+{-# LINE 99 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-}+ x -> SqlUnknownT (show x)
+ Database/HDBC/PostgreSQL/Statement.hs view
@@ -0,0 +1,443 @@+{-# OPTIONS_GHC -optc-D__HUGS__ #-}+{-# INCLUDE <libpq-fe.h> #-}+{-# LINE 1 "Database/HDBC/PostgreSQL/Statement.hsc" #-}+-- -*- mode: haskell; -*-+{-# LINE 2 "Database/HDBC/PostgreSQL/Statement.hsc" #-}+{-# CFILES hdbc-postgresql-helper.c #-}+-- Above line for hugs+{-+Copyright (C) 2005 John Goerzen <jgoerzen@complete.org>++ This library is free software; you can redistribute it and/or+ modify it under the terms of the GNU Lesser General Public+ License as published by the Free Software Foundation; either+ version 2.1 of the License, or (at your option) any later version.++ This library 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+ Lesser General Public License for more details.++ You should have received a copy of the GNU Lesser General Public+ License along with this library; if not, write to the Free Software+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA+-}+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 Foreign.Marshal+import Foreign.Storable+import Control.Monad+import Data.List+import Data.Word+import Data.Maybe+import Data.Ratio+import Control.Exception+import System.IO+import System.Time+import Database.HDBC.PostgreSQL.Parser(convertSQL)+import Database.HDBC.DriverUtils+import Database.HDBC.PostgreSQL.PTypeConv++l _ = return ()+--l m = hPutStrLn stderr ("\n" ++ m)+++{-# LINE 49 "Database/HDBC/PostgreSQL/Statement.hsc" #-}++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 -> throwDyn $ 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,+ finish = public_ffinish sstate,+ fetchRow = ffetchrow sstate,+ originalQuery = query,+ getColumnNames = fgetColumnNames sstate,+ describeResult = fdescribeResult sstate}+ addChild mchildren retval+ return retval++fgetColumnNames sstate = + do c <- readMVar (coldefmv sstate)+ return (map fst c)++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 sstate args = withConn (dbo sstate) $ \cconn ->+ withCString (squery sstate) $ \cquery ->+ withCStringArr0 args $ \cargs ->+ do l "in fexecute"+ public_ffinish sstate -- Sets nextrowmv to -1+ resptr <- pqexecParams cconn cquery+ (genericLength args) nullPtr cargs nullPtr nullPtr 0+ status <- pqresultStatus resptr+ case status of+ 0 ->+{-# LINE 105 "Database/HDBC/PostgreSQL/Statement.hsc" #-}+ do l $ "PGRES_EMPTY_QUERY: " ++ squery sstate+ pqclear_raw resptr+ swapMVar (coldefmv sstate) []+ return 0+ 1 ->+{-# LINE 110 "Database/HDBC/PostgreSQL/Statement.hsc" #-}+ 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+ 2 -> +{-# LINE 119 "Database/HDBC/PostgreSQL/Statement.hsc" #-}+ 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+ statusmsg <- peekCString csstatusmsg+ errormsg <- peekCString cserrormsg+ pqclear_raw resptr+ throwDyn $ + SqlError {seState = "",+ seNativeError = fromIntegral status,+ seErrorMsg = "execute: " ++ statusmsg +++ ": " ++ errormsg}+{- 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 <- peekCString text+ makeSqlValue coltype s++fgetcoldef cstmt =+ do ncols <- pqnfields cstmt+ mapM desccol [0..(ncols - 1)]+ where desccol i =+ do colname <- (pqfname cstmt i >>= peekCString)+ 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) arglist >> return ()++-- Finish and change state+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 Word32+{-# LINE 204 "Database/HDBC/PostgreSQL/Statement.hsc" #-}++foreign import ccall unsafe "libpq-fe.h PQexecParams"+ pqexecParams :: (Ptr CConn) -> CString -> CInt ->+ (Ptr Word32) ->+{-# LINE 208 "Database/HDBC/PostgreSQL/Statement.hsc" #-}+ (Ptr CString) ->+ (Ptr CInt) ->+ (Ptr CInt) ->+ CInt ->+ 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 :: Word32 -> IO CString+{-# LINE 230 "Database/HDBC/PostgreSQL/Statement.hsc" #-}++foreign import ccall unsafe "libpq-fe.h PQresultErrorMessage"+ pqresultErrorMessage :: (Ptr CStmt) -> 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 Word32+{-# LINE 251 "Database/HDBC/PostgreSQL/Statement.hsc" #-}++++-- 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 -> String -> IO SqlValue+makeSqlValue sqltypeid strval =++ case sqltypeid of ++ tid | tid == SqlCharT ||+ tid == SqlVarCharT ||+ tid == SqlLongVarCharT ||+ tid == SqlWCharT ||+ tid == SqlWVarCharT ||+ tid == SqlWLongVarCharT -> return $ SqlString strval++ 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 ||+ tid == SqlTimestampT ||+ tid == SqlUTCDateTimeT ->+ do+ clockTime <- clockTimeFromISODateAndMaybeTime strval+ + case clockTime of TOD epochSecs picos -> return $ SqlEpochTime epochSecs+++ -- Times without dates+ tid | tid == SqlTimeT || + tid == SqlUTCTimeT -> return $ SqlTimeDiff $ secsTimeDiffFromISOTime strval+ + -- TODO: There's no proper way to map intervals as understood by postgres currently so we resort to SqlString. + -- E.g. a "1 month" interval is not a specific span of time that could be converted to a SqlTimeDiff.+ -- A new SqlValue constructor would be needed (wrapping System.Time.TimeDiff) to really handle intervals properly.+ SqlIntervalT si -> return $ SqlString strval+ + -- TODO: For now we just map the binary types to SqlStrings. New SqlValue constructors are needed to handle these.+ tid | tid == SqlBinaryT ||+ tid == SqlVarBinaryT || + tid == SqlLongVarBinaryT -> return $ SqlString strval++ SqlGUIDT -> return $ SqlString strval++ SqlUnknownT s -> return $ SqlString strval+++-- 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+++-- Creates a ClockTime from an ISO-8601 representation of a date or date/time with optional numeric timezone, as output by Postgres.+-- The IO monad is required because local timezone information may need to be fetched if not provided in the input string.+clockTimeFromISODateAndMaybeTime :: String -> IO ClockTime+clockTimeFromISODateAndMaybeTime datestr =+ let+ (y, '-':month_etc) = head $ reads datestr+ (mo, '-':day_etc) = head $ reads month_etc+ (d, maybeTime) = head $ reads day_etc+ hourParses = reads maybeTime+ (h, min_etc) = if not (null hourParses) then head hourParses else (0,"")+ (min, sec_etc) = if not (null $ drop 1 min_etc) then head $ reads (drop 1 min_etc) else (0,"")+ (sec, maybeTZ) = if not (null $ drop 1 sec_etc) then head $ reads (drop 1 sec_etc) else (0,"")+ tzParses = reads maybeTZ+ in+ do+ tzoff <- if not $ null tzParses then return $ 3600 * (fst $ head $ tzParses) else getLocalTimeZoneOffsetSecsForDateTime y mo d h min sec++ if null hourParses + then + return $ toClockTime $ makeCalendarTimeForDate y mo d tzoff+ else+ return $ toClockTime $ makeCalendarTimeForDateTime y mo d h min sec tzoff++ where+ makeCalendarTimeForDate :: Int -> Int -> Int -> Int -> CalendarTime+ makeCalendarTimeForDate year mon day tzoff =+ CalendarTime { ctYear = year, ctMonth = makeMonth mon, ctDay = day, + ctHour = 0, ctMin = 0, ctSec = 0, ctPicosec = 0, + ctWDay = Sunday, ctYDay = 0, -- bogus but ignored when converting to ClockTime according to the docs in System.Time+ ctTZName = "",+ ctTZ = tzoff,+ ctIsDST = False -- bogus but ignored when converting to ClockTime+ }++ makeCalendarTimeForDateTime :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> CalendarTime+ makeCalendarTimeForDateTime year mon day hour min sec tzoff =+ CalendarTime { ctYear = year, ctMonth = makeMonth mon, ctDay = day, ctHour = hour, ctMin = min, ctSec = sec,+ ctPicosec = 0, + ctWDay = Sunday, ctYDay = 0, -- bogus but ignored when converting to ClockTime+ ctTZName = "",+ ctTZ = tzoff,+ ctIsDST = False -- bogus but ignored when converting to ClockTime+ }++ -- Convert 1->Jan, 2->Feb etc as commonly done on planet Earth (what's with the Month enum instance in System.Time ?)+ makeMonth :: Int -> Month+ makeMonth monNum = toEnum (monNum - 1)+++ getLocalTimeZoneOffsetSecsForDateTime :: Int -> Int -> Int -> Int -> Int -> Int -> IO Int + getLocalTimeZoneOffsetSecsForDateTime y mo d h min s =+ do+ -- Convert nominal day and time at GMT to our location to get first guess of our tz offset at required date and time+ approxLocalCalTime <- toLocalCalTime (makeCalendarTimeForDateTime y mo d h min s 0)+ + -- First guess of the proper timezon offset for this date and time in our location.+ let firstGuess = makeCalendarTimeForDateTime y mo d h min s (ctTZ approxLocalCalTime)+ + -- Allow up to 6 hours for date/time dependent timezone offset adjustments (Usually should be 0,1, or -1 depending on daylight savings time).+ let adjustments = map (3600*) $ [0,-1,1] ++ [2..6] ++ [-2,-3..(-6)]++ let adjustedCalTimes = map (\adj -> firstGuess { ctTZ = ctTZ firstGuess + adj }) adjustments+ + successList <- mapM isFixedPointUnderConversionToLocalTime adjustedCalTimes++ case elemIndex True successList of+ Nothing -> error $ "Could not find proper timezone for date: " ++ + show y ++ "-" ++ show mo ++ "-" ++ show d ++ " " ++ show h ++ ":" ++ show min ++ ":" ++ show s+ Just ix -> return (ctTZ $ adjustedCalTimes!!ix)+ where+ toLocalCalTime :: CalendarTime -> IO CalendarTime+ toLocalCalTime calTime = toCalendarTime $ toClockTime calTime+ + isFixedPointUnderConversionToLocalTime :: CalendarTime -> IO Bool+ isFixedPointUnderConversionToLocalTime calTime =+ do+ calTime' <- toLocalCalTime calTime+ return $ eqParts calTime calTime'++ eqParts :: CalendarTime -> CalendarTime -> Bool+ eqParts calTime1 calTime2 = ctHour calTime1 == ctHour calTime2 &&+ ctMin calTime1 == ctMin calTime2 &&+ ctSec calTime1 == ctSec calTime2 &&+ ctDay calTime1 == ctDay calTime2 &&+ ctMonth calTime1 == ctMonth calTime2 &&+ ctYear calTime1 == ctYear calTime2++++-- Time values (without dates) are represented as a seconds count+secsTimeDiffFromISOTime :: String -> Integer+secsTimeDiffFromISOTime timestr =+ let+ (h, min_etc) = head $ reads timestr+ (min, sec_etc) = if null min_etc || min_etc == ":" then (0,":0") else head $ reads (tail min_etc)+ (sec, _) = if null sec_etc || sec_etc == ":" then (0,"") else head $ reads (tail sec_etc)+ in+ h * 3600 + 60 * min + sec
+ Database/HDBC/PostgreSQL/Utils.hs view
@@ -0,0 +1,99 @@+{-# OPTIONS_GHC -optc-D__HUGS__ #-}+{-# INCLUDE "hdbc-postgresql-helper.h" #-}+{-# LINE 1 "Database/HDBC/PostgreSQL/Utils.hsc" #-}+{- -*- mode: haskell; -*- +{-# LINE 2 "Database/HDBC/PostgreSQL/Utils.hsc" #-}+Copyright (C) 2005 John Goerzen <jgoerzen@complete.org>++ This library is free software; you can redistribute it and/or+ modify it under the terms of the GNU Lesser General Public+ License as published by the Free Software Foundation; either+ version 2.1 of the License, or (at your option) any later version.++ This library 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+ Lesser General Public License for more details.++ You should have received a copy of the GNU Lesser General Public+ License along with this library; if not, write to the Free Software+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA+-}++module Database.HDBC.PostgreSQL.Utils where+import Foreign.C.String+import Foreign.ForeignPtr+import Foreign.Ptr+import Database.HDBC.Types+import Database.HDBC.PostgreSQL.Types+import Foreign.C.Types+import Control.Exception+import Foreign.Storable+import Foreign.Marshal.Array+import Foreign.Marshal.Alloc+import Data.Word+++{-# LINE 33 "Database/HDBC/PostgreSQL/Utils.hsc" #-}++raiseError :: String -> Word32 -> (Ptr CConn) -> IO a+raiseError msg code cconn =+ do rc <- pqerrorMessage cconn+ str <- peekCString rc+ throwDyn $ 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 = genericUnwrap++withRawConn :: Conn -> (Ptr WrappedCConn -> IO b) -> IO b+withRawConn = withForeignPtr++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 x = newCString (fromSql x)+ freefunc x =+ if x == nullPtr+ then return ()+ else free x++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)+++genericUnwrap :: ForeignPtr (Ptr a) -> (Ptr a -> IO b) -> IO b+genericUnwrap fptr action = withForeignPtr fptr (\structptr ->+ do objptr <- (\hsc_ptr -> peekByteOff hsc_ptr 0) structptr+{-# LINE 88 "Database/HDBC/PostgreSQL/Utils.hsc" #-}+ action objptr+ )+ +foreign import ccall unsafe "libpq-fe.h PQerrorMessage"+ pqerrorMessage :: Ptr CConn -> IO CString+
HDBC-postgresql.cabal view
@@ -1,30 +1,40 @@-Extra-Libraries: pq-include-dirs: /usr/include/postgresql, .--- extra-lib-dirs: Name: HDBC-postgresql-Version: 1.1.3.0+Version: 1.1.4.0 License: LGPL Maintainer: John Goerzen <jgoerzen@complete.org> Author: John Goerzen-Copyright: Copyright (c) 2005-2007 John Goerzen+Copyright: Copyright (c) 2005-2008 John Goerzen license-file: COPYRIGHT-extra-source-files: COPYING+extra-source-files: COPYING, hdbc-postgresql-helper.h, pgtypes.h homepage: http://software.complete.org/hdbc-postgres Category: Database synopsis: PostgreSQL driver for HDBC Description: This package provides a PostgreSQL driver for HDBC Stability: Stable-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---Extensions: ExistentialQuantification, AllowOverlappingInstances,--- AllowUndecidableInstances, CPP-Extensions: ExistentialQuantification-Build-Depends: base, mtl, HDBC>=1.1.0, parsec-GHC-Options: -O2-C-Sources: hdbc-postgresql-helper.c++Build-Type: Custom+Cabal-Version: >=1.2 && < 1.3++Flag splitBase+ description: Choose the new smaller, split-up package.++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+ --Extensions: ExistentialQuantification, AllowOverlappingInstances,+ -- AllowUndecidableInstances, CPP+ Extensions: ExistentialQuantification, ForeignFunctionInterface+ Build-Depends: base, mtl, HDBC>=1.1.0, parsec+ if flag(splitBase)+ Build-Depends: base >= 3, old-time+ else+ Build-Depends: base < 3+ Extra-Libraries: pq+ C-Sources: hdbc-postgresql-helper.c+ Include-Dirs: .
Setup.lhs view
@@ -1,6 +1,40 @@ #!/usr/bin/env runhaskell -> import Distribution.Simple+\begin{code}+import Distribution.PackageDescription+import Distribution.Simple+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Program+import qualified Distribution.Verbosity as Verbosity -> main = defaultMain+main = defaultMainWithHooks defaultUserHooks {+ hookedPrograms = [pgConfigProgram],+ postConf=configure+ } +pgConfigProgram = (simpleProgram "pg_config") {+ programFindVersion = findProgramVersion "--version" $ \str ->+ -- Invoking "pg_config --version" gives a string like "PostgreSQL 8.0.13"+ case words str of+ (_:ver:_) -> ver+ _ -> ""+}++configure _ _ _ lbi = do+ mb_bi <- pgConfigBuildInfo Verbosity.normal lbi+ writeHookedBuildInfo "HDBC-postgresql.buildinfo" (mb_bi,[])+\end{code}++Populate BuildInfo using pg_config tool.+\begin{code}+pgConfigBuildInfo verbosity lbi = do+ (pgConfigProg, _) <- requireProgram verbosity pgConfigProgram+ (orLaterVersion $ Version [8] []) (withPrograms lbi)+ let pg_config = rawSystemProgramStdout verbosity pgConfigProg+ libDir <- pg_config ["--libdir"]+ incDir <- pg_config ["--includedir"]+ return $ Just emptyBuildInfo {+ extraLibDirs = lines libDir,+ includeDirs = lines incDir+ }+\end{code}
+ hdbc-postgresql-helper.h view
@@ -0,0 +1,16 @@+#include <libpq-fe.h>++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);
+ pgtypes.h view
@@ -0,0 +1,66 @@+/* 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 */+++#if 0+#define PG_TYPE_LO ???? /* waiting for permanent type */+#endif++#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_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_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_OIDINT4 910+#define PG_TYPE_OIDNAME 911+#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 INTERNAL_ASIS_TYPE (-9999)++#endif