Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Merge pull request #13 from joeyadams/master

Use exception mask in withTransactionMode, and compile with -Wall
  • Loading branch information...
commit fdf85c4c046a3e6c53dda616c008b1c5ef40c533 2 parents c576a8c + 8fa277a
@lpsmith authored
View
5 postgresql-simple.cabal
@@ -31,6 +31,9 @@ Library
-- Other-modules:
Database.PostgreSQL.Simple.Internal
+ Other-modules:
+ Database.PostgreSQL.Simple.Compat
+
Build-depends:
attoparsec >= 0.8.5.3,
base < 5,
@@ -46,6 +49,8 @@ Library
text >= 0.11.1,
time
+ ghc-options: -Wall -fno-warn-name-shadowing
+
source-repository head
type: git
location: http://github.com/lpsmith/postgresql-simple
View
22 src/Database/PostgreSQL/Simple.hs
@@ -108,9 +108,8 @@ import Blaze.ByteString.Builder (Builder, fromByteString, toByteString)
import Blaze.ByteString.Builder.Char8 (fromChar)
import Control.Applicative ((<$>), pure)
import Control.Concurrent.MVar
-import Control.Exception (Exception, bracket, onException, throw, throwIO, finally)
+import Control.Exception (Exception, onException, throw, throwIO, finally)
import Control.Monad (foldM)
-import Control.Monad.Fix (fix)
import Data.ByteString (ByteString)
import Data.Char(ord)
import Data.Int (Int64)
@@ -119,6 +118,7 @@ import Data.List (intersperse)
import Data.Monoid (mappend, mconcat)
import Data.Typeable (Typeable)
import Database.PostgreSQL.Simple.BuiltinTypes (oid2builtin, builtin2typname)
+import Database.PostgreSQL.Simple.Compat (mask)
import Database.PostgreSQL.Simple.Param (Action(..), inQuotes)
import Database.PostgreSQL.Simple.QueryParams (QueryParams(..))
import Database.PostgreSQL.Simple.Result (ResultError(..))
@@ -194,6 +194,7 @@ formatMany conn q@(Query template) qs = do
\([^?]*)$"
[caseless]
+escapeStringConn :: Connection -> ByteString -> IO (Maybe ByteString)
escapeStringConn conn s = withConnection conn $ \c -> do
PQ.escapeStringConn c s
@@ -241,7 +242,7 @@ executeMany conn q qs = do
finishExecute conn q result
finishExecute :: Connection -> Query -> PQ.Result -> IO Int64
-finishExecute conn q result = do
+finishExecute _conn q result = do
status <- PQ.resultStatus result
case status of
PQ.CommandOk -> do
@@ -343,6 +344,7 @@ data FoldOptions
transactionMode :: !TransactionMode
}
+defaultFoldOptions :: FoldOptions
defaultFoldOptions = FoldOptions {
fetchQuantity = Automatic,
transactionMode = TransactionMode ReadCommitted ReadOnly
@@ -532,11 +534,12 @@ withTransactionLevel lvl
-- | Execute an action inside a SQL transaction with a given transaction mode.
withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a
-withTransactionMode mode conn act = do
- beginMode mode conn
- r <- act `onException` rollback conn
- commit conn
- return r
+withTransactionMode mode conn act =
+ mask $ \restore -> do
+ beginMode mode conn
+ r <- restore act `onException` rollback conn
+ commit conn
+ return r
-- | Rollback a transaction.
rollback :: Connection -> IO ()
@@ -557,7 +560,8 @@ beginLevel lvl = beginMode defaultTransactionMode { isolationLevel = lvl }
-- | Begin a transaction with a given transaction mode
beginMode :: TransactionMode -> Connection -> IO ()
beginMode mode conn = do
- execute_ conn $! case mode of
+ _ <- execute_ conn $!
+ case mode of
TransactionMode ReadCommitted ReadWrite ->
"BEGIN"
TransactionMode ReadCommitted ReadOnly ->
View
25 src/Database/PostgreSQL/Simple/Compat.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE CPP #-}
+-- | This is a module of its own, because it uses the CPP extension, which
+-- doesn't play well with the regex string literal in Simple.hs .
+module Database.PostgreSQL.Simple.Compat
+ ( mask
+ ) where
+
+import qualified Control.Exception as E
+
+-- | Like 'E.mask', but backported to base before version 4.3.0.
+--
+-- Note that the restore callback is monomorphic, unlike in 'E.mask'. This
+-- could be fixed by changing the type signature, but it would require us to
+-- enable the RankNTypes extension (since 'E.mask' has a rank-3 type). The
+-- 'withTransactionMode' function calls the restore callback only once, so we
+-- don't need that polymorphism.
+mask :: ((IO a -> IO a) -> IO b) -> IO b
+#if MIN_VERSION_base(4,3,0)
+mask io = E.mask $ \restore -> io restore
+#else
+mask io = do
+ b <- E.blocked
+ E.block $ io $ \m -> if b then m else E.unblock m
+#endif
+{-# INLINE mask #-}
View
1  src/Database/PostgreSQL/Simple/Internal.hs
@@ -195,6 +195,7 @@ exec conn sql =
Just res -> do
return res
+disconnectedError :: SqlError
disconnectedError = SqlError {
sqlNativeError = -1,
sqlErrorMsg = "connection disconnected",
View
1  src/Database/PostgreSQL/Simple/LargeObjects.hs
@@ -36,7 +36,6 @@ import qualified Data.ByteString as B
import Database.PostgreSQL.LibPQ (Oid(..),LoFd(..))
import qualified Database.PostgreSQL.LibPQ as PQ
import Database.PostgreSQL.Simple.Internal
-import Foreign.C.Types (CInt)
import System.IO (IOMode(..),SeekMode(..))
liftPQ :: B.ByteString -> Connection -> (PQ.Connection -> IO (Maybe a)) -> IO a
View
1  src/Database/PostgreSQL/Simple/Notification.hs
@@ -29,6 +29,7 @@ data Notification = Notification
, notificationData :: B.ByteString
}
+errfd :: String
errfd = "Database.PostgreSQL.Simple.Notification.getNotification: \
\failed to fetch file descriptor"
View
4 src/Database/PostgreSQL/Simple/QueryResults.hs
@@ -24,14 +24,13 @@ module Database.PostgreSQL.Simple.QueryResults
) where
import Control.Applicative (Applicative(..), (<$>))
-import Control.Exception (SomeException(..), throw)
+import Control.Exception (SomeException(..))
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either()
import Database.PostgreSQL.Simple.Internal
import Database.PostgreSQL.Simple.Result (ResultError(..), Result(..))
import Database.PostgreSQL.Simple.Types (Only(..))
-import qualified Database.PostgreSQL.LibPQ as LibPQ (Result)
-- | A collection type that can be converted from a list of strings.
--
@@ -212,6 +211,7 @@ instance (Result a, Result b, Result c, Result d, Result e, Result f,
return (a,b,c,d,e,f,g,h,i,j)
convertResults fs vs = convertError fs vs 10
+(<$!>) :: Functor f => (a -> b) -> f a -> f b
f <$!> (!x) = f <$> x
infixl 4 <$!>
View
9 src/Database/PostgreSQL/Simple/Result.hs
@@ -32,7 +32,7 @@ module Database.PostgreSQL.Simple.Result
#include "MachDeps.h"
import Control.Applicative (Applicative, (<$>), (<*>), (<*), pure)
-import Control.Exception (SomeException(..), Exception, throw)
+import Control.Exception (SomeException(..), Exception)
import Data.Attoparsec.Char8 hiding (Result)
import Data.Bits ((.&.), (.|.), shiftL)
import Data.ByteString (ByteString)
@@ -44,10 +44,9 @@ import Data.Time.Calendar (Day, fromGregorian)
import Data.Time.Clock (UTCTime)
import Data.Time.Format (parseTime)
import Data.Time.LocalTime (TimeOfDay, makeTimeOfDayValid)
-import Data.Typeable (TypeRep, Typeable, typeOf)
+import Data.Typeable (Typeable, typeOf)
import Data.Word (Word64)
import Database.PostgreSQL.Simple.Internal
-import Database.PostgreSQL.Simple.Field (Field(..), RawResult(..))
import Database.PostgreSQL.Simple.BuiltinTypes
import Database.PostgreSQL.Simple.Types (Binary(..), Null(..))
import qualified Database.PostgreSQL.LibPQ as PQ
@@ -58,7 +57,6 @@ import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as LB
import qualified Data.Text as ST
import qualified Data.Text.Encoding as ST
-import qualified Data.Text.Encoding.Error (UnicodeException)
import qualified Data.Text.Lazy as LT
-- | Exception thrown if conversion from a SQL value to a Haskell
@@ -140,6 +138,7 @@ instance Result (Ratio Integer) where
convert = atto ok rational
where ok = mkCompats [Float4,Float8,Int2,Int4,Numeric]
+unBinary :: Binary t -> t
unBinary (Binary x) = x
instance Result SB.ByteString where
@@ -228,7 +227,7 @@ mkCompat = Compat . shiftL 1 . fromEnum
compat :: Compat -> Compat -> Bool
compat (Compat a) (Compat b) = a .&. b /= 0
-okText, okText', ok16, ok32, ok64 :: Compat
+okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat
okText = mkCompats [Name,Text,Char,Bpchar,Varchar]
okText' = mkCompats [Name,Text,Char,Bpchar,Varchar,Unknown]
okBinary = mkCompats [Bytea]
Please sign in to comment.
Something went wrong with that request. Please try again.