HDBC-postgresql 2.2.3.2 → 2.2.3.3
raw patch · 5 files changed
+71/−53 lines, 5 filesPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
API changes (from Hackage documentation)
+ Database.HDBC.PostgreSQL: withPostgreSQL :: String -> (Connection -> IO a) -> IO a
Files
- Database/HDBC/PostgreSQL.hs +2/−2
- Database/HDBC/PostgreSQL/Connection.hsc +13/−7
- Database/HDBC/PostgreSQL/Statement.hsc +47/−43
- Database/HDBC/PostgreSQL/Utils.hsc +8/−0
- HDBC-postgresql.cabal +1/−1
Database/HDBC/PostgreSQL.hs view
@@ -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
Database/HDBC/PostgreSQL/Connection.hsc view
@@ -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 <libpq-fe.h> #include <pg_config.h>@@ -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
Database/HDBC/PostgreSQL/Statement.hsc view
@@ -48,7 +48,7 @@ #include <libpq-fe.h> -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)
Database/HDBC/PostgreSQL/Utils.hsc view
@@ -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
HDBC-postgresql.cabal view
@@ -1,5 +1,5 @@ Name: HDBC-postgresql-Version: 2.2.3.2+Version: 2.2.3.3 License: LGPL Maintainer: John Goerzen <jgoerzen@complete.org> Author: John Goerzen