git.iko.soy/typeable/postgresql-simple
on master help sign in
Merge pull request #213 from BardurArantsson/wip-add-cursor
f92ff66Leon P Smith
.gitignore+1
compare with master
unifiedsplit
@@ -11,3 +11,4 @@ dist/
11.cabal-sandbox/
11.cabal-sandbox/
12.stack-work/
12.stack-work/
13cabal.sandbox.config
13cabal.sandbox.config
14+/dist-newstyle
cabal.projectnew file+1
@@ -0,0 +1 @@
1+packages: .
postgresql-simple.cabal+2
@@ -24,6 +24,7 @@ Library
24 Database.PostgreSQL.Simple
24 Database.PostgreSQL.Simple
25 Database.PostgreSQL.Simple.Arrays
25 Database.PostgreSQL.Simple.Arrays
26 Database.PostgreSQL.Simple.Copy
26 Database.PostgreSQL.Simple.Copy
27+ Database.PostgreSQL.Simple.Cursor
27 Database.PostgreSQL.Simple.FromField
28 Database.PostgreSQL.Simple.FromField
28 Database.PostgreSQL.Simple.FromRow
29 Database.PostgreSQL.Simple.FromRow
29 Database.PostgreSQL.Simple.LargeObjects
30 Database.PostgreSQL.Simple.LargeObjects
@@ -49,6 +50,7 @@ Library
49 Other-modules:
50 Other-modules:
50 Database.PostgreSQL.Simple.Compat
51 Database.PostgreSQL.Simple.Compat
51 Database.PostgreSQL.Simple.HStore.Implementation
52 Database.PostgreSQL.Simple.HStore.Implementation
53+ Database.PostgreSQL.Simple.Internal.PQResultUtils
52 Database.PostgreSQL.Simple.Time.Implementation
54 Database.PostgreSQL.Simple.Time.Implementation
53 Database.PostgreSQL.Simple.Time.Internal.Parser
55 Database.PostgreSQL.Simple.Time.Internal.Parser
54 Database.PostgreSQL.Simple.Time.Internal.Printer
56 Database.PostgreSQL.Simple.Time.Internal.Printer
src/Database/PostgreSQL/Simple.hs+15−111
@@ -118,30 +118,26 @@ module Database.PostgreSQL.Simple
118 , formatQuery
118 , formatQuery
119 ) where
119 ) where
120
120
121−import Data.ByteString.Builder
121+import Data.ByteString.Builder (Builder, byteString, char8)
122− ( Builder, byteString, char8, intDec )
123import Control.Applicative ((<$>))
122import Control.Applicative ((<$>))
124import Control.Exception as E
123import Control.Exception as E
125−import Control.Monad (unless)
126import Data.ByteString (ByteString)
124import Data.ByteString (ByteString)
127import Data.Int (Int64)
125import Data.Int (Int64)
128import Data.List (intersperse)
126import Data.List (intersperse)
129import Data.Monoid (mconcat)
127import Data.Monoid (mconcat)
130−import Database.PostgreSQL.Simple.Compat ( (<>), toByteString )
128+import Database.PostgreSQL.Simple.Compat ((<>), toByteString)
129+import Database.PostgreSQL.Simple.Cursor
131import Database.PostgreSQL.Simple.FromField (ResultError(..))
130import Database.PostgreSQL.Simple.FromField (ResultError(..))
132import Database.PostgreSQL.Simple.FromRow (FromRow(..))
131import Database.PostgreSQL.Simple.FromRow (FromRow(..))
133−import Database.PostgreSQL.Simple.Ok
134import Database.PostgreSQL.Simple.ToField (Action(..))
132import Database.PostgreSQL.Simple.ToField (Action(..))
135import Database.PostgreSQL.Simple.ToRow (ToRow(..))
133import Database.PostgreSQL.Simple.ToRow (ToRow(..))
136import Database.PostgreSQL.Simple.Types
134import Database.PostgreSQL.Simple.Types
137 ( Binary(..), In(..), Only(..), Query(..), (:.)(..) )
135 ( Binary(..), In(..), Only(..), Query(..), (:.)(..) )
138import Database.PostgreSQL.Simple.Internal as Base
136import Database.PostgreSQL.Simple.Internal as Base
137+import Database.PostgreSQL.Simple.Internal.PQResultUtils
139import Database.PostgreSQL.Simple.Transaction
138import Database.PostgreSQL.Simple.Transaction
140−import Database.PostgreSQL.Simple.TypeInfo
141import qualified Database.PostgreSQL.LibPQ as PQ
139import qualified Database.PostgreSQL.LibPQ as PQ
142import qualified Data.ByteString.Char8 as B
140import qualified Data.ByteString.Char8 as B
143−import Control.Monad.Trans.Reader
144−import Control.Monad.Trans.State.Strict
145
141
146
142
147-- | Format a query string.
143-- | Format a query string.
@@ -562,39 +558,17 @@ doFold FoldOptions{..} parser conn _template q a0 f = do
562 PQ.TransUnknown -> fail "foldWithOpts FIXME: PQ.TransUnknown"
558 PQ.TransUnknown -> fail "foldWithOpts FIXME: PQ.TransUnknown"
563 -- Not sure what this means.
559 -- Not sure what this means.
564 where
560 where
565− declare = do
561+ declare =
566− name <- newTempName conn
562+ declareCursor conn q
567− _ <- execute_ conn $ mconcat
563+ fetch cursor a =
568− [ "DECLARE ", name, " NO SCROLL CURSOR FOR ", q ]
564+ foldForwardWithParser cursor parser chunkSize f a
569− return name
565+
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) ->
566+ go = bracket declare closeCursor $ \cursor ->
577− let q = toByteString (byteString "FETCH FORWARD "
567+ let loop a = fetch cursor a >>=
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
568+ \r -> case r of
586− PQ.TuplesOk -> do
569+ Left a -> return a
587− nrows <- PQ.ntuples result
570+ Right a -> loop a
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
571+ in loop a0
598
572
599-- FIXME: choose the Automatic chunkSize more intelligently
573-- FIXME: choose the Automatic chunkSize more intelligently
600-- One possibility is to use the type of the results, although this
574-- One possibility is to use the type of the results, although this
@@ -644,76 +618,6 @@ forEachWith_ :: RowParser r
644forEachWith_ parser conn template = foldWith_ parser conn template () . const
618forEachWith_ parser conn template = foldWith_ parser conn template () . const
645{-# INLINE forEachWith_ #-}
619{-# INLINE forEachWith_ #-}
646
620
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−
717
621
718-- $use
622-- $use
719--
623--
src/Database/PostgreSQL/Simple/Copy.hs+5−2
@@ -75,15 +75,18 @@ doCopy :: B.ByteString -> Connection -> Query -> B.ByteString -> IO ()
75doCopy funcName conn template q = do
75doCopy funcName conn template q = do
76 result <- exec conn q
76 result <- exec conn q
77 status <- PQ.resultStatus result
77 status <- PQ.resultStatus result
78− let err = throwIO $ QueryError
78+ let errMsg msg = throwIO $ QueryError
79− (B.unpack funcName ++ " " ++ show status)
79+ (B.unpack funcName ++ " " ++ msg)
80 template
80 template
81+ let err = errMsg $ show status
81 case status of
82 case status of
82 PQ.EmptyQuery -> err
83 PQ.EmptyQuery -> err
83 PQ.CommandOk -> err
84 PQ.CommandOk -> err
84 PQ.TuplesOk -> err
85 PQ.TuplesOk -> err
85 PQ.CopyOut -> return ()
86 PQ.CopyOut -> return ()
86 PQ.CopyIn -> return ()
87 PQ.CopyIn -> return ()
88+ PQ.CopyBoth -> errMsg "COPY BOTH is not supported"
89+ PQ.SingleTuple -> errMsg "single-row mode is not supported"
87 PQ.BadResponse -> throwResultError funcName result status
90 PQ.BadResponse -> throwResultError funcName result status
88 PQ.NonfatalError -> throwResultError funcName result status
91 PQ.NonfatalError -> throwResultError funcName result status
89 PQ.FatalError -> throwResultError funcName result status
92 PQ.FatalError -> throwResultError funcName result status
src/Database/PostgreSQL/Simple/Cursor.hsnew file+99
@@ -0,0 +1,99 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+------------------------------------------------------------------------------
4+-- |
5+-- Module: Database.PostgreSQL.Simple.Cursor
6+-- Copyright: (c) 2011 MailRank, Inc.
7+-- (c) 2011-2012 Leon P Smith
8+-- (c) 2017 Bardur Arantsson
9+-- License: BSD3
10+-- Maintainer: Leon P Smith <leon@melding-monads.com>
11+--
12+------------------------------------------------------------------------------
13+
14+module Database.PostgreSQL.Simple.Cursor
15+ (
16+ -- * Types
17+ Cursor
18+ -- * Cursor management
19+ , declareCursor
20+ , closeCursor
21+ -- * Folding over rows from a cursor
22+ , foldForward
23+ , foldForwardWithParser
24+ ) where
25+
26+import Data.ByteString.Builder (intDec)
27+import Control.Applicative ((<$>))
28+import Control.Exception as E
29+import Control.Monad (unless, void)
30+import Data.Monoid (mconcat)
31+import Database.PostgreSQL.Simple.Compat ((<>), toByteString)
32+import Database.PostgreSQL.Simple.FromRow (FromRow(..))
33+import Database.PostgreSQL.Simple.Types (Query(..))
34+import Database.PostgreSQL.Simple.Internal as Base
35+import Database.PostgreSQL.Simple.Internal.PQResultUtils
36+import Database.PostgreSQL.Simple.Transaction
37+import qualified Database.PostgreSQL.LibPQ as PQ
38+
39+-- | Cursor within a transaction.
40+data Cursor = Cursor !Query !Connection
41+
42+-- | Declare a temporary cursor. The cursor is given a
43+-- unique name for the given connection.
44+declareCursor :: Connection -> Query -> IO Cursor
45+declareCursor conn q = do
46+ name <- newTempName conn
47+ void $ execute_ conn $ mconcat ["DECLARE ", name, " NO SCROLL CURSOR FOR ", q]
48+ return $ Cursor name conn
49+
50+-- | Close the given cursor.
51+closeCursor :: Cursor -> IO ()
52+closeCursor (Cursor name conn) =
53+ (void $ execute_ conn ("CLOSE " <> name)) `E.catch` \ex ->
54+ -- Don't throw exception if CLOSE failed because the transaction is
55+ -- aborted. Otherwise, it will throw away the original error.
56+ unless (isFailedTransactionError ex) $ throwIO ex
57+
58+-- | Fold over a chunk of rows from the given cursor, calling the
59+-- supplied fold-like function on each row as it is received. In case
60+-- the cursor is exhausted, a 'Left' value is returned, otherwise a
61+-- 'Right' value is returned.
62+foldForwardWithParser :: Cursor -> RowParser r -> Int -> (a -> r -> IO a) -> a -> IO (Either a a)
63+foldForwardWithParser (Cursor name conn) parser chunkSize f a0 = do
64+ let q = "FETCH FORWARD "
65+ <> (toByteString $ intDec chunkSize)
66+ <> " FROM "
67+ <> fromQuery name
68+ result <- exec conn q
69+ status <- PQ.resultStatus result
70+ case status of
71+ PQ.TuplesOk -> do
72+ nrows <- PQ.ntuples result
73+ ncols <- PQ.nfields result
74+ if nrows > 0
75+ then do
76+ let inner a row = do
77+ x <- getRowWith parser row ncols conn result
78+ f a x
79+ Right <$> foldM' inner a0 0 (nrows - 1)
80+ else
81+ return $ Left a0
82+ _ -> throwResultError "foldForwardWithParser" result status
83+
84+-- | Fold over a chunk of rows, calling the supplied fold-like function
85+-- on each row as it is received. In case the cursor is exhausted,
86+-- a 'Left' value is returned, otherwise a 'Right' value is returned.
87+foldForward :: FromRow r => Cursor -> Int -> (a -> r -> IO a) -> a -> IO (Either a a)
88+foldForward cursor = foldForwardWithParser cursor fromRow
89+
90+
91+foldM' :: (Ord n, Num n) => (a -> n -> IO a) -> a -> n -> n -> IO a
92+foldM' f a lo hi = loop a lo
93+ where
94+ loop a !n
95+ | n > hi = return a
96+ | otherwise = do
97+ a' <- f a n
98+ loop a' (n+1)
99+{-# INLINE foldM' #-}
src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hsnew file+89
@@ -0,0 +1,89 @@
1+
2+------------------------------------------------------------------------------
3+-- |
4+-- Module: Database.PostgreSQL.Simple.Internal.PQResultUtils
5+-- Copyright: (c) 2011 MailRank, Inc.
6+-- (c) 2011-2012 Leon P Smith
7+-- License: BSD3
8+-- Maintainer: Leon P Smith <leon@melding-monads.com>
9+-- Stability: experimental
10+--
11+------------------------------------------------------------------------------
12+
13+
14+module Database.PostgreSQL.Simple.Internal.PQResultUtils
15+ ( finishQueryWith
16+ , getRowWith
17+ ) where
18+
19+import Control.Exception as E
20+import Data.ByteString (ByteString)
21+import Database.PostgreSQL.Simple.FromField (ResultError(..))
22+import Database.PostgreSQL.Simple.Ok
23+import Database.PostgreSQL.Simple.Types (Query(..))
24+import Database.PostgreSQL.Simple.Internal as Base
25+import Database.PostgreSQL.Simple.TypeInfo
26+import qualified Database.PostgreSQL.LibPQ as PQ
27+import qualified Data.ByteString.Char8 as B
28+import Control.Monad.Trans.Reader
29+import Control.Monad.Trans.State.Strict
30+
31+finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r]
32+finishQueryWith parser conn q result = do
33+ status <- PQ.resultStatus result
34+ case status of
35+ PQ.TuplesOk -> do
36+ nrows <- PQ.ntuples result
37+ ncols <- PQ.nfields result
38+ forM' 0 (nrows-1) $ \row ->
39+ getRowWith parser row ncols conn result
40+ PQ.EmptyQuery -> queryErr "query: Empty query"
41+ PQ.CommandOk -> queryErr "query resulted in a command response"
42+ PQ.CopyOut -> queryErr "query: COPY TO is not supported"
43+ PQ.CopyIn -> queryErr "query: COPY FROM is not supported"
44+ PQ.CopyBoth -> queryErr "query: COPY BOTH is not supported"
45+ PQ.SingleTuple -> queryErr "query: single-row mode is not supported"
46+ PQ.BadResponse -> throwResultError "query" result status
47+ PQ.NonfatalError -> throwResultError "query" result status
48+ PQ.FatalError -> throwResultError "query" result status
49+ where
50+ queryErr msg = throwIO $ QueryError msg q
51+
52+getRowWith :: RowParser r -> PQ.Row -> PQ.Column -> Connection -> PQ.Result -> IO r
53+getRowWith parser row ncols conn result = do
54+ let rw = Row row result
55+ let unCol (PQ.Col x) = fromIntegral x :: Int
56+ okvc <- runConversion (runStateT (runReaderT (unRP parser) rw) 0) conn
57+ case okvc of
58+ Ok (val,col) | col == ncols -> return val
59+ | otherwise -> do
60+ vals <- forM' 0 (ncols-1) $ \c -> do
61+ tinfo <- getTypeInfo conn =<< PQ.ftype result c
62+ v <- PQ.getvalue result row c
63+ return ( tinfo
64+ , fmap ellipsis v )
65+ throw (ConversionFailed
66+ (show (unCol ncols) ++ " values: " ++ show vals)
67+ Nothing
68+ ""
69+ (show (unCol col) ++ " slots in target type")
70+ "mismatch between number of columns to \
71+ \convert and number in target type")
72+ Errors [] -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error"
73+ Errors [x] -> throwIO x
74+ Errors xs -> throwIO $ ManyErrors xs
75+
76+ellipsis :: ByteString -> ByteString
77+ellipsis bs
78+ | B.length bs > 15 = B.take 10 bs `B.append` "[...]"
79+ | otherwise = bs
80+
81+forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a]
82+forM' lo hi m = loop hi []
83+ where
84+ loop !n !as
85+ | n < lo = return as
86+ | otherwise = do
87+ a <- m n
88+ loop (n-1) (a:as)
89+{-# INLINE forM' #-}