postgresql-simple 0.2.4.1 → 0.3.0.0

raw patch · 26 files changed

+1497/−392 lines, 26 files

Files

• CONTRIBUTORS +3/−0
• postgresql-simple.cabal +13/−4
• src/Database/PostgreSQL/Simple.hs +16/−207
• src/Database/PostgreSQL/Simple.hs-boot +23/−0
• src/Database/PostgreSQL/Simple/Arrays.hs +94/−0
• src/Database/PostgreSQL/Simple/Compat.hs +22/−2
• src/Database/PostgreSQL/Simple/Errors.hs +110/−0
• src/Database/PostgreSQL/Simple/FromField.hs +184/−40
• src/Database/PostgreSQL/Simple/FromField.hs-boot +10/−0
• src/Database/PostgreSQL/Simple/FromRow.hs +30/−16
• src/Database/PostgreSQL/Simple/FromRow.hs-boot +8/−0
• src/Database/PostgreSQL/Simple/Internal.hs +67/−52
• src/Database/PostgreSQL/Simple/LargeObjects.hs +1/−3
• src/Database/PostgreSQL/Simple/SqlQQ.hs +22/−11
• src/Database/PostgreSQL/Simple/ToField.hs +10/−0
• src/Database/PostgreSQL/Simple/ToField.hs-boot +7/−0
• src/Database/PostgreSQL/Simple/ToRow.hs-boot +8/−0
• src/Database/PostgreSQL/Simple/Transaction.hs +193/−0
• src/Database/PostgreSQL/Simple/TypeInfo.hs +63/−0
• src/Database/PostgreSQL/Simple/TypeInfo/Static.hs +487/−0
• src/Database/PostgreSQL/Simple/TypeInfo/Types.hs +30/−0
• test/Bytea.hs +0/−25
• test/ExecuteMany.hs +0/−23
• test/Main.hs +94/−7
• test/Serializable.hs +1/−1
• test/Time.hs +1/−1

@@ -5,4 +5,7 @@ Joey Adams <joeyadams3.14159@gmail.com> Rekado <rekado@elephly.net> Leonid Onokhov <sopvop@gmail.com>+Bas van Dijk <v.dijk.bas@gmail.com> Jason Dusek <jason.dusek@gmail.com>+Jeff Chu <jeff@kiteedu.com>+Oliver Charles <oliver.g.charles@gmail.com>

@@ -1,5 +1,5 @@ Name:                postgresql-simple-Version:             0.2.4.1+Version:             0.3.0.0 Synopsis:            Mid-Level PostgreSQL client library Description:     Mid-Level PostgreSQL client library, forked from mysql-simple.@@ -21,6 +21,7 @@   hs-source-dirs: src   Exposed-modules:      Database.PostgreSQL.Simple+     Database.PostgreSQL.Simple.Arrays      Database.PostgreSQL.Simple.BuiltinTypes      Database.PostgreSQL.Simple.FromField      Database.PostgreSQL.Simple.FromRow@@ -32,13 +33,18 @@      Database.PostgreSQL.Simple.Time.Internal      Database.PostgreSQL.Simple.ToField      Database.PostgreSQL.Simple.ToRow+     Database.PostgreSQL.Simple.Transaction+     Database.PostgreSQL.Simple.TypeInfo+     Database.PostgreSQL.Simple.TypeInfo.Static      Database.PostgreSQL.Simple.Types+     Database.PostgreSQL.Simple.Errors -- Other-modules:      Database.PostgreSQL.Simple.Internal    Other-modules:      Database.PostgreSQL.Simple.Compat      Database.PostgreSQL.Simple.Time.Implementation+     Database.PostgreSQL.Simple.TypeInfo.Types    Build-depends:     attoparsec >= 0.8.5.3,@@ -66,7 +72,7 @@ source-repository this   type:     git   location: http://github.com/lpsmith/postgresql-simple-  tag:      v0.2.4.1+  tag:      v0.3.0.0  test-suite test   type:           exitcode-stdio-1.0@@ -75,18 +81,21 @@   main-is:        Main.hs   other-modules:     Common-    Bytea-    ExecuteMany     Notify     Serializable     Time +  Build-depends:+     vector+   ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind    extensions: NamedFieldPuns             , OverloadedStrings             , Rank2Types             , RecordWildCards+            , PatternGuards+            , ScopedTypeVariables    build-depends: base                , base16-bytestring

@@ -67,6 +67,7 @@     , (:.)(..)     -- ** Exceptions     , SqlError(..)+    , PQ.ExecStatus(..)     , FormatError(fmtMessage, fmtQuery, fmtParams)     , QueryError(qeMessage, qeQuery)     , ResultError(errSQLType, errHaskellType, errMessage)@@ -97,20 +98,8 @@ --    , Base.insertID     -- * Transaction handling     , withTransaction-    , withTransactionSerializable-    , TransactionMode(..)-    , IsolationLevel(..)-    , ReadWriteMode(..)-    , defaultTransactionMode-    , defaultIsolationLevel-    , defaultReadWriteMode-    , withTransactionLevel-    , withTransactionMode-    , withTransactionModeRetry --    , Base.autocommit     , begin-    , beginLevel-    , beginMode     , commit     , rollback     -- * Helper functions@@ -122,19 +111,15 @@                    ( Builder, fromByteString, toByteString ) import           Blaze.ByteString.Builder.Char8 (fromChar) import           Control.Applicative ((<$>), pure)-import           Control.Concurrent.MVar import           Control.Exception-                   ( Exception, onException, throw, throwIO, finally-                   , try, SomeException, fromException )+                   ( Exception, throw, throwIO, finally ) import           Control.Monad (foldM) import           Data.ByteString (ByteString) import           Data.Int (Int64)-import qualified Data.IntMap as IntMap import           Data.List (intersperse)-import           Data.Monoid (mappend, mconcat)+import           Data.Monoid (mconcat) import           Data.Typeable (Typeable)-import           Database.PostgreSQL.Simple.BuiltinTypes ( oid2typname )-import           Database.PostgreSQL.Simple.Compat ( mask )+import           Database.PostgreSQL.Simple.Compat ( (<>) ) import           Database.PostgreSQL.Simple.FromField (ResultError(..)) import           Database.PostgreSQL.Simple.FromRow (FromRow(..)) import           Database.PostgreSQL.Simple.Ok@@ -143,11 +128,12 @@ import           Database.PostgreSQL.Simple.Types                    ( Binary(..), In(..), Only(..), Query(..), (:.)(..) ) import           Database.PostgreSQL.Simple.Internal as Base+import           Database.PostgreSQL.Simple.Transaction+import           Database.PostgreSQL.Simple.TypeInfo import qualified Database.PostgreSQL.LibPQ as PQ import qualified Data.ByteString.Char8 as B import qualified Data.Text          as T import qualified Data.Text.Encoding as TE-import qualified Data.Vector as V import           Control.Monad.Trans.Reader import           Control.Monad.Trans.State.Strict @@ -322,7 +308,7 @@         sub (Many  ys)      = mconcat <$> mapM sub ys         split s = fromByteString h : if B.null t then [] else split (B.tail t)             where (h,t) = B.break (=='?') s-        zipParams (t:ts) (p:ps) = t `mappend` p `mappend` zipParams ts ps+        zipParams (t:ts) (p:ps) = t <> p <> zipParams ts ps         zipParams [t] []        = t         zipParams _ _ = fmtError (show (B.count '?' template) ++                                   " '?' characters, but " ++@@ -496,8 +482,7 @@   where     go = do        -- FIXME:  what about name clashes with already-declared cursors?-       _ <- execute_ conn ("DECLARE fold NO SCROLL CURSOR FOR "-                           `mappend` q)+       _ <- execute_ conn ("DECLARE fold NO SCROLL CURSOR FOR " <> q)        loop a `finally` execute_ conn "CLOSE fold"  -- FIXME: choose the Automatic chunkSize more intelligently@@ -550,28 +535,28 @@     PQ.CommandOk -> do         throwIO $ QueryError "query resulted in a command response" q     PQ.TuplesOk -> do-        ncols <- PQ.nfields result         let unCol (PQ.Col x) = fromIntegral x :: Int-        typenames <- V.generateM (unCol ncols)-                                 (\(PQ.Col . fromIntegral -> col) -> do-                                    getTypename conn =<< PQ.ftype result col)         nrows <- PQ.ntuples result         ncols <- PQ.nfields result         forM' 0 (nrows-1) $ \row -> do-           let rw = Row row typenames result-           case runStateT (runReaderT (unRP fromRow) rw) 0 of+           let rw = Row row result+           okvc <- runConversion (runStateT (runReaderT (unRP fromRow) rw) 0) conn+           case okvc of              Ok (val,col) | col == ncols -> return val                           | otherwise -> do                               vals <- forM' 0 (ncols-1) $ \c -> do+                                  tinfo <- getTypeInfo conn =<< PQ.ftype result c                                   v <- PQ.getvalue result row c-                                  return ( typenames V.! unCol c+                                  return ( tinfo                                          , fmap ellipsis v       )                               throw (ConversionFailed                                (show (unCol ncols) ++ " values: " ++ show vals)+                               Nothing+                               ""                                (show (unCol col) ++ " slots in target type")                                "mismatch between number of columns to \                                \convert and number in target type")-             Errors []  -> throwIO $ ConversionFailed "" "" "unknown error"+             Errors []  -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error"              Errors [x] -> throwIO x              Errors xs  -> throwIO $ ManyErrors xs     PQ.CopyOut ->@@ -587,160 +572,6 @@     | B.length bs > 15 = B.take 10 bs `B.append` "[...]"     | otherwise        = bs ---- | Of the four isolation levels defined by the SQL standard,--- these are the three levels distinguished by PostgreSQL as of version 9.0.--- See <http://www.postgresql.org/docs/9.1/static/transaction-iso.html>--- for more information.   Note that prior to PostgreSQL 9.0, 'RepeatableRead'--- was equivalent to 'Serializable'.--data IsolationLevel-   = DefaultIsolationLevel  -- ^ the isolation level will be taken from-                            --   PostgreSQL's per-connection-                            --   @default_transaction_isolation@ variable,-                            --   which is initialized according to the-                            --   server's config.  The default configuration-                            --   is 'ReadCommitted'.-   | ReadCommitted-   | RepeatableRead-   | Serializable-     deriving (Show, Eq, Ord, Enum, Bounded)--data ReadWriteMode-   = DefaultReadWriteMode   -- ^ the read-write mode will be taken from-                            --   PostgreSQL's per-connection-                            --   @default_transaction_read_only@ variable,-                            --   which is initialized according to the-                            --   server's config.  The default configuration-                            --   is 'ReadWrite'.-   | ReadWrite-   | ReadOnly-     deriving (Show, Eq, Ord, Enum, Bounded)--data TransactionMode = TransactionMode {-       isolationLevel :: !IsolationLevel,-       readWriteMode  :: !ReadWriteMode-     } deriving (Show, Eq)--defaultTransactionMode :: TransactionMode-defaultTransactionMode =  TransactionMode-                            defaultIsolationLevel-                            defaultReadWriteMode--defaultIsolationLevel  :: IsolationLevel-defaultIsolationLevel  =  DefaultIsolationLevel--defaultReadWriteMode   :: ReadWriteMode-defaultReadWriteMode   =  DefaultReadWriteMode---- | Execute an action inside a SQL transaction.------ This function initiates a transaction with a \"@begin--- transaction@\" statement, then executes the supplied action.  If--- the action succeeds, the transaction will be completed with--- 'Base.commit' before this function returns.------ If the action throws /any/ kind of exception (not just a--- PostgreSQL-related exception), the transaction will be rolled back using--- 'rollback', then the exception will be rethrown.-withTransaction :: Connection -> IO a -> IO a-withTransaction = withTransactionMode defaultTransactionMode---- | Execute an action inside of a 'Serializable' transaction.  If a--- serialization failure occurs, roll back the transaction and try again.--- Be warned that this may execute the IO action multiple times.------ A 'Serializable' transaction creates the illusion that your program has--- exclusive access to the database.  This means that, even in a concurrent--- setting, you can perform queries in sequence without having to worry about--- what might happen between one statement and the next.------ Think of it as STM, but without @retry@.-withTransactionSerializable :: Connection -> IO a -> IO a-withTransactionSerializable =-    withTransactionModeRetry-        TransactionMode-        { isolationLevel = Serializable-        , readWriteMode  = ReadWrite-        }---- | Execute an action inside a SQL transaction with a given isolation level.-withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a-withTransactionLevel lvl-    = withTransactionMode defaultTransactionMode { isolationLevel = lvl }---- | Execute an action inside a SQL transaction with a given transaction mode.-withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a-withTransactionMode mode conn act =-  mask $ \restore -> do-    beginMode mode conn-    r <- restore act `onException` rollback conn-    commit conn-    return r---- | Like 'withTransactionMode', but if a 'SqlError' arises whose 'sqlState' is--- @\"40001\"@ (@serialization_failure@), this will issue a @ROLLBACK@, then--- try the action again.  If any other exception arises, this will issue a--- @ROLLBACK@, but will propagate the exception instead of retrying.------ This is used to implement 'withTransactionSerializable'.-withTransactionModeRetry :: TransactionMode -> Connection -> IO a -> IO a-withTransactionModeRetry mode conn act =-    mask $ \restore ->-        retryLoop $ try $ do-            a <- restore act-            commit conn-            return a-  where-    retryLoop :: IO (Either SomeException a) -> IO a-    retryLoop act' = do-        beginMode mode conn-        r <- act'-        case r of-            Left e -> do-                rollback conn-                case fromException e of-                    Just SqlError{..} | sqlState == serialization_failure-                      -> retryLoop act'-                    _ -> throwIO e-            Right a ->-                return a--    -- http://www.postgresql.org/docs/current/static/errcodes-appendix.html-    serialization_failure = "40001"---- | Rollback a transaction.-rollback :: Connection -> IO ()-rollback conn = execute_ conn "ABORT" >> return ()---- | Commit a transaction.-commit :: Connection -> IO ()-commit conn = execute_ conn "COMMIT" >> return ()---- | Begin a transaction.-begin :: Connection -> IO ()-begin = beginMode defaultTransactionMode---- | Begin a transaction with a given isolation level-beginLevel :: IsolationLevel -> Connection -> IO ()-beginLevel lvl = beginMode defaultTransactionMode { isolationLevel = lvl }---- | Begin a transaction with a given transaction mode-beginMode :: TransactionMode -> Connection -> IO ()-beginMode mode conn = do-    _ <- execute_ conn $! Query (B.concat ["BEGIN", isolevel, readmode])-    return ()-  where-    isolevel = case isolationLevel mode of-                 DefaultIsolationLevel -> ""-                 ReadCommitted  -> " ISOLATION LEVEL READ COMMITTED"-                 RepeatableRead -> " ISOLATION LEVEL REPEATABLE READ"-                 Serializable   -> " ISOLATION LEVEL SERIALIZABLE"-    readmode = case readWriteMode mode of-                 DefaultReadWriteMode -> ""-                 ReadWrite -> " READ WRITE"-                 ReadOnly  -> " READ ONLY"- fmtError :: String -> Query -> [Action] -> a fmtError msg q xs = throw FormatError {                       fmtMessage = msg@@ -1014,25 +845,3 @@ --   UTF-8. If you use some other encoding, decoding may fail or give --   wrong results. In such cases, write a @newtype@ wrapper and a --   custom 'Result' instance to handle your encoding.--getTypename :: Connection -> PQ.Oid -> IO ByteString-getTypename conn@Connection{..} oid =-  case oid2typname oid of-    Just name -> return name-    Nothing -> modifyMVar connectionObjects $ \oidmap -> do-      case IntMap.lookup (oid2int oid) oidmap of-        Just name -> return (oidmap, name)-        Nothing -> do-            names <- query conn "SELECT typname FROM pg_type WHERE oid=?"-                            (Only oid)-            name <- case names of-                      []  -> return $ throw SqlError {-                                         sqlNativeError = -1,-                                         sqlErrorMsg    = "invalid type oid",-                                         sqlState       = ""-                                       }-                      [Only x] -> return x-                      _   -> fail "typename query returned more than one result"-                               -- oid is a primary key,  so the query should-                               -- never return more than one result-            return (IntMap.insert (oid2int oid) name oidmap, name)

@@ -0,0 +1,23 @@+module Database.PostgreSQL.Simple+     ( Connection+     , Query+     , query+     , query_+     , execute+     , execute_+     , executeMany+     ) where++import Data.Int(Int64)+import Database.PostgreSQL.Simple.Internal+import Database.PostgreSQL.Simple.Types+import {-# SOURCE #-} Database.PostgreSQL.Simple.FromRow+import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow++query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r]++query_ :: FromRow r => Connection -> Query -> IO [r]++execute :: ToRow q => Connection -> Query -> q -> IO Int64++executeMany :: ToRow q => Connection -> Query -> [q] -> IO Int64

@@ -0,0 +1,94 @@+{-# LANGUAGE PatternGuards #-}++------------------------------------------------------------------------------+-- |+-- Module:      Database.PostgreSQL.Simple.Arrays+-- Copyright:   (c) 2012 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+-- Portability: portable+--+-- A Postgres array parser and pretty-printer.+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.Arrays where++import           Control.Applicative (Applicative(..), Alternative(..), (<$>))+import           Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B+import           Data.Monoid+import           Data.Attoparsec.Char8+++-- | Parse one of three primitive field formats: array, quoted and plain.+arrayFormat :: Char -> Parser ArrayFormat+arrayFormat delim  =  Array  <$> array delim+                  <|> Plain  <$> plain delim+                  <|> Quoted <$> quoted++data ArrayFormat = Array [ArrayFormat]+                 | Plain ByteString+                 | Quoted ByteString+                   deriving (Eq, Show, Ord)++array :: Char -> Parser [ArrayFormat]+array delim = char '{' *> option [] (arrays <|> strings) <* char '}'+  where+    strings = sepBy1 (Quoted <$> quoted <|> Plain <$> plain delim) (char delim)+    arrays  = sepBy1 (Array <$> array delim) (char ',')+    -- NB: Arrays seem to always be delimited by commas.++-- | Recognizes a quoted string.+quoted :: Parser ByteString+quoted  = char '"' *> option "" contents <* char '"'+  where+    esc = char '\\' *> (char '\\' <|> char '"')+    unQ = takeWhile1 (notInClass "\"\\")+    contents = mconcat <$> many (unQ <|> B.singleton <$> esc)++-- | Recognizes a plain string literal, not containing quotes or brackets and+--   not containing the delimiter character.+plain :: Char -> Parser ByteString+plain delim = takeWhile1 (notInClass (delim:"\"{}"))++-- Mutually recursive 'fmt' and 'delimit' separate out value formatting+-- from the subtleties of delimiting.++-- | Format an array format item, using the delimiter character if the item is+--   itself an array.+fmt :: Char -> ArrayFormat -> ByteString+fmt = fmt' False++-- | Format a list of array format items, inserting the appropriate delimiter+--   between them. When the items are arrays, they will be delimited with+--   commas; otherwise, they are delimited with the passed-in-delimiter.+delimit :: Char -> [ArrayFormat] -> ByteString+delimit _      [] = ""+delimit c     [x] = fmt' True c x+delimit c (x:y:z) = (fmt' True c x `B.snoc` c') `mappend` delimit c (y:z)+  where+    c' | Array _ <- x = ','+       | otherwise    = c++-- | Format an array format item, using the delimiter character if the item is+--   itself an array, optionally applying quoting rules. Creates copies for+--   safety when used in 'FromField' instances.+fmt' :: Bool -> Char -> ArrayFormat -> ByteString+fmt' quoting c x =+  case x of+    Array items          -> '{' `B.cons` (delimit c items `B.snoc` '}')+    Plain bytes          -> B.copy bytes+    Quoted q | quoting   -> '"' `B.cons` (esc q `B.snoc` '"')+             | otherwise -> B.copy q+    -- NB: The 'snoc' and 'cons' functions always copy.++-- | Escape a string according to Postgres double-quoted string format.+esc :: ByteString -> ByteString+esc = B.concatMap f+  where+    f '"'  = "\\\""+    f '\\' = "\\\\"+    f c    = B.singleton c+  -- TODO: Implement easy performance improvements with unfoldr.+

@@ -1,12 +1,24 @@ {-# 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 .+-- | This is a module of its own, partly because it uses the CPP extension,+-- which doesn't play well with backslash-broken string literals. module Database.PostgreSQL.Simple.Compat     ( mask+    , (<>)+    , unsafeDupablePerformIO     ) where  import qualified Control.Exception as E+import Data.Monoid +#if   __GLASGOW_HASKELL__ >= 702+import System.IO.Unsafe (unsafeDupablePerformIO)+#elif __GLASGOW_HASKELL__ >= 611+import GHC.IO (unsafeDupablePerformIO)+#else+import GHC.IOBase (unsafeDupablePerformIO)+#endif++ -- | Like 'E.mask', but backported to base before version 4.3.0. -- -- Note that the restore callback is monomorphic, unlike in 'E.mask'.  This@@ -23,3 +35,11 @@     E.block $ io $ \m -> if b then m else E.unblock m #endif {-# INLINE mask #-}++#if !MIN_VERSION_base(4,5,0)+infixr 6 <>++(<>) :: Monoid m => m -> m -> m+(<>) = mappend+{-# INLINE (<>) #-}+#endif

@@ -0,0 +1,110 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings  #-}++-- | Module for parsing errors from posgresql error messages.+--  Currently in only parses integrity violation errors (class 23).+--+-- /Note: Success of parsing may depend on language settings./+----------------------------------------------------------+module Database.PostgreSQL.Simple.Errors+       ( ConstraintViolation(..)+       , constraintViolation+       , constraintViolationE+       , catchViolation+       )+       where++import Prelude hiding (catch)++import Control.Applicative+import Control.Exception++import Data.Attoparsec.Char8+import Data.ByteString       (ByteString)+import Data.Typeable++import Database.PostgreSQL.Simple.Internal++-- Examples of parsed error messages+--+-- `ERROR:  new row for relation "users" violates check+-- constraint "user_kind_check"`+--+-- `ERROR:  insert or update on table "user_group_map" violates foreign key+--  constraint "user_id"`+--+-- `ERROR: null value in column "login" violates not-null constraint`+--+-- `ERROR: duplicate key value violates unique constraint "users_login_key"`++data ConstraintViolation+   = NotNullViolation ByteString+   -- ^ The field is a column name+   | ForeignKeyViolation ByteString ByteString+   -- ^ Table name and name of violated constraint+   | UniqueViolation ByteString+   -- ^ Name of violated constraint+   | CheckViolation ByteString ByteString+   -- ^ Relation name (usually table), constraint name+   deriving (Show, Eq, Ord, Typeable)++-- Default instance should be enough+instance Exception ConstraintViolation+++-- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and+-- succeedes only if able to parse sqlErrorMsg.+--+-- > createUser = catchJust constraintViolation catcher $ execute conn ...+-- >   where+-- >     catcher UniqueViolation "user_login_key" = ...+-- >     catcher _ = ...+constraintViolation :: SqlError -> Maybe ConstraintViolation+constraintViolation e =+  case sqlState e of+    "23502" -> NotNullViolation <$> parseMaybe parseQ1 msg+    "23503" -> uncurry ForeignKeyViolation <$> parseMaybe parseQ2 msg+    "23505" -> UniqueViolation <$> parseMaybe parseQ1 msg+    "23514" -> uncurry CheckViolation <$> parseMaybe parseQ2 msg+    _ -> Nothing+  where msg = sqlErrorMsg e+++-- | Like constraintViolation, but also packs original SqlError.+--+-- > createUser = catchJust constraintViolationE catcher $ execute conn ...+-- >   where+-- >     catcher (_, UniqueViolation "user_login_key") = ...+-- >     catcher (e, _) = throw e+--+constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation)+constraintViolationE e = fmap ((,) e) $ constraintViolation e++-- | Catches SqlError, tries to convert to ConstraintViolation, re-throws+-- on fail. Provides alternative interface to catchJust+--+-- > createUser = catchViolation catcher $ execute conn ...+-- >   where+-- >     catcher _ (UniqueViolation "user_login_key") = ...+-- >     catcher e _ = throw e+catchViolation :: (SqlError -> ConstraintViolation -> IO a) -> IO a -> IO a+catchViolation f m = catch m+                     (\e -> maybe (throw e) (f e) $ constraintViolation e)++-- Parsers just try to extract quoted strings from error messages, number+-- of quoted strings depend on error type.+scanTillQuote :: Parser ByteString+scanTillQuote = scan False go+  where go True _ = Just False -- escaped character+        go False '"' = Nothing -- end parse+        go False '\\' = Just True -- next one is escaped+        go _ _ = Just False++parseQ1 :: Parser ByteString+parseQ1 = scanTillQuote *> char '"' *> scanTillQuote <* char '"'++parseQ2 :: Parser (ByteString, ByteString)+parseQ2 = (,) <$> parseQ1 <*> parseQ1++parseMaybe :: Parser a -> ByteString -> Maybe a+parseMaybe p b = either (const Nothing) Just $ parseOnly p b

@@ -1,6 +1,7 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor  #-} {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE PatternGuards, ScopedTypeVariables      #-}+{-# LANGUAGE RecordWildCards                         #-}  ------------------------------------------------------------------------------ -- |@@ -18,21 +19,63 @@ -- A Haskell numeric type is considered to be compatible with all -- PostgreSQL numeric types that are less accurate than it. For instance, -- the Haskell 'Double' type is compatible with the PostgreSQL's 32-bit--- @Int@ type because it can represent a @Int@ exactly. On the other hand,--- since a 'Double' might lose precision if representing a 64-bit @BigInt@,--- the two are /not/ considered compatible.+-- @int@ type because it can represent a @int@ exactly.  On the other hand,+-- since a 'Double' might lose precision if representing PostgreSQL's 64-bit+-- @bigint@, the two are /not/ considered compatible. --+-- Because 'FromField' is a typeclass,  one may provide conversions to+-- additional Haskell types without modifying postgresql-simple.  This is+-- particularly useful for supporting PostgreSQL types that postgresql-simple+-- does not support out-of-box.  Here's an example of what such an instance+-- might look like for a UUID type that implements the @Read@ class:+--+-- @+-- import Data.UUID ( UUID )+-- import Database.PostgreSQL.Simple.BuiltinTypes+--                  ( BuiltinType(UUID), builtin2oid )+-- import qualified Data.ByteString as B+--+-- instance FromField UUID where+--    fromField f mdata =+--        if typeOid f /= builtin2oid UUID+--        then returnError Incompatible f ""+--        else case B.unpack `fmap` mdata of+--               Nothing   -> returnError UnexpectedNull f ""+--               Just data ->+--                   case [ x | (x,t) <- reads data, ("","") <- lex t ] of+--                     [x] -> Ok x+--                     _   -> returnError ConversionError f data+-- @+--+-- Note that because PostgreSQL's @uuid@ type is built into postgres and is+-- not provided by an extension,  the 'typeOid' of @uuid@ does not change and+-- thus we can examine it directly.   Here,  we simply pull the type oid out+-- of the static table provided by postgresql-simple.+--+-- On the other hand if the type is provided by an extension,  such as+-- @PostGIS@ or @hstore@,  then the 'typeOid' is not stable and can vary from+-- database to database. In this case it is recommended that FromField+-- instances use 'typename' instead.+-- ------------------------------------------------------------------------------  module Database.PostgreSQL.Simple.FromField     (       FromField(..)     , FieldParser+    , Conversion()++    , runConversion+    , conversionMap+    , conversionError     , ResultError(..)     , returnError      , Field     , typename+    , TypeInfo(..)+    , typeInfo+    , typeInfoByOid     , name     , tableOid     , tableColumn@@ -46,7 +89,7 @@  import           Control.Applicative                    ( Applicative, (<|>), (<$>), pure )-import           Control.Exception (SomeException(..), Exception)+import           Control.Exception (Exception) import           Data.Attoparsec.Char8 hiding (Result) import           Data.Bits ((.&.), (.|.), shiftL) import           Data.ByteString (ByteString)@@ -56,14 +99,19 @@ import           Data.Ratio (Ratio) import           Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay ) import           Data.Typeable (Typeable, typeOf)+import           Data.Vector (Vector)+import qualified Data.Vector as V import           Data.Word (Word64) import           Database.PostgreSQL.Simple.Internal import           Database.PostgreSQL.Simple.BuiltinTypes+import           Database.PostgreSQL.Simple.Compat import           Database.PostgreSQL.Simple.Ok import           Database.PostgreSQL.Simple.Types (Binary(..), Null(..))+import           Database.PostgreSQL.Simple.TypeInfo as TypeInfo+import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TypeInfo import           Database.PostgreSQL.Simple.Time+import           Database.PostgreSQL.Simple.Arrays as Arrays import qualified Database.PostgreSQL.LibPQ as PQ-import           System.IO.Unsafe (unsafePerformIO) import qualified Data.ByteString as SB import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as LB@@ -74,15 +122,21 @@ -- | Exception thrown if conversion from a SQL value to a Haskell -- value fails. data ResultError = Incompatible { errSQLType :: String+                                , errSQLTableOid :: Maybe PQ.Oid+                                , errSQLField :: String                                 , errHaskellType :: String                                 , errMessage :: String }                  -- ^ The SQL and Haskell types are not compatible.                  | UnexpectedNull { errSQLType :: String+                                  , errSQLTableOid :: Maybe PQ.Oid+                                  , errSQLField :: String                                   , errHaskellType :: String                                   , errMessage :: String }                  -- ^ A SQL @NULL@ was encountered when the Haskell                  -- type did not permit it.                  | ConversionFailed { errSQLType :: String+                                    , errSQLTableOid :: Maybe PQ.Oid+                                    , errSQLField :: String                                     , errHaskellType :: String                                     , errMessage :: String }                  -- ^ The SQL value could not be parsed, or could not@@ -93,10 +147,10 @@  instance Exception ResultError -left :: Exception a => a -> Ok b-left = Errors . (:[]) . SomeException+left :: Exception a => a -> Conversion b+left = conversionError -type FieldParser a = Field -> Maybe ByteString -> Ok a+type FieldParser a = Field -> Maybe ByteString -> Conversion a  -- | A type that may be converted from a SQL type. class FromField a where@@ -116,6 +170,61 @@     -- such a reference,  and that using bytestring functions such as 'B.drop'     -- and 'B.takeWhile' alone will also trigger this memory leak. +-- | Returns the data type name.  This is the preferred way of identifying+--   types that do not have a stable type oid, such as types provided by+--   extensions to PostgreSQL.+--+--   More concretely,  it returns the @typname@ column associated with the+--   type oid in the @pg_type@ table.  First, postgresql-simple will check+--   built-in, static table.   If the type oid is not there, postgresql-simple+--   will check a per-connection cache,  and then finally query the database's+--   meta-schema.++typename :: Field -> Conversion ByteString+typename field = typname <$> typeInfo field++typeInfo :: Field -> Conversion TypeInfo+typeInfo Field{..} = Conversion $ \conn -> do+                       Ok <$> (getTypeInfo conn =<< PQ.ftype result column)++typeInfoByOid :: PQ.Oid -> Conversion TypeInfo+typeInfoByOid oid = Conversion $ \conn -> do+                      Ok <$> (getTypeInfo conn oid)++-- | Returns the name of the column.  This is often determined by a table+--   definition,  but it can be set using an @as@ clause.++name :: Field -> Maybe ByteString+name Field{..} = unsafeDupablePerformIO (PQ.fname result column)++-- | Returns the name of the object id of the @table@ associated with the+--   column,  if any.  Returns 'Nothing' when there is no such table;+--   for example a computed column does not have a table associated with it.+--   Analogous to libpq's @PQftable@.++tableOid :: Field -> Maybe PQ.Oid+tableOid Field{..} = toMaybeOid (unsafeDupablePerformIO (PQ.ftable result column))+  where+     toMaybeOid x+       = if   x == PQ.invalidOid+         then Nothing+         else Just x++-- | If the column has a table associated with it,  this returns the number+--   off the associated table column.   Numbering starts from 0.  Analogous+--   to libpq's @PQftablecol@.++tableColumn :: Field -> Int+tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column))+  where+    fromCol (PQ.Col x) = fromIntegral x++-- | This returns whether the data was returned in a binary or textual format.+--   Analogous to libpq's @PQfformat@.++format :: Field -> PQ.Format+format Field{..} = unsafeDupablePerformIO (PQ.fformat result column)+ instance (FromField a) => FromField (Maybe a) where     fromField _ Nothing = pure Nothing     fromField f bs      = Just <$> fromField f bs@@ -126,7 +235,7 @@  instance FromField Bool where     fromField f bs-      | typeOid f /= builtin2oid Bool = returnError Incompatible f ""+      | typeOid f /= typoid (TypeInfo.bool) = returnError Incompatible f ""       | bs == Nothing                 = returnError UnexpectedNull f ""       | bs == Just "t"                = pure True       | bs == Just "f"                = pure False@@ -163,7 +272,7 @@ unBinary (Binary x) = x  instance FromField SB.ByteString where-    fromField f dat = if typeOid f == builtin2oid ByteA+    fromField f dat = if typeOid f == typoid TypeInfo.bytea                       then unBinary <$> fromField f dat                       else doFromField f okText' (pure . B.copy) dat @@ -174,8 +283,8 @@     fromField f dat = LB.fromChunks . (:[]) <$> fromField f dat  unescapeBytea :: Field -> SB.ByteString-              -> Ok (Binary SB.ByteString)-unescapeBytea f str = case unsafePerformIO (PQ.unescapeBytea str) of+              -> Conversion (Binary SB.ByteString)+unescapeBytea f str = case unsafeDupablePerformIO (PQ.unescapeBytea str) of        Nothing  -> returnError ConversionFailed f "unescapeBytea failed"        Just str -> pure (Binary str) @@ -198,49 +307,79 @@     fromField f dat = ST.unpack <$> fromField f dat  instance FromField UTCTime where-  fromField = ff TimestampTZ "UTCTime" parseUTCTime+  fromField = ff TypeInfo.timestamptz "UTCTime" parseUTCTime  instance FromField ZonedTime where-  fromField = ff TimestampTZ "ZonedTime" parseZonedTime+  fromField = ff TypeInfo.timestamptz "ZonedTime" parseZonedTime  instance FromField LocalTime where-  fromField = ff Timestamp "LocalTime" parseLocalTime+  fromField = ff TypeInfo.timestamp "LocalTime" parseLocalTime  instance FromField Day where-  fromField = ff Date "Day" parseDay+  fromField = ff TypeInfo.date "Day" parseDay  instance FromField TimeOfDay where-  fromField = ff Time "TimeOfDay" parseTimeOfDay+  fromField = ff TypeInfo.time "TimeOfDay" parseTimeOfDay  instance FromField UTCTimestamp where-  fromField = ff TimestampTZ "UTCTimestamp" parseUTCTimestamp+  fromField = ff TypeInfo.timestamptz "UTCTimestamp" parseUTCTimestamp  instance FromField ZonedTimestamp where-  fromField = ff TimestampTZ "ZonedTimestamp" parseZonedTimestamp+  fromField = ff TypeInfo.timestamptz "ZonedTimestamp" parseZonedTimestamp  instance FromField LocalTimestamp where-  fromField = ff Timestamp "LocalTimestamp" parseLocalTimestamp+  fromField = ff TypeInfo.timestamp "LocalTimestamp" parseLocalTimestamp  instance FromField Date where-  fromField = ff Date "Date" parseDate+  fromField = ff TypeInfo.date "Date" parseDate -ff :: BuiltinType -> String -> (B8.ByteString -> Either String a)-   -> Field -> Maybe B8.ByteString -> Ok a-ff pgType hsType parse f mstr-    | typeOid f /= builtin2oid pgType-    = left (Incompatible   (B8.unpack (typename f)) hsType "")-    | Nothing <- mstr-    = left (UnexpectedNull (B8.unpack (typename f)) hsType "")-    | Just str <- mstr-    = case parse str of-        Left msg -> left (ConversionFailed (B8.unpack (typename f)) hsType msg)-        Right val -> return val+ff :: TypeInfo -> String -> (B8.ByteString -> Either String a)+   -> Field -> Maybe B8.ByteString -> Conversion a+ff pgType hsType parse f mstr =+  if typeOid f /= typoid pgType+  then err Incompatible ""+  else case mstr of+         Nothing -> err UnexpectedNull ""+         Just str -> case parse str of+                       Left msg -> err ConversionFailed msg+                       Right val -> return val+ where+   err errC msg = do+     typnam <- typename f+     left $ errC (B8.unpack typnam)+                 (tableOid f)+                 (maybe "" B8.unpack (name f))+                 hsType+                 msg {-# INLINE ff #-}  instance (FromField a, FromField b) => FromField (Either a b) where     fromField f dat =   (Right <$> fromField f dat)                     <|> (Left  <$> fromField f dat) +instance (FromField a, Typeable a) => FromField (Vector a) where+    fromField f mdat = do+        info <- typeInfo f+        case info of+          TypeInfo.Array{} ->+              case mdat of+                Nothing  -> returnError UnexpectedNull f ""+                Just dat -> do+                   case parseOnly (fromArray info f) dat of+                     Left  err  -> returnError ConversionFailed f err+                     Right conv -> V.fromList <$> conv+          _ -> returnError Incompatible f ""++fromArray :: (FromField a)+          => TypeInfo -> Field -> Parser (Conversion [a])+fromArray typeInfo f = sequence . (parseIt <$>) <$> array delim+  where+    delim = typdelim (typelem typeInfo)+    fElem = f{ typeOid = typoid (typelem typeInfo) }+    parseIt item = (fromField f' . Just . fmt delim) item+      where f' | Arrays.Array _ <- item = f+               | otherwise              = fElem+ newtype Compat = Compat Word64  mkCompats :: [BuiltinType] -> Compat@@ -267,8 +406,8 @@ #endif  doFromField :: forall a . (Typeable a)-          => Field -> Compat -> (ByteString -> Ok a)-          -> Maybe ByteString -> Ok a+          => Field -> Compat -> (ByteString -> Conversion a)+          -> Maybe ByteString -> Conversion a doFromField f types cvt (Just bs)     | Just typ <- oid2builtin (typeOid f)     , mkCompat typ `compat` types = cvt bs@@ -281,17 +420,22 @@ --   exception value and returns it in a 'Left . SomeException' --   constructor. returnError :: forall a err . (Typeable a, Exception err)-            => (String -> String -> String -> err)-            -> Field -> String -> Ok a-returnError mkErr f = left . mkErr (B.unpack (typename f))-                                   (show (typeOf (undefined :: a)))+            => (String -> Maybe PQ.Oid -> String -> String -> String -> err)+            -> Field -> String -> Conversion a+returnError mkErr f msg = do+  typnam <- typename f+  left $ mkErr (B.unpack typnam)+               (tableOid f)+               (maybe "" B.unpack (name f))+               (show (typeOf (undefined :: a)))+               msg  atto :: forall a. (Typeable a)      => Compat -> Parser a -> Field -> Maybe ByteString-     -> Ok a+     -> Conversion a atto types p0 f dat = doFromField f types (go p0) dat   where-    go :: Parser a -> ByteString -> Ok a+    go :: Parser a -> ByteString -> Conversion a     go p s =         case parseOnly p s of           Left err -> returnError ConversionFailed f err

@@ -0,0 +1,10 @@+module Database.PostgreSQL.Simple.FromField where++import Data.ByteString(ByteString)+import Database.PostgreSQL.Simple.Types++class FromField a++instance FromField Oid+instance FromField ByteString+instance FromField a => FromField (Maybe a)

@@ -25,23 +25,22 @@      ) where  import Control.Applicative (Applicative(..), (<$>))-import Control.Exception (SomeException(..)) import Control.Monad (replicateM) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import Database.PostgreSQL.Simple.Types (Only(..))-import Database.PostgreSQL.Simple.Ok import qualified Database.PostgreSQL.LibPQ as PQ import           Database.PostgreSQL.Simple.Internal+import           Database.PostgreSQL.Simple.Compat import           Database.PostgreSQL.Simple.FromField+import           Database.PostgreSQL.Simple.Ok import           Database.PostgreSQL.Simple.Types ((:.)(..))+import           Database.PostgreSQL.Simple.TypeInfo  import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Class -import Data.Vector ((!))- -- | A collection type that can be converted from a sequence of fields. -- Instances are provided for tuples up to 10 elements and lists of any length. --@@ -65,30 +64,45 @@ class FromRow a where     fromRow :: RowParser a +getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString+getvalue result row col = unsafeDupablePerformIO (PQ.getvalue result row col)++nfields :: PQ.Result -> PQ.Column+nfields result = unsafeDupablePerformIO (PQ.nfields result)++getTypeInfoByCol :: Row -> PQ.Column -> Conversion TypeInfo+getTypeInfoByCol Row{..} col = +    Conversion $ \conn -> do+      oid <- PQ.ftype rowresult col+      Ok <$> getTypeInfo conn oid++getTypenameByCol :: Row -> PQ.Column -> Conversion ByteString+getTypenameByCol row col = typname <$> getTypeInfoByCol row col+ fieldWith :: FieldParser a -> RowParser a fieldWith fieldP = RP $ do     let unCol (PQ.Col x) = fromIntegral x :: Int-    Row{..} <- ask+    r@Row{..} <- ask     column <- lift get     lift (put (column + 1))     let ncols = nfields rowresult     if (column >= ncols)-    then do-        let vals = map (\c -> ( typenames ! (unCol c)-                              , fmap ellipsis (getvalue rowresult row c) ))-                       [0..ncols-1]-            convertError = ConversionFailed-                (show (unCol ncols) ++ " values: " ++ show vals)+    then lift $ lift $ do+        vals <- mapM (getTypenameByCol r) [0..ncols-1]+        let err = ConversionFailed+                (show (unCol ncols) ++ " values: " ++ show (map ellipsis vals))+                Nothing+                ""                 ("at least " ++ show (unCol column + 1)                   ++ " slots in target type")                 "mismatch between number of columns to \                 \convert and number in target type"-        lift (lift (Errors [SomeException convertError]))+        conversionError err     else do-        let typename = typenames ! unCol column-            result = rowresult-            field = Field{..}-        lift (lift (fieldP field (getvalue result row column)))+      let !result = rowresult+          !typeOid = unsafeDupablePerformIO (PQ.ftype result column)+          !field = Field{..}+      lift (lift (fieldP field (getvalue result row column)))  field :: FromField a => RowParser a field = fieldWith fromField

@@ -0,0 +1,8 @@+module Database.PostgreSQL.Simple.FromRow where++import {-# SOURCE #-} Database.PostgreSQL.Simple.FromField++class FromRow a++instance (FromField a, FromField b, FromField c, FromField d) => FromRow (a,b,c,d)+instance (FromField a, FromField b, FromField c, FromField d, FromField e) => FromRow (a,b,c,d,e)

@@ -24,24 +24,24 @@ import           Control.Applicative import           Control.Exception import           Control.Concurrent.MVar+import           Control.Monad(MonadPlus(..)) import           Data.ByteString(ByteString)-import qualified Data.ByteString       as B import qualified Data.ByteString.Char8 as B8 import           Data.Char (ord) import           Data.Int (Int64) import qualified Data.IntMap as IntMap+import           Data.Maybe(fromMaybe) import           Data.String import           Data.Typeable import           Data.Word import           Database.PostgreSQL.LibPQ(Oid(..)) import qualified Database.PostgreSQL.LibPQ as PQ-import           Database.PostgreSQL.Simple.BuiltinTypes (BuiltinType)+import           Database.PostgreSQL.LibPQ(ExecStatus(..)) import           Database.PostgreSQL.Simple.Ok import           Database.PostgreSQL.Simple.Types (Query(..))+import           Database.PostgreSQL.Simple.TypeInfo.Types(TypeInfo) import           Control.Monad.Trans.State.Strict import           Control.Monad.Trans.Reader-import qualified Data.Vector as V-import           System.IO.Unsafe (unsafePerformIO)  -- | A Field represents metadata about a particular field --@@ -52,43 +52,29 @@ data Field = Field {      result   :: !PQ.Result    , column   :: {-# UNPACK #-} !PQ.Column-   , typename :: !ByteString+   , typeOid  :: {-# UNPACK #-} !PQ.Oid  +     -- ^ This returns the type oid associated with the column.  Analogous +     --   to libpq's @PQftype@.    } -name :: Field -> Maybe ByteString-name Field{..} = unsafePerformIO (PQ.fname result column)--tableOid :: Field -> PQ.Oid-tableOid Field{..} = unsafePerformIO (PQ.ftable result column)--tableColumn :: Field -> Int-tableColumn Field{..} = fromCol (unsafePerformIO (PQ.ftablecol result column))-  where-    fromCol (PQ.Col x) = fromIntegral x---format :: Field -> PQ.Format-format Field{..} = unsafePerformIO (PQ.fformat result column)--typeOid :: Field -> PQ.Oid-typeOid Field{..} = unsafePerformIO (PQ.ftype result column)-+type TypeInfoCache = IntMap.IntMap TypeInfo  data Connection = Connection {      connectionHandle  :: {-# UNPACK #-} !(MVar PQ.Connection)-   , connectionObjects :: {-# UNPACK #-} !(MVar (IntMap.IntMap ByteString))+   , connectionObjects :: {-# UNPACK #-} !(MVar TypeInfoCache)    } -data SqlType-   = Builtin BuiltinType-   | Other   Oid- data SqlError = SqlError {      sqlState       :: ByteString-   , sqlNativeError :: Int+   , sqlExecStatus  :: ExecStatus    , sqlErrorMsg    :: ByteString+   , sqlErrorDetail :: ByteString+   , sqlErrorHint   :: ByteString    } deriving (Show, Typeable) +fatalError :: ByteString -> SqlError+fatalError msg = SqlError "" FatalError msg "" ""+ instance Exception SqlError  -- | Exception thrown if 'query' is used to perform an @INSERT@-like@@ -162,9 +148,7 @@           return wconn       _ -> do           msg <- maybe "connectPostgreSQL error" id <$> PQ.errorMessage conn-          throwIO $ SqlError { sqlNativeError = -1   -- FIXME?-                             , sqlErrorMsg    = msg-                             , sqlState       = ""  }+          throwIO $ fatalError msg  -- | Turns a 'ConnectInfo' data structure into a libpq connection string. @@ -213,9 +197,7 @@         case mres of           Nothing -> do             msg <- maybe "execute error" id <$> PQ.errorMessage h-            throwIO $ SqlError { sqlNativeError = -1   -- FIXME?-                               , sqlErrorMsg    = msg-                               , sqlState       = ""  }+            throwIO $ fatalError msg           Just res -> do             return res @@ -260,21 +242,22 @@                     else error ("finishExecute:  not an int: " ++ B8.unpack str)  throwResultError :: ByteString -> PQ.Result -> PQ.ExecStatus -> IO a-throwResultError context result status = do-    errormsg  <- maybe "" id <$> PQ.resultErrorMessage result-    statusmsg <- PQ.resStatus status+throwResultError _ result status = do+    errormsg  <- fromMaybe "" <$>+                 PQ.resultErrorField result PQ.DiagMessagePrimary+    detail    <- fromMaybe "" <$>+                 PQ.resultErrorField result PQ.DiagMessageDetail+    hint      <- fromMaybe "" <$>+                 PQ.resultErrorField result PQ.DiagMessageHint     state     <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate     throwIO $ SqlError { sqlState = state-                       , sqlNativeError = fromEnum status-                       , sqlErrorMsg = B.concat [ context, ": ", statusmsg-                                                , ": ", errormsg ]}+                       , sqlExecStatus = status+                       , sqlErrorMsg = errormsg+                       , sqlErrorDetail = detail+                       , sqlErrorHint = hint }  disconnectedError :: SqlError-disconnectedError = SqlError {-                      sqlNativeError = -1,-                      sqlErrorMsg    = "connection disconnected",-                      sqlState       = ""-                    }+disconnectedError = fatalError "connection disconnected"  -- | Atomically perform an action with the database handle, if there is one. withConnection :: Connection -> (PQ.Connection -> IO a) -> IO a@@ -301,15 +284,47 @@  data Row = Row {      row        :: {-# UNPACK #-} !PQ.Row-   , typenames  :: !(V.Vector ByteString)    , rowresult  :: !PQ.Result    } -newtype RowParser a = RP { unRP :: ReaderT Row (StateT PQ.Column Ok) a }+newtype RowParser a = RP { unRP :: ReaderT Row (StateT PQ.Column Conversion) a }    deriving ( Functor, Applicative, Alternative, Monad ) -getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString-getvalue result row col = unsafePerformIO (PQ.getvalue result row col)+newtype Conversion a = Conversion { runConversion :: Connection -> IO (Ok a) } -nfields :: PQ.Result -> PQ.Column-nfields result = unsafePerformIO (PQ.nfields result)+instance Functor Conversion where+   fmap f m = Conversion $ \conn -> (fmap . fmap) f (runConversion m conn)++instance Applicative Conversion where+   pure a    = Conversion $ \_conn -> pure (pure a)+   mf <*> ma = Conversion $ \conn -> do+                   okf <- runConversion mf conn+                   case okf of+                     Ok f -> (fmap . fmap) f (runConversion ma conn)+                     Errors errs -> return (Errors errs)++instance Alternative Conversion where+   empty     = Conversion $ \_conn -> pure empty+   ma <|> mb = Conversion $ \conn -> do+                   oka <- runConversion ma conn+                   case oka of+                     Ok _     -> return oka+                     Errors _ -> (oka <|>) <$> runConversion mb conn+                       +instance Monad Conversion where+   return a = Conversion $ \_conn -> return (return a)+   m >>= f = Conversion $ \conn -> do+                 oka <- runConversion m conn +                 case oka of+                   Ok a -> runConversion (f a) conn+                   Errors err -> return (Errors err)++instance MonadPlus Conversion where+   mzero = empty+   mplus = (<|>)++conversionMap :: (Ok a -> Ok b) -> Conversion a -> Conversion b+conversionMap f m = Conversion $ \conn -> f <$> runConversion m conn++conversionError :: Exception err => err -> Conversion a+conversionError err = Conversion $ \_ -> return (Errors [SomeException err])

@@ -51,9 +51,7 @@     case res of       Nothing -> do           msg <- maybe str id <$> PQ.errorMessage c-          throwIO $ SqlError { sqlNativeError = -1   -- FIXME?-                             , sqlErrorMsg    = msg-                             , sqlState       = ""  }+          throwIO $ fatalError msg       Just  x -> return x  loCreat :: Connection -> IO Oid

@@ -29,14 +29,16 @@ -- -- This quasiquoter attempts to mimimize whitespace;  otherwise the -- above query would consist of approximately half whitespace when sent--- to the database backend.+-- to the database backend.  It also recognizes and strips out standard+-- sql comments "--". -- -- The implementation of the whitespace reducer is currently incomplete. -- Thus it can mess up your syntax in cases where whitespace should be -- preserved as-is.  It does preserve whitespace inside standard SQL string -- literals.  But it can get confused by the non-standard PostgreSQL string -- literal syntax (which is the default setting in PostgreSQL 8 and below),--- the extended escape string syntax,  and other similar constructs.+-- the extended escape string syntax,  quoted identifiers,  and other similar+-- constructs. -- -- Of course, this caveat only applies to text written inside the SQL -- quasiquoter; whitespace reduction is a compile-time computation and@@ -58,19 +60,28 @@     }  sqlExp :: String -> Q Exp-sqlExp = stringE . outstring . dropSpace+sqlExp = stringE . minimizeSpace++minimizeSpace :: String -> String+minimizeSpace = drop 1 . reduceSpace   where-    dropSpace = dropWhile isSpace+    needsReduced []          = False+    needsReduced ('-':'-':_) = True+    needsReduced (x:_)       = isSpace x -    outstring ('\'':xs) = '\'' : instring xs-    outstring (x:xs) | isSpace x = case dropSpace xs of-                                     [] -> []-                                     ys -> ' ' : outstring ys-                     | otherwise = x : outstring xs-    outstring [] = []+    reduceSpace xs =+        case dropWhile isSpace xs of+          [] -> []+          ('-':'-':ys) -> reduceSpace (dropWhile (/= '\n') ys)+          ys -> ' ' : insql ys +    insql ('\'':xs)            = '\'' : instring xs+    insql xs | needsReduced xs = reduceSpace xs+    insql (x:xs)               = x : insql xs+    insql []                   = []+     instring ('\'':'\'':xs) = '\'':'\'': instring xs-    instring ('\'':xs)      = '\'': outstring xs+    instring ('\'':xs)      = '\'': insql xs     instring (x:xs)         = x : instring xs     instring []             = error "Database.PostgreSQL.Simple.SqlQQ.sql:\                                     \ string literal not terminated"

@@ -39,6 +39,8 @@ import qualified Data.Text as ST import qualified Data.Text.Encoding as ST import qualified Data.Text.Lazy as LT+import           Data.Vector (Vector)+import qualified Data.Vector as V import qualified Database.PostgreSQL.LibPQ as PQ import           Database.PostgreSQL.Simple.Time @@ -220,6 +222,14 @@ instance ToField Date where     toField = Plain . inQuotes . dateToBuilder     {-# INLINE toField #-}++instance (ToField a) => ToField (Vector a) where+    toField xs = Many $+        Plain (fromByteString "ARRAY[") :+        (intersperse (Plain (fromChar ',')) . map toField $ V.toList xs) +++        [Plain (fromChar ']')]+        -- Because the ARRAY[...] input syntax is being used, it is possible+        -- that the use of type-specific separator characters is unnecessary.  -- | Surround a string with single-quote characters: \"@'@\" --

@@ -0,0 +1,7 @@+module Database.PostgreSQL.Simple.ToField where++import Database.PostgreSQL.Simple.Types++class ToField a++instance ToField Oid

@@ -0,0 +1,8 @@+module Database.PostgreSQL.Simple.ToRow where++import Database.PostgreSQL.Simple.Types+import {-# SOURCE #-} Database.PostgreSQL.Simple.ToField++class ToRow a++instance ToField a => ToRow (Only a)

@@ -0,0 +1,193 @@+{-# LANGUAGE RecordWildCards #-}++module Database.PostgreSQL.Simple.Transaction+    (+    -- * Transaction handling+      withTransaction+    , withTransactionLevel+    , withTransactionMode+    , withTransactionModeRetry+    , withTransactionSerializable+    , isSerializationError+    , TransactionMode(..)+    , IsolationLevel(..)+    , ReadWriteMode(..)+    , defaultTransactionMode+    , defaultIsolationLevel+    , defaultReadWriteMode+--    , Base.autocommit+    , begin+    , beginLevel+    , beginMode+    , commit+    , rollback+    ) where++import Control.Exception hiding (mask)+import qualified Data.ByteString as B+import Database.PostgreSQL.Simple.Internal+import Database.PostgreSQL.Simple.Types+import Database.PostgreSQL.Simple.Compat(mask)+++-- | Of the four isolation levels defined by the SQL standard,+-- these are the three levels distinguished by PostgreSQL as of version 9.0.+-- See <http://www.postgresql.org/docs/9.1/static/transaction-iso.html>+-- for more information.   Note that prior to PostgreSQL 9.0, 'RepeatableRead'+-- was equivalent to 'Serializable'.++data IsolationLevel+   = DefaultIsolationLevel  -- ^ the isolation level will be taken from+                            --   PostgreSQL's per-connection+                            --   @default_transaction_isolation@ variable,+                            --   which is initialized according to the+                            --   server's config.  The default configuration+                            --   is 'ReadCommitted'.+   | ReadCommitted+   | RepeatableRead+   | Serializable+     deriving (Show, Eq, Ord, Enum, Bounded)++data ReadWriteMode+   = DefaultReadWriteMode   -- ^ the read-write mode will be taken from+                            --   PostgreSQL's per-connection+                            --   @default_transaction_read_only@ variable,+                            --   which is initialized according to the+                            --   server's config.  The default configuration+                            --   is 'ReadWrite'.+   | ReadWrite+   | ReadOnly+     deriving (Show, Eq, Ord, Enum, Bounded)++data TransactionMode = TransactionMode {+       isolationLevel :: !IsolationLevel,+       readWriteMode  :: !ReadWriteMode+     } deriving (Show, Eq)++defaultTransactionMode :: TransactionMode+defaultTransactionMode =  TransactionMode+                            defaultIsolationLevel+                            defaultReadWriteMode++defaultIsolationLevel  :: IsolationLevel+defaultIsolationLevel  =  DefaultIsolationLevel++defaultReadWriteMode   :: ReadWriteMode+defaultReadWriteMode   =  DefaultReadWriteMode++-- | Execute an action inside a SQL transaction.+--+-- This function initiates a transaction with a \"@begin+-- transaction@\" statement, then executes the supplied action.  If+-- the action succeeds, the transaction will be completed with+-- 'Base.commit' before this function returns.+--+-- If the action throws /any/ kind of exception (not just a+-- PostgreSQL-related exception), the transaction will be rolled back using+-- 'rollback', then the exception will be rethrown.+withTransaction :: Connection -> IO a -> IO a+withTransaction = withTransactionMode defaultTransactionMode++-- | Execute an action inside of a 'Serializable' transaction.  If a+-- serialization failure occurs, roll back the transaction and try again.+-- Be warned that this may execute the IO action multiple times.+--+-- A 'Serializable' transaction creates the illusion that your program has+-- exclusive access to the database.  This means that, even in a concurrent+-- setting, you can perform queries in sequence without having to worry about+-- what might happen between one statement and the next.+--+-- Think of it as STM, but without @retry@.+withTransactionSerializable :: Connection -> IO a -> IO a+withTransactionSerializable =+    withTransactionModeRetry+        TransactionMode+        { isolationLevel = Serializable+        , readWriteMode  = ReadWrite+        }+        isSerializationError+++isSerializationError :: SqlError -> Bool+isSerializationError exception =+      case exception of+        SqlError{..} | sqlState == serialization_failure+          -> True+        _ -> False+  where+    -- http://www.postgresql.org/docs/current/static/errcodes-appendix.html+    serialization_failure = "40001"++-- | Execute an action inside a SQL transaction with a given isolation level.+withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a+withTransactionLevel lvl+    = withTransactionMode defaultTransactionMode { isolationLevel = lvl }++-- | Execute an action inside a SQL transaction with a given transaction mode.+withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a+withTransactionMode mode conn act =+  mask $ \restore -> do+    beginMode mode conn+    r <- restore act `onException` rollback conn+    commit conn+    return r++-- | Like 'withTransactionMode', but also takes a custom callback to+-- determine if a transaction should be retried if an 'SqlError' occurs.+-- If the callback returns True, then the transaction will be retried.+-- If the callback returns False, or an exception other than an 'SqlError'+-- occurs then the transaction will be rolled back and the exception rethrown.+--+-- This is used to implement 'withTransactionSerializable'.+withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a+withTransactionModeRetry mode shouldRetry conn act =+    mask $ \restore ->+        retryLoop $ try $ do+            a <- restore act+            commit conn+            return a+  where+    retryLoop :: IO (Either SomeException a) -> IO a+    retryLoop act' = do+        beginMode mode conn+        r <- act'+        case r of+            Left e -> do+                rollback conn+                case fmap shouldRetry (fromException e) of+                  Just True -> retryLoop act'+                  _ -> throwIO e+            Right a ->+                return a++-- | Rollback a transaction.+rollback :: Connection -> IO ()+rollback conn = execute_ conn "ABORT" >> return ()++-- | Commit a transaction.+commit :: Connection -> IO ()+commit conn = execute_ conn "COMMIT" >> return ()++-- | Begin a transaction.+begin :: Connection -> IO ()+begin = beginMode defaultTransactionMode++-- | Begin a transaction with a given isolation level+beginLevel :: IsolationLevel -> Connection -> IO ()+beginLevel lvl = beginMode defaultTransactionMode { isolationLevel = lvl }++-- | Begin a transaction with a given transaction mode+beginMode :: TransactionMode -> Connection -> IO ()+beginMode mode conn = do+    _ <- execute_ conn $! Query (B.concat ["BEGIN", isolevel, readmode])+    return ()+  where+    isolevel = case isolationLevel mode of+                 DefaultIsolationLevel -> ""+                 ReadCommitted  -> " ISOLATION LEVEL READ COMMITTED"+                 RepeatableRead -> " ISOLATION LEVEL REPEATABLE READ"+                 Serializable   -> " ISOLATION LEVEL SERIALIZABLE"+    readmode = case readWriteMode mode of+                 DefaultReadWriteMode -> ""+                 ReadWrite -> " READ WRITE"+                 ReadOnly  -> " READ ONLY"

@@ -0,0 +1,63 @@+{-# LANGUAGE RecordWildCards #-}++------------------------------------------------------------------------------+-- |+-- Module:      Database.PostgreSQL.Simple.TypeInfo+-- Copyright:   (c) 2013 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.TypeInfo+     ( getTypeInfo+     , TypeInfo(..)+     ) where++import qualified Data.ByteString.Char8 as B8+import qualified Data.IntMap as IntMap+import           Control.Concurrent.MVar+import           Control.Exception (throw)++import qualified Database.PostgreSQL.LibPQ as PQ+import {-# SOURCE #-} Database.PostgreSQL.Simple+import                Database.PostgreSQL.Simple.Internal+import                Database.PostgreSQL.Simple.Types+import                Database.PostgreSQL.Simple.TypeInfo.Types+import                Database.PostgreSQL.Simple.TypeInfo.Static++getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo+getTypeInfo conn@Connection{..} oid =+  case staticTypeInfo oid of+    Just name -> return name+    Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid++getTypeInfo' :: Connection -> PQ.Oid -> TypeInfoCache+             -> IO (TypeInfoCache, TypeInfo)+getTypeInfo' conn oid oidmap =+  case IntMap.lookup (oid2int oid) oidmap of+    Just typeinfo -> return (oidmap, typeinfo)+    Nothing -> do+      names  <- query conn "SELECT oid, typcategory, typdelim, typname, typelem\+                         \ FROM pg_type WHERE oid = ?"+                           (Only oid)+      (oidmap', typeInfo) <-+          case names of+            []  -> return $ throw (fatalError "invalid type oid")+            [(typoid, typcategory_, typdelim_, typname, typelem_)] -> do+               let !typcategory = B8.index typcategory_ 0+                   !typdelim    = B8.index typdelim_    0+               if typcategory == 'A'+                 then do+                   (oidmap', typelem) <- getTypeInfo' conn typelem_ oidmap+                   let !typeInfo = Array{..}+                   return (oidmap', typeInfo)+                 else do+                   let !typeInfo = Basic{..}+                   return (oidmap, typeInfo)+            _ -> fail "typename query returned more than one result"+                   -- oid is a primary key,  so the query should+                   -- never return more than one result+      let !oidmap'' = IntMap.insert (oid2int oid) typeInfo oidmap'+      return $! (oidmap'', typeInfo)

@@ -0,0 +1,487 @@+------------------------------------------------------------------------------+-- |+-- Module:      Database.PostgreSQL.Simple.TypeInfo+-- Copyright:   (c) 2011-2012 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+-- Note that this module is semi-internal,  and you probably want to use+-- Database.PostgreSQL.Simple.TypeInfo instead.+--+------------------------------------------------------------------------------++-- Note that this file is generated by tools/GenTypeInfo.hs, and should+-- not be edited directly++module Database.PostgreSQL.Simple.TypeInfo.Static+     ( TypeInfo(..)+     , staticTypeInfo+     , bool+     , bytea+     , char+     , name+     , int8+     , int2+     , int4+     , regproc+     , text+     , oid+     , tid+     , xid+     , cid+     , xml+     , point+     , lseg+     , path+     , box+     , polygon+     , line+     , cidr+     , float4+     , float8+     , abstime+     , reltime+     , tinterval+     , unknown+     , circle+     , money+     , macaddr+     , inet+     , bpchar+     , varchar+     , date+     , time+     , timestamp+     , timestamptz+     , interval+     , timetz+     , bit+     , varbit+     , numeric+     , refcursor+     , record+     , void+     , uuid+     ) where++import Database.PostgreSQL.LibPQ (Oid(..))+import Database.PostgreSQL.Simple.TypeInfo.Types++staticTypeInfo :: Oid -> Maybe TypeInfo+staticTypeInfo (Oid x) = case x of+    16   -> Just bool+    17   -> Just bytea+    18   -> Just char+    19   -> Just name+    20   -> Just int8+    21   -> Just int2+    23   -> Just int4+    24   -> Just regproc+    25   -> Just text+    26   -> Just oid+    27   -> Just tid+    28   -> Just xid+    29   -> Just cid+    142  -> Just xml+    600  -> Just point+    601  -> Just lseg+    602  -> Just path+    603  -> Just box+    604  -> Just polygon+    628  -> Just line+    650  -> Just cidr+    700  -> Just float4+    701  -> Just float8+    702  -> Just abstime+    703  -> Just reltime+    704  -> Just tinterval+    705  -> Just unknown+    718  -> Just circle+    790  -> Just money+    829  -> Just macaddr+    869  -> Just inet+    1042 -> Just bpchar+    1043 -> Just varchar+    1082 -> Just date+    1083 -> Just time+    1114 -> Just timestamp+    1184 -> Just timestamptz+    1186 -> Just interval+    1266 -> Just timetz+    1560 -> Just bit+    1562 -> Just varbit+    1700 -> Just numeric+    1790 -> Just refcursor+    2249 -> Just record+    2278 -> Just void+    2950 -> Just uuid+    _ -> Nothing++bool :: TypeInfo+bool =  Basic {+    typoid      = Oid 16,+    typcategory = 'B',+    typdelim    = ',',+    typname     = "bool"+  }++bytea :: TypeInfo+bytea =  Basic {+    typoid      = Oid 17,+    typcategory = 'U',+    typdelim    = ',',+    typname     = "bytea"+  }++char :: TypeInfo+char =  Basic {+    typoid      = Oid 18,+    typcategory = 'S',+    typdelim    = ',',+    typname     = "char"+  }++name :: TypeInfo+name =  Basic {+    typoid      = Oid 19,+    typcategory = 'S',+    typdelim    = ',',+    typname     = "name"+  }++int8 :: TypeInfo+int8 =  Basic {+    typoid      = Oid 20,+    typcategory = 'N',+    typdelim    = ',',+    typname     = "int8"+  }++int2 :: TypeInfo+int2 =  Basic {+    typoid      = Oid 21,+    typcategory = 'N',+    typdelim    = ',',+    typname     = "int2"+  }++int4 :: TypeInfo+int4 =  Basic {+    typoid      = Oid 23,+    typcategory = 'N',+    typdelim    = ',',+    typname     = "int4"+  }++regproc :: TypeInfo+regproc =  Basic {+    typoid      = Oid 24,+    typcategory = 'N',+    typdelim    = ',',+    typname     = "regproc"+  }++text :: TypeInfo+text =  Basic {+    typoid      = Oid 25,+    typcategory = 'S',+    typdelim    = ',',+    typname     = "text"+  }++oid :: TypeInfo+oid =  Basic {+    typoid      = Oid 26,+    typcategory = 'N',+    typdelim    = ',',+    typname     = "oid"+  }++tid :: TypeInfo+tid =  Basic {+    typoid      = Oid 27,+    typcategory = 'U',+    typdelim    = ',',+    typname     = "tid"+  }++xid :: TypeInfo+xid =  Basic {+    typoid      = Oid 28,+    typcategory = 'U',+    typdelim    = ',',+    typname     = "xid"+  }++cid :: TypeInfo+cid =  Basic {+    typoid      = Oid 29,+    typcategory = 'U',+    typdelim    = ',',+    typname     = "cid"+  }++xml :: TypeInfo+xml =  Basic {+    typoid      = Oid 142,+    typcategory = 'U',+    typdelim    = ',',+    typname     = "xml"+  }++point :: TypeInfo+point =  Basic {+    typoid      = Oid 600,+    typcategory = 'G',+    typdelim    = ',',+    typname     = "point"+  }++lseg :: TypeInfo+lseg =  Basic {+    typoid      = Oid 601,+    typcategory = 'G',+    typdelim    = ',',+    typname     = "lseg"+  }++path :: TypeInfo+path =  Basic {+    typoid      = Oid 602,+    typcategory = 'G',+    typdelim    = ',',+    typname     = "path"+  }++box :: TypeInfo+box =  Basic {+    typoid      = Oid 603,+    typcategory = 'G',+    typdelim    = ';',+    typname     = "box"+  }++polygon :: TypeInfo+polygon =  Basic {+    typoid      = Oid 604,+    typcategory = 'G',+    typdelim    = ',',+    typname     = "polygon"+  }++line :: TypeInfo+line =  Basic {+    typoid      = Oid 628,+    typcategory = 'G',+    typdelim    = ',',+    typname     = "line"+  }++cidr :: TypeInfo+cidr =  Basic {+    typoid      = Oid 650,+    typcategory = 'I',+    typdelim    = ',',+    typname     = "cidr"+  }++float4 :: TypeInfo+float4 =  Basic {+    typoid      = Oid 700,+    typcategory = 'N',+    typdelim    = ',',+    typname     = "float4"+  }++float8 :: TypeInfo+float8 =  Basic {+    typoid      = Oid 701,+    typcategory = 'N',+    typdelim    = ',',+    typname     = "float8"+  }++abstime :: TypeInfo+abstime =  Basic {+    typoid      = Oid 702,+    typcategory = 'D',+    typdelim    = ',',+    typname     = "abstime"+  }++reltime :: TypeInfo+reltime =  Basic {+    typoid      = Oid 703,+    typcategory = 'T',+    typdelim    = ',',+    typname     = "reltime"+  }++tinterval :: TypeInfo+tinterval =  Basic {+    typoid      = Oid 704,+    typcategory = 'T',+    typdelim    = ',',+    typname     = "tinterval"+  }++unknown :: TypeInfo+unknown =  Basic {+    typoid      = Oid 705,+    typcategory = 'X',+    typdelim    = ',',+    typname     = "unknown"+  }++circle :: TypeInfo+circle =  Basic {+    typoid      = Oid 718,+    typcategory = 'G',+    typdelim    = ',',+    typname     = "circle"+  }++money :: TypeInfo+money =  Basic {+    typoid      = Oid 790,+    typcategory = 'N',+    typdelim    = ',',+    typname     = "money"+  }++macaddr :: TypeInfo+macaddr =  Basic {+    typoid      = Oid 829,+    typcategory = 'U',+    typdelim    = ',',+    typname     = "macaddr"+  }++inet :: TypeInfo+inet =  Basic {+    typoid      = Oid 869,+    typcategory = 'I',+    typdelim    = ',',+    typname     = "inet"+  }++bpchar :: TypeInfo+bpchar =  Basic {+    typoid      = Oid 1042,+    typcategory = 'S',+    typdelim    = ',',+    typname     = "bpchar"+  }++varchar :: TypeInfo+varchar =  Basic {+    typoid      = Oid 1043,+    typcategory = 'S',+    typdelim    = ',',+    typname     = "varchar"+  }++date :: TypeInfo+date =  Basic {+    typoid      = Oid 1082,+    typcategory = 'D',+    typdelim    = ',',+    typname     = "date"+  }++time :: TypeInfo+time =  Basic {+    typoid      = Oid 1083,+    typcategory = 'D',+    typdelim    = ',',+    typname     = "time"+  }++timestamp :: TypeInfo+timestamp =  Basic {+    typoid      = Oid 1114,+    typcategory = 'D',+    typdelim    = ',',+    typname     = "timestamp"+  }++timestamptz :: TypeInfo+timestamptz =  Basic {+    typoid      = Oid 1184,+    typcategory = 'D',+    typdelim    = ',',+    typname     = "timestamptz"+  }++interval :: TypeInfo+interval =  Basic {+    typoid      = Oid 1186,+    typcategory = 'T',+    typdelim    = ',',+    typname     = "interval"+  }++timetz :: TypeInfo+timetz =  Basic {+    typoid      = Oid 1266,+    typcategory = 'D',+    typdelim    = ',',+    typname     = "timetz"+  }++bit :: TypeInfo+bit =  Basic {+    typoid      = Oid 1560,+    typcategory = 'V',+    typdelim    = ',',+    typname     = "bit"+  }++varbit :: TypeInfo+varbit =  Basic {+    typoid      = Oid 1562,+    typcategory = 'V',+    typdelim    = ',',+    typname     = "varbit"+  }++numeric :: TypeInfo+numeric =  Basic {+    typoid      = Oid 1700,+    typcategory = 'N',+    typdelim    = ',',+    typname     = "numeric"+  }++refcursor :: TypeInfo+refcursor =  Basic {+    typoid      = Oid 1790,+    typcategory = 'U',+    typdelim    = ',',+    typname     = "refcursor"+  }++record :: TypeInfo+record =  Basic {+    typoid      = Oid 2249,+    typcategory = 'P',+    typdelim    = ',',+    typname     = "record"+  }++void :: TypeInfo+void =  Basic {+    typoid      = Oid 2278,+    typcategory = 'P',+    typdelim    = ',',+    typname     = "void"+  }++uuid :: TypeInfo+uuid =  Basic {+    typoid      = Oid 2950,+    typcategory = 'U',+    typdelim    = ',',+    typname     = "uuid"+  }

@@ -0,0 +1,30 @@+------------------------------------------------------------------------------+-- |+-- Module:      Database.PostgreSQL.Simple.TypeInfo.Types+-- Copyright:   (c) 2013 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.TypeInfo.Types where++import Data.ByteString(ByteString)+import Database.PostgreSQL.LibPQ(Oid)++data TypeInfo++  = Basic { typoid      :: {-# UNPACK #-} !Oid+          , typcategory :: {-# UNPACK #-} !Char+          , typdelim    :: {-# UNPACK #-} !Char+          , typname     :: !ByteString+          }++  | Array { typoid      :: {-# UNPACK #-} !Oid+          , typcategory :: {-# UNPACK #-} !Char+          , typdelim    :: {-# UNPACK #-} !Char+          , typname     :: !ByteString+          , typelem     :: !TypeInfo+          }+    deriving (Show)

@@ -1,25 +0,0 @@-module Bytea (testBytea) where--import Common-import qualified Data.ByteString as B--testBytea :: TestEnv -> Test-testBytea TestEnv{..} = TestList-    [ testStr "empty"                  []-    , testStr "\"hello\""              $ map (fromIntegral . fromEnum) ("hello" :: String)-    , testStr "ascending"              [0..255]-    , testStr "descending"             [255,254..0]-    , testStr "ascending, doubled up"  $ doubleUp [0..255]-    , testStr "descending, doubled up" $ doubleUp [255,254..0]-    ]-  where-    testStr label bytes = TestLabel label $ TestCase $ do-        let bs = B.pack bytes--        [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs]-        assertBool "Haskell -> SQL conversion altered the string" $ md5 bs == h--        [Only (Binary r)] <- query conn "SELECT ?::bytea" [Binary bs]-        assertBool "SQL -> Haskell conversion altered the string" $ bs == r--    doubleUp = concatMap (\x -> [x, x])

@@ -1,23 +0,0 @@-module ExecuteMany (testExecuteMany) where--import Common--import Data.ByteString (ByteString)--testExecuteMany :: TestEnv -> Test-testExecuteMany TestEnv{..} = TestCase $ do-    execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)"--    let rows :: [(Int, String, Binary ByteString)]-        rows = [ (1, "hello", Binary "bye")-               , (2, "world", Binary "\0\r\t\n")-               , (3, "?",     Binary "")-               ]--    count <- executeMany conn "INSERT INTO tmp_executeMany VALUES (?, ?, ?)" rows-    assertEqual "count" (fromIntegral $ length rows) count--    rows' <- query_ conn "SELECT * FROM tmp_executeMany"-    assertEqual "rows" rows rows'--    return ()

@@ -1,11 +1,15 @@+{-# LANGUAGE ScopedTypeVariables #-} import Common-import Control.Exception            (bracket)-import Control.Monad                (when)-import System.Exit                  (exitFailure)+import Database.PostgreSQL.Simple.FromField (FromField)+import Control.Exception as E+import Control.Monad+import Data.ByteString (ByteString)+import Data.Typeable+import qualified Data.ByteString as B+import System.Exit (exitFailure) import System.IO+import qualified Data.Vector as V -import Bytea-import ExecuteMany import Notify import Serializable import Time@@ -13,11 +17,94 @@ tests :: [TestEnv -> Test] tests =     [ TestLabel "Bytea"         . testBytea-    , TestLabel "Notify"        . testNotify     , TestLabel "ExecuteMany"   . testExecuteMany-    , TestLabel "Time"          . testTime+    , TestLabel "Fold"          . testFold+    , TestLabel "Notify"        . testNotify     , TestLabel "Serializable"  . testSerializable+    , TestLabel "Time"          . testTime+    , TestLabel "Array"         . testArray     ]++testBytea :: TestEnv -> Test+testBytea TestEnv{..} = TestList+    [ testStr "empty"                  []+    , testStr "\"hello\""              $ map (fromIntegral . fromEnum) ("hello" :: String)+    , testStr "ascending"              [0..255]+    , testStr "descending"             [255,254..0]+    , testStr "ascending, doubled up"  $ doubleUp [0..255]+    , testStr "descending, doubled up" $ doubleUp [255,254..0]+    ]+  where+    testStr label bytes = TestLabel label $ TestCase $ do+        let bs = B.pack bytes++        [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs]+        assertBool "Haskell -> SQL conversion altered the string" $ md5 bs == h++        [Only (Binary r)] <- query conn "SELECT ?::bytea" [Binary bs]+        assertBool "SQL -> Haskell conversion altered the string" $ bs == r++    doubleUp = concatMap (\x -> [x, x])++testExecuteMany :: TestEnv -> Test+testExecuteMany TestEnv{..} = TestCase $ do+    execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)"++    let rows :: [(Int, String, Binary ByteString)]+        rows = [ (1, "hello", Binary "bye")+               , (2, "world", Binary "\0\r\t\n")+               , (3, "?",     Binary "")+               ]++    count <- executeMany conn "INSERT INTO tmp_executeMany VALUES (?, ?, ?)" rows+    count @?= fromIntegral (length rows)++    rows' <- query_ conn "SELECT * FROM tmp_executeMany"+    rows' @?= rows++    return ()++testFold :: TestEnv -> Test+testFold TestEnv{..} = TestCase $ do+    xs <- fold_ conn "SELECT generate_series(1,10000)"+            [] $ \xs (Only x) -> return (x:xs)+    reverse xs @?= ([1..10000] :: [Int])++    -- TODO: add more complete tests, e.g.:+    --+    --  * Fold in a transaction+    --+    --  * Fold in a transaction after a previous fold has been performed+    --+    --  * Nested fold++    return ()++queryFailure :: forall a. (FromField a, Typeable a, Show a)+             => Connection -> Query -> a -> Assertion+queryFailure conn q resultType = do+  x :: Either SomeException [Only a] <- E.try $ query_ conn q+  case x of+    Left  _   -> return ()+    Right val -> assertFailure ("Did not fail as expected:  "+                              ++ show q+                              ++ " :: "+                              ++ show (typeOf resultType)+                              ++ " -> " ++ show val)+++testArray :: TestEnv -> Test+testArray TestEnv{..} = TestCase $ do+    xs <- query_ conn "SELECT '{1,2,3,4}'::_int4"+    xs @?= [Only (V.fromList [1,2,3,4 :: Int])]+    xs <- query_ conn "SELECT '{{1,2},{3,4}}'::_int4"+    xs @?= [Only (V.fromList [V.fromList [1,2],+                              V.fromList [3,4 :: Int]])]+    queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool)+    queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int)+++------------------------------------------------------------------------  -- | Action for connecting to the database that will be used for testing. --

@@ -1,10 +1,10 @@-{-# LANGUAGE ScopedTypeVariables #-} module Serializable (testSerializable) where  import Common import Control.Concurrent import Control.Exception as E import Data.IORef+import Database.PostgreSQL.Simple.Transaction  initCounter :: Connection -> IO () initCounter conn = do

@@ -1,4 +1,4 @@-{-# LANGUAGE QuasiQuotes, ScopedTypeVariables #-}+{-# LANGUAGE QuasiQuotes #-}  {-