@@ -118,30 +118,26 @@ module Database.PostgreSQL.Simple
118118 , formatQuery
119119 ) where
120120
121−import Data.ByteString.Builder
122− ( Builder, byteString, char8, intDec )
121+import Data.ByteString.Builder (Builder, byteString, char8)
123122import Control.Applicative ((<$>))
124123import Control.Exception as E
125−import Control.Monad (unless)
126124import Data.ByteString (ByteString)
127125import Data.Int (Int64)
128126import Data.List (intersperse)
129127import Data.Monoid (mconcat)
130−import Database.PostgreSQL.Simple.Compat ( (<>), toByteString )
128+import Database.PostgreSQL.Simple.Compat ((<>), toByteString)
129+import Database.PostgreSQL.Simple.Cursor
131130import Database.PostgreSQL.Simple.FromField (ResultError(..))
132131import Database.PostgreSQL.Simple.FromRow (FromRow(..))
133−import Database.PostgreSQL.Simple.Ok
134132import Database.PostgreSQL.Simple.ToField (Action(..))
135133import Database.PostgreSQL.Simple.ToRow (ToRow(..))
136134import Database.PostgreSQL.Simple.Types
137135 ( Binary(..), In(..), Only(..), Query(..), (:.)(..) )
138136import Database.PostgreSQL.Simple.Internal as Base
137+import Database.PostgreSQL.Simple.Internal.PQResultUtils
139138import Database.PostgreSQL.Simple.Transaction
140−import Database.PostgreSQL.Simple.TypeInfo
141139import qualified Database.PostgreSQL.LibPQ as PQ
142140import qualified Data.ByteString.Char8 as B
143−import Control.Monad.Trans.Reader
144−import Control.Monad.Trans.State.Strict
145141
146142
147143-- | Format a query string.
@@ -562,39 +558,17 @@ doFold FoldOptions{..} parser conn _template q a0 f = do
562558 PQ.TransUnknown -> fail "foldWithOpts FIXME: PQ.TransUnknown"
563559 -- Not sure what this means.
564560 where
565− declare = do
566− name <- newTempName conn
567− _ <- execute_ conn $ mconcat
568− [ "DECLARE ", name, " NO SCROLL CURSOR FOR ", q ]
569− return name
570− close name =
571− (execute_ conn ("CLOSE " <> name) >> return ()) `E.catch` \ex ->
572− -- Don't throw exception if CLOSE failed because the transaction is
573− -- aborted. Otherwise, it will throw away the original error.
574− unless (isFailedTransactionError ex) $ throwIO ex
575−
576− go = bracket declare close $ \(Query name) ->
577− let q = toByteString (byteString "FETCH FORWARD "
578− <> intDec chunkSize
579− <> byteString " FROM "
580− <> byteString name
581− )
582− loop a = do
583− result <- exec conn q
584− status <- PQ.resultStatus result
585− case status of
586− PQ.TuplesOk -> do
587− nrows <- PQ.ntuples result
588− ncols <- PQ.nfields result
589− if nrows > 0
590− then do
591− let inner a row = do
592− x <- getRowWith parser row ncols conn result
593− f a x
594− foldM' inner a 0 (nrows - 1) >>= loop
595− else return a
596− _ -> throwResultError "fold" result status
597− in loop a0
561+ declare =
562+ declareCursor conn q
563+ fetch cursor a =
564+ foldForwardWithParser cursor parser chunkSize f a
565+
566+ go = bracket declare closeCursor $ \cursor ->
567+ let loop a = fetch cursor a >>=
568+ \r -> case r of
569+ Left a -> return a
570+ Right a -> loop a
571+ in loop a0
598572
599573-- FIXME: choose the Automatic chunkSize more intelligently
600574-- One possibility is to use the type of the results, although this
@@ -644,76 +618,6 @@ forEachWith_ :: RowParser r
644618forEachWith_ parser conn template = foldWith_ parser conn template () . const
645619{-# INLINE forEachWith_ #-}
646620
647−forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a]
648−forM' lo hi m = loop hi []
649− where
650− loop !n !as
651− | n < lo = return as
652− | otherwise = do
653− a <- m n
654− loop (n-1) (a:as)
655−{-# INLINE forM' #-}
656−
657−foldM' :: (Ord n, Num n) => (a -> n -> IO a) -> a -> n -> n -> IO a
658−foldM' f a lo hi = loop a lo
659− where
660− loop a !n
661− | n > hi = return a
662− | otherwise = do
663− a' <- f a n
664− loop a' (n+1)
665−{-# INLINE foldM' #-}
666−
667−finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r]
668−finishQueryWith parser conn q result = do
669− status <- PQ.resultStatus result
670− case status of
671− PQ.EmptyQuery ->
672− throwIO $ QueryError "query: Empty query" q
673− PQ.CommandOk ->
674− throwIO $ QueryError "query resulted in a command response" q
675− PQ.TuplesOk -> do
676− nrows <- PQ.ntuples result
677− ncols <- PQ.nfields result
678− forM' 0 (nrows-1) $ \row ->
679− getRowWith parser row ncols conn result
680− PQ.CopyOut ->
681− throwIO $ QueryError "query: COPY TO is not supported" q
682− PQ.CopyIn ->
683− throwIO $ QueryError "query: COPY FROM is not supported" q
684− PQ.BadResponse -> throwResultError "query" result status
685− PQ.NonfatalError -> throwResultError "query" result status
686− PQ.FatalError -> throwResultError "query" result status
687−
688−getRowWith :: RowParser r -> PQ.Row -> PQ.Column -> Connection -> PQ.Result -> IO r
689−getRowWith parser row ncols conn result = do
690− let rw = Row row result
691− let unCol (PQ.Col x) = fromIntegral x :: Int
692− okvc <- runConversion (runStateT (runReaderT (unRP parser) rw) 0) conn
693− case okvc of
694− Ok (val,col) | col == ncols -> return val
695− | otherwise -> do
696− vals <- forM' 0 (ncols-1) $ \c -> do
697− tinfo <- getTypeInfo conn =<< PQ.ftype result c
698− v <- PQ.getvalue result row c
699− return ( tinfo
700− , fmap ellipsis v )
701− throw (ConversionFailed
702− (show (unCol ncols) ++ " values: " ++ show vals)
703− Nothing
704− ""
705− (show (unCol col) ++ " slots in target type")
706− "mismatch between number of columns to \
707− \convert and number in target type")
708− Errors [] -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error"
709− Errors [x] -> throwIO x
710− Errors xs -> throwIO $ ManyErrors xs
711−
712−ellipsis :: ByteString -> ByteString
713−ellipsis bs
714− | B.length bs > 15 = B.take 10 bs `B.append` "[...]"
715− | otherwise = bs
716−
717621
718622-- $use
719623--