hpqtypes 1.3.0 → 1.3.1

raw patch · 18 files changed

+439/−153 lines, 18 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 +6/−3
• libpqtypes/src/handler.c +4/−1
• libpqtypes/src/libpqtypes-int.h +1/−0
• src/Database/PostgreSQL/PQTypes.hs +4/−2
• src/Database/PostgreSQL/PQTypes/Class.hs +18/−0
• src/Database/PostgreSQL/PQTypes/Class/Instances.hs +11/−0
• src/Database/PostgreSQL/PQTypes/Class/Instances/Overlapping.hs +1/−0
• src/Database/PostgreSQL/PQTypes/Fold.hs +0/−85
• src/Database/PostgreSQL/PQTypes/Internal/C/Interface.hs +14/−1
• src/Database/PostgreSQL/PQTypes/Internal/Connection.hs +14/−1
• src/Database/PostgreSQL/PQTypes/Internal/Fold.hs +85/−0
• src/Database/PostgreSQL/PQTypes/Internal/Monad.hs +8/−4
• src/Database/PostgreSQL/PQTypes/Internal/Notification.hsc +111/−0
• src/Database/PostgreSQL/PQTypes/Internal/Query.hs +30/−40
• src/Database/PostgreSQL/PQTypes/Notification.hs +34/−0
• src/Database/PostgreSQL/PQTypes/Transaction.hs +12/−5
• src/Database/PostgreSQL/PQTypes/XML.hs +29/−0
• test/Main.hs +57/−11

@@ -1,5 +1,5 @@ name:                hpqtypes-version:             1.3.0+version:             1.3.1 synopsis:            Haskell bindings to libpqtypes  description:         Efficient and easy-to-use bindings to (slightly modified)@@ -68,7 +68,6 @@                      , 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@@ -78,18 +77,22 @@                      , 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                      , Database.PostgreSQL.PQTypes.SQL.Class                      , Database.PostgreSQL.PQTypes.Transaction.Settings+                     , 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@@ -159,7 +162,7 @@                      , monad-control >= 0.3                      , lifted-base >= 0.2                      , mtl >= 2.1-                     , QuickCheck >= 2.5 && < 2.7+                     , QuickCheck >= 2.5                      , HUnit >= 1.2                      , test-framework >= 0.8                      , test-framework-hunit >= 0.3

@@ -116,7 +116,10 @@ 	/* text passed as bytea to avoid double copy with ByteStringS 	 * and silent truncation of strings containting NULL characters */ 	{34, "pg_catalog", "btext", -1, TEXTOID, 1009, pqt_put_bytea,-		pqt_get_bytea, __HANDLER_DEFAULTS__}+                pqt_get_bytea, __HANDLER_DEFAULTS__},++	{35, "pg_catalog", "xml", -1, XMLOID, 143, pqt_put_bytea,+		pqt_get_bytea, __HANDLER_DEFAULTS__}, /* supports ptr */ };  static int

@@ -257,6 +257,7 @@ #define ZPBITOID         1560 /* not supported yet */ #define VARBITOID        1562 /* not supported yet */ #define BYTEAOID           17+#define XMLOID            142 /* date and time types */ #define DATEOID          1082 #define TIMEOID          1083

@@ -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@@ -54,6 +54,7 @@   , module Database.PostgreSQL.PQTypes.Transaction   , module Database.PostgreSQL.PQTypes.Transaction.Settings   , module Database.PostgreSQL.PQTypes.Utils+  , module Database.PostgreSQL.PQTypes.XML   ) where  import Database.PostgreSQL.PQTypes.Internal.Connection@@ -68,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@@ -82,3 +83,4 @@ import Database.PostgreSQL.PQTypes.Transaction import Database.PostgreSQL.PQTypes.Transaction.Settings import Database.PostgreSQL.PQTypes.Utils+import Database.PostgreSQL.PQTypes.XML

@@ -6,6 +6,7 @@  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@@ -38,6 +39,23 @@   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,6 +31,7 @@     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@@ -43,6 +44,7 @@   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@@ -57,6 +59,7 @@     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@@ -71,6 +74,7 @@     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@@ -87,6 +91,7 @@   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@@ -103,6 +108,7 @@   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@@ -117,6 +123,7 @@     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@@ -131,6 +138,7 @@     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@@ -145,6 +153,7 @@     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@@ -161,6 +170,7 @@   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@@ -177,4 +187,5 @@   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,6 +32,7 @@     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) 

@@ -1,85 +0,0 @@-{-# 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,9 +2,12 @@ -- | Exports a set of FFI-imported libpq/libpqtypes functions. module Database.PostgreSQL.PQTypes.Internal.C.Interface (   -- * libpq imports-    c_PQstatus+    c_PQfreemem+  , c_PQstatus   , c_PQerrorMessage   , c_PQsetClientEncoding+  , c_PQsocket+  , c_PQconsumeInput   , c_PQresultStatus   , c_PQresultErrorField   , c_PQresultErrorMessage@@ -31,12 +34,16 @@ 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 @@ -45,6 +52,12 @@  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,7 +1,9 @@-{-# LANGUAGE FlexibleContexts, Rank2Types, RecordWildCards #-}+{-# LANGUAGE FlexibleContexts, RankNTypes, RecordWildCards+  , TupleSections #-} module Database.PostgreSQL.PQTypes.Internal.Connection (     Connection(..)   , ConnectionData(..)+  , withConnectionData   , ConnectionStats(..)   , ConnectionSettings(..)   , defaultSettings@@ -13,6 +15,7 @@   ) where  import Control.Applicative+import Control.Arrow import Control.Concurrent.MVar import Control.Monad import Control.Monad.Base@@ -34,6 +37,7 @@ 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.@@ -90,6 +94,15 @@ 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 {

@@ -0,0 +1,85 @@+{-# 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, TypeFamilies-  , UndecidableInstances, CPP #-}+  , MultiParamTypeClasses, ScopedTypeVariables, TupleSections+  , TypeFamilies, UndecidableInstances, CPP #-} module Database.PostgreSQL.PQTypes.Internal.Monad (     DBT(..)   , runDBT@@ -21,10 +21,11 @@ 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@@ -63,7 +64,7 @@ ----------------------------------------  instance (MonadBase IO m, MonadMask m) => MonadDB (DBT m) where-  runQuery = runSQLQuery DBT+  runQuery sql = DBT . StateT $ liftBase . runQueryIO sql   getLastQuery = DBT . gets $ dbLastQuery    getConnectionStats = do@@ -80,6 +81,9 @@    foldlM = foldLeftM   foldrM = foldRightM++  getNotification time = DBT . StateT $ \st -> (, st)+    <$> liftBase (getNotificationIO st time)    withNewConnection m = DBT . StateT $ \st -> do     let cs = dbConnectionSource st

@@ -0,0 +1,111 @@+{-# 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,12 +1,9 @@ {-# LANGUAGE FlexibleContexts, RecordWildCards #-} module Database.PostgreSQL.PQTypes.Internal.Query (-    runSQLQuery+    runQueryIO   ) 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@@ -22,48 +19,41 @@ import Database.PostgreSQL.PQTypes.SQL.Class import Database.PostgreSQL.PQTypes.Internal.Utils --- | 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 {+-- | 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 {           statsQueries = statsQueries cdStats + 1+        , statsRows    = statsRows cdStats + rows+        , statsValues  = statsValues cdStats + (rows * columns)         , statsParams  = statsParams cdStats + paramCount         }-        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 {+    -- Force evaluation of modified stats to squash space leak.+    stats' `seq` return (cd { cdStats = stats' }, (either id id affected, res))+  return (affected, 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-      st <- c_PQresultStatus res-      case st of-        _ | st == c_PGRES_COMMAND_OK -> do+      rst <- c_PQresultStatus res+      case rst of+        _ | rst == c_PGRES_COMMAND_OK -> do           sn <- c_PQcmdTuples res >>= BS.packCString           case BS.readInt sn of             Nothing@@ -72,9 +62,9 @@             Just (n, rest)               | rest /= BS.empty -> throwParseError sn               | otherwise        -> return . Left $ n-        _ | st == c_PGRES_TUPLES_OK    -> Right . fromIntegral <$> c_PQntuples res-        _ | st == c_PGRES_FATAL_ERROR  -> throwSQLError-        _ | st == c_PGRES_BAD_RESPONSE -> throwSQLError+        _ | rst == c_PGRES_TUPLES_OK    -> Right . fromIntegral <$> c_PQntuples res+        _ | rst == c_PGRES_FATAL_ERROR  -> throwSQLError+        _ | rst == c_PGRES_BAD_RESPONSE -> throwSQLError         _ | otherwise                  -> return . Left $ 0         where           throwSQLError = throwQueryError conn res

@@ -0,0 +1,34 @@+{-# 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,6 +17,8 @@ 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@@ -82,11 +84,16 @@ withTransaction' ts m = mask $ exec 1   where     exec :: Integer -> (forall r. m r -> m r) -> m a-    exec !n restore = handleJust expred (const $ exec (succ n) restore) $ do-      begin' ts-      res <- restore m `onException` rollback' ts-      commit' ts-      return res+    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       where         expred :: DBException -> Maybe ()         expred DBException{..} = do

@@ -0,0 +1,29 @@+{-# LANGUAGE DeriveDataTypeable, TypeFamilies #-}+module Database.PostgreSQL.PQTypes.XML (+    XML(..)+  ) where++import Data.Text+import Data.Typeable+import qualified Data.ByteString.Char8 as BSC++import Database.PostgreSQL.PQTypes.Format+import Database.PostgreSQL.PQTypes.FromSQL+import Database.PostgreSQL.PQTypes.Internal.C.Types+import Database.PostgreSQL.PQTypes.ToSQL++-- | Representation of SQL XML types as 'Text'.  Users of hpqtypes may+-- want to add conversion instances for their favorite XML type around 'XML'.+newtype XML = XML { unXML :: Text }+  deriving (Eq, Ord, Read, Show, Typeable)++instance PQFormat XML where+  pqFormat _ = BSC.pack "%xml"++instance FromSQL XML where+  type PQBase XML = PGbytea+  fromSQL = fmap XML . fromSQL++instance ToSQL XML where+  type PQDest XML = PGbytea+  toSQL = toSQL . unXML

@@ -1,10 +1,12 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleContexts   , GeneralizedNewtypeDeriving, MultiParamTypeClasses, OverloadedStrings-  , ScopedTypeVariables, TypeFamilies, UndecidableInstances, CPP #-}+  , RecordWildCards, 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@@ -12,6 +14,7 @@ import Control.Monad.Trans.Control import Data.Char import Data.Int+import Data.Maybe import Data.Time import Data.Typeable import Data.Word@@ -22,6 +25,7 @@ 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@@ -33,7 +37,7 @@ import Prelude.Instances () import Test.QuickCheck.Arbitrary.Instances () -type InnerTestEnv = StateT StdGen (DBT IO)+type InnerTestEnv = StateT QCGen (DBT IO)  newtype TestEnv a = TestEnv { unTestEnv :: InnerTestEnv a }   deriving (Applicative, Functor, Monad, MonadBase IO, MonadCatch, MonadDB, MonadMask, MonadThrow)@@ -41,9 +45,9 @@ instance MonadBaseControl IO TestEnv where #if MIN_VERSION_monad_control(1,0,0)   type StM TestEnv a = StM InnerTestEnv a-  liftBaseWith f = liftBaseWith $ \run ->-                         f $ run-  restoreM = restoreM+  liftBaseWith f = TestEnv $ liftBaseWith $ \run ->+                         f $ run . unTestEnv+  restoreM = TestEnv . restoreM #else   newtype StM TestEnv a = StTestEnv { unStTestEnv :: StM InnerTestEnv a }   liftBaseWith f = TestEnv $ liftBaseWith $ \run ->@@ -51,15 +55,15 @@   restoreM = TestEnv . restoreM . unStTestEnv #endif -withStdGen :: (StdGen -> r) -> TestEnv r-withStdGen f = do+withQCGen :: (QCGen -> r) -> TestEnv r+withQCGen f = do   gen <- TestEnv get   TestEnv . modify $ snd . next   return (f gen)  ---------------------------------------- -type TestData = (StdGen, ConnectionSource)+type TestData = (QCGen, ConnectionSource)  runTestEnv :: TestData -> TransactionSettings -> TestEnv a -> IO a runTestEnv (env, cs) ts m = runDBT cs ts $ evalStateT (unTestEnv m) env@@ -244,8 +248,11 @@ dts :: TransactionSettings dts = defaultTransactionSettings +tsNoTrans :: TransactionSettings+tsNoTrans = dts { tsAutoTransaction = False }+ randomValue :: Arbitrary t => Int -> TestEnv t-randomValue n = withStdGen $ \gen -> unGen arbitrary gen n+randomValue n = withQCGen $ \gen -> unGen arbitrary gen n  assertEqual :: (Show a, MonadBase IO m)             => String -> a -> a -> (a -> a -> Bool) -> m ()@@ -260,7 +267,7 @@ ----------------------------------------  autocommitTest :: TestData -> Test-autocommitTest td = testCase "Autocommit mode works" . runTestEnv td dts{tsAutoTransaction = False} $ do+autocommitTest td = testCase "Autocommit mode works" . runTestEnv td tsNoTrans $ do   let sint = Single (1::Int32)   runQuery_ $ rawSQL "INSERT INTO test1_ (a) VALUES ($1)" sint   withNewConnection $ do@@ -303,6 +310,31 @@   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)@@ -330,6 +362,18 @@   v' <- fetchOne unSingle   assertEqual "Value doesn't change after getting through database" v v' eq +xmlTest :: TestData -> Test+xmlTest td  = testCase "Put and get XML value works" . runTestEnv td dts $ do+  runSQL_ $ "SET CLIENT_ENCODING TO 'UTF8'"+  let v = XML "some<tag>stringå</tag>"+  runSQL_ $ "SELECT XML 'some<tag>stringå</tag>'"+  v' <- fetchOne unSingle+  assertEqual "XML value correct" v v' (==)+  runSQL_ $ "SELECT" <?> v+  v'' <- fetchOne unSingle+  assertEqual "XML value correct" v v'' (==)+  runSQL_ $ "SET CLIENT_ENCODING TO 'latin-1'"+ rowTest :: forall row. (Arbitrary row, Eq row, Show row, ToRow row, FromRow row)         => TestData -> row -> Test rowTest td r = testCase ("Putting row of length" <+> show (pqVariables r) <+> "through database works") . runTestEnv td dts . runTimes 100 $ do@@ -350,8 +394,10 @@ tests :: TestData -> [Test] tests td = [     autocommitTest td+  , xmlTest td   , readOnlyTest td   , savepointTest td+  , notifyTest td   ----------------------------------------   , transactionTest td ReadCommitted   , transactionTest td RepeatableRead@@ -495,7 +541,7 @@    createStructures connSource   connPool <- poolSource (connSettings { csComposites = ["simple_", "nested_"] }) 1 30 16-  gen <- getStdGen+  gen <- newQCGen   putStrLn $ "PRNG:" <+> show gen    finally (defaultMainWithArgs (tests (gen, connPool)) $ tail args) $ do