diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -27,3 +27,5 @@ Sam Rijs Janne Hellsten Timmy Tofu +Alexey Khudyakov +Timo von Holtz diff --git a/postgresql-simple.cabal b/postgresql-simple.cabal --- a/postgresql-simple.cabal +++ b/postgresql-simple.cabal @@ -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 diff --git a/src/Database/PostgreSQL/Simple.hs b/src/Database/PostgreSQL/Simple.hs --- a/src/Database/PostgreSQL/Simple.hs +++ b/src/Database/PostgreSQL/Simple.hs @@ -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 diff --git a/src/Database/PostgreSQL/Simple/Compat.hs b/src/Database/PostgreSQL/Simple/Compat.hs --- a/src/Database/PostgreSQL/Simple/Compat.hs +++ b/src/Database/PostgreSQL/Simple/Compat.hs @@ -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) diff --git a/src/Database/PostgreSQL/Simple/FromRow.hs b/src/Database/PostgreSQL/Simple/FromRow.hs --- a/src/Database/PostgreSQL/Simple/FromRow.hs +++ b/src/Database/PostgreSQL/Simple/FromRow.hs @@ -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 diff --git a/src/Database/PostgreSQL/Simple/ToRow.hs b/src/Database/PostgreSQL/Simple/ToRow.hs --- a/src/Database/PostgreSQL/Simple/ToRow.hs +++ b/src/Database/PostgreSQL/Simple/ToRow.hs @@ -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 _ = [] diff --git a/src/Database/PostgreSQL/Simple/ToRow.hs-boot b/src/Database/PostgreSQL/Simple/ToRow.hs-boot --- a/src/Database/PostgreSQL/Simple/ToRow.hs-boot +++ b/src/Database/PostgreSQL/Simple/ToRow.hs-boot @@ -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) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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