diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -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`. diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -15,3 +15,22 @@ Manuel Gómez Michael Snoyman Adam Bergmark +Tobias Florek +Francesco Mazzoli +Chris Allen +Simon Hengel +Tom Ellis +Mike Ledger +João Cristóvão +Bardur Arantsson +Travis Staton +Sam Rijs +Janne Hellsten +Timmy Tofu +Alexey Khudyakov +Timo von Holtz +Amit Levy +Ben Gamari +Edgar Gomes Araujo +Erik Hesselink +Matvey Aksenov diff --git a/bench/Select.hs b/bench/Select.hs new file mode 100644 --- /dev/null +++ b/bench/Select.hs @@ -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 diff --git a/postgresql-simple.cabal b/postgresql-simple.cabal --- a/postgresql-simple.cabal +++ b/postgresql-simple.cabal @@ -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 -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 +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 diff --git a/src/Database/PostgreSQL/Simple.hs b/src/Database/PostgreSQL/Simple.hs --- a/src/Database/PostgreSQL/Simple.hs +++ b/src/Database/PostgreSQL/Simple.hs @@ -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 diff --git a/src/Database/PostgreSQL/Simple/Arrays.hs b/src/Database/PostgreSQL/Simple/Arrays.hs --- a/src/Database/PostgreSQL/Simple/Arrays.hs +++ b/src/Database/PostgreSQL/Simple/Arrays.hs @@ -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. diff --git a/src/Database/PostgreSQL/Simple/BuiltinTypes.hs b/src/Database/PostgreSQL/Simple/BuiltinTypes.hs deleted file mode 100644 --- a/src/Database/PostgreSQL/Simple/BuiltinTypes.hs +++ /dev/null @@ -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 --- 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" diff --git a/src/Database/PostgreSQL/Simple/Compat.hs b/src/Database/PostgreSQL/Simple/Compat.hs --- a/src/Database/PostgreSQL/Simple/Compat.hs +++ b/src/Database/PostgreSQL/Simple/Compat.hs @@ -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 diff --git a/src/Database/PostgreSQL/Simple/Copy.hs b/src/Database/PostgreSQL/Simple/Copy.hs --- a/src/Database/PostgreSQL/Simple/Copy.hs +++ b/src/Database/PostgreSQL/Simple/Copy.hs @@ -9,7 +9,7 @@ -- Stability: experimental -- -- mid-level support for COPY IN and COPY OUT. See --- for +-- 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 diff --git a/src/Database/PostgreSQL/Simple/Cursor.hs b/src/Database/PostgreSQL/Simple/Cursor.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Cursor.hs @@ -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 +-- +------------------------------------------------------------------------------ + +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' #-} diff --git a/src/Database/PostgreSQL/Simple/Errors.hs b/src/Database/PostgreSQL/Simple/Errors.hs --- a/src/Database/PostgreSQL/Simple/Errors.hs +++ b/src/Database/PostgreSQL/Simple/Errors.hs @@ -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" diff --git a/src/Database/PostgreSQL/Simple/FromField.hs b/src/Database/PostgreSQL/Simple/FromField.hs --- a/src/Database/PostgreSQL/Simple/FromField.hs +++ b/src/Database/PostgreSQL/Simple/FromField.hs @@ -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 = diff --git a/src/Database/PostgreSQL/Simple/FromRow.hs b/src/Database/PostgreSQL/Simple/FromRow.hs --- a/src/Database/PostgreSQL/Simple/FromRow.hs +++ b/src/Database/PostgreSQL/Simple/FromRow.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE RecordWildCards, FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards, FlexibleInstances, DefaultSignatures #-} + ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.FromRow @@ -27,7 +29,7 @@ ) where import Prelude hiding (null) -import Control.Applicative (Applicative(..), (<$>), (<|>), (*>)) +import Control.Applicative (Applicative(..), (<$>), (<|>), (*>), liftA2) import Control.Monad (replicateM, replicateM_) import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader @@ -45,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 diff --git a/src/Database/PostgreSQL/Simple/FromRow.hs-boot b/src/Database/PostgreSQL/Simple/FromRow.hs-boot --- a/src/Database/PostgreSQL/Simple/FromRow.hs-boot +++ b/src/Database/PostgreSQL/Simple/FromRow.hs-boot @@ -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) - diff --git a/src/Database/PostgreSQL/Simple/HStore.hs b/src/Database/PostgreSQL/Simple/HStore.hs --- a/src/Database/PostgreSQL/Simple/HStore.hs +++ b/src/Database/PostgreSQL/Simple/HStore.hs @@ -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 for more +-- See 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 --- for more +-- for more -- information. -- ------------------------------------------------------------------------------ @@ -28,6 +28,7 @@ , toBuilder , toLazyByteString , hstore + , parseHStoreList , ToHStoreText(..) , HStoreText ) where diff --git a/src/Database/PostgreSQL/Simple/HStore/Implementation.hs b/src/Database/PostgreSQL/Simple/HStore/Implementation.hs --- a/src/Database/PostgreSQL/Simple/HStore/Implementation.hs +++ b/src/Database/PostgreSQL/Simple/HStore/Implementation.hs @@ -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 diff --git a/src/Database/PostgreSQL/Simple/HStore/Internal.hs b/src/Database/PostgreSQL/Simple/HStore/Internal.hs --- a/src/Database/PostgreSQL/Simple/HStore/Internal.hs +++ b/src/Database/PostgreSQL/Simple/HStore/Internal.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} - ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.HStore.Internal diff --git a/src/Database/PostgreSQL/Simple/Internal.hs b/src/Database/PostgreSQL/Simple/Internal.hs --- a/src/Database/PostgreSQL/Simple/Internal.hs +++ b/src/Database/PostgreSQL/Simple/Internal.hs @@ -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 -- 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 --- for more information. +-- See +-- 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 +-- +-- 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 +-- 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 +-- 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 +-- +-- 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 diff --git a/src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs b/src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs @@ -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 +-- 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' #-} diff --git a/src/Database/PostgreSQL/Simple/LargeObjects.hs b/src/Database/PostgreSQL/Simple/LargeObjects.hs --- a/src/Database/PostgreSQL/Simple/LargeObjects.hs +++ b/src/Database/PostgreSQL/Simple/LargeObjects.hs @@ -7,14 +7,14 @@ -- Maintainer : leon@melding-monads.com -- -- Support for PostgreSQL's Large Objects; see --- for more +-- 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. -- diff --git a/src/Database/PostgreSQL/Simple/Newtypes.hs b/src/Database/PostgreSQL/Simple/Newtypes.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Newtypes.hs @@ -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) diff --git a/src/Database/PostgreSQL/Simple/Notification.hs b/src/Database/PostgreSQL/Simple/Notification.hs --- a/src/Database/PostgreSQL/Simple/Notification.hs +++ b/src/Database/PostgreSQL/Simple/Notification.hs @@ -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 --- for more +-- 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. -- --- +-- -- ----------------------------------------------------------------------------- @@ -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'. diff --git a/src/Database/PostgreSQL/Simple/Ok.hs b/src/Database/PostgreSQL/Simple/Ok.hs --- a/src/Database/PostgreSQL/Simple/Ok.hs +++ b/src/Database/PostgreSQL/Simple/Ok.hs @@ -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 diff --git a/src/Database/PostgreSQL/Simple/Range.hs b/src/Database/PostgreSQL/Simple/Range.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Range.hs @@ -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 +-- +------------------------------------------------------------------------------ + +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 #-} diff --git a/src/Database/PostgreSQL/Simple/SqlQQ.hs b/src/Database/PostgreSQL/Simple/SqlQQ.hs --- a/src/Database/PostgreSQL/Simple/SqlQQ.hs +++ b/src/Database/PostgreSQL/Simple/SqlQQ.hs @@ -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" diff --git a/src/Database/PostgreSQL/Simple/Time.hs b/src/Database/PostgreSQL/Simple/Time.hs --- a/src/Database/PostgreSQL/Simple/Time.hs +++ b/src/Database/PostgreSQL/Simple/Time.hs @@ -1,54 +1,217 @@ ------------------------------------------------------------------------------- --- | --- Module: Database.PostgreSQL.Simple.Time --- Copyright: (c) 2012 Leon P Smith --- License: BSD3 --- Maintainer: Leon P Smith --- 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 --- , --- and zoneinfo at . --- ------------------------------------------------------------------------------- +{- | +Module: Database.PostgreSQL.Simple.Time +Copyright: (c) 2012-2015 Leon P Smith +License: BSD3 +Maintainer: Leon P Smith +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 , +and the IANA time zone database at . + +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 diff --git a/src/Database/PostgreSQL/Simple/Time/Implementation.hs b/src/Database/PostgreSQL/Simple/Time/Implementation.hs --- a/src/Database/PostgreSQL/Simple/Time/Implementation.hs +++ b/src/Database/PostgreSQL/Simple/Time/Implementation.hs @@ -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 -- 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 diff --git a/src/Database/PostgreSQL/Simple/Time/Internal.hs b/src/Database/PostgreSQL/Simple/Time/Internal.hs --- a/src/Database/PostgreSQL/Simple/Time/Internal.hs +++ b/src/Database/PostgreSQL/Simple/Time/Internal.hs @@ -19,6 +19,9 @@ , getZonedTimestamp , getUTCTime , getUTCTimestamp + , TimeZoneHMS + , getTimeZoneHMS + , localToUTCTimeOfDayHMS ) where import Database.PostgreSQL.Simple.Time.Implementation diff --git a/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs b/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs @@ -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 +-- 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 diff --git a/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs b/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs @@ -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 +-- 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 diff --git a/src/Database/PostgreSQL/Simple/ToField.hs b/src/Database/PostgreSQL/Simple/ToField.hs --- a/src/Database/PostgreSQL/Simple/ToField.hs +++ b/src/Database/PostgreSQL/Simple/ToField.hs @@ -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 diff --git a/src/Database/PostgreSQL/Simple/ToField.hs-boot b/src/Database/PostgreSQL/Simple/ToField.hs-boot --- a/src/Database/PostgreSQL/Simple/ToField.hs-boot +++ b/src/Database/PostgreSQL/Simple/ToField.hs-boot @@ -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 diff --git a/src/Database/PostgreSQL/Simple/ToRow.hs b/src/Database/PostgreSQL/Simple/ToRow.hs --- a/src/Database/PostgreSQL/Simple/ToRow.hs +++ b/src/Database/PostgreSQL/Simple/ToRow.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.ToRow @@ -22,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 _ = [] diff --git a/src/Database/PostgreSQL/Simple/ToRow.hs-boot b/src/Database/PostgreSQL/Simple/ToRow.hs-boot --- a/src/Database/PostgreSQL/Simple/ToRow.hs-boot +++ b/src/Database/PostgreSQL/Simple/ToRow.hs-boot @@ -1,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) diff --git a/src/Database/PostgreSQL/Simple/Transaction.hs b/src/Database/PostgreSQL/Simple/Transaction.hs --- a/src/Database/PostgreSQL/Simple/Transaction.hs +++ b/src/Database/PostgreSQL/Simple/Transaction.hs @@ -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 +-- +------------------------------------------------------------------------------ + 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 +-- See -- 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 +-- See withSavepoint :: Connection -> IO a -> IO a withSavepoint conn body = mask $ \restore -> do diff --git a/src/Database/PostgreSQL/Simple/TypeInfo.hs b/src/Database/PostgreSQL/Simple/TypeInfo.hs --- a/src/Database/PostgreSQL/Simple/TypeInfo.hs +++ b/src/Database/PostgreSQL/Simple/TypeInfo.hs @@ -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 diff --git a/src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs b/src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs --- a/src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs +++ b/src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs @@ -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) diff --git a/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs b/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs --- a/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs +++ b/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs @@ -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 #-} diff --git a/src/Database/PostgreSQL/Simple/Types.hs b/src/Database/PostgreSQL/Simple/Types.hs --- a/src/Database/PostgreSQL/Simple/Types.hs +++ b/src/Database/PostgreSQL/Simple/Types.hs @@ -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 for +-- more information. +data Values a = Values [QualifiedIdentifier] [a] deriving (Eq, Ord, Show, Read, Typeable) diff --git a/src/Database/PostgreSQL/Simple/Vector.hs b/src/Database/PostgreSQL/Simple/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Vector.hs @@ -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 diff --git a/src/Database/PostgreSQL/Simple/Vector/Unboxed.hs b/src/Database/PostgreSQL/Simple/Vector/Unboxed.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Vector/Unboxed.hs @@ -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 diff --git a/test/Common.hs b/test/Common.hs --- a/test/Common.hs +++ b/test/Common.hs @@ -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 diff --git a/test/Exception.hs b/test/Exception.hs new file mode 100644 --- /dev/null +++ b/test/Exception.hs @@ -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 diff --git a/test/Inspection.hs b/test/Inspection.hs new file mode 100644 --- /dev/null +++ b/test/Inspection.hs @@ -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 + ] diff --git a/test/Interval.hs b/test/Interval.hs new file mode 100644 --- /dev/null +++ b/test/Interval.hs @@ -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 + diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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" + ] diff --git a/test/Notify.hs b/test/Notify.hs --- a/test/Notify.hs +++ b/test/Notify.hs @@ -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" diff --git a/test/Serializable.hs b/test/Serializable.hs --- a/test/Serializable.hs +++ b/test/Serializable.hs @@ -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 diff --git a/test/Time.hs b/test/Time.hs --- a/test/Time.hs +++ b/test/Time.hs @@ -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] diff --git a/test/results/malformed-input.expected b/test/results/malformed-input.expected new file mode 100644 --- /dev/null +++ b/test/results/malformed-input.expected @@ -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" +) diff --git a/test/results/unique-constraint-violation.expected b/test/results/unique-constraint-violation.expected new file mode 100644 --- /dev/null +++ b/test/results/unique-constraint-violation.expected @@ -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 +)