hpqtypes 1.3.1 → 1.3.2

raw patch · 15 files changed

+152/−389 lines, 15 filesdep ~QuickCheckPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: QuickCheck

API changes (from Hackage documentation)

Files

• hpqtypes.cabal +3/−5
• src/Database/PostgreSQL/PQTypes.hs +2/−2
• src/Database/PostgreSQL/PQTypes/Class.hs +0/−18
• src/Database/PostgreSQL/PQTypes/Class/Instances.hs +0/−11
• src/Database/PostgreSQL/PQTypes/Class/Instances/Overlapping.hs +0/−1
• src/Database/PostgreSQL/PQTypes/Fold.hs +85/−0
• src/Database/PostgreSQL/PQTypes/Internal/C/Interface.hs +1/−14
• src/Database/PostgreSQL/PQTypes/Internal/Connection.hs +1/−14
• src/Database/PostgreSQL/PQTypes/Internal/Fold.hs +0/−85
• src/Database/PostgreSQL/PQTypes/Internal/Monad.hs +4/−8
• src/Database/PostgreSQL/PQTypes/Internal/Notification.hsc +0/−111
• src/Database/PostgreSQL/PQTypes/Internal/Query.hs +40/−30
• src/Database/PostgreSQL/PQTypes/Notification.hs +0/−34
• src/Database/PostgreSQL/PQTypes/Transaction.hs +5/−12
• test/Main.hs +11/−44

@@ -1,5 +1,5 @@ name:                hpqtypes-version:             1.3.1+version:             1.3.2 synopsis:            Haskell bindings to libpqtypes  description:         Efficient and easy-to-use bindings to (slightly modified)@@ -68,6 +68,7 @@                      , Database.PostgreSQL.PQTypes.Utils                      , Database.PostgreSQL.PQTypes.FromSQL                      , Database.PostgreSQL.PQTypes.Array+                     , Database.PostgreSQL.PQTypes.Fold                      , Database.PostgreSQL.PQTypes.FromRow                      , Database.PostgreSQL.PQTypes.ToSQL                      , Database.PostgreSQL.PQTypes.Transaction@@ -77,7 +78,6 @@                      , Database.PostgreSQL.PQTypes.Format                      , Database.PostgreSQL.PQTypes.Binary                      , Database.PostgreSQL.PQTypes.Interval-                     , Database.PostgreSQL.PQTypes.Notification                      , Database.PostgreSQL.PQTypes.SQL                      , Database.PostgreSQL.PQTypes.Single                      , Database.PostgreSQL.PQTypes.SQL.Raw@@ -86,13 +86,11 @@                      , Database.PostgreSQL.PQTypes.XML                      , Database.PostgreSQL.PQTypes.Internal.Error                      , Database.PostgreSQL.PQTypes.Internal.Error.Code-                     , Database.PostgreSQL.PQTypes.Internal.Fold                      , Database.PostgreSQL.PQTypes.Internal.Composite                      , Database.PostgreSQL.PQTypes.Internal.Utils                      , Database.PostgreSQL.PQTypes.Internal.Connection                      , Database.PostgreSQL.PQTypes.Internal.Exception                      , Database.PostgreSQL.PQTypes.Internal.Monad-                     , Database.PostgreSQL.PQTypes.Internal.Notification                      , Database.PostgreSQL.PQTypes.Internal.QueryResult                      , Database.PostgreSQL.PQTypes.Internal.Query                      , Database.PostgreSQL.PQTypes.Internal.State@@ -162,7 +160,7 @@                      , monad-control >= 0.3                      , lifted-base >= 0.2                      , mtl >= 2.1-                     , QuickCheck >= 2.5+                     , QuickCheck >= 2.5 && < 2.7                      , HUnit >= 1.2                      , test-framework >= 0.8                      , test-framework-hunit >= 0.3

@@ -40,11 +40,11 @@   , module Database.PostgreSQL.PQTypes.Binary   , module Database.PostgreSQL.PQTypes.Class   , module Database.PostgreSQL.PQTypes.Composite+  , module Database.PostgreSQL.PQTypes.Fold   , module Database.PostgreSQL.PQTypes.Format   , module Database.PostgreSQL.PQTypes.FromRow   , module Database.PostgreSQL.PQTypes.FromSQL   , module Database.PostgreSQL.PQTypes.Interval-  , module Database.PostgreSQL.PQTypes.Notification   , module Database.PostgreSQL.PQTypes.Single   , module Database.PostgreSQL.PQTypes.SQL   , module Database.PostgreSQL.PQTypes.SQL.Class@@ -69,11 +69,11 @@ import Database.PostgreSQL.PQTypes.Class import Database.PostgreSQL.PQTypes.Class.Instances () import Database.PostgreSQL.PQTypes.Composite+import Database.PostgreSQL.PQTypes.Fold import Database.PostgreSQL.PQTypes.Format import Database.PostgreSQL.PQTypes.FromRow import Database.PostgreSQL.PQTypes.FromSQL import Database.PostgreSQL.PQTypes.Interval-import Database.PostgreSQL.PQTypes.Notification import Database.PostgreSQL.PQTypes.Single import Database.PostgreSQL.PQTypes.SQL import Database.PostgreSQL.PQTypes.SQL.Class

@@ -6,7 +6,6 @@  import Database.PostgreSQL.PQTypes.FromRow import Database.PostgreSQL.PQTypes.Internal.Connection-import Database.PostgreSQL.PQTypes.Internal.Notification import Database.PostgreSQL.PQTypes.Internal.QueryResult import Database.PostgreSQL.PQTypes.Transaction.Settings import Database.PostgreSQL.PQTypes.SQL.Class@@ -39,23 +38,6 @@   foldlM :: FromRow row => (acc -> row -> m acc) -> acc -> m acc   -- | Fold the result set of rows from right to left.   foldrM :: FromRow row => (row -> acc -> m acc) -> acc -> m acc--  -- | Attempt to receive a notification from the server. This-  -- function waits until a notification arrives or specified-  -- number of microseconds has passed. If a negative number-  -- of microseconds is passed as an argument, it will wait-  -- indefinitely. In addition, there are a couple of things-  -- to be aware of:-  ---  -- * A lock on the underlying database connection is acquired-  -- for the duration of the function.-  ---  -- * Notifications can be received only between transactions-  -- (see <http://www.postgresql.org/docs/current/static/sql-notify.html>-  -- for further info), therefore calling this function within-  -- a transaction block will return 'Just' only if notifications-  -- were received before the transaction began.-  getNotification :: Int -> m (Maybe Notification)    -- | Execute supplied monadic action with new connection   -- using current connection source and transaction settings.

@@ -31,7 +31,6 @@     either (return . Left) (\k -> runErrorT $ f k row) acc) . Right   foldrM f = ErrorT . foldrM (\row acc ->     either (return . Left) (\k -> runErrorT $ f row k) acc) . Right-  getNotification = lift . getNotification   withNewConnection = mapErrorT withNewConnection  instance MonadDB m => MonadDB (IdentityT m) where@@ -44,7 +43,6 @@   setTransactionSettings = lift . setTransactionSettings   foldlM f = IdentityT . foldlM (\acc row -> runIdentityT $ f acc row)   foldrM f = IdentityT . foldrM (\row acc -> runIdentityT $ f row acc)-  getNotification = lift . getNotification   withNewConnection = mapIdentityT withNewConnection  instance MonadDB m => MonadDB (ListT m) where@@ -59,7 +57,6 @@     concat <$> mapM (\k -> runListT $ f k row) acc) . return   foldrM f = ListT . foldrM (\row acc ->     concat <$> mapM (\k -> runListT $ f row k) acc) . return-  getNotification = lift . getNotification   withNewConnection = mapListT withNewConnection  instance MonadDB m => MonadDB (MaybeT m) where@@ -74,7 +71,6 @@     maybe (return Nothing) (\k -> runMaybeT $ f k row) acc) . Just   foldrM f = MaybeT . foldrM (\row acc ->     maybe (return Nothing) (\k -> runMaybeT $ f row k) acc) . Just-  getNotification = lift . getNotification   withNewConnection = mapMaybeT withNewConnection  instance (Monoid w, MonadDB m) => MonadDB (L.RWST r w s m) where@@ -91,7 +87,6 @@   foldrM f acc = L.RWST $ \r s -> foldrM (\row ~(acc', s', w) -> do     ~(a, s'', w') <- L.runRWST (f row acc') r s'     return (a, s'', w `mappend` w')) (acc, s, mempty)-  getNotification = lift . getNotification   withNewConnection = L.mapRWST withNewConnection  instance (Monoid w, MonadDB m) => MonadDB (S.RWST r w s m) where@@ -108,7 +103,6 @@   foldrM f acc = S.RWST $ \r s -> foldrM (\row (acc', s', w) -> do     (a, s'', w') <- S.runRWST (f row acc') r s'     return (a, s'', w `mappend` w')) (acc, s, mempty)-  getNotification = lift . getNotification   withNewConnection = S.mapRWST withNewConnection  instance MonadDB m => MonadDB (ReaderT r m) where@@ -123,7 +117,6 @@     runReaderT (f acc' row) r) acc   foldrM f acc = ReaderT $ \r -> foldrM (\row acc' ->     runReaderT (f row acc') r) acc-  getNotification = lift . getNotification   withNewConnection = mapReaderT withNewConnection  instance MonadDB m => MonadDB (L.StateT s m) where@@ -138,7 +131,6 @@     L.runStateT (f acc' row) s') (acc, s)   foldrM f acc = L.StateT $ \s -> foldrM (\row ~(acc', s') ->     L.runStateT (f row acc') s') (acc, s)-  getNotification = lift . getNotification   withNewConnection = L.mapStateT withNewConnection  instance MonadDB m => MonadDB (S.StateT s m) where@@ -153,7 +145,6 @@     S.runStateT (f acc' row) s') (acc, s)   foldrM f acc = S.StateT $ \s -> foldrM (\row (acc', s') ->     S.runStateT (f row acc') s') (acc, s)-  getNotification = lift . getNotification   withNewConnection = S.mapStateT withNewConnection  instance (Monoid w, MonadDB m) => MonadDB (L.WriterT w m) where@@ -170,7 +161,6 @@   foldrM f acc = L.WriterT $ foldrM (\ row ~(acc', w) -> do     ~(r, w') <- L.runWriterT $ f row acc'     return (r, w `mappend` w')) (acc, mempty)-  getNotification = lift . getNotification   withNewConnection = L.mapWriterT withNewConnection  instance (Monoid w, MonadDB m) => MonadDB (S.WriterT w m) where@@ -187,5 +177,4 @@   foldrM f acc = S.WriterT $ foldrM (\ row (acc', w) -> do     (r, w') <- S.runWriterT $ f row acc'     return (r, w `mappend` w')) (acc, mempty)-  getNotification = lift . getNotification   withNewConnection = S.mapWriterT withNewConnection

@@ -32,7 +32,6 @@     foldrM f acc = controlT $ \run ->       run (return acc) >>= foldrM (\row acc' ->         run $ restoreT (return acc') >>= f row)-    getNotification = lift . getNotification     withNewConnection m = controlT $ \run ->       withNewConnection (run m) 

@@ -0,0 +1,85 @@+{-# LANGUAGE BangPatterns, FlexibleContexts, Rank2Types, ScopedTypeVariables #-}+module Database.PostgreSQL.PQTypes.Fold (+    foldLeftM+  , foldRightM+  ) where++import Control.Monad+import Control.Monad.Base+import Foreign.ForeignPtr.Safe+import Foreign.C.Types+import qualified Control.Exception as E++import Database.PostgreSQL.PQTypes.Class+import Database.PostgreSQL.PQTypes.Format+import Database.PostgreSQL.PQTypes.FromRow+import Database.PostgreSQL.PQTypes.Internal.C.Interface+import Database.PostgreSQL.PQTypes.Internal.C.Types+import Database.PostgreSQL.PQTypes.Internal.Exception+import Database.PostgreSQL.PQTypes.Internal.Error+import Database.PostgreSQL.PQTypes.Internal.QueryResult+import Database.PostgreSQL.PQTypes.Internal.Utils+import Database.PostgreSQL.PQTypes.SQL.Class++-- | Fold the result set of rows from left to right.+foldLeftM :: forall m row acc. (MonadBase IO m, MonadDB m, FromRow row)+          => (acc -> row -> m acc) -> acc -> m acc+foldLeftM f initAcc = withQueryResult $ \(_::row) ctx fres ferr ffmt ->+  liftBase (withForeignPtr fres c_PQntuples)+    >>= worker ctx fres ferr ffmt initAcc 0+  where+    worker ctx fres ferr ffmt acc !i !n+      | i == n    = return acc+      | otherwise = do+        obj <- liftBase $+          withForeignPtr fres $ \res ->+          withForeignPtr ferr $ \err ->+          withForeignPtr ffmt $ \fmt ->+            E.handle (rethrowWithContext ctx) (fromRow res err i fmt)+        acc' <- f acc obj+        worker ctx fres ferr ffmt acc' (i+1) n++-- | Fold the result set of rows from right to left.+foldRightM :: forall m row acc. (MonadBase IO m, MonadDB m, FromRow row)+           => (row -> acc -> m acc) -> acc -> m acc+foldRightM f initAcc = withQueryResult $ \(_::row) ctx fres ferr ffmt ->+  liftBase (withForeignPtr fres c_PQntuples)+    >>= worker ctx fres ferr ffmt initAcc (-1) . pred+  where+    worker ctx fres ferr ffmt acc !n !i+      | i == n    = return acc+      | otherwise = do+        obj <- liftBase $+          withForeignPtr fres $ \res ->+          withForeignPtr ferr $ \err ->+          withForeignPtr ffmt $ \fmt ->+            E.handle (rethrowWithContext ctx) (fromRow res err i fmt)+        acc' <- f obj acc+        worker ctx fres ferr ffmt acc' n (i-1)++----------------------------------------++-- | Helper for abstracting away shared elements of both folds.+withQueryResult :: forall m row r. (MonadBase IO m, MonadDB m, FromRow row)+                => (forall sql. IsSQL sql => row -> sql -> ForeignPtr PGresult -> ForeignPtr PGerror -> ForeignPtr CChar -> m r)+                -> m r+withQueryResult f = do+  mres <- getQueryResult+  SomeSQL ctx <- getLastQuery+  case mres of+    Nothing -> liftBase . rethrowWithContext ctx . E.toException . HPQTypesError+      $ "withQueryResult: no query result"+    Just (QueryResult res) -> do+      liftBase $ do+        rowlen <- fromIntegral `liftM` withForeignPtr res c_PQnfields+        let expected = pqVariables (undefined::row)+        when (rowlen /= expected) $+          E.throwIO DBException {+            dbeQueryContext = ctx+          , dbeError = RowLengthMismatch expected rowlen+          }+      fmt <- liftBase . bsToCString $ pqFormat (undefined::row)+      err <- liftBase mallocForeignPtr+      acc <- f (undefined::row) ctx res err fmt+      clearQueryResult+      return acc

@@ -2,12 +2,9 @@ -- | Exports a set of FFI-imported libpq/libpqtypes functions. module Database.PostgreSQL.PQTypes.Internal.C.Interface (   -- * libpq imports-    c_PQfreemem-  , c_PQstatus+    c_PQstatus   , c_PQerrorMessage   , c_PQsetClientEncoding-  , c_PQsocket-  , c_PQconsumeInput   , c_PQresultStatus   , c_PQresultErrorField   , c_PQresultErrorMessage@@ -34,16 +31,12 @@ import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable-import System.Posix.Types import qualified Control.Exception as E  import Database.PostgreSQL.PQTypes.Internal.C.Types  -- libpq imports -foreign import ccall unsafe "PQfreemem"-  c_PQfreemem :: Ptr a -> IO ()- foreign import ccall unsafe "PQstatus"   c_PQstatus :: Ptr PGconn -> IO ConnStatusType @@ -52,12 +45,6 @@  foreign import ccall unsafe "PQsetClientEncoding"   c_PQsetClientEncoding :: Ptr PGconn -> CString -> IO CInt--foreign import ccall unsafe "PQsocket"-  c_PQsocket :: Ptr PGconn -> IO Fd--foreign import ccall unsafe "PQconsumeInput"-  c_PQconsumeInput :: Ptr PGconn -> IO CInt  foreign import ccall unsafe "PQresultStatus"   c_PQresultStatus :: Ptr PGresult -> IO ExecStatusType

@@ -1,9 +1,7 @@-{-# LANGUAGE FlexibleContexts, RankNTypes, RecordWildCards-  , TupleSections #-}+{-# LANGUAGE FlexibleContexts, Rank2Types, RecordWildCards #-} module Database.PostgreSQL.PQTypes.Internal.Connection (     Connection(..)   , ConnectionData(..)-  , withConnectionData   , ConnectionStats(..)   , ConnectionSettings(..)   , defaultSettings@@ -15,7 +13,6 @@   ) where  import Control.Applicative-import Control.Arrow import Control.Concurrent.MVar import Control.Monad import Control.Monad.Base@@ -37,7 +34,6 @@ import Database.PostgreSQL.PQTypes.Internal.Exception import Database.PostgreSQL.PQTypes.Internal.Utils import Database.PostgreSQL.PQTypes.SQL-import Database.PostgreSQL.PQTypes.SQL.Class  data ConnectionSettings = ConnectionSettings { -- | Connection info string.@@ -94,15 +90,6 @@ newtype Connection = Connection {   unConnection :: MVar (Maybe ConnectionData) }--withConnectionData :: Connection-                   -> String-                   -> (ConnectionData -> IO (ConnectionData, r))-                   -> IO r-withConnectionData (Connection mvc) fname f =-  modifyMVar mvc $ \mc -> case mc of-    Nothing -> E.throwIO . HPQTypesError $ fname ++ ": no connection"-    Just cd -> first Just <$> f cd  -- | Database connection supplier. newtype ConnectionSource = ConnectionSource {

@@ -1,85 +0,0 @@-{-# LANGUAGE BangPatterns, FlexibleContexts, Rank2Types, ScopedTypeVariables #-}-module Database.PostgreSQL.PQTypes.Internal.Fold (-    foldLeftM-  , foldRightM-  ) where--import Control.Monad-import Control.Monad.Base-import Foreign.ForeignPtr.Safe-import Foreign.C.Types-import qualified Control.Exception as E--import Database.PostgreSQL.PQTypes.Class-import Database.PostgreSQL.PQTypes.Format-import Database.PostgreSQL.PQTypes.FromRow-import Database.PostgreSQL.PQTypes.Internal.C.Interface-import Database.PostgreSQL.PQTypes.Internal.C.Types-import Database.PostgreSQL.PQTypes.Internal.Exception-import Database.PostgreSQL.PQTypes.Internal.Error-import Database.PostgreSQL.PQTypes.Internal.QueryResult-import Database.PostgreSQL.PQTypes.Internal.Utils-import Database.PostgreSQL.PQTypes.SQL.Class---- | Fold the result set of rows from left to right.-foldLeftM :: forall m row acc. (MonadBase IO m, MonadDB m, FromRow row)-          => (acc -> row -> m acc) -> acc -> m acc-foldLeftM f initAcc = withQueryResult $ \(_::row) ctx fres ferr ffmt ->-  liftBase (withForeignPtr fres c_PQntuples)-    >>= worker ctx fres ferr ffmt initAcc 0-  where-    worker ctx fres ferr ffmt acc !i !n-      | i == n    = return acc-      | otherwise = do-        obj <- liftBase $-          withForeignPtr fres $ \res ->-          withForeignPtr ferr $ \err ->-          withForeignPtr ffmt $ \fmt ->-            E.handle (rethrowWithContext ctx) (fromRow res err i fmt)-        acc' <- f acc obj-        worker ctx fres ferr ffmt acc' (i+1) n---- | Fold the result set of rows from right to left.-foldRightM :: forall m row acc. (MonadBase IO m, MonadDB m, FromRow row)-           => (row -> acc -> m acc) -> acc -> m acc-foldRightM f initAcc = withQueryResult $ \(_::row) ctx fres ferr ffmt ->-  liftBase (withForeignPtr fres c_PQntuples)-    >>= worker ctx fres ferr ffmt initAcc (-1) . pred-  where-    worker ctx fres ferr ffmt acc !n !i-      | i == n    = return acc-      | otherwise = do-        obj <- liftBase $-          withForeignPtr fres $ \res ->-          withForeignPtr ferr $ \err ->-          withForeignPtr ffmt $ \fmt ->-            E.handle (rethrowWithContext ctx) (fromRow res err i fmt)-        acc' <- f obj acc-        worker ctx fres ferr ffmt acc' n (i-1)---------------------------------------------- | Helper for abstracting away shared elements of both folds.-withQueryResult :: forall m row r. (MonadBase IO m, MonadDB m, FromRow row)-                => (forall sql. IsSQL sql => row -> sql -> ForeignPtr PGresult -> ForeignPtr PGerror -> ForeignPtr CChar -> m r)-                -> m r-withQueryResult f = do-  mres <- getQueryResult-  SomeSQL ctx <- getLastQuery-  case mres of-    Nothing -> liftBase . rethrowWithContext ctx . E.toException . HPQTypesError-      $ "withQueryResult: no query result"-    Just (QueryResult res) -> do-      liftBase $ do-        rowlen <- fromIntegral `liftM` withForeignPtr res c_PQnfields-        let expected = pqVariables (undefined::row)-        when (rowlen /= expected) $-          E.throwIO DBException {-            dbeQueryContext = ctx-          , dbeError = RowLengthMismatch expected rowlen-          }-      fmt <- liftBase . bsToCString $ pqFormat (undefined::row)-      err <- liftBase mallocForeignPtr-      acc <- f (undefined::row) ctx res err fmt-      clearQueryResult-      return acc

@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving-  , MultiParamTypeClasses, ScopedTypeVariables, TupleSections-  , TypeFamilies, UndecidableInstances, CPP #-}+  , MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies+  , UndecidableInstances, CPP #-} module Database.PostgreSQL.PQTypes.Internal.Monad (     DBT(..)   , runDBT@@ -21,11 +21,10 @@ import qualified Control.Monad.Trans.State as S  import Database.PostgreSQL.PQTypes.Class+import Database.PostgreSQL.PQTypes.Fold import Database.PostgreSQL.PQTypes.Internal.Connection import Database.PostgreSQL.PQTypes.Internal.Error import Database.PostgreSQL.PQTypes.Internal.Exception-import Database.PostgreSQL.PQTypes.Internal.Fold-import Database.PostgreSQL.PQTypes.Internal.Notification import Database.PostgreSQL.PQTypes.Internal.Query import Database.PostgreSQL.PQTypes.Internal.State import Database.PostgreSQL.PQTypes.SQL@@ -64,7 +63,7 @@ ----------------------------------------  instance (MonadBase IO m, MonadMask m) => MonadDB (DBT m) where-  runQuery sql = DBT . StateT $ liftBase . runQueryIO sql+  runQuery = runSQLQuery DBT   getLastQuery = DBT . gets $ dbLastQuery    getConnectionStats = do@@ -81,9 +80,6 @@    foldlM = foldLeftM   foldrM = foldRightM--  getNotification time = DBT . StateT $ \st -> (, st)-    <$> liftBase (getNotificationIO st time)    withNewConnection m = DBT . StateT $ \st -> do     let cs = dbConnectionSource st

@@ -1,111 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, ForeignFunctionInterface, RecordWildCards-  , TupleSections #-}-module Database.PostgreSQL.PQTypes.Internal.Notification (-    Channel(..)-  , Notification(..)-  , getNotificationIO-  ) where--import Control.Concurrent-import Control.Monad-import Control.Monad.Fix-import Data.String-import Data.Typeable-import Foreign.Ptr-import Foreign.Storable-import System.Posix.Types-import System.Timeout-import qualified Control.Exception as E-import qualified Data.ByteString.Char8 as BS--import Database.PostgreSQL.PQTypes.Internal.C.Interface-import Database.PostgreSQL.PQTypes.Internal.C.Types-import Database.PostgreSQL.PQTypes.Internal.Connection-import Database.PostgreSQL.PQTypes.Internal.Exception-import Database.PostgreSQL.PQTypes.Internal.State-import Database.PostgreSQL.PQTypes.Internal.Utils-import Database.PostgreSQL.PQTypes.SQL.Class-import Database.PostgreSQL.PQTypes.SQL.Raw--#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__);}, y__)--#include <libpq-fe.h>--foreign import ccall unsafe "PQnotifies"-  c_PQnotifies :: Ptr PGconn -> IO (Ptr Notification)---------------------------------------------- | Representation of notification channel.-newtype Channel = Channel (RawSQL ())-  deriving (Eq, Ord, Typeable)--instance IsString Channel where-  fromString = Channel . fromString--instance Show Channel where-  showsPrec n (Channel chan) = ("Channel " ++) . showsPrec n (unRawSQL chan)---------------------------------------------- | Representation of a notification sent by PostgreSQL.-data Notification = Notification {--- | Process ID of notifying server.-  ntPID     :: !CPid-  -- | Notification channel name.-, ntChannel :: !Channel-  -- | Notification payload string.-, ntPayload :: !BS.ByteString-} deriving (Eq, Ord, Show, Typeable)--instance Storable Notification where-  sizeOf _ = #{size PGnotify}-  alignment _ = #{alignment PGnotify}-  peek ptr = do-    ntPID <- return . CPid-      =<< #{peek PGnotify, be_pid} ptr-    ntChannel <- fmap (Channel . flip rawSQL ()) . BS.packCString-      =<< #{peek PGnotify, relname} ptr-    ntPayload <- BS.packCString-      =<< #{peek PGnotify, extra} ptr-    return Notification{..}-  poke _ _ = error "Storable Notification: poke is not supposed to be used"---------------------------------------------- | Low-level function that waits for a notification for a given--- number of microseconds (it uses 'timeout' function internally).-getNotificationIO :: DBState -> Int -> IO (Maybe Notification)-getNotificationIO st n = do-  let mvconn = dbConnection st-  SomeSQL ctx <- return $ dbLastQuery st-  E.handle (rethrowWithContext ctx)-    . timeout n-    . withConnectionData mvconn fname $ \cd -> fix $ \loop -> do-      let conn = cdPtr cd-      mmsg <- tryGet conn-      case mmsg of-        Just msg -> return (cd, msg)-        Nothing -> do-          fd <- c_PQsocket conn-          if fd == -1-            then hpqTypesError $ fname ++ ": invalid file descriptor"-            else do-              threadWaitRead fd-              res <- c_PQconsumeInput conn-              when (res /= 1) $ do-                throwLibPQError conn fname-              loop-  where-    fname :: String-    fname = "getNotificationIO"--    tryGet :: Ptr PGconn -> IO (Maybe Notification)-    tryGet connPtr = E.mask_ $ do-      ptr <- c_PQnotifies connPtr-      if ptr /= nullPtr-        then do-          msg <- peek ptr-          c_PQfreemem ptr-          return $ Just msg-        else return Nothing

@@ -1,9 +1,12 @@ {-# LANGUAGE FlexibleContexts, RecordWildCards #-} module Database.PostgreSQL.PQTypes.Internal.Query (-    runQueryIO+    runSQLQuery   ) where  import Control.Applicative+import Control.Concurrent.MVar+import Control.Monad.Base+import Control.Monad.Trans.State import Foreign.ForeignPtr import Foreign.Ptr import qualified Control.Exception as E@@ -19,41 +22,48 @@ import Database.PostgreSQL.PQTypes.SQL.Class import Database.PostgreSQL.PQTypes.Internal.Utils --- | Low-level function for running SQL query.-runQueryIO :: IsSQL sql => sql -> DBState -> IO (Int, DBState)-runQueryIO sql st = E.handle (rethrowWithContext sql) $ do-  (affected, res) <- withConnectionData (dbConnection st) "runQueryIO" $ \cd -> do-    let ConnectionData{..} = cd-    (paramCount, res) <- withSQL sql (withPGparam cdPtr) $ \param query -> (,)-      <$> (fromIntegral <$> c_PQparamCount param)-      <*> c_PQparamExec cdPtr nullPtr param query c_RESULT_BINARY-    affected <- withForeignPtr res $ verifyResult cdPtr-    stats' <- case affected of-      Left _ -> return cdStats {-        statsQueries = statsQueries cdStats + 1-      , statsParams  = statsParams cdStats + paramCount-      }-      Right rows -> do-        columns <- fromIntegral <$> withForeignPtr res c_PQnfields-        return ConnectionStats {+-- | Run SQL query.+runSQLQuery :: (IsSQL sql, MonadBase IO m)+            => (StateT DBState m Int -> r) -> sql -> r+runSQLQuery dbT sql = dbT $ do+  mvconn <- gets (unConnection . dbConnection)+  (affected, res) <- liftBase . modifyMVar mvconn $ \mconn -> case mconn of+    Nothing -> E.throwIO DBException {+      dbeQueryContext = sql+    , dbeError = HPQTypesError "runQuery: no connection"+    }+    Just cd@ConnectionData{..} -> E.handle (rethrowWithContext sql) $ do+      (paramCount, res) <- withSQL sql (withPGparam cdPtr) $ \param query -> (,)+        <$> (fromIntegral <$> c_PQparamCount param)+        <*> c_PQparamExec cdPtr nullPtr param query c_RESULT_BINARY+      affected <- withForeignPtr res $ verifyResult cdPtr+      stats' <- case affected of+        Left _ -> return cdStats {           statsQueries = statsQueries cdStats + 1-        , statsRows    = statsRows cdStats + rows-        , statsValues  = statsValues cdStats + (rows * columns)         , statsParams  = statsParams cdStats + paramCount         }-    -- Force evaluation of modified stats to squash space leak.-    stats' `seq` return (cd { cdStats = stats' }, (either id id affected, res))-  return (affected, st {+        Right rows -> do+          columns <- fromIntegral <$> withForeignPtr res c_PQnfields+          return ConnectionStats {+            statsQueries = statsQueries cdStats + 1+          , statsRows    = statsRows cdStats + rows+          , statsValues  = statsValues cdStats + (rows * columns)+          , statsParams  = statsParams cdStats + paramCount+          }+      -- Force evaluation of modified stats to squash space leak.+      stats' `seq` return (Just cd { cdStats = stats' }, (either id id affected, res))+  modify $ \st -> st {     dbLastQuery = someSQL sql   , dbQueryResult = Just $ QueryResult res-  })+  }+  return affected   where     verifyResult :: Ptr PGconn -> Ptr PGresult -> IO (Either Int Int)     verifyResult conn res = do       -- works even if res is NULL-      rst <- c_PQresultStatus res-      case rst of-        _ | rst == c_PGRES_COMMAND_OK -> do+      st <- c_PQresultStatus res+      case st of+        _ | st == c_PGRES_COMMAND_OK -> do           sn <- c_PQcmdTuples res >>= BS.packCString           case BS.readInt sn of             Nothing@@ -62,9 +72,9 @@             Just (n, rest)               | rest /= BS.empty -> throwParseError sn               | otherwise        -> return . Left $ n-        _ | rst == c_PGRES_TUPLES_OK    -> Right . fromIntegral <$> c_PQntuples res-        _ | rst == c_PGRES_FATAL_ERROR  -> throwSQLError-        _ | rst == c_PGRES_BAD_RESPONSE -> throwSQLError+        _ | st == c_PGRES_TUPLES_OK    -> Right . fromIntegral <$> c_PQntuples res+        _ | st == c_PGRES_FATAL_ERROR  -> throwSQLError+        _ | st == c_PGRES_BAD_RESPONSE -> throwSQLError         _ | otherwise                  -> return . Left $ 0         where           throwSQLError = throwQueryError conn res

@@ -1,34 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Database.PostgreSQL.PQTypes.Notification (-    Channel(..)-  , Notification(..)-  , listen-  , unlisten-  , unlistenAll-  , notify-  ) where--import Data.ByteString (ByteString)--import Data.Monoid.Space-import Database.PostgreSQL.PQTypes.Class-import Database.PostgreSQL.PQTypes.Internal.Notification-import Database.PostgreSQL.PQTypes.SQL.Raw-import Database.PostgreSQL.PQTypes.Utils---- | Start listening for notifications on a given channel.-listen :: MonadDB m => Channel -> m ()-listen (Channel chan) = runQuery_ $ "LISTEN" <+> chan---- | Stop listening for notifications on a given channel.-unlisten :: MonadDB m => Channel -> m ()-unlisten (Channel chan) = runQuery_ $ "UNLISTEN" <+> chan---- | Cancel all listener registrations for the current session.-unlistenAll :: MonadDB m => m ()-unlistenAll = runSQL_ "UNLISTEN *"---- | Generate a notification on a given channel.-notify :: MonadDB m => Channel -> ByteString -> m ()-notify (Channel chan) payload = runQuery_-  $ rawSQL "SELECT pg_notify($1, $2)" (unRawSQL chan, payload)

@@ -17,8 +17,6 @@ import Control.Monad.Catch import Data.String import Data.Typeable-import qualified Data.ByteString as BS-import System.IO.Unsafe  import Data.Monoid.Space import Data.Monoid.Utils@@ -84,16 +82,11 @@ withTransaction' ts m = mask $ exec 1   where     exec :: Integer -> (forall r. m r -> m r) -> m a-    exec !n restore = handleJust expred (\_ -> do-      unsafePerformIO $ do-        BS.appendFile "/home/unknown/transaction.txt" "."-        return $ return ()-      exec (succ n) restore-      ) $ do-        begin' ts-        res <- restore m `onException` rollback' ts-        commit' ts-        return res+    exec !n restore = handleJust expred (const $ exec (succ n) restore) $ do+      begin' ts+      res <- restore m `onException` rollback' ts+      commit' ts+      return res       where         expred :: DBException -> Maybe ()         expred DBException{..} = do

@@ -1,12 +1,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts   , GeneralizedNewtypeDeriving, MultiParamTypeClasses, OverloadedStrings-  , RecordWildCards, ScopedTypeVariables, TypeFamilies-  , UndecidableInstances, CPP #-}+  , ScopedTypeVariables, TypeFamilies, UndecidableInstances, CPP #-} module Main where  import Control.Applicative-import Control.Concurrent.Lifted import Control.Monad import Control.Monad.Base import Control.Monad.Catch@@ -14,7 +12,6 @@ import Control.Monad.Trans.Control import Data.Char import Data.Int-import Data.Maybe import Data.Time import Data.Typeable import Data.Word@@ -25,7 +22,6 @@ import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, assertEqual) import Test.QuickCheck-import Test.QuickCheck.Compat import Test.QuickCheck.Gen import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC@@ -37,7 +33,7 @@ import Prelude.Instances () import Test.QuickCheck.Arbitrary.Instances () -type InnerTestEnv = StateT QCGen (DBT IO)+type InnerTestEnv = StateT StdGen (DBT IO)  newtype TestEnv a = TestEnv { unTestEnv :: InnerTestEnv a }   deriving (Applicative, Functor, Monad, MonadBase IO, MonadCatch, MonadDB, MonadMask, MonadThrow)@@ -45,9 +41,9 @@ instance MonadBaseControl IO TestEnv where #if MIN_VERSION_monad_control(1,0,0)   type StM TestEnv a = StM InnerTestEnv a-  liftBaseWith f = TestEnv $ liftBaseWith $ \run ->-                         f $ run . unTestEnv-  restoreM = TestEnv . restoreM+  liftBaseWith f = liftBaseWith $ \run ->+                         f $ run+  restoreM = restoreM #else   newtype StM TestEnv a = StTestEnv { unStTestEnv :: StM InnerTestEnv a }   liftBaseWith f = TestEnv $ liftBaseWith $ \run ->@@ -55,15 +51,15 @@   restoreM = TestEnv . restoreM . unStTestEnv #endif -withQCGen :: (QCGen -> r) -> TestEnv r-withQCGen f = do+withStdGen :: (StdGen -> r) -> TestEnv r+withStdGen f = do   gen <- TestEnv get   TestEnv . modify $ snd . next   return (f gen)  ---------------------------------------- -type TestData = (QCGen, ConnectionSource)+type TestData = (StdGen, ConnectionSource)  runTestEnv :: TestData -> TransactionSettings -> TestEnv a -> IO a runTestEnv (env, cs) ts m = runDBT cs ts $ evalStateT (unTestEnv m) env@@ -248,11 +244,8 @@ dts :: TransactionSettings dts = defaultTransactionSettings -tsNoTrans :: TransactionSettings-tsNoTrans = dts { tsAutoTransaction = False }- randomValue :: Arbitrary t => Int -> TestEnv t-randomValue n = withQCGen $ \gen -> unGen arbitrary gen n+randomValue n = withStdGen $ \gen -> unGen arbitrary gen n  assertEqual :: (Show a, MonadBase IO m)             => String -> a -> a -> (a -> a -> Bool) -> m ()@@ -267,7 +260,7 @@ ----------------------------------------  autocommitTest :: TestData -> Test-autocommitTest td = testCase "Autocommit mode works" . runTestEnv td tsNoTrans $ do+autocommitTest td = testCase "Autocommit mode works" . runTestEnv td dts{tsAutoTransaction = False} $ do   let sint = Single (1::Int32)   runQuery_ $ rawSQL "INSERT INTO test1_ (a) VALUES ($1)" sint   withNewConnection $ do@@ -310,31 +303,6 @@   res2 <- fetchMany unSingle   assertEqual "Result of all queries is visible" res2 [int1, int2] (==) -notifyTest :: TestData -> Test-notifyTest td = testCase "Notifications work" . runTestEnv td tsNoTrans $ do-  listen chan-  forkNewConn $ notify chan payload-  mnt1 <- getNotification 100000-  liftBase $ assertBool "Notification received" (isJust mnt1)-  let Just nt1 = mnt1-  assertEqual "Channels are equal" chan (ntChannel nt1) (==)-  assertEqual "Payloads are equal" payload (ntPayload nt1) (==)--  unlisten chan-  forkNewConn $ notify chan payload-  mnt2 <- getNotification 100000-  assertEqual "No notification received after unlisten" Nothing mnt2 (==)--  listen chan-  unlistenAll-  forkNewConn $ notify chan payload-  mnt3 <- getNotification 100000-  assertEqual "No notification received after unlistenAll" Nothing mnt3 (==)-  where-    chan = "test_channel"-    payload = "test_payload"-    forkNewConn = void . fork . withNewConnection- transactionTest :: TestData -> IsolationLevel -> Test transactionTest td lvl = testCase ("Auto transaction works by default with isolation level" <+> show lvl) . runTestEnv td dts{tsIsolationLevel = lvl} $ do   let sint = Single (5::Int32)@@ -397,7 +365,6 @@   , xmlTest td   , readOnlyTest td   , savepointTest td-  , notifyTest td   ----------------------------------------   , transactionTest td ReadCommitted   , transactionTest td RepeatableRead@@ -541,7 +508,7 @@    createStructures connSource   connPool <- poolSource (connSettings { csComposites = ["simple_", "nested_"] }) 1 30 16-  gen <- newQCGen+  gen <- getStdGen   putStrLn $ "PRNG:" <+> show gen    finally (defaultMainWithArgs (tests (gen, connPool)) $ tail args) $ do