diff --git a/Database/HDBC/PostgreSQL.hs b/Database/HDBC/PostgreSQL.hs --- a/Database/HDBC/PostgreSQL.hs +++ b/Database/HDBC/PostgreSQL.hs @@ -63,7 +63,7 @@ module Database.HDBC.PostgreSQL ( -- * Connecting to Databases - connectPostgreSQL, Connection, + connectPostgreSQL, withPostgreSQL, Connection, -- * PostgreSQL Error Codes -- -- |When an @SqlError@ is thrown, the field @seState@ is set to one of the following @@ -76,7 +76,7 @@ where -import Database.HDBC.PostgreSQL.Connection(connectPostgreSQL, Connection()) +import Database.HDBC.PostgreSQL.Connection(connectPostgreSQL, withPostgreSQL, Connection()) import Database.HDBC.PostgreSQL.ErrorCodes {- $threading diff --git a/Database/HDBC/PostgreSQL/Connection.hsc b/Database/HDBC/PostgreSQL/Connection.hsc --- a/Database/HDBC/PostgreSQL/Connection.hsc +++ b/Database/HDBC/PostgreSQL/Connection.hsc @@ -20,7 +20,7 @@ -} module Database.HDBC.PostgreSQL.Connection - (connectPostgreSQL, Impl.Connection()) + (connectPostgreSQL, withPostgreSQL, Impl.Connection()) where import Database.HDBC @@ -42,7 +42,7 @@ import Control.Concurrent.MVar import System.IO (stderr, hPutStrLn) import System.IO.Unsafe (unsafePerformIO) - +import Control.Exception(bracket) #include #include @@ -50,6 +50,7 @@ -- | 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 () @@ -101,9 +102,14 @@ Impl.dbTransactionSupport = True, Impl.getTables = fgetTables conn children, Impl.describeTable = fdescribeTable conn children} - quickQuery rconn "SET client_encoding TO utf8;" [] + _ <- 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) + -------------------------------------------------- -- Guts here -------------------------------------------------- @@ -126,11 +132,11 @@ return res fcommit :: Conn -> ChildList -> IO () -fcommit o cl = do frun o cl "COMMIT" [] +fcommit o cl = do _ <- frun o cl "COMMIT" [] begin_transaction o cl frollback :: Conn -> ChildList -> IO () -frollback o cl = do frun o cl "ROLLBACK" [] +frollback o cl = do _ <- frun o cl "ROLLBACK" [] begin_transaction o cl fgetTables conn children = @@ -138,7 +144,7 @@ "select table_name from information_schema.tables where \ \table_schema != 'pg_catalog' AND table_schema != \ \'information_schema'" - execute sth [] + _ <- execute sth [] res1 <- fetchAllRows' sth let res = map fromSql $ concat res1 return $ seq (length res) res @@ -155,7 +161,7 @@ (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 + _ <- execute sth params res <- fetchAllRows' sth return $ map desccol res where diff --git a/Database/HDBC/PostgreSQL/Statement.hsc b/Database/HDBC/PostgreSQL/Statement.hsc --- a/Database/HDBC/PostgreSQL/Statement.hsc +++ b/Database/HDBC/PostgreSQL/Statement.hsc @@ -48,7 +48,7 @@ #include -data SState = +data SState = SState { stomv :: MVar (Maybe Stmt), nextrowmv :: MVar (CInt), -- -1 for no next row (empty); otherwise, next row to read. dbo :: Conn, @@ -57,8 +57,8 @@ -- FIXME: we currently do no prepare optimization whatsoever. -newSth :: Conn -> ChildList -> String -> IO Statement -newSth indbo mchildren query = +newSth :: Conn -> ChildList -> String -> IO Statement +newSth indbo mchildren query = do l "in newSth" newstomv <- newMVar Nothing newnextrowmv <- newMVar (-1) @@ -67,13 +67,13 @@ Left errstr -> throwSqlError $ SqlError {seState = "", seNativeError = (-1), - seErrorMsg = "hdbc prepare: " ++ + seErrorMsg = "hdbc prepare: " ++ show errstr} Right converted -> return converted let sstate = SState {stomv = newstomv, nextrowmv = newnextrowmv, dbo = indbo, squery = usequery, coldefmv = newcoldefmv} - let retval = + let retval = Statement {execute = fexecute sstate, executeMany = fexecutemany sstate, executeRaw = fexecuteRaw sstate, @@ -86,12 +86,12 @@ return retval fgetColumnNames :: SState -> IO [(String)] -fgetColumnNames sstate = +fgetColumnNames sstate = do c <- readMVar (coldefmv sstate) return (map fst c) fdescribeResult :: SState -> IO [(String, SqlColDesc)] -fdescribeResult sstate = +fdescribeResult sstate = readMVar (coldefmv sstate) {- For now, we try to just handle things as simply as possible. @@ -104,7 +104,7 @@ public_ffinish sstate -- Sets nextrowmv to -1 resptr <- pqexecParams cconn cquery (genericLength args) nullPtr cargs nullPtr nullPtr 0 - handleResultStatus resptr sstate =<< pqresultStatus resptr + 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 @@ -116,11 +116,11 @@ do l "in fexecute" public_ffinish sstate -- Sets nextrowmv to -1 resptr <- pqexec cconn cquery - handleResultStatus resptr sstate =<< pqresultStatus resptr + handleResultStatus cconn resptr sstate =<< pqresultStatus resptr return () -handleResultStatus :: (Num a, Read a) => WrappedCStmt -> SState -> ResultStatus -> IO a -handleResultStatus resptr sstate status = +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 @@ -148,16 +148,21 @@ swapMVar (nextrowmv sstate) 0 swapMVar (stomv sstate) (Just fresptr) return 0 - _ -> do l $ "PGRES ERROR: " ++ squery sstate - csstatusmsg <- pqresStatus status - cserrormsg <- pqresultErrorMessage resptr + _ | resptr == nullPtr -> do + l $ "PGRES ERROR: " ++ squery sstate + errormsg <- peekCStringUTF8 =<< pqerrorMessage cconn + statusmsg <- peekCStringUTF8 =<< pqresStatus status - statusmsgbs <- B.packCString csstatusmsg - errormsgbs <- B.packCString cserrormsg - let statusmsg = BUTF8.toString statusmsgbs - let errormsg = BUTF8.toString errormsgbs + throwSqlError $ SqlError { seState = "E" + , seNativeError = fromIntegral status + , seErrorMsg = "execute: " ++ statusmsg ++ + ": " ++ errormsg} - state <- pqresultErrorField resptr #{const PG_DIAG_SQLSTATE} >>= peekCStringUTF8 + _ -> 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 @@ -168,7 +173,9 @@ peekCStringUTF8 :: CString -> IO String -- Marshal a NUL terminated C string into a Haskell string, decoding it -- with UTF8. -peekCStringUTF8 str = fmap BUTF8.toString (B.packCString str) +peekCStringUTF8 str + | str == nullPtr = return "" + | otherwise = fmap BUTF8.toString (B.packCString str) @@ -179,7 +186,7 @@ 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 -> + dofetchrow nextrow = modifyMVar (stomv sstate) $ \stmt -> case stmt of Nothing -> l "ffr nos" >> return (stmt, ((-1), Nothing)) Just cmstmt -> withStmt cmstmt $ \cstmt -> @@ -193,10 +200,10 @@ return (Nothing, ((-1), Nothing)) else do l "getting stuff" ncols <- pqnfields cstmt - res <- mapM (getCol cstmt nextrow) + res <- mapM (getCol cstmt nextrow) [0..(ncols - 1)] return (stmt, (nextrow + 1, Just res)) - getCol p row icol = + getCol p row icol = do isnull <- pqgetisnull p row icol if isnull /= 0 then return SqlNull @@ -212,8 +219,7 @@ do ncols <- pqnfields cstmt mapM desccol [0..(ncols - 1)] where desccol i = - do colname <- (pqfname cstmt i >>= B.packCString >>= - return . BUTF8.toString) + do colname <- peekCStringUTF8 =<< pqfname cstmt i coltype <- pqftype cstmt i --coloctets <- pqfsize let coldef = oidToColDef coltype @@ -226,7 +232,7 @@ -- Finish and change state public_ffinish :: SState -> IO () -public_ffinish sstate = +public_ffinish sstate = do l "public_ffinish" swapMVar (nextrowmv sstate) (-1) modifyMVar_ (stomv sstate) worker @@ -292,17 +298,15 @@ 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 + let strval = BUTF8.toString bstrval in - case sqltypeid of + case sqltypeid of tid | tid == SqlCharT || tid == SqlVarCharT || @@ -323,8 +327,8 @@ tid | tid == SqlRealT || tid == SqlFloatT || tid == SqlDoubleT -> return $ SqlDouble (read strval) - - SqlBitT -> return $ case strval of + + 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 @@ -332,21 +336,21 @@ '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 | tid == SqlTimeT || tid == SqlUTCTimeT -> return $ SqlLocalTimeOfDay (fromSql (toSql strval)) - tid | tid == SqlTimeWithZoneT -> + 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) @@ -354,16 +358,16 @@ timestr = fixString strval in return $ SqlZonedLocalTimeOfDay a b) - SqlIntervalT _ -> return $ SqlDiffTime $ fromRational $ - case split ':' strval of + 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 == SqlVarBinaryT || tid == SqlLongVarBinaryT -> return $ SqlByteString bstrval SqlGUIDT -> return $ SqlByteString bstrval @@ -379,14 +383,14 @@ 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 = +makeRationalFromDecimal s = case elemIndex '.' s of Nothing -> toRational ((read s)::Integer) - Just dotix -> + Just dotix -> let (nstr,'.':dstr) = splitAt dotix s num = (read $ nstr ++ dstr)::Integer den = 10^((genericLength dstr) :: Integer) diff --git a/Database/HDBC/PostgreSQL/Utils.hsc b/Database/HDBC/PostgreSQL/Utils.hsc --- a/Database/HDBC/PostgreSQL/Utils.hsc +++ b/Database/HDBC/PostgreSQL/Utils.hsc @@ -33,6 +33,7 @@ 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 @@ -89,11 +90,18 @@ -} 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 diff --git a/HDBC-postgresql.cabal b/HDBC-postgresql.cabal --- a/HDBC-postgresql.cabal +++ b/HDBC-postgresql.cabal @@ -1,5 +1,5 @@ Name: HDBC-postgresql -Version: 2.2.3.2 +Version: 2.2.3.3 License: LGPL Maintainer: John Goerzen Author: John Goerzen