diff --git a/Database/HDBC/PostgreSQL.hs b/Database/HDBC/PostgreSQL.hs --- a/Database/HDBC/PostgreSQL.hs +++ b/Database/HDBC/PostgreSQL.hs @@ -69,9 +69,24 @@ -- |When an @SqlError@ is thrown, the field @seState@ is set to one of the following -- error codes. module Database.HDBC.PostgreSQL.ErrorCodes, + + -- * Threading + -- $threading ) where import Database.HDBC.PostgreSQL.Connection(connectPostgreSQL, Connection()) import Database.HDBC.PostgreSQL.ErrorCodes + +{- $threading + + Provided the local libpq library is thread-safe, multiple 'Connection's may be used + to have concurrent database queries. Concurrent queries issued on a single + 'Connection' will be performed serially. + + When the local libpq library is not thread-safe (ie. it has not been compiled with + --enable-thread-safety), only a single database function will be performed at a time. + +-} + 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 @@ -37,13 +37,22 @@ import Foreign.Ptr import Data.Word import Data.Maybe -import Control.Concurrent.MVar import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as BUTF8 +import Control.Concurrent.MVar +import System.IO (stderr, hPutStrLn) +import System.IO.Unsafe (unsafePerformIO) + #include #include + +-- | 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/. +{-# NOINLINE globalConnLock #-} +globalConnLock = unsafePerformIO $ newMVar () + {- | Connect to a PostgreSQL server. See for the meaning @@ -51,11 +60,19 @@ connectPostgreSQL :: String -> IO Impl.Connection connectPostgreSQL args = B.useAsCString (BUTF8.fromString args) $ \cs -> do ptr <- pqconnectdb cs + threadSafe <- pqisThreadSafe ptr + connLock <- if threadSafe==0 -- Also check GHC.Conc.numCapabilities here? + then do hPutStrLn stderr "WARNING: libpq is not threadsafe, \ + \serializing all libpq FFI calls. \ + \(Consider recompiling libpq with \ + \--enable-thread-safety.\n" + return globalConnLock + else newMVar () status <- pqstatus ptr wrappedptr <- wrapconn ptr nullPtr fptr <- newForeignPtr pqfinishptr wrappedptr case status of - #{const CONNECTION_OK} -> mkConn args fptr + #{const CONNECTION_OK} -> mkConn args (connLock,fptr) _ -> raiseError "connectPostgreSQL" status ptr -- FIXME: environment vars may have changed, should use pgsql enquiries @@ -120,7 +137,7 @@ do sth <- newSth conn children "select table_name from information_schema.tables where \ \table_schema != 'pg_catalog' AND table_schema != \ - \'information_schema' AND table_schema != 'system_schema'" + \'information_schema'" execute sth [] res1 <- fetchAllRows' sth let res = map fromSql $ concat res1 @@ -154,7 +171,7 @@ do closeAllChildren mchildren withRawConn conn $ pqfinish -foreign import ccall unsafe "libpq-fe.h PQconnectdb" +foreign import ccall safe "libpq-fe.h PQconnectdb" pqconnectdb :: CString -> IO (Ptr CConn) foreign import ccall unsafe "hdbc-postgresql-helper.h wrapobjpg" @@ -174,3 +191,6 @@ foreign import ccall unsafe "libpq-fe.h PQserverVersion" pqserverVersion :: Ptr CConn -> IO CInt + +foreign import ccall unsafe "libpq.fe.h PQisthreadsafe" + pqisThreadSafe :: Ptr CConn -> IO Int 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 @@ -97,7 +97,7 @@ {- For now, we try to just handle things as simply as possible. FIXME lots of room for improvement here (types, etc). -} fexecute :: (Num a, Read a) => SState -> [SqlValue] -> IO a -fexecute sstate args = withConn (dbo sstate) $ \cconn -> +fexecute sstate args = withConnLocked (dbo sstate) $ \cconn -> B.useAsCString (BUTF8.fromString (squery sstate)) $ \cquery -> withCStringArr0 args $ \cargs -> -- wichSTringArr0 uses UTF-8 do l "in fexecute" @@ -111,7 +111,7 @@ is useful for issuing DDL or DML commands. -} fexecuteRaw :: SState -> IO () fexecuteRaw sstate = - withConn (dbo sstate) $ \cconn -> + withConnLocked (dbo sstate) $ \cconn -> B.useAsCString (BUTF8.fromString (squery sstate)) $ \cquery -> do l "in fexecute" public_ffinish sstate -- Sets nextrowmv to -1 @@ -239,7 +239,7 @@ foreign import ccall unsafe "libpq-fe.h PQresultStatus" pqresultStatus :: (Ptr CStmt) -> IO #{type ExecStatusType} -foreign import ccall unsafe "libpq-fe.h PQexecParams" +foreign import ccall safe "libpq-fe.h PQexecParams" pqexecParams :: (Ptr CConn) -> CString -> CInt -> (Ptr #{type Oid}) -> (Ptr CString) -> @@ -248,7 +248,7 @@ CInt -> IO (Ptr CStmt) -foreign import ccall unsafe "libpq-fe.h PQexec" +foreign import ccall safe "libpq-fe.h PQexec" pqexec :: (Ptr CConn) -> CString -> IO (Ptr CStmt) foreign import ccall unsafe "hdbc-postgresql-helper.h PQclear_app" diff --git a/Database/HDBC/PostgreSQL/Types.hs b/Database/HDBC/PostgreSQL/Types.hs --- a/Database/HDBC/PostgreSQL/Types.hs +++ b/Database/HDBC/PostgreSQL/Types.hs @@ -2,10 +2,13 @@ where import Foreign +import Control.Concurrent.MVar +type ConnLock = MVar () + data CConn = CConn type WrappedCConn = Ptr CConn -type Conn = ForeignPtr WrappedCConn +type Conn = (ConnLock, ForeignPtr WrappedCConn) data CStmt = CStmt type WrappedCStmt = Ptr CStmt 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 @@ -23,6 +23,7 @@ import Database.HDBC(throwSqlError) import Database.HDBC.Types import Database.HDBC.PostgreSQL.Types +import Control.Concurrent.MVar import Foreign.C.Types import Control.Exception import Foreign.Storable @@ -60,10 +61,17 @@ Ditto for statements. -} withConn :: Conn -> (Ptr CConn -> IO b) -> IO b -withConn = genericUnwrap +withConn (_lock,conn) = genericUnwrap conn +-- Perform the associated action with the connection lock held. +-- Care must be taken with the use of this as it is *not* re-entrant. Calling it +-- a second time in the same thread will cause dead-lock. +-- (A better approach would be to use RLock from concurrent-extra) +withConnLocked :: Conn -> (Ptr CConn -> IO b) -> IO b +withConnLocked c@(lock,_) a = withConn c (\cconn -> withMVar lock (\_ -> a cconn)) + withRawConn :: Conn -> (Ptr WrappedCConn -> IO b) -> IO b -withRawConn = withForeignPtr +withRawConn (_lock,conn) = withForeignPtr conn withStmt :: Stmt -> (Ptr CStmt -> IO b) -> IO b withStmt = genericUnwrap 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.1 +Version: 2.2.3.2 License: LGPL Maintainer: John Goerzen Author: John Goerzen @@ -51,7 +51,8 @@ if flag(buildtests) Buildable: True Build-Depends: HUnit, QuickCheck, testpack, containers, - convertible, time, old-locale + convertible, time, old-locale, parsec, utf8-string, + bytestring, old-time, base, HDBC>=2.2.6 else Buildable: False Main-Is: runtests.hs diff --git a/testsrc/TestTime.hs b/testsrc/TestTime.hs --- a/testsrc/TestTime.hs +++ b/testsrc/TestTime.hs @@ -9,7 +9,8 @@ import Data.Maybe import Data.Convertible import SpecificDB -import System.Locale +import System.Locale(defaultTimeLocale) +import Database.HDBC.Locale (iso8601DateFormat) import qualified System.Time as ST instance Eq ZonedTime where