postgresql-simple 0.5.0.1 → 0.5.1.0
raw patch · 8 files changed
+185/−44 lines, 8 filesdep +ghc-primdep ~bytestring
Dependencies added: ghc-prim
Dependency ranges changed: bytestring
Files
- CONTRIBUTORS +2/−0
- postgresql-simple.cabal +11/−3
- src/Database/PostgreSQL/Simple.hs +61/−38
- src/Database/PostgreSQL/Simple/Compat.hs +9/−0
- src/Database/PostgreSQL/Simple/FromRow.hs +27/−2
- src/Database/PostgreSQL/Simple/ToRow.hs +21/−0
- src/Database/PostgreSQL/Simple/ToRow.hs-boot +10/−1
- test/Main.hs +44/−0
CONTRIBUTORS view
@@ -27,3 +27,5 @@ Sam Rijs <srijs@airpost.net> Janne Hellsten <jjhellst@gmail.com> Timmy Tofu <timmytofu@users.noreply.github.com>+Alexey Khudyakov <alexey.skladnoy@gmail.com>+Timo von Holtz <tvh@anchor.com.au>
postgresql-simple.cabal view
@@ -1,5 +1,5 @@ Name: postgresql-simple-Version: 0.5.0.1+Version: 0.5.1.0 Synopsis: Mid-Level PostgreSQL client library Description: Mid-Level PostgreSQL client library, forked from mysql-simple.@@ -56,7 +56,7 @@ Build-depends: aeson >= 0.6, attoparsec >= 0.10.3,- base < 5,+ base >= 4.4 && < 5, bytestring >= 0.9, bytestring-builder, case-insensitive,@@ -71,6 +71,10 @@ scientific, vector + if !impl(ghc >= 7.6)+ Build-depends:+ ghc-prim+ extensions: DoAndIfThenElse, OverloadedStrings, BangPatterns, ViewPatterns TypeOperators @@ -83,7 +87,7 @@ source-repository this type: git location: http://github.com/lpsmith/postgresql-simple- tag: v0.5.0.1+ tag: v0.5.1.0 test-suite test type: exitcode-stdio-1.0@@ -116,3 +120,7 @@ , text , time , vector++ if !impl(ghc >= 7.6)+ build-depends:+ ghc-prim
src/Database/PostgreSQL/Simple.hs view
@@ -122,7 +122,7 @@ ( Builder, byteString, char8, intDec ) import Control.Applicative ((<$>)) import Control.Exception as E-import Control.Monad (foldM)+import Control.Monad (unless) import Data.ByteString (ByteString) import Data.Int (Int64) import Data.List (intersperse)@@ -508,7 +508,7 @@ -> IO a fold_ = foldWithOptions_ defaultFoldOptions --- | A version of 'foldWith' taking a parser as an argument+-- | A version of 'fold_' taking a parser as an argument foldWith_ :: RowParser r -> Connection -> Query@@ -567,22 +567,33 @@ _ <- execute_ conn $ mconcat [ "DECLARE ", name, " NO SCROLL CURSOR FOR ", q ] return name- fetch (Query name) = queryWith_ parser conn $- Query (toByteString (byteString "FETCH FORWARD "- <> intDec chunkSize- <> byteString " FROM "- <> byteString 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.- if isFailedTransactionError ex then return () else throwIO ex+ unless (isFailedTransactionError ex) $ throwIO ex - go = bracket declare close $ \name ->- let loop a = do- rs <- fetch name- if null rs then return a else foldM f a rs >>= loop+ 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 -- FIXME: choose the Automatic chunkSize more intelligently@@ -641,9 +652,17 @@ | otherwise = do a <- m n loop (n-1) (a:as)+{-# INLINE forM' #-} -finishQuery :: FromRow r => Connection -> Query -> PQ.Result -> IO [r]-finishQuery = finishQueryWith 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' #-} finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r] finishQueryWith parser conn q result = do@@ -651,33 +670,13 @@ case status of PQ.EmptyQuery -> throwIO $ QueryError "query: Empty query" q- PQ.CommandOk -> do+ PQ.CommandOk -> throwIO $ QueryError "query resulted in a command response" q PQ.TuplesOk -> do- let unCol (PQ.Col x) = fromIntegral x :: Int nrows <- PQ.ntuples result ncols <- PQ.nfields result- forM' 0 (nrows-1) $ \row -> do- let rw = Row row result- 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+ forM' 0 (nrows-1) $ \row ->+ getRowWith parser row ncols conn result PQ.CopyOut -> throwIO $ QueryError "query: COPY TO is not supported" q PQ.CopyIn ->@@ -685,6 +684,30 @@ 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
src/Database/PostgreSQL/Simple/Compat.hs view
@@ -14,7 +14,12 @@ import qualified Control.Exception as E import Data.Monoid import Data.ByteString (ByteString)+#if MIN_VERSION_bytestring(0,10,0) import Data.ByteString.Lazy (toStrict)+#else+import qualified Data.ByteString as B+import Data.ByteString.Lazy (toChunks)+#endif import Data.ByteString.Builder (Builder, toLazyByteString) #if MIN_VERSION_scientific(0,3,0)@@ -64,7 +69,11 @@ #endif toByteString :: Builder -> ByteString+#if MIN_VERSION_bytestring(0,10,0) toByteString x = toStrict (toLazyByteString x)+#else+toByteString x = B.concat (toChunks (toLazyByteString x))+#endif #if MIN_VERSION_base(4,7,0)
src/Database/PostgreSQL/Simple/FromRow.hs view
@@ -1,5 +1,7 @@-{-# LANGUAGE RecordWildCards, FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards, FlexibleInstances, DefaultSignatures #-} + ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.FromRow@@ -27,7 +29,7 @@ ) where import Prelude hiding (null)-import Control.Applicative (Applicative(..), (<$>), (<|>), (*>))+import Control.Applicative (Applicative(..), (<$>), (<|>), (*>), liftA2) import Control.Monad (replicateM, replicateM_) import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader@@ -45,6 +47,9 @@ import Database.PostgreSQL.Simple.Types ((:.)(..), Null) import Database.PostgreSQL.Simple.TypeInfo +import GHC.Generics++ -- | 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. --@@ -68,6 +73,8 @@ class FromRow a where fromRow :: RowParser a+ default fromRow :: (Generic a, GFromRow (Rep a)) => RowParser a+ fromRow = to <$> gfromRow getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString getvalue result row col = unsafeDupablePerformIO (PQ.getvalue' result row col)@@ -252,3 +259,21 @@ instance (FromRow a, FromRow b) => FromRow (a :. b) where fromRow = (:.) <$> fromRow <*> fromRow++++-- Type class for default implementation of FromRow using generics+class GFromRow f where+ gfromRow :: RowParser (f p)++instance GFromRow f => GFromRow (M1 c i f) where+ gfromRow = M1 <$> gfromRow++instance (GFromRow f, GFromRow g) => GFromRow (f :*: g) where+ gfromRow = liftA2 (:*:) gfromRow gfromRow++instance (FromField a) => GFromRow (K1 R a) where+ gfromRow = K1 <$> field++instance GFromRow U1 where+ gfromRow = pure U1
src/Database/PostgreSQL/Simple/ToRow.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.ToRow@@ -22,6 +23,7 @@ import Database.PostgreSQL.Simple.ToField (Action(..), ToField(..)) import Database.PostgreSQL.Simple.Types (Only(..), (:.)(..))+import GHC.Generics -- | A collection type that can be turned into a list of rendering -- 'Action's.@@ -30,6 +32,8 @@ -- to perform conversion of each element of the collection. class ToRow a where toRow :: a -> [Action]+ default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action]+ toRow = gtoRow . from -- ^ ToField a collection of values. instance ToRow () where@@ -90,3 +94,20 @@ instance (ToRow a, ToRow b) => ToRow (a :. b) where toRow (a :. b) = toRow a ++ toRow b+++-- Type class for default implementation of ToRow using generics+class GToRow f where+ gtoRow :: f p -> [Action]++instance GToRow f => GToRow (M1 c i f) where+ gtoRow (M1 x) = gtoRow x++instance (GToRow f, GToRow g) => GToRow (f :*: g) where+ gtoRow (f :*: g) = gtoRow f ++ gtoRow g++instance (ToField a) => GToRow (K1 R a) where+ gtoRow (K1 a) = [toField a]++instance GToRow U1 where+ gtoRow _ = []
src/Database/PostgreSQL/Simple/ToRow.hs-boot view
@@ -1,9 +1,18 @@-module Database.PostgreSQL.Simple.ToRow where+{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-}+module Database.PostgreSQL.Simple.ToRow (+ ToRow(..)+ ) where import Database.PostgreSQL.Simple.Types import {-# SOURCE #-} Database.PostgreSQL.Simple.ToField+import GHC.Generics class ToRow a where toRow :: a -> [Action]+ default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action]+ toRow = gtoRow . from++class GToRow f where+ gtoRow :: f p -> [Action] instance ToField a => ToRow (Only a)
test/Main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -23,6 +24,7 @@ import System.IO import qualified Data.Vector as V import Data.Aeson+import GHC.Generics (Generic) import Notify import Serializable@@ -44,6 +46,9 @@ , TestLabel "Values" . testValues , TestLabel "Copy" . testCopy , TestLabel "Double" . testDouble+ , TestLabel "1-ary generic" . testGeneric1+ , TestLabel "2-ary generic" . testGeneric2+ , TestLabel "3-ary generic" . testGeneric3 ] testBytea :: TestEnv -> Test@@ -319,6 +324,45 @@ [Only (x :: Double)] <- query_ conn "SELECT '-Infinity'::float8" x @?= (-1 / 0) ++testGeneric1 :: TestEnv -> Test+testGeneric1 TestEnv{..} = TestCase $ do+ roundTrip conn (Gen1 123)+ where+ roundTrip conn x0 = do+ r <- query conn "SELECT ?::int" (x0 :: Gen1)+ r @?= [x0]++testGeneric2 :: TestEnv -> Test+testGeneric2 TestEnv{..} = TestCase $ do+ roundTrip conn (Gen2 123 "asdf")+ where+ roundTrip conn x0 = do+ r <- query conn "SELECT ?::int, ?::text" x0+ r @?= [x0]++testGeneric3 :: TestEnv -> Test+testGeneric3 TestEnv{..} = TestCase $ do+ roundTrip conn (Gen3 123 "asdf" True)+ where+ roundTrip conn x0 = do+ r <- query conn "SELECT ?::int, ?::text, ?::bool" x0+ r @?= [x0]++data Gen1 = Gen1 Int+ deriving (Show,Eq,Generic)+instance FromRow Gen1+instance ToRow Gen1++data Gen2 = Gen2 Int Text+ deriving (Show,Eq,Generic)+instance FromRow Gen2+instance ToRow Gen2++data Gen3 = Gen3 Int Text Bool+ deriving (Show,Eq,Generic)+instance FromRow Gen3+instance ToRow Gen3 data TestException = TestException