diff --git a/Database/HDBC/PostgreSQL/Connection.hs b/Database/HDBC/PostgreSQL/Connection.hs new file mode 100644 --- /dev/null +++ b/Database/HDBC/PostgreSQL/Connection.hs @@ -0,0 +1,168 @@ +{-# OPTIONS_GHC -optc-D__HUGS__ #-} +{-# INCLUDE #-} +{-# INCLUDE #-} +{-# 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 + + 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 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 diff --git a/Database/HDBC/PostgreSQL/PTypeConv.hs b/Database/HDBC/PostgreSQL/PTypeConv.hs new file mode 100644 --- /dev/null +++ b/Database/HDBC/PostgreSQL/PTypeConv.hs @@ -0,0 +1,136 @@ +{-# OPTIONS_GHC -optc-D__HUGS__ #-} +{-# INCLUDE "pgtypes.h" #-} +{-# INCLUDE #-} +{-# LINE 1 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-} +-- -*- mode: haskell; -*- +{-# LINE 2 "Database/HDBC/PostgreSQL/PTypeConv.hsc" #-} +{- +Copyright (C) 2006 John Goerzen + + 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) diff --git a/Database/HDBC/PostgreSQL/Statement.hs b/Database/HDBC/PostgreSQL/Statement.hs new file mode 100644 --- /dev/null +++ b/Database/HDBC/PostgreSQL/Statement.hs @@ -0,0 +1,443 @@ +{-# OPTIONS_GHC -optc-D__HUGS__ #-} +{-# INCLUDE #-} +{-# 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 + + 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 diff --git a/Database/HDBC/PostgreSQL/Utils.hs b/Database/HDBC/PostgreSQL/Utils.hs new file mode 100644 --- /dev/null +++ b/Database/HDBC/PostgreSQL/Utils.hs @@ -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 + + 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 + diff --git a/HDBC-postgresql.cabal b/HDBC-postgresql.cabal --- a/HDBC-postgresql.cabal +++ b/HDBC-postgresql.cabal @@ -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 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: . diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -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} diff --git a/hdbc-postgresql-helper.h b/hdbc-postgresql-helper.h new file mode 100644 --- /dev/null +++ b/hdbc-postgresql-helper.h @@ -0,0 +1,16 @@ +#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); diff --git a/pgtypes.h b/pgtypes.h new file mode 100644 --- /dev/null +++ b/pgtypes.h @@ -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