diff --git a/cbits/noticehandlers.c b/cbits/noticehandlers.c new file mode 100644 --- /dev/null +++ b/cbits/noticehandlers.c @@ -0,0 +1,59 @@ +#include "noticehandlers.h" +#include +#include + +void +hs_postgresql_libpq_discard_notices(NoticeBuffer* arg, const PGresult* res) { + return; +} + +void +hs_postgresql_libpq_store_notices(NoticeBuffer* arg, const PGresult* res) { + if (arg == NULL || res == NULL) return; + const char* msg = PQresultErrorMessage(res); + if (msg == NULL) return; + size_t len = strlen(msg); + PGnotice* notice = (PGnotice*)malloc(sizeof(PGnotice) + sizeof(char)*(len + 1)); + notice->next = NULL; + notice->len = len; + memcpy(notice->str, msg, len+1); + if (arg->last == NULL) { + arg->first = notice; + arg->last = notice; + } else { + arg->last->next = notice; + arg->last = notice; + } +} + +PGnotice * +hs_postgresql_libpq_get_notice(NoticeBuffer* arg) { + if (arg == NULL) return NULL; + PGnotice * res = arg->first; + if (res == NULL) return NULL; + PGnotice * next = res->next; + arg->first = next; + if (next == NULL) arg->last = NULL; + return res; +} + +NoticeBuffer * +hs_postgresql_libpq_malloc_noticebuffer (void) { + NoticeBuffer * arg = (NoticeBuffer*)malloc(sizeof(NoticeBuffer)); + if (arg == NULL) return NULL; + arg->first = NULL; + arg->last = NULL; + return arg; +} + +void +hs_postgresql_libpq_free_noticebuffer (NoticeBuffer * arg) { + if (arg == NULL) return; + PGnotice * x = arg->first; + PGnotice * nx; + while (x != NULL) { + nx = x->next; + free(x); + x = nx; + } +} diff --git a/postgresql-libpq.cabal b/postgresql-libpq.cabal --- a/postgresql-libpq.cabal +++ b/postgresql-libpq.cabal @@ -1,5 +1,5 @@ Name: postgresql-libpq -Version: 0.9.0.2 +Version: 0.9.1.0 Synopsis: low-level binding to libpq Description: This is a binding to libpq: the C application @@ -29,6 +29,8 @@ Library hs-source-dirs: src + c-sources: cbits/noticehandlers.c + include-dirs: cbits Exposed-modules: Database.PostgreSQL.LibPQ Build-depends: base >= 4 && < 5 @@ -52,4 +54,4 @@ source-repository this type: git location: http://github.com/lpsmith/postgresql-libpq - tag: v0.9.0.2 + tag: v0.9.1.0 diff --git a/src/Database/PostgreSQL/LibPQ.hsc b/src/Database/PostgreSQL/LibPQ.hsc --- a/src/Database/PostgreSQL/LibPQ.hsc +++ b/src/Database/PostgreSQL/LibPQ.hsc @@ -43,6 +43,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} module Database.PostgreSQL.LibPQ ( @@ -185,6 +186,11 @@ , Verbosity(..) , setErrorVerbosity + -- * Nonfatal Error Reporting + , disableNoticeReporting + , enableNoticeReporting + , getNotice + -- * Large Objects -- $largeobjects , LoFd(..) @@ -206,6 +212,7 @@ #include #include +#include "noticehandlers.h" import Prelude hiding ( print ) import Foreign @@ -229,13 +236,14 @@ import qualified Data.ByteString.Internal as B ( fromForeignPtr , c_strlen , createAndTrim + , ByteString(..) ) import qualified Data.ByteString as B -#if __GLASGOW_HASKELL__ >= 700 -import Control.Concurrent (newMVar, tryTakeMVar) -#endif +import Control.Concurrent.MVar +import Data.Typeable + #if __GLASGOW_HASKELL__ >= 700 import Control.Exception (mask_) #else @@ -254,7 +262,13 @@ -- via the connection object. -- | 'Connection' encapsulates a connection to the backend. -newtype Connection = Conn (ForeignPtr PGconn) deriving Eq +data Connection = Conn {-# UNPACK #-} !(ForeignPtr PGconn) + {-# UNPACK #-} !(MVar NoticeBuffer) + +instance Eq Connection where + (Conn c _) == (Conn d _) = c == d + (Conn c _) /= (Conn d _) = c /= d + data PGconn -- | Makes a new connection to the database server. @@ -277,14 +291,10 @@ connPtr <- B.useAsCString conninfo c_PQconnectdb if connPtr == nullPtr then fail "libpq failed to allocate a PGconn structure" -#if 0 --- FIXME: #if __GLASGOW_HASKELL__ >= ??? - else Conn `fmap` FC.newForeignPtr connPtr (pqfinish connPtr) -#elif __GLASGOW_HASKELL__ >= 700 - else Conn `fmap` newForeignPtrOnce connPtr (pqfinish connPtr) -#else - else Conn `fmap` newForeignPtr p_PQfinish connPtr -#endif + else do + noticeBuffer <- newMVar nullPtr + connection <- newForeignPtrOnce connPtr (pqfinish connPtr noticeBuffer) + return $! Conn connection noticeBuffer -- | Make a connection to the database server in a nonblocking manner. connectStart :: B.ByteString -- ^ Connection Info @@ -294,33 +304,32 @@ connPtr <- B.useAsCString connStr c_PQconnectStart if connPtr == nullPtr then fail "libpq failed to allocate a PGconn structure" -#if 0 --- FIXME: #if __GLASGOW_HASKELL__ >= ??? - else Conn `fmap` FC.newForeignPtr connPtr (pqfinish connPtr) -#elif __GLASGOW_HASKELL__ >= 700 - else Conn `fmap` newForeignPtrOnce connPtr (pqfinish connPtr) -#else - else Conn `fmap` newForeignPtr p_PQfinish connPtr -#endif + else do + noticeBuffer <- newMVar nullPtr + connection <- newForeignPtrOnce connPtr (pqfinish connPtr noticeBuffer) + return $! Conn connection noticeBuffer +pqfinish :: Ptr PGconn -> MVar NoticeBuffer -> IO () +pqfinish conn noticeBuffer = do #if __GLASGOW_HASKELL__ >= 700 --- | This covers the case when a connection is closed while other Haskell +-- This covers the case when a connection is closed while other Haskell -- threads are using GHC's IO manager to wait on the descriptor. This is -- commonly the case with asynchronous notifications, for example. Since -- libpq is responsible for opening and closing the file descriptor, GHC's -- IO manager needs to be informed that the file descriptor has been -- closed. The IO manager will then raise an exception in those threads. -pqfinish :: Ptr PGconn -> IO () -pqfinish conn = do mfd <- c_PQsocket conn case mfd of -1 -> -- This can happen if the connection is bad/lost -- This case may be worth investigating further c_PQfinish conn fd -> closeFdWith (\_ -> c_PQfinish conn) (Fd fd) +#else + c_PQfinish conn #endif + nb <- swapMVar noticeBuffer nullPtr + c_free_noticebuffer nb -#if __GLASGOW_HASKELL__ >= 700 -- | Workaround for bug in 'FC.newForeignPtr' before base 4.6. Ensure the -- finalizer is only run once, to prevent a segfault. See GHC ticket #7170 -- @@ -330,19 +339,21 @@ newForeignPtrOnce ptr fin = do mv <- newMVar fin FC.newForeignPtr ptr $ tryTakeMVar mv >>= maybe (return ()) id -#endif -- | Allocate a Null Connection, which all libpq functions -- should safely fail on. newNullConnection :: IO Connection -newNullConnection = Conn `fmap` newForeignPtr_ nullPtr +newNullConnection = do + connection <- newForeignPtr_ nullPtr + noticeBuffer <- newMVar nullPtr + return $! Conn connection noticeBuffer -- | Test if a connection is the Null Connection. isNullConnection :: Connection -> Bool #if __GLASGOW_HASKELL__ >= 702 -isNullConnection (Conn x) = Unsafe.unsafeForeignPtrToPtr x == nullPtr +isNullConnection (Conn x _) = Unsafe.unsafeForeignPtrToPtr x == nullPtr #else -isNullConnection (Conn x) = unsafeForeignPtrToPtr x == nullPtr +isNullConnection (Conn x _) = unsafeForeignPtrToPtr x == nullPtr #endif {-# INLINE isNullConnection #-} @@ -452,7 +463,7 @@ -- has been called. finish :: Connection -> IO () -finish (Conn fp) = +finish (Conn fp _) = do finalizeForeignPtr fp @@ -706,7 +717,7 @@ data Format = Text | Binary deriving (Eq, Ord, Show, Enum) -newtype Oid = Oid CUInt deriving (Eq, Ord, Read, Show, Storable) +newtype Oid = Oid CUInt deriving (Eq, Ord, Read, Show, Storable, Typeable) invalidOid :: Oid invalidOid = Oid (#const InvalidOid) @@ -1993,7 +2004,7 @@ withConn :: Connection -> (Ptr PGconn -> IO b) -> IO b -withConn (Conn !fp) f = withForeignPtr fp f +withConn (Conn !fp _) f = withForeignPtr fp f enumFromConn :: (Integral a, Enum b) => Connection @@ -2075,6 +2086,50 @@ -- where -- finalizer = touchForeignPtr fp +data CNoticeBuffer +type NoticeBuffer = Ptr CNoticeBuffer + +type NoticeReceiver = NoticeBuffer -> Ptr PGresult -> IO () + +data PGnotice + +-- | Upon connection initialization, any notices received from the server are +-- normally written to the console. Notices are akin to warnings, and +-- are distinct from notifications. This function suppresses notices. +-- You may later call 'enableNoticeReporting' after calling this function. +disableNoticeReporting :: Connection -> IO () +disableNoticeReporting conn@(Conn _ nbRef) = do + _ <- withConn conn $ \c -> c_PQsetNoticeReceiver c p_discard_notices nullPtr + nb <- swapMVar nbRef nullPtr + c_free_noticebuffer nb + +-- | Upon connection initialization, any notices received from the server are +-- normally written to the console. Notices are akin to warnings, and +-- are distinct from notifications. This function enables notices to be +-- programmatically retreived using the 'getNotice' function. You may +-- later call 'disableNoticeReporting' after calling this function. +enableNoticeReporting :: Connection -> IO () +enableNoticeReporting conn@(Conn _ nbRef) = do + nb' <- c_malloc_noticebuffer + _ <- withConn conn $ \c -> c_PQsetNoticeReceiver c p_store_notices nb' + nb <- swapMVar nbRef nb' + c_free_noticebuffer nb + +-- | This function retrieves any notices received from the backend. +-- Because multiple notices can be received at a time, you will +-- typically want to call this function in a loop until you get +-- back a 'Nothing'. +getNotice :: Connection -> IO (Maybe B.ByteString) +getNotice (Conn _ nbRef) = + withMVar nbRef $ \nb -> do + np <- c_get_notice nb + if np == nullPtr + then return Nothing + else do + fp <- newForeignPtr finalizerFree (castPtr np) + len <- #{peek PGnotice, len} np + return $! Just $! B.PS fp (#offset PGnotice, str) len + -- $largeobjects -- | LoFd is a Large Object (pseudo) File Descriptor. It is understood by @@ -2275,6 +2330,8 @@ = withConn connection $ \c -> do negError =<< c_lo_unlink c oid + + foreign import ccall "libpq-fe.h PQconnectdb" c_PQconnectdb :: CString ->IO (Ptr PGconn) @@ -2542,6 +2599,25 @@ foreign import ccall unsafe "libpq-fe.h PQfreemem" c_PQfreemem :: Ptr a -> IO () + +foreign import ccall unsafe "noticehandlers.h hs_postgresql_libpq_malloc_noticebuffer" + c_malloc_noticebuffer :: IO (Ptr CNoticeBuffer) + +foreign import ccall unsafe "noticehandlers.h hs_postgresql_libpq_free_noticebuffer" + c_free_noticebuffer :: Ptr CNoticeBuffer -> IO () + +foreign import ccall unsafe "noticehandlers.h hs_postgresql_libpq_get_notice" + c_get_notice :: Ptr CNoticeBuffer -> IO (Ptr PGnotice) + +foreign import ccall unsafe "noticehandlers.h &hs_postgresql_libpq_discard_notices" + p_discard_notices :: FunPtr NoticeReceiver + +foreign import ccall unsafe "noticehandlers.h &hs_postgresql_libpq_store_notices" + p_store_notices :: FunPtr NoticeReceiver + +foreign import ccall unsafe "libpq-fe.h PQsetNoticeReceiver" + c_PQsetNoticeReceiver :: Ptr PGconn -> FunPtr NoticeReceiver -> Ptr CNoticeBuffer -> IO (FunPtr NoticeReceiver) + type CFd = CInt