commit ghc-postgresql-simple for openSUSE:Factory

Hello community, here is the log from the commit of package ghc-postgresql-simple for openSUSE:Factory checked in at 2017-06-04 01:58:32 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-postgresql-simple (Old) and /work/SRC/openSUSE:Factory/.ghc-postgresql-simple.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-postgresql-simple" Sun Jun 4 01:58:32 2017 rev:2 rq:499722 version:0.5.3.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-postgresql-simple/ghc-postgresql-simple.changes 2016-10-22 13:17:56.000000000 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-postgresql-simple.new/ghc-postgresql-simple.changes 2017-06-04 01:58:33.686945015 +0200 @@ -1,0 +2,5 @@ +Thu May 18 09:52:17 UTC 2017 - psimons@suse.com + +- Update to version 0.5.3.0 with cabal2obs. + +------------------------------------------------------------------- Old: ---- postgresql-simple-0.5.2.1.tar.gz New: ---- postgresql-simple-0.5.3.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-postgresql-simple.spec ++++++ --- /var/tmp/diff_new_pack.tO8Tso/_old 2017-06-04 01:58:35.386704883 +0200 +++ /var/tmp/diff_new_pack.tO8Tso/_new 2017-06-04 01:58:35.390704318 +0200 @@ -1,7 +1,7 @@ # # spec file for package ghc-postgresql-simple # -# Copyright (c) 2016 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,15 +19,14 @@ %global pkg_name postgresql-simple %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.5.2.1 +Version: 0.5.3.0 Release: 0 Summary: Mid-Level PostgreSQL client library License: BSD-3-Clause -Group: System/Libraries +Group: Development/Languages/Other Url: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz BuildRequires: ghc-Cabal-devel -# Begin cabal-rpm deps: BuildRequires: ghc-aeson-devel BuildRequires: ghc-attoparsec-devel BuildRequires: ghc-bytestring-builder-devel @@ -54,7 +53,6 @@ BuildRequires: ghc-tasty-golden-devel BuildRequires: ghc-tasty-hunit-devel %endif -# End cabal-rpm deps %description Mid-Level PostgreSQL client library, forked from mysql-simple. @@ -74,20 +72,14 @@ %prep %setup -q -n %{pkg_name}-%{version} - %build %ghc_lib_build - %install %ghc_lib_install - %check -%if %{with tests} -%{cabal} test -%endif - +%cabal_test %post devel %ghc_pkg_recache @@ -101,6 +93,6 @@ %files devel -f %{name}-devel.files %defattr(-,root,root,-) -%doc CHANGELOG.md +%doc CHANGELOG.md CONTRIBUTORS %changelog ++++++ postgresql-simple-0.5.2.1.tar.gz -> postgresql-simple-0.5.3.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/postgresql-simple-0.5.2.1/CHANGELOG.md new/postgresql-simple-0.5.3.0/CHANGELOG.md --- old/postgresql-simple-0.5.2.1/CHANGELOG.md 2016-06-29 21:24:32.000000000 +0200 +++ new/postgresql-simple-0.5.3.0/CHANGELOG.md 2017-05-15 07:29:53.000000000 +0200 @@ -1,22 +1,22 @@ For the full changelog, see https://github.com/lpsmith/postgresql-simple/blob/master/CHANGES.md -### Version 0.5.2.1 (2016-06-29) - * Bumped the lower bound for `base` to 4.6. Thanks to Herbert - Valerio Riedel for reporting the issue. - - * Added an `Eq` instance for `SqlError`, thanks to Chris Allen - - * Fixed a bug where a all-caps `"NULL"` text value inside a - postgresql array would get parsed as the SQL null value. Thanks - goes to Edgar Gomes and Silk for finding and fixing this mistake. - - * Modified `withTransaction` and friends to ignore `IOError`s when - attempting to roll back the transaction. This fixes a buggy - interaction between `withTransaction` and async exceptions (e.g. - `System.Timeout`) on unix platforms. Thanks goes to Erik - Hesselink and Silk for providing the test case that exposed this - issue. - - * Added the `testTimeout` regression test for the problem above. +### Version 0.5.3.0 (2017-05-15) + * Refactored some rudimentary cursor handling code out of the + implementation of the fold operators, into a new + `Database.PostgreSQL.Simple.Cursor` module, thanks to Bardur Arantsson. + + * Made the `FromField` instance for `Char` compatible with + postgresql's `bpchar` type. Thanks to Ivan Lazar Miljenovic for + reporting the issue. + + * Added `Show` and `Eq` instances for `Notification`, thanks to + Matvey Aksenov. + + * Fixed some example code, thanks to Matvey Aksenov. + + * Fixed a problem with using `conversionError` to throw exceptions + of type `SomeException`. Previously, the exception would be + wrapped in a second `SomeException` dynamic constructor which + would cause normal GHC typecase idioms over `SomeException` to fail. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/postgresql-simple-0.5.2.1/CONTRIBUTORS new/postgresql-simple-0.5.3.0/CONTRIBUTORS --- old/postgresql-simple-0.5.2.1/CONTRIBUTORS 2016-06-29 21:24:32.000000000 +0200 +++ new/postgresql-simple-0.5.3.0/CONTRIBUTORS 2017-05-15 07:29:53.000000000 +0200 @@ -33,3 +33,4 @@ Ben Gamari Edgar Gomes Araujo Erik Hesselink +Matvey Aksenov diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/postgresql-simple-0.5.2.1/postgresql-simple.cabal new/postgresql-simple-0.5.3.0/postgresql-simple.cabal --- old/postgresql-simple-0.5.2.1/postgresql-simple.cabal 2016-06-29 21:24:32.000000000 +0200 +++ new/postgresql-simple-0.5.3.0/postgresql-simple.cabal 2017-05-15 07:29:53.000000000 +0200 @@ -1,5 +1,5 @@ Name: postgresql-simple -Version: 0.5.2.1 +Version: 0.5.3.0 Synopsis: Mid-Level PostgreSQL client library Description: Mid-Level PostgreSQL client library, forked from mysql-simple. @@ -24,6 +24,7 @@ Database.PostgreSQL.Simple Database.PostgreSQL.Simple.Arrays Database.PostgreSQL.Simple.Copy + Database.PostgreSQL.Simple.Cursor Database.PostgreSQL.Simple.FromField Database.PostgreSQL.Simple.FromRow Database.PostgreSQL.Simple.LargeObjects @@ -49,6 +50,7 @@ Other-modules: Database.PostgreSQL.Simple.Compat Database.PostgreSQL.Simple.HStore.Implementation + Database.PostgreSQL.Simple.Internal.PQResultUtils Database.PostgreSQL.Simple.Time.Implementation Database.PostgreSQL.Simple.Time.Internal.Parser Database.PostgreSQL.Simple.Time.Internal.Printer @@ -88,7 +90,7 @@ source-repository this type: git location: http://github.com/lpsmith/postgresql-simple - tag: v0.5.2.1 + tag: v0.5.3.0 test-suite test type: exitcode-stdio-1.0 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/postgresql-simple-0.5.2.1/src/Database/PostgreSQL/Simple/Copy.hs new/postgresql-simple-0.5.3.0/src/Database/PostgreSQL/Simple/Copy.hs --- old/postgresql-simple-0.5.2.1/src/Database/PostgreSQL/Simple/Copy.hs 2016-06-29 21:24:32.000000000 +0200 +++ new/postgresql-simple-0.5.3.0/src/Database/PostgreSQL/Simple/Copy.hs 2017-05-15 07:29:53.000000000 +0200 @@ -75,15 +75,22 @@ doCopy funcName conn template q = do result <- exec conn q status <- PQ.resultStatus result - let err = throwIO $ QueryError - (B.unpack funcName ++ " " ++ show status) + let errMsg msg = throwIO $ QueryError + (B.unpack funcName ++ " " ++ msg) template + let err = errMsg $ show status case status of PQ.EmptyQuery -> err PQ.CommandOk -> err PQ.TuplesOk -> err PQ.CopyOut -> return () PQ.CopyIn -> return () +#if MIN_VERSION_postgresql_libpq(0,9,3) + PQ.CopyBoth -> errMsg "COPY BOTH is not supported" +#endif +#if MIN_VERSION_postgresql_libpq(0,9,2) + PQ.SingleTuple -> errMsg "single-row mode is not supported" +#endif PQ.BadResponse -> throwResultError funcName result status PQ.NonfatalError -> throwResultError funcName result status PQ.FatalError -> throwResultError funcName result status diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/postgresql-simple-0.5.2.1/src/Database/PostgreSQL/Simple/Cursor.hs new/postgresql-simple-0.5.3.0/src/Database/PostgreSQL/Simple/Cursor.hs --- old/postgresql-simple-0.5.2.1/src/Database/PostgreSQL/Simple/Cursor.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/postgresql-simple-0.5.3.0/src/Database/PostgreSQL/Simple/Cursor.hs 2017-05-15 07:29:53.000000000 +0200 @@ -0,0 +1,98 @@ +{-# LANGUAGE OverloadedStrings #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.Cursor +-- Copyright: (c) 2011-2012 Leon P Smith +-- (c) 2017 Bardur Arantsson +-- License: BSD3 +-- Maintainer: Leon P Smith +-- +------------------------------------------------------------------------------ + +module Database.PostgreSQL.Simple.Cursor + ( + -- * Types + Cursor + -- * Cursor management + , declareCursor + , closeCursor + -- * Folding over rows from a cursor + , foldForward + , foldForwardWithParser + ) where + +import Data.ByteString.Builder (intDec) +import Control.Applicative ((<$>)) +import Control.Exception as E +import Control.Monad (unless, void) +import Data.Monoid (mconcat) +import Database.PostgreSQL.Simple.Compat ((<>), toByteString) +import Database.PostgreSQL.Simple.FromRow (FromRow(..)) +import Database.PostgreSQL.Simple.Types (Query(..)) +import Database.PostgreSQL.Simple.Internal as Base +import Database.PostgreSQL.Simple.Internal.PQResultUtils +import Database.PostgreSQL.Simple.Transaction +import qualified Database.PostgreSQL.LibPQ as PQ + +-- | Cursor within a transaction. +data Cursor = Cursor !Query !Connection + +-- | Declare a temporary cursor. The cursor is given a +-- unique name for the given connection. +declareCursor :: Connection -> Query -> IO Cursor +declareCursor conn q = do + name <- newTempName conn + void $ execute_ conn $ mconcat ["DECLARE ", name, " NO SCROLL CURSOR FOR ", q] + return $ Cursor name conn + +-- | Close the given cursor. +closeCursor :: Cursor -> IO () +closeCursor (Cursor name conn) = + (void $ execute_ conn ("CLOSE " <> name)) `E.catch` \ex -> + -- Don't throw exception if CLOSE failed because the transaction is + -- aborted. Otherwise, it will throw away the original error. + unless (isFailedTransactionError ex) $ throwIO ex + +-- | Fold over a chunk of rows from the given cursor, calling the +-- supplied fold-like function on each row as it is received. In case +-- the cursor is exhausted, a 'Left' value is returned, otherwise a +-- 'Right' value is returned. +foldForwardWithParser :: Cursor -> RowParser r -> Int -> (a -> r -> IO a) -> a -> IO (Either a a) +foldForwardWithParser (Cursor name conn) parser chunkSize f a0 = do + let q = "FETCH FORWARD " + <> (toByteString $ intDec chunkSize) + <> " FROM " + <> fromQuery name + result <- exec conn q + status <- PQ.resultStatus result + case status of + PQ.TuplesOk -> do + nrows <- PQ.ntuples result + ncols <- PQ.nfields result + if nrows > 0 + then do + let inner a row = do + x <- getRowWith parser row ncols conn result + f a x + Right <$> foldM' inner a0 0 (nrows - 1) + else + return $ Left a0 + _ -> throwResultError "foldForwardWithParser" result status + +-- | Fold over a chunk of rows, calling the supplied fold-like function +-- on each row as it is received. In case the cursor is exhausted, +-- a 'Left' value is returned, otherwise a 'Right' value is returned. +foldForward :: FromRow r => Cursor -> Int -> (a -> r -> IO a) -> a -> IO (Either a a) +foldForward cursor = foldForwardWithParser cursor fromRow + + +foldM' :: (Ord n, Num n) => (a -> n -> IO a) -> a -> n -> n -> IO a +foldM' f a lo hi = loop a lo + where + loop a !n + | n > hi = return a + | otherwise = do + a' <- f a n + loop a' (n+1) +{-# INLINE foldM' #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/postgresql-simple-0.5.2.1/src/Database/PostgreSQL/Simple/Errors.hs new/postgresql-simple-0.5.3.0/src/Database/PostgreSQL/Simple/Errors.hs --- old/postgresql-simple-0.5.2.1/src/Database/PostgreSQL/Simple/Errors.hs 2016-06-29 21:24:32.000000000 +0200 +++ new/postgresql-simple-0.5.3.0/src/Database/PostgreSQL/Simple/Errors.hs 2017-05-15 07:29:53.000000000 +0200 @@ -66,10 +66,10 @@ -- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and -- succeedes only if able to parse sqlErrorMsg. -- --- > createUser = catchJust constraintViolation catcher $ execute conn ... +-- > createUser = handleJust constraintViolation handler $ execute conn ... -- > where --- > catcher UniqueViolation "user_login_key" = ... --- > catcher _ = ... +-- > handler (UniqueViolation "user_login_key") = ... +-- > handler _ = ... constraintViolation :: SqlError -> Maybe ConstraintViolation constraintViolation e = case sqlState e of @@ -84,16 +84,16 @@ -- | Like constraintViolation, but also packs original SqlError. -- --- > createUser = catchJust constraintViolationE catcher $ execute conn ... +-- > createUser = handleJust constraintViolationE handler $ execute conn ... -- > where --- > catcher (_, UniqueViolation "user_login_key") = ... --- > catcher (e, _) = throwIO e +-- > handler (_, UniqueViolation "user_login_key") = ... +-- > handler (e, _) = throwIO 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 +-- on fail. Provides alternative interface to 'E.handleJust' -- -- > createUser = catchViolation catcher $ execute conn ... -- > where diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/postgresql-simple-0.5.2.1/src/Database/PostgreSQL/Simple/FromField.hs new/postgresql-simple-0.5.3.0/src/Database/PostgreSQL/Simple/FromField.hs --- old/postgresql-simple-0.5.2.1/src/Database/PostgreSQL/Simple/FromField.hs 2016-06-29 21:24:32.000000000 +0200 +++ new/postgresql-simple-0.5.3.0/src/Database/PostgreSQL/Simple/FromField.hs 2017-05-15 07:29:53.000000000 +0200 @@ -298,16 +298,16 @@ | bs == Just "f" = pure False | otherwise = returnError ConversionFailed f "" --- | \"char\" +-- | \"char\", bpchar instance FromField Char where fromField f bs = - if typeOid f /= $(inlineTypoid TI.char) - then returnError Incompatible f "" - else case bs of + if $(mkCompats [TI.char,TI.bpchar]) (typeOid f) + then case bs of Nothing -> returnError UnexpectedNull f "" Just bs -> if B.length bs /= 1 then returnError ConversionFailed f "length not 1" else return $! (B.head bs) + else returnError Incompatible f "" -- | int2 instance FromField Int16 where diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/postgresql-simple-0.5.2.1/src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs new/postgresql-simple-0.5.3.0/src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs --- old/postgresql-simple-0.5.2.1/src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/postgresql-simple-0.5.3.0/src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs 2017-05-15 07:29:53.000000000 +0200 @@ -0,0 +1,93 @@ +{-# LANGUAGE CPP #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.Internal.PQResultUtils +-- Copyright: (c) 2011 MailRank, Inc. +-- (c) 2011-2012 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +------------------------------------------------------------------------------ + + +module Database.PostgreSQL.Simple.Internal.PQResultUtils + ( finishQueryWith + , getRowWith + ) where + +import Control.Exception as E +import Data.ByteString (ByteString) +import Database.PostgreSQL.Simple.FromField (ResultError(..)) +import Database.PostgreSQL.Simple.Ok +import Database.PostgreSQL.Simple.Types (Query(..)) +import Database.PostgreSQL.Simple.Internal as Base +import Database.PostgreSQL.Simple.TypeInfo +import qualified Database.PostgreSQL.LibPQ as PQ +import qualified Data.ByteString.Char8 as B +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict + +finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r] +finishQueryWith parser conn q result = do + status <- PQ.resultStatus result + case status of + PQ.TuplesOk -> do + nrows <- PQ.ntuples result + ncols <- PQ.nfields result + forM' 0 (nrows-1) $ \row -> + getRowWith parser row ncols conn result + PQ.EmptyQuery -> queryErr "query: Empty query" + PQ.CommandOk -> queryErr "query resulted in a command response" + PQ.CopyOut -> queryErr "query: COPY TO is not supported" + PQ.CopyIn -> queryErr "query: COPY FROM is not supported" +#if MIN_VERSION_postgresql_libpq(0,9,3) + PQ.CopyBoth -> queryErr "query: COPY BOTH is not supported" +#endif +#if MIN_VERSION_postgresql_libpq(0,9,2) + PQ.SingleTuple -> queryErr "query: single-row mode is not supported" +#endif + PQ.BadResponse -> throwResultError "query" result status + PQ.NonfatalError -> throwResultError "query" result status + PQ.FatalError -> throwResultError "query" result status + where + queryErr msg = throwIO $ QueryError msg q + +getRowWith :: RowParser r -> PQ.Row -> PQ.Column -> Connection -> PQ.Result -> IO r +getRowWith parser row ncols conn result = do + let rw = Row row result + let unCol (PQ.Col x) = fromIntegral x :: Int + okvc <- runConversion (runStateT (runReaderT (unRP parser) 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 ( 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 "" Nothing "" "" "unknown error" + Errors [x] -> throwIO x + Errors xs -> throwIO $ ManyErrors xs + +ellipsis :: ByteString -> ByteString +ellipsis bs + | B.length bs > 15 = B.take 10 bs `B.append` "[...]" + | otherwise = bs + +forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a] +forM' lo hi m = loop hi [] + where + loop !n !as + | n < lo = return as + | otherwise = do + a <- m n + loop (n-1) (a:as) +{-# INLINE forM' #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/postgresql-simple-0.5.2.1/src/Database/PostgreSQL/Simple/Internal.hs new/postgresql-simple-0.5.3.0/src/Database/PostgreSQL/Simple/Internal.hs --- old/postgresql-simple-0.5.2.1/src/Database/PostgreSQL/Simple/Internal.hs 2016-06-29 21:24:32.000000000 +0200 +++ new/postgresql-simple-0.5.3.0/src/Database/PostgreSQL/Simple/Internal.hs 2017-05-15 07:29:53.000000000 +0200 @@ -351,6 +351,7 @@ Just res -> do status <- PQ.resultStatus res case status of + -- FIXME: handle PQ.CopyBoth and PQ.SingleTuple PQ.EmptyQuery -> getResult h mres' PQ.CommandOk -> getResult h mres' PQ.TuplesOk -> getResult h mres' @@ -371,6 +372,7 @@ finishExecute _conn q result = do status <- PQ.resultStatus result case status of + -- FIXME: handle PQ.CopyBoth and PQ.SingleTuple PQ.EmptyQuery -> throwIO $ QueryError "execute: Empty query" q PQ.CommandOk -> do ncols <- PQ.nfields result @@ -496,7 +498,7 @@ conversionMap f m = Conversion $ \conn -> f <$> runConversion m conn conversionError :: Exception err => err -> Conversion a -conversionError err = Conversion $ \_ -> return (Errors [SomeException err]) +conversionError err = Conversion $ \_ -> return (Errors [toException err]) newTempName :: Connection -> IO Query newTempName Connection{..} = do diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/postgresql-simple-0.5.2.1/src/Database/PostgreSQL/Simple/Notification.hs new/postgresql-simple-0.5.3.0/src/Database/PostgreSQL/Simple/Notification.hs --- old/postgresql-simple-0.5.2.1/src/Database/PostgreSQL/Simple/Notification.hs 2016-06-29 21:24:32.000000000 +0200 +++ new/postgresql-simple-0.5.3.0/src/Database/PostgreSQL/Simple/Notification.hs 2017-05-15 07:29:53.000000000 +0200 @@ -58,7 +58,7 @@ { notificationPid :: {-# UNPACK #-} !CPid , notificationChannel :: {-# UNPACK #-} !B.ByteString , notificationData :: {-# UNPACK #-} !B.ByteString - } + } deriving (Show, Eq) convertNotice :: PQ.Notify -> Notification convertNotice PQ.Notify{..} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/postgresql-simple-0.5.2.1/src/Database/PostgreSQL/Simple.hs new/postgresql-simple-0.5.3.0/src/Database/PostgreSQL/Simple.hs --- old/postgresql-simple-0.5.2.1/src/Database/PostgreSQL/Simple.hs 2016-06-29 21:24:32.000000000 +0200 +++ new/postgresql-simple-0.5.3.0/src/Database/PostgreSQL/Simple.hs 2017-05-15 07:29:53.000000000 +0200 @@ -118,30 +118,26 @@ , formatQuery ) where -import Data.ByteString.Builder - ( Builder, byteString, char8, intDec ) +import Data.ByteString.Builder (Builder, byteString, char8) import Control.Applicative ((<$>)) import Control.Exception as E -import Control.Monad (unless) import Data.ByteString (ByteString) import Data.Int (Int64) import Data.List (intersperse) import Data.Monoid (mconcat) -import Database.PostgreSQL.Simple.Compat ( (<>), toByteString ) +import Database.PostgreSQL.Simple.Compat ((<>), toByteString) +import Database.PostgreSQL.Simple.Cursor import Database.PostgreSQL.Simple.FromField (ResultError(..)) import Database.PostgreSQL.Simple.FromRow (FromRow(..)) -import Database.PostgreSQL.Simple.Ok import Database.PostgreSQL.Simple.ToField (Action(..)) import Database.PostgreSQL.Simple.ToRow (ToRow(..)) import Database.PostgreSQL.Simple.Types ( Binary(..), In(..), Only(..), Query(..), (:.)(..) ) import Database.PostgreSQL.Simple.Internal as Base +import Database.PostgreSQL.Simple.Internal.PQResultUtils 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 Control.Monad.Trans.Reader -import Control.Monad.Trans.State.Strict -- | Format a query string. @@ -562,39 +558,17 @@ PQ.TransUnknown -> fail "foldWithOpts FIXME: PQ.TransUnknown" -- Not sure what this means. where - declare = do - name <- newTempName conn - _ <- execute_ conn $ mconcat - [ "DECLARE ", name, " NO SCROLL CURSOR FOR ", q ] - return name - close name = - (execute_ conn ("CLOSE " <> name) >> return ()) `E.catch` \ex -> - -- Don't throw exception if CLOSE failed because the transaction is - -- aborted. Otherwise, it will throw away the original error. - unless (isFailedTransactionError ex) $ throwIO ex - - go = bracket declare close $ \(Query name) -> - let q = toByteString (byteString "FETCH FORWARD " - <> intDec chunkSize - <> byteString " FROM " - <> byteString name - ) - loop a = do - result <- exec conn q - status <- PQ.resultStatus result - case status of - PQ.TuplesOk -> do - nrows <- PQ.ntuples result - ncols <- PQ.nfields result - if nrows > 0 - then do - let inner a row = do - x <- getRowWith parser row ncols conn result - f a x - foldM' inner a 0 (nrows - 1) >>= loop - else return a - _ -> throwResultError "fold" result status - in loop a0 + declare = + declareCursor conn q + fetch cursor a = + foldForwardWithParser cursor parser chunkSize f a + + go = bracket declare closeCursor $ \cursor -> + let loop a = fetch cursor a >>= + \r -> case r of + Left a -> return a + Right a -> loop a + in loop a0 -- FIXME: choose the Automatic chunkSize more intelligently -- One possibility is to use the type of the results, although this @@ -644,76 +618,6 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const {-# INLINE forEachWith_ #-} -forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a] -forM' lo hi m = loop hi [] - where - loop !n !as - | n < lo = return as - | otherwise = do - a <- m n - loop (n-1) (a:as) -{-# INLINE forM' #-} - -foldM' :: (Ord n, Num n) => (a -> n -> IO a) -> a -> n -> n -> IO a -foldM' f a lo hi = loop a lo - where - loop a !n - | n > hi = return a - | otherwise = do - a' <- f a n - loop a' (n+1) -{-# INLINE foldM' #-} - -finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r] -finishQueryWith parser conn q result = do - status <- PQ.resultStatus result - case status of - PQ.EmptyQuery -> - throwIO $ QueryError "query: Empty query" q - PQ.CommandOk -> - throwIO $ QueryError "query resulted in a command response" q - PQ.TuplesOk -> do - nrows <- PQ.ntuples result - ncols <- PQ.nfields result - forM' 0 (nrows-1) $ \row -> - getRowWith parser row ncols conn result - PQ.CopyOut -> - throwIO $ QueryError "query: COPY TO is not supported" q - PQ.CopyIn -> - throwIO $ QueryError "query: COPY FROM is not supported" q - PQ.BadResponse -> throwResultError "query" result status - PQ.NonfatalError -> throwResultError "query" result status - PQ.FatalError -> throwResultError "query" result status - -getRowWith :: RowParser r -> PQ.Row -> PQ.Column -> Connection -> PQ.Result -> IO r -getRowWith parser row ncols conn result = do - let rw = Row row result - let unCol (PQ.Col x) = fromIntegral x :: Int - okvc <- runConversion (runStateT (runReaderT (unRP parser) 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 ( 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 "" Nothing "" "" "unknown error" - Errors [x] -> throwIO x - Errors xs -> throwIO $ ManyErrors xs - -ellipsis :: ByteString -> ByteString -ellipsis bs - | B.length bs > 15 = B.take 10 bs `B.append` "[...]" - | otherwise = bs - -- $use --