postgresql-simple 0.3.10.0 → 0.7.0.1
raw patch · 51 files changed
Files
- CHANGES.md +746/−0
- CONTRIBUTORS +19/−0
- bench/Select.hs +32/−0
- postgresql-simple.cabal +153/−94
- src/Database/PostgreSQL/Simple.hs +211/−170
- src/Database/PostgreSQL/Simple/Arrays.hs +3/−3
- src/Database/PostgreSQL/Simple/BuiltinTypes.hs +0/−420
- src/Database/PostgreSQL/Simple/Compat.hs +17/−21
- src/Database/PostgreSQL/Simple/Copy.hs +47/−6
- src/Database/PostgreSQL/Simple/Cursor.hs +98/−0
- src/Database/PostgreSQL/Simple/Errors.hs +16/−12
- src/Database/PostgreSQL/Simple/FromField.hs +269/−101
- src/Database/PostgreSQL/Simple/FromRow.hs +240/−7
- src/Database/PostgreSQL/Simple/FromRow.hs-boot +3/−4
- src/Database/PostgreSQL/Simple/HStore.hs +3/−2
- src/Database/PostgreSQL/Simple/HStore/Implementation.hs +27/−21
- src/Database/PostgreSQL/Simple/HStore/Internal.hs +0/−2
- src/Database/PostgreSQL/Simple/Internal.hs +308/−29
- src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs +124/−0
- src/Database/PostgreSQL/Simple/LargeObjects.hs +2/−2
- src/Database/PostgreSQL/Simple/Newtypes.hs +49/−0
- src/Database/PostgreSQL/Simple/Notification.hs +62/−32
- src/Database/PostgreSQL/Simple/Ok.hs +10/−4
- src/Database/PostgreSQL/Simple/Range.hs +317/−0
- src/Database/PostgreSQL/Simple/SqlQQ.hs +17/−14
- src/Database/PostgreSQL/Simple/Time.hs +216/−50
- src/Database/PostgreSQL/Simple/Time/Implementation.hs +50/−156
- src/Database/PostgreSQL/Simple/Time/Internal.hs +3/−0
- src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs +204/−0
- src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs +135/−0
- src/Database/PostgreSQL/Simple/ToField.hs +182/−50
- src/Database/PostgreSQL/Simple/ToField.hs-boot +23/−0
- src/Database/PostgreSQL/Simple/ToRow.hs +128/−1
- src/Database/PostgreSQL/Simple/ToRow.hs-boot +12/−2
- src/Database/PostgreSQL/Simple/Transaction.hs +35/−17
- src/Database/PostgreSQL/Simple/TypeInfo.hs +9/−9
- src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs +9/−3
- src/Database/PostgreSQL/Simple/TypeInfo/Static.hs +1781/−477
- src/Database/PostgreSQL/Simple/Types.hs +151/−34
- src/Database/PostgreSQL/Simple/Vector.hs +45/−0
- src/Database/PostgreSQL/Simple/Vector/Unboxed.hs +44/−0
- test/Common.hs +2/−2
- test/Exception.hs +70/−0
- test/Inspection.hs +79/−0
- test/Interval.hs +176/−0
- test/Main.hs +407/−46
- test/Notify.hs +1/−2
- test/Serializable.hs +1/−2
- test/Time.hs +63/−15
- test/results/malformed-input.expected +4/−0
- test/results/unique-constraint-violation.expected +5/−0
+ CHANGES.md view
@@ -0,0 +1,746 @@+### 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)++### Version 0.5.3.0 (2017-05-15)+ * Refactored some rudimentary cursor handling code out of the+ implementation of the fold operators, into a new+ `Database.PostgreSQL.Simple.Cursor` module, thanks to Bardur Arantsson.++ * Made the `FromField` instance for `Char` compatible with+ postgresql's `bpchar` type. Thanks to Ivan Lazar Miljenovic for+ reporting the issue.++ * Added `Show` and `Eq` instances for `Notification`, thanks to+ Matvey Aksenov.++ * Fixed some example code, thanks to Matvey Aksenov.++ * Fixed a problem with using `conversionError` to throw exceptions+ of type `SomeException`. Previously, the exception would be+ wrapped in a second `SomeException` dynamic constructor which+ would cause normal GHC typecase idioms over `SomeException` to fail.++### Version 0.5.2.1 (2016-06-29)+ * Bumped the lower bound for `base` to 4.6. Thanks to Herbert+ Valerio Riedel for reporting the issue.++ * Added an `Eq` instance for `SqlError`, thanks to Chris Allen++ * Fixed a bug where a all-caps `"NULL"` text value inside a+ postgresql array would get parsed as the SQL null value. Thanks+ goes to Edgar Gomes and Silk for finding and fixing this mistake.++ * Modified `withTransaction` and friends to ignore `IOError`s when+ attempting to roll back the transaction. This fixes a buggy+ interaction between `withTransaction` and async exceptions (e.g.+ `System.Timeout`) on unix platforms. Thanks goes to Erik+ Hesselink and Silk for providing the test case that exposed this+ issue.++ * Added the `testTimeout` regression test for the problem above.++### Version 0.5.2.0 (2016-05-25)+ * Significantly improved the error reporting from+ `Copy.putCopyData`, thanks to Ben Gamari.++ * Moved the test suite to use `tasty`, with a big thanks+ to Ben Gamari.++ * Added `FromField.optionalField`, and updated the documentation+ of `FromField.fromJSONField`, as inspired by an email conversation+ with Ian Wagner.++ * Updated all links in the haddocks to use https, and added a link+ to the documentation of `connectPostgreSQL`.++ * Added a truncated changelog to the source distribution.++### Version 0.5.1.3 (2016-04-30)+ * Implemented the Monad of No Return proposal, future-proofing+ postgresql-simple against future releases of GHC.++ * Fixed a rare and usually benign race condition where+ `getNotification` could end up waiting on a newly reallocated+ file descriptor index, potentially leading to deadlock if the+ descriptor does not become readable promptly. This fix only+ applies to GHC 7.8 or later, as it depends on `threadWaitReadSTM`.++ * Tweaked the time parsers to accept times of day of the form `hh:mm`,+ omitting seconds, following changes made to aeson.++ * Updated the documentation of the `In` type to point out a gotcha+ when using the SQL fragment `... NOT IN ?` with `In []`. Thanks+ goes to Simon Michael and Dan Haraj for bringing this issue to+ my attention.++### Version 0.5.1.2 (2015-12-14)+ * The syntax generated for empty arrays was changed so that+ postgresql's type inference would work better, thanks to+ Amit Levy.++ * Further revision and expansion of the new Time documentation.++### Version 0.5.1.1 (2015-12-02)+ * This is a documentation-only release++ * The documentation of the `Time` module has been completely+ rewritten, and is far longer and more informative. It contains+ a brief overview of civil time, the semantics of postgresql's+ time types, and their relation to Haskell's time types via+ postgresql-simple.++ * The documentation of `connectPostgreSQL` has been modified to+ mention the effects of environment variables on the connection+ string parameters.++ * The documentation of `HStore.Internal` has been unhidden from+ haddock.++ * A typo in example code was fixed courtesy of Levi Notik.++### Version 0.5.1.0 (2015-10-22)+ * Optimized the implementation of the streaming operators to avoid+ creating intermediate lists of rows, thanks to Timo von Holtz.++ * Added default instances for `ToRow` and `FromRow` that depend on+ Generics, thanks to Alexey Khudyakov.++ * Fixed support for bytestring-0.9 and GHC 7.4.++### Version 0.5.0.1 (2015-09-21)+ * Fixed a bug when printing a `ZonedTime` with a negative offset+ that is not a whole number of hours.++### Version 0.5.0.0 (2015-09-19)+ * Removed the deprecated `BuiltinTypes` module.++ * Modified the SQL quasiquoter so that it returns a `Query`, not+ an overloaded string, and so that the `OverloadedStrings` language+ extension is no longer necessary, thanks to Mike Ledger.++ * Moved away from `blaze-builder` in favor of `bytestring-builder`. This+ shouldn't affect very many people, but does reduce the transitive+ dependencies.++ * Rewrote the timestamp printers to use the new `Prim`+ infrastructure in `bytestring-builder`. The new printers should+ be a fair bit faster.++ * Added support for exclusion violations to the `ConstraintViolation`+ type in the Errors module, thanks to João Cristóvão.++ * Moved away from the `uuid` package in favor of the `uuid-types` package,+ thanks to Bardur Arantsson. This shouldn't affect anybody, but does+ reduce the transitive dependencies.++ * Postgresql-simple now explicitly assumes the UTF8 character encoding+ for communication between the client and server. All database encodings+ 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+ accommodate this requirement.++ * Added `Eq` and `Typeable` instances for `Connection`.++ * Added the `foldWith`, `forEachWith`, and `returningWith` families+ of functions courtesy of Travis Staton.++ * Support for Ranged types, with thanks to Leonid Onokhov for his+ contributions.++ * The `FromField` instance for JSON now allows for top-level values that+ are not objects or arrays, thanks to Sam Rijs.++ * The timestamp parsers have been replaced with those now in Aeson.+ Janne Hellsten adapted the old parsers from postgresql-simple for+ inclusion in Aeson; Bryan O'Sullivan rewrote those parsers to be+ faster, with some tweaks contributed by myself. And now to+ bring the effort full circle, the result has been brought back to+ postgresql-simple, with some adaptations.++ * Fixed a bug in the typeinfo system where postgresql's `_record` type+ was being reported as a basic type and not an array type. Thanks to+ Nickolay Kolev for helping to expose this issue.++ * Fixed a bug with the `typeInfo` operator, thanks to Timmy Tofu. In the+ case of parsing subfields of arrays and composites, it would fetch the+ `TypeInfo` of the array or composite type and not the subtype.++### Version 0.4.10.0 (2015-02-26)+ * Added a blurb about SSL/TLS in the documentation for connectPostgreSQL++ * Moved some functions into the Internal module, courtesy of Aleksey+ Uimanov.++### Version 0.4.9.0 (2014-12-27)+ * Made the fromField method for PGArray available as pgArrayFieldParser,+ outside of the typeclass courtesy of Tom Ellis.++ * Fixed a missing OverloadedStrings pragma in the documentation of SqlQQ.++ * Fixed deprecation warnings, courtesy of Simon Hengel.++### Version 0.4.8.0 (2014-11-24)+ * Added support for postgresql's citext type extension via the+ case-insensitive package.++ * Added the function parseHStoreList to the HStore module.++### Version 0.4.7.0 (2014-10-27)+ * Added support for very old timestamps to UTCTime. Depending on time+ zone, very old timestamps can be returned with a offset from UTC that+ contains seconds.++ All timezones in the TZ database moved to a time standard offset an+ integer number of minutes from UTC before 1973, almost all locations+ moved before 1938, and a solid majority moved before 1921.++ ZonedTime assumes offsets are a whole number of minutes, and thus the+ conversion to ZonedTime does not support these timestamps and will+ still throw a conversion error.++ Note that PostgreSQL's "timestamp with time zone" (or "timestamptz")+ type is nearly universally misunderstood. For an explanation, see:++ https://github.com/lpsmith/postgresql-simple/issues/69++ Thanks to Michael Snoyman for his assistance with this issue.++### Version 0.4.6.0 (2014-10-07)+ * Added an instance ToField NominalDiffTime.++### Version 0.4.5.0 (2014-09-26)+ * Added support for retrieving NaN and ±Infinity floating point values+ from postgres to the FromField instances for Float, Double, and Rational.+ The instance for Scientific is unchanged due to the fact it has no+ way of representing these special values. Thanks goes to Tom Nielsen+ for reporting the issue.++### Version 0.4.4.1 (2014-09-07)+ * Fixed a rather serious bug that prevented the COPY module from working+ at all on unix clients since version 0.4.3.0. Thanks goes to+ Dmitry Dzhus for reporting the issue.++ * Added a regression test for the COPY module to the test suite.++### Version 0.4.4.0 (2014-08-26)+ * Added the jsonb type debuting in PostgreSQL 9.4 to the TypeInfo.Static+ and Builtin tables, and extended the out-of-box json instances to+ be compatible with the new type. Thanks to Tobias Florek for the+ patch.++ * Ported some expanded documentation from mysql-simple, and fixed+ a documentation typo.++### Version 0.4.3.0 (2014-07-10)+ * connect and exec now use libpq asynchronously on non-Windows platforms.+ This means we are using threadWaitRead and threadWaitWrite to+ have GHC's IO manager schedule non-blocking C calls to libpq,+ instead of using blocking C calls and having the OS kernel do the+ scheduling. Among other things, this now means that System.Timeout+ will work with connect and exec on unix platforms.++ * connect and exec now throw IOErrors instead of SQLErrors in+ some cases. The intention is for SQLErrors to represent+ an error returned by the server, and to use IOErrors for errors+ that originate from client-side code. However, this goal+ isn't perfectly achieved as of yet.++### Version 0.4.2.3 (2014-06-04)+ * This is strictly a documentation release, with no code changes.++ * Fixed several documentation typos, thanks to Chris Allen and remdezx.++ * Expanded the documentation of connectPostgreSQL, including a short+ overview of common use cases and two new links to the official Postgres+ documentation about the authentication process.++ * 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++ * Improved documentation of the FromField module, as well as the fold,+ foldWithOptions, executeMany, and returning operators.++### Version 0.4.2.1 (2014-03-27)+ * Fixed bug in Values syntax generation++ * Improved documentation, including examples of multi-row update,+ a better example for Values, documenting the inaccuracies in reading+ floating point numbers from the database, and the IsString instance+ for QualifiedIdentifier.++### Version 0.4.2.0 (2014-03-22)+ * Added ToField and FromField instances for the scientific package++ * Changed the Identifier and QualifiedIdentifier to use Text in+ order to avoid encoding errors. Technically this requires a+ 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.++### Version 0.4.1.0 (2014-03-22)+ * Fixed the parsing of arrays containing null values, courtesy of+ Francesco Mazzoli++ * Added support for properly escaped identifiers, courtesy of+ Tobias Florek. See the new Identifier and QualifiedIdentifier+ types inside Database.PostgreSQL.Simple.Types.++ * Added support for parameterized VALUES expressions. This is+ more general than executeMany and returning. See the+ Database.PostgreSQL.Simple.Types.Values data type.++### Version 0.4.0.2 (2014-01-12)+ * Tweaked C preprocessor directive to be more portable++ * Tweaked testsuite for compatibility with aeson-0.7++### Version 0.4.0.1 (2013-12-21)+ * Relaxed dependency on aeson to >= 0.6++ * Update the documentation of `fromField`++### Version 0.4.0.0 (2013-12-21)+ * Changed the calling code of `fromField` so that it always sends+ a copy of the raw data. This should be a small but significant+ performance bump for most people most of the time; however it+ may slow down retrieval of large values not converted directly+ to ByteString, such as large json, hstore, and array values.+ See commit 8635f8 for more information.++ * Added the PGArray type. Thanks to Joey Adams for the suggestion++ * Fixed JSON decoding, which was almost entirely broken up until now,+ due to bugs in the version of aeson currently available on Hackage.+ Thanks to Amit Levy for the report.++ * Added FromField instances for IORef, MVar, and IOVector.++### Version 0.3.10.0 (2013-12-17)+ * Added the queryWith function, courtesy of Leonid Onokhov++ * Added the Default type, for representing postgresql's default values++### Version 0.3.9.1 (2013-10-28)+ * Removed dependency on hashable++### Version 0.3.9.0 (2013-10-27)+ * Added FromField and ToField instances for the `uuid` package,+ courtesy of Bas van Dijk.++ * Added instance FromRow (Maybe a) for most pre-packaged FromRow+ instances. See issue #64 for some discussion.++ * Added the fromBinary, fromHStoreMap, and fromHStoreList newtype+ unwrapper functions, courtesy of Bas van Dijk.++### Version 0.3.8.0 (2013-10-11)+ * Fixed the example code in `FromField`, thanks to Adam Bergmark.++ * Added `Notification.getBackendPID`.++### Version 0.3.7.1 (2013-09-12)+ * Relaxed the dependency on bytestring-0.10 back to bytestring-0.9,+ courtesy of Michael Snoyman++### Version 0.3.7.0 (2013-09-11)+ * Added `aeson` as a dependency.++ * Added ToField and FromField instances for aeson's JSON.Value type,+ courtesy of Bas van Dijk.++ * Added toJSONField and fromJSONField helper functions for declaring+ FromField/ToField JSON instances to other Haskell types, courtesy+ of Bas van Dijk.++ * Added a FromField instance for (), corresponding to postgresql's void+ type.++ * Added liftConversion and liftRowParser functions to the Internal+ module, for lifting IO actions into the respective monads.++ * The SqlError predicates available in the Transaction module are now+ also exported from the Errors module.++ * Various documentation fixes.++### Version 0.3.6.0 (2013-08-19)+ * Added the json type to BuiltinTypes and TypeInfo.Static, courtesy of+ Manuel Gómez.++ * Removed the remaining internal dependencies on BuiltinTypes from+ FromField. Added the TypeInfo.Macro module as a result.++ * Deprecated the BuiltinTypes module, which will be removed several+ months from now. Fixed the example code in FromField to reflect+ this change.++### Version 0.3.5.0 (2013-08-09)+ * Added an FromRow instance for Vector, semantically identical to the+ existing FromRow instance for [], courtesy of Doug Beardsley++ * Reworked the documentation for the Copy module, and tweaked the+ documentation for the LargeObjects module.++### Version 0.3.4.0 (2013-07-23)+ * Added direct support for COPY IN and COPY OUT, without having+ to use raw postgresql-libpq calls and postgresql-simple's Internal+ module.++ * Changed `getNotification` so that it throws a IOError (resource vanished)+ exception instead of an ErrorCall exception when it fails to fetch+ the connection's file descriptor from libpq.++### Version 0.3.3.2 (2013-06-18)+ * Optimized the definition of `mconcat` in the Monoid instance for+ the Query type, courtesy of Joey Adams.++### Version 0.3.3.1 (2013-06-06)+ * `getNotification` now works on Windows, albeit using a one-second+ polling loop, courtesy of Joey Adams.++### Version 0.3.3.0 (2013-05-29)+ * Fixed two issues with the fold operator: fold would raise the wrong+ exception, and gave the database cursor a static name preventing+ folds from being nested. Thanks to Joey Adams for his+ work on these issues.++### Version 0.3.2.0 (2013-05-20)+ * Added a savepoint abstraction to the Transaction module, courtesy+ of Joey Adams++### Version 0.3.1.2 (2013-04-29)+ * Fixed hstore parser to not unnecessarily reverse the key-value pairs++### Version 0.3.1.1 (2013-04-29)+ * Fixed hstore parser to recognize empty hstores, courtesy of Simon+ Meier++### Version 0.3.1.0 (2013-04-26)+ * Added support for Range and Composite types to the TypeInfo system.++ * Added support for hstore types in the Simple.HStore module.++ * Improved documentation of the FromField module.++### Version 0.3.0.1 (2013-03-26)+ * A large chunk of the documentation inside the FromField module had+ silently failed to render in Haddock.++### Version 0.3.0.0 (2013-03-25)+ * Added support for PostgreSQL's Array Types. Thanks to Jason Dusek+ for his work on this feature.++ * 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 necessary to properly+ support postgres array types. Thanks to Bas van Dijk for his+ work on this feature.++ * Changed the type of the `fromField` and `fromRow` methods to allow+ a restricted set of IO actions, and stopped pre-calculating the type+ name of every column. As a result, the type of the `typename`+ operator changed from `Field -> ByteString` to+ `Field -> Conversion ByteString`, where Conversion is the new monad+ that conversion computations run inside.++ * Improved the documentation of the FromField module.++ * Added the Database.PostgreSQL.Simple.Errors module, which offers+ some predicates and functions for interpreting SqlError values, courtesy+ of Leonid Onokhov.++ * Added a the name of a column and the associated table's object identifier+ to ResultError exceptions, courtesy of Jeff Chu.++ * Moved most of the more detailed transaction operators into the+ Database.PostgreSQL.Simple.Transaction module.++ * Changed withTransactionModeRetry to accept a predicate of which+ SqlErrors to retry, due to the fact that serialization errors can+ sometimes manifest themselves as constraint violations. Thanks+ to Oliver Charles for pointing this out and implementing the change.++ * Added simple tests of the fold operator, thanks to Joey Adams.++ * Added simple tests of the array conversion code.++ * Added recognition of -- comments in the quasiquoter, which are+ now stripped out.+++### Version 0.2.4.1 (2012-08-29)+ * Fixed the documentation of `In`. Thanks to rekado and dstcruz for+ pointing this out.++### Version 0.2.4.0 (2012-08-23)+ * Added the `withTransactionSerializable` and `withTransactionModeRetry`+ operators, thanks to Joey Adams.++### Version 0.2.3.0 (2012-08-09)+ * Added the `returning` operator, thanks to Jason Dusek++### Version 0.2.2.0 (2012-07-26)+ * Added a ToRow instance for the (:.) type, courtesy of Leonid Onokhov++ * Added the type oid for PostgreSQL's `uuid` type to BuiltinTypes++### Version 0.2.1.0 (2012-07-23)+ * Added the FromRow.fieldWith operator, thanks to Leonid Onokhov++ * Added a type synonym for FieldParser++### Version 0.2.0.1 (2012-06-21)+ * Fixed a compatibility problem with PostgreSQL 8.1, which does not allow+ clients to set their own value for `standard_conforming_strings`. This+ connection variable is still set to `on` for PostgreSQL 8.2 and later.++### Version 0.2: (2012-06-19)+ * Removed the conversion from `timestamp` to `UTCTime`. Some code will be+ broken even though it will still compile.++ * Renamed a number of data constructors, mostly in the BuiltinTypes module.++ * Exported ToRow/FromRow from Database.PostgreSQL.Simple+++### Version 0.1.4.3: (2012-06-10)+ * Fix language extensions for compatibility with GHC 7.0++### Version 0.1.4.2: (2012-06-10)+ * Fix a wayward dependency on Text.++### Version 0.1.4.1: (2012-06-10)+ * Added support for timezones with minutes in their UTC offset.++### Version 0.1.4: (2012-06-10)+ * Removed pcre-light dependency, courtesy of Joey Adams.++ * Reworked support for the Time types.++ * The conversion from PostgreSQL's `timestamp` (without time zone) type+ to Haskell's `UTCTime` type is deprecated and will be removed in 0.2.++ * `Data.Time.LocalTime` now has `FromField`/`ToField` instances. It is+ now the preferred way of dealing with `timestamp` (without time zone).++ * `Database.PostgreSQL.Simple.Time` is a new module that offers types+ 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+ time package included in GHC.++ * Planned breaking changes for 0.2:++ * Removing the conversion from `timestamp` to `UTCTime`.++ * Renaming some of the type names in `BuiltinTypes`.+++### Version 0.1.3: (2012-05-30)+ * Made ZonedTime an instance of FromField and ToField++ * Added getNotificationNonBlocking+++### Version 0.1.2: (2012-05-09)+ * Switched to libpq-based escaping for bytea types; Binary now works with+ PostgreSQL 8 courtesy of Joey Adams.++ * postgresql-simple now sets standard_conforming_strings to "on". This+ per-connection variable is initialized according to the server+ configuration, which defaults to "off" for PostgreSQL < 9, and "on"+ for PostgreSQL >= 9. You may need to adjust any string literals in+ your SQL queries, or set the variable yourself.++ * Exported (:.) from Database.PostgreSQL.Simple+++### Version 0.1.1: (2012-05-06)+ * Added some preliminary documentation for the Ok, Notification, and+ LargeObjects modules++ * Implemented the `fail` method for the monad instance for `Ok`.++ * Fixed a bug relating to handling the transaction level+++### Version 0.1: (2012-05-04)+ * Renamed several modules, typeclasses, and functions:++ QueryParams (renderParams) -> ToRow (toRow)+ QueryResults (convertResults) -> FromRow (fromRow)+ Param (render) -> ToField (toField)+ Result (convert) -> FromField (fromField)++ * Added the `Database.PostgreSQL.Simple.Ok` module, a variation of+ `Either SomeException` that has an instance for `Alternative` and also+ uses a list of exceptions to track the ways it has failed.++ * Changed the return type of `fromField` and `fromRow` from+ `Either SomeException` to `Ok`.++ * Thanks to suggestions from Ozgun Ataman, the `FromRow` typeclass has been+ massively improved. The result is simpler definitions and better+ compositionality. Also, user-defined instances need not be to be+ concerned about forcing the converted results to WHNF. Here is an+ example comparing the old to the new:++ instance (Result a, Result b) => QueryResults (a,b) where+ convertResults [fa,fb] [va,vb] = do+ !a <- convert fa va+ !b <- convert fb vb+ return (a,b)+ convertResults fs vs = convertError fs vs 2++ instance (FromField a, FromField b) => FromRow (a,b) where+ fromRow = (,) <$> field <*> field++ * Added `(:.)`, a pair that allows one to compose `FromRow` instances:++ instance (FromRow a, FromRow b) => FromRow (a :. b) where+ fromRow = (:.) <$> fromRow <*> fromRow++ * Moved the contents `Field` module into the `FromField` module.++ * Removed the `RawResult` type.++ * Added `DefaultIsolationLevel` as a distinct `IsolationLevel` option+ and `DefaultReadWriteMode` as a distinct `ReadWriteMode`.
CONTRIBUTORS view
@@ -15,3 +15,22 @@ Manuel Gómez <targen@gmail.com> Michael Snoyman <michael@snoyman.com> Adam Bergmark <adam@edea.se>+Tobias Florek <tob@butter.sh>+Francesco Mazzoli <francesco.mazzoli@erudify.com>+Chris Allen <cma@bitemyapp.com>+Simon Hengel <sol@typeful.net>+Tom Ellis <tom-2013@purelyagile.com>+Mike Ledger <mike@quasimal.com>+João Cristóvão <jmacristovao@gmail.com>+Bardur Arantsson <bardur@scientician.net>+Travis Staton <hello@travisstaton.com>+Sam Rijs <srijs@airpost.net>+Janne Hellsten <jjhellst@gmail.com>+Timmy Tofu <timmytofu@users.noreply.github.com>+Alexey Khudyakov <alexey.skladnoy@gmail.com>+Timo von Holtz <tvh@anchor.com.au>+Amit Levy <amit@amitlevy.com>+Ben Gamari <ben@smart-cactus.org>+Edgar Gomes Araujo <talktoedgar@gmail.com>+Erik Hesselink <hesselink@gmail.com>+Matvey Aksenov <matvey.aksenov@gmail.com>
+ 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,116 +1,175 @@-Name: postgresql-simple-Version: 0.3.10.0-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-2013 Leon P Smith-Category: Database-Build-type: Simple+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. -Cabal-version: >= 1.9.2+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 -Library- hs-source-dirs: src- Exposed-modules:- Database.PostgreSQL.Simple- Database.PostgreSQL.Simple.Arrays- Database.PostgreSQL.Simple.BuiltinTypes- Database.PostgreSQL.Simple.Copy- 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.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+tested-with:+ 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.Time.Implementation- 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.2,- attoparsec >= 0.10.3,- base < 5,- blaze-builder,- blaze-textual,- bytestring >= 0.9,- containers,- postgresql-libpq >= 0.6.2,- template-haskell,- text >= 0.11.1,- time,- transformers,- uuid >= 1.3.1,- 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 - extensions: DoAndIfThenElse, OverloadedStrings, BangPatterns, ViewPatterns- TypeOperators+ -- 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 - ghc-options: -Wall -fno-warn-name-shadowing+ -- 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+ TypeOperators+ ViewPatterns++ ghc-options: -Wall -fno-warn-name-shadowing+ source-repository head type: git- location: http://github.com/lpsmith/postgresql-simple+ location: http://github.com/haskellari/postgresql-simple -source-repository this- type: git- location: http://github.com/lpsmith/postgresql-simple- tag: v0.3.10.0+test-suite inspection+ default-language: Haskell2010+ 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 test-suite test- type: exitcode-stdio-1.0-- hs-source-dirs: test- main-is: Main.hs+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs other-modules: Common+ Exception+ Interval Notify Serializable Time - Build-depends:- vector-- 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+ ScopedTypeVariables - extensions: NamedFieldPuns- , OverloadedStrings- , Rank2Types- , RecordWildCards- , PatternGuards- , ScopedTypeVariables+ 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 - build-depends: base- , aeson- , base16-bytestring- , bytestring- , containers- , cryptohash- , HUnit- , postgresql-simple- , text- , time+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
@@ -42,7 +42,7 @@ -- ** Modifying multiple rows at once -- $many - -- ** @RETURNING@: modifications that returns results+ -- ** @RETURNING@: modifications that return results -- $returning -- * Extracting results@@ -55,8 +55,7 @@ -- $types -- * Types- Base.ConnectInfo(..)- , Connection+ Connection , Query , ToRow , FromRow@@ -65,17 +64,20 @@ , Only(..) , (:.)(..) -- ** Exceptions+ , SomePostgreSqlException(..) , SqlError(..) , PQ.ExecStatus(..)- , FormatError(fmtMessage, fmtQuery, fmtParams)- , QueryError(qeMessage, qeQuery)- , ResultError(errSQLType, errHaskellType, errMessage)+ , FormatError(..)+ , QueryError(..)+ , ResultError(..) -- * Connection management- , Base.connect , Base.connectPostgreSQL- , Base.postgreSQLConnectionString- , Base.defaultConnectInfo , Base.close+ , Base.connect+ , Base.withConnect+ , Base.ConnectInfo(..)+ , Base.defaultConnectInfo+ , Base.postgreSQLConnectionString -- * Queries that return results , query , query_@@ -93,6 +95,14 @@ , forEach , forEach_ , returning+ -- ** Queries that stream results taking a parser as an argument+ , foldWith+ , foldWithOptionsAndParser+ , foldWith_+ , foldWithOptionsAndParser_+ , forEachWith+ , forEachWith_+ , returningWith -- * Statements that do not return results , execute , execute_@@ -110,47 +120,28 @@ , formatQuery ) where -import Blaze.ByteString.Builder- ( Builder, fromByteString, toByteString )-import Blaze.ByteString.Builder.Char8 (fromChar)-import Blaze.Text ( integral )-import Control.Applicative ((<$>), pure)+import Data.ByteString.Builder (Builder, byteString, char8)+import Control.Applicative ((<$>)) import Control.Exception as E-import Control.Monad (foldM) import Data.ByteString (ByteString) import Data.Int (Int64) import Data.List (intersperse) import Data.Monoid (mconcat)-import Data.Typeable (Typeable)-import Database.PostgreSQL.Simple.Compat ( (<>) )+import Database.PostgreSQL.Simple.Compat ((<>), toByteString)+import Database.PostgreSQL.Simple.Cursor import Database.PostgreSQL.Simple.FromField (ResultError(..)) import Database.PostgreSQL.Simple.FromRow (FromRow(..))-import Database.PostgreSQL.Simple.Ok-import Database.PostgreSQL.Simple.ToField (Action(..), inQuotes)+import Database.PostgreSQL.Simple.ToField (Action(..)) import Database.PostgreSQL.Simple.ToRow (ToRow(..)) import Database.PostgreSQL.Simple.Types ( Binary(..), In(..), Only(..), Query(..), (:.)(..) ) import Database.PostgreSQL.Simple.Internal as Base+import Database.PostgreSQL.Simple.Internal.PQResultUtils import Database.PostgreSQL.Simple.Transaction-import Database.PostgreSQL.Simple.TypeInfo import qualified Database.PostgreSQL.LibPQ as PQ import qualified Data.ByteString.Char8 as B-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import Control.Monad.Trans.Reader-import Control.Monad.Trans.State.Strict --- | Exception thrown if a 'Query' could not be formatted correctly.--- This may occur if the number of \'@?@\' characters in the query--- string does not match the number of parameters provided.-data FormatError = FormatError {- fmtMessage :: String- , fmtQuery :: Query- , fmtParams :: [ByteString]- } deriving (Eq, Show, Typeable) -instance Exception FormatError- -- | Format a query string. -- -- This function is exposed to help with debugging and logging. Do not@@ -186,9 +177,9 @@ case parseTemplate template of Just (before, qbits, after) -> do bs <- mapM (buildQuery conn q qbits . toRow) qs- return . toByteString . mconcat $ fromByteString before :- intersperse (fromChar ',') bs ++- [fromByteString after]+ return . toByteString . mconcat $ byteString before :+ intersperse (char8 ',') bs +++ [byteString after] Nothing -> fmtError "syntax error in multi-row template" q [] -- Split the input string into three pieces, @before@, @qbits@, and @after@,@@ -286,43 +277,40 @@ skipSpace = B.dropWhile isSpace_ascii -escapeStringConn :: Connection -> ByteString -> IO (Either ByteString ByteString)-escapeStringConn conn s =- withConnection conn $ \c ->- PQ.escapeStringConn c s >>= checkError c -escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString)-escapeByteaConn conn s =- withConnection conn $ \c ->- PQ.escapeByteaConn c s >>= checkError c--checkError :: PQ.Connection -> Maybe a -> IO (Either ByteString a)-checkError _ (Just x) = return $ Right x-checkError c Nothing = Left . maybe "" id <$> PQ.errorMessage c- buildQuery :: Connection -> Query -> ByteString -> [Action] -> IO Builder-buildQuery conn q template xs = zipParams (split template) <$> mapM sub xs- where quote = either (\msg -> fmtError (utf8ToString msg) q xs)- (inQuotes . fromByteString)- utf8ToString = T.unpack . TE.decodeUtf8- sub (Plain b) = pure b- sub (Escape s) = quote <$> escapeStringConn conn s- sub (EscapeByteA s) = quote <$> escapeByteaConn conn s- sub (Many ys) = mconcat <$> mapM sub ys- split s = fromByteString h : if B.null t then [] else split (B.tail t)- where (h,t) = B.break (=='?') s+buildQuery conn q template xs =+ zipParams (split template) <$> mapM (buildAction conn q xs) xs+ where split 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. -- -- Returns the number of rows affected. ----- Throws 'FormatError' if the query could not be formatted correctly.+-- Throws 'FormatError' if the query could not be formatted correctly, or+-- a 'SqlError' exception if the backend returns an error. execute :: (ToRow q) => Connection -> Query -> q -> IO Int64 execute conn template qs = do result <- exec conn =<< formatQuery conn template qs@@ -331,9 +319,33 @@ -- | Execute a multi-row @INSERT@, @UPDATE@, or other SQL query that is not -- expected to return results. ----- Returns the number of rows affected.+-- Returns the number of rows affected. If the list of parameters is empty,+-- this function will simply return 0 without issuing the query to the backend.+-- If this is not desired, consider using the 'Values' constructor instead. ----- Throws 'FormatError' if the query could not be formatted correctly.+-- Throws 'FormatError' if the query could not be formatted correctly, or+-- a 'SqlError' exception if the backend returns an error.+--+-- For example, here's a command that inserts two rows into a table+-- with two columns:+--+-- @+-- executeMany c [sql|+-- INSERT INTO sometable VALUES (?,?)+-- |] [(1, \"hello\"),(2, \"world\")]+-- @+--+-- Here's an canonical example of a multi-row update command:+--+-- @+-- executeMany c [sql|+-- UPDATE sometable+-- SET y = upd.y+-- FROM (VALUES (?,?)) as upd(x,y)+-- WHERE sometable.x = upd.x+-- |] [(1, \"hello\"),(2, \"world\")]+-- @+ executeMany :: (ToRow q) => Connection -> Query -> [q] -> IO Int64 executeMany _ _ [] = return 0 executeMany conn q qs = do@@ -347,12 +359,20 @@ -- in cases where you are only inserting a single row, and do not need -- functionality analogous to 'executeMany'. --+-- If the list of parameters is empty, this function will simply return @[]@+-- without issuing the query to the backend. If this is not desired,+-- consider using the 'Values' constructor instead.+-- -- Throws 'FormatError' if the query could not be formatted correctly. returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO [r]-returning _ _ [] = return []-returning conn q qs = do+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 result <- exec conn =<< formatMany conn q qs- finishQuery conn q result+ finishQueryWith parser conn q result -- | Perform a @SELECT@ or other SQL query that is expected to return -- results. All results are retrieved and converted before this@@ -369,6 +389,9 @@ -- using 'execute' instead of 'query'). -- -- * 'ResultError': result conversion failed.+--+-- * 'SqlError': the postgresql backend returned an error, e.g.+-- a syntax or type error, or an incorrect table or column name. query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r] query = queryWith fromRow @@ -398,6 +421,12 @@ -- This fold is /not/ strict. The stream consumer is responsible for -- forcing the evaluation of its result to avoid space leaks. --+-- This is implemented using a database cursor. As such, this requires+-- a transaction. This function will detect whether or not there is a+-- transaction in progress, and will create a 'ReadCommitted' 'ReadOnly'+-- transaction if needed. The cursor is given a unique temporary name,+-- so the consumer may itself call fold.+-- -- Exceptions that may be thrown: -- -- * 'FormatError': the query string could not be formatted correctly.@@ -406,7 +435,9 @@ -- using 'execute' instead of 'query'). -- -- * 'ResultError': result conversion failed.-+--+-- * 'SqlError': the postgresql backend returned an error, e.g.+-- a syntax or type error, or an incorrect table or column name. fold :: ( FromRow row, ToRow params ) => Connection -> Query@@ -416,6 +447,20 @@ -> IO a fold = foldWithOptions defaultFoldOptions +-- | A version of 'fold' taking a parser as an argument+foldWith :: ( ToRow params )+ => RowParser row+ -> Connection+ -> Query+ -> params+ -> a+ -> (a -> row -> IO a)+ -> IO a+foldWith = foldWithOptionsAndParser defaultFoldOptions++-- | Number of rows to fetch at a time. 'Automatic' currently defaults+-- to 256 rows, although it might be nice to make this more intelligent+-- based on e.g. the average size of the rows. data FetchQuantity = Automatic | Fixed !Int@@ -426,12 +471,19 @@ transactionMode :: !TransactionMode } +-- | defaults to 'Automatic', and 'TransactionMode' 'ReadCommitted' 'ReadOnly' defaultFoldOptions :: FoldOptions defaultFoldOptions = FoldOptions { fetchQuantity = Automatic, transactionMode = TransactionMode ReadCommitted ReadOnly } +-- | The same as 'fold', but this provides a bit more control over+-- lower-level details. Currently, the number of rows fetched per+-- round-trip to the server and the transaction mode may be adjusted+-- accordingly. If the connection is already in a transaction,+-- then the existing transaction is used and thus the 'transactionMode'+-- option is ignored. foldWithOptions :: ( FromRow row, ToRow params ) => FoldOptions -> Connection@@ -440,9 +492,21 @@ -> a -> (a -> row -> IO a) -> IO a-foldWithOptions opts conn template qs a f = do+foldWithOptions opts = foldWithOptionsAndParser opts fromRow++-- | A version of 'foldWithOptions' taking a parser as an argument+foldWithOptionsAndParser :: (ToRow params)+ => FoldOptions+ -> RowParser row+ -> Connection+ -> Query+ -> params+ -> a+ -> (a -> row -> IO a)+ -> IO a+foldWithOptionsAndParser opts parser conn template qs a f = do q <- formatQuery conn template qs- doFold opts conn template (Query q) a f+ doFold opts parser conn template (Query q) a f -- | A version of 'fold' that does not perform query substitution. fold_ :: (FromRow r) =>@@ -453,6 +517,14 @@ -> IO a fold_ = foldWithOptions_ defaultFoldOptions +-- | A version of 'fold_' taking a parser as an argument+foldWith_ :: RowParser r+ -> Connection+ -> Query+ -> a+ -> (a -> r -> IO a)+ -> IO a+foldWith_ = foldWithOptionsAndParser_ defaultFoldOptions foldWithOptions_ :: (FromRow r) => FoldOptions@@ -461,18 +533,27 @@ -> a -- ^ Initial state for result consumer. -> (a -> r -> IO a) -- ^ Result consumer. -> IO a-foldWithOptions_ opts conn query a f = doFold opts 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+ -> RowParser r+ -> Connection+ -> Query -- ^ Query.+ -> 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 -doFold :: ( FromRow row )- => FoldOptions+doFold :: FoldOptions+ -> RowParser row -> Connection -> Query -> Query -> a -> (a -> row -> IO a) -> IO a-doFold FoldOptions{..} conn _template q a0 f = do+doFold FoldOptions{..} parser conn _template q a0 f = do stat <- withConnection conn PQ.transactionStatus case stat of PQ.TransIdle -> withTransactionMode transactionMode conn go@@ -490,28 +571,17 @@ PQ.TransUnknown -> fail "foldWithOpts FIXME: PQ.TransUnknown" -- Not sure what this means. where- declare = do- name <- newTempName conn- _ <- execute_ conn $ mconcat- [ "DECLARE ", name, " NO SCROLL CURSOR FOR ", q ]- return name- fetch (Query name) = query_ conn $- Query (toByteString (fromByteString "FETCH FORWARD "- <> integral chunkSize- <> fromByteString " FROM "- <> fromByteString name- ))- close name =- (execute_ conn ("CLOSE " <> name) >> return ()) `E.catch` \ex ->- -- Don't throw exception if CLOSE failed because the transaction is- -- aborted. Otherwise, it will throw away the original error.- if isFailedTransactionError ex then return () else throwIO ex+ declare =+ declareCursor conn q+ fetch cursor a =+ foldForwardWithParser cursor parser chunkSize f a - go = bracket declare close $ \name ->- let loop a = do- rs <- fetch name- if null rs then return a else foldM f a rs >>= loop- in loop a0+ go = bracket declare closeCursor $ \cursor ->+ let loop a = fetch cursor a >>=+ \r -> case r of+ Left x -> return x+ Right x -> loop x+ in loop a0 -- FIXME: choose the Automatic chunkSize more intelligently -- One possibility is to use the type of the results, although this@@ -530,87 +600,38 @@ -> q -- ^ Query parameters. -> (r -> IO ()) -- ^ Result consumer. -> IO ()-forEach conn template qs = fold conn template qs () . const+forEach = forEachWith fromRow {-# INLINE forEach #-} +-- | A version of 'forEach' taking a parser as an argument+forEachWith :: ( ToRow q )+ => RowParser r+ -> Connection+ -> Query+ -> q+ -> (r -> IO ())+ -> IO ()+forEachWith parser conn template qs = foldWith parser conn template qs () . const+{-# INLINE forEachWith #-}+ -- | A version of 'forEach' that does not perform query substitution. forEach_ :: (FromRow r) => Connection -> Query -- ^ Query template. -> (r -> IO ()) -- ^ Result consumer. -> IO ()-forEach_ conn template = fold_ conn template () . const+forEach_ = forEachWith_ fromRow {-# INLINE forEach_ #-} -forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a]-forM' lo hi m = loop hi []- where- loop !n !as- | n < lo = return as- | otherwise = do- a <- m n- loop (n-1) (a:as)+forEachWith_ :: RowParser r+ -> Connection+ -> Query+ -> (r -> IO ())+ -> IO ()+forEachWith_ parser conn template = foldWith_ parser conn template () . const+{-# INLINE forEachWith_ #-} -finishQuery :: FromRow r => Connection -> Query -> PQ.Result -> IO [r]-finishQuery = finishQueryWith fromRow -finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r]-finishQueryWith parser conn q result = do- status <- PQ.resultStatus result- case status of- PQ.EmptyQuery ->- throwIO $ QueryError "query: Empty query" q- PQ.CommandOk -> do- throwIO $ QueryError "query resulted in a command response" q- PQ.TuplesOk -> do- let unCol (PQ.Col x) = fromIntegral x :: Int- nrows <- PQ.ntuples result- ncols <- PQ.nfields result- forM' 0 (nrows-1) $ \row -> do- let rw = Row row result- okvc <- runConversion (runStateT (runReaderT (unRP parser) rw) 0) conn- case okvc of- Ok (val,col) | col == ncols -> return val- | otherwise -> do- vals <- forM' 0 (ncols-1) $ \c -> do- tinfo <- getTypeInfo conn =<< PQ.ftype result c- v <- PQ.getvalue result row c- return ( tinfo- , fmap ellipsis v )- throw (ConversionFailed- (show (unCol ncols) ++ " values: " ++ show vals)- Nothing- ""- (show (unCol col) ++ " slots in target type")- "mismatch between number of columns to \- \convert and number in target type")- Errors [] -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error"- Errors [x] -> throwIO x- Errors xs -> throwIO $ ManyErrors xs- PQ.CopyOut ->- throwIO $ QueryError "query: COPY TO is not supported" q- PQ.CopyIn ->- throwIO $ QueryError "query: COPY FROM is not supported" q- PQ.BadResponse -> throwResultError "query" result status- PQ.NonfatalError -> throwResultError "query" result status- PQ.FatalError -> throwResultError "query" result status--ellipsis :: ByteString -> ByteString-ellipsis bs- | B.length bs > 15 = B.take 10 bs `B.append` "[...]"- | otherwise = bs--fmtError :: String -> Query -> [Action] -> a-fmtError msg q xs = throw FormatError {- fmtMessage = msg- , fmtQuery = q- , fmtParams = map twiddle xs- }- where twiddle (Plain b) = toByteString b- twiddle (Escape s) = s- twiddle (EscapeByteA s) = s- twiddle (Many ys) = B.concat (map twiddle ys)- -- $use -- -- SQL-based applications are somewhat notorious for their@@ -637,9 +658,11 @@ -- > -- > import Database.PostgreSQL.Simple -- >+-- > hello :: IO Int -- > hello = do--- > conn <- connect defaultConnectInfo--- > query_ conn "select 2 + 2"+-- > conn <- connectPostgreSQL ""+-- > [Only i] <- query_ conn "select 2 + 2"+-- > return i -- -- A 'Query' value does not represent the actual query that will be -- executed, but is a template for constructing the final query.@@ -700,11 +723,26 @@ -- The same kind of problem can arise with string literals if you have -- the @OverloadedStrings@ language extension enabled. Again, just -- use an explicit type signature if this happens.+--+-- Finally, remember that the compiler must be able to infer the type+-- of a query's /results/ as well as its parameters. We might like+-- the following example to work:+--+-- > print =<< query_ conn "select 2 + 2"+--+-- Unfortunately, while a quick glance tells us that the result type+-- should be a single row containing a single numeric column, the+-- compiler has no way to infer what the types are. We can easily fix+-- this by providing an explicit type annotation:+--+-- > xs <- query_ conn "select 2 + 2"+-- > print (xs :: [Only Int]) -- $only_param -- -- Haskell lacks a single-element tuple type, so if you have just one--- value you want substituted into a query, what should you do?+-- value you want substituted into a query or a single-column result,+-- what should you do? -- -- The obvious approach would appear to be something like this: --@@ -719,6 +757,9 @@ -- -- > execute conn "insert into users (first_name) values (?)" -- > ["Nuala"]+--+-- A row of /n/ query results is represented using an /n/-tuple, so+-- you should use 'Only' to represent a single-column result. -- $in --@@ -736,7 +777,7 @@ -- Here's an example: -- -- > query conn "select * from users where first_name in ?" $--- > In ["Anna", "Boris", "Carla"]+-- > Only $ In ["Anna", "Boris", "Carla"] -- -- If your 'In'-wrapped list is empty, the string @\"(null)\"@ will be -- substituted instead, to ensure that your clause remains@@ -861,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
@@ -17,7 +17,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Monoid-import Data.Attoparsec.Char8+import Data.Attoparsec.ByteString.Char8 -- | Parse one of three primitive field formats: array, quoted and plain.@@ -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/BuiltinTypes.hs
@@ -1,420 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}----------------------------------------------------------------------------------- |--- Module: Database.PostgreSQL.Simple.BuiltinTypes--- Copyright: (c) 2011-2012 Leon P Smith--- License: BSD3--- Maintainer: Leon P Smith <leon@melding-monads.com>--- Stability: experimental-------------------------------------------------------------------------------------- Note that this file is generated by tools/GenBuiltinTypes.hs, and should--- not be edited directly--module Database.PostgreSQL.Simple.BuiltinTypes- {-# DEPRECATED "Use TypeInfo instead" #-}- ( BuiltinType (..)- , builtin2oid- , oid2builtin- , builtin2typname- , oid2typname- ) where--import Data.Typeable-import Data.ByteString (ByteString)-import qualified Database.PostgreSQL.LibPQ as PQ--data BuiltinType- = Bool- | ByteA- | Char- | Name- | Int8- | Int2- | Int4- | RegProc- | Text- | Oid- | Tid- | Xid- | Cid- | Xml- | Point- | LSeg- | Path- | Box- | Polygon- | Line- | Cidr- | Float4- | Float8- | AbsTime- | RelTime- | TInterval- | Unknown- | Circle- | Money- | MacAddr- | Inet- | BpChar- | VarChar- | Date- | Time- | Timestamp- | TimestampTZ- | Interval- | TimeTZ- | Bit- | VarBit- | Numeric- | RefCursor- | Record- | Void- | UUID- | JSON- deriving (Eq, Ord, Enum, Bounded, Read, Show, Typeable)--builtin2oid :: BuiltinType -> PQ.Oid-builtin2oid typ = PQ.Oid $ case typ of- Bool -> 16- ByteA -> 17- Char -> 18- Name -> 19- Int8 -> 20- Int2 -> 21- Int4 -> 23- RegProc -> 24- Text -> 25- Oid -> 26- Tid -> 27- Xid -> 28- Cid -> 29- Xml -> 142- Point -> 600- LSeg -> 601- Path -> 602- Box -> 603- Polygon -> 604- Line -> 628- Cidr -> 650- Float4 -> 700- Float8 -> 701- AbsTime -> 702- RelTime -> 703- TInterval -> 704- Unknown -> 705- Circle -> 718- Money -> 790- MacAddr -> 829- Inet -> 869- BpChar -> 1042- VarChar -> 1043- Date -> 1082- Time -> 1083- Timestamp -> 1114- TimestampTZ -> 1184- Interval -> 1186- TimeTZ -> 1266- Bit -> 1560- VarBit -> 1562- Numeric -> 1700- RefCursor -> 1790- Record -> 2249- Void -> 2278- UUID -> 2950- JSON -> 114--oid2builtin :: PQ.Oid -> Maybe BuiltinType-oid2builtin (PQ.Oid x) = case x of- 16 -> Just Bool- 17 -> Just ByteA- 18 -> Just Char- 19 -> Just Name- 20 -> Just Int8- 21 -> Just Int2- 23 -> Just Int4- 24 -> Just RegProc- 25 -> Just Text- 26 -> Just Oid- 27 -> Just Tid- 28 -> Just Xid- 29 -> Just Cid- 142 -> Just Xml- 600 -> Just Point- 601 -> Just LSeg- 602 -> Just Path- 603 -> Just Box- 604 -> Just Polygon- 628 -> Just Line- 650 -> Just Cidr- 700 -> Just Float4- 701 -> Just Float8- 702 -> Just AbsTime- 703 -> Just RelTime- 704 -> Just TInterval- 705 -> Just Unknown- 718 -> Just Circle- 790 -> Just Money- 829 -> Just MacAddr- 869 -> Just Inet- 1042 -> Just BpChar- 1043 -> Just VarChar- 1082 -> Just Date- 1083 -> Just Time- 1114 -> Just Timestamp- 1184 -> Just TimestampTZ- 1186 -> Just Interval- 1266 -> Just TimeTZ- 1560 -> Just Bit- 1562 -> Just VarBit- 1700 -> Just Numeric- 1790 -> Just RefCursor- 2249 -> Just Record- 2278 -> Just Void- 2950 -> Just UUID- 114 -> Just JSON- _ -> Nothing--builtin2typname :: BuiltinType -> ByteString-builtin2typname typ = case typ of- Bool -> bool- ByteA -> bytea- Char -> char- Name -> name- Int8 -> int8- Int2 -> int2- Int4 -> int4- RegProc -> regproc- Text -> text- Oid -> oid- Tid -> tid- Xid -> xid- Cid -> cid- Xml -> xml- Point -> point- LSeg -> lseg- Path -> path- Box -> box- Polygon -> polygon- Line -> line- Cidr -> cidr- Float4 -> float4- Float8 -> float8- AbsTime -> abstime- RelTime -> reltime- TInterval -> tinterval- Unknown -> unknown- Circle -> circle- Money -> money- MacAddr -> macaddr- Inet -> inet- BpChar -> bpchar- VarChar -> varchar- Date -> date- Time -> time- Timestamp -> timestamp- TimestampTZ -> timestamptz- Interval -> interval- TimeTZ -> timetz- Bit -> bit- VarBit -> varbit- Numeric -> numeric- RefCursor -> refcursor- Record -> record- Void -> void- UUID -> uuid- JSON -> json--oid2typname :: PQ.Oid -> Maybe ByteString-oid2typname (PQ.Oid x) = case x of- 16 -> Just bool- 17 -> Just bytea- 18 -> Just char- 19 -> Just name- 20 -> Just int8- 21 -> Just int2- 23 -> Just int4- 24 -> Just regproc- 25 -> Just text- 26 -> Just oid- 27 -> Just tid- 28 -> Just xid- 29 -> Just cid- 142 -> Just xml- 600 -> Just point- 601 -> Just lseg- 602 -> Just path- 603 -> Just box- 604 -> Just polygon- 628 -> Just line- 650 -> Just cidr- 700 -> Just float4- 701 -> Just float8- 702 -> Just abstime- 703 -> Just reltime- 704 -> Just tinterval- 705 -> Just unknown- 718 -> Just circle- 790 -> Just money- 829 -> Just macaddr- 869 -> Just inet- 1042 -> Just bpchar- 1043 -> Just varchar- 1082 -> Just date- 1083 -> Just time- 1114 -> Just timestamp- 1184 -> Just timestamptz- 1186 -> Just interval- 1266 -> Just timetz- 1560 -> Just bit- 1562 -> Just varbit- 1700 -> Just numeric- 1790 -> Just refcursor- 2249 -> Just record- 2278 -> Just void- 2950 -> Just uuid- 114 -> Just json- _ -> Nothing--bool :: ByteString-bool = "bool"--bytea :: ByteString-bytea = "bytea"--char :: ByteString-char = "char"--name :: ByteString-name = "name"--int8 :: ByteString-int8 = "int8"--int2 :: ByteString-int2 = "int2"--int4 :: ByteString-int4 = "int4"--regproc :: ByteString-regproc = "regproc"--text :: ByteString-text = "text"--oid :: ByteString-oid = "oid"--tid :: ByteString-tid = "tid"--xid :: ByteString-xid = "xid"--cid :: ByteString-cid = "cid"--xml :: ByteString-xml = "xml"--point :: ByteString-point = "point"--lseg :: ByteString-lseg = "lseg"--path :: ByteString-path = "path"--box :: ByteString-box = "box"--polygon :: ByteString-polygon = "polygon"--line :: ByteString-line = "line"--cidr :: ByteString-cidr = "cidr"--float4 :: ByteString-float4 = "float4"--float8 :: ByteString-float8 = "float8"--abstime :: ByteString-abstime = "abstime"--reltime :: ByteString-reltime = "reltime"--tinterval :: ByteString-tinterval = "tinterval"--unknown :: ByteString-unknown = "unknown"--circle :: ByteString-circle = "circle"--money :: ByteString-money = "money"--macaddr :: ByteString-macaddr = "macaddr"--inet :: ByteString-inet = "inet"--bpchar :: ByteString-bpchar = "bpchar"--varchar :: ByteString-varchar = "varchar"--date :: ByteString-date = "date"--time :: ByteString-time = "time"--timestamp :: ByteString-timestamp = "timestamp"--timestamptz :: ByteString-timestamptz = "timestamptz"--interval :: ByteString-interval = "interval"--timetz :: ByteString-timetz = "timetz"--bit :: ByteString-bit = "bit"--varbit :: ByteString-varbit = "varbit"--numeric :: ByteString-numeric = "numeric"--refcursor :: ByteString-refcursor = "refcursor"--record :: ByteString-record = "record"--void :: ByteString-void = "void"--uuid :: ByteString-uuid = "uuid"--json :: ByteString-json = "json"
src/Database/PostgreSQL/Simple/Compat.hs view
@@ -5,19 +5,20 @@ ( mask , (<>) , unsafeDupablePerformIO+ , toByteString+ , scientificBuilder+ , toPico+ , fromPico ) where import qualified Control.Exception as E-import Data.Monoid--#if __GLASGOW_HASKELL__ >= 702+import Data.ByteString (ByteString)+import Data.ByteString.Lazy (toStrict)+import Data.ByteString.Builder (Builder, toLazyByteString)+import Data.Text.Lazy.Builder.Scientific (scientificBuilder) import System.IO.Unsafe (unsafeDupablePerformIO)-#elif __GLASGOW_HASKELL__ >= 611-import GHC.IO (unsafeDupablePerformIO)-#else-import GHC.IOBase (unsafeDupablePerformIO)-#endif-+import Data.Fixed (Pico)+import Data.Fixed (Fixed(MkFixed)) -- | Like 'E.mask', but backported to base before version 4.3.0. --@@ -27,19 +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 <>+toByteString :: Builder -> ByteString+toByteString x = toStrict (toLazyByteString x) -(<>) :: Monoid m => m -> m -> m-(<>) = mappend-{-# INLINE (<>) #-}-#endif+toPico :: Integer -> Pico+toPico = MkFixed++fromPico :: Pico -> Integer+fromPico (MkFixed i) = i
src/Database/PostgreSQL/Simple/Copy.hs view
@@ -9,7 +9,7 @@ -- Stability: experimental -- -- mid-level support for COPY IN and COPY OUT. See--- <http://www.postgresql.org/docs/9.2/static/sql-copy.html> for+-- <https://www.postgresql.org/docs/9.5/static/sql-copy.html> for -- more information. -- -- To use this binding, first call 'copy' with an appropriate@@ -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@@ -75,18 +76,22 @@ doCopy funcName conn template q = do result <- exec conn q status <- PQ.resultStatus result- let err = throwIO $ QueryError- (B.unpack funcName ++ " " ++ show status)+ let errMsg msg = throwIO $ QueryError+ (B.unpack funcName ++ " " ++ msg) template+ let err = errMsg $ show status case status of PQ.EmptyQuery -> err PQ.CommandOk -> err PQ.TuplesOk -> err PQ.CopyOut -> return () PQ.CopyIn -> return ()+ PQ.CopyBoth -> errMsg "COPY BOTH is not supported"+ PQ.SingleTuple -> errMsg "single-row mode is not supported" 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@@ -97,6 +102,30 @@ 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 -- must be in the @CopyOut@ state in order to call this function. If this -- returns a 'CopyOutRow', the connection remains in the @CopyOut@ state,@@ -186,6 +215,7 @@ putCopyError :: Connection -> B.ByteString -> IO () putCopyError conn err = withConnection conn $ \pqconn -> do doCopyIn funcName (\c -> PQ.putCopyEnd c (Just err)) pqconn+ consumeResults pqconn where funcName = "Database.PostgreSQL.Simple.Copy.putCopyError" @@ -220,10 +250,21 @@ getCopyCommandTag funcName pqconn = do result <- maybe (fail errCmdStatus) return =<< PQ.getResult pqconn cmdStat <- maybe (fail errCmdStatus) return =<< PQ.cmdStatus result+ consumeResults pqconn let rowCount = P.string "COPY " *> (P.decimal <* P.endOfInput) case P.parseOnly rowCount cmdStat of- Left _ -> fail errCmdStatusFmt+ Left _ -> do mmsg <- PQ.errorMessage pqconn+ fail $ errCmdStatusFmt+ ++ maybe "" (\msg -> "\nConnection error: "++B.unpack msg) mmsg Right n -> return $! n where errCmdStatus = B.unpack funcName ++ ": failed to fetch command status" errCmdStatusFmt = B.unpack funcName ++ ": failed to parse command status"+++consumeResults :: PQ.Connection -> IO ()+consumeResults pqconn = do+ mres <- PQ.getResult pqconn+ case mres of+ Nothing -> return ()+ Just _ -> consumeResults pqconn
+ src/Database/PostgreSQL/Simple/Cursor.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings #-}++------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.Cursor+-- Copyright: (c) 2011-2012 Leon P Smith+-- (c) 2017 Bardur Arantsson+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+--+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.Cursor+ (+ -- * Types+ Cursor+ -- * Cursor management+ , declareCursor+ , closeCursor+ -- * Folding over rows from a cursor+ , foldForward+ , foldForwardWithParser+ ) where++import Data.ByteString.Builder (intDec)+import Control.Applicative ((<$>))+import Control.Exception as E+import Control.Monad (unless, void)+import Data.Monoid (mconcat)+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 hiding (result, row)+import Database.PostgreSQL.Simple.Internal.PQResultUtils+import Database.PostgreSQL.Simple.Transaction+import qualified Database.PostgreSQL.LibPQ as PQ++-- | Cursor within a transaction.+data Cursor = Cursor !Query !Connection++-- | Declare a temporary cursor. The cursor is given a+-- unique name for the given connection.+declareCursor :: Connection -> Query -> IO Cursor+declareCursor conn q = do+ name <- newTempName conn+ void $ execute_ conn $ mconcat ["DECLARE ", name, " NO SCROLL CURSOR FOR ", q]+ return $ Cursor name conn++-- | Close the given cursor.+closeCursor :: Cursor -> IO ()+closeCursor (Cursor name conn) =+ (void $ execute_ conn ("CLOSE " <> name)) `E.catch` \ex ->+ -- Don't throw exception if CLOSE failed because the transaction is+ -- aborted. Otherwise, it will throw away the original error.+ unless (isFailedTransactionError ex) $ throwIO ex++-- | Fold over a chunk of rows from the given cursor, calling the+-- supplied fold-like function on each row as it is received. In case+-- the cursor is exhausted, a 'Left' value is returned, otherwise a+-- 'Right' value is returned.+foldForwardWithParser :: Cursor -> RowParser r -> Int -> (a -> r -> IO a) -> a -> IO (Either a a)+foldForwardWithParser (Cursor name conn) parser chunkSize f a0 = do+ let q = "FETCH FORWARD "+ <> (toByteString $ intDec chunkSize)+ <> " FROM "+ <> fromQuery name+ result <- exec conn q+ status <- PQ.resultStatus result+ case status of+ PQ.TuplesOk -> do+ nrows <- PQ.ntuples result+ ncols <- PQ.nfields result+ if nrows > 0+ then do+ let inner a row = do+ x <- getRowWith parser row ncols conn result+ f a x+ Right <$> foldM' inner a0 0 (nrows - 1)+ else+ return $ Left a0+ _ -> throwResultError "foldForwardWithParser" result status++-- | Fold over a chunk of rows, calling the supplied fold-like function+-- on each row as it is received. In case the cursor is exhausted,+-- a 'Left' value is returned, otherwise a 'Right' value is returned.+foldForward :: FromRow r => Cursor -> Int -> (a -> r -> IO a) -> a -> IO (Either a a)+foldForward cursor = foldForwardWithParser cursor fromRow+++foldM' :: (Ord n, Num n) => (a -> n -> IO a) -> a -> n -> n -> IO a+foldM' f a lo hi = loop a lo+ where+ loop x !n+ | n > hi = return x+ | otherwise = do+ x' <- f x n+ loop x' (n+1)+{-# INLINE foldM' #-}
src/Database/PostgreSQL/Simple/Errors.hs view
@@ -25,10 +25,9 @@ ) where -import Control.Applicative import Control.Exception as E -import Data.Attoparsec.Char8+import Data.Attoparsec.ByteString.Char8 import Data.ByteString (ByteString) import Data.Typeable @@ -55,19 +54,23 @@ -- ^ Name of violated constraint | CheckViolation ByteString ByteString -- ^ Relation name (usually table), constraint name+ | ExclusionViolation ByteString+ -- ^ Name of the exclusion violation constraint 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 = catchJust constraintViolation catcher $ execute conn ...+-- > createUser = handleJust constraintViolation handler $ execute conn ... -- > where--- > catcher UniqueViolation "user_login_key" = ...--- > catcher _ = ...+-- > handler (UniqueViolation "user_login_key") = ...+-- > handler _ = ... constraintViolation :: SqlError -> Maybe ConstraintViolation constraintViolation e = case sqlState e of@@ -75,22 +78,23 @@ "23503" -> uncurry ForeignKeyViolation <$> parseMaybe parseQ2 msg "23505" -> UniqueViolation <$> parseMaybe parseQ1 msg "23514" -> uncurry CheckViolation <$> parseMaybe parseQ2 msg+ "23P01" -> ExclusionViolation <$> parseMaybe parseQ1 msg _ -> Nothing where msg = sqlErrorMsg e -- | Like constraintViolation, but also packs original SqlError. ----- > createUser = catchJust constraintViolationE catcher $ execute conn ...+-- > createUser = handleJust constraintViolationE handler $ execute conn ... -- > where--- > catcher (_, UniqueViolation "user_login_key") = ...--- > catcher (e, _) = throwIO e+-- > handler (_, UniqueViolation "user_login_key") = ...+-- > handler (e, _) = throwIO e -- constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation) constraintViolationE e = fmap ((,) e) $ constraintViolation e -- | Catches SqlError, tries to convert to ConstraintViolation, re-throws--- on fail. Provides alternative interface to catchJust+-- on fail. Provides alternative interface to 'E.handleJust' -- -- > createUser = catchViolation catcher $ execute conn ... -- > where@@ -121,7 +125,7 @@ ------------------------------------------------------------------------ -- Error predicates ----- http://www.postgresql.org/docs/current/static/errcodes-appendix.html+-- https://www.postgresql.org/docs/9.5/static/errcodes-appendix.html isSerializationError :: SqlError -> Bool isSerializationError = isSqlState "40001"
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@@ -23,6 +24,24 @@ since a 'Double' might lose precision if representing PostgreSQL's 64-bit @bigint@, the two are /not/ considered compatible. +Note that the 'Float' and 'Double' instances use attoparsec's 'double'+conversion routine, which sacrifices some accuracy for speed. If you+need accuracy, consider first converting data to a 'Scientific' or 'Rational'+type, and then converting to a floating-point type. If you are defining+your own 'Database.PostgreSQL.Simple.FromRow.FromRow' instances, this can be+achieved simply by+@'fromRational' '<$>' 'Database.PostgreSQL.Simple.FromRow.field'@, although+this idiom is additionally compatible with PostgreSQL's @int8@ and @numeric@+types. If this is unacceptable, you may find+'Database.PostgreSQL.Simple.FromRow.fieldWith' useful.++Also note that while converting to a 'Double' through the 'Scientific' type+is likely somewhat faster than converting through the 'Rational' type,+the 'Scientific' type has no way to represent @NaN@ and @±Infinity@ values.+Thus, if you need precision conversion of regular floating point values+and the possibility of receiving these special values from the backend,+stick with 'Rational'.+ Because 'FromField' is a typeclass, one may provide conversions to additional Haskell types without modifying postgresql-simple. This is particularly useful for supporting PostgreSQL types that postgresql-simple@@ -87,32 +106,38 @@ , typeOid , PQ.Oid(..) , PQ.Format(..)+ , pgArrayFieldParser+ , attoFieldParser + , optionalField , fromJSONField+ , fromFieldJSONByteString ) where #include "MachDeps.h" -import Control.Applicative- ( Applicative, (<|>), (<$>), pure )-import Control.Exception (Exception)+import Control.Applicative ( Const(Const), (<|>), (<$>), pure, (*>), (<*) )+import Control.Concurrent.MVar (MVar, newMVar)+import Control.Exception (Exception (toException, fromException)) import qualified Data.Aeson as JSON-import Data.Attoparsec.Char8 hiding (Result)+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) import qualified Data.Vector as V import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Compat import Database.PostgreSQL.Simple.Ok-import Database.PostgreSQL.Simple.Types (Binary(..), Null(..))+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@@ -122,9 +147,15 @@ import qualified Data.Text as ST import qualified Data.Text.Encoding as ST import qualified Data.Text.Lazy as LT-import Data.UUID (UUID)-import qualified Data.UUID as UUID+import Data.CaseInsensitive (CI)+import qualified Data.CaseInsensitive as CI+import Data.UUID.Types (UUID)+import qualified Data.UUID.Types as UUID+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@@ -151,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@@ -167,16 +200,15 @@ -- library instances, this will usually be a single 'ResultError', but -- may be a 'UnicodeException'. --- -- Note that retaining any reference to the 'Field' or 'ByteString'- -- arguments causes the entire @LibPQ.'PQ.Result'@ to be retained.- -- Thus, as a rule of thumb, implementations of 'fromField' should- -- not refer to these values after the result has been evaluated- -- to WHNF. But it can be profitable to break this rule when you- -- know it won't cause memory management problems.+ -- Note that retaining any reference to the 'Field' argument causes+ -- the entire @LibPQ.'PQ.Result'@ to be retained. Thus, implementations+ -- of 'fromField' should return results that do not refer to this value+ -- after the result have been evaluated to WHNF. --- -- The instances included with postgresql-simple follow this rule- -- of thumb (modulo bugs). For example, the instance for 'ByteString'- -- uses 'B.copy' to avoid such a reference.+ -- Note that as of @postgresql-simple-0.4.0.0@, the 'ByteString' value+ -- has already been copied out of the @LibPQ.'PQ.Result'@ before it has+ -- been passed to 'fromField'. This is because for short strings, it's+ -- cheaper to copy the string than to set up a finalizer. -- | Returns the data type name. This is the preferred way of identifying -- types that do not have a stable type oid, such as types provided by@@ -193,7 +225,7 @@ typeInfo :: Field -> Conversion TypeInfo typeInfo Field{..} = Conversion $ \conn -> do- Ok <$> (getTypeInfo conn =<< PQ.ftype result column)+ Ok <$> (getTypeInfo conn typeOid) typeInfoByOid :: PQ.Oid -> Conversion TypeInfo typeInfoByOid oid = Conversion $ \conn -> do@@ -218,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))@@ -236,17 +270,34 @@ -- | 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 -- behavior.-instance (FromField a) => FromField (Maybe a) where- fromField _ Nothing = pure Nothing- fromField f bs = Just <$> fromField f bs+instance FromField a => FromField (Maybe a) where+ fromField = optionalField fromField +-- | For dealing with SQL @null@ values outside of the 'FromField' class.+-- Alternatively, one could use 'Control.Applicative.optional', but that+-- also turns type and conversion errors into 'Nothing', whereas this is+-- more specific and turns only @null@ values into 'Nothing'.++optionalField :: FieldParser a -> FieldParser (Maybe a)+optionalField p f mv =+ case mv of+ Nothing -> pure Nothing+ Just _ -> Just <$> p f mv+{-# INLINE optionalField #-}+ -- | compatible with any data type, but the value must be null instance FromField Null where fromField _ Nothing = pure Null@@ -255,30 +306,30 @@ -- | 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 | otherwise = returnError ConversionFailed f "" --- | \"char\"+-- | \"char\", bpchar instance FromField Char where- fromField f bs =- if typeOid f /= $(inlineTypoid TI.char)- then returnError Incompatible f ""- else 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" else return $! (B.head bs)+ else returnError Incompatible f "" -- | 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.@@ -288,43 +339,64 @@ -- 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+-- | int2, float4 (Uses attoparsec's 'double' routine, for+-- better accuracy convert to 'Scientific' or 'Rational' first) instance FromField Float where- fromField = atto ok (realToFrac <$> 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+-- | 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 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, float4, float8, numeric+-- | int2, int4, int8, float4, float8, numeric instance FromField (Ratio Integer) where- fromField = atto ok rational- where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,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 = 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 +pg_double :: Parser Double+pg_double+ = (string "NaN" *> pure ( 0 / 0))+ <|> (string "Infinity" *> pure ( 1 / 0))+ <|> (string "-Infinity" *> pure (-1 / 0))+ <|> double++pg_rational :: Parser Rational+pg_rational+ = (string "NaN" *> pure notANumber )+ <|> (string "Infinity" *> pure infinity )+ <|> (string "-Infinity" *> pure (-infinity))+ <|> rational+ -- | 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 . B.copy) 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@@ -332,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) @@ -340,7 +412,7 @@ instance FromField (Binary SB.ByteString) where fromField f dat = case format f of PQ.Text -> doFromField f okBinary (unescapeBytea f) dat- PQ.Binary -> doFromField f okBinary (pure . Binary . B.copy) dat+ PQ.Binary -> doFromField f okBinary (pure . Binary) dat -- | bytea instance FromField (Binary LB.ByteString) where@@ -355,54 +427,85 @@ instance FromField LT.Text where fromField f dat = LT.fromStrict <$> fromField f dat +-- | citext+instance FromField (CI ST.Text) where+ fromField f mdat = do+ typ <- typename f+ if typ /= "citext"+ then returnError Incompatible f ""+ else case mdat of+ Nothing -> returnError UnexpectedNull f ""+ Just dat -> either left (pure . CI.mk)+ (ST.decodeUtf8' dat)++-- | citext+instance FromField (CI LT.Text) where+ fromField f mdat = do+ typ <- typename f+ if typ /= "citext"+ then returnError Incompatible f ""+ else case mdat of+ Nothing -> returnError UnexpectedNull f ""+ Just dat -> either left (pure . CI.mk . LT.fromStrict)+ (ST.decodeUtf8' dat)+ -- | name, text, \"char\", bpchar, varchar instance FromField [Char] where fromField f dat = ST.unpack <$> fromField f dat -- | 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@@ -423,33 +526,45 @@ <|> (Left <$> fromField f dat) -- | any postgresql array whose elements are compatible with type @a@-instance (FromField a, Typeable a) => FromField (Vector a) where- fromField f mdat = do+instance (FromField a, Typeable a) => FromField (PGArray a) where+ fromField = pgArrayFieldParser fromField++pgArrayFieldParser :: Typeable a => FieldParser a -> FieldParser (PGArray a)+pgArrayFieldParser fieldParser f mdat = do info <- typeInfo f case info of TI.Array{} -> case mdat of Nothing -> returnError UnexpectedNull f "" Just dat -> do- case parseOnly (fromArray info f) dat of+ case parseOnly (fromArray fieldParser info f) dat of Left err -> returnError ConversionFailed f err- Right conv -> V.fromList <$> conv+ Right conv -> PGArray <$> conv _ -> returnError Incompatible f "" -fromArray :: (FromField a)- => TypeInfo -> Field -> Parser (Conversion [a])-fromArray typeInfo f = sequence . (parseIt <$>) <$> array delim+fromArray :: FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a])+fromArray fieldParser typInfo f = sequence . (parseIt <$>) <$> array delim where- delim = typdelim (typelem typeInfo)- fElem = f{ typeOid = typoid (typelem typeInfo) }- parseIt item = (fromField f' . Just . fmt delim) item- where f' | Arrays.Array _ <- item = f- | otherwise = fElem+ delim = typdelim (typelem typInfo)+ fElem = f{ typeOid = typoid (typelem typInfo) } + parseIt item =+ fieldParser f' $ if item == Arrays.Plain "NULL" then Nothing else Just item'+ where+ item' = fmt delim item+ f' | Arrays.Array _ <- item = f+ | otherwise = fElem++instance (FromField a, Typeable a) => FromField (Vector a) where+ fromField f v = V.fromList . fromPGArray <$> fromField f v++instance (FromField a, Typeable a) => FromField (IOVector a) where+ fromField f v = liftConversion . V.unsafeThaw =<< fromField f v+ -- | 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 ""@@ -458,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)+ 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 JSON.eitherDecodeStrict' 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@@ -479,31 +600,66 @@ -- -- The 'Typeable' constraint is required to show more informative -- error messages when parsing fails.+--+-- Note that @fromJSONField :: FieldParser ('Maybe' Foo)@ will return+-- @'Nothing'@ on the json @null@ value, and return an exception on SQL @null@+-- value. Alternatively, one could write @'optionalField' fromJSONField@+-- that will return @Nothing@ on SQL @null@, and otherwise will call+-- @fromJSONField :: FieldParser Foo@ and then return @'Just'@ the+-- result value, or return its exception. If one would+-- like to return @Nothing@ on both the SQL @null@ and json @null@ values,+-- one way to do it would be to write+-- @\\f mv -> 'Control.Monad.join' '<$>' optionalField fromJSONField f mv@ 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+-- the local process on the local machine.+instance FromField a => FromField (IORef a) where+ fromField f v = liftConversion . newIORef =<< fromField f v++-- | Compatible with the same set of types as @a@. Note that+-- modifying the 'MVar' does not have any effects outside+-- the local process on the local machine.+instance FromField a => FromField (MVar a) where+ fromField f v = liftConversion . newMVar =<< fromField f v+ 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@@ -528,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
@@ -1,5 +1,7 @@-{-# LANGUAGE RecordWildCards, FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards, FlexibleInstances, DefaultSignatures #-} + ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.FromRow@@ -27,7 +29,7 @@ ) where import Prelude hiding (null)-import Control.Applicative (Applicative(..), (<$>), (<|>), (*>))+import Control.Applicative (Applicative(..), (<$>), (<|>), (*>), liftA2) import Control.Monad (replicateM, replicateM_) import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader@@ -45,13 +47,17 @@ import Database.PostgreSQL.Simple.Types ((:.)(..), Null) import Database.PostgreSQL.Simple.TypeInfo +import GHC.Generics++ -- | A collection type that can be converted from a sequence of fields. -- Instances are provided for tuples up to 10 elements and lists of any length. -- -- Note that instances can be defined outside of postgresql-simple, which is -- often useful. For example, here's an instance for a user-defined pair: ----- @data User = User { name :: String, fileQuota :: Int }+-- @+-- data User = User { name :: String, fileQuota :: Int } -- -- instance 'FromRow' User where -- fromRow = User \<$\> 'field' \<*\> 'field'@@ -61,16 +67,35 @@ -- in a single row of the query result. Otherwise, a 'ConversionFailed' -- exception will be thrown. ----- Note that 'field' evaluates it's result to WHNF, so the caveats listed in+-- 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 -- of 'fromField'. class FromRow a where fromRow :: RowParser a+ default fromRow :: (Generic a, GFromRow (Rep a)) => RowParser a+ fromRow = to <$> gfromRow getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString-getvalue result row col = unsafeDupablePerformIO (PQ.getvalue result row col)+getvalue result row col = unsafeDupablePerformIO (PQ.getvalue' result row col) nfields :: PQ.Result -> PQ.Column nfields result = unsafeDupablePerformIO (PQ.nfields result)@@ -106,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@@ -230,6 +255,196 @@ 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)+ instance FromField a => FromRow [a] where fromRow = do n <- numFieldsRemaining@@ -252,3 +467,21 @@ instance (FromRow a, FromRow b) => FromRow (a :. b) where fromRow = (:.) <$> fromRow <*> fromRow++++-- Type class for default implementation of FromRow using generics+class GFromRow f where+ gfromRow :: RowParser (f p)++instance GFromRow f => GFromRow (M1 c i f) where+ gfromRow = M1 <$> gfromRow++instance (GFromRow f, GFromRow g) => GFromRow (f :*: g) where+ gfromRow = liftA2 (:*:) gfromRow gfromRow++instance (FromField a) => GFromRow (K1 R a) where+ gfromRow = K1 <$> field++instance GFromRow U1 where+ gfromRow = pure U1
src/Database/PostgreSQL/Simple/FromRow.hs-boot view
@@ -8,11 +8,10 @@ instance (FromField a) => FromRow (Only a) instance (FromField a, FromField b) => FromRow (a,b)-instance (FromField a, FromField b, FromField c, FromField d) +instance (FromField a, FromField b, FromField c, FromField d) => FromRow (a,b,c,d)-instance (FromField a, FromField b, FromField c, FromField d, FromField e) +instance (FromField a, FromField b, FromField c, FromField d, FromField e) => FromRow (a,b,c,d,e) instance (FromField a, FromField b, FromField c, FromField d, FromField e- ,FromField f) + ,FromField f) => FromRow (a,b,c,d,e,f)-
src/Database/PostgreSQL/Simple/HStore.hs view
@@ -8,14 +8,14 @@ -- -- Parsers and printers for hstore, a extended type bundled with -- PostgreSQL providing finite maps from text strings to text strings.--- See <http://www.postgresql.org/docs/9.2/static/hstore.html> for more+-- See <https://www.postgresql.org/docs/9.5/static/hstore.html> for more -- information. -- -- Note that in order to use this type, a database superuser must -- install it by running a sql script in the share directory. This -- can be done on PostgreSQL 9.1 and later with the command -- @CREATE EXTENSION hstore@. See--- <http://www.postgresql.org/docs/9.2/static/contrib.html> for more+-- <https://www.postgresql.org/docs/9.5/static/contrib.html> for more -- information. -- ------------------------------------------------------------------------------@@ -28,6 +28,7 @@ , toBuilder , toLazyByteString , hstore+ , parseHStoreList , ToHStoreText(..) , HStoreText ) where
src/Database/PostgreSQL/Simple/HStore/Implementation.hs view
@@ -15,17 +15,13 @@ module Database.PostgreSQL.Simple.HStore.Implementation where import Control.Applicative-import Blaze.ByteString.Builder as Blaze- ( Builder, toLazyByteString, copyByteString )-import Blaze.ByteString.Builder.Char8 (fromChar) import qualified Data.Attoparsec.ByteString as P import qualified Data.Attoparsec.ByteString.Char8 as P (isSpace_w8) import qualified Data.ByteString as BS+import Data.ByteString.Builder (Builder, byteString, char8)+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)@@ -35,6 +31,7 @@ import qualified Data.Text.Lazy as TL import Data.Typeable import Data.Monoid(Monoid(..))+import Data.Semigroup import Database.PostgreSQL.Simple.FromField import Database.PostgreSQL.Simple.ToField @@ -53,26 +50,28 @@ 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 -> Blaze.toLazyByteString x+ Comma c -> BU.toLazyByteString c -instance Monoid HStoreBuilder where- mempty = Empty- mappend Empty x = x- mappend (Comma a) x+instance Semigroup HStoreBuilder where+ Empty <> x = x+ Comma a <> x = Comma (a `mappend` case x of Empty -> mempty- Comma b -> fromChar ',' `mappend` b)+ Comma b -> char8 ',' `mappend` b) +instance Monoid HStoreBuilder where+ mempty = Empty+ class ToHStoreText a where toHStoreText :: a -> HStoreText -- | Represents escape text, ready to be the key or value to a hstore value-newtype HStoreText = HStoreText Builder deriving (Typeable, Monoid)+newtype HStoreText = HStoreText Builder deriving (Typeable, Semigroup, Monoid) instance ToHStoreText HStoreText where toHStoreText = id@@ -95,24 +94,24 @@ escapeAppend = loop where loop (BS.break quoteNeeded -> (a,b)) rest- = copyByteString a `mappend`+ = byteString a `mappend` case BS.uncons b of Nothing -> rest Just (c,d) -> quoteChar c `mappend` loop d rest quoteNeeded c = c == c2w '\"' || c == c2w '\\' quoteChar c- | c == c2w '\"' = copyByteString "\\\""- | otherwise = copyByteString "\\\\"+ | c == c2w '\"' = byteString "\\\""+ | otherwise = byteString "\\\\" hstore :: (ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder hstore (toHStoreText -> (HStoreText key)) (toHStoreText -> (HStoreText val)) =- Comma (fromChar '"' `mappend` key `mappend` copyByteString "\"=>\""- `mappend` val `mappend` fromChar '"')+ Comma (char8 '"' `mappend` key `mappend` byteString "\"=>\""+ `mappend` val `mappend` char8 '"') instance ToField HStoreBuilder where toField Empty = toField (BS.empty)- toField (Comma x) = toField (Blaze.toLazyByteString x)+ toField (Comma x) = toField (BU.toLazyByteString x) newtype HStoreList = HStoreList {fromHStoreList :: [(Text,Text)]} deriving (Typeable, Show) @@ -145,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)@@ -153,6 +152,13 @@ instance FromField HStoreMap where fromField f mdat = convert <$> fromField f mdat where convert (HStoreList xs) = HStoreMap (Map.fromList xs)++parseHStoreList :: BS.ByteString -> Either String HStoreList+parseHStoreList dat =+ case P.parseOnly (parseHStore <* P.endOfInput) dat of+ Left err -> Left (show err)+ Right (Left err) -> Left (show err)+ Right (Right val) -> Right val parseHStore :: P.Parser (Either UnicodeException HStoreList) parseHStore = do
src/Database/PostgreSQL/Simple/HStore/Internal.hs view
@@ -1,5 +1,3 @@-{-# OPTIONS_HADDOCK hide #-}- ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.HStore.Internal
src/Database/PostgreSQL/Simple/Internal.hs view
@@ -1,12 +1,13 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE InstanceSigs #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Internal--- Copyright: (c) 2011-2012 Leon P Smith+-- Copyright: (c) 2011-2015 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith <leon@melding-monads.com> -- Stability: experimental@@ -27,25 +28,35 @@ import Control.Concurrent.MVar import Control.Monad(MonadPlus(..)) import Data.ByteString(ByteString)+import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8+import Data.ByteString.Builder ( Builder, byteString ) import Data.Char (ord) import Data.Int (Int64) import qualified Data.IntMap as IntMap import Data.IORef import Data.Maybe(fromMaybe) import Data.String+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE import Data.Typeable import Data.Word import Database.PostgreSQL.LibPQ(Oid(..)) import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.LibPQ(ExecStatus(..))+import Database.PostgreSQL.Simple.Compat ( toByteString ) import Database.PostgreSQL.Simple.Ok+import Database.PostgreSQL.Simple.ToField (Action(..), inQuotes) import Database.PostgreSQL.Simple.Types (Query(..)) import Database.PostgreSQL.Simple.TypeInfo.Types(TypeInfo) 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)+#endif -- | A Field represents metadata about a particular field --@@ -67,21 +78,46 @@ connectionHandle :: {-# UNPACK #-} !(MVar PQ.Connection) , connectionObjects :: {-# UNPACK #-} !(MVar TypeInfoCache) , connectionTempNameCounter :: {-# UNPACK #-} !(IORef Int64)- }+ } deriving (Typeable) +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 , sqlErrorMsg :: ByteString , sqlErrorDetail :: ByteString , sqlErrorHint :: ByteString- } deriving (Show, Typeable)+ } deriving (Eq, Show, Typeable) 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 {@@ -89,15 +125,30 @@ , 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+-- string does not match the number of parameters provided.+data FormatError = FormatError {+ fmtMessage :: String+ , fmtQuery :: Query+ , fmtParams :: [ByteString]+ } deriving (Eq, Show, Typeable)++instance Exception FormatError where+ toException = postgresqlExceptionToException+ fromException = postgresqlExceptionFromException+ data ConnectInfo = ConnectInfo { connectHost :: String , connectPort :: Word16 , connectUser :: String , connectPassword :: String , connectDatabase :: String- } deriving (Eq,Read,Show,Typeable)+ } deriving (Generic,Eq,Read,Show,Typeable) -- | Default information for setting up a connection. --@@ -131,13 +182,85 @@ 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 <http://www.postgresql.org/docs/9.1/static/libpq-connect.html>--- for more information.+-- See <https://www.postgresql.org/docs/9.5/static/libpq-connect.html#LIBPQ-CONNSTRING>+-- for more information. Also note that environment variables also affect+-- parameters not provided, parameters provided as the empty string, and a+-- few other things; see+-- <https://www.postgresql.org/docs/9.5/static/libpq-envars.html>+-- for details. Here is an example with some of the most commonly used+-- parameters:+--+-- > host='db.somedomain.com' port=5432 ...+--+-- This attempts to connect to @db.somedomain.com:5432@. Omitting the port+-- will normally default to 5432.+--+-- On systems that provide unix domain sockets, omitting the host parameter+-- will cause libpq to attempt to connect via unix domain sockets.+-- The default filesystem path to the socket is constructed from the+-- port number and the @DEFAULT_PGSOCKET_DIR@ constant defined in the+-- @pg_config_manual.h@ header file. Connecting via unix sockets tends+-- to use the @peer@ authentication method, which is very secure and+-- does not require a password.+--+-- On Windows and other systems without unix domain sockets, omitting+-- the host will default to @localhost@.+--+-- > ... dbname='postgres' user='postgres' password='secret \' \\ pw'+--+-- This attempts to connect to a database named @postgres@ with+-- user @postgres@ and password @secret \' \\ pw@. Backslash+-- characters will have to be double-quoted in literal Haskell strings,+-- of course. Omitting @dbname@ and @user@ will both default to the+-- system username that the client process is running as.+--+-- 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. 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.+--+-- As all parameters are optional and the defaults are sensible, the+-- empty connection string can be useful for development and+-- exploratory use, assuming your system is set up appropriately.+--+-- On Unix, such a setup would typically consist of a local+-- postgresql server listening on port 5432, as well as a system user,+-- database user, and database sharing a common name, with permissions+-- granted to the user on the database.+--+-- On Windows, in addition you will either need @pg_hba.conf@+-- to specify the use of the @trust@ authentication method for+-- the connection, which may not be appropriate for multiuser+-- or production machines, or you will need to use a @pgpass@ file+-- with the @password@ or @md5@ authentication methods.+--+-- See <https://www.postgresql.org/docs/9.5/static/client-authentication.html>+-- for more information regarding the authentication process.+--+-- SSL/TLS will typically "just work" if your postgresql server supports or+-- requires it. However, note that libpq is trivially vulnerable to a MITM+-- attack without setting additional SSL connection parameters. In+-- particular, @sslmode@ needs to be set to @require@, @verify-ca@, or+-- @verify-full@ in order to perform certificate validation. When @sslmode@+-- is @require@, then you will also need to specify a @sslrootcert@ file,+-- otherwise no validation of the server's identity will be performed.+-- Client authentication via certificates is also possible via the+-- @sslcert@ and @sslkey@ parameters. See+-- <https://www.postgresql.org/docs/9.5/static/libpq-ssl.html>+-- for detailed information regarding libpq and SSL. connectPostgreSQL :: ByteString -> IO Connection connectPostgreSQL connstr = do- conn <- PQ.connectdb connstr+ conn <- connectdb connstr stat <- PQ.status conn case stat of PQ.ConnectionOk -> do@@ -147,15 +270,45 @@ let wconn = Connection{..} version <- PQ.serverVersion conn let settings- | version < 80200 = "SET datestyle TO ISO"- | otherwise = "SET standard_conforming_strings TO on;\- \SET datestyle TO ISO"+ | version < 80200 = "SET datestyle TO ISO;SET client_encoding TO UTF8"+ | otherwise = "SET datestyle TO ISO;SET client_encoding TO UTF8;SET standard_conforming_strings TO on" _ <- execute_ wconn settings return wconn _ -> do msg <- maybe "connectPostgreSQL error" id <$> PQ.errorMessage conn throwIO $ fatalError msg +connectdb :: ByteString -> IO PQ.Connection+#if defined(mingw32_HOST_OS)+connectdb = PQ.connectdb+#else+connectdb conninfo = do+ conn <- PQ.connectStart conninfo+ loop conn+ where+ funcName = "Database.PostgreSQL.Simple.connectPostgreSQL"+ loop conn = do+ status <- PQ.connectPoll conn+ case status of+ PQ.PollingFailed -> throwLibPQError conn "connection failed"+ PQ.PollingReading -> do+ mfd <- PQ.socket conn+ case mfd of+ Nothing -> throwIO $! fdError funcName+ Just fd -> do+ threadWaitRead fd+ loop conn+ PQ.PollingWriting -> do+ mfd <- PQ.socket conn+ case mfd of+ Nothing -> throwIO $! fdError funcName+ Just fd -> do+ threadWaitWrite fd+ loop conn+ PQ.PollingOk -> return conn++#endif+ -- | Turns a 'ConnectInfo' data structure into a libpq connection string. postgreSQLConnectionString :: ConnectInfo -> ByteString@@ -170,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@@ -178,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@@ -197,16 +350,55 @@ exec :: Connection -> ByteString -> IO PQ.Result+#if defined(mingw32_HOST_OS) exec conn sql = withConnection conn $ \h -> do mres <- PQ.exec h sql case mres of- Nothing -> do- msg <- maybe "execute error" id <$> PQ.errorMessage h- throwIO $ fatalError msg- Just res -> do- return res+ Nothing -> throwLibPQError h "PQexec returned no results"+ Just res -> return res+#else+exec conn sql =+ withConnection conn $ \h -> do+ success <- PQ.sendQuery h sql+ if success+ then awaitResult h Nothing+ else throwLibPQError h "PQsendQuery failed"+ where+ awaitResult h mres = do+ mfd <- PQ.socket h+ case mfd of+ Nothing -> throwIO $! fdError "Database.PostgreSQL.Simple.Internal.exec"+ Just fd -> do+ threadWaitRead fd+ _ <- PQ.consumeInput h -- FIXME?+ getResult h mres + getResult h mres = do+ isBusy <- PQ.isBusy h+ if isBusy+ then awaitResult h mres+ else do+ mres' <- PQ.getResult h+ case mres' of+ Nothing -> case mres of+ Nothing -> throwLibPQError h "PQgetResult returned no results"+ Just res -> return res+ Just res -> do+ status <- PQ.resultStatus res+ case status of+ -- FIXME: handle PQ.CopyBoth and PQ.SingleTuple+ PQ.EmptyQuery -> getResult h mres'+ PQ.CommandOk -> getResult h mres'+ PQ.TuplesOk -> getResult h mres'+ PQ.CopyOut -> return res+ PQ.CopyIn -> return res+ 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. execute_ :: Connection -> Query -> IO Int64 execute_ conn q@(Query stmt) = do@@ -217,6 +409,7 @@ finishExecute _conn q result = do status <- PQ.resultStatus result case status of+ -- FIXME: handle PQ.CopyBoth and PQ.SingleTuple PQ.EmptyQuery -> throwIO $ QueryError "execute: Empty query" q PQ.CommandOk -> do ncols <- PQ.nfields result@@ -227,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 ++@@ -239,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'@@ -255,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@@ -325,7 +519,6 @@ Errors _ -> (oka <|>) <$> runConversion mb conn instance Monad Conversion where- return a = Conversion $ \_conn -> return (return a) m >>= f = Conversion $ \conn -> do oka <- runConversion m conn case oka of@@ -340,7 +533,7 @@ conversionMap f m = Conversion $ \conn -> f <$> runConversion m conn conversionError :: Exception err => err -> Conversion a-conversionError err = Conversion $ \_ -> return (Errors [SomeException err])+conversionError err = Conversion $ \_ -> return (Errors [toException err]) newTempName :: Connection -> IO Query newTempName Connection{..} = do@@ -358,3 +551,89 @@ ioe_errno = Nothing, ioe_filename = Nothing }+++libPQError :: ByteString -> IOError+libPQError desc = IOError {+ ioe_handle = Nothing,+ ioe_type = OtherError,+ ioe_location = "libpq",+ ioe_description = B8.unpack desc,+ ioe_errno = Nothing,+ ioe_filename = Nothing+ }++throwLibPQError :: PQ.Connection -> ByteString -> IO a+throwLibPQError conn default_desc = do+ msg <- maybe default_desc id <$> PQ.errorMessage conn+ throwIO $! libPQError msg+++fmtError :: String -> Query -> [Action] -> a+fmtError msg q xs = throw FormatError {+ fmtMessage = msg+ , fmtQuery = q+ , fmtParams = map twiddle xs+ }+ where twiddle (Plain b) = toByteString b+ twiddle (Escape s) = s+ twiddle (EscapeByteA s) = s+ twiddle (EscapeIdentifier s) = s+ twiddle (Many ys) = B.concat (map twiddle ys)++fmtErrorBs :: Query -> [Action] -> ByteString -> a+fmtErrorBs q xs msg = fmtError (T.unpack $ TE.decodeUtf8 msg) q xs++-- | Quote bytestring or throw 'FormatError'+quote :: Query -> [Action] -> Either ByteString ByteString -> Builder+quote q xs = either (fmtErrorBs q xs) (inQuotes . byteString)++buildAction :: Connection -- ^ Connection for string escaping+ -> Query -- ^ Query for message error+ -> [Action] -- ^ List of parameters for message error+ -> Action -- ^ Action to build+ -> IO Builder+buildAction _ _ _ (Plain b) = pure b+buildAction conn q xs (Escape s) = quote q xs <$> escapeStringConn conn s+buildAction conn q xs (EscapeByteA s) = quote q xs <$> escapeByteaConn conn s+buildAction conn q xs (EscapeIdentifier s) =+ either (fmtErrorBs q xs) byteString <$> escapeIdentifier conn s+buildAction conn q xs (Many ys) =+ mconcat <$> mapM (buildAction conn q xs) ys++checkError :: PQ.Connection -> Maybe a -> IO (Either ByteString a)+checkError _ (Just x) = return $ Right x+checkError c Nothing = Left . maybe "" id <$> PQ.errorMessage c++escapeWrap :: (PQ.Connection -> ByteString -> IO (Maybe ByteString))+ -> Connection+ -> ByteString+ -> IO (Either ByteString ByteString)+escapeWrap f conn s =+ withConnection conn $ \c ->+ f c s >>= checkError c++escapeStringConn :: Connection -> ByteString -> IO (Either ByteString ByteString)+escapeStringConn = escapeWrap PQ.escapeStringConn++escapeIdentifier :: Connection -> ByteString -> IO (Either ByteString ByteString)+escapeIdentifier = escapeWrap PQ.escapeIdentifier++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
@@ -0,0 +1,124 @@+{-# LANGUAGE CPP #-}++------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.Internal.PQResultUtils+-- Copyright: (c) 2011 MailRank, Inc.+-- (c) 2011-2012 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+--+------------------------------------------------------------------------------+++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 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 = 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 -> k+ PQ.EmptyQuery -> queryErr "query: Empty query"+ 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"+ PQ.CopyBoth -> queryErr "query: COPY BOTH is not supported"+ PQ.SingleTuple -> queryErr "query: single-row mode is not supported"+ 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++getRowWith :: RowParser r -> PQ.Row -> PQ.Column -> Connection -> PQ.Result -> IO r+getRowWith parser row ncols conn result = do+ let rw = Row row result+ let unCol (PQ.Col x) = fromIntegral x :: Int+ okvc <- runConversion (runStateT (runReaderT (unRP parser) rw) 0) conn+ case okvc of+ Ok (val,col) | col == ncols -> return val+ | otherwise -> do+ vals <- forM' 0 (ncols-1) $ \c -> do+ tinfo <- getTypeInfo conn =<< PQ.ftype result c+ v <- PQ.getvalue result row c+ return ( tinfo+ , fmap ellipsis v )+ throw (ConversionFailed+ (show (unCol ncols) ++ " values: " ++ show vals)+ Nothing+ ""+ (show (unCol col) ++ " slots in target type")+ "mismatch between number of columns to convert and number in target type")+ Errors [] -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error"+ Errors [x] -> throwIO x+ Errors xs -> throwIO $ ManyErrors xs++ellipsis :: ByteString -> ByteString+ellipsis bs+ | B.length bs > 15 = B.take 10 bs `B.append` "[...]"+ | otherwise = bs++forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a]+forM' lo hi m = loop hi []+ where+ loop !n !as+ | n < lo = return as+ | otherwise = do+ a <- m n+ loop (n-1) (a:as)+{-# INLINE forM' #-}
src/Database/PostgreSQL/Simple/LargeObjects.hs view
@@ -7,14 +7,14 @@ -- Maintainer : leon@melding-monads.com -- -- Support for PostgreSQL's Large Objects; see--- <http://www.postgresql.org/docs/9.1/static/largeobjects.html> for more+-- <https://www.postgresql.org/docs/9.5/static/largeobjects.html> for more -- information. -- -- Note that Large Object File Descriptors are only valid within a single -- database transaction, so if you are interested in using anything beyond -- 'loCreat', 'loCreate', and 'loUnlink', you will need to run the entire -- sequence of functions in a transaction. As 'loImport' and 'loExport'--- are simply C functions that call 'loCreat', 'loOpen', 'loRead', and +-- are simply C functions that call 'loCreat', 'loOpen', 'loRead', and -- 'loWrite', and do not perform any transaction handling themselves, -- they also need to be wrapped in an explicit transaction. --
+ 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
@@ -5,7 +5,8 @@ ----------------------------------------------------------------------------- -- | -- Module : Database.PostgreSQL.Simple.Notification--- Copyright : (c) 2011-2012 Leon P Smith+-- Copyright : (c) 2011-2015 Leon P Smith+-- (c) 2012 Joey Adams -- License : BSD3 -- -- Maintainer : leon@melding-monads.com@@ -13,7 +14,7 @@ -- -- Support for receiving asynchronous notifications via PostgreSQL's -- Listen/Notify mechanism. See--- <http://www.postgresql.org/docs/9.1/static/sql-notify.html> for more+-- <https://www.postgresql.org/docs/9.5/static/sql-notify.html> for more -- information. -- -- Note that on Windows, @getNotification@ currently uses a polling loop@@ -24,7 +25,7 @@ -- Notifications do not create any extra work for the backend, and are -- likely cheaper on the client side as well. ----- <http://hackage.haskell.org/trac/ghc/ticket/7353>+-- <https://hackage.haskell.org/trac/ghc/ticket/7353> -- ----------------------------------------------------------------------------- @@ -35,19 +36,27 @@ , getBackendPID ) where -import Control.Concurrent-import Control.Monad ( when )-import Control.Exception ( throwIO )+import Control.Monad ( join, void )+import Control.Exception ( throwIO, catch ) import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8 import Database.PostgreSQL.Simple.Internal import qualified Database.PostgreSQL.LibPQ as PQ import System.Posix.Types ( CPid )+import GHC.IO.Exception ( ioe_location ) +#if defined(mingw32_HOST_OS)+import Control.Concurrent ( threadDelay )+#else+import GHC.Conc ( atomically )+import Control.Concurrent ( threadWaitReadSTM )+#endif+ data Notification = Notification- { notificationPid :: !CPid- , notificationChannel :: !B.ByteString- , notificationData :: !B.ByteString- }+ { notificationPid :: {-# UNPACK #-} !CPid+ , notificationChannel :: {-# UNPACK #-} !B.ByteString+ , notificationData :: {-# UNPACK #-} !B.ByteString+ } deriving (Show, Eq) convertNotice :: PQ.Notify -> Notification convertNotice PQ.Notify{..}@@ -57,35 +66,56 @@ -- | Returns a single notification. If no notifications are available, -- 'getNotification' blocks until one arrives.+--+-- It is safe to call 'getNotification' on a connection that is concurrently+-- being used for other purposes, note however that PostgreSQL does not+-- deliver notifications while a connection is inside a transaction. getNotification :: Connection -> IO Notification-getNotification conn = loop False+getNotification conn = join $ withConnection conn fetch where funcName = "Database.PostgreSQL.Simple.Notification.getNotification"- loop doConsume = do- res <- withConnection conn $ \c -> do- when doConsume (PQ.consumeInput c >> return ())- mmsg <- PQ.notifies c- case mmsg of- Nothing -> do- mfd <- PQ.socket c- case mfd of- Nothing -> throwIO $ fdError funcName- Just fd -> return (Left fd)- Just msg -> return (Right msg)- -- FIXME? what happens if the connection is closed/reset right here?- case res of++ fetch c = do+ mmsg <- PQ.notifies c+ case mmsg of+ Just msg -> return (return $! convertNotice msg)+ Nothing -> do+ mfd <- PQ.socket c+ case mfd of+ Nothing -> return (throwIO $! fdError funcName) #if defined(mingw32_HOST_OS)- -- threadWaitRead doesn't work for sockets on Windows, so just poll- -- for input every second (PQconsumeInput is non-blocking).- --- -- We could call select(), but FFI calls can't be interrupted with- -- async exceptions, whereas threadDelay can.- Left _fd -> threadDelay 1000000 >> loop True+ -- threadWaitRead doesn't work for sockets on Windows, so just+ -- poll for input every second (PQconsumeInput is non-blocking).+ --+ -- We could call select(), but FFI calls can't be interrupted+ -- with async exceptions, whereas threadDelay can.+ Just _fd -> do+ return (threadDelay 1000000 >> loop) #else- Left fd -> threadWaitRead fd >> loop True+ -- This case fixes the race condition above. By registering+ -- our interest in the descriptor before we drop the lock,+ -- there is no opportunity for the descriptor index to be+ -- reallocated on us.+ --+ -- (That is, assuming there isn't concurrently executing+ -- code that manipulates the descriptor without holding+ -- the lock... but such a major bug is likely to exhibit+ -- itself in an at least somewhat more dramatic fashion.)+ Just fd -> do+ (waitRead, _) <- threadWaitReadSTM fd+ return $ do+ atomically waitRead `catch` (throwIO . setIOErrorLocation)+ loop #endif- Right msg -> return $! convertNotice msg++ loop = join $ withConnection conn $ \c -> do+ void $ PQ.consumeInput c+ fetch c++ setIOErrorLocation :: IOError -> IOError+ setIOErrorLocation err = err { ioe_location = B8.unpack funcName }+ -- | Non-blocking variant of 'getNotification'. Returns a single notification, -- if available. If no notifications are available, returns 'Nothing'.
src/Database/PostgreSQL/Simple/Ok.hs view
@@ -1,10 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ -- | -- Module : Database.PostgreSQL.Simple.Ok--- Copyright : (c) 2012 Leon P Smith+-- Copyright : (c) 2012-2015 Leon P Smith -- License : BSD3 -- -- Maintainer : leon@melding-monads.com@@ -20,7 +21,7 @@ -- commonly-used type and typeclass included in @base@. -- -- Extending the failure case to a list of 'SomeException's enables a--- more sensible 'Alternative' instance definitions: '<|>' concatinates+-- more sensible 'Alternative' instance definitions: '<|>' concatenates -- the list of exceptions when both cases fail, and 'empty' is defined as -- 'Errors []'. Though '<|>' one could pick one of two exceptions, and -- throw away the other, and have 'empty' provide a generic exception,@@ -36,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?) @@ -69,11 +72,14 @@ mplus = (<|>) instance Monad Ok where- return = Ok- 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
@@ -0,0 +1,317 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}++------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.Range+-- Copyright: (c) 2014-2015 Leonid Onokhov+-- (c) 2014-2015 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+--+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.Range+ ( RangeBound(..)+ , PGRange(..)+ , empty+ , isEmpty, isEmptyBy+ , contains, containsBy+ , fromFieldRange+ ) where++import Control.Applicative hiding (empty)+import Data.Attoparsec.ByteString.Char8 (Parser, parseOnly)+import qualified Data.Attoparsec.ByteString.Char8 as A+import qualified Data.ByteString as B+import Data.ByteString.Builder+ ( Builder, byteString, lazyByteString, char8+ , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec+ , wordDec, word8Dec, word16Dec, word32Dec, word64Dec+ , doubleDec, floatDec )+import Data.Int (Int16, Int32, Int64,+ Int8)+import Data.Function (on)+import Data.Monoid (mempty)+import Data.Scientific (Scientific)+import qualified Data.Text.Lazy.Builder as LT+import qualified Data.Text.Lazy.Encoding as LT+import Data.Time.Compat (Day, LocalTime,+ NominalDiffTime,+ TimeOfDay, UTCTime,+ ZonedTime,+ zonedTimeToUTC)+import Data.Typeable (Typeable)+import Data.Word (Word, Word16, Word32,+ Word64, Word8)++import Database.PostgreSQL.Simple.Compat (scientificBuilder, (<>), toByteString)+import Database.PostgreSQL.Simple.FromField+import Database.PostgreSQL.Simple.Time+ hiding (PosInfinity, NegInfinity)+-- import qualified Database.PostgreSQL.Simple.Time as Time+import Database.PostgreSQL.Simple.ToField++-- | Represents boundary of a range+data RangeBound a = NegInfinity+ | Inclusive !a+ | Exclusive !a+ | PosInfinity+ deriving (Show, Typeable, Eq, Functor)++-- | Generic range type+data PGRange a = PGRange !(RangeBound a) !(RangeBound a)+ deriving (Show, Typeable, Functor)++empty :: PGRange a+empty = PGRange PosInfinity NegInfinity++instance Ord a => Eq (PGRange a) where+ x == y = eq x y || (isEmpty x && isEmpty y)+ where eq (PGRange a m) (PGRange b n) = a == b && m == n++isEmptyBy :: (a -> a -> Ordering) -> PGRange a -> Bool+isEmptyBy cmp v =+ case v of+ (PGRange PosInfinity _) -> True+ (PGRange _ NegInfinity) -> True+ (PGRange NegInfinity _) -> False+ (PGRange _ PosInfinity) -> False+ (PGRange (Inclusive x) (Inclusive y)) -> cmp x y == GT+ (PGRange (Inclusive x) (Exclusive y)) -> cmp x y /= LT+ (PGRange (Exclusive x) (Inclusive y)) -> cmp x y /= LT+ (PGRange (Exclusive x) (Exclusive y)) -> cmp x y /= LT++-- | Is a range empty? If this returns 'True', then the 'contains'+-- predicate will always return 'False'. However, if this returns+-- 'False', it is not necessarily true that there exists a point for+-- which 'contains' returns 'True'.+-- Consider @'PGRange' ('Excludes' 2) ('Excludes' 3) :: PGRange Int@,+-- for example.+isEmpty :: Ord a => PGRange a -> Bool+isEmpty = isEmptyBy compare+++-- | Does a range contain a given point? Note that in some cases, this may+-- not correspond exactly with a server-side computation. Consider @UTCTime@+-- for example, which has a resolution of a picosecond, whereas postgresql's+-- @timestamptz@ types have a resolution of a microsecond. Putting such+-- Haskell values into the database will result in them being rounded, which+-- can change the value of the containment predicate.++contains :: Ord a => PGRange a -> (a -> Bool)+contains = containsBy compare++containsBy :: (a -> a -> Ordering) -> PGRange a -> (a -> Bool)+containsBy cmp rng x =+ case rng of+ PGRange _lb NegInfinity -> False+ PGRange lb ub -> checkLB lb x && checkUB ub x+ where+ checkLB lb y =+ case lb of+ NegInfinity -> True+ PosInfinity -> False+ Inclusive a -> cmp a y /= GT+ Exclusive a -> cmp a y == LT++ checkUB ub y =+ case ub of+ NegInfinity -> False+ PosInfinity -> True+ 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)+{-# INLINE lowerBound #-}++upperBound :: Parser (a -> RangeBound a)+upperBound = (A.char ')' *> pure Exclusive) <|> (A.char ']' *> pure Inclusive)+{-# INLINE upperBound #-}++-- | Generic range parser+pgrange :: Parser (RangeBound B.ByteString, RangeBound B.ByteString)+pgrange = do+ lb <- lowerBound+ v1 <- (A.char ',' *> "") <|> (rangeElem (==',') <* A.char ',')+ v2 <- rangeElem $ \c -> c == ')' || c == ']'+ ub <- upperBound+ A.endOfInput+ let low = if B.null v1 then NegInfinity else lb v1+ up = if B.null v2 then PosInfinity else ub v2+ return (low, up)++rangeElem :: (Char -> Bool) -> Parser B.ByteString+rangeElem end = (A.char '"' *> doubleQuoted)+ <|> A.takeTill end+{-# INLINE rangeElem #-}++-- | Simple double quoted value parser+doubleQuoted :: Parser B.ByteString+doubleQuoted = toByteString <$> go mempty+ where+ go acc = do+ h <- byteString <$> A.takeTill (\c -> c == '\\' || c == '"')+ let rest = do+ start <- A.anyChar+ case start of+ '\\' -> do+ c <- A.anyChar+ go (acc <> h <> char8 c)+ '"' -> (A.char '"' *> go (acc <> h <> char8 '"'))+ <|> pure (acc <> h)+ _ -> error "impossible in doubleQuoted"+ rest++rangeToBuilder :: Ord a => (a -> Builder) -> PGRange a -> Builder+rangeToBuilder = rangeToBuilderBy compare++-- | Generic range to builder for plain values+rangeToBuilderBy :: (a -> a -> Ordering) -> (a -> Builder) -> PGRange a -> Builder+rangeToBuilderBy cmp f x =+ if isEmptyBy cmp x+ then byteString "'empty'"+ else let (PGRange a b) = x+ in buildLB a <> buildUB b+ where+ buildLB NegInfinity = byteString "'[,"+ buildLB (Inclusive v) = byteString "'[\"" <> f v <> byteString "\","+ buildLB (Exclusive v) = byteString "'(\"" <> f v <> byteString "\","+ buildLB PosInfinity = error "impossible in rangeToBuilder"++ buildUB NegInfinity = error "impossible in rangeToBuilder"+ buildUB (Inclusive v) = char8 '"' <> f v <> byteString "\"]'"+ buildUB (Exclusive v) = char8 '"' <> f v <> byteString "\")'"+ buildUB PosInfinity = byteString "]'"+{-# INLINE rangeToBuilder #-}+++instance (FromField a, Typeable a) => FromField (PGRange a) where+ fromField = fromFieldRange fromField++fromFieldRange :: Typeable a => FieldParser a -> FieldParser (PGRange a)+fromFieldRange fromField' f mdat = do+ info <- typeInfo f+ case info of+ Range{} ->+ let f' = f { typeOid = typoid (rngsubtype info) }+ in case mdat of+ Nothing -> returnError UnexpectedNull f ""+ 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 PosInfinity = pure PosInfinity+ in case parseOnly pgrange bs of+ Left e -> returnError ConversionFailed f e+ Right (lb,ub) -> PGRange <$> parseIt lb <*> parseIt ub+ _ -> returnError Incompatible f ""+++instance ToField (PGRange Int8) where+ toField = Plain . rangeToBuilder int8Dec+ {-# INLINE toField #-}++instance ToField (PGRange Int16) where+ toField = Plain . rangeToBuilder int16Dec+ {-# INLINE toField #-}++instance ToField (PGRange Int32) where+ toField = Plain . rangeToBuilder int32Dec+ {-# INLINE toField #-}++instance ToField (PGRange Int) where+ toField = Plain . rangeToBuilder intDec+ {-# INLINE toField #-}++instance ToField (PGRange Int64) where+ toField = Plain . rangeToBuilder int64Dec+ {-# INLINE toField #-}++instance ToField (PGRange Integer) where+ toField = Plain . rangeToBuilder integerDec+ {-# INLINE toField #-}++instance ToField (PGRange Word8) where+ toField = Plain . rangeToBuilder word8Dec+ {-# INLINE toField #-}++instance ToField (PGRange Word16) where+ toField = Plain . rangeToBuilder word16Dec+ {-# INLINE toField #-}++instance ToField (PGRange Word32) where+ toField = Plain . rangeToBuilder word32Dec+ {-# INLINE toField #-}++instance ToField (PGRange Word) where+ toField = Plain . rangeToBuilder wordDec+ {-# INLINE toField #-}++instance ToField (PGRange Word64) where+ toField = Plain . rangeToBuilder word64Dec+ {-# INLINE toField #-}++instance ToField (PGRange Float) where+ toField = Plain . rangeToBuilder floatDec+ {-# INLINE toField #-}++instance ToField (PGRange Double) where+ toField = Plain . rangeToBuilder doubleDec+ {-# INLINE toField #-}++instance ToField (PGRange Scientific) where+ toField = Plain . rangeToBuilder f+ where+ f = lazyByteString . LT.encodeUtf8 . LT.toLazyText . scientificBuilder+ {-# INLINE toField #-}++instance ToField (PGRange UTCTime) where+ toField = Plain . rangeToBuilder utcTimeToBuilder+ {-# INLINE toField #-}++instance ToField (PGRange ZonedTime) where+ toField = Plain . rangeToBuilderBy cmpZonedTime zonedTimeToBuilder+ {-# INLINE toField #-}++cmpZonedTime :: ZonedTime -> ZonedTime -> Ordering+cmpZonedTime = compare `on` zonedTimeToUTC -- FIXME: optimize++instance ToField (PGRange LocalTime) where+ toField = Plain . rangeToBuilder localTimeToBuilder+ {-# INLINE toField #-}++instance ToField (PGRange Day) where+ toField = Plain . rangeToBuilder dayToBuilder+ {-# INLINE toField #-}++instance ToField (PGRange TimeOfDay) where+ toField = Plain . rangeToBuilder timeOfDayToBuilder+ {-# INLINE toField #-}++instance ToField (PGRange UTCTimestamp) where+ toField = Plain . rangeToBuilder utcTimestampToBuilder+ {-# INLINE toField #-}++instance ToField (PGRange ZonedTimestamp) where+ toField = Plain . rangeToBuilderBy cmpZonedTimestamp zonedTimestampToBuilder+ {-# INLINE toField #-}++cmpZonedTimestamp :: ZonedTimestamp -> ZonedTimestamp -> Ordering+cmpZonedTimestamp = compare `on` (zonedTimeToUTC <$>)++instance ToField (PGRange LocalTimestamp) where+ toField = Plain . rangeToBuilder localTimestampToBuilder+ {-# INLINE toField #-}++instance ToField (PGRange Date) where+ toField = Plain . rangeToBuilder dateToBuilder+ {-# INLINE toField #-}++instance ToField (PGRange NominalDiffTime) where+ toField = Plain . rangeToBuilder nominalDiffTimeToBuilder+ {-# INLINE toField #-}
src/Database/PostgreSQL/Simple/SqlQQ.hs view
@@ -1,3 +1,9 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE TemplateHaskellQuotes #-}+#else+{-# LANGUAGE TemplateHaskell #-}+#endif ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.SqlQQ@@ -9,10 +15,11 @@ ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.SqlQQ (sql) where-+import Database.PostgreSQL.Simple.Types (Query) import Language.Haskell.TH import Language.Haskell.TH.Quote import Data.Char+import Data.String -- | 'sql' is a quasiquoter that eases the syntactic burden -- of writing big sql statements in Haskell source code. For example:@@ -27,10 +34,10 @@ -- > LIMIT 100 |] -- > (beginTime,endTime,string) ----- This quasiquoter attempts to mimimize 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 "--".+-- This quasiquoter returns a literal string expression of type 'Query',+-- 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 "--". -- -- The implementation of the whitespace reducer is currently incomplete. -- Thus it can mess up your syntax in cases where whitespace should be@@ -50,17 +57,14 @@ 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-sqlExp = stringE . minimizeSpace+sqlExp = appE [| fromString :: String -> Query |] . stringE . minimizeSpace minimizeSpace :: String -> String minimizeSpace = drop 1 . reduceSpace@@ -83,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
@@ -1,54 +1,217 @@---------------------------------------------------------------------------------- |--- Module: Database.PostgreSQL.Simple.Time--- Copyright: (c) 2012 Leon P Smith--- License: BSD3--- Maintainer: Leon P Smith <leon@melding-monads.com>--- Stability: experimental------ Time types that supports positive and negative infinity. Also includes--- new time parsers and printers with better performance than GHC's time--- package.------ The parsers only understand the specific variant of ISO 8601 that--- PostgreSQL emits, and the printers attempt to duplicate this syntax.--- Thus the @datestyle@ parameter for the connection must be set to @ISO@.------ These parsers and printers likely have problems and shortcomings. Some--- that I know of:------ 1 @TimestampTZ@s before a timezone-dependent point in time cannot be--- parsed, because the parsers can only handle timezone offsets of a--- integer number of minutes. However, PostgreSQL will include seconds--- in the offset, depending on the historical time standards for the city--- identifying the time zone.------ This boundary point often marks an event of some interest. In the US--- for example, @timestamptz@s before @1883-Nov-18 12:00:00@ local time--- cannot be parsed. This is the moment Standard Railway Time went live.--- Concretely, PostgreSQL will emit @1883-11-18 12:03:57-04:56:02@--- instead of @1883-11-18 11:59:59-05@ when the @timezone@ parameter--- for the connection is set to @America/New_York@.------ 2. Dates and times surrounding @1582-Feb-24@, the date the Gregorian--- Calendar was introduced, should be investigated for conversion errors.------ 3. Points in time Before Christ are not also not supported. For example,--- PostgreSQL will emit @0045-01-01 BC@ for a value of a @date@ type.--- This is the year that the Julian Calendar was adopted.------ However, it should be noted that the old parsers also had issues 1 and 3.--- Also, the new parsers now correctly handle time zones that include minutes--- in their offset. Most notably, this includes all of India and parts of--- Canada and Australia.------ PostgreSQL uses the zoneinfo database for its time zone information.--- You can read more about PostgreSQL's date and time types at--- <http://www.postgresql.org/docs/9.1/static/datatype-datetime.html>,--- and zoneinfo at <http://en.wikipedia.org/wiki/Tz_database>.----------------------------------------------------------------------------------+{- |+Module: Database.PostgreSQL.Simple.Time+Copyright: (c) 2012-2015 Leon P Smith+License: BSD3+Maintainer: Leon P Smith <leon@melding-monads.com>+Stability: experimental +This module provides time types that supports positive and negative+infinity, as well as some functions for converting to and from strings.++Also, this module also contains commentary regarding postgresql's timestamp+types, civil timekeeping in general, and how it relates to+postgresql-simple. You can read more about PostgreSQL's date and time types+at <https://www.postgresql.org/docs/9.5/static/datatype-datetime.html>,+and the IANA time zone database at <https://en.wikipedia.org/wiki/Tz_database>.++Stack Overflow also has some excellent commentary on time, if it is a+wiki page or a highly upvoted question and answer. If the answer regarding+time has not received about a hundred upvotes at least, then the answer is+almost invariably completely and painfully wrong, even if it's the chosen+answer or the most highly upvoted answer to a question.++PostgreSQL's @timestamp with time zone@ (hereafter, @timestamptz@) can be+converted to Haskell's 'Data.Time.UTCTime' and 'Data.Time.ZonedTime' types,+because values of these types represent a self-contained, unambiguous point+in time. PostgreSQL's @timestamp without time zone@ (hereafter, @timestamp@)+can be converted to Haskell's 'Data.Time.LocalTime', because values of these+types are ambiguous by themselves, and require context to disambiguate.++While this behavior may be superficially counterintuitive because the+names might suggest otherwise, this behavior is correct. In fact,+the \"timezone\" language in both the postgresql and haskell types would+be better read as \"offset (from UTC)\", thus we have postgresql's+\"timestamp with offset\" corresponding to Haskell's \"time with the+offset \'zero\'\" and Haskell's \"time with an offset (that might be+nonzero)\". Similarly, postgresql's \"timestamp without an offset\"+corresponds to Haskell's \"local time (without an offset)\".++It's important to distinguish between an offset, a standard time, and+a time zone. An offset is simply a difference of a local time from UTC,+such as @+00@, @-05@, or @+05:30@. A standard time specifies an offset+(which may vary throughout the year, due to daylight savings) that a+region follows, such as Universal Coordinated Time (UTC), Eastern Standard+Time\/Eastern Daylight Time (EST\/EDT), or India Standard Time (IST).+And a time zone, much like a standard time, is a function from+timestamps to offsets.++A time zone is different from a standard time because different regions+inside a standard time can be governed by different civil authorities with+different laws and thus have different histories of civil time. An IANA+time zone is any region of the world that has had the same history of+civil time since @1970-01-01 00:00+00@.++For example, as of today, both @America\/New_York@ and+@America\/Indiana\/Indianapolis@ are on the EST\/EDT time standard, but+Indiana used to be on Central Standard Time until 1942, and did not observe+daylight savings time (EST only) until 2006. Thus, the choice between+these two time zones still matters if you are dealing with timestamps+prior to 2006, and could become relevant again if (most of) Indiana+moves back to Central Time. (Of course, if the Central to Eastern switch+was the only difference, then these two time zones would be the same in+IANA's eyes, due to their cutoff date of 1970-01-01.)++Getting back to practicalities, PostgreSQL's @timestamptz@ type does not+actually store an offset; rather, it uses the offset provided to calculate+UTC, and stores the timestamp as UTC. If an offset is not provided, the+given timestamp is assumed to be a local time for whatever the @timezone@+variable is set to, and the IANA TZ database is consulted to calculate an+offset from UTC for the time in question.++Note that while most (local timestamp, time zone) pairs correspond to exactly+one UTC timestamp, some correspond to two UTC timestamps, while others+correspond to none at all. The ambiguous case occurs when the civil time+is rolled back, making a calendar day longer than 24 hours. In this case,+PostgreSQL silently chooses the second, later possibility. The inconsistent+case occurs when the civil time is moved forward, making a calendar day less+than 24 hours. In this case, PostgreSQL silently assumes the local time+was read off a clock that had not been moved forward at the prescribed time,+and moves the clock forward for you. Thus, converting from local time+to UTC need not be monotonic, if these inconsistent cases are allowed.++When retrieving a @timestamptz@, the backend looks at the @time zone@+connection variable and then consults the IANA TZ database to calculate+an offset for the timestamp in the given time zone.++Note that while some of the information contained in the IANA TZ database+is a bit of a standardized fiction, the conversion from UTC time to a+(local time, offset) pair in a particular time zone is always unambiguous,+and the result can always be unambiguously converted back to UTC. Thus,+postgresql-simple can interpret such a result as a 'Data.Time.ZonedTime',+or use the offset to convert back to 'Data.Time.UTCTime'.++By contrast, the @timestamp@ type ignores any offsets provided to it,+and never sends back an offset. Thus, postgresql-simple equates this+with 'Data.Time.LocalTime', which has no concept of an offset. One can+convert between @timestamptz@ and @timestamp@ using the @AT TIME ZONE@+operator, whose semantics also demonstrates that @timestamptz@ is+'Data.Time.UTCTime' whereas @timestamp@ is 'Data.Time.LocalTime'.++PostgreSQL's @timezone@ is a per-connection variable that by default is+initialized to @\'localtime\'@, which normally corresponds to the server's+time zone. However, this default can be modified on the server side for an+entire cluster, or on a per-user or per-database basis. Moreover, a client+can modify their instance of the variable at any time, and can apply that+change to the remaining duration of the connection, the current transaction,+or the execution context of a server-side function. In addition, upon+connection initialization, the libpq client checks for the existence of+the @PGTZ@ environment variable, and if it exists, modifies @timezone@+accordingly.++With a few caveats, postgresql-simple is designed so that you can both send+and receive timestamps with the server and get a correct result, no matter+what the @timezone@ setting is. But it is important to understand the caveats:++1. The correctness of server-side computations can depend on the @timezone@+ setting. Examples include adding an @interval@ to a @timestamptz@, or+ type casting between @timestamp@ and @timestamptz@, or applying+ the @DATE@ function to a @timestamptz@.++2. The (localtime, offset) pair contained in a 'Data.Time.ZonedTime' result+ will depend on the @timezone@ setting, although the result will always+ represent the same instant in time regardless of the time zone.++3. Sending a 'Data.Time.LocalTime' and interpreting it as a @timestamptz@+ can be useful, as it will be converted to UTC via the tz database,+ but correctness will depend on the @timezone@ setting. You may prefer+ to use an explicit @AT TIME ZONE@ conversion instead, which would avoid+ this contextual dependence.++Furthermore, although these following points don't involve the @timezone@+setting, they are related to the last point above:++1. Sending a 'Data.Time.UTCTime' and interpreting it as a @timestamp@ can+ be useful. In practice, the most common context used to disambiguate+ @timestamp@ is that it represents UTC, and this coding technique will+ work as expected in this situation.++2. Sending a 'Data.Time.ZonedTime' and interpreting it as a @timestamp@ is+ almost always the wrong thing to do, as the offset will be ignored and+ discarded. This is likely to lead to inconsistencies in the database,+ and may lead to partial data loss.++When dealing with local timestamps that refer to the future, it is often+useful to store it as a local time in a @timestamp@ column and store the+time zone in a second column. One reason to do this is so that you can+convert to UTC on the fly as needed, and be protected against future changes+to the TZ database due to changes in local time standards. In any case,+'Data.Time.ZonedTime' is not suitable for this application, because despite+its name, it represents an offset and not a time zone. Time zones can change;+offsets do not. In reality, we can't convert a local timestamp that occurs+sufficiently far in the future to UTC, because we don't know how to do it yet.++There are a few limitations and caveats that one might need to be aware+of with the current implementation when dealing with older timestamps:++For sufficiently old timestamps in almost all time zones, the IANA TZ+database specifies offsets from UTC that is not an integral number of+minutes. This corresponds to local mean time; that is, astronomical+time in the city that defines the time zone. Different time zones moved+away from local mean time to a standard time at different points in+history, so \"sufficiently old\" depends on the time zone in question.++Thus, when retrieving a @timestamptz@ postgresql will in some cases+provide seconds in the offset. For example:++@+$ psql+psql (9.4.5)+Type \"help\" for help.++lpsmith=> SET timezone TO \'America/New_York\';+SET+lpsmith=> VALUES (\'1883-11-18 16:59:59+00\'::timestamptz),+ (\'1883-11-18 17:00:00+00\'::timestamptz);+ column1+------------------------------+ 1883-11-18 12:03:57-04:56:02+ 1883-11-18 12:00:00-05+(2 rows)+@++Both of these timestamps can be parsed as a 'Data.Time.UTCTime' type,+however 'Data.Time.ZonedTime' will fail on the former timestamp.+Because 'Data.Time.ZonedTime' assumes that offsets are an integer number+of minutes, there isn't an particularly good solution here.++PostgreSQL, like most software, uses the proleptic Gregorian calendar+for its date calculations, extending the Gregorian calendar backwards+in time before its introduction and pretending that the Julian calendar+does not exist. For most purposes, the adoption of the Gregorian calendar+ranges from @1582-10-15@ to @1923-03-01@, depending on location and+sometimes even political allegiances within a single location.++Timestamps BCE are not supported. For example, PostgreSQL+will emit \"@0045-01-01 BC@\" for the first proleptic Gregorian day of+the year the Roman Empire adopted the Julian Calendar, but+postgresql-simple does not (yet?) have the ability to either parse or+generate this syntax. Unfortunately this syntax isn't convenient to+print or especially parse.++Also, postgresql itself cannot parse or print dates before @4714-11-24 BC@,+which is the Julian date on the proleptic Gregorian Calendar. Although+postgresql's timestamp types are perfectly capable of representing timestamps+nearly 300,000 years in the past, using this would require postgresql-simple+and other client programs to support binary parameters and results.++Dealing with years BCE is also complicated slightly by the fact that+Haskell's time library has a year \"0000\", which is a convention often+used by astronomers, while postgresql adopts the more historically+accurate convention that there is no year zero, but rather \"1 BCE\"+was immediately followed by \"1 CE\".++-}+ module Database.PostgreSQL.Simple.Time ( Unbounded(..) , Date@@ -64,6 +227,7 @@ , parseUTCTimestamp , parseZonedTimestamp , parseLocalTimestamp+ , parseCalendarDiffTime , dayToBuilder , utcTimeToBuilder , zonedTimeToBuilder@@ -75,6 +239,8 @@ , zonedTimestampToBuilder , localTimestampToBuilder , unboundedToBuilder+ , nominalDiffTimeToBuilder+ , calendarDiffTimeToBuilder ) where import Database.PostgreSQL.Simple.Time.Implementation
src/Database/PostgreSQL/Simple/Time/Implementation.hs view
@@ -1,51 +1,44 @@ ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Time.Implementation--- Copyright: (c) 2012 Leon P Smith+-- Copyright: (c) 2012-2015 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith <leon@melding-monads.com> -- Stability: experimental -- ------------------------------------------------------------------------------ -{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-} module Database.PostgreSQL.Simple.Time.Implementation where -import Prelude hiding (take, (++))-import Blaze.ByteString.Builder(Builder, fromByteString)-import Blaze.ByteString.Builder.Char8(fromChar)-import Blaze.Text.Int(integral)+import Prelude hiding (take)+import Data.ByteString.Builder(Builder, byteString)+import Data.ByteString.Builder.Prim(primBounded) import Control.Arrow((***)) import Control.Applicative-import Control.Monad(when)-import Data.Bits((.&.)) import qualified Data.ByteString as B-import Data.ByteString.Internal (c2w, w2c)-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.Word(Word8)-import qualified Data.Attoparsec.Char8 as A-import Data.Monoid(Monoid(..))-import Data.Fixed (Pico)-import Unsafe.Coerce--(++) :: Monoid a => a -> a -> a-(++) = mappend-infixr 5 +++import Data.Maybe (fromMaybe)+import qualified Data.Attoparsec.ByteString.Char8 as A+import Database.PostgreSQL.Simple.Compat ((<>))+import qualified Database.PostgreSQL.Simple.Time.Internal.Parser as TP+import qualified Database.PostgreSQL.Simple.Time.Internal.Printer as TPP data Unbounded a = NegInfinity | Finite !a | PosInfinity- deriving (Eq, Ord, Typeable)+ deriving (Eq, Ord, Typeable, Functor) instance Show a => Show (Unbounded a) where showsPrec prec x rest = case x of- NegInfinity -> "-infinity" ++ rest+ NegInfinity -> "-infinity" <> rest Finite time -> showsPrec prec time rest- PosInfinity -> "infinity" ++ rest+ PosInfinity -> "infinity" <> rest instance Read a => Read (Unbounded a) where readsPrec prec = readParen False $ \str -> case str of@@ -85,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")@@ -92,130 +88,74 @@ <|> (Finite <$> getFinite) getDay :: A.Parser Day-getDay = do- yearStr <- A.takeWhile A.isDigit- when (B.length yearStr < 4) (fail "year must consist of at least 4 digits")-- let !year = toNum yearStr- _ <- A.char '-'- month <- digits "month"- _ <- A.char '-'- day <- digits "day"-- case fromGregorianValid year month day of- Nothing -> fail "invalid date"- Just x -> return $! x+getDay = TP.day getDate :: A.Parser Date getDate = getUnbounded getDay -decimal :: Fractional a => B.ByteString -> a-decimal str = toNum str / 10^(B.length str)-{-# INLINE decimal #-}- getTimeOfDay :: A.Parser TimeOfDay-getTimeOfDay = do- hour <- digits "hours"- _ <- A.char ':'- minute <- digits "minutes"- _ <- A.char ':'- second <- digits "seconds"- subsec <- (A.char '.' *> (decimal <$> A.takeWhile1 A.isDigit)) <|> return 0-- let !picos' = second + subsec-- case makeTimeOfDayValid hour minute picos' of- Nothing -> fail "invalid time of day"- Just x -> return $! x+getTimeOfDay = TP.timeOfDay getLocalTime :: A.Parser LocalTime-getLocalTime = LocalTime <$> getDay <*> (A.char ' ' *> getTimeOfDay)+getLocalTime = TP.localTime getLocalTimestamp :: A.Parser LocalTimestamp getLocalTimestamp = getUnbounded getLocalTime getTimeZone :: A.Parser TimeZone-getTimeZone = do- sign <- A.satisfy (\c -> c == '+' || c == '-')- hours <- digits "timezone"- mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0- let !absset = 60 * hours + mins- !offset = if sign == '+' then absset else -absset- return $! minutesToTimeZone offset+getTimeZone = fromMaybe utc <$> TP.timeZone +type TimeZoneHMS = (Int,Int,Int)++getTimeZoneHMS :: A.Parser TimeZoneHMS+getTimeZoneHMS = munge <$> TP.timeZoneHMS+ where+ munge Nothing = (0,0,0)+ munge (Just (TP.UTCOffsetHMS h m s)) = (h,m,s)++localToUTCTimeOfDayHMS :: TimeZoneHMS -> TimeOfDay -> (Integer, TimeOfDay)+localToUTCTimeOfDayHMS (dh, dm, ds) tod =+ TP.localToUTCTimeOfDayHMS (TP.UTCOffsetHMS dh dm ds) tod+ getZonedTime :: A.Parser ZonedTime-getZonedTime = ZonedTime <$> getLocalTime <*> getTimeZone+getZonedTime = TP.zonedTime getZonedTimestamp :: A.Parser ZonedTimestamp getZonedTimestamp = getUnbounded getZonedTime getUTCTime :: A.Parser UTCTime-getUTCTime = do- day <- getDay- _ <- A.char ' '- time <- getTimeOfDay- zone <- getTimeZone- let (!dayDelta,!time') = localToUTCTimeOfDay zone time- let !day' = addDays dayDelta day- let !time'' = timeOfDayToTime time'- return (UTCTime day' time'')+getUTCTime = TP.utcTime getUTCTimestamp :: A.Parser UTCTimestamp getUTCTimestamp = getUnbounded getUTCTime -toNum :: Num n => B.ByteString -> n-toNum = B.foldl' (\a c -> 10*a + digit c) 0-{-# INLINE toNum #-}--digit :: Num n => Word8 -> n-digit c = fromIntegral (c .&. 0x0f)-{-# INLINE digit #-}--digits :: Num n => String -> A.Parser n-digits msg = do- x <- A.anyChar- y <- A.anyChar- if A.isDigit x && A.isDigit y- then return $! (10 * digit (c2w x) + digit (c2w y))- else fail (msg ++ " is not 2 digits")-{-# INLINE digits #-}+getCalendarDiffTime :: A.Parser CalendarDiffTime+getCalendarDiffTime = TP.calendarDiffTime dayToBuilder :: Day -> Builder-dayToBuilder (toGregorian -> (y,m,d)) = do- pad4 y ++ fromChar '-' ++ pad2 m ++ fromChar '-' ++ pad2 d+dayToBuilder = primBounded TPP.day timeOfDayToBuilder :: TimeOfDay -> Builder-timeOfDayToBuilder (TimeOfDay h m s) = do- pad2 h ++ fromChar ':' ++ pad2 m ++ fromChar ':' ++ showSeconds s+timeOfDayToBuilder = primBounded TPP.timeOfDay timeZoneToBuilder :: TimeZone -> Builder-timeZoneToBuilder tz- | m == 0 = sign h ++ pad2 (abs h)- | otherwise = sign h ++ pad2 (abs h) ++ fromChar ':' ++ pad2 (abs m)- where- (h,m) = timeZoneMinutes tz `quotRem` 60- sign h | h >= 0 = fromChar '+'- | otherwise = fromChar '-'+timeZoneToBuilder = primBounded TPP.timeZone utcTimeToBuilder :: UTCTime -> Builder-utcTimeToBuilder (UTCTime day time) =- dayToBuilder day ++ fromChar ' '- ++ timeOfDayToBuilder (timeToTimeOfDay time) ++ fromByteString "+00"+utcTimeToBuilder = primBounded TPP.utcTime zonedTimeToBuilder :: ZonedTime -> Builder-zonedTimeToBuilder (ZonedTime localTime tz) =- localTimeToBuilder localTime ++ timeZoneToBuilder tz+zonedTimeToBuilder = primBounded TPP.zonedTime localTimeToBuilder :: LocalTime -> Builder-localTimeToBuilder (LocalTime day tod) =- dayToBuilder day ++ fromChar ' ' ++ timeOfDayToBuilder tod+localTimeToBuilder = primBounded TPP.localTime unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder) unboundedToBuilder finiteToBuilder unbounded = case unbounded of- NegInfinity -> fromByteString "-infinity"+ NegInfinity -> byteString "-infinity" Finite a -> finiteToBuilder a- PosInfinity -> fromByteString "infinity"+ PosInfinity -> byteString "infinity" utcTimestampToBuilder :: UTCTimestamp -> Builder utcTimestampToBuilder = unboundedToBuilder utcTimeToBuilder@@ -229,54 +169,8 @@ dateToBuilder :: Date -> Builder dateToBuilder = unboundedToBuilder dayToBuilder -showSeconds :: Pico -> Builder-showSeconds xyz- | yz == 0 = pad2 x- | z == 0 = pad2 x ++ fromChar '.' ++ showD6 y- | otherwise = pad2 x ++ fromChar '.' ++ pad6 y ++ showD6 z- where- -- A kludge to work around the fact that Data.Fixed isn't very fast and- -- doesn't give me access to the MkFixed constructor.- (x_,yz) = (unsafeCoerce xyz :: Integer) `quotRem` 1000000000000- x = fromIntegral x_ :: Int- (fromIntegral -> y, fromIntegral -> z) = yz `quotRem` 1000000--pad6 :: Int -> Builder-pad6 xy = let (x,y) = xy `quotRem` 1000- in pad3 x ++ pad3 y--showD6 :: Int -> Builder-showD6 xy = case xy `quotRem` 1000 of- (x,0) -> showD3 x- (x,y) -> pad3 x ++ showD3 y--pad3 :: Int -> Builder-pad3 abc = let (ab,c) = abc `quotRem` 10- (a,b) = ab `quotRem` 10- in p a ++ p b ++ p c--showD3 :: Int -> Builder-showD3 abc = case abc `quotRem` 100 of- (a, 0) -> p a- (a,bc) -> case bc `quotRem` 10 of- (b,0) -> p a ++ p b- (b,c) -> p a ++ p b ++ p c---- | p assumes its input is in the range [0..9]-p :: Integral n => n -> Builder-p n = fromChar (w2c (fromIntegral (n + 48)))-{-# INLINE p #-}---- | pad2 assumes its input is in the range [0..99]-pad2 :: Integral n => n -> Builder-pad2 n = let (a,b) = n `quotRem` 10 in p a ++ p b-{-# INLINE pad2 #-}+nominalDiffTimeToBuilder :: NominalDiffTime -> Builder+nominalDiffTimeToBuilder = TPP.nominalDiffTime --- | pad4 assumes its input is positive-pad4 :: (Integral n, Show n) => n -> Builder-pad4 abcd | abcd >= 10000 = integral abcd- | otherwise = p a ++ p b ++ p c ++ p d- where (ab,cd) = abcd `quotRem` 100- (a,b) = ab `quotRem` 10- (c,d) = cd `quotRem` 10-{-# INLINE pad4 #-}+calendarDiffTimeToBuilder :: CalendarDiffTime -> Builder+calendarDiffTimeToBuilder = TPP.calendarDiffTime
src/Database/PostgreSQL/Simple/Time/Internal.hs view
@@ -19,6 +19,9 @@ , getZonedTimestamp , getUTCTime , getUTCTimestamp+ , TimeZoneHMS+ , getTimeZoneHMS+ , localToUTCTimeOfDayHMS ) where import Database.PostgreSQL.Simple.Time.Implementation
+ src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}++-- |+-- Module: Database.PostgreSQL.Simple.Time.Internal.Parser+-- Copyright: (c) 2012-2015 Leon P Smith+-- (c) 2015 Bryan O'Sullivan+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+--+-- Parsers for parsing dates and times.++module Database.PostgreSQL.Simple.Time.Internal.Parser+ (+ day+ , localTime+ , timeOfDay+ , timeZone+ , UTCOffsetHMS(..)+ , timeZoneHMS+ , 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.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.Compat as Local++-- | Parse a date of the form @YYYY-MM-DD@.+day :: Parser Day+day = do+ y <- decimal <* char '-'+ m <- twoDigits <* char '-'+ d <- twoDigits+ maybe (fail "invalid date") return (fromGregorianValid y m d)++-- | Parse a two-digit integer (e.g. day of month, hour).+twoDigits :: Parser Int+twoDigits = do+ a <- digit+ b <- digit+ let c2d c = ord c .&. 15+ return $! c2d a * 10 + c2d b++-- | Parse a time of the form @HH:MM[:SS[.SSS]]@.+timeOfDay :: Parser Local.TimeOfDay+timeOfDay = do+ h <- twoDigits <* char ':'+ m <- twoDigits+ mc <- peekChar+ s <- case mc of+ Just ':' -> anyChar *> seconds+ _ -> return 0+ if h < 24 && m < 60 && s <= 60+ then return (Local.TimeOfDay h m s)+ else fail "invalid time"++-- | Parse a count of seconds, with the integer part being two digits+-- long.+seconds :: Parser Pico+seconds = do+ real <- twoDigits+ mc <- peekChar+ case mc of+ Just '.' -> do+ t <- anyChar *> takeWhile1 isDigit+ return $! parsePicos (fromIntegral real) t+ _ -> return $! fromIntegral real+ where+ parsePicos :: Int64 -> B8.ByteString -> Pico+ parsePicos a0 t = toPico (fromIntegral (t' * 10^n))+ where n = max 0 (12 - B8.length t)+ t' = B8.foldl' (\a c -> 10 * a + fromIntegral (ord c .&. 15)) a0+ (B8.take 12 t)++-- | Parse a time zone, and return 'Nothing' if the offset from UTC is+-- zero. (This makes some speedups possible.)+timeZone :: Parser (Maybe Local.TimeZone)+timeZone = do+ ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z'+ if ch == 'Z'+ then return Nothing+ else do+ h <- twoDigits+ mm <- peekChar+ m <- case mm of+ Just ':' -> anyChar *> twoDigits+ _ -> return 0+ let off | ch == '-' = negate off0+ | otherwise = off0+ off0 = h * 60 + m+ case undefined of+ _ | off == 0 ->+ return Nothing+ | h > 23 || m > 59 ->+ fail "invalid time zone offset"+ | otherwise ->+ let !tz = Local.minutesToTimeZone off+ in return (Just tz)++data UTCOffsetHMS = UTCOffsetHMS {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int++-- | Parse a time zone, and return 'Nothing' if the offset from UTC is+-- zero. (This makes some speedups possible.)+timeZoneHMS :: Parser (Maybe UTCOffsetHMS)+timeZoneHMS = do+ ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z'+ if ch == 'Z'+ then return Nothing+ else do+ h <- twoDigits+ m <- maybeTwoDigits+ s <- maybeTwoDigits+ case undefined of+ _ | h == 0 && m == 0 && s == 0 ->+ return Nothing+ | h > 23 || m >= 60 || s >= 60 ->+ fail "invalid time zone offset"+ | otherwise ->+ if ch == '+'+ then let !tz = UTCOffsetHMS h m s+ in return (Just tz)+ else let !tz = UTCOffsetHMS (-h) (-m) (-s)+ in return (Just tz)+ where+ maybeTwoDigits = do+ ch <- peekChar+ case ch of+ Just ':' -> anyChar *> twoDigits+ _ -> return 0++localToUTCTimeOfDayHMS :: UTCOffsetHMS -> Local.TimeOfDay -> (Integer, Local.TimeOfDay)+localToUTCTimeOfDayHMS (UTCOffsetHMS dh dm ds) (Local.TimeOfDay h m s) =+ (\ !a !b -> (a,b)) dday (Local.TimeOfDay h'' m'' s'')+ where+ s' = s - fromIntegral ds+ (!s'', m')+ | s' < 0 = (s' + 60, m - dm - 1)+ | s' >= 60 = (s' - 60, m - dm + 1)+ | otherwise = (s' , m - dm )+ (!m'', h')+ | m' < 0 = (m' + 60, h - dh - 1)+ | m' >= 60 = (m' - 60, h - dh + 1)+ | otherwise = (m' , h - dh )+ (!h'', dday)+ | h' < 0 = (h' + 24, -1)+ | h' >= 24 = (h' - 24, 1)+ | otherwise = (h' , 0)+++-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@.+-- The space may be replaced with a @T@. The number of seconds may be+-- followed by a fractional component.+localTime :: Parser Local.LocalTime+localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay+ where daySep = satisfy (\c -> c == ' ' || c == 'T')++-- | Behaves as 'zonedTime', but converts any time zone offset into a+-- UTC time.+utcTime :: Parser UTCTime+utcTime = do+ (Local.LocalTime d t) <- localTime+ mtz <- timeZoneHMS+ case mtz of+ Nothing -> let !tt = Local.timeOfDayToTime t+ in return (UTCTime d tt)+ Just tz -> let !(dd,t') = localToUTCTimeOfDayHMS tz t+ !d' = addDays dd d+ !tt = Local.timeOfDayToTime t'+ in return (UTCTime d' tt)++-- | Parse a date with time zone info. Acceptable formats:+--+-- @YYYY-MM-DD HH:MM:SS Z@+--+-- The first space may instead be a @T@, and the second space is+-- optional. The @Z@ represents UTC. The @Z@ may be replaced with a+-- time zone offset of the form @+0000@ or @-08:00@, where the first+-- two digits are hours, the @:@ is optional and the second two digits+-- (also optional) are minutes.+zonedTime :: Parser Local.ZonedTime+zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)++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
@@ -0,0 +1,135 @@+{-# LANGUAGE BangPatterns, ViewPatterns #-}++------------------------------------------------------------------------------+-- Module: Database.PostgreSQL.Simple.Time.Internal.Printer+-- Copyright: (c) 2012-2015 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.Time.Internal.Printer+ (+ day+ , timeOfDay+ , timeZone+ , utcTime+ , localTime+ , zonedTime+ , nominalDiffTime+ , calendarDiffTime+ ) where++import Control.Arrow ((>>>))+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.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)++liftB :: FixedPrim a -> BoundedPrim a+liftB = liftFixedToBounded++digit :: FixedPrim Int+digit = (\x -> chr (x + 48)) >$< char8++digits2 :: FixedPrim Int+digits2 = (`quotRem` 10) >$< (digit >*< digit)++digits3 :: FixedPrim Int+digits3 = (`quotRem` 10) >$< (digits2 >*< digit)++digits4 :: FixedPrim Int+digits4 = (`quotRem` 10) >$< (digits3 >*< digit)++frac :: BoundedPrim Int64+frac = condB (== 0) emptyB ((,) '.' >$< (liftB char8 >*< trunc12))+ where+ trunc12 :: BoundedPrim Int64+ trunc12 = (`quotRem` 1000000) >$<+ condB (\(_,y) -> y == 0)+ (fst >$< trunc6)+ (liftB digits6 >*< trunc6)++ digitB = liftB digit++ digits6 = (fromIntegral >>> (`quotRem` 10)) >$< (digits5 >*< digit)+ digits5 = (`quotRem` 10) >$< (digits4 >*< digit)++ trunc6 = (fromIntegral >>> (`quotRem` 100000)) >$< (digitB >*< trunc5)+ trunc5 = condB (== 0) emptyB ((`quotRem` 10000) >$< (digitB >*< trunc4))+ trunc4 = condB (== 0) emptyB ((`quotRem` 1000) >$< (digitB >*< trunc3))+ trunc3 = condB (== 0) emptyB ((`quotRem` 100) >$< (digitB >*< trunc2))+ trunc2 = condB (== 0) emptyB ((`quotRem` 10) >$< (digitB >*< trunc1))+ trunc1 = condB (== 0) emptyB digitB+++year :: BoundedPrim Int32+year = condB (>= 10000) int32Dec (checkBCE >$< liftB digits4)+ where+ checkBCE :: Int32 -> Int+ checkBCE y+ | y > 0 = fromIntegral y+ | otherwise = error msg++ msg = "Database.PostgreSQL.Simple.Time.Printer.year: years BCE not supported"++day :: BoundedPrim Day+day = toYMD >$< (year >*< liftB (char8 >*< digits2 >*< char8 >*< digits2))+ where+ toYMD (toGregorian -> (fromIntegral -> !y, !m,!d)) = (y,('-',(m,('-',d))))++timeOfDay :: BoundedPrim TimeOfDay+timeOfDay = f >$< (hh_mm_ >*< ss)+ where+ f (TimeOfDay h m s) = ((h,(':',(m,':'))),s)++ hh_mm_ = liftB (digits2 >*< char8 >*< digits2 >*< char8)++ ss = (\s -> fromIntegral (fromPico s) `quotRem` 1000000000000) >$<+ (liftB (fromIntegral >$< digits2) >*< frac)++timeZone :: BoundedPrim TimeZone+timeZone = timeZoneMinutes >$< tz+ where+ tz = condB (>= 0) ((,) '+' >$< tzh) ((,) '-' . negate >$< tzh)++ tzh = liftB char8 >*< ((`quotRem` 60) >$< (liftB digits2 >*< tzm))++ tzm = condB (==0) emptyB ((,) ':' >$< liftB (char8 >*< digits2))++utcTime :: BoundedPrim UTCTime+utcTime = f >$< (day >*< liftB char8 >*< timeOfDay >*< liftB char8)+ where f (UTCTime d (timeToTimeOfDay -> tod)) = (d,(' ',(tod,'Z')))++localTime :: BoundedPrim LocalTime+localTime = f >$< (day >*< liftB char8 >*< timeOfDay)+ where f (LocalTime d tod) = (d, (' ', tod))++zonedTime :: BoundedPrim ZonedTime+zonedTime = f >$< (localTime >*< timeZone)+ where f (ZonedTime lt tz) = (lt, tz)+++nominalDiffTime :: NominalDiffTime -> Builder+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 DeriveDataTypeable, DeriveFunctor #-}+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE PolyKinds #-} ------------------------------------------------------------------------------ -- |@@ -22,30 +23,44 @@ , inQuotes ) where -import Blaze.ByteString.Builder (Builder, fromByteString, toByteString)-import Blaze.ByteString.Builder.Char8 (fromChar)-import Blaze.Text (integral, double, float)+import Control.Applicative (Const(Const)) import qualified Data.Aeson as JSON-import Data.ByteString (ByteString)+import Data.ByteString (ByteString)+import Data.ByteString.Builder+ ( Builder, byteString, char8, stringUtf8+ , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec+ , 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)+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 Database.PostgreSQL.Simple.Types (Binary(..), In(..), Null, Default)-import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8+import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow+import Database.PostgreSQL.Simple.Types+import Database.PostgreSQL.Simple.Compat (toByteString)+ 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-import Data.UUID (UUID)-import qualified Data.UUID as UUID+import qualified Data.Text.Lazy.Builder as LT+import Data.UUID.Types (UUID)+import qualified Data.UUID.Types as UUID import Data.Vector (Vector) import qualified Data.Vector as V import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.Time+import Data.Scientific (Scientific)+import Data.Text.Lazy.Builder.Scientific (scientificBuilder)+import Foreign.C.Types (CUInt(..)) -- | How to render an element when substituting it into a query. data Action =@@ -61,15 +76,20 @@ | EscapeByteA ByteString -- ^ Escape binary data for use as a @bytea@ literal. Include surrounding -- quotes. This is used by the 'Binary' newtype wrapper.+ | EscapeIdentifier ByteString+ -- ^ Escape before substituting. Use for all sql identifiers like+ -- table, column names, etc. This is used by the 'Identifier' newtype+ -- wrapper. | Many [Action] -- ^ Concatenate a series of rendering actions. deriving (Typeable) instance Show Action where- show (Plain b) = "Plain " ++ show (toByteString b)- show (Escape b) = "Escape " ++ show b- show (EscapeByteA b) = "EscapeByteA " ++ show b- show (Many b) = "Many " ++ show b+ show (Plain b) = "Plain " ++ show (toByteString b)+ show (Escape b) = "Escape " ++ show b+ show (EscapeByteA b) = "EscapeByteA " ++ show b+ show (EscapeIdentifier b) = "EscapeIdentifier " ++ show b+ show (Many b) = "Many " ++ show b -- | A type that may be used as a single parameter to a SQL query. class ToField a where@@ -80,92 +100,104 @@ 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 {-# INLINE toField #-} instance (ToField a) => ToField (In [a]) where- toField (In []) = Plain $ fromByteString "(null)"+ toField (In []) = Plain $ byteString "(null)" toField (In xs) = Many $- Plain (fromChar '(') :- (intersperse (Plain (fromChar ',')) . map toField $ xs) ++- [Plain (fromChar ')')]+ Plain (char8 '(') :+ (intersperse (Plain (char8 ',')) . map toField $ xs) +++ [Plain (char8 ')')] renderNull :: Action-renderNull = Plain (fromByteString "null")+renderNull = Plain (byteString "null") instance ToField Null where toField _ = renderNull {-# INLINE toField #-} instance ToField Default where- toField _ = Plain (fromByteString "default")+ toField _ = Plain (byteString "default") {-# INLINE toField #-} instance ToField Bool where- toField True = Plain (fromByteString "true")- toField False = Plain (fromByteString "false")+ toField True = Plain (byteString "true")+ toField False = Plain (byteString "false") {-# INLINE toField #-} instance ToField Int8 where- toField = Plain . integral+ toField = Plain . int8Dec {-# INLINE toField #-} instance ToField Int16 where- toField = Plain . integral+ toField = Plain . int16Dec {-# INLINE toField #-} instance ToField Int32 where- toField = Plain . integral+ toField = Plain . int32Dec {-# INLINE toField #-} instance ToField Int where- toField = Plain . integral+ toField = Plain . intDec {-# INLINE toField #-} instance ToField Int64 where- toField = Plain . integral+ toField = Plain . int64Dec {-# INLINE toField #-} instance ToField Integer where- toField = Plain . integral+ toField = Plain . integerDec {-# INLINE toField #-} instance ToField Word8 where- toField = Plain . integral+ toField = Plain . word8Dec {-# INLINE toField #-} instance ToField Word16 where- toField = Plain . integral+ toField = Plain . word16Dec {-# INLINE toField #-} instance ToField Word32 where- toField = Plain . integral+ toField = Plain . word32Dec {-# INLINE toField #-} instance ToField Word where- toField = Plain . integral+ toField = Plain . wordDec {-# INLINE toField #-} instance ToField Word64 where- toField = Plain . integral+ toField = Plain . word64Dec {-# INLINE toField #-} instance ToField PQ.Oid where- toField = Plain . integral . \(PQ.Oid x) -> x+ toField = Plain . \(PQ.Oid (CUInt x)) -> word32Dec x {-# INLINE toField #-} instance ToField Float where- toField v | isNaN v || isInfinite v = Plain (inQuotes (float v))- | otherwise = Plain (float v)+ toField v | isNaN v || isInfinite v = Plain (inQuotes (floatDec v))+ | otherwise = Plain (floatDec v) {-# INLINE toField #-} instance ToField Double where- toField v | isNaN v || isInfinite v = Plain (inQuotes (double v))- | otherwise = Plain (double v)+ toField v | isNaN v || isInfinite v = Plain (inQuotes (doubleDec v))+ | otherwise = Plain (doubleDec v) {-# INLINE toField #-} +instance ToField Scientific where+ toField x = toField (LT.toLazyText (scientificBuilder x))+ {-# INLINE toField #-}+ instance ToField (Binary SB.ByteString) where toField (Binary bs) = EscapeByteA bs {-# INLINE toField #-}@@ -174,6 +206,20 @@ toField (Binary bs) = (EscapeByteA . SB.concat . LB.toChunks) bs {-# INLINE toField #-} +instance ToField Identifier where+ toField (Identifier bs) = EscapeIdentifier (ST.encodeUtf8 bs)+ {-# INLINE toField #-}++instance ToField QualifiedIdentifier where+ toField (QualifiedIdentifier (Just s) t) =+ Many [ EscapeIdentifier (ST.encodeUtf8 s)+ , Plain (char8 '.')+ , EscapeIdentifier (ST.encodeUtf8 t)+ ]+ toField (QualifiedIdentifier Nothing t) =+ EscapeIdentifier (ST.encodeUtf8 t)+ {-# INLINE toField #-}+ instance ToField SB.ByteString where toField = Escape {-# INLINE toField #-}@@ -187,13 +233,23 @@ {-# INLINE toField #-} instance ToField [Char] where- toField = Escape . toByteString . Utf8.fromString+ toField = Escape . toByteString . stringUtf8 {-# INLINE toField #-} instance ToField LT.Text where 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 #-}@@ -230,32 +286,108 @@ toField = Plain . inQuotes . dateToBuilder {-# INLINE toField #-} +instance ToField NominalDiffTime where+ 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+ [] -> Plain (byteString "'{}'")+ xs -> Many $+ Plain (byteString "ARRAY[") :+ (intersperse (Plain (char8 ',')) . map toField $ xs) +++ [Plain (char8 ']')]+ -- Because the ARRAY[...] input syntax is being used, it is possible+ -- that the use of type-specific separator characters is unnecessary.+ instance (ToField a) => ToField (Vector a) where- toField xs = Many $- Plain (fromByteString "ARRAY[") :- (intersperse (Plain (fromChar ',')) . map toField $ V.toList xs) ++- [Plain (fromChar ']')]- -- Because the ARRAY[...] input syntax is being used, it is possible- -- that the use of type-specific separator characters is unnecessary.+ toField = toField . PGArray . V.toList instance ToField UUID where- toField = Plain . inQuotes . fromByteString . UUID.toASCIIBytes+ toField = Plain . inQuotes . byteString . UUID.toASCIIBytes 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: \"@'@\" -- -- This function /does not/ perform any other escaping. inQuotes :: Builder -> Builder inQuotes b = quote `mappend` b `mappend` quote- where quote = Utf8.fromChar '\''+ 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+{-# INLINE interleaveFoldr #-}++instance ToRow a => ToField (Values a) where+ toField (Values types rows) =+ case rows of+ [] -> case types of+ [] -> error norows+ (_:_) -> values $ typedRow (repeat (lit "null"))+ types+ [lit " LIMIT 0)"]+ (_:_) -> case types of+ [] -> values $ untypedRows rows [litC ')']+ (_:_) -> values $ typedRows rows types [litC ')']+ where+ funcname = "Database.PostgreSQL.Simple.toField :: Values a -> Action"+ norows = funcname ++ " either values or types must be non-empty"+ emptyrow = funcname ++ " each row must contain at least one column"+ lit = Plain . byteString+ litC = Plain . char8+ values x = Many (lit "(VALUES ": x)++ typedField :: (Action, QualifiedIdentifier) -> [Action] -> [Action]+ typedField (val,typ) rest = val : lit "::" : toField typ : rest++ typedRow :: [Action] -> [QualifiedIdentifier] -> [Action] -> [Action]+ typedRow (val:vals) (typ:typs) rest =+ litC '(' :+ typedField (val,typ) ( interleaveFoldr+ typedField+ (litC ',')+ (litC ')' : rest)+ (zip vals typs) )+ typedRow _ _ _ = error emptyrow++ untypedRow :: [Action] -> [Action] -> [Action]+ untypedRow (val:vals) rest =+ litC '(' : val :+ interleaveFoldr+ (:)+ (litC ',')+ (litC ')' : rest)+ vals+ untypedRow _ _ = error emptyrow++ typedRows :: ToRow a => [a] -> [QualifiedIdentifier] -> [Action] -> [Action]+ typedRows [] _ _ = error funcname+ typedRows (val:vals) typs rest =+ typedRow (toRow val) typs (multiRows vals rest)++ untypedRows :: ToRow a => [a] -> [Action] -> [Action]+ untypedRows [] _ = error funcname+ untypedRows (val:vals) rest =+ untypedRow (toRow val) (multiRows vals rest)++ multiRows :: ToRow a => [a] -> [Action] -> [Action]+ multiRows vals rest = interleaveFoldr+ (untypedRow . toRow)+ (litC ',')+ rest+ vals
src/Database/PostgreSQL/Simple/ToField.hs-boot view
@@ -1,6 +1,29 @@ module Database.PostgreSQL.Simple.ToField where import Database.PostgreSQL.Simple.Types+import Data.ByteString.Builder(Builder)+import Data.ByteString(ByteString)++-- | How to render an element when substituting it into a query.+data Action =+ Plain Builder+ -- ^ Render without escaping or quoting. Use for non-text types+ -- such as numbers, when you are /certain/ that they will not+ -- introduce formatting vulnerabilities via use of characters such+ -- as spaces or \"@'@\".+ | Escape ByteString+ -- ^ Escape and enclose in quotes before substituting. Use for all+ -- text-like types, and anything else that may contain unsafe+ -- characters when rendered.+ | EscapeByteA ByteString+ -- ^ Escape binary data for use as a @bytea@ literal. Include surrounding+ -- quotes. This is used by the 'Binary' newtype wrapper.+ | EscapeIdentifier ByteString+ -- ^ Escape before substituting. Use for all sql identifiers like+ -- table, column names, etc. This is used by the 'Identifier' newtype+ -- wrapper.+ | Many [Action]+ -- ^ Concatenate a series of rendering actions. class ToField a
src/Database/PostgreSQL/Simple/ToRow.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.ToRow@@ -22,14 +23,33 @@ import Database.PostgreSQL.Simple.ToField (Action(..), ToField(..)) import Database.PostgreSQL.Simple.Types (Only(..), (:.)(..))+import GHC.Generics -- | A collection type that can be turned into a list of rendering -- 'Action's. ----- Instances should use the 'render' method of the 'Param' class+-- 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]+ toRow = gtoRow . from -- ^ ToField a collection of values. instance ToRow () where@@ -85,8 +105,115 @@ [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 instance (ToRow a, ToRow b) => ToRow (a :. b) where toRow (a :. b) = toRow a ++ toRow b+++-- Type class for default implementation of ToRow using generics+class GToRow f where+ gtoRow :: f p -> [Action]++instance GToRow f => GToRow (M1 c i f) where+ gtoRow (M1 x) = gtoRow x++instance (GToRow f, GToRow g) => GToRow (f :*: g) where+ gtoRow (f :*: g) = gtoRow f ++ gtoRow g++instance (ToField a) => GToRow (K1 R a) where+ gtoRow (K1 a) = [toField a]++instance GToRow U1 where+ gtoRow _ = []
src/Database/PostgreSQL/Simple/ToRow.hs-boot view
@@ -1,8 +1,18 @@-module Database.PostgreSQL.Simple.ToRow where+{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-}+module Database.PostgreSQL.Simple.ToRow (+ ToRow(..)+ ) where import Database.PostgreSQL.Simple.Types import {-# SOURCE #-} Database.PostgreSQL.Simple.ToField+import GHC.Generics -class ToRow a+class ToRow a where+ toRow :: a -> [Action]+ default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action]+ toRow = gtoRow . from++class GToRow f where+ gtoRow :: f p -> [Action] instance ToField a => ToRow (Only a)
src/Database/PostgreSQL/Simple/Transaction.hs view
@@ -1,5 +1,15 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-} +------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.Transaction+-- Copyright: (c) 2011-2013 Leon P Smith+-- (c) 2013 Joey Adams+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+--+------------------------------------------------------------------------------+ module Database.PostgreSQL.Simple.Transaction ( -- * Transaction handling@@ -7,6 +17,7 @@ , withTransactionLevel , withTransactionMode , withTransactionModeRetry+ , withTransactionModeRetry' , withTransactionSerializable , TransactionMode(..) , IsolationLevel(..)@@ -45,7 +56,7 @@ -- | Of the four isolation levels defined by the SQL standard, -- these are the three levels distinguished by PostgreSQL as of version 9.0.--- See <http://www.postgresql.org/docs/9.1/static/transaction-iso.html>+-- See <https://www.postgresql.org/docs/9.5/static/transaction-iso.html> -- for more information. Note that prior to PostgreSQL 9.0, 'RepeatableRead' -- was equivalent to 'Serializable'. @@ -132,42 +143,49 @@ withTransactionMode mode conn act = mask $ \restore -> do beginMode mode conn- r <- restore act `E.onException` rollback conn+ r <- restore act `E.onException` rollback_ conn 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 ()+rollback_ conn = rollback conn `E.catch` \(_ :: IOError) -> return ()+ -- | Commit a transaction. commit :: Connection -> IO () commit conn = execute_ conn "COMMIT" >> return ()@@ -203,7 +221,7 @@ -- be used inside of a transaction, and provides a sort of -- \"nested transaction\". ----- See <http://www.postgresql.org/docs/current/static/sql-savepoint.html>+-- See <https://www.postgresql.org/docs/9.5/static/sql-savepoint.html> withSavepoint :: Connection -> IO a -> IO a withSavepoint conn body = mask $ \restore -> do
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,480 +19,1784 @@ ( TypeInfo(..) , staticTypeInfo , bool- , bytea- , char- , name- , int8- , int2- , int4- , regproc- , text- , oid- , tid- , xid- , cid- , xml- , point- , lseg- , path- , box- , polygon- , line- , cidr- , float4- , float8- , abstime- , reltime- , tinterval- , unknown- , circle- , money- , macaddr- , inet- , bpchar- , varchar- , date- , time- , timestamp- , timestamptz- , interval- , timetz- , bit- , varbit- , numeric- , refcursor- , record- , void- , uuid- , json- ) where--import Database.PostgreSQL.LibPQ (Oid(..))-import Database.PostgreSQL.Simple.TypeInfo.Types--staticTypeInfo :: Oid -> Maybe TypeInfo-staticTypeInfo (Oid x) = case x of- 16 -> Just bool- 17 -> Just bytea- 18 -> Just char- 19 -> Just name- 20 -> Just int8- 21 -> Just int2- 23 -> Just int4- 24 -> Just regproc- 25 -> Just text- 26 -> Just oid- 27 -> Just tid- 28 -> Just xid- 29 -> Just cid- 142 -> Just xml- 600 -> Just point- 601 -> Just lseg- 602 -> Just path- 603 -> Just box- 604 -> Just polygon- 628 -> Just line- 650 -> Just cidr- 700 -> Just float4- 701 -> Just float8- 702 -> Just abstime- 703 -> Just reltime- 704 -> Just tinterval- 705 -> Just unknown- 718 -> Just circle- 790 -> Just money- 829 -> Just macaddr- 869 -> Just inet- 1042 -> Just bpchar- 1043 -> Just varchar- 1082 -> Just date- 1083 -> Just time- 1114 -> Just timestamp- 1184 -> Just timestamptz- 1186 -> Just interval- 1266 -> Just timetz- 1560 -> Just bit- 1562 -> Just varbit- 1700 -> Just numeric- 1790 -> Just refcursor- 2249 -> Just record- 2278 -> Just void- 2950 -> Just uuid- 114 -> Just json- _ -> Nothing--bool :: TypeInfo-bool = Basic {- typoid = Oid 16,- typcategory = 'B',- typdelim = ',',- typname = "bool"- }--bytea :: TypeInfo-bytea = Basic {- typoid = Oid 17,- typcategory = 'U',- typdelim = ',',- typname = "bytea"- }--char :: TypeInfo-char = Basic {- typoid = Oid 18,- typcategory = 'S',- typdelim = ',',- typname = "char"- }--name :: TypeInfo-name = Basic {- typoid = Oid 19,- typcategory = 'S',- typdelim = ',',- typname = "name"- }--int8 :: TypeInfo-int8 = Basic {- typoid = Oid 20,- typcategory = 'N',- typdelim = ',',- typname = "int8"- }--int2 :: TypeInfo-int2 = Basic {- typoid = Oid 21,- typcategory = 'N',- typdelim = ',',- typname = "int2"- }--int4 :: TypeInfo-int4 = Basic {- typoid = Oid 23,- typcategory = 'N',- typdelim = ',',- typname = "int4"- }--regproc :: TypeInfo-regproc = Basic {- typoid = Oid 24,- typcategory = 'N',- typdelim = ',',- typname = "regproc"- }--text :: TypeInfo-text = Basic {- typoid = Oid 25,- typcategory = 'S',- typdelim = ',',- typname = "text"- }--oid :: TypeInfo-oid = Basic {- typoid = Oid 26,- typcategory = 'N',- typdelim = ',',- typname = "oid"- }--tid :: TypeInfo-tid = Basic {- typoid = Oid 27,- typcategory = 'U',- typdelim = ',',- typname = "tid"- }--xid :: TypeInfo-xid = Basic {- typoid = Oid 28,- typcategory = 'U',- typdelim = ',',- typname = "xid"- }--cid :: TypeInfo-cid = Basic {- typoid = Oid 29,- typcategory = 'U',- typdelim = ',',- typname = "cid"- }--xml :: TypeInfo-xml = Basic {- typoid = Oid 142,- typcategory = 'U',- typdelim = ',',- typname = "xml"- }--point :: TypeInfo-point = Basic {- typoid = Oid 600,- typcategory = 'G',- typdelim = ',',- typname = "point"- }--lseg :: TypeInfo-lseg = Basic {- typoid = Oid 601,- typcategory = 'G',- typdelim = ',',- typname = "lseg"- }--path :: TypeInfo-path = Basic {- typoid = Oid 602,- typcategory = 'G',- typdelim = ',',- typname = "path"- }--box :: TypeInfo-box = Basic {- typoid = Oid 603,- typcategory = 'G',- typdelim = ';',- typname = "box"- }--polygon :: TypeInfo-polygon = Basic {- typoid = Oid 604,- typcategory = 'G',- typdelim = ',',- typname = "polygon"- }--line :: TypeInfo-line = Basic {- typoid = Oid 628,- typcategory = 'G',- typdelim = ',',- typname = "line"- }--cidr :: TypeInfo-cidr = Basic {- typoid = Oid 650,- typcategory = 'I',- typdelim = ',',- typname = "cidr"- }--float4 :: TypeInfo-float4 = Basic {- typoid = Oid 700,- typcategory = 'N',- typdelim = ',',- typname = "float4"- }--float8 :: TypeInfo-float8 = Basic {- typoid = Oid 701,- typcategory = 'N',- typdelim = ',',- typname = "float8"- }--abstime :: TypeInfo-abstime = Basic {- typoid = Oid 702,- typcategory = 'D',- typdelim = ',',- typname = "abstime"- }--reltime :: TypeInfo-reltime = Basic {- typoid = Oid 703,- typcategory = 'T',- typdelim = ',',- typname = "reltime"- }--tinterval :: TypeInfo-tinterval = Basic {- typoid = Oid 704,- typcategory = 'T',- typdelim = ',',- typname = "tinterval"- }--unknown :: TypeInfo-unknown = Basic {- typoid = Oid 705,- typcategory = 'X',- typdelim = ',',- typname = "unknown"- }--circle :: TypeInfo-circle = Basic {- typoid = Oid 718,- typcategory = 'G',- typdelim = ',',- typname = "circle"- }--money :: TypeInfo-money = Basic {- typoid = Oid 790,- typcategory = 'N',- typdelim = ',',- typname = "money"- }--macaddr :: TypeInfo-macaddr = Basic {- typoid = Oid 829,- typcategory = 'U',- typdelim = ',',- typname = "macaddr"- }--inet :: TypeInfo-inet = Basic {- typoid = Oid 869,- typcategory = 'I',- typdelim = ',',- typname = "inet"- }--bpchar :: TypeInfo-bpchar = Basic {- typoid = Oid 1042,- typcategory = 'S',- typdelim = ',',- typname = "bpchar"- }--varchar :: TypeInfo-varchar = Basic {- typoid = Oid 1043,- typcategory = 'S',- typdelim = ',',- typname = "varchar"- }--date :: TypeInfo-date = Basic {- typoid = Oid 1082,- typcategory = 'D',- typdelim = ',',- typname = "date"- }--time :: TypeInfo-time = Basic {- typoid = Oid 1083,- typcategory = 'D',- typdelim = ',',- typname = "time"- }--timestamp :: TypeInfo-timestamp = Basic {- typoid = Oid 1114,- typcategory = 'D',- typdelim = ',',- typname = "timestamp"- }--timestamptz :: TypeInfo-timestamptz = Basic {- typoid = Oid 1184,- typcategory = 'D',- typdelim = ',',- typname = "timestamptz"- }--interval :: TypeInfo-interval = Basic {- typoid = Oid 1186,- typcategory = 'T',- typdelim = ',',- typname = "interval"- }--timetz :: TypeInfo-timetz = Basic {- typoid = Oid 1266,- typcategory = 'D',- typdelim = ',',- typname = "timetz"- }--bit :: TypeInfo-bit = Basic {- typoid = Oid 1560,- typcategory = 'V',- typdelim = ',',- typname = "bit"- }--varbit :: TypeInfo-varbit = Basic {- typoid = Oid 1562,- typcategory = 'V',- typdelim = ',',- typname = "varbit"- }--numeric :: TypeInfo-numeric = Basic {- typoid = Oid 1700,- typcategory = 'N',- typdelim = ',',- typname = "numeric"- }--refcursor :: TypeInfo-refcursor = Basic {- typoid = Oid 1790,- typcategory = 'U',- typdelim = ',',- typname = "refcursor"- }--record :: TypeInfo-record = Basic {- typoid = Oid 2249,- typcategory = 'P',- typdelim = ',',- typname = "record"- }--void :: TypeInfo-void = Basic {- typoid = Oid 2278,- typcategory = 'P',- typdelim = ',',- typname = "void"- }--uuid :: TypeInfo-uuid = Basic {- typoid = Oid 2950,- typcategory = 'U',- typdelim = ',',- typname = "uuid"- }--json :: TypeInfo-json = Basic {- typoid = Oid 114,- typcategory = 'U',- typdelim = ',',- typname = "json"- }+ , 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(..))+import Database.PostgreSQL.Simple.TypeInfo.Types++staticTypeInfo :: Oid -> Maybe TypeInfo+staticTypeInfo (Oid x) = case x of+ 16 -> Just bool+ 17 -> Just bytea+ 18 -> Just char+ 19 -> Just name+ 20 -> Just int8+ 21 -> Just int2+ 23 -> Just int4+ 24 -> Just regproc+ 25 -> Just text+ 26 -> Just oid+ 27 -> Just tid+ 28 -> Just xid+ 29 -> Just cid+ 142 -> Just xml+ 600 -> Just point+ 601 -> Just lseg+ 602 -> Just path+ 603 -> Just box+ 604 -> Just polygon+ 628 -> Just line+ 650 -> Just cidr+ 700 -> Just float4+ 701 -> Just float8+ 705 -> Just unknown+ 718 -> Just circle+ 790 -> Just money+ 829 -> Just macaddr+ 869 -> Just inet+ 1042 -> Just bpchar+ 1043 -> Just varchar+ 1082 -> Just date+ 1083 -> Just time+ 1114 -> Just timestamp+ 1184 -> Just timestamptz+ 1186 -> Just interval+ 1266 -> Just timetz+ 1560 -> Just bit+ 1562 -> Just varbit+ 1700 -> Just numeric+ 1790 -> Just refcursor+ 2249 -> Just record+ 2278 -> Just void+ 2287 -> Just array_record+ 2202 -> Just regprocedure+ 2203 -> Just regoper+ 2204 -> Just regoperator+ 2205 -> Just regclass+ 2206 -> Just regtype+ 2950 -> Just uuid+ 114 -> Just json+ 3802 -> Just jsonb+ 22 -> Just int2vector+ 30 -> Just oidvector+ 143 -> Just array_xml+ 199 -> Just array_json+ 629 -> Just array_line+ 651 -> Just array_cidr+ 719 -> Just array_circle+ 791 -> Just array_money+ 1000 -> Just array_bool+ 1001 -> Just array_bytea+ 1002 -> Just array_char+ 1003 -> Just array_name+ 1005 -> Just array_int2+ 1006 -> Just array_int2vector+ 1007 -> Just array_int4+ 1008 -> Just array_regproc+ 1009 -> Just array_text+ 1010 -> Just array_tid+ 1011 -> Just array_xid+ 1012 -> Just array_cid+ 1013 -> Just array_oidvector+ 1014 -> Just array_bpchar+ 1015 -> Just array_varchar+ 1016 -> Just array_int8+ 1017 -> Just array_point+ 1018 -> Just array_lseg+ 1019 -> Just array_path+ 1020 -> Just array_box+ 1021 -> Just array_float4+ 1022 -> Just array_float8+ 1027 -> Just array_polygon+ 1028 -> Just array_oid+ 1040 -> Just array_macaddr+ 1041 -> Just array_inet+ 1115 -> Just array_timestamp+ 1182 -> Just array_date+ 1183 -> Just array_time+ 1185 -> Just array_timestamptz+ 1187 -> Just array_interval+ 1231 -> Just array_numeric+ 1270 -> Just array_timetz+ 1561 -> Just array_bit+ 1563 -> Just array_varbit+ 2201 -> Just array_refcursor+ 2207 -> Just array_regprocedure+ 2208 -> Just array_regoper+ 2209 -> Just array_regoperator+ 2210 -> Just array_regclass+ 2211 -> Just array_regtype+ 2951 -> Just array_uuid+ 3807 -> Just array_jsonb+ 3904 -> Just int4range+ 3905 -> Just _int4range+ 3906 -> Just numrange+ 3907 -> Just _numrange+ 3908 -> Just tsrange+ 3909 -> Just _tsrange+ 3910 -> Just tstzrange+ 3911 -> Just _tstzrange+ 3912 -> Just daterange+ 3913 -> Just _daterange+ 3926 -> Just int8range+ 3927 -> Just _int8range+ _ -> Nothing++bool :: TypeInfo+bool = Basic {+ typoid = boolOid,+ typcategory = 'B',+ typdelim = ',',+ typname = "bool"+ }++boolOid :: Oid+boolOid = Oid 16+{-# INLINE boolOid #-}++bytea :: TypeInfo+bytea = Basic {+ typoid = byteaOid,+ typcategory = 'U',+ typdelim = ',',+ typname = "bytea"+ }++byteaOid :: Oid+byteaOid = Oid 17+{-# INLINE byteaOid #-}++char :: TypeInfo+char = Basic {+ typoid = charOid,+ typcategory = 'S',+ typdelim = ',',+ typname = "char"+ }++charOid :: Oid+charOid = Oid 18+{-# INLINE charOid #-}++name :: TypeInfo+name = Basic {+ typoid = nameOid,+ typcategory = 'S',+ typdelim = ',',+ typname = "name"+ }++nameOid :: Oid+nameOid = Oid 19+{-# INLINE nameOid #-}++int8 :: TypeInfo+int8 = Basic {+ typoid = int8Oid,+ typcategory = 'N',+ typdelim = ',',+ typname = "int8"+ }++int8Oid :: Oid+int8Oid = Oid 20+{-# INLINE int8Oid #-}++int2 :: TypeInfo+int2 = Basic {+ typoid = int2Oid,+ typcategory = 'N',+ typdelim = ',',+ typname = "int2"+ }++int2Oid :: Oid+int2Oid = Oid 21+{-# INLINE int2Oid #-}++int4 :: TypeInfo+int4 = Basic {+ typoid = int4Oid,+ typcategory = 'N',+ typdelim = ',',+ typname = "int4"+ }++int4Oid :: Oid+int4Oid = Oid 23+{-# INLINE int4Oid #-}++regproc :: TypeInfo+regproc = Basic {+ typoid = regprocOid,+ typcategory = 'N',+ typdelim = ',',+ typname = "regproc"+ }++regprocOid :: Oid+regprocOid = Oid 24+{-# INLINE regprocOid #-}++text :: TypeInfo+text = Basic {+ typoid = textOid,+ typcategory = 'S',+ typdelim = ',',+ typname = "text"+ }++textOid :: Oid+textOid = Oid 25+{-# INLINE textOid #-}++oid :: TypeInfo+oid = Basic {+ typoid = oidOid,+ typcategory = 'N',+ typdelim = ',',+ typname = "oid"+ }++oidOid :: Oid+oidOid = Oid 26+{-# INLINE oidOid #-}++tid :: TypeInfo+tid = Basic {+ typoid = tidOid,+ typcategory = 'U',+ typdelim = ',',+ typname = "tid"+ }++tidOid :: Oid+tidOid = Oid 27+{-# INLINE tidOid #-}++xid :: TypeInfo+xid = Basic {+ typoid = xidOid,+ typcategory = 'U',+ typdelim = ',',+ typname = "xid"+ }++xidOid :: Oid+xidOid = Oid 28+{-# INLINE xidOid #-}++cid :: TypeInfo+cid = Basic {+ typoid = cidOid,+ typcategory = 'U',+ typdelim = ',',+ typname = "cid"+ }++cidOid :: Oid+cidOid = Oid 29+{-# INLINE cidOid #-}++xml :: TypeInfo+xml = Basic {+ typoid = xmlOid,+ typcategory = 'U',+ typdelim = ',',+ typname = "xml"+ }++xmlOid :: Oid+xmlOid = Oid 142+{-# INLINE xmlOid #-}++point :: TypeInfo+point = Basic {+ typoid = pointOid,+ typcategory = 'G',+ typdelim = ',',+ typname = "point"+ }++pointOid :: Oid+pointOid = Oid 600+{-# INLINE pointOid #-}++lseg :: TypeInfo+lseg = Basic {+ typoid = lsegOid,+ typcategory = 'G',+ typdelim = ',',+ typname = "lseg"+ }++lsegOid :: Oid+lsegOid = Oid 601+{-# INLINE lsegOid #-}++path :: TypeInfo+path = Basic {+ typoid = pathOid,+ typcategory = 'G',+ typdelim = ',',+ typname = "path"+ }++pathOid :: Oid+pathOid = Oid 602+{-# INLINE pathOid #-}++box :: TypeInfo+box = Basic {+ typoid = boxOid,+ typcategory = 'G',+ typdelim = ';',+ typname = "box"+ }++boxOid :: Oid+boxOid = Oid 603+{-# INLINE boxOid #-}++polygon :: TypeInfo+polygon = Basic {+ typoid = polygonOid,+ typcategory = 'G',+ typdelim = ',',+ typname = "polygon"+ }++polygonOid :: Oid+polygonOid = Oid 604+{-# INLINE polygonOid #-}++line :: TypeInfo+line = Basic {+ typoid = lineOid,+ typcategory = 'G',+ typdelim = ',',+ typname = "line"+ }++lineOid :: Oid+lineOid = Oid 628+{-# INLINE lineOid #-}++cidr :: TypeInfo+cidr = Basic {+ typoid = cidrOid,+ typcategory = 'I',+ typdelim = ',',+ typname = "cidr"+ }++cidrOid :: Oid+cidrOid = Oid 650+{-# INLINE cidrOid #-}++float4 :: TypeInfo+float4 = Basic {+ typoid = float4Oid,+ typcategory = 'N',+ typdelim = ',',+ typname = "float4"+ }++float4Oid :: Oid+float4Oid = Oid 700+{-# INLINE float4Oid #-}++float8 :: TypeInfo+float8 = Basic {+ typoid = float8Oid,+ typcategory = 'N',+ typdelim = ',',+ typname = "float8"+ }++float8Oid :: Oid+float8Oid = Oid 701+{-# INLINE float8Oid #-}++unknown :: TypeInfo+unknown = Basic {+ typoid = unknownOid,+ typcategory = 'X',+ typdelim = ',',+ typname = "unknown"+ }++unknownOid :: Oid+unknownOid = Oid 705+{-# INLINE unknownOid #-}++circle :: TypeInfo+circle = Basic {+ typoid = circleOid,+ typcategory = 'G',+ typdelim = ',',+ typname = "circle"+ }++circleOid :: Oid+circleOid = Oid 718+{-# INLINE circleOid #-}++money :: TypeInfo+money = Basic {+ typoid = moneyOid,+ typcategory = 'N',+ typdelim = ',',+ typname = "money"+ }++moneyOid :: Oid+moneyOid = Oid 790+{-# INLINE moneyOid #-}++macaddr :: TypeInfo+macaddr = Basic {+ typoid = macaddrOid,+ typcategory = 'U',+ typdelim = ',',+ typname = "macaddr"+ }++macaddrOid :: Oid+macaddrOid = Oid 829+{-# INLINE macaddrOid #-}++inet :: TypeInfo+inet = Basic {+ typoid = inetOid,+ typcategory = 'I',+ typdelim = ',',+ typname = "inet"+ }++inetOid :: Oid+inetOid = Oid 869+{-# INLINE inetOid #-}++bpchar :: TypeInfo+bpchar = Basic {+ typoid = bpcharOid,+ typcategory = 'S',+ typdelim = ',',+ typname = "bpchar"+ }++bpcharOid :: Oid+bpcharOid = Oid 1042+{-# INLINE bpcharOid #-}++varchar :: TypeInfo+varchar = Basic {+ typoid = varcharOid,+ typcategory = 'S',+ typdelim = ',',+ typname = "varchar"+ }++varcharOid :: Oid+varcharOid = Oid 1043+{-# INLINE varcharOid #-}++date :: TypeInfo+date = Basic {+ typoid = dateOid,+ typcategory = 'D',+ typdelim = ',',+ typname = "date"+ }++dateOid :: Oid+dateOid = Oid 1082+{-# INLINE dateOid #-}++time :: TypeInfo+time = Basic {+ typoid = timeOid,+ typcategory = 'D',+ typdelim = ',',+ typname = "time"+ }++timeOid :: Oid+timeOid = Oid 1083+{-# INLINE timeOid #-}++timestamp :: TypeInfo+timestamp = Basic {+ typoid = timestampOid,+ typcategory = 'D',+ typdelim = ',',+ typname = "timestamp"+ }++timestampOid :: Oid+timestampOid = Oid 1114+{-# INLINE timestampOid #-}++timestamptz :: TypeInfo+timestamptz = Basic {+ typoid = timestamptzOid,+ typcategory = 'D',+ typdelim = ',',+ typname = "timestamptz"+ }++timestamptzOid :: Oid+timestamptzOid = Oid 1184+{-# INLINE timestamptzOid #-}++interval :: TypeInfo+interval = Basic {+ typoid = intervalOid,+ typcategory = 'T',+ typdelim = ',',+ typname = "interval"+ }++intervalOid :: Oid+intervalOid = Oid 1186+{-# INLINE intervalOid #-}++timetz :: TypeInfo+timetz = Basic {+ typoid = timetzOid,+ typcategory = 'D',+ typdelim = ',',+ typname = "timetz"+ }++timetzOid :: Oid+timetzOid = Oid 1266+{-# INLINE timetzOid #-}++bit :: TypeInfo+bit = Basic {+ typoid = bitOid,+ typcategory = 'V',+ typdelim = ',',+ typname = "bit"+ }++bitOid :: Oid+bitOid = Oid 1560+{-# INLINE bitOid #-}++varbit :: TypeInfo+varbit = Basic {+ typoid = varbitOid,+ typcategory = 'V',+ typdelim = ',',+ typname = "varbit"+ }++varbitOid :: Oid+varbitOid = Oid 1562+{-# INLINE varbitOid #-}++numeric :: TypeInfo+numeric = Basic {+ typoid = numericOid,+ typcategory = 'N',+ typdelim = ',',+ typname = "numeric"+ }++numericOid :: Oid+numericOid = Oid 1700+{-# INLINE numericOid #-}++refcursor :: TypeInfo+refcursor = Basic {+ typoid = refcursorOid,+ typcategory = 'U',+ typdelim = ',',+ typname = "refcursor"+ }++refcursorOid :: Oid+refcursorOid = Oid 1790+{-# INLINE refcursorOid #-}++record :: TypeInfo+record = Basic {+ typoid = recordOid,+ typcategory = 'P',+ typdelim = ',',+ typname = "record"+ }++recordOid :: Oid+recordOid = Oid 2249+{-# INLINE recordOid #-}++void :: TypeInfo+void = Basic {+ typoid = voidOid,+ typcategory = 'P',+ typdelim = ',',+ typname = "void"+ }++voidOid :: Oid+voidOid = Oid 2278+{-# INLINE voidOid #-}++array_record :: TypeInfo+array_record = Array {+ 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 = regprocedureOid,+ typcategory = 'N',+ typdelim = ',',+ typname = "regprocedure"+ }++regprocedureOid :: Oid+regprocedureOid = Oid 2202+{-# INLINE regprocedureOid #-}++regoper :: TypeInfo+regoper = Basic {+ typoid = regoperOid,+ typcategory = 'N',+ typdelim = ',',+ typname = "regoper"+ }++regoperOid :: Oid+regoperOid = Oid 2203+{-# INLINE regoperOid #-}++regoperator :: TypeInfo+regoperator = Basic {+ typoid = regoperatorOid,+ typcategory = 'N',+ typdelim = ',',+ typname = "regoperator"+ }++regoperatorOid :: Oid+regoperatorOid = Oid 2204+{-# INLINE regoperatorOid #-}++regclass :: TypeInfo+regclass = Basic {+ typoid = regclassOid,+ typcategory = 'N',+ typdelim = ',',+ typname = "regclass"+ }++regclassOid :: Oid+regclassOid = Oid 2205+{-# INLINE regclassOid #-}++regtype :: TypeInfo+regtype = Basic {+ typoid = regtypeOid,+ typcategory = 'N',+ typdelim = ',',+ typname = "regtype"+ }++regtypeOid :: Oid+regtypeOid = Oid 2206+{-# INLINE regtypeOid #-}++uuid :: TypeInfo+uuid = Basic {+ typoid = uuidOid,+ typcategory = 'U',+ typdelim = ',',+ typname = "uuid"+ }++uuidOid :: Oid+uuidOid = Oid 2950+{-# INLINE uuidOid #-}++json :: TypeInfo+json = Basic {+ typoid = jsonOid,+ typcategory = 'U',+ typdelim = ',',+ typname = "json"+ }++jsonOid :: Oid+jsonOid = Oid 114+{-# INLINE jsonOid #-}++jsonb :: TypeInfo+jsonb = Basic {+ typoid = jsonbOid,+ typcategory = 'U',+ typdelim = ',',+ typname = "jsonb"+ }++jsonbOid :: Oid+jsonbOid = Oid 3802+{-# INLINE jsonbOid #-}++int2vector :: TypeInfo+int2vector = Array {+ typoid = int2vectorOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "int2vector",+ typelem = int2+ }++int2vectorOid :: Oid+int2vectorOid = Oid 22+{-# INLINE int2vectorOid #-}++oidvector :: TypeInfo+oidvector = Array {+ typoid = oidvectorOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "oidvector",+ typelem = oid+ }++oidvectorOid :: Oid+oidvectorOid = Oid 30+{-# INLINE oidvectorOid #-}++array_xml :: TypeInfo+array_xml = Array {+ 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = array_jsonbOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_jsonb",+ typelem = jsonb+ }++array_jsonbOid :: Oid+array_jsonbOid = Oid 3807+{-# INLINE array_jsonbOid #-}++int4range :: TypeInfo+int4range = Range {+ typoid = int4rangeOid,+ typcategory = 'R',+ typdelim = ',',+ typname = "int4range",+ rngsubtype = int4+ }++int4rangeOid :: Oid+int4rangeOid = Oid 3904+{-# INLINE int4rangeOid #-}++_int4range :: TypeInfo+_int4range = Array {+ typoid = _int4rangeOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_int4range",+ typelem = int4range+ }++_int4rangeOid :: Oid+_int4rangeOid = Oid 3905+{-# INLINE _int4rangeOid #-}++numrange :: TypeInfo+numrange = Range {+ typoid = numrangeOid,+ typcategory = 'R',+ typdelim = ',',+ typname = "numrange",+ rngsubtype = numeric+ }++numrangeOid :: Oid+numrangeOid = Oid 3906+{-# INLINE numrangeOid #-}++_numrange :: TypeInfo+_numrange = Array {+ typoid = _numrangeOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_numrange",+ typelem = numrange+ }++_numrangeOid :: Oid+_numrangeOid = Oid 3907+{-# INLINE _numrangeOid #-}++tsrange :: TypeInfo+tsrange = Range {+ typoid = tsrangeOid,+ typcategory = 'R',+ typdelim = ',',+ typname = "tsrange",+ rngsubtype = timestamp+ }++tsrangeOid :: Oid+tsrangeOid = Oid 3908+{-# INLINE tsrangeOid #-}++_tsrange :: TypeInfo+_tsrange = Array {+ typoid = _tsrangeOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_tsrange",+ typelem = tsrange+ }++_tsrangeOid :: Oid+_tsrangeOid = Oid 3909+{-# INLINE _tsrangeOid #-}++tstzrange :: TypeInfo+tstzrange = Range {+ typoid = tstzrangeOid,+ typcategory = 'R',+ typdelim = ',',+ typname = "tstzrange",+ rngsubtype = timestamptz+ }++tstzrangeOid :: Oid+tstzrangeOid = Oid 3910+{-# INLINE tstzrangeOid #-}++_tstzrange :: TypeInfo+_tstzrange = Array {+ typoid = _tstzrangeOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_tstzrange",+ typelem = tstzrange+ }++_tstzrangeOid :: Oid+_tstzrangeOid = Oid 3911+{-# INLINE _tstzrangeOid #-}++daterange :: TypeInfo+daterange = Range {+ typoid = daterangeOid,+ typcategory = 'R',+ typdelim = ',',+ typname = "daterange",+ rngsubtype = date+ }++daterangeOid :: Oid+daterangeOid = Oid 3912+{-# INLINE daterangeOid #-}++_daterange :: TypeInfo+_daterange = Array {+ typoid = _daterangeOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_daterange",+ typelem = daterange+ }++_daterangeOid :: Oid+_daterangeOid = Oid 3913+{-# INLINE _daterangeOid #-}++int8range :: TypeInfo+int8range = Range {+ typoid = int8rangeOid,+ typcategory = 'R',+ typdelim = ',',+ typname = "int8range",+ rngsubtype = int8+ }++int8rangeOid :: Oid+int8rangeOid = Oid 3926+{-# INLINE int8rangeOid #-}++_int8range :: TypeInfo+_int8range = Array {+ typoid = _int8rangeOid,+ typcategory = 'A',+ typdelim = ',',+ typname = "_int8range",+ typelem = int8range+ }++_int8rangeOid :: Oid+_int8rangeOid = Oid 3927+{-# INLINE _int8rangeOid #-}
src/Database/PostgreSQL/Simple/Types.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ -- |@@ -20,30 +20,36 @@ , Only(..) , In(..) , Binary(..)+ , Identifier(..)+ , QualifiedIdentifier(..) , Query(..) , Oid(..) , (:.)(..) , Savepoint(..)+ , PGArray(..)+ , Values(..) ) where -import Blaze.ByteString.Builder (toByteString)-import Control.Arrow (first)-import Data.ByteString (ByteString)-import Data.Monoid (Monoid(..))-import Data.String (IsString(..))-import Data.Typeable (Typeable)-import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8+import Control.Arrow (first)+import Data.ByteString (ByteString)+import Data.Hashable (Hashable(hashWithSalt))+import Data.Foldable (toList)+import Data.Monoid (Monoid(..))+import Data.Semigroup+import Data.String (IsString(..))+import Data.Typeable (Typeable)+import Data.ByteString.Builder ( stringUtf8 ) import qualified Data.ByteString as B-import Database.PostgreSQL.LibPQ (Oid(..))+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) -- | A placeholder for the SQL @NULL@ value. 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)@@ -78,31 +84,16 @@ readsPrec i = fmap (first Query) . readsPrec i instance IsString Query where- fromString = Query . toByteString . Utf8.fromString+ fromString = Query . toByteString . stringUtf8 +instance Semigroup Query where+ Query a <> Query b = Query (B.append a b)+ {-# INLINE (<>) #-}+ sconcat xs = Query (B.concat $ map fromQuery $ toList xs)+ instance Monoid Query where mempty = Query B.empty- mappend (Query a) (Query b) = Query (B.append a b)- {-# INLINE mappend #-}- mconcat xs = Query (B.concat (map fromQuery xs)) --- | 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 -- values.@@ -110,6 +101,44 @@ -- Example: -- -- > query c "select * from whatever where id in ?" (Only (In [3,4,5]))+--+-- Note that @In []@ expands to @(null)@, which works as expected in+-- the query above, but evaluates to the logical null value on every+-- row instead of @TRUE@. This means that changing the query above+-- to @... id NOT in ?@ and supplying the empty list as the parameter+-- returns zero rows, instead of all of them as one would expect.+--+-- Since postgresql doesn't seem to provide a syntax for actually specifying+-- an empty list, which could solve this completely, there are two+-- workarounds particularly worth mentioning, namely:+--+-- 1. Use postgresql-simple's 'Values' type instead, which can handle the+-- empty case correctly. Note however that while specifying the+-- postgresql type @"int4"@ is mandatory in the empty case, specifying+-- the haskell type @Values (Only Int)@ would not normally be needed in+-- realistic use cases.+--+-- > query c "select * from whatever where id not in ?"+-- > (Only (Values ["int4"] [] :: Values (Only Int)))+--+--+-- 2. Use sql's @COALESCE@ operator to turn a logical @null@ into the correct+-- boolean. Note however that the correct boolean depends on the use+-- case:+--+-- > query c "select * from whatever where coalesce(id NOT in ?, TRUE)"+-- > (Only (In [] :: In [Int]))+--+-- > query c "select * from whatever where coalesce(id IN ?, FALSE)"+-- > (Only (In [] :: In [Int]))+--+-- Note that at as of PostgreSQL 9.4, the query planner cannot see inside+-- the @COALESCE@ operator, so if you have an index on @id@ then you+-- probably don't want to write the last example with @COALESCE@, which+-- would result in a table scan. There are further caveats if @id@ can+-- be null or you want null treated sensibly as a component of @IN@ or+-- @NOT IN@.+ newtype In a = In a deriving (Eq, Ord, Read, Show, Typeable, Functor) @@ -117,6 +146,38 @@ newtype Binary a = Binary {fromBinary :: a} deriving (Eq, Ord, Read, Show, Typeable, Functor) +-- | Wrap text for use as sql identifier, i.e. a table or column name.+newtype Identifier = Identifier {fromIdentifier :: Text}+ deriving (Eq, Ord, Read, Show, Typeable, IsString)++instance Hashable Identifier where+ hashWithSalt i (Identifier t) = hashWithSalt i t++-- | Wrap text for use as (maybe) qualified identifier, i.e. a table+-- with schema, or column with table.+data QualifiedIdentifier = QualifiedIdentifier (Maybe Text) Text+ deriving (Eq, Ord, Read, Show, Typeable)++instance Hashable QualifiedIdentifier where+ hashWithSalt i (QualifiedIdentifier q t) = hashWithSalt i (q, t)++-- | @\"foo.bar\"@ will get turned into+-- @QualifiedIdentifier (Just \"foo\") \"bar\"@, while @\"foo\"@ will get+-- turned into @QualifiedIdentifier Nothing \"foo\"@. Note this instance+-- is for convenience, and does not match postgres syntax. It+-- only examines the first period character, and thus cannot be used if the+-- qualifying identifier contains a period for example.++instance IsString QualifiedIdentifier where+ fromString str = let (x,y) = T.break (== '.') (fromString str)+ in if T.null y+ then QualifiedIdentifier Nothing x+ else QualifiedIdentifier (Just x) (T.tail y)++-- | Wrap a list for use as a PostgreSQL array.+newtype PGArray a = PGArray {fromPGArray :: [a]}+ deriving (Eq, Ord, Read, Show, Typeable, Functor)+ -- | A composite type to parse your custom data structures without -- having to define dummy newtype wrappers every time. --@@ -138,4 +199,60 @@ infixr 3 :. newtype Savepoint = Savepoint Query+ deriving (Eq, Ord, Show, Read, Typeable)++-- | Represents a @VALUES@ table literal, usable as an alternative to+-- 'Database.PostgreSQL.Simple.executeMany' and+-- 'Database.PostgreSQL.Simple.returning'. The main advantage is that+-- you can parametrize more than just a single @VALUES@ expression.+-- For example, here's a query to insert a thing into one table+-- and some attributes of that thing into another, returning the+-- new id generated by the database:+--+--+-- > query c [sql|+-- > WITH new_thing AS (+-- > INSERT INTO thing (name) VALUES (?) RETURNING id+-- > ), new_attributes AS (+-- > INSERT INTO thing_attributes+-- > SELECT new_thing.id, attrs.*+-- > FROM new_thing JOIN ? attrs ON TRUE+-- > ) SELECT * FROM new_thing+-- > |] ("foo", Values [ "int4", "text" ]+-- > [ ( 1 , "hello" )+-- > , ( 2 , "world" ) ])+--+-- (Note this example uses writable common table expressions,+-- which were added in PostgreSQL 9.1)+--+-- The second parameter gets expanded into the following SQL syntax:+--+-- > (VALUES (1::"int4",'hello'::"text"),(2,'world'))+--+-- When the list of attributes is empty, the second parameter expands to:+--+-- > (VALUES (null::"int4",null::"text") LIMIT 0)+--+-- By contrast, @executeMany@ and @returning@ don't issue the query+-- in the empty case, and simply return @0@ and @[]@ respectively.+-- This behavior is usually correct given their intended use cases,+-- but would certainly be wrong in the example above.+--+-- The first argument is a list of postgresql type names. Because this+-- is turned into a properly quoted identifier, the type name is case+-- sensitive and must be as it appears in the @pg_type@ table. Thus,+-- you must write @timestamptz@ instead of @timestamp with time zone@,+-- @int4@ instead of @integer@ or @serial@, @_int8@ instead of @bigint[]@,+-- etcetera.+--+-- You may omit the type names, however, if you do so the list+-- of values must be non-empty, and postgresql must be able to infer+-- the types of the columns from the surrounding context. If the first+-- condition is not met, postgresql-simple will throw an exception+-- without issuing the query. In the second case, the postgres server+-- will return an error which will be turned into a @SqlError@ exception.+--+-- See <https://www.postgresql.org/docs/9.5/static/sql-values.html> for+-- more information.+data Values a = Values [QualifiedIdentifier] [a] deriving (Eq, Ord, Show, Read, Typeable)
+ 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/Common.hs view
@@ -1,6 +1,6 @@ module Common ( module Database.PostgreSQL.Simple,- module Test.HUnit,+ module Test.Tasty.HUnit, TestEnv(..), md5, ) where@@ -8,7 +8,7 @@ import Data.ByteString (ByteString) import Data.Text (Text) import Database.PostgreSQL.Simple-import Test.HUnit+import Test.Tasty.HUnit import qualified Crypto.Hash.MD5 as MD5 import qualified Data.ByteString.Base16 as Base16
+ 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
@@ -1,45 +1,95 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-} {-# 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.HStore+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.ByteString (ByteString)+import Data.Char+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)-import System.Exit (exitFailure)-import System.IO+import qualified Data.Text.Encoding as T import qualified Data.Vector as V-import Data.Aeson+import System.FilePath+import System.Timeout(timeout)+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 -> Test]-tests =- [ TestLabel "Bytea" . testBytea- , TestLabel "ExecuteMany" . testExecuteMany- , TestLabel "Fold" . testFold- , TestLabel "Notify" . testNotify- , TestLabel "Serializable" . testSerializable- , TestLabel "Time" . testTime- , TestLabel "Array" . testArray- , TestLabel "HStore" . testHStore- , TestLabel "JSON" . testJSON- , TestLabel "Savepoint" . testSavepoint+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 "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 "Exceptions" . testExceptions ] -testBytea :: TestEnv -> Test-testBytea TestEnv{..} = TestList+testBytea :: TestEnv -> TestTree+testBytea TestEnv{..} = testGroup "Bytea" [ testStr "empty" [] , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String) , testStr "ascending" [0..255]@@ -48,7 +98,7 @@ , testStr "descending, doubled up" $ doubleUp [255,254..0] ] where- testStr label bytes = TestLabel label $ TestCase $ do+ testStr label bytes = testCase label $ do let bs = B.pack bytes [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs]@@ -59,8 +109,8 @@ doubleUp = concatMap (\x -> [x, x]) -testExecuteMany :: TestEnv -> Test-testExecuteMany TestEnv{..} = TestCase $ do+testExecuteMany :: TestEnv -> Assertion+testExecuteMany TestEnv{..} = do execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)" let rows :: [(Int, String, Binary ByteString)]@@ -77,8 +127,8 @@ return () -testFold :: TestEnv -> Test-testFold TestEnv{..} = TestCase $ do+testFold :: TestEnv -> Assertion+testFold TestEnv{..} = do xs <- fold_ conn "SELECT generate_series(1,10000)" [] $ \xs (Only x) -> return (x:xs) reverse xs @?= ([1..10000] :: [Int])@@ -89,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 []@@ -147,8 +197,8 @@ ++ show (typeOf resultType) ++ " -> " ++ show val) -testArray :: TestEnv -> Test-testArray TestEnv{..} = TestCase $ do+testArray :: TestEnv -> Assertion+testArray TestEnv{..} = do xs <- query_ conn "SELECT '{1,2,3,4}'::_int4" xs @?= [Only (V.fromList [1,2,3,4 :: Int])] xs <- query_ conn "SELECT '{{1,2},{3,4}}'::_int4"@@ -157,8 +207,17 @@ queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool) queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int) -testHStore :: TestEnv -> Test-testHStore TestEnv{..} = TestCase $ do+testNullableArray :: TestEnv -> Assertion+testNullableArray TestEnv{..} = do+ xs <- query_ conn "SELECT '{sometext, \"NULL\"}'::_text"+ xs @?= [Only (V.fromList ["sometext", "NULL" :: Text])]+ xs <- query_ conn "SELECT '{sometext, NULL}'::_text"+ xs @?= [Only (V.fromList [Just "sometext", Nothing :: Maybe Text])]+ queryFailure conn "SELECT '{sometext, NULL}'::_text" (undefined :: V.Vector Text)++testHStore :: TestEnv -> Assertion+testHStore TestEnv{..} = do+ execute_ conn "CREATE EXTENSION IF NOT EXISTS hstore" roundTrip [] roundTrip [("foo","bar"),("bar","baz"),("baz","hello")] roundTrip [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")]@@ -169,12 +228,27 @@ m' <- query conn "SELECT ?::hstore" m [m] @?= m' -testJSON :: TestEnv -> Test-testJSON TestEnv{..} = TestCase $ do- roundTrip (Map.fromList [] :: Map ByteString ByteString)- roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map ByteString ByteString )- roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map ByteString ByteString)+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)+ 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 :: ToJSON a => a -> Assertion roundTrip a = do@@ -182,8 +256,92 @@ js' <- query conn "SELECT ?::json" js [js] @?= js' -testSavepoint :: TestEnv -> Test-testSavepoint TestEnv{..} = TestCase $ do+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 $ withSavepoint conn $ return () @@ -243,6 +401,181 @@ return () +testUnicode :: TestEnv -> Assertion+testUnicode TestEnv{..} = do+ let q = Query . T.encodeUtf8 -- Handle encoding ourselves to ensure+ -- the table gets created correctly.+ let messages = map Only ["привет","мир"] :: [Only Text]+ execute_ conn (q "CREATE TEMPORARY TABLE ру́сский (сообщение TEXT)")+ executeMany conn "INSERT INTO ру́сский (сообщение) VALUES (?)" messages+ messages' <- query_ conn "SELECT сообщение FROM ру́сский"+ sort messages @?= sort messages'++testValues :: TestEnv -> Assertion+testValues TestEnv{..} = do+ execute_ conn "CREATE TEMPORARY TABLE values_test (x int, y text)"+ test (Values ["int4","text"] [])+ test (Values ["int4","text"] [(1,"hello")])+ test (Values ["int4","text"] [(1,"hello"),(2,"world")])+ test (Values ["int4","text"] [(1,"hello"),(2,"world"),(3,"goodbye")])+ test (Values [] [(1,"hello")])+ test (Values [] [(1,"hello"),(2,"world")])+ test (Values [] [(1,"hello"),(2,"world"),(3,"goodbye")])+ where+ test :: Values (Int, Text) -> Assertion+ test table@(Values _ vals) = do+ execute conn "INSERT INTO values_test ?" (Only table)+ vals' <- query_ conn "DELETE FROM values_test RETURNING *"+ sort vals @?= sort vals'+++testCopy :: TestEnv -> Assertion+testCopy TestEnv{..} = do+ execute_ conn "CREATE TEMPORARY TABLE copy_test (x int, y text)"+ copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"+ mapM_ (putCopyData conn) copyRows+ putCopyEnd conn+ copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"+ mapM_ (putCopyData conn) abortRows+ putCopyError conn "aborted"+ -- Hmm, does postgres always produce \n as an end-of-line here, or+ -- are there cases where it will use a \r\n as well?+ copy_ conn "COPY copy_test TO STDOUT (FORMAT CSV)"+ rows <- loop []+ sort rows @?= sort copyRows+ -- Now, let's just verify that the connection state is back to ready,+ -- 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"]+ abortRows = ["3,baz\n"]+ loop rows = do+ mrow <- getCopyData conn+ case mrow of+ CopyOutDone _ -> return rows+ CopyOutRow row -> loop (row:rows)++testCopyFailures :: TestEnv -> TestTree+testCopyFailures env = testGroup "Copy failures"+ $ map ($ env)+ [ testCopyUniqueConstraintError+ , testCopyMalformedError+ ]++goldenTest :: TestName -> IO BL.ByteString -> TestTree+goldenTest testName =+ 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+testCopyUniqueConstraintError TestEnv{..} =+ goldenTest "unique constraint violation"+ $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do+ execute_ conn "CREATE TEMPORARY TABLE copy_unique_constraint_error_test (x int PRIMARY KEY, y text)"+ copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)"+ mapM_ (putCopyData conn) copyRows+ _n <- putCopyEnd conn+ return BL.empty+ where+ copyRows = ["1,foo\n"+ ,"2,bar\n"+ ,"1,baz\n"]++testCopyMalformedError :: TestEnv -> TestTree+testCopyMalformedError TestEnv{..} =+ goldenTest "malformed input"+ $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do+ execute_ conn "CREATE TEMPORARY TABLE copy_malformed_input_error_test (x int PRIMARY KEY, y text)"+ copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)"+ mapM_ (putCopyData conn) copyRows+ _n <- putCopyEnd conn+ return BL.empty+ where+ copyRows = ["1,foo\n"+ ,"2,bar\n"+ ,"z,baz\n"]++testTimeout :: TestEnv -> Assertion+testTimeout TestEnv{..} =+ withConn $ \c -> do+ start_t <- getCurrentTime+ res <- timeout 200000 $ do+ withTransaction c $ do+ query_ c "SELECT pg_sleep(1)" :: IO [Only ()]+ end_t <- getCurrentTime+ assertBool "Timeout did not occur" (res == Nothing)+#if !defined(mingw32_HOST_OS)+-- At the moment, you cannot timely abandon queries with async exceptions on+-- Windows.+ let d = end_t `diffUTCTime` start_t+ assertBool "Timeout didn't work in a timely fashion" (0.1 < d && d < 0.6)+#endif++testDouble :: TestEnv -> Assertion+testDouble TestEnv{..} = do+ [Only (x :: Double)] <- query_ conn "SELECT 'NaN'::float8"+ assertBool "expected NaN" (isNaN x)+ [Only (x :: Double)] <- query_ conn "SELECT 'Infinity'::float8"+ x @?= (1 / 0)+ [Only (x :: Double)] <- query_ conn "SELECT '-Infinity'::float8"+ x @?= (-1 / 0)+++testGeneric1 :: TestEnv -> Assertion+testGeneric1 TestEnv{..} = do+ roundTrip conn (Gen1 123)+ where+ roundTrip conn x0 = do+ r <- query conn "SELECT ?::int" (x0 :: Gen1)+ r @?= [x0]++testGeneric2 :: TestEnv -> Assertion+testGeneric2 TestEnv{..} = do+ roundTrip conn (Gen2 123 "asdf")+ where+ roundTrip conn x0 = do+ r <- query conn "SELECT ?::int, ?::text" x0+ r @?= [x0]++testGeneric3 :: TestEnv -> Assertion+testGeneric3 TestEnv{..} = do+ roundTrip conn (Gen3 123 "asdf" True)+ where+ roundTrip conn x0 = do+ r <- query conn "SELECT ?::int, ?::text, ?::bool" x0+ r @?= [x0]++data Gen1 = Gen1 Int+ deriving (Show,Eq,Generic)+instance FromRow Gen1+instance ToRow Gen1++data Gen2 = Gen2 Int Text+ deriving (Show,Eq,Generic)+instance FromRow Gen2+instance ToRow Gen2++data Gen3 = Gen3 Int Text Bool+ deriving (Show,Eq,Generic)+instance FromRow Gen3+instance ToRow Gen3+ data TestException = TestException deriving (Eq, Show, Typeable)@@ -260,28 +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 = do- mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr]- Counts{cases, tried, errors, failures} <-- withTestEnv $ \env -> runTestTT $ TestList $ map ($ env) tests- when (cases /= tried || errors /= 0 || failures /= 0) $ exitFailure+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/Notify.hs view
@@ -14,9 +14,8 @@ -- TODO: Test with payload, but only for PostgreSQL >= 9.0 -- (when that feature was introduced). -testNotify :: TestEnv -> Test+testNotify :: TestEnv -> Assertion testNotify TestEnv{..} =- TestCase $ withConn $ \conn2 -> do execute_ conn "LISTEN foo" execute_ conn "LISTEN bar"
test/Serializable.hs view
@@ -23,9 +23,8 @@ 1 <- execute conn "UPDATE testSerializableCounter SET n=?" (Only n) return () -testSerializable :: TestEnv -> Test+testSerializable :: TestEnv -> Assertion testSerializable TestEnv{..} =- TestCase $ withConn $ \conn2 -> do initCounter conn
test/Time.hs view
@@ -17,42 +17,82 @@ 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 Time (testTime) where import Common import Control.Monad(forM_, replicateM_)-import Data.Time+import Data.Time.Compat import Data.ByteString(ByteString) import Database.PostgreSQL.Simple.SqlQQ numTests :: Int numTests = 200 -testTime :: TestEnv -> Test-testTime env@TestEnv{..} = TestCase $ do+testTime :: TestEnv -> Assertion+testTime env@TestEnv{..} = do initializeTable env execute_ conn "SET timezone TO 'UTC'"- checkRoundTrips env- execute_ conn "SET timezone TO 'America/Chicago'"- checkRoundTrips env- execute_ conn "SET timezone TO 'Asia/Tokyo'"- checkRoundTrips env- execute_ conn "SET timezone TO 'Asia/Kathmandu'"- checkRoundTrips env- execute_ conn "SET timezone TO 'America/St_Johns'"- checkRoundTrips env+ checkRoundTrips env "1860-01-01 00:00:00+00"+ execute_ conn "SET timezone TO 'America/Chicago'" -- -5:00+ checkRoundTrips env "1883-11-18 12:00:00-06"+ execute_ conn "SET timezone TO 'Asia/Tokyo'" -- +9:00+ checkRoundTrips env "1888-01-01 00:00:00+09"+ execute_ conn "SET timezone TO 'Asia/Kathmandu'" -- +5:45+ checkRoundTrips env "1919-12-31 23:48:44+05:30"+ execute_ conn "SET timezone TO 'America/St_Johns'" -- -3:30+ checkRoundTrips env "1935-03-30 00:00:52-03:30" initializeTable :: TestEnv -> IO () initializeTable TestEnv{..} = withTransaction conn $ do execute_ conn [sql| CREATE TEMPORARY TABLE testtime ( x serial, y timestamptz, PRIMARY KEY(x) ) |]++ let test :: ByteString -> IO () = \x -> do+ execute conn [sql|+ INSERT INTO testtime (y) VALUES (?)+ |] (Only x)+ return ()+ -- America/Chicago+ test "1883-11-18 11:59:59-05:50:36"+ test "1883-11-18 12:09:23-05:50:36"+ test "1883-11-18 12:00:00-06"+ -- Asia/Tokyo+ test "1887-12-31 23:59:59+09:18:59"+ test "1888-01-01 00:18:58+09:18:59"+ test "1888-01-01 00:00:00+09"+ -- Asia/Kathmandu+ test "1919-12-31 23:59:59+05:41:16"+ test "1919-12-31 23:48:44+05:30"+ test "1985-12-31 23:59:59+05:30"+ test "1986-01-01 00:15:00+05:45"+ -- America/St_Johns+ test "1935-03-29 23:59:59-03:30:52"+ test "1935-03-30 00:00:52-03:30"++ -- While the above special cases are probably a decent start, there+ -- are probably more that are well worth adding to ensure better+ -- coverage.+ let pop :: ByteString -> Double -> IO () = \x y -> replicateM_ numTests $ execute conn [sql| INSERT INTO testtime (y) VALUES- ('1936-01-01 00:00:00+00'::timestamptz+ ('1860-01-01 00:00:00+00'::timestamptz + ?::interval * ROUND(RANDOM() * ?)) |] (x,y) pop "1 microsecond" 6.3113904e15 pop "10 microseconds" 6.3113904e14@@ -62,10 +102,18 @@ pop "100 milliseconds" 6.3113904e10 pop "1 second" 6.3113904e9 -checkRoundTrips :: TestEnv -> IO ()-checkRoundTrips TestEnv{..} = do+checkRoundTrips :: TestEnv -> ByteString -> IO ()+checkRoundTrips TestEnv{..} limit = do yxs :: [(UTCTime, Int)] <- query_ conn [sql| SELECT y, x FROM testtime |] forM_ yxs $ \yx -> do res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx assertBool "UTCTime did not round-trip from SQL to Haskell and back" $+ res == [Only True]++ yxs :: [(ZonedTime, Int)] <- query conn [sql| + SELECT y, x FROM testtime WHERE y > ? + |] (Only limit)+ forM_ yxs $ \yx -> do+ res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx+ assertBool "ZonedTime did not round-trip from SQL to Haskell and back" $ res == [Only True]
+ test/results/malformed-input.expected view
@@ -0,0 +1,4 @@+user error (Database.PostgreSQL.Simple.Copy.putCopyEnd: failed to parse command status+Connection error: ERROR: invalid input syntax for type integer: "z"+CONTEXT: COPY copy_unique_constraint_error_test, line 3, column x: "z"+)
+ test/results/unique-constraint-violation.expected view
@@ -0,0 +1,5 @@+user error (Database.PostgreSQL.Simple.Copy.putCopyEnd: failed to parse command status+Connection error: ERROR: duplicate key value violates unique constraint "copy_unique_constraint_error_test_pkey"+DETAIL: Key (x)=(1) already exists.+CONTEXT: COPY copy_unique_constraint_error_test, line 3+)