postgresql-simple 0.5.4.0 → 0.7.0.1
raw patch · 38 files changed
Files
- CHANGES.md +138/−5
- bench/Select.hs +32/−0
- postgresql-simple.cabal +137/−116
- src/Database/PostgreSQL/Simple.hs +23/−10
- src/Database/PostgreSQL/Simple/Arrays.hs +2/−2
- src/Database/PostgreSQL/Simple/Compat.hs +0/−53
- src/Database/PostgreSQL/Simple/Copy.hs +28/−6
- src/Database/PostgreSQL/Simple/Cursor.hs +5/−5
- src/Database/PostgreSQL/Simple/Errors.hs +4/−3
- src/Database/PostgreSQL/Simple/FromField.hs +124/−70
- src/Database/PostgreSQL/Simple/FromRow.hs +209/−2
- src/Database/PostgreSQL/Simple/HStore/Implementation.hs +3/−9
- src/Database/PostgreSQL/Simple/Internal.hs +67/−16
- src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs +43/−12
- src/Database/PostgreSQL/Simple/Newtypes.hs +49/−0
- src/Database/PostgreSQL/Simple/Notification.hs +0/−17
- src/Database/PostgreSQL/Simple/Ok.hs +7/−4
- src/Database/PostgreSQL/Simple/Range.hs +14/−10
- src/Database/PostgreSQL/Simple/SqlQQ.hs +10/−9
- src/Database/PostgreSQL/Simple/Time.hs +2/−0
- src/Database/PostgreSQL/Simple/Time/Implementation.hs +11/−1
- src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs +12/−3
- src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs +15/−3
- src/Database/PostgreSQL/Simple/ToField.hs +33/−11
- src/Database/PostgreSQL/Simple/ToRow.hs +106/−0
- src/Database/PostgreSQL/Simple/Transaction.hs +17/−13
- src/Database/PostgreSQL/Simple/TypeInfo.hs +9/−9
- src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs +9/−3
- src/Database/PostgreSQL/Simple/TypeInfo/Static.hs +684/−114
- src/Database/PostgreSQL/Simple/Types.hs +1/−24
- src/Database/PostgreSQL/Simple/Vector.hs +45/−0
- src/Database/PostgreSQL/Simple/Vector/Unboxed.hs +44/−0
- test/Exception.hs +70/−0
- test/Inspection.hs +79/−0
- test/Interval.hs +176/−0
- test/Main.hs +194/−31
- test/Time.hs +1/−1
- test/results/malformed-input.expected +1/−1
CHANGES.md view
@@ -1,3 +1,136 @@+### Version 0.7.0.0 (2023-07-31)++ * Remove Eq Null instance. (Future `base` may break it, we remove it profilacticly).+ * Use `postgresql-libpq >=0.10.0.0`. It includes critical fixes,+ by using `postgresql-simple >=0.7` you won't get older `postgresql-libpq`.+ * Drop support for GHC prior 8.6+ * Added a class for `postgresql-simple` exceptions: `SomePostgreSqlException`.+ This allows to catch all `postgresql-simple` exceptions at once.+ (c.f. `AsyncException` in `base).++### Version 0.6.5.1 (2023-07-09)++ * Support `aeson-2.2.0.0`++### Version 0.6.5 (2022-10-30)++ * Add `withConnect`++### Version 0.6.4 (2021-01-06)++ * Add foldCopyData helper function+ Thanks to Sebastián Estrella for the implementation+ https://github.com/haskellari/postgresql-simple/pull/56+ * Implement support for postgresql 'interval' type+ Thanks to Andre Marques Lee for the implementation+ https://github.com/haskellari/postgresql-simple/pull/60+ * Depend on `time-compat` to provide uniform `time` related interface.++### Version 0.6.3 (2020-11-15)++ * Add `fromFieldJSONByteString`+ Thanks to tomjaguarpaw for the implementation+ https://github.com/haskellari/postgresql-simple/pull/47+ * Add `attoFieldParser`+ Thanks to Victor Nawothnig for the implementation+ https://github.com/haskellari/postgresql-simple/pull/45+ * Add `Identity` and `Const` instance+ Thanks to Cary Robbins for the implementation+ https://github.com/haskellari/postgresql-simple/pull/46+ * Add `withTransactionModeRetry'`, a variant of `withTransactionModeRetry`+ for all exception types.+ Thanks to Elliot Cameron for the implementation+ https://github.com/haskellari/postgresql-simple/pull/42+ * Fix spurious aborts when retrying transactions+ Thanks to Elliot Cameron for the implementation+ https://github.com/haskellari/postgresql-simple/pull/34+ * Add `Database.PostgreSQL.Simple.Newtypes` module+ with `Aeson` newtype.+ https://github.com/haskellari/postgresql-simple/pull/55++### Version 0.6.2 (2019-04-26)+ + * Define `MonadFail Ok`.++### Version 0.6.1 (2019-03-04)++ * Escape double '??' to a literal '?+ Thanks to Felix Paulusma for the implementation.+ https://github.com/phadej/postgresql-simple/pull/5++ * Mention GHC Generics support in the documentation.+ Thanks to Gabriel Gonzalez for the implementation.+ https://github.com/phadej/postgresql-simple/pull/6++ * Better error message for "Query resulted in a command response+ Thanks to Max Amanshauser for the implementation.+ https://github.com/phadej/postgresql-simple/pull/7++ * fromJSONField: Include JSONPath on JSON parse errors+ Thanks to Simon Hengel for the implementation.+ https://github.com/phadej/postgresql-simple/pull/2++ * No TH in implementation+ https://github.com/phadej/postgresql-simple/pull/4++### Version 0.6 (2018-10-16)++ * *Breaking change*: Use `Only` package's `Only` for a common 1-tuple.++ Consider a downstream library depending already both on+ `Only` and `postgresql-simple` package. This library my define+ a `MyClass` with instances for `Only.Only` and `PostgreSQL.Only`.+ As now these types are the same, a library would break.+ Therefore I consider "merging" types a breaking change.++ There are two ways for adopting this change in that scenario:++ - Either CPP-guard `PostgreSQL.Only` instance with++ ```haskell+ #if !MIN_VERSION_postgresql_simple(0,6,0)+ instance MyClass (PostgreSQL.Only a) where ...+ #endif+ ```++ - or simply remove it and add `postgresql-simple >=0.6` lower bound,+ making sure that there's only single `Only`.++ * Add `ToField` instances for case-insensitive strict and lazy text.+ Thanks to Max Tagher for the implementation.+ https://github.com/lpsmith/postgresql-simple/pull/232++ * Add support to CockroachDB.+ Thanks to Georte Steel.+ https://github.com/lpsmith/postgresql-simple/pull/245++ * Add Generic ConnectInfo instance+ Thanks to Dmitry Dzhus.+ https://github.com/lpsmith/postgresql-simple/pull/235++ * Add `fromFieldRange :: Typeable a => FieldParser a -> FieldParser (PGRange a)`+ https://github.com/lpsmith/postgresql-simple/pull/221++ * Add `fromFieldJSONByteString :: FieldParser ByteString`+ https://github.com/lpsmith/postgresql-simple/pull/222/files++ * Fix off-by-one error in year builder.+ Thanks to Nathan Ferris Hunter.+ https://github.com/lpsmith/postgresql-simple/pull/230++ * Extend ToRow and FromRow to tuples of size 18+ Thanks to Bardur Arantsson.+ https://github.com/lpsmith/postgresql-simple/pull/229++ * Add `Vector` and `Vector.Unboxed` `query` variants.+ These are more memory efficient+ (especially, if you anyway will convert to some vector)+ https://github.com/phadej/1++ * Documentation improvements+ https://github.com/lpsmith/postgresql-simple/pull/227+ https://github.com/lpsmith/postgresql-simple/pull/236+ ### Version 0.5.4.0 (2018-05-23) * Support GHC-8.4 (Semigroup/Monoid) @@ -138,7 +271,7 @@ support UTF8 except for Mule Internal Code, the Multilingual Extensions for Emacs. An exception should be raised upon connecting to a database by the backend if the backend cannot- accomodate this requirement.+ accommodate this requirement. * Added `Eq` and `Typeable` instances for `Connection`. @@ -258,7 +391,7 @@ * De-emphasized connect and ConnectInfo in favor of connectPostgreSQL. ### Version 0.4.2.2 (2014-05-15)- * Fixed compatibility with scientific-0.3.*, thanks to Adam Bergmark+ * Fixed compatibility with scientific-0.3.\*, thanks to Adam Bergmark * Improved documentation of the FromField module, as well as the fold, foldWithOptions, executeMany, and returning operators.@@ -276,7 +409,7 @@ * Changed the Identifier and QualifiedIdentifier to use Text in order to avoid encoding errors. Technically this requires a- major verson bump, but let's pretend 0.4.1.0 didn't happen.+ major version bump, but let's pretend 0.4.1.0 didn't happen. * Removed non-exhaustive cases in the ToField instance for Values, and tweaked error messages.@@ -436,7 +569,7 @@ * Added a brand new TypeInfo system that gives FromField instances convenient and efficient access to the pg_type metatable. This- replaced the older typename cache, and was neccesary to properly+ replaced the older typename cache, and was necessary to properly support postgres array types. Thanks to Bas van Dijk for his work on this feature. @@ -528,7 +661,7 @@ now the preferred way of dealing with `timestamp` (without time zone). * `Database.PostgreSQL.Simple.Time` is a new module that offers types- that accomodate PostgreSQL's infinities.+ that accommodate PostgreSQL's infinities. * All time-related `FromField`/`ToField` instances are now based on new, higher-speed parsers and printers instead of those provided by the
+ bench/Select.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Database.PostgreSQL.Simple+import qualified Database.PostgreSQL.Simple.Vector as V+import qualified Database.PostgreSQL.Simple.Vector.Unboxed as VU++import System.Environment (getArgs)+import Data.Foldable (Foldable, foldl')+import qualified Data.Vector.Unboxed as VU++main :: IO ()+main = do+ args <- getArgs+ conn <- connectPostgreSQL ""+ case args of+ ("vector":_) -> do+ result <- V.query_ conn "SELECT * FROM generate_series(1, 10000000);"+ print (process result)+ ("unboxed":_) -> do+ -- dummy column+ result <- VU.query_ conn "SELECT (NULL :: VOID), * FROM generate_series(1, 10000000);"+ print (process' result)+ _ -> do+ result <- query_ conn "SELECT * FROM generate_series(1, 10000000);"+ print (process result)++process :: Foldable f => f (Only Int) -> Int+process = foldl' (\x (Only y) -> max x y) 0++process' :: VU.Vector ((), Int) -> Int+process' = VU.foldl' (\x (_, y) -> max x y) 0
postgresql-simple.cabal view
@@ -1,154 +1,175 @@-Cabal-version: >= 1.10-Name: postgresql-simple-Version: 0.5.4.0+cabal-version: 1.12+name: postgresql-simple+version: 0.7.0.1+synopsis: Mid-Level PostgreSQL client library+description:+ Mid-Level PostgreSQL client library, forked from mysql-simple. -Synopsis: Mid-Level PostgreSQL client library-Description:- Mid-Level PostgreSQL client library, forked from mysql-simple.-License: BSD3-License-file: LICENSE-Author: Bryan O'Sullivan, Leon P Smith-Maintainer: Leon P Smith <leon@melding-monads.com>-Copyright: (c) 2011 MailRank, Inc.- (c) 2011-2015 Leon P Smith-Category: Database-Build-type: Simple+license: BSD3+license-file: LICENSE+author: Bryan O'Sullivan, Leon P Smith+maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>+copyright:+ (c) 2011 MailRank, Inc.+ (c) 2011-2018 Leon P Smith+ (c) 2018-2020 Oleg Grenrus +category: Database+build-type: Simple extra-source-files:- CONTRIBUTORS CHANGES.md+ CONTRIBUTORS test/results/malformed-input.expected test/results/unique-constraint-violation.expected tested-with:- GHC == 7.6.3- || == 7.8.4- || == 7.10.3- || == 8.0.2- || == 8.2.2- || == 8.4.2--Library- default-language: Haskell2010- hs-source-dirs: src- Exposed-modules:- 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- Database.PostgreSQL.Simple.HStore- Database.PostgreSQL.Simple.HStore.Internal- Database.PostgreSQL.Simple.Notification- Database.PostgreSQL.Simple.Ok- Database.PostgreSQL.Simple.Range- Database.PostgreSQL.Simple.SqlQQ- Database.PostgreSQL.Simple.Time- Database.PostgreSQL.Simple.Time.Internal- Database.PostgreSQL.Simple.ToField- Database.PostgreSQL.Simple.ToRow- Database.PostgreSQL.Simple.Transaction- Database.PostgreSQL.Simple.TypeInfo- Database.PostgreSQL.Simple.TypeInfo.Macro- Database.PostgreSQL.Simple.TypeInfo.Static- Database.PostgreSQL.Simple.Types- Database.PostgreSQL.Simple.Errors--- Other-modules:- Database.PostgreSQL.Simple.Internal+ GHC ==8.6.5+ || ==8.8.4+ || ==8.10.7+ || ==9.0.2+ || ==9.2.8+ || ==9.4.8+ || ==9.6.7+ || ==9.8.4+ || ==9.10.2+ || ==9.12.2 - 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- Database.PostgreSQL.Simple.TypeInfo.Types+library+ default-language: Haskell2010+ hs-source-dirs: src+ exposed-modules:+ Database.PostgreSQL.Simple+ Database.PostgreSQL.Simple.Arrays+ Database.PostgreSQL.Simple.Copy+ Database.PostgreSQL.Simple.Cursor+ Database.PostgreSQL.Simple.Errors+ Database.PostgreSQL.Simple.FromField+ Database.PostgreSQL.Simple.FromRow+ Database.PostgreSQL.Simple.HStore+ Database.PostgreSQL.Simple.HStore.Internal+ Database.PostgreSQL.Simple.Internal+ Database.PostgreSQL.Simple.LargeObjects+ Database.PostgreSQL.Simple.Newtypes+ Database.PostgreSQL.Simple.Notification+ Database.PostgreSQL.Simple.Ok+ Database.PostgreSQL.Simple.Range+ Database.PostgreSQL.Simple.SqlQQ+ Database.PostgreSQL.Simple.Time+ Database.PostgreSQL.Simple.Time.Internal+ Database.PostgreSQL.Simple.ToField+ Database.PostgreSQL.Simple.ToRow+ Database.PostgreSQL.Simple.Transaction+ Database.PostgreSQL.Simple.TypeInfo+ Database.PostgreSQL.Simple.TypeInfo.Macro+ Database.PostgreSQL.Simple.TypeInfo.Static+ Database.PostgreSQL.Simple.Types+ Database.PostgreSQL.Simple.Vector+ Database.PostgreSQL.Simple.Vector.Unboxed - Build-depends:- aeson >= 0.6,- attoparsec >= 0.10.3,- base >= 4.6 && < 5,- bytestring >= 0.9,- bytestring-builder,- case-insensitive,- containers,- hashable,- postgresql-libpq >= 0.9 && < 0.10,- template-haskell,- text >= 0.11.1,- time >= 1.1.4,- transformers,- uuid-types >= 1.0.0,- scientific,- vector+ -- Other-modules:+ 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+ Database.PostgreSQL.Simple.TypeInfo.Types - if !impl(ghc >= 8.0)- Build-depends:- semigroups >=0.18.2+ -- GHC bundled libs+ build-depends:+ base >=4.12.0.0 && <4.22+ , bytestring >=0.10.8.2 && <0.13+ , containers >=0.6.0.1 && <0.8+ , template-haskell >=2.14.0.0 && <2.24+ , text >=1.2.3.0 && <1.3 || >=2.0 && <2.2+ , time-compat >=1.9.5 && <1.12+ , transformers >=0.5.6.2 && <0.7 - if !impl(ghc >= 7.6)- Build-depends:- ghc-prim+ -- Other dependencies+ build-depends:+ aeson >=2.1.2.1 && <2.3+ , attoparsec >=0.14.4 && <0.15+ , case-insensitive >=1.2.1.0 && <1.3+ , hashable >=1.4.3.0 && <1.6+ , Only >=0.1 && <0.1.1+ , postgresql-libpq >=0.10.0.0 && <0.12+ , scientific >=0.3.7.0 && <0.4+ , uuid-types >=1.0.5 && <1.1+ , vector >=0.13.0.0 && <0.14 default-extensions:+ BangPatterns DoAndIfThenElse OverloadedStrings- BangPatterns- ViewPatterns TypeOperators+ ViewPatterns - ghc-options: -Wall -fno-warn-name-shadowing+ ghc-options: -Wall -fno-warn-name-shadowing source-repository head type: git- location: http://github.com/lpsmith/postgresql-simple--source-repository this- type: git- location: http://github.com/hackage-trustees/postgresql-simple- tag: v0.5.4.0+ location: http://github.com/haskellari/postgresql-simple -test-suite test+test-suite inspection default-language: Haskell2010- type: exitcode-stdio-1.0+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Inspection.hs+ build-depends:+ base+ , inspection-testing >=0.4.1.1 && <0.7+ , postgresql-libpq+ , postgresql-simple+ , tasty+ , tasty-hunit - hs-source-dirs: test- main-is: Main.hs+test-suite test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs other-modules: Common+ Exception+ Interval Notify Serializable Time - ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind-+ ghc-options: -threaded+ ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind default-extensions: NamedFieldPuns OverloadedStrings+ PatternGuards Rank2Types RecordWildCards- PatternGuards ScopedTypeVariables - build-depends: base- , aeson- , base16-bytestring- , bytestring- , containers- , cryptohash- , filepath- , tasty- , tasty-hunit- , tasty-golden- , HUnit- , postgresql-simple- , text- , time- , vector+ build-depends:+ aeson+ , base+ , base16-bytestring+ , bytestring+ , case-insensitive+ , containers+ , cryptohash-md5 >=0.11.100.1 && <0.12+ , filepath+ , postgresql-simple+ , tasty+ , tasty-golden+ , tasty-hunit+ , text+ , time-compat+ , vector - if !impl(ghc >= 7.6)- build-depends:- ghc-prim+benchmark select+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: Select.hs+ build-depends:+ base+ , postgresql-simple+ , vector
src/Database/PostgreSQL/Simple.hs view
@@ -64,6 +64,7 @@ , Only(..) , (:.)(..) -- ** Exceptions+ , SomePostgreSqlException(..) , SqlError(..) , PQ.ExecStatus(..) , FormatError(..)@@ -73,6 +74,7 @@ , Base.connectPostgreSQL , Base.close , Base.connect+ , Base.withConnect , Base.ConnectInfo(..) , Base.defaultConnectInfo , Base.postgreSQLConnectionString@@ -276,21 +278,31 @@ skipSpace = B.dropWhile isSpace_ascii - buildQuery :: Connection -> Query -> ByteString -> [Action] -> IO Builder buildQuery conn q template xs = zipParams (split template) <$> mapM (buildAction conn q xs) xs where split s =- let (h,t) = B.break (=='?') s+ -- This part escapes double '??'s to make literal '?'s possible+ -- in PostgreSQL queries using the JSON operators: @?@, @?|@ and @?&@+ let (h,t) = breakOnSingleQuestionMark s in byteString h : if B.null t then [] else split (B.tail t) zipParams (t:ts) (p:ps) = t <> p <> zipParams ts ps zipParams [t] [] = t- zipParams _ _ = fmtError (show (B.count '?' template) ++- " '?' characters, but " +++ zipParams _ _ = fmtError (show countSingleQs +++ " single '?' characters, but " ++ show (length xs) ++ " parameters") q xs+ countSingleQs = go 0 template+ where go i "" = (i :: Int)+ go i bs = case qms of+ ("?","?") -> go i nextQMBS+ ("?",_) -> go (i+1) nextQMBS+ _ -> i+ where qms = B.splitAt 1 qmBS+ (qmBS,nextQMBS) = B.splitAt 2 qmBS'+ qmBS' = B.dropWhile (/= '?') bs -- | Execute an @INSERT@, @UPDATE@, or other SQL query that is not -- expected to return results.@@ -328,7 +340,7 @@ -- @ -- executeMany c [sql| -- UPDATE sometable--- SET sometable.y = upd.y+-- SET y = upd.y -- FROM (VALUES (?,?)) as upd(x,y) -- WHERE sometable.x = upd.x -- |] [(1, \"hello\"),(2, \"world\")]@@ -355,6 +367,7 @@ returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO [r] returning = returningWith fromRow +-- | A version of 'returning' taking parser as argument returningWith :: (ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO [r] returningWith _ _ _ [] = return [] returningWith parser conn q qs = do@@ -520,7 +533,7 @@ -> a -- ^ Initial state for result consumer. -> (a -> r -> IO a) -- ^ Result consumer. -> IO a-foldWithOptions_ opts conn query a f = doFold opts fromRow conn query query a f+foldWithOptions_ opts conn query' a f = doFold opts fromRow conn query' query' a f -- | A version of 'foldWithOptions_' taking a parser as an argument foldWithOptionsAndParser_ :: FoldOptions@@ -530,7 +543,7 @@ -> a -- ^ Initial state for result consumer. -> (a -> r -> IO a) -- ^ Result consumer. -> IO a-foldWithOptionsAndParser_ opts parser conn query a f = doFold opts parser conn query query a f+foldWithOptionsAndParser_ opts parser conn query' a f = doFold opts parser conn query' query' a f doFold :: FoldOptions -> RowParser row@@ -566,8 +579,8 @@ go = bracket declare closeCursor $ \cursor -> let loop a = fetch cursor a >>= \r -> case r of- Left a -> return a- Right a -> loop a+ Left x -> return x+ Right x -> loop x in loop a0 -- FIXME: choose the Automatic chunkSize more intelligently@@ -889,7 +902,7 @@ -- all values of the given PostgreSQL type is considered \"compatible\". -- For instance, you can always extract a PostgreSQL 16-bit @SMALLINT@ -- column to a Haskell 'Int'. The Haskell 'Float' type can accurately--- represent a @SMALLINT@, so it is considered compatble with those types.+-- represent a @SMALLINT@, so it is considered compatible with those types. -- -- * A numeric compatibility check is based only on the type of a -- column, /not/ on its values. For instance, a PostgreSQL 64-bit
src/Database/PostgreSQL/Simple/Arrays.hs view
@@ -42,9 +42,9 @@ quoted :: Parser ByteString quoted = char '"' *> option "" contents <* char '"' where- esc = char '\\' *> (char '\\' <|> char '"')+ esc' = char '\\' *> (char '\\' <|> char '"') unQ = takeWhile1 (notInClass "\"\\")- contents = mconcat <$> many (unQ <|> B.singleton <$> esc)+ contents = mconcat <$> many (unQ <|> B.singleton <$> esc') -- | Recognizes a plain string literal, not containing quotes or brackets and -- not containing the delimiter character.
src/Database/PostgreSQL/Simple/Compat.hs view
@@ -12,36 +12,13 @@ ) where 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) import Data.Text.Lazy.Builder.Scientific (scientificBuilder)-#else-import Data.Scientific (scientificBuilder)-#endif--#if __GLASGOW_HASKELL__ >= 702 import System.IO.Unsafe (unsafeDupablePerformIO)-#elif __GLASGOW_HASKELL__ >= 611-import GHC.IO (unsafeDupablePerformIO)-#else-import GHC.IOBase (unsafeDupablePerformIO)-#endif- import Data.Fixed (Pico)-#if MIN_VERSION_base(4,7,0) import Data.Fixed (Fixed(MkFixed))-#else-import Unsafe.Coerce (unsafeCoerce)-#endif -- | Like 'E.mask', but backported to base before version 4.3.0. --@@ -51,44 +28,14 @@ -- 'withTransactionMode' function calls the restore callback only once, so we -- don't need that polymorphism. mask :: ((IO a -> IO a) -> IO b) -> IO b-#if MIN_VERSION_base(4,3,0) mask io = E.mask $ \restore -> io restore-#else-mask io = do- b <- E.blocked- E.block $ io $ \m -> if b then m else E.unblock m-#endif {-# INLINE mask #-} -#if !MIN_VERSION_base(4,5,0)-infixr 6 <>--(<>) :: Monoid m => m -> m -> m-(<>) = mappend-{-# INLINE (<>) #-}-#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)- toPico :: Integer -> Pico toPico = MkFixed fromPico :: Pico -> Integer fromPico (MkFixed i) = i--#else--toPico :: Integer -> Pico-toPico = unsafeCoerce--fromPico :: Pico -> Integer-fromPico = unsafeCoerce--#endif
src/Database/PostgreSQL/Simple/Copy.hs view
@@ -32,6 +32,7 @@ ( copy , copy_ , CopyOutResult(..)+ , foldCopyData , getCopyData , putCopyData , putCopyEnd@@ -48,13 +49,13 @@ import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple.Types-import Database.PostgreSQL.Simple.Internal+import Database.PostgreSQL.Simple.Internal hiding (result, row) -- | Issue a @COPY FROM STDIN@ or @COPY TO STDOUT@ query. In the former -- case, the connection's state will change to @CopyIn@; in the latter, -- @CopyOut@. The connection must be in the ready state in order--- to call this function. Performs parameter subsitution.+-- to call this function. Performs parameter substitution. copy :: ( ToRow params ) => Connection -> Query -> params -> IO () copy conn template qs = do@@ -85,15 +86,12 @@ 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+ _ -> throwResultError funcName result status -- TODO data CopyOutResult = CopyOutRow !B.ByteString -- ^ Data representing either exactly@@ -102,6 +100,30 @@ | CopyOutDone {-# UNPACK #-} !Int64 -- ^ No more rows, and a count of the -- number of rows returned. deriving (Eq, Typeable, Show)+++-- | Fold over @COPY TO STDOUT@ query passing each copied row to an accumulator+-- and calling a post-process at the end. A connection must be in the+-- @CopyOut@ state in order to call this function.+--+-- __Example__+--+-- > (acc, count) <- foldCopyData conn+-- > (\acc row -> return (row:acc))+-- > (\acc count -> return (acc, count))+-- > []++foldCopyData+ :: Connection -- ^ Database connection+ -> (a -> B.ByteString -> IO a) -- ^ Accumulate one row of the result+ -> (a -> Int64 -> IO b) -- ^ Post-process accumulator with a count of rows+ -> a -- ^ Initial accumulator+ -> IO b -- ^ Result+foldCopyData conn f g !acc = do+ result <- getCopyData conn+ case result of+ CopyOutRow row -> f acc row >>= foldCopyData conn f g+ CopyOutDone count -> g acc count -- | Retrieve some data from a @COPY TO STDOUT@ query. A connection
src/Database/PostgreSQL/Simple/Cursor.hs view
@@ -30,7 +30,7 @@ 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 as Base hiding (result, row) import Database.PostgreSQL.Simple.Internal.PQResultUtils import Database.PostgreSQL.Simple.Transaction import qualified Database.PostgreSQL.LibPQ as PQ@@ -90,9 +90,9 @@ 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+ loop x !n+ | n > hi = return x | otherwise = do- a' <- f a n- loop a' (n+1)+ x' <- f x n+ loop x' (n+1) {-# INLINE foldM' #-}
src/Database/PostgreSQL/Simple/Errors.hs view
@@ -25,7 +25,6 @@ ) where -import Control.Applicative import Control.Exception as E import Data.Attoparsec.ByteString.Char8@@ -60,11 +59,13 @@ deriving (Show, Eq, Ord, Typeable) -- Default instance should be enough-instance Exception ConstraintViolation+instance Exception ConstraintViolation where+ toException = postgresqlExceptionToException+ fromException = postgresqlExceptionFromException -- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and--- succeedes only if able to parse sqlErrorMsg.+-- succeeds only if able to parse sqlErrorMsg. -- -- > createUser = handleJust constraintViolation handler $ execute conn ... -- > where
src/Database/PostgreSQL/Simple/FromField.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE PatternGuards, ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards, TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE PolyKinds #-} {- | Module: Database.PostgreSQL.Simple.FromField@@ -106,25 +107,27 @@ , PQ.Oid(..) , PQ.Format(..) , pgArrayFieldParser+ , attoFieldParser , optionalField , fromJSONField+ , fromFieldJSONByteString ) where #include "MachDeps.h" -import Control.Applicative ( (<|>), (<$>), pure, (*>), (<*) )+import Control.Applicative ( Const(Const), (<|>), (<$>), pure, (*>), (<*) ) import Control.Concurrent.MVar (MVar, newMVar)-import Control.Exception (Exception)+import Control.Exception (Exception (toException, fromException)) import qualified Data.Aeson as JSON-import qualified Data.Aeson.Parser as JSON (value') import Data.Attoparsec.ByteString.Char8 hiding (Result) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B+import Data.Functor.Identity (Identity(Identity)) import Data.Int (Int16, Int32, Int64) import Data.IORef (IORef, newIORef) import Data.Ratio (Ratio)-import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )+import Data.Time.Compat ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay, CalendarDiffTime ) import Data.Typeable (Typeable, typeOf) import Data.Vector (Vector) import Data.Vector.Mutable (IOVector)@@ -135,7 +138,6 @@ import Database.PostgreSQL.Simple.Types import Database.PostgreSQL.Simple.TypeInfo as TI import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI-import Database.PostgreSQL.Simple.TypeInfo.Macro as TI import Database.PostgreSQL.Simple.Time import Database.PostgreSQL.Simple.Arrays as Arrays import qualified Database.PostgreSQL.LibPQ as PQ@@ -152,6 +154,8 @@ import Data.Scientific (Scientific) import GHC.Real (infinity, notANumber) +import qualified Data.Aeson.Types as JSON+ -- | Exception thrown if conversion from a SQL value to a Haskell -- value fails. data ResultError = Incompatible { errSQLType :: String@@ -178,7 +182,9 @@ -- between metadata and actual data in a row). deriving (Eq, Show, Typeable) -instance Exception ResultError+instance Exception ResultError where+ toException = postgresqlExceptionToException+ fromException = postgresqlExceptionFromException left :: Exception a => a -> Conversion b left = conversionError@@ -244,9 +250,11 @@ then Nothing else Just x --- | If the column has a table associated with it, this returns the number--- off the associated table column. Numbering starts from 0. Analogous--- to libpq's @PQftablecol@.+-- | If the column has a table associated with it, this returns the+-- number of the associated table column. Table columns have+-- nonzero numbers. Zero is returned if the specified column is not+-- a simple reference to a table column, or when using pre-3.0+-- protocol. Analogous to libpq's @PQftablecol@. tableColumn :: Field -> Int tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column))@@ -262,9 +270,15 @@ -- | void instance FromField () where fromField f _bs- | typeOid f /= $(inlineTypoid TI.void) = returnError Incompatible f ""+ | typeOid f /= TI.voidOid = returnError Incompatible f "" | otherwise = pure () +instance (FromField a) => FromField (Const a b) where+ fromField f bs = Const <$> fromField f bs++instance (FromField a) => FromField (Identity a) where+ fromField f bs = Identity <$> fromField f bs+ -- | For dealing with null values. Compatible with any postgresql type -- compatible with type @a@. Note that the type is not checked if -- the value is null, although it is inadvisable to rely on this@@ -292,7 +306,7 @@ -- | bool instance FromField Bool where fromField f bs- | typeOid f /= $(inlineTypoid TI.bool) = returnError Incompatible f ""+ | typeOid f /= TI.boolOid = returnError Incompatible f "" | bs == Nothing = returnError UnexpectedNull f "" | bs == Just "t" = pure True | bs == Just "f" = pure False@@ -300,9 +314,9 @@ -- | \"char\", bpchar instance FromField Char where- fromField f bs =- if $(mkCompats [TI.char,TI.bpchar]) (typeOid f)- then case bs of+ fromField f bs0 =+ if (eq TI.charOid \/ eq TI.bpcharOid) (typeOid f)+ then case bs0 of Nothing -> returnError UnexpectedNull f "" Just bs -> if B.length bs /= 1 then returnError ConversionFailed f "length not 1"@@ -311,11 +325,11 @@ -- | int2 instance FromField Int16 where- fromField = atto ok16 $ signed decimal+ fromField = attoFieldParser ok16 $ signed decimal -- | int2, int4 instance FromField Int32 where- fromField = atto ok32 $ signed decimal+ fromField = attoFieldParser ok32 $ signed decimal #if WORD_SIZE_IN_BITS < 64 -- | int2, int4, and if compiled as 64-bit code, int8 as well.@@ -325,37 +339,37 @@ -- This library was compiled as 64-bit code. #endif instance FromField Int where- fromField = atto okInt $ signed decimal+ fromField = attoFieldParser okInt $ signed decimal -- | int2, int4, int8 instance FromField Int64 where- fromField = atto ok64 $ signed decimal+ fromField = attoFieldParser ok64 $ signed decimal -- | int2, int4, int8 instance FromField Integer where- fromField = atto ok64 $ signed decimal+ fromField = attoFieldParser ok64 $ signed decimal -- | int2, float4 (Uses attoparsec's 'double' routine, for -- better accuracy convert to 'Scientific' or 'Rational' first) instance FromField Float where- fromField = atto ok (realToFrac <$> pg_double)- where ok = $(mkCompats [TI.float4,TI.int2])+ fromField = attoFieldParser ok (realToFrac <$> pg_double)+ where ok = eq TI.float4Oid \/ eq TI.int2Oid -- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for -- better accuracy convert to 'Scientific' or 'Rational' first) instance FromField Double where- fromField = atto ok pg_double- where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4])+ fromField = attoFieldParser ok pg_double+ where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid -- | int2, int4, int8, float4, float8, numeric instance FromField (Ratio Integer) where- fromField = atto ok pg_rational- where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.int8,TI.numeric])+ fromField = attoFieldParser ok pg_rational+ where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid -- | int2, int4, int8, float4, float8, numeric instance FromField Scientific where- fromField = atto ok rational- where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.int8,TI.numeric])+ fromField = attoFieldParser ok rational+ where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid unBinary :: Binary t -> t unBinary (Binary x) = x@@ -376,13 +390,13 @@ -- | bytea, name, text, \"char\", bpchar, varchar, unknown instance FromField SB.ByteString where- fromField f dat = if typeOid f == $(inlineTypoid TI.bytea)+ fromField f dat = if typeOid f == TI.byteaOid then unBinary <$> fromField f dat else doFromField f okText' pure dat -- | oid instance FromField PQ.Oid where- fromField f dat = PQ.Oid <$> atto (== $(inlineTypoid TI.oid)) decimal f dat+ fromField f dat = PQ.Oid <$> attoFieldParser (== TI.oidOid) decimal f dat -- | bytea, name, text, \"char\", bpchar, varchar, unknown instance FromField LB.ByteString where@@ -390,7 +404,7 @@ unescapeBytea :: Field -> SB.ByteString -> Conversion (Binary SB.ByteString)-unescapeBytea f str = case unsafeDupablePerformIO (PQ.unescapeBytea str) of+unescapeBytea f str' = case unsafeDupablePerformIO (PQ.unescapeBytea str') of Nothing -> returnError ConversionFailed f "unescapeBytea failed" Just str -> pure (Binary str) @@ -441,48 +455,57 @@ -- | timestamptz instance FromField UTCTime where- fromField = ff $(inlineTypoid TI.timestamptz) "UTCTime" parseUTCTime+ fromField = ff TI.timestamptzOid "UTCTime" parseUTCTime -- | timestamptz instance FromField ZonedTime where- fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTime" parseZonedTime+ fromField = ff TI.timestamptzOid "ZonedTime" parseZonedTime -- | timestamp instance FromField LocalTime where- fromField = ff $(inlineTypoid TI.timestamp) "LocalTime" parseLocalTime+ fromField = ff TI.timestampOid "LocalTime" parseLocalTime -- | date instance FromField Day where- fromField = ff $(inlineTypoid TI.date) "Day" parseDay+ fromField = ff TI.dateOid "Day" parseDay -- | time instance FromField TimeOfDay where- fromField = ff $(inlineTypoid TI.time) "TimeOfDay" parseTimeOfDay+ fromField = ff TI.timeOid "TimeOfDay" parseTimeOfDay -- | timestamptz instance FromField UTCTimestamp where- fromField = ff $(inlineTypoid TI.timestamptz) "UTCTimestamp" parseUTCTimestamp+ fromField = ff TI.timestamptzOid "UTCTimestamp" parseUTCTimestamp -- | timestamptz instance FromField ZonedTimestamp where- fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTimestamp" parseZonedTimestamp+ fromField = ff TI.timestamptzOid "ZonedTimestamp" parseZonedTimestamp -- | timestamp instance FromField LocalTimestamp where- fromField = ff $(inlineTypoid TI.timestamp) "LocalTimestamp" parseLocalTimestamp+ fromField = ff TI.timestampOid "LocalTimestamp" parseLocalTimestamp -- | date instance FromField Date where- fromField = ff $(inlineTypoid TI.date) "Date" parseDate+ fromField = ff TI.dateOid "Date" parseDate +-- | interval. Requires you to configure intervalstyle as @iso_8601@.+--+-- You can configure intervalstyle on every connection with a @SET@ command,+-- but for better performance you may want to configure it permanently in the+-- file found with @SHOW config_file;@ .+--+instance FromField CalendarDiffTime where+ fromField = ff TI.intervalOid "CalendarDiffTime" parseCalendarDiffTime+ ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a) -> Field -> Maybe B8.ByteString -> Conversion a-ff compatOid hsType parse f mstr =+ff compatOid hsType parseBS f mstr = if typeOid f /= compatOid then err Incompatible "" else case mstr of Nothing -> err UnexpectedNull ""- Just str -> case parse str of+ Just str -> case parseBS str of Left msg -> err ConversionFailed msg Right val -> return val where@@ -520,10 +543,10 @@ _ -> returnError Incompatible f "" fromArray :: FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a])-fromArray fieldParser typeInfo f = sequence . (parseIt <$>) <$> array delim+fromArray fieldParser typInfo f = sequence . (parseIt <$>) <$> array delim where- delim = typdelim (typelem typeInfo)- fElem = f{ typeOid = typoid (typelem typeInfo) }+ delim = typdelim (typelem typInfo)+ fElem = f{ typeOid = typoid (typelem typInfo) } parseIt item = fieldParser f' $ if item == Arrays.Plain "NULL" then Nothing else Just item'@@ -541,7 +564,7 @@ -- | uuid instance FromField UUID where fromField f mbs =- if typeOid f /= $(inlineTypoid TI.uuid)+ if typeOid f /= TI.uuidOid then returnError Incompatible f "" else case mbs of Nothing -> returnError UnexpectedNull f ""@@ -550,20 +573,26 @@ Nothing -> returnError ConversionFailed f "Invalid UUID" Just uuid -> pure uuid --- | json+-- | json, jsonb instance FromField JSON.Value where- fromField f mbs =- if typeOid f /= $(inlineTypoid TI.json) && typeOid f /= $(inlineTypoid TI.jsonb)+ fromField f mbs = parseBS =<< fromFieldJSONByteString f mbs+ where parseBS bs = case JSON.eitherDecodeStrict' bs of+ Left err -> returnError ConversionFailed f err+ Right val -> pure val++-- | Return the JSON ByteString directly+--+-- @since 0.6.3+fromFieldJSONByteString :: Field -> Maybe ByteString -> Conversion ByteString+fromFieldJSONByteString f mbs =+ if typeOid f /= TI.jsonOid && typeOid f /= TI.jsonbOid then returnError Incompatible f "" else case mbs of Nothing -> returnError UnexpectedNull f ""- Just bs ->- case parseOnly (JSON.value' <* endOfInput) bs of- Left err -> returnError ConversionFailed f err- Right val -> pure val+ Just bs -> pure bs -- | Parse a field to a JSON 'JSON.Value' and convert that into a--- Haskell value using 'JSON.fromJSON'.+-- Haskell value using the 'JSON.FromJSON' instance. -- -- This can be used as the default implementation for the 'fromField' -- method for Haskell types that have a JSON representation in@@ -584,10 +613,10 @@ fromJSONField :: (JSON.FromJSON a, Typeable a) => FieldParser a fromJSONField f mbBs = do value <- fromField f mbBs- case JSON.fromJSON value of- JSON.Error err -> returnError ConversionFailed f $- "JSON decoding error: " ++ err- JSON.Success x -> pure x+ case JSON.ifromJSON value of+ JSON.IError path err -> returnError ConversionFailed f $+ "JSON decoding error: " ++ (JSON.formatError path err)+ JSON.ISuccess x -> pure x -- | Compatible with the same set of types as @a@. Note that -- modifying the 'IORef' does not have any effects outside@@ -604,20 +633,33 @@ type Compat = PQ.Oid -> Bool okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat-okText = $( mkCompats [ TI.name, TI.text, TI.char,- TI.bpchar, TI.varchar ] )-okText' = $( mkCompats [ TI.name, TI.text, TI.char,- TI.bpchar, TI.varchar, TI.unknown ] )-okBinary = (== $( inlineTypoid TI.bytea ))-ok16 = (== $( inlineTypoid TI.int2 ))-ok32 = $( mkCompats [TI.int2,TI.int4] )-ok64 = $( mkCompats [TI.int2,TI.int4,TI.int8] )+okText = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid+ \/ eq TI.bpcharOid \/ eq TI.varcharOid+okText' = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid+ \/ eq TI.bpcharOid \/ eq TI.varcharOid \/ eq TI.unknownOid+okBinary = eq TI.byteaOid+ok16 = eq TI.int2Oid+ok32 = eq TI.int2Oid \/ eq TI.int4Oid+ok64 = eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid #if WORD_SIZE_IN_BITS < 64 okInt = ok32 #else okInt = ok64 #endif +-- | eq and \/ are used to imlement what Macro stuff did,+-- i.e. mkCompats and inlineTypoid+eq :: PQ.Oid -> PQ.Oid -> Bool+eq = (==)+{-# INLINE eq #-}++infixr 2 \/+(\/) :: (PQ.Oid -> Bool)+ -> (PQ.Oid -> Bool)+ -> (PQ.Oid -> Bool)+f \/ g = \x -> f x || g x+{-# INLINE (\/) #-}+ doFromField :: forall a . (Typeable a) => Field -> Compat -> (ByteString -> Conversion a) -> Maybe ByteString -> Conversion a@@ -642,10 +684,22 @@ (show (typeOf (undefined :: a))) msg -atto :: forall a. (Typeable a)- => Compat -> Parser a -> Field -> Maybe ByteString- -> Conversion a-atto types p0 f dat = doFromField f types (go p0) dat+-- | Construct a field parser from an attoparsec parser. An 'Incompatible' error is thrown if the+-- PostgreSQL oid does not match the specified predicate.+--+-- @+-- instance FromField Int16 where+-- fromField = attoFieldParser ok16 (signed decimal)+-- @+--+-- @since 0.6.3+attoFieldParser :: forall a. (Typeable a)+ => (PQ.Oid -> Bool)+ -- ^ Predicate for whether the postgresql type oid is compatible with this parser+ -> Parser a+ -- ^ An attoparsec parser.+ -> FieldParser a+attoFieldParser types p0 f dat = doFromField f types (go p0) dat where go :: Parser a -> ByteString -> Conversion a go p s =
src/Database/PostgreSQL/Simple/FromRow.hs view
@@ -67,6 +67,23 @@ -- in a single row of the query result. Otherwise, a 'ConversionFailed' -- exception will be thrown. --+-- You can also derive 'FromRow' for your data type using GHC generics, like+-- this:+--+-- @+-- \{-# LANGUAGE DeriveAnyClass \#-}+-- \{-# LANGUAGE DeriveGeneric \#-}+--+-- import "GHC.Generics" ('GHC.Generics.Generic')+-- import "Database.PostgreSQL.Simple" ('FromRow')+--+-- data User = User { name :: String, fileQuota :: Int }+-- deriving ('GHC.Generics.Generic', 'FromRow')+-- @+--+-- Note that this only works for product types (e.g. records) and does not+-- support sum types or recursive types.+-- -- Note that 'field' evaluates its result to WHNF, so the caveats listed in -- mysql-simple and very early versions of postgresql-simple no longer apply. -- Instead, look at the caveats associated with user-defined implementations@@ -114,8 +131,8 @@ else do let !result = rowresult !typeOid = unsafeDupablePerformIO (PQ.ftype result column)- !field = Field{..}- lift (lift (fieldP field (getvalue result row column)))+ !field' = Field{..}+ lift (lift (fieldP field' (getvalue result row column))) field :: FromField a => RowParser a field = fieldWith fromField@@ -235,6 +252,196 @@ FromField f, FromField g, FromField h, FromField i, FromField j) => FromRow (Maybe (a,b,c,d,e,f,g,h,i,j)) where fromRow = (null *> null *> null *> null *> null *>+ null *> null *> null *> null *> null *> pure Nothing)+ <|> (Just <$> fromRow)++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i, FromField j,+ FromField k) =>+ FromRow (a,b,c,d,e,f,g,h,i,j,k) where+ fromRow = (,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field <*> field <*> field+ <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i, FromField j,+ FromField k) =>+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k)) where+ fromRow = (null *> null *> null *> null *> null *>+ null *> null *> null *> null *> null *>+ null *> pure Nothing)+ <|> (Just <$> fromRow)++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i, FromField j,+ FromField k, FromField l) =>+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l) where+ fromRow = (,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field <*> field <*> field+ <*> field <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i, FromField j,+ FromField k, FromField l) =>+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l)) where+ fromRow = (null *> null *> null *> null *> null *>+ null *> null *> null *> null *> null *>+ null *> null *> pure Nothing)+ <|> (Just <$> fromRow)++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i, FromField j,+ FromField k, FromField l, FromField m) =>+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m) where+ fromRow = (,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i, FromField j,+ FromField k, FromField l, FromField m) =>+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m)) where+ fromRow = (null *> null *> null *> null *> null *>+ null *> null *> null *> null *> null *>+ null *> null *> null *> pure Nothing)+ <|> (Just <$> fromRow)++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i, FromField j,+ FromField k, FromField l, FromField m, FromField n) =>+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where+ fromRow = (,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i, FromField j,+ FromField k, FromField l, FromField m, FromField n) =>+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n)) where+ fromRow = (null *> null *> null *> null *> null *>+ null *> null *> null *> null *> null *>+ null *> null *> null *> null *> pure Nothing)+ <|> (Just <$> fromRow)++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i, FromField j,+ FromField k, FromField l, FromField m, FromField n, FromField o) =>+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where+ fromRow = (,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field <*> field <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i, FromField j,+ FromField k, FromField l, FromField m, FromField n, FromField o) =>+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)) where+ fromRow = (null *> null *> null *> null *> null *>+ null *> null *> null *> null *> null *>+ null *> null *> null *> null *> null *> pure Nothing)+ <|> (Just <$> fromRow)++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i, FromField j,+ FromField k, FromField l, FromField m, FromField n, FromField o,+ FromField p) =>+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where+ fromRow = (,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field <*> field <*> field+ <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i, FromField j,+ FromField k, FromField l, FromField m, FromField n, FromField o,+ FromField p) =>+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)) where+ fromRow = (null *> null *> null *> null *> null *>+ null *> null *> null *> null *> null *>+ null *> null *> null *> null *> null *>+ null *> pure Nothing)+ <|> (Just <$> fromRow)++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i, FromField j,+ FromField k, FromField l, FromField m, FromField n, FromField o,+ FromField p, FromField q) =>+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) where+ fromRow = (,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field <*> field <*> field+ <*> field <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i, FromField j,+ FromField k, FromField l, FromField m, FromField n, FromField o,+ FromField p, FromField q) =>+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q)) where+ fromRow = (null *> null *> null *> null *> null *>+ null *> null *> null *> null *> null *>+ null *> null *> null *> null *> null *>+ null *> null *> pure Nothing)+ <|> (Just <$> fromRow)++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i, FromField j,+ FromField k, FromField l, FromField m, FromField n, FromField o,+ FromField p, FromField q, FromField r) =>+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) where+ fromRow = (,,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i, FromField j,+ FromField k, FromField l, FromField m, FromField n, FromField o,+ FromField p, FromField q, FromField r) =>+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r)) where+ fromRow = (null *> null *> null *> null *> null *>+ null *> null *> null *> null *> null *>+ null *> null *> null *> null *> null *>+ null *> null *> null *> pure Nothing)+ <|> (Just <$> fromRow)++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i, FromField j,+ FromField k, FromField l, FromField m, FromField n, FromField o,+ FromField p, FromField q, FromField r, FromField s) =>+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) where+ fromRow = (,,,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i, FromField j,+ FromField k, FromField l, FromField m, FromField n, FromField o,+ FromField p, FromField q, FromField r, FromField s) =>+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s)) where+ fromRow = (null *> null *> null *> null *> null *>+ null *> null *> null *> null *> null *>+ null *> null *> null *> null *> null *>+ null *> null *> null *> null *> pure Nothing)+ <|> (Just <$> fromRow)++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i, FromField j,+ FromField k, FromField l, FromField m, FromField n, FromField o,+ FromField p, FromField q, FromField r, FromField s, FromField t) =>+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) where+ fromRow = (,,,,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field <*> field <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i, FromField j,+ FromField k, FromField l, FromField m, FromField n, FromField o,+ FromField p, FromField q, FromField r, FromField s, FromField t) =>+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t)) where+ fromRow = (null *> null *> null *> null *> null *>+ null *> null *> null *> null *> null *>+ null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> pure Nothing) <|> (Just <$> fromRow)
src/Database/PostgreSQL/Simple/HStore/Implementation.hs view
@@ -22,9 +22,6 @@ import qualified Data.ByteString.Builder as BU import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy as BL-#if !MIN_VERSION_bytestring(0,10,0)-import qualified Data.ByteString.Lazy.Internal as BL (foldrChunks)-#endif import Data.Map(Map) import qualified Data.Map as Map import Data.Text(Text)@@ -53,12 +50,12 @@ toBuilder :: HStoreBuilder -> Builder toBuilder x = case x of Empty -> mempty- Comma x -> x+ Comma c -> c toLazyByteString :: HStoreBuilder -> BL.ByteString toLazyByteString x = case x of Empty -> BL.empty- Comma x -> BU.toLazyByteString x+ Comma c -> BU.toLazyByteString c instance Semigroup HStoreBuilder where Empty <> x = x@@ -69,9 +66,6 @@ instance Monoid HStoreBuilder where mempty = Empty-#if !(MIN_VERSION_base(4,11,0))- mappend = (<>)-#endif class ToHStoreText a where toHStoreText :: a -> HStoreText@@ -150,7 +144,7 @@ instance ToHStore HStoreMap where toHStore (HStoreMap xs) = Map.foldrWithKey f mempty xs- where f k v xs = hstore k v `mappend` xs+ where f k v xs' = hstore k v `mappend` xs' instance ToField HStoreMap where toField xs = toField (toHStore xs)
src/Database/PostgreSQL/Simple/Internal.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, RecordWildCards #-}-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE InstanceSigs #-} ------------------------------------------------------------------------------ -- |@@ -33,7 +36,6 @@ import qualified Data.IntMap as IntMap import Data.IORef import Data.Maybe(fromMaybe)-import Data.Monoid import Data.String import qualified Data.Text as T import qualified Data.Text.Encoding as TE@@ -50,6 +52,7 @@ import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Class+import GHC.Generics import GHC.IO.Exception #if !defined(mingw32_HOST_OS) import Control.Concurrent(threadWaitRead, threadWaitWrite)@@ -80,6 +83,25 @@ instance Eq Connection where x == y = connectionHandle x == connectionHandle y +-- | Superclass for postgresql exceptions+data SomePostgreSqlException = forall e. Exception e => SomePostgreSqlException e+ deriving Typeable++postgresqlExceptionToException :: Exception e => e -> SomeException+postgresqlExceptionToException = toException . SomePostgreSqlException++postgresqlExceptionFromException :: Exception e => SomeException -> Maybe e+postgresqlExceptionFromException x = do+ SomePostgreSqlException a <- fromException x+ cast a++instance Show SomePostgreSqlException where+ showsPrec :: Int -> SomePostgreSqlException -> ShowS+ showsPrec p (SomePostgreSqlException e) = showsPrec p e++instance Exception SomePostgreSqlException where+ displayException (SomePostgreSqlException e) = displayException e+ data SqlError = SqlError { sqlState :: ByteString , sqlExecStatus :: ExecStatus@@ -91,8 +113,11 @@ fatalError :: ByteString -> SqlError fatalError msg = SqlError "" FatalError msg "" "" -instance Exception SqlError+instance Exception SqlError where+ toException = postgresqlExceptionToException+ fromException = postgresqlExceptionFromException + -- | Exception thrown if 'query' is used to perform an @INSERT@-like -- operation, or 'execute' is used to perform a @SELECT@-like operation. data QueryError = QueryError {@@ -100,7 +125,9 @@ , qeQuery :: Query } deriving (Eq, Show, Typeable) -instance Exception QueryError+instance Exception QueryError where+ toException = postgresqlExceptionToException+ fromException = postgresqlExceptionFromException -- | Exception thrown if a 'Query' could not be formatted correctly. -- This may occur if the number of \'@?@\' characters in the query@@ -111,7 +138,9 @@ , fmtParams :: [ByteString] } deriving (Eq, Show, Typeable) -instance Exception FormatError+instance Exception FormatError where+ toException = postgresqlExceptionToException+ fromException = postgresqlExceptionFromException data ConnectInfo = ConnectInfo { connectHost :: String@@ -119,7 +148,7 @@ , connectUser :: String , connectPassword :: String , connectDatabase :: String- } deriving (Eq,Read,Show,Typeable)+ } deriving (Generic,Eq,Read,Show,Typeable) -- | Default information for setting up a connection. --@@ -153,6 +182,12 @@ connect :: ConnectInfo -> IO Connection connect = connectPostgreSQL . postgreSQLConnectionString +-- | Memory bracket around 'connect' and 'close'.+--+-- @since 0.6.5+withConnect :: ConnectInfo -> (Connection -> IO c) -> IO c+withConnect connInfo = bracket (connect connInfo) close+ -- | Attempt to make a connection based on a libpq connection string. -- See <https://www.postgresql.org/docs/9.5/static/libpq-connect.html#LIBPQ-CONNSTRING> -- for more information. Also note that environment variables also affect@@ -188,7 +223,8 @@ -- -- Omitting @password@ will default to an appropriate password found -- in the @pgpass@ file, or no password at all if a matching line is--- not found. See+-- not found. The path of the @pgpass@ file may be specified by setting+-- the @PGPASSFILE@ environment variable. See -- <https://www.postgresql.org/docs/9.5/static/libpq-pgpass.html> for -- more information regarding this file. --@@ -287,7 +323,7 @@ str name field | null value = id- | otherwise = showString name . quote value . space+ | otherwise = showString name . addQuotes value . space where value = field connectInfo num name field@@ -295,7 +331,7 @@ | otherwise = showString name . shows value . space where value = field connectInfo - quote str rest = '\'' : foldr delta ('\'' : rest) str+ addQuotes s rest = '\'' : foldr delta ('\'' : rest) s where delta c cs = case c of '\\' -> '\\' : '\\' : cs@@ -360,6 +396,7 @@ PQ.BadResponse -> getResult h mres' PQ.NonfatalError -> getResult h mres' PQ.FatalError -> getResult h mres'+ _ -> error "incomplete match" #endif -- | A version of 'execute' that does not perform query substitution.@@ -383,7 +420,7 @@ nstr <- PQ.cmdTuples result return $ case nstr of Nothing -> 0 -- is this appropriate?- Just str -> toInteger str+ Just str -> mkInteger str PQ.TuplesOk -> do ncols <- PQ.nfields result throwIO $ QueryError ("execute resulted in " ++ show ncols ++@@ -395,8 +432,9 @@ PQ.BadResponse -> throwResultError "execute" result status PQ.NonfatalError -> throwResultError "execute" result status PQ.FatalError -> throwResultError "execute" result status+ _ -> throwResultError "execute: TODO" result status where- toInteger str = B8.foldl' delta 0 str+ mkInteger str = B8.foldl' delta 0 str where delta acc c = if '0' <= c && c <= '9'@@ -411,8 +449,8 @@ PQ.resultErrorField result PQ.DiagMessageDetail hint <- fromMaybe "" <$> PQ.resultErrorField result PQ.DiagMessageHint- state <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate- throwIO $ SqlError { sqlState = state+ state' <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate+ throwIO $ SqlError { sqlState = state' , sqlExecStatus = status , sqlErrorMsg = errormsg , sqlErrorDetail = detail@@ -481,9 +519,6 @@ Errors _ -> (oka <|>) <$> runConversion mb conn instance Monad Conversion where-#if !(MIN_VERSION_base(4,8,0))- return = pure-#endif m >>= f = Conversion $ \conn -> do oka <- runConversion m conn case oka of@@ -586,3 +621,19 @@ escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString) escapeByteaConn = escapeWrap PQ.escapeByteaConn++breakOnSingleQuestionMark :: ByteString -> (ByteString, ByteString)+breakOnSingleQuestionMark b = go (B8.empty, b)+ where go (x,bs) = (x `B8.append` x',bs')+ -- seperate from first QM+ where tup@(noQ, restWithQ) = B8.break (=='?') bs+ -- if end of query, just return+ -- else check for second QM in 'go2'+ (x', bs') = maybe tup go2 $+ -- drop found QM and peek at next char+ B8.uncons restWithQ >>= B8.uncons . snd+ -- another QM after the first means:+ -- take literal QM and keep going.+ go2 ('?', t2) = go (noQ `B8.snoc` '?',t2)+ -- Anything else means+ go2 _ = tup
src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs view
@@ -14,43 +14,74 @@ module Database.PostgreSQL.Simple.Internal.PQResultUtils ( finishQueryWith+ , finishQueryWithV+ , finishQueryWithVU , getRowWith ) where import Control.Exception as E import Data.ByteString (ByteString)+import Data.Foldable (for_) 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.Internal as Base hiding (result, row) import Database.PostgreSQL.Simple.TypeInfo import qualified Database.PostgreSQL.LibPQ as PQ import qualified Data.ByteString.Char8 as B+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Unboxed.Mutable as MVU 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+finishQueryWith parser conn q result = finishQueryWith' q result $ do+ nrows <- PQ.ntuples result+ ncols <- PQ.nfields result+ forM' 0 (nrows-1) $ \row ->+ getRowWith parser row ncols conn result++finishQueryWithV :: RowParser r -> Connection -> Query -> PQ.Result -> IO (V.Vector r)+finishQueryWithV parser conn q result = finishQueryWith' q result $ do+ nrows <- PQ.ntuples result+ let PQ.Row nrows' = nrows+ ncols <- PQ.nfields result+ mv <- MV.unsafeNew (fromIntegral nrows')+ for_ [ 0 .. nrows-1 ] $ \row -> do+ let PQ.Row row' = row+ value <- getRowWith parser row ncols conn result+ MV.unsafeWrite mv (fromIntegral row') value+ V.unsafeFreeze mv++finishQueryWithVU :: VU.Unbox r => RowParser r -> Connection -> Query -> PQ.Result -> IO (VU.Vector r)+finishQueryWithVU parser conn q result = finishQueryWith' q result $ do+ nrows <- PQ.ntuples result+ let PQ.Row nrows' = nrows+ ncols <- PQ.nfields result+ mv <- MVU.unsafeNew (fromIntegral nrows')+ for_ [ 0 .. nrows-1 ] $ \row -> do+ let PQ.Row row' = row+ value <- getRowWith parser row ncols conn result+ MVU.unsafeWrite mv (fromIntegral row') value+ VU.unsafeFreeze mv++finishQueryWith' :: Query -> PQ.Result -> IO a -> IO a+finishQueryWith' q result k = 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.TuplesOk -> k PQ.EmptyQuery -> queryErr "query: Empty query"- PQ.CommandOk -> queryErr "query resulted in a command response"+ PQ.CommandOk -> queryErr "query resulted in a command response (did you mean to use `execute` or forget a RETURNING?)" 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+ _ -> throwResultError "query: TODO" result status where queryErr msg = throwIO $ QueryError msg q
+ src/Database/PostgreSQL/Simple/Newtypes.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveDataTypeable #-}+-- | Module with newtypes suitable to usage with @DerivingVia@ or standalone.+--+-- The newtypes are named after packages they wrap.+module Database.PostgreSQL.Simple.Newtypes (+ Aeson (..), getAeson,+) where++import Data.Typeable (Typeable)+import Database.PostgreSQL.Simple.ToField (ToField (..))+import Database.PostgreSQL.Simple.FromField (FromField (..), fromJSONField)++import qualified Data.Aeson as Aeson++-------------------------------------------------------------------------------+-- aeson+-------------------------------------------------------------------------------++-- | A newtype wrapper with 'ToField' and 'FromField' instances+-- based on 'Aeson.ToJSON' and 'Aeson.FromJSON' type classes from @aeson@.+--+-- Example using @DerivingVia@:+--+-- @+-- data Foo = Foo Int String+-- deriving stock (Eq, Show, Generic) -- GHC built int+-- deriving anyclass ('Aeson.FromJSON', 'Aeson.ToJSON') -- Derived using GHC Generics+-- deriving ('ToField', 'FromField') via 'Aeson' Foo -- DerivingVia+-- @+--+-- Example using 'Aeson' newtype directly, for more ad-hoc queries+--+-- @+-- execute conn "INSERT INTO tbl (fld) VALUES (?)" (Only ('Aeson' x))+-- @+-- +-- @since 0.6.3+newtype Aeson a = Aeson a+ deriving (Eq, Show, Read, Typeable, Functor)++getAeson :: Aeson a -> a+getAeson (Aeson a) = a++instance Aeson.ToJSON a => ToField (Aeson a) where+ toField = toField . Aeson.encode . getAeson++instance (Aeson.FromJSON a, Typeable a) => FromField (Aeson a) where+ fromField f bs = fmap Aeson (fromJSONField f bs)
src/Database/PostgreSQL/Simple/Notification.hs view
@@ -47,8 +47,6 @@ #if defined(mingw32_HOST_OS) import Control.Concurrent ( threadDelay )-#elif !MIN_VERSION_base(4,7,0)-import Control.Concurrent ( threadWaitRead ) #else import GHC.Conc ( atomically ) import Control.Concurrent ( threadWaitReadSTM )@@ -94,21 +92,6 @@ -- with async exceptions, whereas threadDelay can. Just _fd -> do return (threadDelay 1000000 >> loop)-#elif !MIN_VERSION_base(4,7,0)- -- Technically there's a race condition that is usually benign.- -- If the connection is closed or reset after we drop the- -- lock, and then the fd index is reallocated to a new- -- descriptor before we call threadWaitRead, then- -- we could end up waiting on the wrong descriptor.- --- -- Now, if the descriptor becomes readable promptly, then- -- it's no big deal as we'll wake up and notice the change- -- on the next iteration of the loop. But if are very- -- unlucky, then we could end up waiting a long time.- Just fd -> do- return $ do- threadWaitRead fd `catch` (throwIO . setIOErrorLocation)- loop #else -- This case fixes the race condition above. By registering -- our interest in the descriptor before we drop the lock,
src/Database/PostgreSQL/Simple/Ok.hs view
@@ -37,6 +37,8 @@ import Control.Monad(MonadPlus(..)) import Data.Typeable +import qualified Control.Monad.Fail as Fail+ -- FIXME: [SomeException] should probably be something else, maybe -- a difference list (or a tree?) @@ -70,13 +72,14 @@ mplus = (<|>) instance Monad Ok where-#if !(MIN_VERSION_base(4,8,0))- return = pure-#endif- Errors es >>= _ = Errors es Ok a >>= f = f a +#if !(MIN_VERSION_base(4,13,0))+ fail = Fail.fail+#endif++instance Fail.MonadFail Ok where fail str = Errors [SomeException (ErrorCall str)] -- | a way to reify a list of exceptions into a single exception
src/Database/PostgreSQL/Simple/Range.hs view
@@ -19,6 +19,7 @@ , empty , isEmpty, isEmptyBy , contains, containsBy+ , fromFieldRange ) where import Control.Applicative hiding (empty)@@ -37,7 +38,7 @@ import Data.Scientific (Scientific) import qualified Data.Text.Lazy.Builder as LT import qualified Data.Text.Lazy.Encoding as LT-import Data.Time (Day, LocalTime,+import Data.Time.Compat (Day, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime,@@ -109,19 +110,19 @@ PGRange _lb NegInfinity -> False PGRange lb ub -> checkLB lb x && checkUB ub x where- checkLB lb x =+ checkLB lb y = case lb of NegInfinity -> True PosInfinity -> False- Inclusive a -> cmp a x /= GT- Exclusive a -> cmp a x == LT+ Inclusive a -> cmp a y /= GT+ Exclusive a -> cmp a y == LT - checkUB ub x =+ checkUB ub y = case ub of NegInfinity -> False PosInfinity -> True- Inclusive z -> cmp x z /= GT- Exclusive z -> cmp x z == LT+ Inclusive z -> cmp y z /= GT+ Exclusive z -> cmp y z == LT lowerBound :: Parser (a -> RangeBound a) lowerBound = (A.char '(' *> pure Exclusive) <|> (A.char '[' *> pure Inclusive)@@ -189,7 +190,10 @@ instance (FromField a, Typeable a) => FromField (PGRange a) where- fromField f mdat = do+ fromField = fromFieldRange fromField++fromFieldRange :: Typeable a => FieldParser a -> FieldParser (PGRange a)+fromFieldRange fromField' f mdat = do info <- typeInfo f case info of Range{} ->@@ -199,8 +203,8 @@ Just "empty" -> pure $ empty Just bs -> let parseIt NegInfinity = pure NegInfinity- parseIt (Inclusive v) = Inclusive <$> fromField f' (Just v)- parseIt (Exclusive v) = Exclusive <$> fromField f' (Just v)+ parseIt (Inclusive v) = Inclusive <$> fromField' f' (Just v)+ parseIt (Exclusive v) = Exclusive <$> fromField' f' (Just v) parseIt PosInfinity = pure PosInfinity in case parseOnly pgrange bs of Left e -> returnError ConversionFailed f e
src/Database/PostgreSQL/Simple/SqlQQ.hs view
@@ -1,4 +1,9 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE TemplateHaskellQuotes #-}+#else {-# LANGUAGE TemplateHaskell #-}+#endif ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.SqlQQ@@ -30,7 +35,7 @@ -- > (beginTime,endTime,string) -- -- This quasiquoter returns a literal string expression of type 'Query',--- and attempts to mimimize whitespace; otherwise the above query would+-- and attempts to minimize whitespace; otherwise the above query would -- consist of approximately half whitespace when sent to the database -- backend. It also recognizes and strips out standard sql comments "--". --@@ -52,13 +57,10 @@ sql :: QuasiQuoter sql = QuasiQuoter- { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql:\- \ quasiquoter used in pattern context"- , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql:\- \ quasiquoter used in type context"+ { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in pattern context"+ , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in type context" , quoteExp = sqlExp- , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql:\- \ quasiquoter used in declaration context"+ , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in declaration context" } sqlExp :: String -> Q Exp@@ -85,5 +87,4 @@ instring ('\'':'\'':xs) = '\'':'\'': instring xs instring ('\'':xs) = '\'': insql xs instring (x:xs) = x : instring xs- instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql:\- \ string literal not terminated"+ instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql: string literal not terminated"
src/Database/PostgreSQL/Simple/Time.hs view
@@ -227,6 +227,7 @@ , parseUTCTimestamp , parseZonedTimestamp , parseLocalTimestamp+ , parseCalendarDiffTime , dayToBuilder , utcTimeToBuilder , zonedTimeToBuilder@@ -239,6 +240,7 @@ , localTimestampToBuilder , unboundedToBuilder , nominalDiffTimeToBuilder+ , calendarDiffTimeToBuilder ) where import Database.PostgreSQL.Simple.Time.Implementation
src/Database/PostgreSQL/Simple/Time/Implementation.hs view
@@ -18,7 +18,8 @@ import Control.Arrow((***)) import Control.Applicative import qualified Data.ByteString as B-import Data.Time hiding (getTimeZone, getZonedTime)+import Data.Time.Compat (LocalTime, UTCTime, ZonedTime, Day, TimeOfDay, TimeZone, NominalDiffTime, utc)+import Data.Time.LocalTime.Compat (CalendarDiffTime) import Data.Typeable import Data.Maybe (fromMaybe) import qualified Data.Attoparsec.ByteString.Char8 as A@@ -77,6 +78,9 @@ parseDate :: B.ByteString -> Either String Date parseDate = A.parseOnly (getDate <* A.endOfInput) +parseCalendarDiffTime :: B.ByteString -> Either String CalendarDiffTime+parseCalendarDiffTime = A.parseOnly (getCalendarDiffTime <* A.endOfInput)+ getUnbounded :: A.Parser a -> A.Parser (Unbounded a) getUnbounded getFinite = (pure NegInfinity <* A.string "-infinity")@@ -125,6 +129,9 @@ getUTCTimestamp :: A.Parser UTCTimestamp getUTCTimestamp = getUnbounded getUTCTime +getCalendarDiffTime :: A.Parser CalendarDiffTime+getCalendarDiffTime = TP.calendarDiffTime+ dayToBuilder :: Day -> Builder dayToBuilder = primBounded TPP.day @@ -164,3 +171,6 @@ nominalDiffTimeToBuilder :: NominalDiffTime -> Builder nominalDiffTimeToBuilder = TPP.nominalDiffTime++calendarDiffTimeToBuilder :: CalendarDiffTime -> Builder+calendarDiffTimeToBuilder = TPP.calendarDiffTime
src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs view
@@ -21,20 +21,24 @@ , localToUTCTimeOfDayHMS , utcTime , zonedTime+ , calendarDiffTime ) where import Control.Applicative ((<$>), (<*>), (<*), (*>)) import Database.PostgreSQL.Simple.Compat (toPico) import Data.Attoparsec.ByteString.Char8 as A import Data.Bits ((.&.))+import Data.ByteString (ByteString) import Data.Char (ord) import Data.Fixed (Pico) import Data.Int (Int64) import Data.Maybe (fromMaybe)-import Data.Time.Calendar (Day, fromGregorianValid, addDays)-import Data.Time.Clock (UTCTime(..))+import Data.Time.Calendar.Compat (Day, fromGregorianValid, addDays)+import Data.Time.Clock.Compat (UTCTime(..))+import Data.Time.Format.ISO8601.Compat (iso8601ParseM)+import Data.Time.LocalTime.Compat (CalendarDiffTime) import qualified Data.ByteString.Char8 as B8-import qualified Data.Time.LocalTime as Local+import qualified Data.Time.LocalTime.Compat as Local -- | Parse a date of the form @YYYY-MM-DD@. day :: Parser Day@@ -193,3 +197,8 @@ utc :: Local.TimeZone utc = Local.TimeZone 0 False ""++calendarDiffTime :: Parser CalendarDiffTime+calendarDiffTime = do+ contents <- takeByteString+ iso8601ParseM $ B8.unpack contents
src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs view
@@ -17,19 +17,23 @@ , localTime , zonedTime , nominalDiffTime+ , calendarDiffTime ) where import Control.Arrow ((>>>))-import Data.ByteString.Builder (Builder, integerDec)+import Data.ByteString.Builder (Builder, byteString, integerDec) import Data.ByteString.Builder.Prim ( liftFixedToBounded, (>$<), (>*<) , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec) import Data.Char ( chr ) import Data.Int ( Int32, Int64 )-import Data.Time+import Data.String (fromString)+import Data.Time.Compat ( UTCTime(..), ZonedTime(..), LocalTime(..), NominalDiffTime , Day, toGregorian, TimeOfDay(..), timeToTimeOfDay , TimeZone, timeZoneMinutes )+import Data.Time.Format.ISO8601.Compat (iso8601Show)+import Data.Time.LocalTime.Compat (CalendarDiffTime) import Database.PostgreSQL.Simple.Compat ((<>), fromPico) import Unsafe.Coerce (unsafeCoerce) @@ -71,7 +75,7 @@ year :: BoundedPrim Int32-year = condB (> 10000) int32Dec (checkBCE >$< liftB digits4)+year = condB (>= 10000) int32Dec (checkBCE >$< liftB digits4) where checkBCE :: Int32 -> Int checkBCE y@@ -121,3 +125,11 @@ nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y)) where (x,y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000++calendarDiffTime :: CalendarDiffTime -> Builder+calendarDiffTime = byteString+ . fromString+ -- from the docs: "Beware: fromString truncates multi-byte characters to octets".+ -- However, I think this is a safe usage, because ISO8601-encoding seems restricted+ -- to ASCII output.+ . iso8601Show
src/Database/PostgreSQL/Simple/ToField.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE PolyKinds #-} ------------------------------------------------------------------------------ -- |@@ -22,6 +23,7 @@ , inQuotes ) where +import Control.Applicative (Const(Const)) import qualified Data.Aeson as JSON import Data.ByteString (ByteString) import Data.ByteString.Builder@@ -30,10 +32,12 @@ , wordDec, word8Dec, word16Dec, word32Dec, word64Dec , floatDec, doubleDec )+import Data.Functor.Identity (Identity(Identity)) import Data.Int (Int8, Int16, Int32, Int64) import Data.List (intersperse) import Data.Monoid (mappend)-import Data.Time (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime)+import Data.Time.Compat (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime)+import Data.Time.LocalTime.Compat (CalendarDiffTime) import Data.Typeable (Typeable) import Data.Word (Word, Word8, Word16, Word32, Word64) import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow@@ -42,6 +46,8 @@ import qualified Data.ByteString as SB import qualified Data.ByteString.Lazy as LB+import Data.CaseInsensitive (CI)+import qualified Data.CaseInsensitive as CI import qualified Data.Text as ST import qualified Data.Text.Encoding as ST import qualified Data.Text.Lazy as LT@@ -53,11 +59,7 @@ import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.Time import Data.Scientific (Scientific)-#if MIN_VERSION_scientific(0,3,0) import Data.Text.Lazy.Builder.Scientific (scientificBuilder)-#else-import Data.Scientific (scientificBuilder)-#endif import Foreign.C.Types (CUInt(..)) -- | How to render an element when substituting it into a query.@@ -98,6 +100,14 @@ toField a = a {-# INLINE toField #-} +instance (ToField a) => ToField (Const a b) where+ toField (Const a) = toField a+ {-# INLINE toField #-}++instance (ToField a) => ToField (Identity a) where+ toField (Identity a) = toField a+ {-# INLINE toField #-}+ instance (ToField a) => ToField (Maybe a) where toField Nothing = renderNull toField (Just a) = toField a@@ -230,7 +240,16 @@ toField = toField . LT.toStrict {-# INLINE toField #-} +-- | citext+instance ToField (CI ST.Text) where+ toField = toField . CI.original+ {-# INLINE toField #-} +-- | citext+instance ToField (CI LT.Text) where+ toField = toField . LT.toStrict . CI.original+ {-# INLINE toField #-}+ instance ToField UTCTime where toField = Plain . inQuotes . utcTimeToBuilder {-# INLINE toField #-}@@ -271,6 +290,10 @@ toField = Plain . inQuotes . nominalDiffTimeToBuilder {-# INLINE toField #-} +instance ToField CalendarDiffTime where+ toField = Plain . inQuotes . calendarDiffTimeToBuilder+ {-# INLINE toField #-}+ instance (ToField a) => ToField (PGArray a) where toField pgArray = case fromPGArray pgArray of@@ -291,14 +314,13 @@ instance ToField JSON.Value where toField = toField . JSON.encode --- | Convert a Haskell value to a JSON 'JSON.Value' using--- 'JSON.toJSON' and convert that to a field using 'toField'.+-- | Convert a Haskell value to JSON using 'JSON.toEncoding'. -- -- This can be used as the default implementation for the 'toField' -- method for Haskell types that have a JSON representation in -- PostgreSQL. toJSONField :: JSON.ToJSON a => a -> Action-toJSONField = toField . JSON.toJSON+toJSONField = toField . JSON.encode -- | Surround a string with single-quote characters: \"@'@\" --@@ -308,7 +330,7 @@ where quote = char8 '\'' interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b]-interleaveFoldr f b bs as = foldr (\a bs -> b : f a bs) bs as+interleaveFoldr f b bs' as = foldr (\a bs -> b : f a bs) bs' as {-# INLINE interleaveFoldr #-} instance ToRow a => ToField (Values a) where@@ -355,8 +377,8 @@ typedRows :: ToRow a => [a] -> [QualifiedIdentifier] -> [Action] -> [Action] typedRows [] _ _ = error funcname- typedRows (val:vals) types rest =- typedRow (toRow val) types (multiRows vals rest)+ typedRows (val:vals) typs rest =+ typedRow (toRow val) typs (multiRows vals rest) untypedRows :: ToRow a => [a] -> [Action] -> [Action] untypedRows [] _ = error funcname
src/Database/PostgreSQL/Simple/ToRow.hs view
@@ -30,6 +30,22 @@ -- -- Instances should use the 'toField' method of the 'ToField' class -- to perform conversion of each element of the collection.+--+-- You can derive 'ToRow' for your data type using GHC generics, like this:+--+-- @+-- \{-# LANGUAGE DeriveAnyClass \#-}+-- \{-# LANGUAGE DeriveGeneric \#-}+--+-- import "GHC.Generics" ('GHC.Generics.Generic')+-- import "Database.PostgreSQL.Simple" ('ToRow')+--+-- data User = User { name :: String, fileQuota :: Int }+-- deriving ('GHC.Generics.Generic', 'ToRow')+-- @+--+-- Note that this only works for product types (e.g. records) and does not+-- support sum types or recursive types. class ToRow a where toRow :: a -> [Action] default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action]@@ -88,6 +104,96 @@ toRow (a,b,c,d,e,f,g,h,i,j) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h, toField i, toField j]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,+ ToField g, ToField h, ToField i, ToField j, ToField k)+ => ToRow (a,b,c,d,e,f,g,h,i,j,k) where+ toRow (a,b,c,d,e,f,g,h,i,j,k) =+ [toField a, toField b, toField c, toField d, toField e, toField f,+ toField g, toField h, toField i, toField j, toField k]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l)+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l) where+ toRow (a,b,c,d,e,f,g,h,i,j,k,l) =+ [toField a, toField b, toField c, toField d, toField e, toField f,+ toField g, toField h, toField i, toField j, toField k, toField l]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,+ ToField m)+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m) where+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m) =+ [toField a, toField b, toField c, toField d, toField e, toField f,+ toField g, toField h, toField i, toField j, toField k, toField l,+ toField m]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,+ ToField m, ToField n)+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n) =+ [toField a, toField b, toField c, toField d, toField e, toField f,+ toField g, toField h, toField i, toField j, toField k, toField l,+ toField m, toField n]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,+ ToField m, ToField n, ToField o)+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) =+ [toField a, toField b, toField c, toField d, toField e, toField f,+ toField g, toField h, toField i, toField j, toField k, toField l,+ toField m, toField n, toField o]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,+ ToField m, ToField n, ToField o, ToField p)+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) =+ [toField a, toField b, toField c, toField d, toField e, toField f,+ toField g, toField h, toField i, toField j, toField k, toField l,+ toField m, toField n, toField o, toField p]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,+ ToField m, ToField n, ToField o, ToField p, ToField q)+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) where+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) =+ [toField a, toField b, toField c, toField d, toField e, toField f,+ toField g, toField h, toField i, toField j, toField k, toField l,+ toField m, toField n, toField o, toField p, toField q]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,+ ToField m, ToField n, ToField o, ToField p, ToField q, ToField r)+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) where+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) =+ [toField a, toField b, toField c, toField d, toField e, toField f,+ toField g, toField h, toField i, toField j, toField k, toField l,+ toField m, toField n, toField o, toField p, toField q, toField r]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,+ ToField m, ToField n, ToField o, ToField p, ToField q, ToField r,+ ToField s)+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) where+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) =+ [toField a, toField b, toField c, toField d, toField e, toField f,+ toField g, toField h, toField i, toField j, toField k, toField l,+ toField m, toField n, toField o, toField p, toField q, toField r,+ toField s]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,+ ToField m, ToField n, ToField o, ToField p, ToField q, ToField r,+ ToField s, ToField t)+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) where+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) =+ [toField a, toField b, toField c, toField d, toField e, toField f,+ toField g, toField h, toField i, toField j, toField k, toField l,+ toField m, toField n, toField o, toField p, toField q, toField r,+ toField s, toField t] instance (ToField a) => ToRow [a] where toRow = map toField
src/Database/PostgreSQL/Simple/Transaction.hs view
@@ -17,6 +17,7 @@ , withTransactionLevel , withTransactionMode , withTransactionModeRetry+ , withTransactionModeRetry' , withTransactionSerializable , TransactionMode(..) , IsolationLevel(..)@@ -146,37 +147,40 @@ commit conn return r +-- | 'withTransactionModeRetry'' but with the exception type pinned to 'SqlError'.+withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a+withTransactionModeRetry = withTransactionModeRetry'+ -- | Like 'withTransactionMode', but also takes a custom callback to--- determine if a transaction should be retried if an 'SqlError' occurs.--- If the callback returns True, then the transaction will be retried.--- If the callback returns False, or an exception other than an 'SqlError'+-- determine if a transaction should be retried if an exception occurs.+-- If the callback returns 'True', then the transaction will be retried.+-- If the callback returns 'False', or an exception other than an @e@ -- occurs then the transaction will be rolled back and the exception rethrown. -- -- This is used to implement 'withTransactionSerializable'.-withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a-withTransactionModeRetry mode shouldRetry conn act =+withTransactionModeRetry' :: forall a e. E.Exception e => TransactionMode -> (e -> Bool) -> Connection -> IO a -> IO a+withTransactionModeRetry' mode shouldRetry conn act = mask $ \restore -> retryLoop $ E.try $ do- a <- restore act+ a <- restore act `E.onException` rollback_ conn commit conn return a where- retryLoop :: IO (Either E.SomeException a) -> IO a+ retryLoop :: IO (Either e a) -> IO a retryLoop act' = do beginMode mode conn r <- act' case r of- Left e -> do- rollback_ conn- case fmap shouldRetry (E.fromException e) of- Just True -> retryLoop act'- _ -> E.throwIO e+ Left e ->+ case shouldRetry e of+ True -> retryLoop act'+ False -> E.throwIO e Right a -> return a -- | Rollback a transaction. rollback :: Connection -> IO ()-rollback conn = execute_ conn "ABORT" >> return ()+rollback conn = execute_ conn "ROLLBACK" >> return () -- | Rollback a transaction, ignoring any @IOErrors@ rollback_ :: Connection -> IO ()
src/Database/PostgreSQL/Simple/TypeInfo.hs view
@@ -50,21 +50,21 @@ -- in the connections's cache. getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo-getTypeInfo conn@Connection{..} oid =- case staticTypeInfo oid of- Just name -> return name- Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid+getTypeInfo conn@Connection{..} oid' =+ case staticTypeInfo oid' of+ Just name' -> return name'+ Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid' getTypeInfo' :: Connection -> PQ.Oid -> TypeInfoCache -> IO (TypeInfoCache, TypeInfo)-getTypeInfo' conn oid oidmap =- case IntMap.lookup (oid2int oid) oidmap of+getTypeInfo' conn oid' oidmap =+ case IntMap.lookup (oid2int oid') oidmap of Just typeinfo -> return (oidmap, typeinfo) Nothing -> do names <- query conn "SELECT oid, typcategory, typdelim, typname,\ \ typelem, typrelid\ \ FROM pg_type WHERE oid = ?"- (Only oid)+ (Only oid') (oidmap', typeInfo) <- case names of [] -> return $ throw (fatalError "invalid type oid")@@ -78,7 +78,7 @@ rngsubtypeOids <- query conn "SELECT rngsubtype\ \ FROM pg_range\ \ WHERE rngtypid = ?"- (Only oid)+ (Only oid') case rngsubtypeOids of [Only rngsubtype_] -> do (oidmap', rngsubtype) <-@@ -104,7 +104,7 @@ _ -> fail "typename query returned more than one result" -- oid is a primary key, so the query should -- never return more than one result- let !oidmap'' = IntMap.insert (oid2int oid) typeInfo oidmap'+ let !oidmap'' = IntMap.insert (oid2int oid') typeInfo oidmap' return $! (oidmap'', typeInfo) getAttInfos :: Connection -> [(B.ByteString, PQ.Oid)] -> TypeInfoCache
src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs view
@@ -1,4 +1,9 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE TemplateHaskellQuotes #-}+#else {-# LANGUAGE TemplateHaskell #-}+#endif ------------------------------------------------------------------------------ -- |@@ -22,11 +27,12 @@ import Database.PostgreSQL.Simple.Types (Oid(..)) import Language.Haskell.TH - -- | Returns an expression that has type @'Oid' -> 'Bool'@, true if the -- oid is equal to any one of the 'typoid's of the given 'TypeInfo's. mkCompats :: [TypeInfo] -> ExpQ-mkCompats tys = [| \(Oid x) -> $(caseE [| x |] (map alt tys ++ [catchAll])) |]+mkCompats tys = do+ x <- newName "x"+ lamE [conP 'Oid [varP x]] $ caseE (varE x) (map alt tys ++ [catchAll]) where alt :: TypeInfo -> MatchQ alt ty = match (inlineTypoidP ty) (normalB [| True |]) []@@ -38,7 +44,7 @@ -- Returns an expression of type 'Oid'. Useful because GHC tends -- not to fold constants. inlineTypoid :: TypeInfo -> ExpQ-inlineTypoid ty = [| Oid $(litE (getTypoid ty)) |]+inlineTypoid ty = conE 'Oid `appE` litE (getTypoid ty) inlineTypoidP :: TypeInfo -> PatQ inlineTypoidP ty = litP (getTypoid ty)
src/Database/PostgreSQL/Simple/TypeInfo/Static.hs view
@@ -19,119 +19,233 @@ ( TypeInfo(..) , staticTypeInfo , bool+ , boolOid , bytea+ , byteaOid , char+ , charOid , name+ , nameOid , int8+ , int8Oid , int2+ , int2Oid , int4+ , int4Oid , regproc+ , regprocOid , text+ , textOid , oid+ , oidOid , tid+ , tidOid , xid+ , xidOid , cid+ , cidOid , xml+ , xmlOid , point+ , pointOid , lseg+ , lsegOid , path+ , pathOid , box+ , boxOid , polygon+ , polygonOid , line+ , lineOid , cidr+ , cidrOid , float4+ , float4Oid , float8+ , float8Oid , unknown+ , unknownOid , circle+ , circleOid , money+ , moneyOid , macaddr+ , macaddrOid , inet+ , inetOid , bpchar+ , bpcharOid , varchar+ , varcharOid , date+ , dateOid , time+ , timeOid , timestamp+ , timestampOid , timestamptz+ , timestamptzOid , interval+ , intervalOid , timetz+ , timetzOid , bit+ , bitOid , varbit+ , varbitOid , numeric+ , numericOid , refcursor+ , refcursorOid , record+ , recordOid , void+ , voidOid , array_record+ , array_recordOid , regprocedure+ , regprocedureOid , regoper+ , regoperOid , regoperator+ , regoperatorOid , regclass+ , regclassOid , regtype+ , regtypeOid , uuid+ , uuidOid , json+ , jsonOid , jsonb+ , jsonbOid , int2vector+ , int2vectorOid , oidvector+ , oidvectorOid , array_xml+ , array_xmlOid , array_json+ , array_jsonOid , array_line+ , array_lineOid , array_cidr+ , array_cidrOid , array_circle+ , array_circleOid , array_money+ , array_moneyOid , array_bool+ , array_boolOid , array_bytea+ , array_byteaOid , array_char+ , array_charOid , array_name+ , array_nameOid , array_int2+ , array_int2Oid , array_int2vector+ , array_int2vectorOid , array_int4+ , array_int4Oid , array_regproc+ , array_regprocOid , array_text+ , array_textOid , array_tid+ , array_tidOid , array_xid+ , array_xidOid , array_cid+ , array_cidOid , array_oidvector+ , array_oidvectorOid , array_bpchar+ , array_bpcharOid , array_varchar+ , array_varcharOid , array_int8+ , array_int8Oid , array_point+ , array_pointOid , array_lseg+ , array_lsegOid , array_path+ , array_pathOid , array_box+ , array_boxOid , array_float4+ , array_float4Oid , array_float8+ , array_float8Oid , array_polygon+ , array_polygonOid , array_oid+ , array_oidOid , array_macaddr+ , array_macaddrOid , array_inet+ , array_inetOid , array_timestamp+ , array_timestampOid , array_date+ , array_dateOid , array_time+ , array_timeOid , array_timestamptz+ , array_timestamptzOid , array_interval+ , array_intervalOid , array_numeric+ , array_numericOid , array_timetz+ , array_timetzOid , array_bit+ , array_bitOid , array_varbit+ , array_varbitOid , array_refcursor+ , array_refcursorOid , array_regprocedure+ , array_regprocedureOid , array_regoper+ , array_regoperOid , array_regoperator+ , array_regoperatorOid , array_regclass+ , array_regclassOid , array_regtype+ , array_regtypeOid , array_uuid+ , array_uuidOid , array_jsonb+ , array_jsonbOid , int4range+ , int4rangeOid , _int4range+ , _int4rangeOid , numrange+ , numrangeOid , _numrange+ , _numrangeOid , tsrange+ , tsrangeOid , _tsrange+ , _tsrangeOid , tstzrange+ , tstzrangeOid , _tstzrange+ , _tstzrangeOid , daterange+ , daterangeOid , _daterange+ , _daterangeOid , int8range+ , int8rangeOid , _int8range+ , _int8rangeOid ) where import Database.PostgreSQL.LibPQ (Oid(..))@@ -257,976 +371,1432 @@ bool :: TypeInfo bool = Basic {- typoid = Oid 16,+ typoid = boolOid, typcategory = 'B', typdelim = ',', typname = "bool" } +boolOid :: Oid+boolOid = Oid 16+{-# INLINE boolOid #-}+ bytea :: TypeInfo bytea = Basic {- typoid = Oid 17,+ typoid = byteaOid, typcategory = 'U', typdelim = ',', typname = "bytea" } +byteaOid :: Oid+byteaOid = Oid 17+{-# INLINE byteaOid #-}+ char :: TypeInfo char = Basic {- typoid = Oid 18,+ typoid = charOid, typcategory = 'S', typdelim = ',', typname = "char" } +charOid :: Oid+charOid = Oid 18+{-# INLINE charOid #-}+ name :: TypeInfo name = Basic {- typoid = Oid 19,+ typoid = nameOid, typcategory = 'S', typdelim = ',', typname = "name" } +nameOid :: Oid+nameOid = Oid 19+{-# INLINE nameOid #-}+ int8 :: TypeInfo int8 = Basic {- typoid = Oid 20,+ typoid = int8Oid, typcategory = 'N', typdelim = ',', typname = "int8" } +int8Oid :: Oid+int8Oid = Oid 20+{-# INLINE int8Oid #-}+ int2 :: TypeInfo int2 = Basic {- typoid = Oid 21,+ typoid = int2Oid, typcategory = 'N', typdelim = ',', typname = "int2" } +int2Oid :: Oid+int2Oid = Oid 21+{-# INLINE int2Oid #-}+ int4 :: TypeInfo int4 = Basic {- typoid = Oid 23,+ typoid = int4Oid, typcategory = 'N', typdelim = ',', typname = "int4" } +int4Oid :: Oid+int4Oid = Oid 23+{-# INLINE int4Oid #-}+ regproc :: TypeInfo regproc = Basic {- typoid = Oid 24,+ typoid = regprocOid, typcategory = 'N', typdelim = ',', typname = "regproc" } +regprocOid :: Oid+regprocOid = Oid 24+{-# INLINE regprocOid #-}+ text :: TypeInfo text = Basic {- typoid = Oid 25,+ typoid = textOid, typcategory = 'S', typdelim = ',', typname = "text" } +textOid :: Oid+textOid = Oid 25+{-# INLINE textOid #-}+ oid :: TypeInfo oid = Basic {- typoid = Oid 26,+ typoid = oidOid, typcategory = 'N', typdelim = ',', typname = "oid" } +oidOid :: Oid+oidOid = Oid 26+{-# INLINE oidOid #-}+ tid :: TypeInfo tid = Basic {- typoid = Oid 27,+ typoid = tidOid, typcategory = 'U', typdelim = ',', typname = "tid" } +tidOid :: Oid+tidOid = Oid 27+{-# INLINE tidOid #-}+ xid :: TypeInfo xid = Basic {- typoid = Oid 28,+ typoid = xidOid, typcategory = 'U', typdelim = ',', typname = "xid" } +xidOid :: Oid+xidOid = Oid 28+{-# INLINE xidOid #-}+ cid :: TypeInfo cid = Basic {- typoid = Oid 29,+ typoid = cidOid, typcategory = 'U', typdelim = ',', typname = "cid" } +cidOid :: Oid+cidOid = Oid 29+{-# INLINE cidOid #-}+ xml :: TypeInfo xml = Basic {- typoid = Oid 142,+ typoid = xmlOid, typcategory = 'U', typdelim = ',', typname = "xml" } +xmlOid :: Oid+xmlOid = Oid 142+{-# INLINE xmlOid #-}+ point :: TypeInfo point = Basic {- typoid = Oid 600,+ typoid = pointOid, typcategory = 'G', typdelim = ',', typname = "point" } +pointOid :: Oid+pointOid = Oid 600+{-# INLINE pointOid #-}+ lseg :: TypeInfo lseg = Basic {- typoid = Oid 601,+ typoid = lsegOid, typcategory = 'G', typdelim = ',', typname = "lseg" } +lsegOid :: Oid+lsegOid = Oid 601+{-# INLINE lsegOid #-}+ path :: TypeInfo path = Basic {- typoid = Oid 602,+ typoid = pathOid, typcategory = 'G', typdelim = ',', typname = "path" } +pathOid :: Oid+pathOid = Oid 602+{-# INLINE pathOid #-}+ box :: TypeInfo box = Basic {- typoid = Oid 603,+ typoid = boxOid, typcategory = 'G', typdelim = ';', typname = "box" } +boxOid :: Oid+boxOid = Oid 603+{-# INLINE boxOid #-}+ polygon :: TypeInfo polygon = Basic {- typoid = Oid 604,+ typoid = polygonOid, typcategory = 'G', typdelim = ',', typname = "polygon" } +polygonOid :: Oid+polygonOid = Oid 604+{-# INLINE polygonOid #-}+ line :: TypeInfo line = Basic {- typoid = Oid 628,+ typoid = lineOid, typcategory = 'G', typdelim = ',', typname = "line" } +lineOid :: Oid+lineOid = Oid 628+{-# INLINE lineOid #-}+ cidr :: TypeInfo cidr = Basic {- typoid = Oid 650,+ typoid = cidrOid, typcategory = 'I', typdelim = ',', typname = "cidr" } +cidrOid :: Oid+cidrOid = Oid 650+{-# INLINE cidrOid #-}+ float4 :: TypeInfo float4 = Basic {- typoid = Oid 700,+ typoid = float4Oid, typcategory = 'N', typdelim = ',', typname = "float4" } +float4Oid :: Oid+float4Oid = Oid 700+{-# INLINE float4Oid #-}+ float8 :: TypeInfo float8 = Basic {- typoid = Oid 701,+ typoid = float8Oid, typcategory = 'N', typdelim = ',', typname = "float8" } +float8Oid :: Oid+float8Oid = Oid 701+{-# INLINE float8Oid #-}+ unknown :: TypeInfo unknown = Basic {- typoid = Oid 705,+ typoid = unknownOid, typcategory = 'X', typdelim = ',', typname = "unknown" } +unknownOid :: Oid+unknownOid = Oid 705+{-# INLINE unknownOid #-}+ circle :: TypeInfo circle = Basic {- typoid = Oid 718,+ typoid = circleOid, typcategory = 'G', typdelim = ',', typname = "circle" } +circleOid :: Oid+circleOid = Oid 718+{-# INLINE circleOid #-}+ money :: TypeInfo money = Basic {- typoid = Oid 790,+ typoid = moneyOid, typcategory = 'N', typdelim = ',', typname = "money" } +moneyOid :: Oid+moneyOid = Oid 790+{-# INLINE moneyOid #-}+ macaddr :: TypeInfo macaddr = Basic {- typoid = Oid 829,+ typoid = macaddrOid, typcategory = 'U', typdelim = ',', typname = "macaddr" } +macaddrOid :: Oid+macaddrOid = Oid 829+{-# INLINE macaddrOid #-}+ inet :: TypeInfo inet = Basic {- typoid = Oid 869,+ typoid = inetOid, typcategory = 'I', typdelim = ',', typname = "inet" } +inetOid :: Oid+inetOid = Oid 869+{-# INLINE inetOid #-}+ bpchar :: TypeInfo bpchar = Basic {- typoid = Oid 1042,+ typoid = bpcharOid, typcategory = 'S', typdelim = ',', typname = "bpchar" } +bpcharOid :: Oid+bpcharOid = Oid 1042+{-# INLINE bpcharOid #-}+ varchar :: TypeInfo varchar = Basic {- typoid = Oid 1043,+ typoid = varcharOid, typcategory = 'S', typdelim = ',', typname = "varchar" } +varcharOid :: Oid+varcharOid = Oid 1043+{-# INLINE varcharOid #-}+ date :: TypeInfo date = Basic {- typoid = Oid 1082,+ typoid = dateOid, typcategory = 'D', typdelim = ',', typname = "date" } +dateOid :: Oid+dateOid = Oid 1082+{-# INLINE dateOid #-}+ time :: TypeInfo time = Basic {- typoid = Oid 1083,+ typoid = timeOid, typcategory = 'D', typdelim = ',', typname = "time" } +timeOid :: Oid+timeOid = Oid 1083+{-# INLINE timeOid #-}+ timestamp :: TypeInfo timestamp = Basic {- typoid = Oid 1114,+ typoid = timestampOid, typcategory = 'D', typdelim = ',', typname = "timestamp" } +timestampOid :: Oid+timestampOid = Oid 1114+{-# INLINE timestampOid #-}+ timestamptz :: TypeInfo timestamptz = Basic {- typoid = Oid 1184,+ typoid = timestamptzOid, typcategory = 'D', typdelim = ',', typname = "timestamptz" } +timestamptzOid :: Oid+timestamptzOid = Oid 1184+{-# INLINE timestamptzOid #-}+ interval :: TypeInfo interval = Basic {- typoid = Oid 1186,+ typoid = intervalOid, typcategory = 'T', typdelim = ',', typname = "interval" } +intervalOid :: Oid+intervalOid = Oid 1186+{-# INLINE intervalOid #-}+ timetz :: TypeInfo timetz = Basic {- typoid = Oid 1266,+ typoid = timetzOid, typcategory = 'D', typdelim = ',', typname = "timetz" } +timetzOid :: Oid+timetzOid = Oid 1266+{-# INLINE timetzOid #-}+ bit :: TypeInfo bit = Basic {- typoid = Oid 1560,+ typoid = bitOid, typcategory = 'V', typdelim = ',', typname = "bit" } +bitOid :: Oid+bitOid = Oid 1560+{-# INLINE bitOid #-}+ varbit :: TypeInfo varbit = Basic {- typoid = Oid 1562,+ typoid = varbitOid, typcategory = 'V', typdelim = ',', typname = "varbit" } +varbitOid :: Oid+varbitOid = Oid 1562+{-# INLINE varbitOid #-}+ numeric :: TypeInfo numeric = Basic {- typoid = Oid 1700,+ typoid = numericOid, typcategory = 'N', typdelim = ',', typname = "numeric" } +numericOid :: Oid+numericOid = Oid 1700+{-# INLINE numericOid #-}+ refcursor :: TypeInfo refcursor = Basic {- typoid = Oid 1790,+ typoid = refcursorOid, typcategory = 'U', typdelim = ',', typname = "refcursor" } +refcursorOid :: Oid+refcursorOid = Oid 1790+{-# INLINE refcursorOid #-}+ record :: TypeInfo record = Basic {- typoid = Oid 2249,+ typoid = recordOid, typcategory = 'P', typdelim = ',', typname = "record" } +recordOid :: Oid+recordOid = Oid 2249+{-# INLINE recordOid #-}+ void :: TypeInfo void = Basic {- typoid = Oid 2278,+ typoid = voidOid, typcategory = 'P', typdelim = ',', typname = "void" } +voidOid :: Oid+voidOid = Oid 2278+{-# INLINE voidOid #-}+ array_record :: TypeInfo array_record = Array {- typoid = Oid 2287,+ typoid = array_recordOid, typcategory = 'P', typdelim = ',', typname = "_record", typelem = record } +array_recordOid :: Oid+array_recordOid = Oid 2287+{-# INLINE array_recordOid #-}+ regprocedure :: TypeInfo regprocedure = Basic {- typoid = Oid 2202,+ typoid = regprocedureOid, typcategory = 'N', typdelim = ',', typname = "regprocedure" } +regprocedureOid :: Oid+regprocedureOid = Oid 2202+{-# INLINE regprocedureOid #-}+ regoper :: TypeInfo regoper = Basic {- typoid = Oid 2203,+ typoid = regoperOid, typcategory = 'N', typdelim = ',', typname = "regoper" } +regoperOid :: Oid+regoperOid = Oid 2203+{-# INLINE regoperOid #-}+ regoperator :: TypeInfo regoperator = Basic {- typoid = Oid 2204,+ typoid = regoperatorOid, typcategory = 'N', typdelim = ',', typname = "regoperator" } +regoperatorOid :: Oid+regoperatorOid = Oid 2204+{-# INLINE regoperatorOid #-}+ regclass :: TypeInfo regclass = Basic {- typoid = Oid 2205,+ typoid = regclassOid, typcategory = 'N', typdelim = ',', typname = "regclass" } +regclassOid :: Oid+regclassOid = Oid 2205+{-# INLINE regclassOid #-}+ regtype :: TypeInfo regtype = Basic {- typoid = Oid 2206,+ typoid = regtypeOid, typcategory = 'N', typdelim = ',', typname = "regtype" } +regtypeOid :: Oid+regtypeOid = Oid 2206+{-# INLINE regtypeOid #-}+ uuid :: TypeInfo uuid = Basic {- typoid = Oid 2950,+ typoid = uuidOid, typcategory = 'U', typdelim = ',', typname = "uuid" } +uuidOid :: Oid+uuidOid = Oid 2950+{-# INLINE uuidOid #-}+ json :: TypeInfo json = Basic {- typoid = Oid 114,+ typoid = jsonOid, typcategory = 'U', typdelim = ',', typname = "json" } +jsonOid :: Oid+jsonOid = Oid 114+{-# INLINE jsonOid #-}+ jsonb :: TypeInfo jsonb = Basic {- typoid = Oid 3802,+ typoid = jsonbOid, typcategory = 'U', typdelim = ',', typname = "jsonb" } +jsonbOid :: Oid+jsonbOid = Oid 3802+{-# INLINE jsonbOid #-}+ int2vector :: TypeInfo int2vector = Array {- typoid = Oid 22,+ typoid = int2vectorOid, typcategory = 'A', typdelim = ',', typname = "int2vector", typelem = int2 } +int2vectorOid :: Oid+int2vectorOid = Oid 22+{-# INLINE int2vectorOid #-}+ oidvector :: TypeInfo oidvector = Array {- typoid = Oid 30,+ typoid = oidvectorOid, typcategory = 'A', typdelim = ',', typname = "oidvector", typelem = oid } +oidvectorOid :: Oid+oidvectorOid = Oid 30+{-# INLINE oidvectorOid #-}+ array_xml :: TypeInfo array_xml = Array {- typoid = Oid 143,+ typoid = array_xmlOid, typcategory = 'A', typdelim = ',', typname = "_xml", typelem = xml } +array_xmlOid :: Oid+array_xmlOid = Oid 143+{-# INLINE array_xmlOid #-}+ array_json :: TypeInfo array_json = Array {- typoid = Oid 199,+ typoid = array_jsonOid, typcategory = 'A', typdelim = ',', typname = "_json", typelem = json } +array_jsonOid :: Oid+array_jsonOid = Oid 199+{-# INLINE array_jsonOid #-}+ array_line :: TypeInfo array_line = Array {- typoid = Oid 629,+ typoid = array_lineOid, typcategory = 'A', typdelim = ',', typname = "_line", typelem = line } +array_lineOid :: Oid+array_lineOid = Oid 629+{-# INLINE array_lineOid #-}+ array_cidr :: TypeInfo array_cidr = Array {- typoid = Oid 651,+ typoid = array_cidrOid, typcategory = 'A', typdelim = ',', typname = "_cidr", typelem = cidr } +array_cidrOid :: Oid+array_cidrOid = Oid 651+{-# INLINE array_cidrOid #-}+ array_circle :: TypeInfo array_circle = Array {- typoid = Oid 719,+ typoid = array_circleOid, typcategory = 'A', typdelim = ',', typname = "_circle", typelem = circle } +array_circleOid :: Oid+array_circleOid = Oid 719+{-# INLINE array_circleOid #-}+ array_money :: TypeInfo array_money = Array {- typoid = Oid 791,+ typoid = array_moneyOid, typcategory = 'A', typdelim = ',', typname = "_money", typelem = money } +array_moneyOid :: Oid+array_moneyOid = Oid 791+{-# INLINE array_moneyOid #-}+ array_bool :: TypeInfo array_bool = Array {- typoid = Oid 1000,+ typoid = array_boolOid, typcategory = 'A', typdelim = ',', typname = "_bool", typelem = bool } +array_boolOid :: Oid+array_boolOid = Oid 1000+{-# INLINE array_boolOid #-}+ array_bytea :: TypeInfo array_bytea = Array {- typoid = Oid 1001,+ typoid = array_byteaOid, typcategory = 'A', typdelim = ',', typname = "_bytea", typelem = bytea } +array_byteaOid :: Oid+array_byteaOid = Oid 1001+{-# INLINE array_byteaOid #-}+ array_char :: TypeInfo array_char = Array {- typoid = Oid 1002,+ typoid = array_charOid, typcategory = 'A', typdelim = ',', typname = "_char", typelem = char } +array_charOid :: Oid+array_charOid = Oid 1002+{-# INLINE array_charOid #-}+ array_name :: TypeInfo array_name = Array {- typoid = Oid 1003,+ typoid = array_nameOid, typcategory = 'A', typdelim = ',', typname = "_name", typelem = name } +array_nameOid :: Oid+array_nameOid = Oid 1003+{-# INLINE array_nameOid #-}+ array_int2 :: TypeInfo array_int2 = Array {- typoid = Oid 1005,+ typoid = array_int2Oid, typcategory = 'A', typdelim = ',', typname = "_int2", typelem = int2 } +array_int2Oid :: Oid+array_int2Oid = Oid 1005+{-# INLINE array_int2Oid #-}+ array_int2vector :: TypeInfo array_int2vector = Array {- typoid = Oid 1006,+ typoid = array_int2vectorOid, typcategory = 'A', typdelim = ',', typname = "_int2vector", typelem = int2vector } +array_int2vectorOid :: Oid+array_int2vectorOid = Oid 1006+{-# INLINE array_int2vectorOid #-}+ array_int4 :: TypeInfo array_int4 = Array {- typoid = Oid 1007,+ typoid = array_int4Oid, typcategory = 'A', typdelim = ',', typname = "_int4", typelem = int4 } +array_int4Oid :: Oid+array_int4Oid = Oid 1007+{-# INLINE array_int4Oid #-}+ array_regproc :: TypeInfo array_regproc = Array {- typoid = Oid 1008,+ typoid = array_regprocOid, typcategory = 'A', typdelim = ',', typname = "_regproc", typelem = regproc } +array_regprocOid :: Oid+array_regprocOid = Oid 1008+{-# INLINE array_regprocOid #-}+ array_text :: TypeInfo array_text = Array {- typoid = Oid 1009,+ typoid = array_textOid, typcategory = 'A', typdelim = ',', typname = "_text", typelem = text } +array_textOid :: Oid+array_textOid = Oid 1009+{-# INLINE array_textOid #-}+ array_tid :: TypeInfo array_tid = Array {- typoid = Oid 1010,+ typoid = array_tidOid, typcategory = 'A', typdelim = ',', typname = "_tid", typelem = tid } +array_tidOid :: Oid+array_tidOid = Oid 1010+{-# INLINE array_tidOid #-}+ array_xid :: TypeInfo array_xid = Array {- typoid = Oid 1011,+ typoid = array_xidOid, typcategory = 'A', typdelim = ',', typname = "_xid", typelem = xid } +array_xidOid :: Oid+array_xidOid = Oid 1011+{-# INLINE array_xidOid #-}+ array_cid :: TypeInfo array_cid = Array {- typoid = Oid 1012,+ typoid = array_cidOid, typcategory = 'A', typdelim = ',', typname = "_cid", typelem = cid } +array_cidOid :: Oid+array_cidOid = Oid 1012+{-# INLINE array_cidOid #-}+ array_oidvector :: TypeInfo array_oidvector = Array {- typoid = Oid 1013,+ typoid = array_oidvectorOid, typcategory = 'A', typdelim = ',', typname = "_oidvector", typelem = oidvector } +array_oidvectorOid :: Oid+array_oidvectorOid = Oid 1013+{-# INLINE array_oidvectorOid #-}+ array_bpchar :: TypeInfo array_bpchar = Array {- typoid = Oid 1014,+ typoid = array_bpcharOid, typcategory = 'A', typdelim = ',', typname = "_bpchar", typelem = bpchar } +array_bpcharOid :: Oid+array_bpcharOid = Oid 1014+{-# INLINE array_bpcharOid #-}+ array_varchar :: TypeInfo array_varchar = Array {- typoid = Oid 1015,+ typoid = array_varcharOid, typcategory = 'A', typdelim = ',', typname = "_varchar", typelem = varchar } +array_varcharOid :: Oid+array_varcharOid = Oid 1015+{-# INLINE array_varcharOid #-}+ array_int8 :: TypeInfo array_int8 = Array {- typoid = Oid 1016,+ typoid = array_int8Oid, typcategory = 'A', typdelim = ',', typname = "_int8", typelem = int8 } +array_int8Oid :: Oid+array_int8Oid = Oid 1016+{-# INLINE array_int8Oid #-}+ array_point :: TypeInfo array_point = Array {- typoid = Oid 1017,+ typoid = array_pointOid, typcategory = 'A', typdelim = ',', typname = "_point", typelem = point } +array_pointOid :: Oid+array_pointOid = Oid 1017+{-# INLINE array_pointOid #-}+ array_lseg :: TypeInfo array_lseg = Array {- typoid = Oid 1018,+ typoid = array_lsegOid, typcategory = 'A', typdelim = ',', typname = "_lseg", typelem = lseg } +array_lsegOid :: Oid+array_lsegOid = Oid 1018+{-# INLINE array_lsegOid #-}+ array_path :: TypeInfo array_path = Array {- typoid = Oid 1019,+ typoid = array_pathOid, typcategory = 'A', typdelim = ',', typname = "_path", typelem = path } +array_pathOid :: Oid+array_pathOid = Oid 1019+{-# INLINE array_pathOid #-}+ array_box :: TypeInfo array_box = Array {- typoid = Oid 1020,+ typoid = array_boxOid, typcategory = 'A', typdelim = ';', typname = "_box", typelem = box } +array_boxOid :: Oid+array_boxOid = Oid 1020+{-# INLINE array_boxOid #-}+ array_float4 :: TypeInfo array_float4 = Array {- typoid = Oid 1021,+ typoid = array_float4Oid, typcategory = 'A', typdelim = ',', typname = "_float4", typelem = float4 } +array_float4Oid :: Oid+array_float4Oid = Oid 1021+{-# INLINE array_float4Oid #-}+ array_float8 :: TypeInfo array_float8 = Array {- typoid = Oid 1022,+ typoid = array_float8Oid, typcategory = 'A', typdelim = ',', typname = "_float8", typelem = float8 } +array_float8Oid :: Oid+array_float8Oid = Oid 1022+{-# INLINE array_float8Oid #-}+ array_polygon :: TypeInfo array_polygon = Array {- typoid = Oid 1027,+ typoid = array_polygonOid, typcategory = 'A', typdelim = ',', typname = "_polygon", typelem = polygon } +array_polygonOid :: Oid+array_polygonOid = Oid 1027+{-# INLINE array_polygonOid #-}+ array_oid :: TypeInfo array_oid = Array {- typoid = Oid 1028,+ typoid = array_oidOid, typcategory = 'A', typdelim = ',', typname = "_oid", typelem = oid } +array_oidOid :: Oid+array_oidOid = Oid 1028+{-# INLINE array_oidOid #-}+ array_macaddr :: TypeInfo array_macaddr = Array {- typoid = Oid 1040,+ typoid = array_macaddrOid, typcategory = 'A', typdelim = ',', typname = "_macaddr", typelem = macaddr } +array_macaddrOid :: Oid+array_macaddrOid = Oid 1040+{-# INLINE array_macaddrOid #-}+ array_inet :: TypeInfo array_inet = Array {- typoid = Oid 1041,+ typoid = array_inetOid, typcategory = 'A', typdelim = ',', typname = "_inet", typelem = inet } +array_inetOid :: Oid+array_inetOid = Oid 1041+{-# INLINE array_inetOid #-}+ array_timestamp :: TypeInfo array_timestamp = Array {- typoid = Oid 1115,+ typoid = array_timestampOid, typcategory = 'A', typdelim = ',', typname = "_timestamp", typelem = timestamp } +array_timestampOid :: Oid+array_timestampOid = Oid 1115+{-# INLINE array_timestampOid #-}+ array_date :: TypeInfo array_date = Array {- typoid = Oid 1182,+ typoid = array_dateOid, typcategory = 'A', typdelim = ',', typname = "_date", typelem = date } +array_dateOid :: Oid+array_dateOid = Oid 1182+{-# INLINE array_dateOid #-}+ array_time :: TypeInfo array_time = Array {- typoid = Oid 1183,+ typoid = array_timeOid, typcategory = 'A', typdelim = ',', typname = "_time", typelem = time } +array_timeOid :: Oid+array_timeOid = Oid 1183+{-# INLINE array_timeOid #-}+ array_timestamptz :: TypeInfo array_timestamptz = Array {- typoid = Oid 1185,+ typoid = array_timestamptzOid, typcategory = 'A', typdelim = ',', typname = "_timestamptz", typelem = timestamptz } +array_timestamptzOid :: Oid+array_timestamptzOid = Oid 1185+{-# INLINE array_timestamptzOid #-}+ array_interval :: TypeInfo array_interval = Array {- typoid = Oid 1187,+ typoid = array_intervalOid, typcategory = 'A', typdelim = ',', typname = "_interval", typelem = interval } +array_intervalOid :: Oid+array_intervalOid = Oid 1187+{-# INLINE array_intervalOid #-}+ array_numeric :: TypeInfo array_numeric = Array {- typoid = Oid 1231,+ typoid = array_numericOid, typcategory = 'A', typdelim = ',', typname = "_numeric", typelem = numeric } +array_numericOid :: Oid+array_numericOid = Oid 1231+{-# INLINE array_numericOid #-}+ array_timetz :: TypeInfo array_timetz = Array {- typoid = Oid 1270,+ typoid = array_timetzOid, typcategory = 'A', typdelim = ',', typname = "_timetz", typelem = timetz } +array_timetzOid :: Oid+array_timetzOid = Oid 1270+{-# INLINE array_timetzOid #-}+ array_bit :: TypeInfo array_bit = Array {- typoid = Oid 1561,+ typoid = array_bitOid, typcategory = 'A', typdelim = ',', typname = "_bit", typelem = bit } +array_bitOid :: Oid+array_bitOid = Oid 1561+{-# INLINE array_bitOid #-}+ array_varbit :: TypeInfo array_varbit = Array {- typoid = Oid 1563,+ typoid = array_varbitOid, typcategory = 'A', typdelim = ',', typname = "_varbit", typelem = varbit } +array_varbitOid :: Oid+array_varbitOid = Oid 1563+{-# INLINE array_varbitOid #-}+ array_refcursor :: TypeInfo array_refcursor = Array {- typoid = Oid 2201,+ typoid = array_refcursorOid, typcategory = 'A', typdelim = ',', typname = "_refcursor", typelem = refcursor } +array_refcursorOid :: Oid+array_refcursorOid = Oid 2201+{-# INLINE array_refcursorOid #-}+ array_regprocedure :: TypeInfo array_regprocedure = Array {- typoid = Oid 2207,+ typoid = array_regprocedureOid, typcategory = 'A', typdelim = ',', typname = "_regprocedure", typelem = regprocedure } +array_regprocedureOid :: Oid+array_regprocedureOid = Oid 2207+{-# INLINE array_regprocedureOid #-}+ array_regoper :: TypeInfo array_regoper = Array {- typoid = Oid 2208,+ typoid = array_regoperOid, typcategory = 'A', typdelim = ',', typname = "_regoper", typelem = regoper } +array_regoperOid :: Oid+array_regoperOid = Oid 2208+{-# INLINE array_regoperOid #-}+ array_regoperator :: TypeInfo array_regoperator = Array {- typoid = Oid 2209,+ typoid = array_regoperatorOid, typcategory = 'A', typdelim = ',', typname = "_regoperator", typelem = regoperator } +array_regoperatorOid :: Oid+array_regoperatorOid = Oid 2209+{-# INLINE array_regoperatorOid #-}+ array_regclass :: TypeInfo array_regclass = Array {- typoid = Oid 2210,+ typoid = array_regclassOid, typcategory = 'A', typdelim = ',', typname = "_regclass", typelem = regclass } +array_regclassOid :: Oid+array_regclassOid = Oid 2210+{-# INLINE array_regclassOid #-}+ array_regtype :: TypeInfo array_regtype = Array {- typoid = Oid 2211,+ typoid = array_regtypeOid, typcategory = 'A', typdelim = ',', typname = "_regtype", typelem = regtype } +array_regtypeOid :: Oid+array_regtypeOid = Oid 2211+{-# INLINE array_regtypeOid #-}+ array_uuid :: TypeInfo array_uuid = Array {- typoid = Oid 2951,+ typoid = array_uuidOid, typcategory = 'A', typdelim = ',', typname = "_uuid", typelem = uuid } +array_uuidOid :: Oid+array_uuidOid = Oid 2951+{-# INLINE array_uuidOid #-}+ array_jsonb :: TypeInfo array_jsonb = Array {- typoid = Oid 3807,+ typoid = array_jsonbOid, typcategory = 'A', typdelim = ',', typname = "_jsonb", typelem = jsonb } +array_jsonbOid :: Oid+array_jsonbOid = Oid 3807+{-# INLINE array_jsonbOid #-}+ int4range :: TypeInfo int4range = Range {- typoid = Oid 3904,+ typoid = int4rangeOid, typcategory = 'R', typdelim = ',', typname = "int4range", rngsubtype = int4 } +int4rangeOid :: Oid+int4rangeOid = Oid 3904+{-# INLINE int4rangeOid #-}+ _int4range :: TypeInfo _int4range = Array {- typoid = Oid 3905,+ typoid = _int4rangeOid, typcategory = 'A', typdelim = ',', typname = "_int4range", typelem = int4range } +_int4rangeOid :: Oid+_int4rangeOid = Oid 3905+{-# INLINE _int4rangeOid #-}+ numrange :: TypeInfo numrange = Range {- typoid = Oid 3906,+ typoid = numrangeOid, typcategory = 'R', typdelim = ',', typname = "numrange", rngsubtype = numeric } +numrangeOid :: Oid+numrangeOid = Oid 3906+{-# INLINE numrangeOid #-}+ _numrange :: TypeInfo _numrange = Array {- typoid = Oid 3907,+ typoid = _numrangeOid, typcategory = 'A', typdelim = ',', typname = "_numrange", typelem = numrange } +_numrangeOid :: Oid+_numrangeOid = Oid 3907+{-# INLINE _numrangeOid #-}+ tsrange :: TypeInfo tsrange = Range {- typoid = Oid 3908,+ typoid = tsrangeOid, typcategory = 'R', typdelim = ',', typname = "tsrange", rngsubtype = timestamp } +tsrangeOid :: Oid+tsrangeOid = Oid 3908+{-# INLINE tsrangeOid #-}+ _tsrange :: TypeInfo _tsrange = Array {- typoid = Oid 3909,+ typoid = _tsrangeOid, typcategory = 'A', typdelim = ',', typname = "_tsrange", typelem = tsrange } +_tsrangeOid :: Oid+_tsrangeOid = Oid 3909+{-# INLINE _tsrangeOid #-}+ tstzrange :: TypeInfo tstzrange = Range {- typoid = Oid 3910,+ typoid = tstzrangeOid, typcategory = 'R', typdelim = ',', typname = "tstzrange", rngsubtype = timestamptz } +tstzrangeOid :: Oid+tstzrangeOid = Oid 3910+{-# INLINE tstzrangeOid #-}+ _tstzrange :: TypeInfo _tstzrange = Array {- typoid = Oid 3911,+ typoid = _tstzrangeOid, typcategory = 'A', typdelim = ',', typname = "_tstzrange", typelem = tstzrange } +_tstzrangeOid :: Oid+_tstzrangeOid = Oid 3911+{-# INLINE _tstzrangeOid #-}+ daterange :: TypeInfo daterange = Range {- typoid = Oid 3912,+ typoid = daterangeOid, typcategory = 'R', typdelim = ',', typname = "daterange", rngsubtype = date } +daterangeOid :: Oid+daterangeOid = Oid 3912+{-# INLINE daterangeOid #-}+ _daterange :: TypeInfo _daterange = Array {- typoid = Oid 3913,+ typoid = _daterangeOid, typcategory = 'A', typdelim = ',', typname = "_daterange", typelem = daterange } +_daterangeOid :: Oid+_daterangeOid = Oid 3913+{-# INLINE _daterangeOid #-}+ int8range :: TypeInfo int8range = Range {- typoid = Oid 3926,+ typoid = int8rangeOid, typcategory = 'R', typdelim = ',', typname = "int8range", rngsubtype = int8 } +int8rangeOid :: Oid+int8rangeOid = Oid 3926+{-# INLINE int8rangeOid #-}+ _int8range :: TypeInfo _int8range = Array {- typoid = Oid 3927,+ typoid = _int8rangeOid, typcategory = 'A', typdelim = ',', typname = "_int8range", typelem = int8range }++_int8rangeOid :: Oid+_int8rangeOid = Oid 3927+{-# INLINE _int8rangeOid #-}
src/Database/PostgreSQL/Simple/Types.hs view
@@ -42,6 +42,7 @@ import qualified Data.ByteString as B import Data.Text (Text) import qualified Data.Text as T+import Data.Tuple.Only (Only(..)) import Database.PostgreSQL.LibPQ (Oid(..)) import Database.PostgreSQL.Simple.Compat (toByteString) @@ -49,10 +50,6 @@ data Null = Null deriving (Read, Show, Typeable) -instance Eq Null where- _ == _ = False- _ /= _ = False- -- | A placeholder for the PostgreSQL @DEFAULT@ value. data Default = Default deriving (Read, Show, Typeable)@@ -96,26 +93,6 @@ instance Monoid Query where mempty = Query B.empty-#if !(MIN_VERSION_base(4,11,0))- mappend = (<>)-#endif---- | A single-value \"collection\".------ This is useful if you need to supply a single parameter to a SQL--- query, or extract a single column from a SQL result.------ Parameter example:------ @query c \"select x from scores where x > ?\" ('Only' (42::Int))@------ Result example:------ @xs <- query_ c \"select id from users\"---forM_ xs $ \\('Only' id) -> {- ... -}@-newtype Only a = Only {- fromOnly :: a- } deriving (Eq, Ord, Read, Show, Typeable, Functor) -- | Wrap a list of values for use in an @IN@ clause. Replaces a -- single \"@?@\" character with a parenthesized list of rendered
+ src/Database/PostgreSQL/Simple/Vector.hs view
@@ -0,0 +1,45 @@+-- | 'query' variants returning 'V.Vector'.+module Database.PostgreSQL.Simple.Vector where++import Database.PostgreSQL.Simple (Connection, formatQuery, formatMany)+import Database.PostgreSQL.Simple.FromRow (FromRow(..))+import Database.PostgreSQL.Simple.ToRow (ToRow(..))+import Database.PostgreSQL.Simple.Internal (RowParser, exec)+import Database.PostgreSQL.Simple.Internal.PQResultUtils+import Database.PostgreSQL.Simple.Types ( Query (..) )++import qualified Data.Vector as V++-- | Perform a @SELECT@ or other SQL query that is expected to return+-- results. All results are retrieved and converted before this+-- function returns.+query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO (V.Vector r)+query = queryWith fromRow++-- | A version of 'query' that does not perform query substitution.+query_ :: (FromRow r) => Connection -> Query -> IO (V.Vector r)+query_ = queryWith_ fromRow++-- | A version of 'query' taking parser as argument+queryWith :: ToRow q => RowParser r -> Connection -> Query -> q -> IO (V.Vector r)+queryWith parser conn template qs = do+ result <- exec conn =<< formatQuery conn template qs+ finishQueryWithV parser conn template result++-- | A version of 'query_' taking parser as argument+queryWith_ :: RowParser r -> Connection -> Query -> IO (V.Vector r)+queryWith_ parser conn q@(Query que) = do+ result <- exec conn que+ finishQueryWithV parser conn q result++-- | Execute @INSERT ... RETURNING@, @UPDATE ... RETURNING@, or other SQL+-- query that accepts multi-row input and is expected to return results.+returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO (V.Vector r)+returning = returningWith fromRow++-- | A version of 'returning' taking parser as argument+returningWith :: (ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO (V.Vector r)+returningWith _ _ _ [] = return V.empty+returningWith parser conn q qs = do+ result <- exec conn =<< formatMany conn q qs+ finishQueryWithV parser conn q result
+ src/Database/PostgreSQL/Simple/Vector/Unboxed.hs view
@@ -0,0 +1,44 @@+module Database.PostgreSQL.Simple.Vector.Unboxed where++import Database.PostgreSQL.Simple (Connection, formatQuery, formatMany)+import Database.PostgreSQL.Simple.FromRow (FromRow(..))+import Database.PostgreSQL.Simple.ToRow (ToRow(..))+import Database.PostgreSQL.Simple.Internal (RowParser, exec)+import Database.PostgreSQL.Simple.Internal.PQResultUtils+import Database.PostgreSQL.Simple.Types ( Query (..) )++import qualified Data.Vector.Unboxed as VU++-- | Perform a @SELECT@ or other SQL query that is expected to return+-- results. All results are retrieved and converted before this+-- function returns.+query :: (ToRow q, FromRow r, VU.Unbox r) => Connection -> Query -> q -> IO (VU.Vector r)+query = queryWith fromRow++-- | A version of 'query' that does not perform query substitution.+query_ :: (FromRow r, VU.Unbox r) => Connection -> Query -> IO (VU.Vector r)+query_ = queryWith_ fromRow++-- | A version of 'query' taking parser as argument+queryWith :: (ToRow q, VU.Unbox r) => RowParser r -> Connection -> Query -> q -> IO (VU.Vector r)+queryWith parser conn template qs = do+ result <- exec conn =<< formatQuery conn template qs+ finishQueryWithVU parser conn template result++-- | A version of 'query_' taking parser as argument+queryWith_ :: VU.Unbox r => RowParser r -> Connection -> Query -> IO (VU.Vector r)+queryWith_ parser conn q@(Query que) = do+ result <- exec conn que+ finishQueryWithVU parser conn q result++-- | Execute @INSERT ... RETURNING@, @UPDATE ... RETURNING@, or other SQL+-- query that accepts multi-row input and is expected to return results.+returning :: (ToRow q, FromRow r, VU.Unbox r) => Connection -> Query -> [q] -> IO (VU.Vector r)+returning = returningWith fromRow++-- | A version of 'returning' taking parser as argument+returningWith :: (ToRow q, VU.Unbox r) => RowParser r -> Connection -> Query -> [q] -> IO (VU.Vector r)+returningWith _ _ _ [] = return VU.empty+returningWith parser conn q qs = do+ result <- exec conn =<< formatMany conn q qs+ finishQueryWithVU parser conn q result
+ test/Exception.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Exception (testExceptions) where++import Database.PostgreSQL.Simple+import Test.Tasty.HUnit (Assertion, assertBool)+import Common (TestEnv)+import Control.Exception (Exception (..), SomeException)+import Data.Maybe (isJust)+import Data.Either (isLeft)+import Control.Exception (throwIO, try)++testExceptions :: TestEnv -> Assertion+testExceptions _ = do+ let sqlError = SqlError+ { sqlState = ""+ , sqlExecStatus = FatalError+ , sqlErrorMsg = ""+ , sqlErrorDetail = ""+ , sqlErrorHint = ""+ }+ let sqlEx :: SomeException = toException sqlError+ assertBool "SqlError is SomePostgreSqlException" $ isJust (fromException sqlEx :: Maybe SomePostgreSqlException)+ assertBool "SqlError is SqlError" $ isJust (fromException sqlEx :: Maybe SqlError)+ eSqlError :: Either SqlError () <- try $ throwIO sqlEx+ assertBool "Can catch SqlError" $ isLeft eSqlError+ eSqlPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO sqlEx+ assertBool "Can catch SomePostgreSqlException from SqlError" $ isLeft eSqlPostgreSqlEx++ let formatError = FormatError+ { fmtMessage = ""+ , fmtQuery = ""+ , fmtParams = []+ }+ let formatEx :: SomeException = toException formatError+ assertBool "FormatError is SomePostgreSqlException" $ isJust (fromException formatEx :: Maybe SomePostgreSqlException)+ assertBool "FormatError is FormatError" $ isJust (fromException formatEx :: Maybe FormatError)+ eFormatError :: Either FormatError () <- try $ throwIO formatEx+ assertBool "Can catch FormatError" $ isLeft eFormatError+ eFormatPostreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO formatEx+ assertBool "Can catch SomePostgreSqlException from FormatError" $ isLeft eFormatPostreSqlEx++ let queryError = QueryError+ { qeMessage = ""+ , qeQuery = ""+ }+ let queryEx :: SomeException = toException queryError+ assertBool "QueryError is SomePostgreSqlException" $ isJust (fromException queryEx :: Maybe SomePostgreSqlException)+ assertBool "QueryError is QueryError" $ isJust (fromException queryEx :: Maybe QueryError)+ eQueryError :: Either QueryError () <- try $ throwIO queryEx+ assertBool "Can catch QueryError" $ isLeft eQueryError+ eQueryPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO queryEx+ assertBool "Can catch SomePostgreSqlException from QueryError" $ isLeft eQueryPostgreSqlEx++ let resultError = Incompatible+ { errSQLType = ""+ , errSQLTableOid = Nothing+ , errSQLField = ""+ , errHaskellType = ""+ , errMessage = ""+ }+ let resultEx :: SomeException = toException resultError+ assertBool "ResultError is SomePostgreSqlException" $ isJust (fromException resultEx :: Maybe SomePostgreSqlException)+ assertBool "ResultError is ResultError" $ isJust (fromException resultEx :: Maybe ResultError)+ eResultEx :: Either ResultError () <- try $ throwIO resultEx+ assertBool "Can catch ResultError" $ isLeft eResultEx+ eResultPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO resultEx+ assertBool "Can catch SomePostgreSqlException from ResultError" $ isLeft eResultPostgreSqlEx
+ test/Inspection.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -dsuppress-idinfo -dsuppress-coercions -dsuppress-type-applications -dsuppress-module-prefixes -dsuppress-type-signatures #-}+-- {-# OPTIONS_GHC -dsuppress-uniques #-}+{-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin #-}+module Main where++import Test.Inspection+import Test.Tasty+import Test.Tasty.HUnit++import qualified Database.PostgreSQL.LibPQ as PQ+import Database.PostgreSQL.Simple.FromField+import Database.PostgreSQL.Simple.TypeInfo as TI+import Database.PostgreSQL.Simple.TypeInfo.Macro+import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI++-------------------------------------------------------------------------------+-- Inspection tests+-------------------------------------------------------------------------------++-- # doesn't work :(+#define TH_MKCOMPATS3(a,b,c) $(mkCompats [TI.a,TI.b,TI.c])+#define IN_MKCOMPATS3(a,b,c) (eq TI.a \/ eq TI.b \/ eq TI.c)++#define TH_INLINETYPOID(n) eq $(inlineTypoid TI.n)+#define IN_INLINETYPOID(n) eq TI.n++-- eta-expansion is required+lhs01, rhs01 :: PQ.Oid -> Bool+lhs01 = TH_MKCOMPATS3(name,text,char)+rhs01 = IN_MKCOMPATS3(nameOid,textOid,charOid)++lhs02, rhs02 :: PQ.Oid -> Bool+lhs02 = TH_INLINETYPOID(name)+rhs02 = IN_INLINETYPOID(nameOid)++eq :: PQ.Oid -> PQ.Oid -> Bool+eq = (==)+{-# INLINE eq #-}++infixr 2 \/+(\/) :: (PQ.Oid -> Bool)+ -> (PQ.Oid -> Bool)+ -> (PQ.Oid -> Bool)+f \/ g = \x -> f x || g x+{-# INLINE (\/) #-}++inspectionTests :: TestTree+inspectionTests = testGroup "inspection"+ [ testCase "mkCompats" $+ assertSuccess $(inspectTest $ 'lhs01 === 'rhs01)+ + -- byteaOid isn't inlined?+ , testCase "inlineTypoid" $+#if __GLASGOW_HASKELL__ >= 808+ assertSuccess+#else+ assertFailure'+#endif+ $(inspectTest $ 'lhs02 ==- 'rhs02)+ ]++assertSuccess :: Result -> IO ()+assertSuccess (Success _) = return ()+assertSuccess (Failure err) = assertFailure err++assertFailure' :: Result -> IO ()+assertFailure' (Success err) = assertFailure err+assertFailure' (Failure _) = return ()++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++main :: IO ()+main = defaultMain $ testGroup "tests"+ [ inspectionTests+ ]
+ test/Interval.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE QuasiQuotes #-}++{-++Testing strategies:++fromString . toString == id ** Todo?++toString . fromString == almost id ** Todo?++postgresql -> haskell -> postgresql * Done++haskell -> postgresql -> haskell ** Todo?++But still, what we really want to establish is that the two values+correspond; for example, a conversion that consistently added hour+when printed to a string and subtracted an hour when parsed from string+would still pass these tests.+++Right now, we are checking that 1400+ timestamps in the range of 1860 to+2060 round trip from postgresql to haskell and back in 5 different timezones.+In addition to UTC, the four timezones were selected so that 2 have a positive+offset, and 2 have a negative offset, and that 2 have an offset of a+whole number of hours, while the other two do not.++It may be worth adding a few more timezones to ensure better test coverage.++We are checking a handful of selected timestamps to ensure we hit+various corner-cases in the code, in addition to 1400 timestamps randomly+generated with granularity of seconds down to microseconds in powers of ten.++-}++module Interval (testInterval) where++import Common+import Control.Monad(forM_, replicateM_)+import Data.Time.Compat+import Data.Time.LocalTime.Compat (CalendarDiffTime(..))+import Data.ByteString(ByteString)+import Database.PostgreSQL.Simple.SqlQQ++data IntervalTestCase = IntervalTestCase+ { label :: String+ , inputMonths :: Integer+ , inputSeconds :: NominalDiffTime+ , asText :: String+ }+ deriving (Eq, Show)++testInterval :: TestEnv -> Assertion+testInterval env@TestEnv{..} = do++ initializeTable env++ let milliseconds = 0.001+ seconds = 1+ minutes = 60 * seconds+ hours = 60 * minutes+ days = 24 * hours+ weeks = 7 * days+ months = 1+ years = 12 * months++ mapM (checkRoundTrip env)+ [ IntervalTestCase+ { label = "zero"+ , inputMonths = 0+ , inputSeconds = 0+ , asText = "PT0"+ }+ , IntervalTestCase+ { label = "1 year"+ , inputMonths = 1 * years+ , inputSeconds = 0+ , asText = "P1Y"+ }+ , IntervalTestCase+ { label = "2 months"+ , inputMonths = 2 * months+ , inputSeconds = 0+ , asText = "P2M"+ }+ , IntervalTestCase+ { label = "3 weeks"+ , inputMonths = 0+ , inputSeconds = 3 * weeks+ , asText = "P3W"+ }+ , IntervalTestCase+ { label = "4 days"+ , inputMonths = 0+ , inputSeconds = 4 * days+ , asText = "P4D"+ }+ , IntervalTestCase+ { label = "5 hours"+ , inputMonths = 0+ , inputSeconds = 5 * hours+ , asText = "PT5H"+ }+ , IntervalTestCase+ { label = "6 minutes"+ , inputMonths = 0+ , inputSeconds = 6 * minutes+ , asText = "PT6M"+ }+ , IntervalTestCase+ { label = "7 seconds"+ , inputMonths = 0+ , inputSeconds = 7 * seconds+ , asText = "PT7S"+ }+ , IntervalTestCase+ { label = "8 milliseconds"+ , inputMonths = 0+ , inputSeconds = 8 * milliseconds+ , asText = "PT0.008S"+ }+ , IntervalTestCase+ { label = "combination of intervals (day-size or bigger)"+ , inputMonths = 2 * years + 4 * months+ , inputSeconds = 3 * weeks + 5 * days+ , asText = "P2Y4M3W5D"+ }+ , IntervalTestCase+ { label = "combination of intervals (smaller than day-size)"+ , inputMonths = 0+ , inputSeconds = 18 * hours + 56 * minutes + 23 * seconds + 563 * milliseconds+ , asText = "PT18H56M23.563S"+ }+ , IntervalTestCase+ { label = "full combination of intervals"+ , inputMonths = 2 * years + 4 * months+ , inputSeconds = 3 * weeks + 5 * days + 18 * hours + 56 * minutes + 23 * seconds + 563 * milliseconds+ , asText = "P2Y4M3W5DT18H56M23.563S"+ }+ ]++ return ()++initializeTable :: TestEnv -> IO ()+initializeTable TestEnv{..} = withTransaction conn $ do+ execute_ conn+ [sql| CREATE TEMPORARY TABLE testinterval+ ( id serial, sample interval, PRIMARY KEY(id) ) |]++ return ()++checkRoundTrip :: TestEnv -> IntervalTestCase -> IO ()+checkRoundTrip TestEnv{..} IntervalTestCase{..} = do++ let input = CalendarDiffTime+ { ctMonths = inputMonths+ , ctTime = inputSeconds+ }++ [(returnedId :: Int, output :: CalendarDiffTime)] <- query conn [sql|+ INSERT INTO testinterval (sample)+ VALUES (?)+ RETURNING id, sample+ |] (Only input)++ assertBool ("CalendarDiffTime did not round-trip from Haskell to SQL and back (" ++ label ++ ")") $+ output == input++ [(Only isExpectedIso)] <- query conn [sql|+ SELECT sample = (?)::interval+ FROM testinterval+ WHERE id = ?+ |] (asText, returnedId)++ assertBool ("CalendarDiffTime inserted did not match ISO8601 equivalent \"" ++ asText ++ "\". (" ++ label ++ ")")+ isExpectedIso+
test/Main.hs view
@@ -3,26 +3,42 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE ScopedTypeVariables #-}+#if __GLASGOW_HASKELL__ >= 806+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DeriveAnyClass #-}+#endif+module Main (main) where+ import Common+import Database.PostgreSQL.Simple.Copy+import Database.PostgreSQL.Simple.ToField (ToField) import Database.PostgreSQL.Simple.FromField (FromField)-import Database.PostgreSQL.Simple.Types(Query(..),Values(..)) import Database.PostgreSQL.Simple.HStore-import Database.PostgreSQL.Simple.Copy+import Database.PostgreSQL.Simple.Newtypes+import Database.PostgreSQL.Simple.Internal (breakOnSingleQuestionMark)+import Database.PostgreSQL.Simple.Types(Query(..),Values(..), PGArray(..)) import qualified Database.PostgreSQL.Simple.Transaction as ST import Control.Applicative import Control.Exception as E import Control.Monad import Data.Char-import Data.List (sort)+import Data.Foldable (toList)+import Data.List (concat, sort) import Data.IORef+import Data.Monoid ((<>))+import Data.String (fromString) import Data.Typeable import GHC.Generics (Generic) import Data.Aeson import Data.ByteString (ByteString) import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy.Char8 as BL+import Data.CaseInsensitive (CI)+import qualified Data.CaseInsensitive as CI import Data.Map (Map) import qualified Data.Map as Map import Data.Text(Text)@@ -30,37 +46,46 @@ import qualified Data.Vector as V import System.FilePath import System.Timeout(timeout)-import Data.Time(getCurrentTime, diffUTCTime)+import Data.Time.Compat (getCurrentTime, diffUTCTime)+import System.Environment (getEnvironment) import Test.Tasty import Test.Tasty.Golden import Notify import Serializable import Time+import Interval+import Exception (testExceptions) tests :: TestEnv -> TestTree tests env = testGroup "tests" $ map ($ env) [ testBytea- , testCase "ExecuteMany" . testExecuteMany- , testCase "Fold" . testFold- , testCase "Notify" . testNotify- , testCase "Serializable" . testSerializable- , testCase "Time" . testTime- , testCase "Array" . testArray- , testCase "Array of nullables" . testNullableArray- , testCase "HStore" . testHStore- , testCase "JSON" . testJSON- , testCase "Savepoint" . testSavepoint- , testCase "Unicode" . testUnicode- , testCase "Values" . testValues- , testCase "Copy" . testCopy+ , testCase "ExecuteMany" . testExecuteMany+ , testCase "Fold" . testFold+ , testCase "Notify" . testNotify+ , testCase "Serializable" . testSerializable+ , testCase "Time" . testTime+ , testCase "Interval" . testInterval+ , testCase "Array" . testArray+ , testCase "Array of nullables" . testNullableArray+ , testCase "HStore" . testHStore+ , testCase "citext" . testCIText+ , testCase "JSON" . testJSON+ , testCase "Aeson newtype" . testAeson+ , testCase "DerivingVia" . testDerivingVia+ , testCase "Question mark escape" . testQM+ , testCase "Savepoint" . testSavepoint+ , testCase "Unicode" . testUnicode+ , testCase "Values" . testValues+ , testCase "Copy" . testCopy , testCopyFailures- , testCase "Double" . testDouble- , testCase "1-ary generic" . testGeneric1- , testCase "2-ary generic" . testGeneric2- , testCase "3-ary generic" . testGeneric3- , testCase "Timeout" . testTimeout+ , testCase "Double" . testDouble+ , testCase "1-ary generic" . testGeneric1+ , testCase "2-ary generic" . testGeneric2+ , testCase "3-ary generic" . testGeneric3+ , testCase "Timeout" . testTimeout+ , testCase "Exceptions" . testExceptions ] testBytea :: TestEnv -> TestTree@@ -114,7 +139,7 @@ xs <- readIORef ref writeIORef ref $! (a,b):xs xs <- readIORef ref- reverse xs @?= [(a,b) | a <- [1..100], b <- [1..50]]+ reverse xs @?= [(a,b) | b <- [1..50], a <- [1..100]] -- Make sure fold propagates our exception. ref <- newIORef []@@ -203,6 +228,19 @@ m' <- query conn "SELECT ?::hstore" m [m] @?= m' +testCIText :: TestEnv -> Assertion+testCIText TestEnv{..} = do+ execute_ conn "CREATE EXTENSION IF NOT EXISTS citext"+ roundTrip (CI.mk "")+ roundTrip (CI.mk "UPPERCASE")+ roundTrip (CI.mk "lowercase")+ where+ roundTrip :: (CI Text) -> Assertion+ roundTrip cit = do+ let toPostgres = Only cit+ fromPostgres <- query conn "SELECT ?::citext" toPostgres+ [toPostgres] @?= fromPostgres+ testJSON :: TestEnv -> Assertion testJSON TestEnv{..} = do roundTrip (Map.fromList [] :: Map Text Text)@@ -218,6 +256,90 @@ js' <- query conn "SELECT ?::json" js [js] @?= js' +testAeson :: TestEnv -> Assertion+testAeson TestEnv{..} = do+ roundTrip (Map.fromList [] :: Map Text Text)+ roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)+ roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)+ roundTrip (V.fromList [1,2,3,4,5::Int])+ roundTrip ("foo" :: Text)+ roundTrip (42 :: Int)+ where+ roundTrip :: (Eq a, Show a, Typeable a, ToJSON a, FromJSON a)=> a -> Assertion+ roundTrip x = do+ y <- query conn "SELECT ?::json" (Only (Aeson x))+ [Only (Aeson x)] @?= y++testDerivingVia :: TestEnv -> Assertion+testDerivingVia TestEnv{..} = do+#if __GLASGOW_HASKELL__ <806+ return ()+#else+ roundTrip $ DerivingVia1 42 "Meaning of Life"+ where+ roundTrip :: (Eq a, Show a, Typeable a, ToField a, FromField a)=> a -> Assertion+ roundTrip x = do+ y <- query conn "SELECT ?::json" (Only x)+ [Only x] @?= y++data DerivingVia1 = DerivingVia1 Int String+ deriving stock (Eq, Show, Generic)+ deriving anyclass (FromJSON, ToJSON)+ deriving (ToField, FromField) via Aeson DerivingVia1++#endif+++testQM :: TestEnv -> Assertion+testQM TestEnv{..} = do+ -- Just test on a single string+ let testQuery' b = "testing for ?" <> b <> " and making sure "+ testQueryDoubleQM = testQuery' "?"+ testQueryRest = "? is substituted"+ testQuery = fromString $ testQueryDoubleQM <> testQueryRest+ -- expect the entire first part with double QMs replaced with literal '?'+ expected = (fromString $ testQuery' "", fromString testQueryRest)+ tried = breakOnSingleQuestionMark testQuery+ errMsg = concat+ [ "Failed to break on single question mark exclusively:\n"+ , "expected: ", show expected+ , "result: ", show tried+ ]+ assertBool errMsg $ tried == expected++ -- Let's also test the question mark operators in action+ -- ? -> Does the string exist as a top-level key within the JSON value?+ positiveQuery "SELECT ?::jsonb ?? ?" (testObj, "foo" :: Text)+ negativeQuery "SELECT ?::jsonb ?? ?" (testObj, "baz" :: Text)+ negativeQuery "SELECT ?::jsonb ?? ?" (toJSON numArray, "1" :: Text)+ -- ?| -> Do any of these array strings exist as top-level keys?+ positiveQuery "SELECT ?::jsonb ??| ?" (testObj, PGArray ["nope","bar","6" :: Text])+ negativeQuery "SELECT ?::jsonb ??| ?" (testObj, PGArray ["nope","6" :: Text])+ negativeQuery "SELECT ?::jsonb ??| ?" (toJSON numArray, PGArray ["1","2","6" :: Text])+ -- ?& -> Do all of these array strings exist as top-level keys?+ positiveQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar","quux" :: Text])+ positiveQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar" :: Text])+ negativeQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar","baz" :: Text])+ negativeQuery "SELECT ?::jsonb ??& ?" (toJSON numArray, PGArray ["1","2","3","4","5" :: Text])+ -- Format error for 2 question marks, not 4+ True <- expectError (isFormatError 2) $+ (query conn "SELECT ?::jsonb ?? ?" $ Only testObj :: IO [Only Bool])+ return ()+ where positiveQuery :: ToRow a => Query -> a -> Assertion+ positiveQuery = boolQuery True+ negativeQuery :: ToRow a => Query -> a -> Assertion+ negativeQuery = boolQuery False+ numArray :: [Int]+ numArray = [1,2,3,4,5]+ boolQuery :: ToRow a => Bool -> Query -> a -> Assertion+ boolQuery b t x = do+ a <- query conn t x+ [Only b] @?= a+ testObj = toJSON (Map.fromList [("foo",toJSON (1 :: Int))+ ,("bar",String "baz")+ ,("quux",toJSON [1 :: Int,2,3,4,5])] :: Map Text Value+ )+ testSavepoint :: TestEnv -> Assertion testSavepoint TestEnv{..} = do True <- expectError ST.isNoActiveTransactionError $@@ -325,6 +447,14 @@ -- so that we can issue more queries: [Only (x::Int)] <- query_ conn "SELECT 2 + 2" x @?= 4+ -- foldCopyData+ copy_ conn "COPY copy_test TO STDOUT (FORMAT CSV)"+ (acc, count) <- foldCopyData conn+ (\acc row -> return (row:acc))+ (\acc count -> return (acc, count))+ []+ sort acc @?= sort copyRows+ count @?= 2 where copyRows = ["1,foo\n" ,"2,bar\n"]@@ -344,12 +474,13 @@ goldenTest :: TestName -> IO BL.ByteString -> TestTree goldenTest testName =- goldenVsString testName (resultsDir </> fileName<.>"expected")+ goldenVsStringDiff testName diff (resultsDir </> fileName<.>"expected") where resultsDir = "test" </> "results" fileName = map normalize testName normalize c | not (isAlpha c) = '-' | otherwise = c+ diff ref new = ["diff", "-u", ref, new] -- | Test that we provide a sensible error message on failure testCopyUniqueConstraintError :: TestEnv -> TestTree@@ -462,24 +593,56 @@ isSyntaxError :: SqlError -> Bool isSyntaxError SqlError{..} = sqlState == "42601" +isFormatError :: Int -> FormatError -> Bool+isFormatError i FormatError{..}+ | null fmtMessage = False+ | otherwise = fmtMessage == concat [ show i+ , " single '?' characters, but "+ , show (length fmtParams)+ , " parameters"+ ] ------------------------------------------------------------------------ -- | Action for connecting to the database that will be used for testing. -- -- Note that some tests, such as Notify, use multiple connections, and assume -- that 'testConnect' connects to the same database every time it is called.-testConnect :: IO Connection-testConnect = connectPostgreSQL ""+withTestEnv :: ByteString -> (TestEnv -> IO a) -> IO a+withTestEnv connstr cb =+ withConn $ \conn -> do+ -- currently required for interval to work.+ -- we also test that this doesn't interfere with anything else+ execute_ conn "SET intervalstyle TO 'iso_8601'" -withTestEnv :: (TestEnv -> IO a) -> IO a-withTestEnv cb =- withConn $ \conn -> cb TestEnv { conn = conn , withConn = withConn } where- withConn = bracket testConnect close+ withConn = bracket (connectPostgreSQL connstr) close main :: IO ()-main = withTestEnv $ defaultMain . tests+main = withConnstring $ \connstring -> do+ withTestEnv connstring (defaultMain . tests)++withConnstring :: (BS8.ByteString -> IO ()) -> IO ()+withConnstring kont = do+ env <- getEnvironment+ case lookup "DATABASE_CONNSTRING" env of+ Just s -> kont (BS8.pack (special s))+ Nothing -> case lookup "GITHUB_ACTIONS" env of+ Just "true" -> kont (BS8.pack gha)+ _ -> putStrLn "Set DATABASE_CONNSTRING environment variable"+ where+ -- https://www.appveyor.com/docs/services-databases/+ special "appveyor" = "dbname='TestDb' user='postgres' password='Password12!'"+ special "travis" = ""+ special s = s++ gha = unwords+ [ "dbname='postgres'"+ , "user='postgres'"+ , "password='postgres'"+ , "host='postgres'"+ , "port=5432"+ ]
test/Time.hs view
@@ -36,7 +36,7 @@ import Common import Control.Monad(forM_, replicateM_)-import Data.Time+import Data.Time.Compat import Data.ByteString(ByteString) import Database.PostgreSQL.Simple.SqlQQ
test/results/malformed-input.expected view
@@ -1,4 +1,4 @@ user error (Database.PostgreSQL.Simple.Copy.putCopyEnd: failed to parse command status-Connection error: ERROR: invalid input syntax for integer: "z"+Connection error: ERROR: invalid input syntax for type integer: "z" CONTEXT: COPY copy_unique_constraint_error_test, line 3, column x: "z" )