postgresql-simple-0.6.5.1/0000755000000000000000000000000007346545000013544 5ustar0000000000000000postgresql-simple-0.6.5.1/CHANGES.md0000644000000000000000000006774707346545000015163 0ustar0000000000000000### 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`. postgresql-simple-0.6.5.1/CONTRIBUTORS0000644000000000000000000000244507346545000015431 0ustar0000000000000000Bryan O'Sullivan Leon P Smith Felipe Lessa Ozgun Ataman Joey Adams Rekado Leonid Onokhov Bas van Dijk Jason Dusek Jeff Chu Oliver Charles Simon Meier Alexey Uimanov Doug Beardsley 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 postgresql-simple-0.6.5.1/LICENSE0000644000000000000000000000565307346545000014562 0ustar0000000000000000Copyright (c) 2011, Leon P Smith All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Leon P Smith nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Copyright (c) 2011, MailRank, Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. postgresql-simple-0.6.5.1/Setup.hs0000644000000000000000000000005607346545000015201 0ustar0000000000000000import Distribution.Simple main = defaultMain postgresql-simple-0.6.5.1/bench/0000755000000000000000000000000007346545000014623 5ustar0000000000000000postgresql-simple-0.6.5.1/bench/Select.hs0000644000000000000000000000211207346545000016372 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Main where import Database.PostgreSQL.Simple import qualified Database.PostgreSQL.Simple.Vector as V import qualified Database.PostgreSQL.Simple.Vector.Unboxed as VU import System.Environment (getArgs) import Data.Foldable (Foldable, foldl') import qualified Data.Vector.Unboxed as VU main :: IO () main = do args <- getArgs conn <- connectPostgreSQL "" case args of ("vector":_) -> do result <- V.query_ conn "SELECT * FROM generate_series(1, 10000000);" print (process result) ("unboxed":_) -> do -- dummy column result <- VU.query_ conn "SELECT (NULL :: VOID), * FROM generate_series(1, 10000000);" print (process' result) _ -> do result <- query_ conn "SELECT * FROM generate_series(1, 10000000);" print (process result) process :: Foldable f => f (Only Int) -> Int process = foldl' (\x (Only y) -> max x y) 0 process' :: VU.Vector ((), Int) -> Int process' = VU.foldl' (\x (_, y) -> max x y) 0 postgresql-simple-0.6.5.1/postgresql-simple.cabal0000644000000000000000000001224007346545000020221 0ustar0000000000000000cabal-version: 1.12 name: postgresql-simple version: 0.6.5.1 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: 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: CHANGES.md CONTRIBUTORS test/results/malformed-input.expected test/results/unique-constraint-violation.expected tested-with: GHC ==7.6.3 || ==7.8.4 || ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.5 || ==9.6.2 library default-language: Haskell2010 hs-source-dirs: src exposed-modules: Database.PostgreSQL.Simple Database.PostgreSQL.Simple.Arrays Database.PostgreSQL.Simple.Copy Database.PostgreSQL.Simple.Cursor Database.PostgreSQL.Simple.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 -- 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 -- GHC bundled libs build-depends: base >=4.6.0.0 && <4.19 , bytestring >=0.10.0.0 && <0.12 , containers >=0.5.0.0 && <0.7 , template-haskell >=2.8.0.0 && <2.21 , text >=1.2.3.0 && <1.3 || >=2.0 && <2.1 , time-compat >=1.9.5 && <1.12 , transformers >=0.3.0.0 && <0.7 -- Other dependencies build-depends: aeson >=1.4.1.0 && <1.6 || >=2.0.0.0 && <2.3 , attoparsec >=0.13.2.2 && <0.15 , bytestring-builder >=0.10.8.1.0 && <0.11 , case-insensitive >=1.2.0.11 && <1.3 , hashable >=1.2.7.0 && <1.5 , Only >=0.1 && <0.1.1 , postgresql-libpq >=0.9.4.3 && <0.10 , scientific >=0.3.6.2 && <0.4 , uuid-types >=1.0.3 && <1.1 , vector >=0.12.0.1 && <0.14 if !impl(ghc >=8.0) build-depends: fail >=4.9.0.0 && <4.10 , semigroups >=0.18.5 && <0.21 if !impl(ghc >=7.6) build-depends: ghc-prim default-extensions: BangPatterns DoAndIfThenElse OverloadedStrings TypeOperators ViewPatterns ghc-options: -Wall -fno-warn-name-shadowing source-repository head type: git location: http://github.com/haskellari/postgresql-simple source-repository this type: git location: http://github.com/haskellari/postgresql-simple tag: v0.6.3 test-suite inspection if !impl(ghc >=8.0) buildable: False 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.6 , postgresql-libpq , postgresql-simple , tasty , tasty-hunit test-suite test default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs other-modules: Common Notify Serializable Time Interval ghc-options: -threaded ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind default-extensions: NamedFieldPuns OverloadedStrings PatternGuards Rank2Types RecordWildCards ScopedTypeVariables build-depends: aeson , base , base16-bytestring , bytestring , case-insensitive , containers , cryptohash-md5 >=0.11.100.1 && <0.12 , filepath , HUnit , postgresql-simple , tasty , tasty-golden , tasty-hunit , text , time-compat , vector if !impl(ghc >=7.6) build-depends: ghc-prim benchmark select default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: bench main-is: Select.hs build-depends: base , postgresql-simple , vector postgresql-simple-0.6.5.1/src/Database/PostgreSQL/0000755000000000000000000000000007346545000020042 5ustar0000000000000000postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple.hs0000644000000000000000000010135407346545000021633 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple -- Copyright: (c) 2011 MailRank, Inc. -- (c) 2011-2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- A mid-level client library for the PostgreSQL database, aimed at ease of -- use and high performance. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple ( -- * Writing queries -- $use -- ** The Query type -- $querytype -- ** Parameter substitution -- $subst -- *** Type inference -- $inference -- ** Substituting a single parameter -- $only_param -- ** Representing a list of values -- $in -- ** Modifying multiple rows at once -- $many -- ** @RETURNING@: modifications that return results -- $returning -- * Extracting results -- $result -- ** Handling null values -- $null -- ** Type conversions -- $types -- * Types Connection , Query , ToRow , FromRow , In(..) , Binary(..) , Only(..) , (:.)(..) -- ** Exceptions , SqlError(..) , PQ.ExecStatus(..) , FormatError(..) , QueryError(..) , ResultError(..) -- * Connection management , Base.connectPostgreSQL , Base.close , Base.connect , Base.withConnect , Base.ConnectInfo(..) , Base.defaultConnectInfo , Base.postgreSQLConnectionString -- * Queries that return results , query , query_ -- ** Queries taking parser as argument , queryWith , queryWith_ -- * Queries that stream results , FoldOptions(..) , FetchQuantity(..) , defaultFoldOptions , fold , foldWithOptions , fold_ , foldWithOptions_ , 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_ , executeMany -- , Base.insertID -- * Transaction handling , withTransaction , withSavepoint -- , Base.autocommit , begin , commit , rollback -- * Helper functions , formatMany , formatQuery ) where import Data.ByteString.Builder (Builder, byteString, char8) import Control.Applicative ((<$>)) import Control.Exception as E import Data.ByteString (ByteString) import Data.Int (Int64) import Data.List (intersperse) import Data.Monoid (mconcat) 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.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 qualified Database.PostgreSQL.LibPQ as PQ import qualified Data.ByteString.Char8 as B -- | Format a query string. -- -- This function is exposed to help with debugging and logging. Do not -- use it to prepare queries for execution. -- -- String parameters are escaped according to the character set in use -- on the 'Connection'. -- -- Throws 'FormatError' if the query string could not be formatted -- correctly. formatQuery :: ToRow q => Connection -> Query -> q -> IO ByteString formatQuery conn q@(Query template) qs | null xs && '?' `B.notElem` template = return template | otherwise = toByteString <$> buildQuery conn q template xs where xs = toRow qs -- | Format a query string with a variable number of rows. -- -- This function is exposed to help with debugging and logging. Do not -- use it to prepare queries for execution. -- -- The query string must contain exactly one substitution group, -- identified by the SQL keyword \"@VALUES@\" (case insensitive) -- followed by an \"@(@\" character, a series of one or more \"@?@\" -- characters separated by commas, and a \"@)@\" character. White -- space in a substitution group is permitted. -- -- Throws 'FormatError' if the query string could not be formatted -- correctly. formatMany :: (ToRow q) => Connection -> Query -> [q] -> IO ByteString formatMany _ q [] = fmtError "no rows supplied" q [] formatMany conn q@(Query template) qs = do case parseTemplate template of Just (before, qbits, after) -> do bs <- mapM (buildQuery conn q qbits . toRow) qs 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@, -- following this grammar: -- -- start: ^ before qbits after $ -- before: ([^?]* [^?\w])? 'VALUES' \s* -- qbits: '(' \s* '?' \s* (',' \s* '?' \s*)* ')' -- after: [^?]* -- -- \s: [ \t\n\r\f] -- \w: [A-Z] | [a-z] | [\x80-\xFF] | '_' | '$' | [0-9] -- -- This would be much more concise with some sort of regex engine. -- 'formatMany' used to use pcre-light instead of this hand-written parser, -- but pcre is a hassle to install on Windows. parseTemplate :: ByteString -> Maybe (ByteString, ByteString, ByteString) parseTemplate template = -- Convert input string to uppercase, to facilitate searching. search $ B.map toUpper_ascii template where -- Search for the next occurrence of "VALUES" search bs = case B.breakSubstring "VALUES" bs of (x, y) -- If "VALUES" is not present in the string, or any '?' characters -- were encountered prior to it, fail. | B.null y || ('?' `B.elem` x) -> Nothing -- If "VALUES" is preceded by an identifier character (a.k.a. \w), -- try the next occurrence. | not (B.null x) && isIdent (B.last x) -> search $ B.drop 6 y -- Otherwise, we have a legitimate "VALUES" token. | otherwise -> parseQueryBits $ skipSpace $ B.drop 6 y -- Parse '(' \s* '?' \s* . If this doesn't match -- (and we don't consume a '?'), look for another "VALUES". -- -- qb points to the open paren (if present), meaning it points to the -- beginning of the "qbits" production described above. This is why we -- pass it down to finishQueryBits. parseQueryBits qb | Just ('(', skipSpace -> bs1) <- B.uncons qb , Just ('?', skipSpace -> bs2) <- B.uncons bs1 = finishQueryBits qb bs2 | otherwise = search qb -- Parse (',' \s* '?' \s*)* ')' [^?]* . -- -- Since we've already consumed at least one '?', there's no turning back. -- The parse has to succeed here, or the whole thing fails -- (because we don't allow '?' to appear outside of the VALUES list). finishQueryBits qb bs0 | Just (')', bs1) <- B.uncons bs0 = if '?' `B.elem` bs1 then Nothing else Just $ slice3 template qb bs1 | Just (',', skipSpace -> bs1) <- B.uncons bs0 , Just ('?', skipSpace -> bs2) <- B.uncons bs1 = finishQueryBits qb bs2 | otherwise = Nothing -- Slice a string into three pieces, given the start offset of the second -- and third pieces. Each "offset" is actually a tail of the uppercase -- version of the template string. Its length is used to infer the offset. -- -- It is important to note that we only slice the original template. -- We don't want our all-caps trick messing up the actual query string. slice3 source p1 p2 = (s1, s2, source'') where (s1, source') = B.splitAt (B.length source - B.length p1) source (s2, source'') = B.splitAt (B.length p1 - B.length p2) source' toUpper_ascii c | c >= 'a' && c <= 'z' = toEnum (fromEnum c - 32) | otherwise = c -- Based on the definition of {ident_cont} in src/backend/parser/scan.l -- in the PostgreSQL source. No need to check [a-z], since we converted -- the whole string to uppercase. isIdent c = (c >= '0' && c <= '9') || (c >= 'A' && c <= 'Z') || (c >= '\x80' && c <= '\xFF') || c == '_' || c == '$' -- Based on {space} in scan.l isSpace_ascii c = (c == ' ') || (c >= '\t' && c <= '\r') skipSpace = B.dropWhile isSpace_ascii buildQuery :: Connection -> Query -> ByteString -> [Action] -> IO Builder buildQuery conn q template xs = zipParams (split template) <$> mapM (buildAction conn q xs) xs where split s = -- 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 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, 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 finishExecute conn template result -- | Execute a multi-row @INSERT@, @UPDATE@, or other SQL query that is not -- expected to return results. -- -- 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, 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 result <- exec conn =<< formatMany conn q qs finishExecute conn q result -- | Execute @INSERT ... RETURNING@, @UPDATE ... RETURNING@, or other SQL -- query that accepts multi-row input and is expected to return results. -- Note that it is possible to write -- @'query' conn "INSERT ... RETURNING ..." ...@ -- 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 = 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 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 -- function returns. -- -- When processing large results, this function will consume a lot of -- client-side memory. Consider using 'fold' instead. -- -- Exceptions that may be thrown: -- -- * 'FormatError': the query string could not be formatted correctly. -- -- * 'QueryError': the result contains no columns (i.e. you should be -- 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 -- | A version of 'query' that does not perform query substitution. query_ :: (FromRow r) => Connection -> Query -> IO [r] query_ = queryWith_ fromRow -- | A version of 'query' taking parser as argument queryWith :: ToRow q => RowParser r -> Connection -> Query -> q -> IO [r] queryWith parser conn template qs = do result <- exec conn =<< formatQuery conn template qs finishQueryWith parser conn template result -- | A version of 'query_' taking parser as argument queryWith_ :: RowParser r -> Connection -> Query -> IO [r] queryWith_ parser conn q@(Query que) = do result <- exec conn que finishQueryWith parser conn q result -- | Perform a @SELECT@ or other SQL query that is expected to return -- results. Results are streamed incrementally from the server, and -- consumed via a left fold. -- -- When dealing with small results, it may be simpler (and perhaps -- faster) to use 'query' instead. -- -- 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. -- -- * 'QueryError': the result contains no columns (i.e. you should be -- 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 -> params -> a -> (a -> row -> IO a) -> 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 data FoldOptions = FoldOptions { fetchQuantity :: !FetchQuantity, 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 -> Query -> params -> a -> (a -> row -> IO a) -> IO a 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 parser conn template (Query q) a f -- | A version of 'fold' that does not perform query substitution. fold_ :: (FromRow r) => Connection -> Query -- ^ Query. -> a -- ^ Initial state for result consumer. -> (a -> r -> IO a) -- ^ Result consumer. -> 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 -> Connection -> Query -- ^ Query. -> a -- ^ Initial state for result consumer. -> (a -> r -> IO a) -- ^ Result consumer. -> IO a foldWithOptions_ opts conn query' a f = doFold opts fromRow conn query' query' a f -- | 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 :: FoldOptions -> RowParser row -> Connection -> Query -> Query -> a -> (a -> row -> IO a) -> IO a doFold FoldOptions{..} parser conn _template q a0 f = do stat <- withConnection conn PQ.transactionStatus case stat of PQ.TransIdle -> withTransactionMode transactionMode conn go PQ.TransInTrans -> go PQ.TransActive -> fail "foldWithOpts FIXME: PQ.TransActive" -- This _shouldn't_ occur in the current incarnation of -- the library, as we aren't using libpq asynchronously. -- However, it could occur in future incarnations of -- this library or if client code uses the Internal module -- to use raw libpq commands on postgresql-simple connections. PQ.TransInError -> fail "foldWithOpts FIXME: PQ.TransInError" -- This should be turned into a better error message. -- It is probably a bad idea to automatically roll -- back the transaction and start another. PQ.TransUnknown -> fail "foldWithOpts FIXME: PQ.TransUnknown" -- Not sure what this means. where declare = declareCursor conn q fetch cursor a = foldForwardWithParser cursor parser chunkSize f a 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 -- still isn't a perfect solution, given that common types (e.g. text) -- are of highly variable size. -- A refinement of this technique is to pick this number adaptively -- as results are read in from the database. chunkSize = case fetchQuantity of Automatic -> 256 Fixed n -> n -- | A version of 'fold' that does not transform a state value. forEach :: (ToRow q, FromRow r) => Connection -> Query -- ^ Query template. -> q -- ^ Query parameters. -> (r -> IO ()) -- ^ Result consumer. -> IO () 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_ = forEachWith_ fromRow {-# INLINE forEach_ #-} forEachWith_ :: RowParser r -> Connection -> Query -> (r -> IO ()) -> IO () forEachWith_ parser conn template = foldWith_ parser conn template () . const {-# INLINE forEachWith_ #-} -- $use -- -- SQL-based applications are somewhat notorious for their -- susceptibility to attacks through the injection of maliciously -- crafted data. The primary reason for widespread vulnerability to -- SQL injections is that many applications are sloppy in handling -- user data when constructing SQL queries. -- -- This library provides a 'Query' type and a parameter substitution -- facility to address both ease of use and security. -- $querytype -- -- A 'Query' is a @newtype@-wrapped 'ByteString'. It intentionally -- exposes a tiny API that is not compatible with the 'ByteString' -- API; this makes it difficult to construct queries from fragments of -- strings. The 'query' and 'execute' functions require queries to be -- of type 'Query'. -- -- To most easily construct a query, enable GHC's @OverloadedStrings@ -- language extension and write your query as a normal literal string. -- -- > {-# LANGUAGE OverloadedStrings #-} -- > -- > import Database.PostgreSQL.Simple -- > -- > hello :: IO Int -- > hello = do -- > 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. -- $subst -- -- Since applications need to be able to construct queries with -- parameters that change, this library provides a query substitution -- capability. -- -- The 'Query' template accepted by 'query' and 'execute' can contain -- any number of \"@?@\" characters. Both 'query' and 'execute' -- accept a third argument, typically a tuple. When constructing the -- real query to execute, these functions replace the first \"@?@\" in -- the template with the first element of the tuple, the second -- \"@?@\" with the second element, and so on. If necessary, each -- tuple element will be quoted and escaped prior to substitution; -- this defeats the single most common injection vector for malicious -- data. -- -- For example, given the following 'Query' template: -- -- > select * from user where first_name = ? and age > ? -- -- And a tuple of this form: -- -- > ("Boris" :: String, 37 :: Int) -- -- The query to be executed will look like this after substitution: -- -- > select * from user where first_name = 'Boris' and age > 37 -- -- If there is a mismatch between the number of \"@?@\" characters in -- your template and the number of elements in your tuple, a -- 'FormatError' will be thrown. -- -- Note that the substitution functions do not attempt to parse or -- validate your query. It's up to you to write syntactically valid -- SQL, and to ensure that each \"@?@\" in your query template is -- matched with the right tuple element. -- $inference -- -- Automated type inference means that you will often be able to avoid -- supplying explicit type signatures for the elements of a tuple. -- However, sometimes the compiler will not be able to infer your -- types. Consider a case where you write a numeric literal in a -- parameter tuple: -- -- > query conn "select ? + ?" (40,2) -- -- The above query will be rejected by the compiler, because it does -- not know the specific numeric types of the literals @40@ and @2@. -- This is easily fixed: -- -- > query conn "select ? + ?" (40 :: Double, 2 :: Double) -- -- 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 or a single-column result, -- what should you do? -- -- The obvious approach would appear to be something like this: -- -- > instance (ToField a) => ToRow a where -- > ... -- -- Unfortunately, this wreaks havoc with type inference, so we take a -- different tack. To represent a single value @val@ as a parameter, write -- a singleton list @[val]@, use 'Just' @val@, or use 'Only' @val@. -- -- Here's an example using a singleton list: -- -- > 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 -- -- Suppose you want to write a query using an @IN@ clause: -- -- > select * from users where first_name in ('Anna', 'Boris', 'Carla') -- -- In such cases, it's common for both the elements and length of the -- list after the @IN@ keyword to vary from query to query. -- -- To address this case, use the 'In' type wrapper, and use a single -- \"@?@\" character to represent the list. Omit the parentheses -- around the list; these will be added for you. -- -- Here's an example: -- -- > query conn "select * from users where first_name in ?" $ -- > 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 -- syntactically valid. -- $many -- -- If you know that you have many rows of data to insert into a table, -- it is much more efficient to perform all the insertions in a single -- multi-row @INSERT@ statement than individually. -- -- The 'executeMany' function is intended specifically for helping -- with multi-row @INSERT@ and @UPDATE@ statements. Its rules for -- query substitution are different than those for 'execute'. -- -- What 'executeMany' searches for in your 'Query' template is a -- single substring of the form: -- -- > values (?,?,?) -- -- The rules are as follows: -- -- * The keyword @VALUES@ is matched case insensitively. -- -- * There must be no other \"@?@\" characters anywhere in your -- template. -- -- * There must be one or more \"@?@\" in the parentheses. -- -- * Extra white space is fine. -- -- The last argument to 'executeMany' is a list of parameter -- tuples. These will be substituted into the query where the @(?,?)@ -- string appears, in a form suitable for use in a multi-row @INSERT@ -- or @UPDATE@. -- -- Here is an example: -- -- > executeMany conn -- > "insert into users (first_name,last_name) values (?,?)" -- > [("Boris","Karloff"),("Ed","Wood")] -- -- The query that will be executed here will look like this -- (reformatted for tidiness): -- -- > insert into users (first_name,last_name) values -- > ('Boris','Karloff'),('Ed','Wood') -- $returning -- -- PostgreSQL supports returning values from data manipulation statements -- such as @INSERT@ and @UPDATE@. You can use these statements by -- using 'query' instead of 'execute'. For multi-tuple inserts, -- use 'returning' instead of 'executeMany'. -- -- For example, were there an auto-incrementing @id@ column and -- timestamp column @t@ that defaulted to the present time for the -- @sales@ table, then the following query would insert two new -- sales records and also return their new @id@s and timestamps. -- -- > let q = "insert into sales (amount, label) values (?,?) returning id, t" -- > xs :: [(Int, UTCTime)] <- query conn q (15,"Sawdust") -- > ys :: [(Int, UTCTime)] <- returning conn q [(20,"Chips"),(300,"Wood")] -- $result -- -- The 'query' and 'query_' functions return a list of values in the -- 'FromRow' typeclass. This class performs automatic extraction -- and type conversion of rows from a query result. -- -- Here is a simple example of how to extract results: -- -- > import qualified Data.Text as Text -- > -- > xs <- query_ conn "select name,age from users" -- > forM_ xs $ \(name,age) -> -- > putStrLn $ Text.unpack name ++ " is " ++ show (age :: Int) -- -- Notice two important details about this code: -- -- * The number of columns we ask for in the query template must -- exactly match the number of elements we specify in a row of the -- result tuple. If they do not match, a 'ResultError' exception -- will be thrown. -- -- * Sometimes, the compiler needs our help in specifying types. It -- can infer that @name@ must be a 'Text', due to our use of the -- @unpack@ function. However, we have to tell it the type of @age@, -- as it has no other information to determine the exact type. -- $null -- -- The type of a result tuple will look something like this: -- -- > (Text, Int, Int) -- -- Although SQL can accommodate @NULL@ as a value for any of these -- types, Haskell cannot. If your result contains columns that may be -- @NULL@, be sure that you use 'Maybe' in those positions of your -- tuple. -- -- > (Text, Maybe Int, Int) -- -- If 'query' encounters a @NULL@ in a row where the corresponding -- Haskell type is not 'Maybe', it will throw a 'ResultError' -- exception. -- $only_result -- -- To specify that a query returns a single-column result, use the -- 'Only' type. -- -- > xs <- query_ conn "select id from users" -- > forM_ xs $ \(Only dbid) -> {- ... -} -- $types -- -- Conversion of SQL values to Haskell values is somewhat -- permissive. Here are the rules. -- -- * For numeric types, any Haskell type that can accurately represent -- 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 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 -- @BIGINT@ column will be considered incompatible with a Haskell -- 'Int16', even if it contains the value @1@. -- -- * If a numeric incompatibility is found, 'query' will throw a -- 'ResultError'. -- -- * The 'String' and 'Text' types are assumed to be encoded as -- UTF-8. If you use some other encoding, decoding may fail or give -- wrong results. In such cases, write a @newtype@ wrapper and a -- custom 'Result' instance to handle your encoding. postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple.hs-boot0000644000000000000000000000115707346545000022574 0ustar0000000000000000module Database.PostgreSQL.Simple ( Connection , Query , query , query_ , execute , execute_ , executeMany ) where import Data.Int(Int64) import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Types import {-# SOURCE #-} Database.PostgreSQL.Simple.FromRow import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r] query_ :: FromRow r => Connection -> Query -> IO [r] execute :: ToRow q => Connection -> Query -> q -> IO Int64 executeMany :: ToRow q => Connection -> Query -> [q] -> IO Int64 postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/0000755000000000000000000000000007346545000021273 5ustar0000000000000000postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Arrays.hs0000644000000000000000000000665207346545000023101 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Arrays -- Copyright: (c) 2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- A Postgres array parser and pretty-printer. ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.Arrays where import Control.Applicative (Applicative(..), Alternative(..), (<$>)) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Monoid import Data.Attoparsec.ByteString.Char8 -- | Parse one of three primitive field formats: array, quoted and plain. arrayFormat :: Char -> Parser ArrayFormat arrayFormat delim = Array <$> array delim <|> Plain <$> plain delim <|> Quoted <$> quoted data ArrayFormat = Array [ArrayFormat] | Plain ByteString | Quoted ByteString deriving (Eq, Show, Ord) array :: Char -> Parser [ArrayFormat] array delim = char '{' *> option [] (arrays <|> strings) <* char '}' where strings = sepBy1 (Quoted <$> quoted <|> Plain <$> plain delim) (char delim) arrays = sepBy1 (Array <$> array delim) (char ',') -- NB: Arrays seem to always be delimited by commas. -- | Recognizes a quoted string. quoted :: Parser ByteString quoted = char '"' *> option "" contents <* char '"' where esc' = char '\\' *> (char '\\' <|> char '"') unQ = takeWhile1 (notInClass "\"\\") contents = mconcat <$> many (unQ <|> B.singleton <$> esc') -- | Recognizes a plain string literal, not containing quotes or brackets and -- not containing the delimiter character. plain :: Char -> Parser ByteString plain delim = takeWhile1 (notInClass (delim:"\"{}")) -- Mutually recursive 'fmt' and 'delimit' separate out value formatting -- from the subtleties of delimiting. -- | Format an array format item, using the delimiter character if the item is -- itself an array. fmt :: Char -> ArrayFormat -> ByteString fmt = fmt' False -- | Format a list of array format items, inserting the appropriate delimiter -- between them. When the items are arrays, they will be delimited with -- commas; otherwise, they are delimited with the passed-in-delimiter. delimit :: Char -> [ArrayFormat] -> ByteString delimit _ [] = "" delimit c [x] = fmt' True c x delimit c (x:y:z) = (fmt' True c x `B.snoc` c') `mappend` delimit c (y:z) where c' | Array _ <- x = ',' | otherwise = c -- | Format an array format item, using the delimiter character if the item is -- itself an array, optionally applying quoting rules. Creates copies for -- safety when used in 'FromField' instances. fmt' :: Bool -> Char -> ArrayFormat -> ByteString fmt' quoting c x = case x of Array items -> '{' `B.cons` (delimit c items `B.snoc` '}') Plain bytes -> B.copy bytes Quoted q | quoting -> '"' `B.cons` (esc q `B.snoc` '"') | otherwise -> B.copy q -- NB: The 'snoc' and 'cons' functions always copy. -- | Escape a string according to Postgres double-quoted string format. esc :: ByteString -> ByteString esc = B.concatMap f where f '"' = "\\\"" f '\\' = "\\\\" f c = B.singleton c -- TODO: Implement easy performance improvements with unfoldr. postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Compat.hs0000644000000000000000000000447407346545000023063 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | This is a module of its own, partly because it uses the CPP extension, -- which doesn't play well with backslash-broken string literals. module Database.PostgreSQL.Simple.Compat ( mask , (<>) , unsafeDupablePerformIO , toByteString , scientificBuilder , toPico , fromPico ) where import qualified Control.Exception as E import Data.Monoid import Data.ByteString (ByteString) #if MIN_VERSION_bytestring(0,10,0) import Data.ByteString.Lazy (toStrict) #else import qualified Data.ByteString as B import Data.ByteString.Lazy (toChunks) #endif import Data.ByteString.Builder (Builder, toLazyByteString) #if MIN_VERSION_scientific(0,3,0) import Data.Text.Lazy.Builder.Scientific (scientificBuilder) #else import Data.Scientific (scientificBuilder) #endif #if __GLASGOW_HASKELL__ >= 702 import System.IO.Unsafe (unsafeDupablePerformIO) #elif __GLASGOW_HASKELL__ >= 611 import GHC.IO (unsafeDupablePerformIO) #else import GHC.IOBase (unsafeDupablePerformIO) #endif import Data.Fixed (Pico) #if MIN_VERSION_base(4,7,0) import Data.Fixed (Fixed(MkFixed)) #else import Unsafe.Coerce (unsafeCoerce) #endif -- | Like 'E.mask', but backported to base before version 4.3.0. -- -- Note that the restore callback is monomorphic, unlike in 'E.mask'. This -- could be fixed by changing the type signature, but it would require us to -- enable the RankNTypes extension (since 'E.mask' has a rank-3 type). The -- 'withTransactionMode' function calls the restore callback only once, so we -- don't need that polymorphism. mask :: ((IO a -> IO a) -> IO b) -> IO b #if MIN_VERSION_base(4,3,0) mask io = E.mask $ \restore -> io restore #else mask io = do b <- E.blocked E.block $ io $ \m -> if b then m else E.unblock m #endif {-# INLINE mask #-} #if !MIN_VERSION_base(4,5,0) infixr 6 <> (<>) :: Monoid m => m -> m -> m (<>) = mappend {-# INLINE (<>) #-} #endif toByteString :: Builder -> ByteString #if MIN_VERSION_bytestring(0,10,0) toByteString x = toStrict (toLazyByteString x) #else toByteString x = B.concat (toChunks (toLazyByteString x)) #endif #if MIN_VERSION_base(4,7,0) toPico :: Integer -> Pico toPico = MkFixed fromPico :: Pico -> Integer fromPico (MkFixed i) = i #else toPico :: Integer -> Pico toPico = unsafeCoerce fromPico :: Pico -> Integer fromPico = unsafeCoerce #endif postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Copy.hs0000644000000000000000000002454107346545000022547 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Copy -- Copyright: (c) 2013 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- mid-level support for COPY IN and COPY OUT. See -- for -- more information. -- -- To use this binding, first call 'copy' with an appropriate -- query as documented in the link above. Then, in the case of a -- @COPY TO STDOUT@ query, call 'getCopyData' repeatedly until it -- returns 'CopyOutDone'. In the case of a @COPY FROM STDIN@ -- query, call 'putCopyData' repeatedly and then finish by calling -- either 'putCopyEnd' to proceed or 'putCopyError' to abort. -- -- You cannot issue another query on the same connection while a copy -- is ongoing; this will result in an exception. It is harmless to -- concurrently call @getNotification@ on a connection while it is in -- a @CopyIn@ or @CopyOut@ state, however be aware that current versions -- of the PostgreSQL backend will not deliver notifications to a client -- while a transaction is ongoing. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.Copy ( copy , copy_ , CopyOutResult(..) , foldCopyData , getCopyData , putCopyData , putCopyEnd , putCopyError ) where import Control.Applicative import Control.Concurrent import Control.Exception ( throwIO ) import qualified Data.Attoparsec.ByteString.Char8 as P import Data.Typeable(Typeable) import Data.Int(Int64) import qualified Data.ByteString.Char8 as B import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple.Types 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 substitution. copy :: ( ToRow params ) => Connection -> Query -> params -> IO () copy conn template qs = do q <- formatQuery conn template qs doCopy "Database.PostgreSQL.Simple.Copy.copy" conn template q -- | 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. Does not perform parameter subsitution. copy_ :: Connection -> Query -> IO () copy_ conn (Query q) = do doCopy "Database.PostgreSQL.Simple.Copy.copy_" conn (Query q) q doCopy :: B.ByteString -> Connection -> Query -> B.ByteString -> IO () doCopy funcName conn template q = do result <- exec conn q status <- PQ.resultStatus result 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 () #if MIN_VERSION_postgresql_libpq(0,9,3) PQ.CopyBoth -> errMsg "COPY BOTH is not supported" #endif #if MIN_VERSION_postgresql_libpq(0,9,2) PQ.SingleTuple -> errMsg "single-row mode is not supported" #endif PQ.BadResponse -> throwResultError funcName result status PQ.NonfatalError -> throwResultError funcName result status PQ.FatalError -> throwResultError funcName result status data CopyOutResult = CopyOutRow !B.ByteString -- ^ Data representing either exactly -- one row of the result, or header -- or footer data depending on format. | CopyOutDone {-# UNPACK #-} !Int64 -- ^ No more rows, and a count of the -- number of rows returned. deriving (Eq, Typeable, Show) -- | Fold over @COPY TO STDOUT@ query passing each copied row to an accumulator -- and calling a post-process at the end. A connection must be in the -- @CopyOut@ state in order to call this function. -- -- __Example__ -- -- > (acc, count) <- foldCopyData conn -- > (\acc row -> return (row:acc)) -- > (\acc count -> return (acc, count)) -- > [] foldCopyData :: Connection -- ^ Database connection -> (a -> B.ByteString -> IO a) -- ^ Accumulate one row of the result -> (a -> Int64 -> IO b) -- ^ Post-process accumulator with a count of rows -> a -- ^ Initial accumulator -> IO b -- ^ Result foldCopyData conn f g !acc = do result <- getCopyData conn case result of CopyOutRow row -> f acc row >>= foldCopyData conn f g CopyOutDone count -> g acc count -- | Retrieve some data from a @COPY TO STDOUT@ query. A connection -- must be in the @CopyOut@ state in order to call this function. If this -- returns a 'CopyOutRow', the connection remains in the @CopyOut@ state, -- if it returns 'CopyOutDone', then the connection has reverted to the -- ready state. getCopyData :: Connection -> IO CopyOutResult getCopyData conn = withConnection conn loop where funcName = "Database.PostgreSQL.Simple.Copy.getCopyData" loop pqconn = do #if defined(mingw32_HOST_OS) row <- PQ.getCopyData pqconn False #else row <- PQ.getCopyData pqconn True #endif case row of PQ.CopyOutRow rowdata -> return $! CopyOutRow rowdata PQ.CopyOutDone -> CopyOutDone <$> getCopyCommandTag funcName pqconn #if defined(mingw32_HOST_OS) PQ.CopyOutWouldBlock -> do fail (B.unpack funcName ++ ": the impossible happened") #else PQ.CopyOutWouldBlock -> do mfd <- PQ.socket pqconn case mfd of Nothing -> throwIO (fdError funcName) Just fd -> do threadWaitRead fd _ <- PQ.consumeInput pqconn loop pqconn #endif PQ.CopyOutError -> do mmsg <- PQ.errorMessage pqconn throwIO SqlError { sqlState = "", sqlExecStatus = FatalError, sqlErrorMsg = maybe "" id mmsg, sqlErrorDetail = "", sqlErrorHint = funcName } -- | Feed some data to a @COPY FROM STDIN@ query. Note that -- the data does not need to represent a single row, or even an -- integral number of rows. The net result of -- @putCopyData conn a >> putCopyData conn b@ -- is the same as @putCopyData conn c@ whenever @c == BS.append a b@. -- -- A connection must be in the @CopyIn@ state in order to call this -- function, otherwise a 'SqlError' exception will result. The -- connection remains in the @CopyIn@ state after this function -- is called. putCopyData :: Connection -> B.ByteString -> IO () putCopyData conn dat = withConnection conn $ \pqconn -> do doCopyIn funcName (\c -> PQ.putCopyData c dat) pqconn where funcName = "Database.PostgreSQL.Simple.Copy.putCopyData" -- | Completes a @COPY FROM STDIN@ query. Returns the number of rows -- processed. -- -- A connection must be in the @CopyIn@ state in order to call this -- function, otherwise a 'SqlError' exception will result. The -- connection's state changes back to ready after this function -- is called. putCopyEnd :: Connection -> IO Int64 putCopyEnd conn = withConnection conn $ \pqconn -> do doCopyIn funcName (\c -> PQ.putCopyEnd c Nothing) pqconn getCopyCommandTag funcName pqconn where funcName = "Database.PostgreSQL.Simple.Copy.putCopyEnd" -- | Aborts a @COPY FROM STDIN@ query. The string parameter is simply -- an arbitrary error message that may show up in the PostgreSQL -- server's log. -- -- A connection must be in the @CopyIn@ state in order to call this -- function, otherwise a 'SqlError' exception will result. The -- connection's state changes back to ready after this function -- is called. 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" doCopyIn :: B.ByteString -> (PQ.Connection -> IO PQ.CopyInResult) -> PQ.Connection -> IO () doCopyIn funcName action = loop where loop pqconn = do stat <- action pqconn case stat of PQ.CopyInOk -> return () PQ.CopyInError -> do mmsg <- PQ.errorMessage pqconn throwIO SqlError { sqlState = "", sqlExecStatus = FatalError, sqlErrorMsg = maybe "" id mmsg, sqlErrorDetail = "", sqlErrorHint = funcName } PQ.CopyInWouldBlock -> do mfd <- PQ.socket pqconn case mfd of Nothing -> throwIO (fdError funcName) Just fd -> do threadWaitWrite fd loop pqconn {-# INLINE doCopyIn #-} getCopyCommandTag :: B.ByteString -> PQ.Connection -> IO Int64 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 _ -> 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 postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Cursor.hs0000644000000000000000000000716007346545000023110 0ustar0000000000000000{-# 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' #-} postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Errors.hs0000644000000000000000000001146707346545000023114 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Errors -- Copyright: (c) 2012-2013 Leonid Onokhov, Joey Adams -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- | Module for parsing errors from postgresql error messages. -- Currently only parses integrity violation errors (class 23). -- -- /Note: Success of parsing may depend on language settings./ ---------------------------------------------------------- module Database.PostgreSQL.Simple.Errors ( ConstraintViolation(..) , constraintViolation , constraintViolationE , catchViolation , isSerializationError , isNoActiveTransactionError , isFailedTransactionError ) where import Control.Applicative import Control.Exception as E import Data.Attoparsec.ByteString.Char8 import Data.ByteString (ByteString) import Data.Typeable import Database.PostgreSQL.Simple.Internal -- Examples of parsed error messages -- -- `ERROR: new row for relation "users" violates check -- constraint "user_kind_check"` -- -- `ERROR: insert or update on table "user_group_map" violates foreign key -- constraint "user_id"` -- -- `ERROR: null value in column "login" violates not-null constraint` -- -- `ERROR: duplicate key value violates unique constraint "users_login_key"` data ConstraintViolation = NotNullViolation ByteString -- ^ The field is a column name | ForeignKeyViolation ByteString ByteString -- ^ Table name and name of violated constraint | UniqueViolation ByteString -- ^ 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 -- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and -- succeeds only if able to parse sqlErrorMsg. -- -- > createUser = handleJust constraintViolation handler $ execute conn ... -- > where -- > handler (UniqueViolation "user_login_key") = ... -- > handler _ = ... constraintViolation :: SqlError -> Maybe ConstraintViolation constraintViolation e = case sqlState e of "23502" -> NotNullViolation <$> parseMaybe parseQ1 msg "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 = handleJust constraintViolationE handler $ execute conn ... -- > where -- > 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 'E.handleJust' -- -- > createUser = catchViolation catcher $ execute conn ... -- > where -- > catcher _ (UniqueViolation "user_login_key") = ... -- > catcher e _ = throwIO e catchViolation :: (SqlError -> ConstraintViolation -> IO a) -> IO a -> IO a catchViolation f m = E.catch m (\e -> maybe (throwIO e) (f e) $ constraintViolation e) -- Parsers just try to extract quoted strings from error messages, number -- of quoted strings depend on error type. scanTillQuote :: Parser ByteString scanTillQuote = scan False go where go True _ = Just False -- escaped character go False '"' = Nothing -- end parse go False '\\' = Just True -- next one is escaped go _ _ = Just False parseQ1 :: Parser ByteString parseQ1 = scanTillQuote *> char '"' *> scanTillQuote <* char '"' parseQ2 :: Parser (ByteString, ByteString) parseQ2 = (,) <$> parseQ1 <*> parseQ1 parseMaybe :: Parser a -> ByteString -> Maybe a parseMaybe p b = either (const Nothing) Just $ parseOnly p b ------------------------------------------------------------------------ -- Error predicates -- -- https://www.postgresql.org/docs/9.5/static/errcodes-appendix.html isSerializationError :: SqlError -> Bool isSerializationError = isSqlState "40001" isNoActiveTransactionError :: SqlError -> Bool isNoActiveTransactionError = isSqlState "25P01" isFailedTransactionError :: SqlError -> Bool isFailedTransactionError = isSqlState "25P02" isSqlState :: ByteString -> SqlError -> Bool isSqlState s SqlError{..} = sqlState == s postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/FromField.hs0000644000000000000000000006545707346545000023517 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE PatternGuards, ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE PolyKinds #-} {- | Module: Database.PostgreSQL.Simple.FromField Copyright: (c) 2011 MailRank, Inc. (c) 2011-2013 Leon P Smith License: BSD3 Maintainer: Leon P Smith Stability: experimental The 'FromField' typeclass, for converting a single value in a row returned by a SQL query into a more useful Haskell representation. Note that each instance of 'FromField' is documented by a list of compatible postgresql types. A Haskell numeric type is considered to be compatible with all PostgreSQL numeric types that are less accurate than it. For instance, the Haskell 'Double' type is compatible with the PostgreSQL's 32-bit @int@ type because it can represent a @int@ exactly. On the other hand, 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 does not support out-of-box. Here's an example of what such an instance might look like for a UUID type that implements the @Read@ class: @ import Data.UUID ( UUID ) import Database.PostgreSQL.Simple.FromField ( FromField (fromField) , typeOid, returnError, ResultError (..) ) import Database.PostgreSQL.Simple.TypeInfo.Static (typoid, uuid) import qualified Data.ByteString.Char8 as B instance FromField UUID where fromField f mdata = if typeOid f /= typoid uuid then returnError Incompatible f \"\" else case B.unpack \`fmap\` mdata of Nothing -> returnError UnexpectedNull f \"\" Just dat -> case [ x | (x,t) <- reads dat, (\"\",\"\") <- lex t ] of [x] -> return x _ -> returnError ConversionFailed f dat @ Note that because PostgreSQL's @uuid@ type is built into postgres and is not provided by an extension, the 'typeOid' of @uuid@ does not change and thus we can examine it directly. One could hard-code the type oid, or obtain it by other means, but in this case we simply pull it out of the static table provided by postgresql-simple. On the other hand if the type is provided by an extension, such as @PostGIS@ or @hstore@, then the 'typeOid' is not stable and can vary from database to database. In this case it is recommended that FromField instances use 'typename' instead. -} module Database.PostgreSQL.Simple.FromField ( FromField(..) , FieldParser , Conversion() , runConversion , conversionMap , conversionError , ResultError(..) , returnError , Field , typename , TypeInfo(..) , Attribute(..) , typeInfo , typeInfoByOid , name , tableOid , tableColumn , format , typeOid , PQ.Oid(..) , PQ.Format(..) , pgArrayFieldParser , attoFieldParser , optionalField , fromJSONField , fromFieldJSONByteString ) where #include "MachDeps.h" import Control.Applicative ( Const(Const), (<|>), (<$>), pure, (*>), (<*) ) import Control.Concurrent.MVar (MVar, newMVar) import Control.Exception (Exception) import qualified Data.Aeson as JSON 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.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 import Database.PostgreSQL.Simple.TypeInfo as TI import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI import Database.PostgreSQL.Simple.Time import Database.PostgreSQL.Simple.Arrays as Arrays import qualified Database.PostgreSQL.LibPQ as PQ import qualified Data.ByteString as SB import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as LB import qualified Data.Text as ST import qualified Data.Text.Encoding as ST import qualified Data.Text.Lazy as LT 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) #if MIN_VERSION_aeson(2,1,2) import qualified Data.Aeson.Types as JSON #else import qualified Data.Aeson.Internal as JSON #endif -- | Exception thrown if conversion from a SQL value to a Haskell -- value fails. data ResultError = Incompatible { errSQLType :: String , errSQLTableOid :: Maybe PQ.Oid , errSQLField :: String , errHaskellType :: String , errMessage :: String } -- ^ The SQL and Haskell types are not compatible. | UnexpectedNull { errSQLType :: String , errSQLTableOid :: Maybe PQ.Oid , errSQLField :: String , errHaskellType :: String , errMessage :: String } -- ^ A SQL @NULL@ was encountered when the Haskell -- type did not permit it. | ConversionFailed { errSQLType :: String , errSQLTableOid :: Maybe PQ.Oid , errSQLField :: String , errHaskellType :: String , errMessage :: String } -- ^ The SQL value could not be parsed, or could not -- be represented as a valid Haskell value, or an -- unexpected low-level error occurred (e.g. mismatch -- between metadata and actual data in a row). deriving (Eq, Show, Typeable) instance Exception ResultError left :: Exception a => a -> Conversion b left = conversionError type FieldParser a = Field -> Maybe ByteString -> Conversion a -- | A type that may be converted from a SQL type. class FromField a where fromField :: FieldParser a -- ^ Convert a SQL value to a Haskell value. -- -- Returns a list of exceptions if the conversion fails. In the case of -- library instances, this will usually be a single 'ResultError', but -- may be a 'UnicodeException'. -- -- 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. -- -- 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 -- extensions to PostgreSQL. -- -- More concretely, it returns the @typname@ column associated with the -- type oid in the @pg_type@ table. First, postgresql-simple will check -- the built-in, static table. If the type oid is not there, -- postgresql-simple will check a per-connection cache, and then -- finally query the database's meta-schema. typename :: Field -> Conversion ByteString typename field = typname <$> typeInfo field typeInfo :: Field -> Conversion TypeInfo typeInfo Field{..} = Conversion $ \conn -> do Ok <$> (getTypeInfo conn typeOid) typeInfoByOid :: PQ.Oid -> Conversion TypeInfo typeInfoByOid oid = Conversion $ \conn -> do Ok <$> (getTypeInfo conn oid) -- | Returns the name of the column. This is often determined by a table -- definition, but it can be set using an @as@ clause. name :: Field -> Maybe ByteString name Field{..} = unsafeDupablePerformIO (PQ.fname result column) -- | Returns the name of the object id of the @table@ associated with the -- column, if any. Returns 'Nothing' when there is no such table; -- for example a computed column does not have a table associated with it. -- Analogous to libpq's @PQftable@. tableOid :: Field -> Maybe PQ.Oid tableOid Field{..} = toMaybeOid (unsafeDupablePerformIO (PQ.ftable result column)) where toMaybeOid x = if x == PQ.invalidOid then Nothing else Just x -- | 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)) where fromCol (PQ.Col x) = fromIntegral x -- | This returns whether the data was returned in a binary or textual format. -- Analogous to libpq's @PQfformat@. format :: Field -> PQ.Format format Field{..} = unsafeDupablePerformIO (PQ.fformat result column) -- | void instance FromField () where fromField f _bs | 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 = 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 fromField f (Just _) = returnError ConversionFailed f "data is not null" -- | bool instance FromField Bool where fromField f bs | 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\", bpchar instance FromField Char where 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 = attoFieldParser ok16 $ signed decimal -- | int2, int4 instance FromField Int32 where fromField = attoFieldParser ok32 $ signed decimal #if WORD_SIZE_IN_BITS < 64 -- | int2, int4, and if compiled as 64-bit code, int8 as well. -- This library was compiled as 32-bit code. #else -- | int2, int4, and if compiled as 64-bit code, int8 as well. -- This library was compiled as 64-bit code. #endif instance FromField Int where fromField = attoFieldParser okInt $ signed decimal -- | int2, int4, int8 instance FromField Int64 where fromField = attoFieldParser ok64 $ signed decimal -- | int2, int4, int8 instance FromField Integer where fromField = attoFieldParser ok64 $ signed decimal -- | int2, float4 (Uses attoparsec's 'double' routine, for -- better accuracy convert to 'Scientific' or 'Rational' first) instance FromField Float where fromField = attoFieldParser ok (realToFrac <$> pg_double) where ok = eq TI.float4Oid \/ eq TI.int2Oid -- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for -- better accuracy convert to 'Scientific' or 'Rational' first) instance FromField Double where fromField = attoFieldParser ok pg_double where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid -- | int2, int4, int8, float4, float8, numeric instance FromField (Ratio Integer) where fromField = 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 == TI.byteaOid then unBinary <$> fromField f dat else doFromField f okText' pure dat -- | oid instance FromField PQ.Oid where fromField f dat = PQ.Oid <$> attoFieldParser (== TI.oidOid) decimal f dat -- | bytea, name, text, \"char\", bpchar, varchar, unknown instance FromField LB.ByteString where fromField f dat = LB.fromChunks . (:[]) <$> fromField f dat unescapeBytea :: Field -> SB.ByteString -> Conversion (Binary SB.ByteString) unescapeBytea f str' = case unsafeDupablePerformIO (PQ.unescapeBytea str') of Nothing -> returnError ConversionFailed f "unescapeBytea failed" Just str -> pure (Binary str) -- | bytea 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) dat -- | bytea instance FromField (Binary LB.ByteString) where fromField f dat = Binary . LB.fromChunks . (:[]) . unBinary <$> fromField f dat -- | name, text, \"char\", bpchar, varchar instance FromField ST.Text where fromField f = doFromField f okText $ (either left pure . ST.decodeUtf8') -- FIXME: check character encoding -- | name, text, \"char\", bpchar, varchar 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 TI.timestamptzOid "UTCTime" parseUTCTime -- | timestamptz instance FromField ZonedTime where fromField = ff TI.timestamptzOid "ZonedTime" parseZonedTime -- | timestamp instance FromField LocalTime where fromField = ff TI.timestampOid "LocalTime" parseLocalTime -- | date instance FromField Day where fromField = ff TI.dateOid "Day" parseDay -- | time instance FromField TimeOfDay where fromField = ff TI.timeOid "TimeOfDay" parseTimeOfDay -- | timestamptz instance FromField UTCTimestamp where fromField = ff TI.timestamptzOid "UTCTimestamp" parseUTCTimestamp -- | timestamptz instance FromField ZonedTimestamp where fromField = ff TI.timestamptzOid "ZonedTimestamp" parseZonedTimestamp -- | timestamp instance FromField LocalTimestamp where fromField = ff TI.timestampOid "LocalTimestamp" parseLocalTimestamp -- | date instance FromField Date where 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 parseBS f mstr = if typeOid f /= compatOid then err Incompatible "" else case mstr of Nothing -> err UnexpectedNull "" Just str -> case parseBS str of Left msg -> err ConversionFailed msg Right val -> return val where err errC msg = do typnam <- typename f left $ errC (B8.unpack typnam) (tableOid f) (maybe "" B8.unpack (name f)) hsType msg {-# INLINE ff #-} -- | Compatible with both types. Conversions to type @b@ are -- preferred, the conversion to type @a@ will be tried after -- the 'Right' conversion fails. instance (FromField a, FromField b) => FromField (Either a b) where fromField f dat = (Right <$> fromField f dat) <|> (Left <$> fromField f dat) -- | any postgresql array whose elements are compatible with type @a@ 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 fieldParser info f) dat of Left err -> returnError ConversionFailed f err Right conv -> PGArray <$> conv _ -> returnError Incompatible f "" fromArray :: FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a]) fromArray fieldParser typInfo f = sequence . (parseIt <$>) <$> array delim where 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 /= TI.uuidOid then returnError Incompatible f "" else case mbs of Nothing -> returnError UnexpectedNull f "" Just bs -> case UUID.fromASCIIBytes bs of Nothing -> returnError ConversionFailed f "Invalid UUID" Just uuid -> pure uuid -- | json, jsonb instance FromField JSON.Value where 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 -> pure bs -- | Parse a field to a JSON 'JSON.Value' and convert that into a -- 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 -- PostgreSQL. -- -- 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.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 = 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 doFromField f isCompat cvt (Just bs) | isCompat (typeOid f) = cvt bs | otherwise = returnError Incompatible f "types incompatible" doFromField f _ _ _ = returnError UnexpectedNull f "" -- | Given one of the constructors from 'ResultError', the field, -- and an 'errMessage', this fills in the other fields in the -- exception value and returns it in a 'Left . SomeException' -- constructor. returnError :: forall a err . (Typeable a, Exception err) => (String -> Maybe PQ.Oid -> String -> String -> String -> err) -> Field -> String -> Conversion a returnError mkErr f msg = do typnam <- typename f left $ mkErr (B.unpack typnam) (tableOid f) (maybe "" B.unpack (name f)) (show (typeOf (undefined :: a))) msg -- | 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 = case parseOnly p s of Left err -> returnError ConversionFailed f err Right v -> pure v postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/FromField.hs-boot0000644000000000000000000000041307346545000024435 0ustar0000000000000000module Database.PostgreSQL.Simple.FromField where import Data.ByteString(ByteString) import Database.PostgreSQL.Simple.Types class FromField a instance FromField Oid instance FromField Char instance FromField ByteString instance FromField a => FromField (Maybe a) postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/FromRow.hs0000644000000000000000000005271307346545000023232 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards, FlexibleInstances, DefaultSignatures #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.FromRow -- Copyright: (c) 2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- The 'FromRow' typeclass, for converting a row of results -- returned by a SQL query into a more useful Haskell representation. -- -- Predefined instances are provided for tuples containing up to ten -- elements. The instances for 'Maybe' types return 'Nothing' if all -- the columns that would have been otherwise consumed are null, otherwise -- it attempts a regular conversion. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.FromRow ( FromRow(..) , RowParser , field , fieldWith , numFieldsRemaining ) where import Prelude hiding (null) import Control.Applicative (Applicative(..), (<$>), (<|>), (*>), liftA2) import Control.Monad (replicateM, replicateM_) import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Class import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import Data.Vector (Vector) import qualified Data.Vector as V import Database.PostgreSQL.Simple.Types (Only(..)) import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Compat import Database.PostgreSQL.Simple.FromField import Database.PostgreSQL.Simple.Ok 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 } -- -- instance 'FromRow' User where -- fromRow = User \<$\> 'field' \<*\> 'field' -- @ -- -- The number of calls to 'field' must match the number of fields returned -- in a single row of the query result. Otherwise, a 'ConversionFailed' -- exception will be thrown. -- -- You can also derive 'FromRow' for your data type using GHC generics, like -- this: -- -- @ -- \{-# LANGUAGE DeriveAnyClass \#-} -- \{-# LANGUAGE DeriveGeneric \#-} -- -- import "GHC.Generics" ('GHC.Generics.Generic') -- import "Database.PostgreSQL.Simple" ('FromRow') -- -- data User = User { name :: String, fileQuota :: Int } -- deriving ('GHC.Generics.Generic', 'FromRow') -- @ -- -- Note that this only works for product types (e.g. records) and does not -- support sum types or recursive types. -- -- Note that 'field' evaluates its result to WHNF, so the caveats listed in -- mysql-simple and very early versions of postgresql-simple no longer apply. -- Instead, look at the caveats associated with user-defined implementations -- 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) nfields :: PQ.Result -> PQ.Column nfields result = unsafeDupablePerformIO (PQ.nfields result) getTypeInfoByCol :: Row -> PQ.Column -> Conversion TypeInfo getTypeInfoByCol Row{..} col = Conversion $ \conn -> do oid <- PQ.ftype rowresult col Ok <$> getTypeInfo conn oid getTypenameByCol :: Row -> PQ.Column -> Conversion ByteString getTypenameByCol row col = typname <$> getTypeInfoByCol row col fieldWith :: FieldParser a -> RowParser a fieldWith fieldP = RP $ do let unCol (PQ.Col x) = fromIntegral x :: Int r@Row{..} <- ask column <- lift get lift (put (column + 1)) let ncols = nfields rowresult if (column >= ncols) then lift $ lift $ do vals <- mapM (getTypenameByCol r) [0..ncols-1] let err = ConversionFailed (show (unCol ncols) ++ " values: " ++ show (map ellipsis vals)) Nothing "" ("at least " ++ show (unCol column + 1) ++ " slots in target type") "mismatch between number of columns to \ \convert and number in target type" conversionError err else do let !result = rowresult !typeOid = unsafeDupablePerformIO (PQ.ftype result column) !field' = Field{..} lift (lift (fieldP field' (getvalue result row column))) field :: FromField a => RowParser a field = fieldWith fromField ellipsis :: ByteString -> ByteString ellipsis bs | B.length bs > 15 = B.take 10 bs `B.append` "[...]" | otherwise = bs numFieldsRemaining :: RowParser Int numFieldsRemaining = RP $ do Row{..} <- ask column <- lift get return $! (\(PQ.Col x) -> fromIntegral x) (nfields rowresult - column) null :: RowParser Null null = field instance (FromField a) => FromRow (Only a) where fromRow = Only <$> field instance (FromField a) => FromRow (Maybe (Only a)) where fromRow = (null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b) => FromRow (a,b) where fromRow = (,) <$> field <*> field instance (FromField a, FromField b) => FromRow (Maybe (a,b)) where fromRow = (null *> null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b, FromField c) => FromRow (a,b,c) where fromRow = (,,) <$> field <*> field <*> field instance (FromField a, FromField b, FromField c) => FromRow (Maybe (a,b,c)) where fromRow = (null *> null *> null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b, FromField c, FromField d) => FromRow (a,b,c,d) where fromRow = (,,,) <$> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d) => FromRow (Maybe (a,b,c,d)) where fromRow = (null *> null *> null *> null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b, FromField c, FromField d, FromField e) => FromRow (a,b,c,d,e) where fromRow = (,,,,) <$> field <*> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e) => FromRow (Maybe (a,b,c,d,e)) where fromRow = (null *> null *> null *> null *> null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f) => FromRow (a,b,c,d,e,f) where fromRow = (,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f) => FromRow (Maybe (a,b,c,d,e,f)) where fromRow = (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) => FromRow (a,b,c,d,e,f,g) where fromRow = (,,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g) => FromRow (Maybe (a,b,c,d,e,f,g)) where fromRow = (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) => FromRow (a,b,c,d,e,f,g,h) where fromRow = (,,,,,,,) <$> 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) => FromRow (Maybe (a,b,c,d,e,f,g,h)) where fromRow = (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) => FromRow (a,b,c,d,e,f,g,h,i) where fromRow = (,,,,,,,,) <$> 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) => FromRow (Maybe (a,b,c,d,e,f,g,h,i)) where fromRow = (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) => FromRow (a,b,c,d,e,f,g,h,i,j) where fromRow = (,,,,,,,,,) <$> 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) => FromRow (Maybe (a,b,c,d,e,f,g,h,i,j)) where fromRow = (null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k) => FromRow (a,b,c,d,e,f,g,h,i,j,k) where fromRow = (,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k) => FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k)) where fromRow = (null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k, FromField l) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l) where fromRow = (,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k, FromField l) => FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l)) where fromRow = (null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k, FromField l, FromField m) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m) where fromRow = (,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k, FromField l, FromField m) => FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m)) where fromRow = (null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k, FromField l, FromField m, FromField n) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where fromRow = (,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k, FromField l, FromField m, FromField n) => FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n)) where fromRow = (null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k, FromField l, FromField m, FromField n, FromField o) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where fromRow = (,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k, FromField l, FromField m, FromField n, FromField o) => FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)) where fromRow = (null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k, FromField l, FromField m, FromField n, FromField o, FromField p) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where fromRow = (,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k, FromField l, FromField m, FromField n, FromField o, FromField p) => FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)) where fromRow = (null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k, FromField l, FromField m, FromField n, FromField o, FromField p, FromField q) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) where fromRow = (,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k, FromField l, FromField m, FromField n, FromField o, FromField p, FromField q) => FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q)) where fromRow = (null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k, FromField l, FromField m, FromField n, FromField o, FromField p, FromField q, FromField r) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) where fromRow = (,,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k, FromField l, FromField m, FromField n, FromField o, FromField p, FromField q, FromField r) => FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r)) where fromRow = (null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k, FromField l, FromField m, FromField n, FromField o, FromField p, FromField q, FromField r, FromField s) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) where fromRow = (,,,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k, FromField l, FromField m, FromField n, FromField o, FromField p, FromField q, FromField r, FromField s) => FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s)) where fromRow = (null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> pure Nothing) <|> (Just <$> fromRow) instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k, FromField l, FromField m, FromField n, FromField o, FromField p, FromField q, FromField r, FromField s, FromField t) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) where fromRow = (,,,,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k, FromField l, FromField m, FromField n, FromField o, FromField p, FromField q, FromField r, FromField s, FromField t) => FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t)) where fromRow = (null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> null *> pure Nothing) <|> (Just <$> fromRow) instance FromField a => FromRow [a] where fromRow = do n <- numFieldsRemaining replicateM n field instance FromField a => FromRow (Maybe [a]) where fromRow = do n <- numFieldsRemaining (replicateM_ n null *> pure Nothing) <|> (Just <$> replicateM n field) instance FromField a => FromRow (Vector a) where fromRow = do n <- numFieldsRemaining V.replicateM n field instance FromField a => FromRow (Maybe (Vector a)) where fromRow = do n <- numFieldsRemaining (replicateM_ n null *> pure Nothing) <|> (Just <$> V.replicateM n field) 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 postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/FromRow.hs-boot0000644000000000000000000000113407346545000024162 0ustar0000000000000000module Database.PostgreSQL.Simple.FromRow where import {-# SOURCE #-} Database.PostgreSQL.Simple.FromField import Database.PostgreSQL.Simple.Types class FromRow a instance (FromField a) => FromRow (Only a) instance (FromField a, FromField b) => FromRow (a,b) 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) => FromRow (a,b,c,d,e) instance (FromField a, FromField b, FromField c, FromField d, FromField e ,FromField f) => FromRow (a,b,c,d,e,f) postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/HStore.hs0000644000000000000000000000230707346545000023035 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.HStore -- Copyright: (c) 2013 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- Parsers and printers for hstore, a extended type bundled with -- PostgreSQL providing finite maps from text strings to text strings. -- 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 -- information. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.HStore ( HStoreList(..) , HStoreMap(..) , ToHStore(..) , HStoreBuilder , toBuilder , toLazyByteString , hstore , parseHStoreList , ToHStoreText(..) , HStoreText ) where import Database.PostgreSQL.Simple.HStore.Implementation postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/HStore/0000755000000000000000000000000007346545000022477 5ustar0000000000000000postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/HStore/Implementation.hs0000644000000000000000000001627007346545000026026 0ustar0000000000000000{-# LANGUAGE CPP, ViewPatterns, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.HStore.Implementation -- Copyright: (c) 2013 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- This code has yet to be profiled and optimized. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.HStore.Implementation where import Control.Applicative 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) import qualified Data.Text as TS import qualified Data.Text.Encoding as TS import Data.Text.Encoding.Error(UnicodeException) 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 class ToHStore a where toHStore :: a -> HStoreBuilder -- | Represents valid hstore syntax. data HStoreBuilder = Empty | Comma !Builder deriving (Typeable) instance ToHStore HStoreBuilder where toHStore = id toBuilder :: HStoreBuilder -> Builder toBuilder x = case x of Empty -> mempty Comma c -> c toLazyByteString :: HStoreBuilder -> BL.ByteString toLazyByteString x = case x of Empty -> BL.empty Comma c -> BU.toLazyByteString c instance Semigroup HStoreBuilder where Empty <> x = x Comma a <> x = Comma (a `mappend` case x of Empty -> mempty Comma b -> char8 ',' `mappend` b) instance Monoid HStoreBuilder where mempty = Empty #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif 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, Semigroup, Monoid) instance ToHStoreText HStoreText where toHStoreText = id -- | Assumed to be UTF-8 encoded instance ToHStoreText BS.ByteString where toHStoreText str = HStoreText (escapeAppend str mempty) -- | Assumed to be UTF-8 encoded instance ToHStoreText BL.ByteString where toHStoreText = HStoreText . BL.foldrChunks escapeAppend mempty instance ToHStoreText TS.Text where toHStoreText str = HStoreText (escapeAppend (TS.encodeUtf8 str) mempty) instance ToHStoreText TL.Text where toHStoreText = HStoreText . TL.foldrChunks (escapeAppend . TS.encodeUtf8) mempty escapeAppend :: BS.ByteString -> Builder -> Builder escapeAppend = loop where loop (BS.break quoteNeeded -> (a,b)) rest = 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 '\"' = byteString "\\\"" | otherwise = byteString "\\\\" hstore :: (ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder hstore (toHStoreText -> (HStoreText key)) (toHStoreText -> (HStoreText val)) = Comma (char8 '"' `mappend` key `mappend` byteString "\"=>\"" `mappend` val `mappend` char8 '"') instance ToField HStoreBuilder where toField Empty = toField (BS.empty) toField (Comma x) = toField (BU.toLazyByteString x) newtype HStoreList = HStoreList {fromHStoreList :: [(Text,Text)]} deriving (Typeable, Show) -- | hstore instance ToHStore HStoreList where toHStore (HStoreList xs) = mconcat (map (uncurry hstore) xs) instance ToField HStoreList where toField xs = toField (toHStore xs) -- | hstore instance FromField HStoreList where fromField f mdat = do typ <- typename f if typ /= "hstore" then returnError Incompatible f "" else case mdat of Nothing -> returnError UnexpectedNull f "" Just dat -> case P.parseOnly (parseHStore <* P.endOfInput) dat of Left err -> returnError ConversionFailed f err Right (Left err) -> returnError ConversionFailed f "unicode exception" <|> conversionError err Right (Right val) -> return val newtype HStoreMap = HStoreMap {fromHStoreMap :: Map Text Text} deriving (Eq, Ord, Typeable, Show) instance ToHStore HStoreMap where toHStore (HStoreMap xs) = Map.foldrWithKey f mempty xs where f k v xs' = hstore k v `mappend` xs' instance ToField HStoreMap where toField xs = toField (toHStore xs) 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 kvs <- P.sepBy' (skipWhiteSpace *> parseHStoreKeyVal) (skipWhiteSpace *> P.word8 (c2w ',')) return $ HStoreList <$> sequence kvs parseHStoreKeyVal :: P.Parser (Either UnicodeException (Text,Text)) parseHStoreKeyVal = do mkey <- parseHStoreText case mkey of Left err -> return (Left err) Right key -> do skipWhiteSpace _ <- P.string "=>" skipWhiteSpace mval <- parseHStoreText case mval of Left err -> return (Left err) Right val -> return (Right (key,val)) skipWhiteSpace :: P.Parser () skipWhiteSpace = P.skipWhile P.isSpace_w8 parseHStoreText :: P.Parser (Either UnicodeException Text) parseHStoreText = do _ <- P.word8 (c2w '"') mtexts <- parseHStoreTexts id case mtexts of Left err -> return (Left err) Right texts -> do _ <- P.word8 (c2w '"') return (Right (TS.concat texts)) parseHStoreTexts :: ([Text] -> [Text]) -> P.Parser (Either UnicodeException [Text]) parseHStoreTexts acc = do mchunk <- TS.decodeUtf8' <$> P.takeWhile (not . isSpecialChar) case mchunk of Left err -> return (Left err) Right chunk -> (do _ <- P.word8 (c2w '\\') c <- TS.singleton . w2c <$> P.satisfy isSpecialChar parseHStoreTexts (acc . (chunk:) . (c:)) ) <|> return (Right (acc [chunk])) where isSpecialChar c = c == c2w '\\' || c == c2w '"' postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/HStore/Internal.hs0000644000000000000000000000113307346545000024605 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.HStore.Internal -- Copyright: (c) 2013 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.HStore.Internal ( HStoreBuilder(..) , HStoreText(..) , parseHStore , parseHStoreKeyVal , parseHStoreText ) where import Database.PostgreSQL.Simple.HStore.Implementation postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Internal.hs0000644000000000000000000005652607346545000023421 0ustar0000000000000000{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Internal -- Copyright: (c) 2011-2015 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- Internal bits. This interface is less stable and can change at any time. -- In particular this means that while the rest of the postgresql-simple -- package endeavors to follow the package versioning policy, this module -- does not. Also, at the moment there are things in here that aren't -- particularly internal and are exported elsewhere; these will eventually -- disappear from this module. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.Internal where import Control.Applicative import Control.Exception 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.Monoid 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 -- -- You don't particularly want to retain these structures for a long -- period of time, as they will retain the entire query result, not -- just the field metadata data Field = Field { result :: !PQ.Result , column :: {-# UNPACK #-} !PQ.Column , typeOid :: {-# UNPACK #-} !PQ.Oid -- ^ This returns the type oid associated with the column. Analogous -- to libpq's @PQftype@. } type TypeInfoCache = IntMap.IntMap TypeInfo data Connection = Connection { 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 data SqlError = SqlError { sqlState :: ByteString , sqlExecStatus :: ExecStatus , sqlErrorMsg :: ByteString , sqlErrorDetail :: ByteString , sqlErrorHint :: ByteString } deriving (Eq, Show, Typeable) fatalError :: ByteString -> SqlError fatalError msg = SqlError "" FatalError msg "" "" instance Exception SqlError -- | 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 { qeMessage :: String , qeQuery :: Query } deriving (Eq, Show, Typeable) instance Exception QueryError -- | 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 data ConnectInfo = ConnectInfo { connectHost :: String , connectPort :: Word16 , connectUser :: String , connectPassword :: String , connectDatabase :: String } deriving (Generic,Eq,Read,Show,Typeable) -- | Default information for setting up a connection. -- -- Defaults are as follows: -- -- * Server on @localhost@ -- -- * Port on @5432@ -- -- * User @postgres@ -- -- * No password -- -- * Database @postgres@ -- -- Use as in the following example: -- -- > connect defaultConnectInfo { connectHost = "db.example.com" } defaultConnectInfo :: ConnectInfo defaultConnectInfo = ConnectInfo { connectHost = "127.0.0.1" , connectPort = 5432 , connectUser = "postgres" , connectPassword = "" , connectDatabase = "" } -- | Connect with the given username to the given database. Will throw -- an exception if it cannot connect. 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. 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 <- connectdb connstr stat <- PQ.status conn case stat of PQ.ConnectionOk -> do connectionHandle <- newMVar conn connectionObjects <- newMVar (IntMap.empty) connectionTempNameCounter <- newIORef 0 let wconn = Connection{..} version <- PQ.serverVersion conn let settings | 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 postgreSQLConnectionString connectInfo = fromString connstr where connstr = str "host=" connectHost $ num "port=" connectPort $ str "user=" connectUser $ str "password=" connectPassword $ str "dbname=" connectDatabase $ [] str name field | null value = id | otherwise = showString name . addQuotes value . space where value = field connectInfo num name field | value <= 0 = id | otherwise = showString name . shows value . space where value = field connectInfo addQuotes s rest = '\'' : foldr delta ('\'' : rest) s where delta c cs = case c of '\\' -> '\\' : '\\' : cs '\'' -> '\\' : '\'' : cs _ -> c : cs space [] = [] space xs = ' ':xs oid2int :: Oid -> Int oid2int (Oid x) = fromIntegral x {-# INLINE oid2int #-} 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 -> 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' #endif -- | A version of 'execute' that does not perform query substitution. execute_ :: Connection -> Query -> IO Int64 execute_ conn q@(Query stmt) = do result <- exec conn stmt finishExecute conn q result finishExecute :: Connection -> Query -> PQ.Result -> IO Int64 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 if ncols /= 0 then throwIO $ QueryError ("execute resulted in " ++ show ncols ++ "-column result") q else do nstr <- PQ.cmdTuples result return $ case nstr of Nothing -> 0 -- is this appropriate? Just str -> mkInteger str PQ.TuplesOk -> do ncols <- PQ.nfields result throwIO $ QueryError ("execute resulted in " ++ show ncols ++ "-column result") q PQ.CopyOut -> throwIO $ QueryError "execute: COPY TO is not supported" q PQ.CopyIn -> throwIO $ QueryError "execute: COPY FROM is not supported" q PQ.BadResponse -> throwResultError "execute" result status PQ.NonfatalError -> throwResultError "execute" result status PQ.FatalError -> throwResultError "execute" result status where mkInteger str = B8.foldl' delta 0 str where delta acc c = if '0' <= c && c <= '9' then 10 * acc + fromIntegral (ord c - ord '0') else error ("finishExecute: not an int: " ++ B8.unpack str) throwResultError :: ByteString -> PQ.Result -> PQ.ExecStatus -> IO a throwResultError _ result status = do errormsg <- fromMaybe "" <$> PQ.resultErrorField result PQ.DiagMessagePrimary detail <- fromMaybe "" <$> PQ.resultErrorField result PQ.DiagMessageDetail hint <- fromMaybe "" <$> PQ.resultErrorField result PQ.DiagMessageHint state' <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate throwIO $ SqlError { sqlState = state' , sqlExecStatus = status , sqlErrorMsg = errormsg , sqlErrorDetail = detail , sqlErrorHint = hint } disconnectedError :: SqlError disconnectedError = fatalError "connection disconnected" -- | Atomically perform an action with the database handle, if there is one. withConnection :: Connection -> (PQ.Connection -> IO a) -> IO a withConnection Connection{..} m = do withMVar connectionHandle $ \conn -> do if PQ.isNullConnection conn then throwIO disconnectedError else m conn close :: Connection -> IO () close Connection{..} = mask $ \restore -> (do conn <- takeMVar connectionHandle restore (PQ.finish conn) `finally` do putMVar connectionHandle =<< PQ.newNullConnection ) newNullConnection :: IO Connection newNullConnection = do connectionHandle <- newMVar =<< PQ.newNullConnection connectionObjects <- newMVar IntMap.empty connectionTempNameCounter <- newIORef 0 return Connection{..} data Row = Row { row :: {-# UNPACK #-} !PQ.Row , rowresult :: !PQ.Result } newtype RowParser a = RP { unRP :: ReaderT Row (StateT PQ.Column Conversion) a } deriving ( Functor, Applicative, Alternative, Monad ) liftRowParser :: IO a -> RowParser a liftRowParser = RP . lift . lift . liftConversion newtype Conversion a = Conversion { runConversion :: Connection -> IO (Ok a) } liftConversion :: IO a -> Conversion a liftConversion m = Conversion (\_ -> Ok <$> m) instance Functor Conversion where fmap f m = Conversion $ \conn -> (fmap . fmap) f (runConversion m conn) instance Applicative Conversion where pure a = Conversion $ \_conn -> pure (pure a) mf <*> ma = Conversion $ \conn -> do okf <- runConversion mf conn case okf of Ok f -> (fmap . fmap) f (runConversion ma conn) Errors errs -> return (Errors errs) instance Alternative Conversion where empty = Conversion $ \_conn -> pure empty ma <|> mb = Conversion $ \conn -> do oka <- runConversion ma conn case oka of Ok _ -> return oka Errors _ -> (oka <|>) <$> runConversion mb conn instance Monad Conversion where #if !(MIN_VERSION_base(4,8,0)) return = pure #endif m >>= f = Conversion $ \conn -> do oka <- runConversion m conn case oka of Ok a -> runConversion (f a) conn Errors err -> return (Errors err) instance MonadPlus Conversion where mzero = empty mplus = (<|>) conversionMap :: (Ok a -> Ok b) -> Conversion a -> Conversion b conversionMap f m = Conversion $ \conn -> f <$> runConversion m conn conversionError :: Exception err => err -> Conversion a conversionError err = Conversion $ \_ -> return (Errors [toException err]) newTempName :: Connection -> IO Query newTempName Connection{..} = do !n <- atomicModifyIORef connectionTempNameCounter (\n -> let !n' = n+1 in (n', n')) return $! Query $ B8.pack $ "temp" ++ show n -- FIXME? What error should getNotification and getCopyData throw? fdError :: ByteString -> IOError fdError funcName = IOError { ioe_handle = Nothing, ioe_type = ResourceVanished, ioe_location = B8.unpack funcName, ioe_description = "failed to fetch file descriptor", 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 postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Internal/0000755000000000000000000000000007346545000023047 5ustar0000000000000000postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs0000644000000000000000000001205707346545000026150 0ustar0000000000000000{-# 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" #if MIN_VERSION_postgresql_libpq(0,9,3) PQ.CopyBoth -> queryErr "query: COPY BOTH is not supported" #endif #if MIN_VERSION_postgresql_libpq(0,9,2) PQ.SingleTuple -> queryErr "query: single-row mode is not supported" #endif PQ.BadResponse -> throwResultError "query" result status PQ.NonfatalError -> throwResultError "query" result status PQ.FatalError -> throwResultError "query" result status 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' #-} postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/LargeObjects.hs0000644000000000000000000000673207346545000024203 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Database.PostgreSQL.Simple.LargeObjects -- Copyright : (c) 2011-2012 Leon P Smith -- License : BSD3 -- -- Maintainer : leon@melding-monads.com -- -- Support for PostgreSQL's Large Objects; see -- 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 -- 'loWrite', and do not perform any transaction handling themselves, -- they also need to be wrapped in an explicit transaction. -- ----------------------------------------------------------------------------- module Database.PostgreSQL.Simple.LargeObjects ( loCreat , loCreate , loImport , loImportWithOid , loExport , loOpen , loWrite , loRead , loSeek , loTell , loTruncate , loClose , loUnlink , Oid(..) , LoFd , IOMode(..) , SeekMode(..) ) where import Control.Applicative ((<$>)) import Control.Exception (throwIO) import qualified Data.ByteString as B import Database.PostgreSQL.LibPQ (Oid(..),LoFd(..)) import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.Internal import System.IO (IOMode(..),SeekMode(..)) liftPQ :: B.ByteString -> Connection -> (PQ.Connection -> IO (Maybe a)) -> IO a liftPQ str conn m = withConnection conn $ \c -> do res <- m c case res of Nothing -> do msg <- maybe str id <$> PQ.errorMessage c throwIO $ fatalError msg Just x -> return x loCreat :: Connection -> IO Oid loCreat conn = liftPQ "loCreat" conn (\c -> PQ.loCreat c) loCreate :: Connection -> Oid -> IO Oid loCreate conn oid = liftPQ "loCreate" conn (\c -> PQ.loCreate c oid) loImport :: Connection -> FilePath -> IO Oid loImport conn path = liftPQ "loImport" conn (\c -> PQ.loImport c path) loImportWithOid :: Connection -> FilePath -> Oid -> IO Oid loImportWithOid conn path oid = liftPQ "loImportWithOid" conn (\c -> PQ.loImportWithOid c path oid) loExport :: Connection -> Oid -> FilePath -> IO () loExport conn oid path = liftPQ "loExport" conn (\c -> PQ.loExport c oid path) loOpen :: Connection -> Oid -> IOMode -> IO LoFd loOpen conn oid mode = liftPQ "loOpen" conn (\c -> PQ.loOpen c oid mode ) loWrite :: Connection -> LoFd -> B.ByteString -> IO Int loWrite conn fd dat = liftPQ "loWrite" conn (\c -> PQ.loWrite c fd dat) loRead :: Connection -> LoFd -> Int -> IO B.ByteString loRead conn fd maxlen = liftPQ "loRead" conn (\c -> PQ.loRead c fd maxlen) loSeek :: Connection -> LoFd -> SeekMode -> Int -> IO Int loSeek conn fd seekmode offset = liftPQ "loSeek" conn (\c -> PQ.loSeek c fd seekmode offset) loTell :: Connection -> LoFd -> IO Int loTell conn fd = liftPQ "loTell" conn (\c -> PQ.loTell c fd) loTruncate :: Connection -> LoFd -> Int -> IO () loTruncate conn fd len = liftPQ "loTruncate" conn (\c -> PQ.loTruncate c fd len) loClose :: Connection -> LoFd -> IO () loClose conn fd = liftPQ "loClose" conn (\c -> PQ.loClose c fd) loUnlink :: Connection -> Oid -> IO () loUnlink conn oid = liftPQ "loUnlink" conn (\c -> PQ.loUnlink c oid) postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Newtypes.hs0000644000000000000000000000313307346545000023445 0ustar0000000000000000{-# 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) postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Notification.hs0000644000000000000000000001516507346545000024265 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module : Database.PostgreSQL.Simple.Notification -- Copyright : (c) 2011-2015 Leon P Smith -- (c) 2012 Joey Adams -- License : BSD3 -- -- Maintainer : leon@melding-monads.com -- Stability : experimental -- -- Support for receiving asynchronous notifications via PostgreSQL's -- Listen/Notify mechanism. See -- for more -- information. -- -- Note that on Windows, @getNotification@ currently uses a polling loop -- of 1 second to check for more notifications, due to some inadequacies -- in GHC's IO implementation and interface on that platform. See GHC -- issue #7353 for more information. While this workaround is less than -- ideal, notifications are still better than polling the database directly. -- Notifications do not create any extra work for the backend, and are -- likely cheaper on the client side as well. -- -- -- ----------------------------------------------------------------------------- module Database.PostgreSQL.Simple.Notification ( Notification(..) , getNotification , getNotificationNonBlocking , getBackendPID ) where 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 ) #elif !MIN_VERSION_base(4,7,0) import Control.Concurrent ( threadWaitRead ) #else import GHC.Conc ( atomically ) import Control.Concurrent ( threadWaitReadSTM ) #endif data Notification = Notification { notificationPid :: {-# UNPACK #-} !CPid , notificationChannel :: {-# UNPACK #-} !B.ByteString , notificationData :: {-# UNPACK #-} !B.ByteString } deriving (Show, Eq) convertNotice :: PQ.Notify -> Notification convertNotice PQ.Notify{..} = Notification { notificationPid = notifyBePid , notificationChannel = notifyRelname , notificationData = notifyExtra } -- | 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 = join $ withConnection conn fetch where funcName = "Database.PostgreSQL.Simple.Notification.getNotification" 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. Just _fd -> do return (threadDelay 1000000 >> loop) #elif !MIN_VERSION_base(4,7,0) -- Technically there's a race condition that is usually benign. -- If the connection is closed or reset after we drop the -- lock, and then the fd index is reallocated to a new -- descriptor before we call threadWaitRead, then -- we could end up waiting on the wrong descriptor. -- -- Now, if the descriptor becomes readable promptly, then -- it's no big deal as we'll wake up and notice the change -- on the next iteration of the loop. But if are very -- unlucky, then we could end up waiting a long time. Just fd -> do return $ do threadWaitRead fd `catch` (throwIO . setIOErrorLocation) loop #else -- This case fixes the race condition above. By registering -- our interest in the descriptor before we drop the lock, -- 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 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'. getNotificationNonBlocking :: Connection -> IO (Maybe Notification) getNotificationNonBlocking conn = withConnection conn $ \c -> do mmsg <- PQ.notifies c case mmsg of Just msg -> return $! Just $! convertNotice msg Nothing -> do _ <- PQ.consumeInput c mmsg' <- PQ.notifies c case mmsg' of Just msg -> return $! Just $! convertNotice msg Nothing -> return Nothing -- | Returns the process 'CPid' of the backend server process -- handling this connection. -- -- The backend PID is useful for debugging purposes and for comparison -- to NOTIFY messages (which include the PID of the notifying backend -- process). Note that the PID belongs to a process executing on the -- database server host, not the local host! getBackendPID :: Connection -> IO CPid getBackendPID conn = withConnection conn PQ.backendPID postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Ok.hs0000644000000000000000000000560707346545000022210 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ -- | -- Module : Database.PostgreSQL.Simple.Ok -- Copyright : (c) 2012-2015 Leon P Smith -- License : BSD3 -- -- Maintainer : leon@melding-monads.com -- Stability : experimental -- -- The 'Ok' type is a simple error handler, basically equivalent to -- @Either [SomeException]@. This type (without the list) was used to -- handle conversion errors in early versions of postgresql-simple. -- -- One of the primary reasons why this type was introduced is that -- @Either SomeException@ had not been provided an instance for 'Alternative', -- and it would have been a bad idea to provide an orphaned instance for a -- 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: '<|>' 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, -- this avoids cases where 'empty' overrides a more informative exception -- and allows you to see all the different ways your computation has failed. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.Ok where import Control.Applicative import Control.Exception 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?) data Ok a = Errors [SomeException] | Ok !a deriving(Show, Typeable, Functor) -- | Two 'Errors' cases are considered equal, regardless of what the -- list of exceptions looks like. instance Eq a => Eq (Ok a) where Errors _ == Errors _ = True Ok a == Ok b = a == b _ == _ = False instance Applicative Ok where pure = Ok Errors es <*> _ = Errors es _ <*> Errors es = Errors es Ok f <*> Ok a = Ok (f a) instance Alternative Ok where empty = Errors [] a@(Ok _) <|> _ = a Errors _ <|> b@(Ok _) = b Errors as <|> Errors bs = Errors (as ++ bs) instance MonadPlus Ok where mzero = empty mplus = (<|>) instance Monad Ok where #if !(MIN_VERSION_base(4,8,0)) return = pure #endif Errors es >>= _ = Errors es Ok a >>= f = f a #if !(MIN_VERSION_base(4,13,0)) fail = Fail.fail #endif instance Fail.MonadFail Ok where fail str = Errors [SomeException (ErrorCall str)] -- | a way to reify a list of exceptions into a single exception newtype ManyErrors = ManyErrors [SomeException] deriving (Show, Typeable) instance Exception ManyErrors postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Range.hs0000644000000000000000000002657207346545000022677 0ustar0000000000000000{-# 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 #-} postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/SqlQQ.hs0000644000000000000000000000675707346545000022647 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TemplateHaskellQuotes #-} #else {-# LANGUAGE TemplateHaskell #-} #endif ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.SqlQQ -- Copyright: (c) 2011-2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- ------------------------------------------------------------------------------ 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: -- -- > {-# LANGUAGE QuasiQuotes #-} -- > -- > query conn [sql| SELECT column_a, column_b -- > FROM table1 NATURAL JOIN table2 -- > WHERE ? <= time AND time < ? -- > AND name LIKE ? -- > ORDER BY size DESC -- > LIMIT 100 |] -- > (beginTime,endTime,string) -- -- 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 -- preserved as-is. It does preserve whitespace inside standard SQL string -- literals. But it can get confused by the non-standard PostgreSQL string -- literal syntax (which is the default setting in PostgreSQL 8 and below), -- the extended escape string syntax, quoted identifiers, and other similar -- constructs. -- -- Of course, this caveat only applies to text written inside the SQL -- quasiquoter; whitespace reduction is a compile-time computation and -- thus will not touch the @string@ parameter above, which is a run-time -- value. -- -- Also note that this will not work if the substring @|]@ is contained -- in the query. 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" , quoteExp = sqlExp , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in declaration context" } sqlExp :: String -> Q Exp sqlExp = appE [| fromString :: String -> Query |] . stringE . minimizeSpace minimizeSpace :: String -> String minimizeSpace = drop 1 . reduceSpace where needsReduced [] = False needsReduced ('-':'-':_) = True needsReduced (x:_) = isSpace x reduceSpace xs = case dropWhile isSpace xs of [] -> [] ('-':'-':ys) -> reduceSpace (dropWhile (/= '\n') ys) ys -> ' ' : insql ys insql ('\'':xs) = '\'' : instring xs insql xs | needsReduced xs = reduceSpace xs insql (x:xs) = x : insql xs insql [] = [] 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" postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Time.hs0000644000000000000000000003006607346545000022532 0ustar0000000000000000{- | 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 , UTCTimestamp , ZonedTimestamp , LocalTimestamp , parseDay , parseUTCTime , parseZonedTime , parseLocalTime , parseTimeOfDay , parseDate , parseUTCTimestamp , parseZonedTimestamp , parseLocalTimestamp , parseCalendarDiffTime , dayToBuilder , utcTimeToBuilder , zonedTimeToBuilder , localTimeToBuilder , timeOfDayToBuilder , timeZoneToBuilder , dateToBuilder , utcTimestampToBuilder , zonedTimestampToBuilder , localTimestampToBuilder , unboundedToBuilder , nominalDiffTimeToBuilder , calendarDiffTimeToBuilder ) where import Database.PostgreSQL.Simple.Time.Implementation postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Time/0000755000000000000000000000000007346545000022171 5ustar0000000000000000postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Time/Implementation.hs0000644000000000000000000001352407346545000025517 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Time.Implementation -- Copyright: (c) 2012-2015 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- ------------------------------------------------------------------------------ {-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-} module Database.PostgreSQL.Simple.Time.Implementation where import Prelude hiding (take) import Data.ByteString.Builder(Builder, byteString) import Data.ByteString.Builder.Prim(primBounded) import Control.Arrow((***)) import Control.Applicative import qualified Data.ByteString as B import Data.Time.Compat (LocalTime, UTCTime, ZonedTime, Day, TimeOfDay, TimeZone, NominalDiffTime, utc) import Data.Time.LocalTime.Compat (CalendarDiffTime) import Data.Typeable import Data.Maybe (fromMaybe) import qualified Data.Attoparsec.ByteString.Char8 as A 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, Functor) instance Show a => Show (Unbounded a) where showsPrec prec x rest = case x of NegInfinity -> "-infinity" <> rest Finite time -> showsPrec prec time rest PosInfinity -> "infinity" <> rest instance Read a => Read (Unbounded a) where readsPrec prec = readParen False $ \str -> case str of ('-':'i':'n':'f':'i':'n':'i':'t':'y':xs) -> [(NegInfinity,xs)] ( 'i':'n':'f':'i':'n':'i':'t':'y':xs) -> [(PosInfinity,xs)] xs -> map (Finite *** id) (readsPrec prec xs) type LocalTimestamp = Unbounded LocalTime type UTCTimestamp = Unbounded UTCTime type ZonedTimestamp = Unbounded ZonedTime type Date = Unbounded Day parseUTCTime :: B.ByteString -> Either String UTCTime parseUTCTime = A.parseOnly (getUTCTime <* A.endOfInput) parseZonedTime :: B.ByteString -> Either String ZonedTime parseZonedTime = A.parseOnly (getZonedTime <* A.endOfInput) parseLocalTime :: B.ByteString -> Either String LocalTime parseLocalTime = A.parseOnly (getLocalTime <* A.endOfInput) parseDay :: B.ByteString -> Either String Day parseDay = A.parseOnly (getDay <* A.endOfInput) parseTimeOfDay :: B.ByteString -> Either String TimeOfDay parseTimeOfDay = A.parseOnly (getTimeOfDay <* A.endOfInput) parseUTCTimestamp :: B.ByteString -> Either String UTCTimestamp parseUTCTimestamp = A.parseOnly (getUTCTimestamp <* A.endOfInput) parseZonedTimestamp :: B.ByteString -> Either String ZonedTimestamp parseZonedTimestamp = A.parseOnly (getZonedTimestamp <* A.endOfInput) parseLocalTimestamp :: B.ByteString -> Either String LocalTimestamp parseLocalTimestamp = A.parseOnly (getLocalTimestamp <* A.endOfInput) 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") <|> (pure PosInfinity <* A.string "infinity") <|> (Finite <$> getFinite) getDay :: A.Parser Day getDay = TP.day getDate :: A.Parser Date getDate = getUnbounded getDay getTimeOfDay :: A.Parser TimeOfDay getTimeOfDay = TP.timeOfDay getLocalTime :: A.Parser LocalTime getLocalTime = TP.localTime getLocalTimestamp :: A.Parser LocalTimestamp getLocalTimestamp = getUnbounded getLocalTime getTimeZone :: A.Parser TimeZone 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 = TP.zonedTime getZonedTimestamp :: A.Parser ZonedTimestamp getZonedTimestamp = getUnbounded getZonedTime getUTCTime :: A.Parser UTCTime getUTCTime = TP.utcTime getUTCTimestamp :: A.Parser UTCTimestamp getUTCTimestamp = getUnbounded getUTCTime getCalendarDiffTime :: A.Parser CalendarDiffTime getCalendarDiffTime = TP.calendarDiffTime dayToBuilder :: Day -> Builder dayToBuilder = primBounded TPP.day timeOfDayToBuilder :: TimeOfDay -> Builder timeOfDayToBuilder = primBounded TPP.timeOfDay timeZoneToBuilder :: TimeZone -> Builder timeZoneToBuilder = primBounded TPP.timeZone utcTimeToBuilder :: UTCTime -> Builder utcTimeToBuilder = primBounded TPP.utcTime zonedTimeToBuilder :: ZonedTime -> Builder zonedTimeToBuilder = primBounded TPP.zonedTime localTimeToBuilder :: LocalTime -> Builder localTimeToBuilder = primBounded TPP.localTime unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder) unboundedToBuilder finiteToBuilder unbounded = case unbounded of NegInfinity -> byteString "-infinity" Finite a -> finiteToBuilder a PosInfinity -> byteString "infinity" utcTimestampToBuilder :: UTCTimestamp -> Builder utcTimestampToBuilder = unboundedToBuilder utcTimeToBuilder zonedTimestampToBuilder :: ZonedTimestamp -> Builder zonedTimestampToBuilder = unboundedToBuilder zonedTimeToBuilder localTimestampToBuilder :: LocalTimestamp -> Builder localTimestampToBuilder = unboundedToBuilder localTimeToBuilder dateToBuilder :: Date -> Builder dateToBuilder = unboundedToBuilder dayToBuilder nominalDiffTimeToBuilder :: NominalDiffTime -> Builder nominalDiffTimeToBuilder = TPP.nominalDiffTime calendarDiffTimeToBuilder :: CalendarDiffTime -> Builder calendarDiffTimeToBuilder = TPP.calendarDiffTime postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Time/Internal.hs0000644000000000000000000000136107346545000024302 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Time.Internal -- Copyright: (c) 2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.Time.Internal ( getDay , getDate , getTimeOfDay , getLocalTime , getLocalTimestamp , getTimeZone , getZonedTime , getZonedTimestamp , getUTCTime , getUTCTimestamp , TimeZoneHMS , getTimeZoneHMS , localToUTCTimeOfDayHMS ) where import Database.PostgreSQL.Simple.Time.Implementation postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Time/Internal/0000755000000000000000000000000007346545000023745 5ustar0000000000000000postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs0000644000000000000000000001467107346545000025546 0ustar0000000000000000{-# 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 postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs0000644000000000000000000001077507346545000025736 0ustar0000000000000000{-# 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 postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/ToField.hs0000644000000000000000000003206507346545000023163 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE PolyKinds #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.ToField -- Copyright: (c) 2011 MailRank, Inc. -- (c) 2011-2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- The 'ToField' typeclass, for rendering a parameter to a SQL query. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.ToField ( Action(..) , ToField(..) , toJSONField , inQuotes ) where import Control.Applicative (Const(Const)) import qualified Data.Aeson as JSON 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.Compat (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime) import Data.Time.LocalTime.Compat (CalendarDiffTime) import Data.Typeable (Typeable) import Data.Word (Word, Word8, Word16, Word32, Word64) import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow 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 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) #if MIN_VERSION_scientific(0,3,0) import Data.Text.Lazy.Builder.Scientific (scientificBuilder) #else import Data.Scientific (scientificBuilder) #endif import Foreign.C.Types (CUInt(..)) -- | How to render an element when substituting it into a query. 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. 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 (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 toField :: a -> Action -- ^ Prepare a value for substitution into a query string. instance ToField Action where 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 $ byteString "(null)" toField (In xs) = Many $ Plain (char8 '(') : (intersperse (Plain (char8 ',')) . map toField $ xs) ++ [Plain (char8 ')')] renderNull :: Action renderNull = Plain (byteString "null") instance ToField Null where toField _ = renderNull {-# INLINE toField #-} instance ToField Default where toField _ = Plain (byteString "default") {-# INLINE toField #-} instance ToField Bool where toField True = Plain (byteString "true") toField False = Plain (byteString "false") {-# INLINE toField #-} instance ToField Int8 where toField = Plain . int8Dec {-# INLINE toField #-} instance ToField Int16 where toField = Plain . int16Dec {-# INLINE toField #-} instance ToField Int32 where toField = Plain . int32Dec {-# INLINE toField #-} instance ToField Int where toField = Plain . intDec {-# INLINE toField #-} instance ToField Int64 where toField = Plain . int64Dec {-# INLINE toField #-} instance ToField Integer where toField = Plain . integerDec {-# INLINE toField #-} instance ToField Word8 where toField = Plain . word8Dec {-# INLINE toField #-} instance ToField Word16 where toField = Plain . word16Dec {-# INLINE toField #-} instance ToField Word32 where toField = Plain . word32Dec {-# INLINE toField #-} instance ToField Word where toField = Plain . wordDec {-# INLINE toField #-} instance ToField Word64 where toField = Plain . word64Dec {-# INLINE toField #-} instance ToField PQ.Oid where toField = Plain . \(PQ.Oid (CUInt x)) -> word32Dec x {-# INLINE toField #-} instance ToField Float where 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 (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 #-} instance ToField (Binary LB.ByteString) where 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 #-} instance ToField LB.ByteString where toField = toField . SB.concat . LB.toChunks {-# INLINE toField #-} instance ToField ST.Text where toField = Escape . ST.encodeUtf8 {-# INLINE toField #-} instance ToField [Char] where 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 #-} instance ToField ZonedTime where toField = Plain . inQuotes . zonedTimeToBuilder {-# INLINE toField #-} instance ToField LocalTime where toField = Plain . inQuotes . localTimeToBuilder {-# INLINE toField #-} instance ToField Day where toField = Plain . inQuotes . dayToBuilder {-# INLINE toField #-} instance ToField TimeOfDay where toField = Plain . inQuotes . timeOfDayToBuilder {-# INLINE toField #-} instance ToField UTCTimestamp where toField = Plain . inQuotes . utcTimestampToBuilder {-# INLINE toField #-} instance ToField ZonedTimestamp where toField = Plain . inQuotes . zonedTimestampToBuilder {-# INLINE toField #-} instance ToField LocalTimestamp where toField = Plain . inQuotes . localTimestampToBuilder {-# INLINE toField #-} instance ToField Date where 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 = toField . PGArray . V.toList instance ToField UUID where toField = Plain . inQuotes . byteString . UUID.toASCIIBytes instance ToField JSON.Value where toField = toField . JSON.encode -- | 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.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 = 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 postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/ToField.hs-boot0000644000000000000000000000220507346545000024115 0ustar0000000000000000module 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 instance ToField Oid postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/ToRow.hs0000644000000000000000000002221507346545000022703 0ustar0000000000000000{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.ToRow -- Copyright: (c) 2011 MailRank, Inc. -- (c) 2011-2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- The 'ToRow' typeclass, for rendering a collection of -- parameters to a SQL query. -- -- Predefined instances are provided for tuples containing up to ten -- elements. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.ToRow ( ToRow(..) ) where 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 '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 toRow _ = [] instance (ToField a) => ToRow (Only a) where toRow (Only v) = [toField v] instance (ToField a, ToField b) => ToRow (a,b) where toRow (a,b) = [toField a, toField b] instance (ToField a, ToField b, ToField c) => ToRow (a,b,c) where toRow (a,b,c) = [toField a, toField b, toField c] instance (ToField a, ToField b, ToField c, ToField d) => ToRow (a,b,c,d) where toRow (a,b,c,d) = [toField a, toField b, toField c, toField d] instance (ToField a, ToField b, ToField c, ToField d, ToField e) => ToRow (a,b,c,d,e) where toRow (a,b,c,d,e) = [toField a, toField b, toField c, toField d, toField e] instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f) => ToRow (a,b,c,d,e,f) where toRow (a,b,c,d,e,f) = [toField a, toField b, toField c, toField d, toField e, toField f] instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g) => ToRow (a,b,c,d,e,f,g) where toRow (a,b,c,d,e,f,g) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g] instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h) => ToRow (a,b,c,d,e,f,g,h) where toRow (a,b,c,d,e,f,g,h) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h] instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i) => ToRow (a,b,c,d,e,f,g,h,i) where toRow (a,b,c,d,e,f,g,h,i) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h, toField i] instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j) => ToRow (a,b,c,d,e,f,g,h,i,j) where toRow (a,b,c,d,e,f,g,h,i,j) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h, toField i, toField j] instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j, ToField k) => ToRow (a,b,c,d,e,f,g,h,i,j,k) where toRow (a,b,c,d,e,f,g,h,i,j,k) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h, toField i, toField j, toField k] instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j, ToField k, ToField l) => ToRow (a,b,c,d,e,f,g,h,i,j,k,l) where toRow (a,b,c,d,e,f,g,h,i,j,k,l) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h, toField i, toField j, toField k, toField l] instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j, ToField k, ToField l, ToField m) => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m) where toRow (a,b,c,d,e,f,g,h,i,j,k,l,m) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h, toField i, toField j, toField k, toField l, toField m] instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j, ToField k, ToField l, ToField m, ToField n) => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h, toField i, toField j, toField k, toField l, toField m, toField n] instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j, ToField k, ToField l, ToField m, ToField n, ToField o) => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h, toField i, toField j, toField k, toField l, toField m, toField n, toField o] instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j, ToField k, ToField l, ToField m, ToField n, ToField o, ToField p) => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h, toField i, toField j, toField k, toField l, toField m, toField n, toField o, toField p] instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j, ToField k, ToField l, ToField m, ToField n, ToField o, ToField p, ToField q) => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) where toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h, toField i, toField j, toField k, toField l, toField m, toField n, toField o, toField p, toField q] instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j, ToField k, ToField l, ToField m, ToField n, ToField o, ToField p, ToField q, ToField r) => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) where toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h, toField i, toField j, toField k, toField l, toField m, toField n, toField o, toField p, toField q, toField r] instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j, ToField k, ToField l, ToField m, ToField n, ToField o, ToField p, ToField q, ToField r, ToField s) => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) where toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h, toField i, toField j, toField k, toField l, toField m, toField n, toField o, toField p, toField q, toField r, toField s] instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j, ToField k, ToField l, ToField m, ToField n, ToField o, ToField p, ToField q, ToField r, ToField s, ToField t) => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) where toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h, toField i, toField j, toField k, toField l, toField m, toField n, toField o, toField p, toField q, toField r, toField s, toField t] instance (ToField a) => ToRow [a] where toRow = map toField 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 _ = [] postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/ToRow.hs-boot0000644000000000000000000000075207346545000023646 0ustar0000000000000000{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-} module Database.PostgreSQL.Simple.ToRow ( ToRow(..) ) where import Database.PostgreSQL.Simple.Types import {-# SOURCE #-} Database.PostgreSQL.Simple.ToField import GHC.Generics class ToRow a where toRow :: a -> [Action] default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action] toRow = gtoRow . from class GToRow f where gtoRow :: f p -> [Action] instance ToField a => ToRow (Only a) postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Transaction.hs0000644000000000000000000002346107346545000024122 0ustar0000000000000000{-# 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 withTransaction , withTransactionLevel , withTransactionMode , withTransactionModeRetry , withTransactionModeRetry' , withTransactionSerializable , TransactionMode(..) , IsolationLevel(..) , ReadWriteMode(..) , defaultTransactionMode , defaultIsolationLevel , defaultReadWriteMode -- , Base.autocommit , begin , beginLevel , beginMode , commit , rollback -- * Savepoint , withSavepoint , Savepoint , newSavepoint , releaseSavepoint , rollbackToSavepoint , rollbackToAndReleaseSavepoint -- * Error predicates , isSerializationError , isNoActiveTransactionError , isFailedTransactionError ) where import qualified Control.Exception as E import qualified Data.ByteString as B import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Types import Database.PostgreSQL.Simple.Errors import Database.PostgreSQL.Simple.Compat (mask, (<>)) -- | Of the four isolation levels defined by the SQL standard, -- these are the three levels distinguished by PostgreSQL as of version 9.0. -- See -- for more information. Note that prior to PostgreSQL 9.0, 'RepeatableRead' -- was equivalent to 'Serializable'. data IsolationLevel = DefaultIsolationLevel -- ^ the isolation level will be taken from -- PostgreSQL's per-connection -- @default_transaction_isolation@ variable, -- which is initialized according to the -- server's config. The default configuration -- is 'ReadCommitted'. | ReadCommitted | RepeatableRead | Serializable deriving (Show, Eq, Ord, Enum, Bounded) data ReadWriteMode = DefaultReadWriteMode -- ^ the read-write mode will be taken from -- PostgreSQL's per-connection -- @default_transaction_read_only@ variable, -- which is initialized according to the -- server's config. The default configuration -- is 'ReadWrite'. | ReadWrite | ReadOnly deriving (Show, Eq, Ord, Enum, Bounded) data TransactionMode = TransactionMode { isolationLevel :: !IsolationLevel, readWriteMode :: !ReadWriteMode } deriving (Show, Eq) defaultTransactionMode :: TransactionMode defaultTransactionMode = TransactionMode defaultIsolationLevel defaultReadWriteMode defaultIsolationLevel :: IsolationLevel defaultIsolationLevel = DefaultIsolationLevel defaultReadWriteMode :: ReadWriteMode defaultReadWriteMode = DefaultReadWriteMode -- | Execute an action inside a SQL transaction. -- -- This function initiates a transaction with a \"@begin -- transaction@\" statement, then executes the supplied action. If -- the action succeeds, the transaction will be completed with -- 'Base.commit' before this function returns. -- -- If the action throws /any/ kind of exception (not just a -- PostgreSQL-related exception), the transaction will be rolled back using -- 'rollback', then the exception will be rethrown. -- -- For nesting transactions, see 'withSavepoint'. withTransaction :: Connection -> IO a -> IO a withTransaction = withTransactionMode defaultTransactionMode -- | Execute an action inside of a 'Serializable' transaction. If a -- serialization failure occurs, roll back the transaction and try again. -- Be warned that this may execute the IO action multiple times. -- -- A 'Serializable' transaction creates the illusion that your program has -- exclusive access to the database. This means that, even in a concurrent -- setting, you can perform queries in sequence without having to worry about -- what might happen between one statement and the next. -- -- Think of it as STM, but without @retry@. withTransactionSerializable :: Connection -> IO a -> IO a withTransactionSerializable = withTransactionModeRetry TransactionMode { isolationLevel = Serializable , readWriteMode = ReadWrite } isSerializationError -- | Execute an action inside a SQL transaction with a given isolation level. withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a withTransactionLevel lvl = withTransactionMode defaultTransactionMode { isolationLevel = lvl } -- | Execute an action inside a SQL transaction with a given transaction mode. withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a withTransactionMode mode conn act = mask $ \restore -> do beginMode mode 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 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' :: 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 `E.onException` rollback_ conn commit conn return a where retryLoop :: IO (Either e a) -> IO a retryLoop act' = do beginMode mode conn r <- act' case r of 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 "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 () -- | Begin a transaction. begin :: Connection -> IO () begin = beginMode defaultTransactionMode -- | Begin a transaction with a given isolation level beginLevel :: IsolationLevel -> Connection -> IO () beginLevel lvl = beginMode defaultTransactionMode { isolationLevel = lvl } -- | Begin a transaction with a given transaction mode beginMode :: TransactionMode -> Connection -> IO () beginMode mode conn = do _ <- execute_ conn $! Query (B.concat ["BEGIN", isolevel, readmode]) return () where isolevel = case isolationLevel mode of DefaultIsolationLevel -> "" ReadCommitted -> " ISOLATION LEVEL READ COMMITTED" RepeatableRead -> " ISOLATION LEVEL REPEATABLE READ" Serializable -> " ISOLATION LEVEL SERIALIZABLE" readmode = case readWriteMode mode of DefaultReadWriteMode -> "" ReadWrite -> " READ WRITE" ReadOnly -> " READ ONLY" ------------------------------------------------------------------------ -- Savepoint -- | Create a savepoint, and roll back to it if an error occurs. This may only -- be used inside of a transaction, and provides a sort of -- \"nested transaction\". -- -- See withSavepoint :: Connection -> IO a -> IO a withSavepoint conn body = mask $ \restore -> do sp <- newSavepoint conn r <- restore body `E.onException` rollbackToAndReleaseSavepoint conn sp releaseSavepoint conn sp `E.catch` \err -> if isFailedTransactionError err then rollbackToAndReleaseSavepoint conn sp else E.throwIO err return r -- | Create a new savepoint. This may only be used inside of a transaction. newSavepoint :: Connection -> IO Savepoint newSavepoint conn = do name <- newTempName conn _ <- execute_ conn ("SAVEPOINT " <> name) return (Savepoint name) -- | Destroy a savepoint, but retain its effects. -- -- Warning: this will throw a 'SqlError' matching 'isFailedTransactionError' if -- the transaction is aborted due to an error. 'commit' would merely warn and -- roll back. releaseSavepoint :: Connection -> Savepoint -> IO () releaseSavepoint conn (Savepoint name) = execute_ conn ("RELEASE SAVEPOINT " <> name) >> return () -- | Roll back to a savepoint. This will not release the savepoint. rollbackToSavepoint :: Connection -> Savepoint -> IO () rollbackToSavepoint conn (Savepoint name) = execute_ conn ("ROLLBACK TO SAVEPOINT " <> name) >> return () -- | Roll back to a savepoint and release it. This is like calling -- 'rollbackToSavepoint' followed by 'releaseSavepoint', but avoids a -- round trip to the database server. rollbackToAndReleaseSavepoint :: Connection -> Savepoint -> IO () rollbackToAndReleaseSavepoint conn (Savepoint name) = execute_ conn sql >> return () where sql = "ROLLBACK TO SAVEPOINT " <> name <> "; RELEASE SAVEPOINT " <> name postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/TypeInfo.hs0000644000000000000000000001253007346545000023365 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.TypeInfo -- Copyright: (c) 2013 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- This module provides convenient and efficient access to parts of the -- @pg_type@ metatable. At the moment, this requires PostgreSQL 8.4 if -- you need to work with types that do not appear in -- 'Database.PostgreSQL.Simple.TypeInfo.Static'. -- -- The current scheme could be more efficient, especially for some use -- cases. In particular, connection pools that use many user-added -- types and connect to a set of servers with identical (or at least -- compatible) @pg_type@ and associated tables could share a common -- typeinfo cache, thus saving memory and communication between the -- client and server. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.TypeInfo ( getTypeInfo , TypeInfo(..) , Attribute(..) ) where import qualified Data.ByteString as B import qualified Data.IntMap as IntMap import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV import Control.Concurrent.MVar import Control.Exception (throw) import qualified Database.PostgreSQL.LibPQ as PQ import {-# SOURCE #-} Database.PostgreSQL.Simple import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Types import Database.PostgreSQL.Simple.TypeInfo.Types import Database.PostgreSQL.Simple.TypeInfo.Static -- | Returns the metadata of the type with a particular oid. To find -- this data, 'getTypeInfo' first consults postgresql-simple's -- built-in 'staticTypeInfo' table, then checks the connection's -- typeinfo cache. Finally, the database's 'pg_type' table will -- be queried only if necessary, and the result will be stored -- 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' :: Connection -> PQ.Oid -> TypeInfoCache -> IO (TypeInfoCache, TypeInfo) 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') (oidmap', typeInfo) <- case names of [] -> return $ throw (fatalError "invalid type oid") [(typoid, typcategory, typdelim, typname, typelem_, typrelid)] -> do case typcategory of 'A' -> do (oidmap', typelem) <- getTypeInfo' conn typelem_ oidmap let !typeInfo = Array{..} return $! (oidmap', typeInfo) 'R' -> do rngsubtypeOids <- query conn "SELECT rngsubtype\ \ FROM pg_range\ \ WHERE rngtypid = ?" (Only oid') case rngsubtypeOids of [Only rngsubtype_] -> do (oidmap', rngsubtype) <- getTypeInfo' conn rngsubtype_ oidmap let !typeInfo = Range{..} return $! (oidmap', typeInfo) _ -> fail "range subtype query failed to return exactly one result" 'C' -> do cols <- query conn "SELECT attname, atttypid\ \ FROM pg_attribute\ \ WHERE attrelid = ?\ \ AND attnum > 0\ \ AND NOT attisdropped\ \ ORDER BY attnum" (Only typrelid) vec <- MV.new $! length cols (oidmap', attributes) <- getAttInfos conn cols oidmap vec 0 let !typeInfo = Composite{..} return $! (oidmap', typeInfo) _ -> do let !typeInfo = Basic{..} return $! (oidmap, typeInfo) _ -> 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' return $! (oidmap'', typeInfo) getAttInfos :: Connection -> [(B.ByteString, PQ.Oid)] -> TypeInfoCache -> MV.IOVector Attribute -> Int -> IO (TypeInfoCache, V.Vector Attribute) getAttInfos conn cols oidmap vec n = case cols of [] -> do !attributes <- V.unsafeFreeze vec return $! (oidmap, attributes) ((attname, attTypeOid):xs) -> do (oidmap', atttype) <- getTypeInfo' conn attTypeOid oidmap MV.write vec n $! Attribute{..} getAttInfos conn xs oidmap' vec (n+1) postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/TypeInfo/0000755000000000000000000000000007346545000023030 5ustar0000000000000000postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs0000644000000000000000000000327107346545000024430 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TemplateHaskellQuotes #-} #else {-# LANGUAGE TemplateHaskell #-} #endif ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.TypeInfo.Macro -- Copyright: (c) 2013 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- A Template Haskell macro for efficiently checking membership in -- a set of type oids. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.TypeInfo.Macro ( mkCompats , inlineTypoid ) where import Database.PostgreSQL.Simple.TypeInfo.Static 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 = 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 |]) [] catchAll :: MatchQ catchAll = match wildP (normalB [| False |]) [] -- | Literally substitute the 'typoid' of a 'TypeInfo' expression. -- Returns an expression of type 'Oid'. Useful because GHC tends -- not to fold constants. inlineTypoid :: TypeInfo -> ExpQ inlineTypoid ty = conE 'Oid `appE` litE (getTypoid ty) inlineTypoidP :: TypeInfo -> PatQ inlineTypoidP ty = litP (getTypoid ty) getTypoid :: TypeInfo -> Lit getTypoid ty = let (Oid x) = typoid ty in integerL (fromIntegral x) postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs0000644000000000000000000010470707346545000024624 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.TypeInfo -- Copyright: (c) 2011-2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- This module contains portions of the @pg_type@ table that are relevant -- to postgresql-simple and are believed to not change between PostgreSQL -- versions. -- ------------------------------------------------------------------------------ -- Note that this file is generated by tools/GenTypeInfo.hs, and should -- not be edited directly module Database.PostgreSQL.Simple.TypeInfo.Static ( TypeInfo(..) , staticTypeInfo , bool , boolOid , bytea , byteaOid , char , charOid , name , nameOid , int8 , int8Oid , int2 , int2Oid , int4 , int4Oid , regproc , regprocOid , text , textOid , oid , oidOid , tid , tidOid , xid , xidOid , cid , cidOid , xml , xmlOid , point , pointOid , lseg , lsegOid , path , pathOid , box , boxOid , polygon , polygonOid , line , lineOid , cidr , cidrOid , float4 , float4Oid , float8 , float8Oid , unknown , unknownOid , circle , circleOid , money , moneyOid , macaddr , macaddrOid , inet , inetOid , bpchar , bpcharOid , varchar , varcharOid , date , dateOid , time , timeOid , timestamp , timestampOid , timestamptz , timestamptzOid , interval , intervalOid , timetz , timetzOid , bit , bitOid , varbit , varbitOid , numeric , numericOid , refcursor , refcursorOid , record , recordOid , void , voidOid , array_record , array_recordOid , regprocedure , regprocedureOid , regoper , regoperOid , regoperator , regoperatorOid , regclass , regclassOid , regtype , regtypeOid , uuid , uuidOid , json , jsonOid , jsonb , jsonbOid , int2vector , int2vectorOid , oidvector , oidvectorOid , array_xml , array_xmlOid , array_json , array_jsonOid , array_line , array_lineOid , array_cidr , array_cidrOid , array_circle , array_circleOid , array_money , array_moneyOid , array_bool , array_boolOid , array_bytea , array_byteaOid , array_char , array_charOid , array_name , array_nameOid , array_int2 , array_int2Oid , array_int2vector , array_int2vectorOid , array_int4 , array_int4Oid , array_regproc , array_regprocOid , array_text , array_textOid , array_tid , array_tidOid , array_xid , array_xidOid , array_cid , array_cidOid , array_oidvector , array_oidvectorOid , array_bpchar , array_bpcharOid , array_varchar , array_varcharOid , array_int8 , array_int8Oid , array_point , array_pointOid , array_lseg , array_lsegOid , array_path , array_pathOid , array_box , array_boxOid , array_float4 , array_float4Oid , array_float8 , array_float8Oid , array_polygon , array_polygonOid , array_oid , array_oidOid , array_macaddr , array_macaddrOid , array_inet , array_inetOid , array_timestamp , array_timestampOid , array_date , array_dateOid , array_time , array_timeOid , array_timestamptz , array_timestamptzOid , array_interval , array_intervalOid , array_numeric , array_numericOid , array_timetz , array_timetzOid , array_bit , array_bitOid , array_varbit , array_varbitOid , array_refcursor , array_refcursorOid , array_regprocedure , array_regprocedureOid , array_regoper , array_regoperOid , array_regoperator , array_regoperatorOid , array_regclass , array_regclassOid , array_regtype , array_regtypeOid , array_uuid , array_uuidOid , array_jsonb , array_jsonbOid , int4range , int4rangeOid , _int4range , _int4rangeOid , numrange , numrangeOid , _numrange , _numrangeOid , tsrange , tsrangeOid , _tsrange , _tsrangeOid , tstzrange , tstzrangeOid , _tstzrange , _tstzrangeOid , daterange , daterangeOid , _daterange , _daterangeOid , int8range , int8rangeOid , _int8range , _int8rangeOid ) where import Database.PostgreSQL.LibPQ (Oid(..)) 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 #-} postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/TypeInfo/Types.hs0000644000000000000000000000340207346545000024467 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.TypeInfo.Types -- Copyright: (c) 2013 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.TypeInfo.Types where import Data.ByteString(ByteString) import Database.PostgreSQL.LibPQ(Oid) import Data.Vector(Vector) -- | A structure representing some of the metadata regarding a PostgreSQL -- type, mostly taken from the @pg_type@ table. data TypeInfo = Basic { typoid :: {-# UNPACK #-} !Oid , typcategory :: {-# UNPACK #-} !Char , typdelim :: {-# UNPACK #-} !Char , typname :: !ByteString } | Array { typoid :: {-# UNPACK #-} !Oid , typcategory :: {-# UNPACK #-} !Char , typdelim :: {-# UNPACK #-} !Char , typname :: !ByteString , typelem :: !TypeInfo } | Range { typoid :: {-# UNPACK #-} !Oid , typcategory :: {-# UNPACK #-} !Char , typdelim :: {-# UNPACK #-} !Char , typname :: !ByteString , rngsubtype :: !TypeInfo } | Composite { typoid :: {-# UNPACK #-} !Oid , typcategory :: {-# UNPACK #-} !Char , typdelim :: {-# UNPACK #-} !Char , typname :: !ByteString , typrelid :: {-# UNPACK #-} !Oid , attributes :: !(Vector Attribute) } deriving (Show) data Attribute = Attribute { attname :: !ByteString , atttype :: !TypeInfo } deriving (Show) postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Types.hs0000644000000000000000000002314207346545000022735 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Types -- Copyright: (c) 2011 MailRank, Inc. -- (c) 2011-2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- Basic types. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.Types ( Null(..) , Default(..) , Only(..) , In(..) , Binary(..) , Identifier(..) , QualifiedIdentifier(..) , Query(..) , Oid(..) , (:.)(..) , Savepoint(..) , PGArray(..) , Values(..) ) where 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 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) -- | A query string. This type is intended to make it difficult to -- construct a SQL query by concatenating string fragments, as that is -- an extremely common way to accidentally introduce SQL injection -- vulnerabilities into an application. -- -- This type is an instance of 'IsString', so the easiest way to -- construct a query is to enable the @OverloadedStrings@ language -- extension and then simply write the query in double quotes. -- -- > {-# LANGUAGE OverloadedStrings #-} -- > -- > import Database.PostgreSQL.Simple -- > -- > q :: Query -- > q = "select ?" -- -- The underlying type is a 'ByteString', and literal Haskell strings -- that contain Unicode characters will be correctly transformed to -- UTF-8. newtype Query = Query { fromQuery :: ByteString } deriving (Eq, Ord, Typeable) instance Show Query where show = show . fromQuery instance Read Query where readsPrec i = fmap (first Query) . readsPrec i instance IsString Query where 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 #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif -- | Wrap a list of values for use in an @IN@ clause. Replaces a -- single \"@?@\" character with a parenthesized list of rendered -- values. -- -- 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) -- | Wrap binary data for use as a @bytea@ value. 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. -- -- -- > instance FromRow MyData where ... -- -- > instance FromRow MyData2 where ... -- -- -- then I can do the following for free: -- -- @ -- res <- query' c "..." -- forM res $ \\(MyData{..} :. MyData2{..}) -> do -- .... -- @ data h :. t = h :. t deriving (Eq,Ord,Show,Read,Typeable) 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) postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Vector.hs0000644000000000000000000000377307346545000023103 0ustar0000000000000000-- | '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 postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Vector/0000755000000000000000000000000007346545000022535 5ustar0000000000000000postgresql-simple-0.6.5.1/src/Database/PostgreSQL/Simple/Vector/Unboxed.hs0000644000000000000000000000406607346545000024503 0ustar0000000000000000module 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 postgresql-simple-0.6.5.1/test/0000755000000000000000000000000007346545000014523 5ustar0000000000000000postgresql-simple-0.6.5.1/test/Common.hs0000644000000000000000000000162107346545000016307 0ustar0000000000000000module Common ( module Database.PostgreSQL.Simple, module Test.Tasty.HUnit, TestEnv(..), md5, ) where import Data.ByteString (ByteString) import Data.Text (Text) import Database.PostgreSQL.Simple import Test.Tasty.HUnit import qualified Crypto.Hash.MD5 as MD5 import qualified Data.ByteString.Base16 as Base16 import qualified Data.Text.Encoding as TE data TestEnv = TestEnv { conn :: Connection -- ^ Connection shared by all the tests , withConn :: forall a. (Connection -> IO a) -> IO a -- ^ Bracket for spawning additional connections } -- | Return the MD5 hash of a 'ByteString', in lowercase hex format. -- -- Example: -- -- >[Only hash] <- query_ conn "SELECT md5('hi')" -- >assertEqual "md5('hi')" (md5 "hi") hash md5 :: ByteString -> Text md5 = TE.decodeUtf8 . Base16.encode . MD5.hash postgresql-simple-0.6.5.1/test/Inspection.hs0000644000000000000000000000460307346545000017175 0ustar0000000000000000{-# 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 ] postgresql-simple-0.6.5.1/test/Interval.hs0000644000000000000000000001147107346545000016647 0ustar0000000000000000{-# 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 postgresql-simple-0.6.5.1/test/Main.hs0000644000000000000000000005727207346545000015760 0ustar0000000000000000{-# 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.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 qualified Data.Text.Encoding as T import qualified Data.Vector as V 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 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 ] testBytea :: TestEnv -> TestTree testBytea TestEnv{..} = testGroup "Bytea" [ testStr "empty" [] , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String) , testStr "ascending" [0..255] , testStr "descending" [255,254..0] , testStr "ascending, doubled up" $ doubleUp [0..255] , testStr "descending, doubled up" $ doubleUp [255,254..0] ] where testStr label bytes = testCase label $ do let bs = B.pack bytes [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs] assertBool "Haskell -> SQL conversion altered the string" $ md5 bs == h [Only (Binary r)] <- query conn "SELECT ?::bytea" [Binary bs] assertBool "SQL -> Haskell conversion altered the string" $ bs == r doubleUp = concatMap (\x -> [x, x]) 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)] rows = [ (1, "hello", Binary "bye") , (2, "world", Binary "\0\r\t\n") , (3, "?", Binary "") ] count <- executeMany conn "INSERT INTO tmp_executeMany VALUES (?, ?, ?)" rows count @?= fromIntegral (length rows) rows' <- query_ conn "SELECT * FROM tmp_executeMany" rows' @?= rows return () 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]) ref <- newIORef [] forEach conn "SELECT * FROM generate_series(1,?) a, generate_series(1,?) b" (100 :: Int, 50 :: Int) $ \(a :: Int, b :: Int) -> do xs <- readIORef ref writeIORef ref $! (a,b):xs xs <- readIORef ref reverse xs @?= [(a,b) | b <- [1..50], a <- [1..100]] -- Make sure fold propagates our exception. ref <- newIORef [] True <- expectError (== TestException) $ forEach_ conn "SELECT generate_series(1,10)" $ \(Only a) -> if a == 5 then do -- Cause a SQL error to trip up CLOSE. True <- expectError isSyntaxError $ execute_ conn "asdf" True <- expectError ST.isFailedTransactionError $ (query_ conn "SELECT 1" :: IO [(Only Int)]) throwIO TestException else do xs <- readIORef ref writeIORef ref $! (a :: Int) : xs xs <- readIORef ref reverse xs @?= [1..4] withTransaction conn $ replicateM_ 2 $ do xs <- fold_ conn "VALUES (1), (2), (3), (4), (5)" [] $ \xs (Only x) -> return (x:xs) reverse xs @?= ([1..5] :: [Int]) ref <- newIORef [] forEach_ conn "SELECT generate_series(1,101)" $ \(Only a) -> forEach_ conn "SELECT generate_series(1,55)" $ \(Only b) -> do xs <- readIORef ref writeIORef ref $! (a :: Int, b :: Int) : xs xs <- readIORef ref reverse xs @?= [(a,b) | a <- [1..101], b <- [1..55]] xs <- fold_ conn "SELECT 1 WHERE FALSE" [] $ \xs (Only x) -> return (x:xs) xs @?= ([] :: [Int]) -- TODO: add more complete tests, e.g.: -- -- * Fold in a transaction -- -- * Fold in a transaction after a previous fold has been performed -- -- * Nested fold return () queryFailure :: forall a. (FromField a, Typeable a, Show a) => Connection -> Query -> a -> Assertion queryFailure conn q resultType = do x :: Either SomeException [Only a] <- E.try $ query_ conn q case x of Left _ -> return () Right val -> assertFailure ("Did not fail as expected: " ++ show q ++ " :: " ++ show (typeOf resultType) ++ " -> " ++ show val) 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" xs @?= [Only (V.fromList [V.fromList [1,2], V.fromList [3,4 :: Int]])] queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool) queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int) 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")] where roundTrip :: [(Text,Text)] -> Assertion roundTrip xs = do let m = Only (HStoreMap (Map.fromList xs)) m' <- query conn "SELECT ?::hstore" m [m] @?= m' testCIText :: TestEnv -> Assertion testCIText TestEnv{..} = do execute_ conn "CREATE EXTENSION IF NOT EXISTS citext" roundTrip (CI.mk "") roundTrip (CI.mk "UPPERCASE") roundTrip (CI.mk "lowercase") where roundTrip :: (CI Text) -> Assertion roundTrip cit = do let toPostgres = Only cit fromPostgres <- query conn "SELECT ?::citext" toPostgres [toPostgres] @?= fromPostgres testJSON :: TestEnv -> Assertion testJSON TestEnv{..} = do roundTrip (Map.fromList [] :: Map Text Text) 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 let js = Only (toJSON a) js' <- query conn "SELECT ?::json" js [js] @?= js' testAeson :: TestEnv -> Assertion testAeson TestEnv{..} = do roundTrip (Map.fromList [] :: Map Text Text) roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text) roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text) roundTrip (V.fromList [1,2,3,4,5::Int]) roundTrip ("foo" :: Text) roundTrip (42 :: Int) where roundTrip :: (Eq a, Show a, Typeable a, ToJSON a, FromJSON a)=> a -> Assertion roundTrip x = do y <- query conn "SELECT ?::json" (Only (Aeson x)) [Only (Aeson x)] @?= y testDerivingVia :: TestEnv -> Assertion testDerivingVia TestEnv{..} = do #if __GLASGOW_HASKELL__ <806 return () #else roundTrip $ DerivingVia1 42 "Meaning of Life" where roundTrip :: (Eq a, Show a, Typeable a, ToField a, FromField a)=> a -> Assertion roundTrip x = do y <- query conn "SELECT ?::json" (Only x) [Only x] @?= y data DerivingVia1 = DerivingVia1 Int String deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) deriving (ToField, FromField) via Aeson DerivingVia1 #endif testQM :: TestEnv -> Assertion testQM TestEnv{..} = do -- Just test on a single string let testQuery' b = "testing for ?" <> b <> " and making sure " testQueryDoubleQM = testQuery' "?" testQueryRest = "? is substituted" testQuery = fromString $ testQueryDoubleQM <> testQueryRest -- expect the entire first part with double QMs replaced with literal '?' expected = (fromString $ testQuery' "", fromString testQueryRest) tried = breakOnSingleQuestionMark testQuery errMsg = concat [ "Failed to break on single question mark exclusively:\n" , "expected: ", show expected , "result: ", show tried ] assertBool errMsg $ tried == expected -- Let's also test the question mark operators in action -- ? -> Does the string exist as a top-level key within the JSON value? positiveQuery "SELECT ?::jsonb ?? ?" (testObj, "foo" :: Text) negativeQuery "SELECT ?::jsonb ?? ?" (testObj, "baz" :: Text) negativeQuery "SELECT ?::jsonb ?? ?" (toJSON numArray, "1" :: Text) -- ?| -> Do any of these array strings exist as top-level keys? positiveQuery "SELECT ?::jsonb ??| ?" (testObj, PGArray ["nope","bar","6" :: Text]) negativeQuery "SELECT ?::jsonb ??| ?" (testObj, PGArray ["nope","6" :: Text]) negativeQuery "SELECT ?::jsonb ??| ?" (toJSON numArray, PGArray ["1","2","6" :: Text]) -- ?& -> Do all of these array strings exist as top-level keys? positiveQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar","quux" :: Text]) positiveQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar" :: Text]) negativeQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar","baz" :: Text]) negativeQuery "SELECT ?::jsonb ??& ?" (toJSON numArray, PGArray ["1","2","3","4","5" :: Text]) -- Format error for 2 question marks, not 4 True <- expectError (isFormatError 2) $ (query conn "SELECT ?::jsonb ?? ?" $ Only testObj :: IO [Only Bool]) return () where positiveQuery :: ToRow a => Query -> a -> Assertion positiveQuery = boolQuery True negativeQuery :: ToRow a => Query -> a -> Assertion negativeQuery = boolQuery False numArray :: [Int] numArray = [1,2,3,4,5] boolQuery :: ToRow a => Bool -> Query -> a -> Assertion boolQuery b t x = do a <- query conn t x [Only b] @?= a testObj = toJSON (Map.fromList [("foo",toJSON (1 :: Int)) ,("bar",String "baz") ,("quux",toJSON [1 :: Int,2,3,4,5])] :: Map Text Value ) testSavepoint :: TestEnv -> Assertion testSavepoint TestEnv{..} = do True <- expectError ST.isNoActiveTransactionError $ withSavepoint conn $ return () let getRows :: IO [Int] getRows = map fromOnly <$> query_ conn "SELECT a FROM tmp_savepoint ORDER BY a" withTransaction conn $ do execute_ conn "CREATE TEMPORARY TABLE tmp_savepoint (a INT UNIQUE)" execute_ conn "INSERT INTO tmp_savepoint VALUES (1)" [1] <- getRows withSavepoint conn $ do execute_ conn "INSERT INTO tmp_savepoint VALUES (2)" [1,2] <- getRows return () [1,2] <- getRows withSavepoint conn $ do execute_ conn "INSERT INTO tmp_savepoint VALUES (3)" [1,2,3] <- getRows True <- expectError isUniqueViolation $ execute_ conn "INSERT INTO tmp_savepoint VALUES (2)" True <- expectError ST.isFailedTransactionError getRows -- Body returning successfully after handling error, -- but 'withSavepoint' will roll back without complaining. return () -- Rolling back clears the error condition. [1,2] <- getRows -- 'withSavepoint' will roll back after an exception, even if the -- exception wasn't SQL-related. True <- expectError (== TestException) $ withSavepoint conn $ do execute_ conn "INSERT INTO tmp_savepoint VALUES (3)" [1,2,3] <- getRows throwIO TestException [1,2] <- getRows -- Nested savepoint can be rolled back while the -- outer effects are retained. withSavepoint conn $ do execute_ conn "INSERT INTO tmp_savepoint VALUES (3)" True <- expectError isUniqueViolation $ withSavepoint conn $ do execute_ conn "INSERT INTO tmp_savepoint VALUES (4)" [1,2,3,4] <- getRows execute_ conn "INSERT INTO tmp_savepoint VALUES (4)" [1,2,3] <- getRows return () [1,2,3] <- getRows return () -- Transaction committed successfully, even though there were errors -- (but we rolled them back). [1,2,3] <- getRows 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) instance Exception TestException expectError :: Exception e => (e -> Bool) -> IO a -> IO Bool expectError p io = (io >> return False) `E.catch` \ex -> if p ex then return True else throwIO ex isUniqueViolation :: SqlError -> Bool isUniqueViolation SqlError{..} = sqlState == "23505" 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. 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'" cb TestEnv { conn = conn , withConn = withConn } where withConn = bracket (connectPostgreSQL connstr) close main :: IO () 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" ] postgresql-simple-0.6.5.1/test/Notify.hs0000644000000000000000000000221307346545000016325 0ustar0000000000000000module Notify (testNotify) where import Common import Control.Applicative import Control.Concurrent import Control.Monad import Data.Function import Data.List import Database.PostgreSQL.Simple.Notification import qualified Data.ByteString as B -- TODO: Test with payload, but only for PostgreSQL >= 9.0 -- (when that feature was introduced). testNotify :: TestEnv -> Assertion testNotify TestEnv{..} = withConn $ \conn2 -> do execute_ conn "LISTEN foo" execute_ conn "LISTEN bar" results_mv <- newEmptyMVar forkIO $ replicateM 2 (getNotification conn) >>= putMVar results_mv threadDelay 100000 execute_ conn2 "NOTIFY foo" execute_ conn2 "NOTIFY bar" [n1, n2] <- sortBy (compare `on` notificationChannel) <$> takeMVar results_mv assertEqual "n1" "bar" (notificationChannel n1) assertEqual "n2" "foo" (notificationChannel n2) -- Other sanity checks assertEqual "Server PIDs match" (notificationPid n1) (notificationPid n2) assertBool "notificationData is empty" $ all (B.null . notificationData) [n1, n2] postgresql-simple-0.6.5.1/test/Serializable.hs0000644000000000000000000000444107346545000017470 0ustar0000000000000000module Serializable (testSerializable) where import Common import Control.Concurrent import Control.Exception as E import Data.IORef import Database.PostgreSQL.Simple.Transaction initCounter :: Connection -> IO () initCounter conn = do 0 <- execute_ conn "DROP TABLE IF EXISTS testSerializableCounter;\ \ CREATE TABLE testSerializableCounter (n INT)" 1 <- execute_ conn "INSERT INTO testSerializableCounter VALUES (0)" return () getCounter :: Connection -> IO Int getCounter conn = do [Only n] <- query_ conn "SELECT n FROM testSerializableCounter" return n putCounter :: Connection -> Int -> IO () putCounter conn n = do 1 <- execute conn "UPDATE testSerializableCounter SET n=?" (Only n) return () testSerializable :: TestEnv -> Assertion testSerializable TestEnv{..} = withConn $ \conn2 -> do initCounter conn attemptCounter <- newIORef (0 :: Int) readyToBother <- newEmptyMVar bothered <- newEmptyMVar finished <- newEmptyMVar _ <- forkIO $ do withTransactionSerializable conn2 $ do modifyIORef attemptCounter (+1) n <- getCounter conn2 True <- tryPutMVar readyToBother () readMVar bothered putCounter conn2 (n+1) putMVar finished () takeMVar readyToBother withTransactionSerializable conn $ do n <- getCounter conn putCounter conn (n+1) True <- tryPutMVar bothered () takeMVar finished ac <- readIORef attemptCounter assertEqual "attemptCounter" 2 ac ok <- E.catch (do withTransactionSerializable conn (fail "Whoops") return False) (\(_ :: IOException) -> return True) assertBool "Exceptions (besides serialization failure) should be\ \ propagated through withTransactionSerializable" ok -- Make sure transaction isn't dangling 1 <- execute_ conn "UPDATE testSerializableCounter SET n=12345" 0 <- execute_ conn "ROLLBACK" -- This prints "NOTICE: there is no transaction in progress" [Only (12345 :: Int)] <- query_ conn "SELECT n FROM testSerializableCounter" return () postgresql-simple-0.6.5.1/test/Time.hs0000644000000000000000000001034007346545000015753 0ustar0000000000000000{-# 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 Time (testTime) where import Common import Control.Monad(forM_, replicateM_) import Data.Time.Compat import Data.ByteString(ByteString) import Database.PostgreSQL.Simple.SqlQQ numTests :: Int numTests = 200 testTime :: TestEnv -> Assertion testTime env@TestEnv{..} = do initializeTable env execute_ conn "SET timezone TO 'UTC'" 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 ('1860-01-01 00:00:00+00'::timestamptz + ?::interval * ROUND(RANDOM() * ?)) |] (x,y) pop "1 microsecond" 6.3113904e15 pop "10 microseconds" 6.3113904e14 pop "100 microseconds" 6.3113904e13 pop "1 millisecond" 6.3113904e12 pop "10 milliseconds" 6.3113904e11 pop "100 milliseconds" 6.3113904e10 pop "1 second" 6.3113904e9 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] postgresql-simple-0.6.5.1/test/results/0000755000000000000000000000000007346545000016224 5ustar0000000000000000postgresql-simple-0.6.5.1/test/results/malformed-input.expected0000644000000000000000000000034507346545000023054 0ustar0000000000000000user 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" )postgresql-simple-0.6.5.1/test/results/unique-constraint-violation.expected0000644000000000000000000000045007346545000025440 0ustar0000000000000000user 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 )