From eeff72e2f6f7e0742c8b931288223719c9ced338 Mon Sep 17 00:00:00 2001 From: Leon P Smith Date: Sat, 26 Dec 2015 01:32:03 -0500 Subject: [PATCH 1/2] Add rudimentary tracking of explicit disconnects No guarantee that using a connection after it has been closed will result in a sensible operation, but at least it won't result in a use-after-free memory fault now. Also, this should make this interface relatively safe to use concurrently. --- library/Hasql/Commands.hs | 2 -- library/Hasql/Connection/Impl.hs | 22 +++++++++++++---- library/Hasql/Query.hs | 41 ++++++++++++++++---------------- 3 files changed, 38 insertions(+), 27 deletions(-) diff --git a/library/Hasql/Commands.hs b/library/Hasql/Commands.hs index f736114..b7469f7 100644 --- a/library/Hasql/Commands.hs +++ b/library/Hasql/Commands.hs @@ -29,5 +29,3 @@ setEncodersToUTF8 = setMinClientMessagesToWarning :: Commands setMinClientMessagesToWarning = Commands (pure "SET client_min_messages TO WARNING") - - diff --git a/library/Hasql/Connection/Impl.hs b/library/Hasql/Connection/Impl.hs index fac8c29..7fc19ae 100644 --- a/library/Hasql/Connection/Impl.hs +++ b/library/Hasql/Connection/Impl.hs @@ -1,7 +1,10 @@ +{-# OPTIONS_GHC -funbox-strict-fields #-} + module Hasql.Connection.Impl where import Hasql.Prelude +import Control.Concurrent.MVar (newMVar, swapMVar) import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Hasql.PreparedStatementRegistry as PreparedStatementRegistry import qualified Hasql.IO as IO @@ -10,7 +13,7 @@ import qualified Hasql.IO as IO -- | -- A single connection to the database. data Connection = - Connection !LibPQ.Connection !Bool !PreparedStatementRegistry.PreparedStatementRegistry + Connection !(MVar LibPQ.Connection) !Bool !PreparedStatementRegistry.PreparedStatementRegistry -- | -- Possible details of the connection acquistion error. @@ -21,17 +24,26 @@ type ConnectionError = -- Acquire a connection using the provided settings encoded according to the PostgreSQL format. acquire :: ByteString -> IO (Either ConnectionError Connection) acquire settings = - {-# SCC "acquire" #-} + {-# SCC "acquire" #-} runEitherT $ do pqConnection <- lift (IO.acquireConnection settings) lift (IO.checkConnectionStatus pqConnection) >>= traverse left lift (IO.initConnection pqConnection) integerDatetimes <- lift (IO.getIntegerDatetimes pqConnection) registry <- lift (IO.acquirePreparedStatementRegistry) - pure (Connection pqConnection integerDatetimes registry) + pqConnectionRef <- lift (newMVar pqConnection) + pure (Connection pqConnectionRef integerDatetimes registry) -- | -- Release the connection. release :: Connection -> IO () -release (Connection pqConnection _ _) = - LibPQ.finish pqConnection +release (Connection pqConnectionRef _ _) = + mask_ $ do + nullConnection <- LibPQ.newNullConnection + pqConnection <- swapMVar pqConnectionRef nullConnection + IO.releaseConnection pqConnection + +{-# INLINE withConnectionRef #-} +withConnectionRef :: MVar LibPQ.Connection -> (LibPQ.Connection -> IO a) -> IO a +withConnectionRef = + withMVar diff --git a/library/Hasql/Query.hs b/library/Hasql/Query.hs index bb59f80..7fbd2bd 100644 --- a/library/Hasql/Query.hs +++ b/library/Hasql/Query.hs @@ -37,26 +37,26 @@ data ResultsError = -- | -- Decoder error details. data ResultError = - -- | + -- | -- An error reported by the DB. -- Consists of the following: Code, message, details, hint. - -- + -- -- * __Code__. -- The SQLSTATE code for the error. -- It's recommended to use -- -- to work with those. - -- + -- -- * __Message__. -- The primary human-readable error message (typically one line). Always present. - -- + -- -- * __Details__. - -- An optional secondary error message carrying more detail about the problem. + -- An optional secondary error message carrying more detail about the problem. -- Might run to multiple lines. - -- + -- -- * __Hint__. - -- An optional suggestion on what to do about the problem. - -- This is intended to differ from detail in that it offers advice (potentially inappropriate) + -- An optional suggestion on what to do about the problem. + -- This is intended to differ from detail in that it offers advice (potentially inappropriate) -- rather than hard facts. -- Might run to multiple lines. ServerError !ByteString !ByteString !(Maybe ByteString) !(Maybe ByteString) | @@ -90,23 +90,23 @@ data RowError = -- | -- A specification of a strictly single-statement query, which can be parameterized and prepared. --- +-- -- Consists of the following: --- +-- -- * SQL template, -- * params encoder, -- * result decoder, -- * a flag, determining whether it should be prepared. --- +-- -- The SQL template must be formatted according to Postgres' standard, -- with any non-ASCII characters of the template encoded using UTF-8. -- According to the format, -- parameters must be referred to using the positional notation, as in the following: -- @$1@, @$2@, @$3@ and etc. -- Those references must be used to refer to the values of the 'Encoders.Params' encoder. --- +-- -- Following is an example of the declaration of a prepared statement with its associated codecs. --- +-- -- @ -- selectSum :: Hasql.'Hasql.Query' (Int64, Int64) Int64 -- selectSum = @@ -120,10 +120,10 @@ data RowError = -- decoder = -- Hasql.Decoders.'Hasql.Decoders.singleRow' (Hasql.Decoders.'Hasql.Decoders.value' Hasql.Decoders.'Hasql.Decoders.int8') -- @ --- +-- -- The statement above accepts a product of two parameters of type 'Int64' -- and produces a single result of type 'Int64'. --- +-- data Query a b = Query !ByteString !(Encoders.Params a) !(Decoders.Result b) !Bool deriving (Functor) @@ -142,11 +142,12 @@ instance Profunctor Query where -- | -- Execute the query, producing either a deserialization failure or a successful result. run :: Query a b -> a -> Connection.Connection -> IO (Either ResultsError b) -run (Query template encoder decoder preparable) params (Connection.Connection pqConnection integerDatetimes registry) = - {-# SCC "query" #-} - fmap (mapLeft coerceResultsError) $ runEitherT $ do - EitherT $ IO.sendParametricQuery pqConnection integerDatetimes registry template (coerceEncoder encoder) preparable params - EitherT $ IO.getResults pqConnection integerDatetimes (coerceDecoder decoder) +run (Query template encoder decoder preparable) params (Connection.Connection pqConnectionRef integerDatetimes registry) = + {-# SCC "query" #-} + Connection.withConnectionRef pqConnectionRef $ \pqConnection -> + fmap (mapLeft coerceResultsError) $ runEitherT $ do + EitherT $ IO.sendParametricQuery pqConnection integerDatetimes registry template (coerceEncoder encoder) preparable params + EitherT $ IO.getResults pqConnection integerDatetimes (coerceDecoder decoder) -- | -- WARNING: We need to take special care that the structure of From 013506a690e092c3cd7cbc6f8de337da4aeefd78 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Mon, 28 Dec 2015 12:14:42 +0500 Subject: [PATCH 2/2] Minor corrections --- library/Hasql/Connection/Impl.hs | 8 -------- library/Hasql/Query.hs | 2 +- 2 files changed, 1 insertion(+), 9 deletions(-) diff --git a/library/Hasql/Connection/Impl.hs b/library/Hasql/Connection/Impl.hs index 7fc19ae..31808c6 100644 --- a/library/Hasql/Connection/Impl.hs +++ b/library/Hasql/Connection/Impl.hs @@ -1,10 +1,7 @@ -{-# OPTIONS_GHC -funbox-strict-fields #-} - module Hasql.Connection.Impl where import Hasql.Prelude -import Control.Concurrent.MVar (newMVar, swapMVar) import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Hasql.PreparedStatementRegistry as PreparedStatementRegistry import qualified Hasql.IO as IO @@ -42,8 +39,3 @@ release (Connection pqConnectionRef _ _) = nullConnection <- LibPQ.newNullConnection pqConnection <- swapMVar pqConnectionRef nullConnection IO.releaseConnection pqConnection - -{-# INLINE withConnectionRef #-} -withConnectionRef :: MVar LibPQ.Connection -> (LibPQ.Connection -> IO a) -> IO a -withConnectionRef = - withMVar diff --git a/library/Hasql/Query.hs b/library/Hasql/Query.hs index 7fbd2bd..dfef7fd 100644 --- a/library/Hasql/Query.hs +++ b/library/Hasql/Query.hs @@ -144,7 +144,7 @@ instance Profunctor Query where run :: Query a b -> a -> Connection.Connection -> IO (Either ResultsError b) run (Query template encoder decoder preparable) params (Connection.Connection pqConnectionRef integerDatetimes registry) = {-# SCC "query" #-} - Connection.withConnectionRef pqConnectionRef $ \pqConnection -> + withMVar pqConnectionRef $ \pqConnection -> fmap (mapLeft coerceResultsError) $ runEitherT $ do EitherT $ IO.sendParametricQuery pqConnection integerDatetimes registry template (coerceEncoder encoder) preparable params EitherT $ IO.getResults pqConnection integerDatetimes (coerceDecoder decoder)