pg (empty) → 0.5.2.1
raw patch · 44 files changed
+8419/−0 lines, 44 filesdep +HUnitdep +aesondep +attoparsecsetup-changed
Dependencies added: HUnit, aeson, attoparsec, base, base16-bytestring, bytestring, bytestring-builder, case-insensitive, containers, cryptohash, filepath, ghc-prim, hashable, pg, postgresql-libpq, scientific, tasty, tasty-golden, tasty-hunit, template-haskell, text, time, transformers, uuid-types, vector
Files
- CHANGELOG.md +22/−0
- CONTRIBUTORS +35/−0
- LICENSE +62/−0
- Setup.hs +2/−0
- pg.cabal +125/−0
- src/Database/PostgreSQL/Simple.hs +1001/−0
- src/Database/PostgreSQL/Simple.hs-boot +23/−0
- src/Database/PostgreSQL/Simple/Arrays.hs +92/−0
- src/Database/PostgreSQL/Simple/Compat.hs +94/−0
- src/Database/PostgreSQL/Simple/Copy.hs +241/−0
- src/Database/PostgreSQL/Simple/Errors.hs +139/−0
- src/Database/PostgreSQL/Simple/FromField.hs +654/−0
- src/Database/PostgreSQL/Simple/FromField.hs-boot +11/−0
- src/Database/PostgreSQL/Simple/FromRow.hs +280/−0
- src/Database/PostgreSQL/Simple/FromRow.hs-boot +17/−0
- src/Database/PostgreSQL/Simple/HStore.hs +36/−0
- src/Database/PostgreSQL/Simple/HStore/Implementation.hs +210/−0
- src/Database/PostgreSQL/Simple/HStore/Internal.hs +19/−0
- src/Database/PostgreSQL/Simple/Internal.hs +586/−0
- src/Database/PostgreSQL/Simple/LargeObjects.hs +97/−0
- src/Database/PostgreSQL/Simple/Notification.hs +162/−0
- src/Database/PostgreSQL/Simple/Ok.hs +87/−0
- src/Database/PostgreSQL/Simple/Range.hs +313/−0
- src/Database/PostgreSQL/Simple/SqlQQ.hs +89/−0
- src/Database/PostgreSQL/Simple/Time.hs +244/−0
- src/Database/PostgreSQL/Simple/Time/Implementation.hs +166/−0
- src/Database/PostgreSQL/Simple/Time/Internal.hs +27/−0
- src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs +195/−0
- src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs +123/−0
- src/Database/PostgreSQL/Simple/ToField.hs +371/−0
- src/Database/PostgreSQL/Simple/ToField.hs-boot +30/−0
- src/Database/PostgreSQL/Simple/ToRow.hs +113/−0
- src/Database/PostgreSQL/Simple/ToRow.hs-boot +18/−0
- src/Database/PostgreSQL/Simple/Transaction.hs +260/−0
- src/Database/PostgreSQL/Simple/TypeInfo.hs +121/−0
- src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs +47/−0
- src/Database/PostgreSQL/Simple/TypeInfo/Static.hs +1232/−0
- src/Database/PostgreSQL/Simple/TypeInfo/Types.hs +56/−0
- src/Database/PostgreSQL/Simple/Types.hs +274/−0
- test/Common.hs +32/−0
- test/Main.hs +485/−0
- test/Notify.hs +41/−0
- test/Serializable.hs +68/−0
- test/Time.hs +119/−0
+ CHANGELOG.md view
@@ -0,0 +1,22 @@+For the full changelog, see+<https://github.com/charmander/haskell-pg/blob/master/CHANGES.md>++### 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.+
+ CONTRIBUTORS view
@@ -0,0 +1,35 @@+Bryan O'Sullivan <bos@serpentine.com>+Leon P Smith <leon@melding-monads.com>+Felipe Lessa <felipe.lessa@gmail.com>+Ozgun Ataman <ozataman@gmail.com>+Joey Adams <joeyadams3.14159@gmail.com>+Rekado <rekado@elephly.net>+Leonid Onokhov <sopvop@gmail.com>+Bas van Dijk <v.dijk.bas@gmail.com>+Jason Dusek <jason.dusek@gmail.com>+Jeff Chu <jeff@kiteedu.com>+Oliver Charles <oliver.g.charles@gmail.com>+Simon Meier <iridcode@gmail.com>+Alexey Uimanov <s9gf4ult@gmail.com>+Doug Beardsley <mightybyte@gmail.com>+Manuel Gómez <targen@gmail.com>+Michael Snoyman <michael@snoyman.com>+Adam Bergmark <adam@edea.se>+Tobias Florek <tob@butter.sh>+Francesco Mazzoli <francesco.mazzoli@erudify.com>+Chris Allen <cma@bitemyapp.com>+Simon Hengel <sol@typeful.net>+Tom Ellis <tom-2013@purelyagile.com>+Mike Ledger <mike@quasimal.com>+João Cristóvão <jmacristovao@gmail.com>+Bardur Arantsson <bardur@scientician.net>+Travis Staton <hello@travisstaton.com>+Sam Rijs <srijs@airpost.net>+Janne Hellsten <jjhellst@gmail.com>+Timmy Tofu <timmytofu@users.noreply.github.com>+Alexey Khudyakov <alexey.skladnoy@gmail.com>+Timo von Holtz <tvh@anchor.com.au>+Amit Levy <amit@amitlevy.com>+Ben Gamari <ben@smart-cactus.org>+Edgar Gomes Araujo <talktoedgar@gmail.com>+Erik Hesselink <hesselink@gmail.com>
+ LICENSE view
@@ -0,0 +1,62 @@+Copyright (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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ pg.cabal view
@@ -0,0 +1,125 @@+Name: pg+Version: 0.5.2.1+Synopsis: Mid-level PostgreSQL client library+Description: Mid-level PostgreSQL client library, forked from postgresql-simple.+License: BSD3+License-file: LICENSE+Author: Bryan O'Sullivan, Leon P Smith+Maintainer: Charmander <~@charmander.me>+Copyright: (c) 2011 MailRank, Inc.+ (c) 2011-2015 Leon P Smith+Category: Database+Build-type: Simple++Cabal-version: >= 1.9.2++extra-source-files:+ CONTRIBUTORS+ CHANGELOG.md++Library+ hs-source-dirs: src+ Exposed-modules:+ Database.PostgreSQL.Simple+ Database.PostgreSQL.Simple.Arrays+ Database.PostgreSQL.Simple.Copy+ Database.PostgreSQL.Simple.FromField+ Database.PostgreSQL.Simple.FromRow+ Database.PostgreSQL.Simple.LargeObjects+ Database.PostgreSQL.Simple.HStore+ Database.PostgreSQL.Simple.HStore.Internal+ Database.PostgreSQL.Simple.Notification+ Database.PostgreSQL.Simple.Ok+ Database.PostgreSQL.Simple.Range+ Database.PostgreSQL.Simple.SqlQQ+ Database.PostgreSQL.Simple.Time+ Database.PostgreSQL.Simple.Time.Internal+ Database.PostgreSQL.Simple.ToField+ Database.PostgreSQL.Simple.ToRow+ Database.PostgreSQL.Simple.Transaction+ Database.PostgreSQL.Simple.TypeInfo+ Database.PostgreSQL.Simple.TypeInfo.Macro+ Database.PostgreSQL.Simple.TypeInfo.Static+ Database.PostgreSQL.Simple.Types+ Database.PostgreSQL.Simple.Errors+-- Other-modules:+ Database.PostgreSQL.Simple.Internal++ Other-modules:+ Database.PostgreSQL.Simple.Compat+ Database.PostgreSQL.Simple.HStore.Implementation+ Database.PostgreSQL.Simple.Time.Implementation+ Database.PostgreSQL.Simple.Time.Internal.Parser+ Database.PostgreSQL.Simple.Time.Internal.Printer+ Database.PostgreSQL.Simple.TypeInfo.Types++ Build-depends:+ aeson >= 0.6,+ attoparsec >= 0.10.3,+ base >= 4.6 && < 5,+ bytestring >= 0.9,+ bytestring-builder,+ case-insensitive,+ containers,+ hashable,+ postgresql-libpq >= 0.9 && < 0.10,+ template-haskell,+ text >= 0.11.1,+ time,+ transformers,+ uuid-types >= 1.0.0,+ scientific,+ vector++ if !impl(ghc >= 7.6)+ Build-depends:+ ghc-prim++ extensions: DoAndIfThenElse, OverloadedStrings, BangPatterns, ViewPatterns+ TypeOperators++ ghc-options: -Wall -fno-warn-name-shadowing++source-repository head+ type: git+ location: https://github.com/charmander/haskell-pg++test-suite test+ type: exitcode-stdio-1.0++ hs-source-dirs: test+ main-is: Main.hs+ other-modules:+ Common+ Notify+ Serializable+ Time++ ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind++ extensions: NamedFieldPuns+ , OverloadedStrings+ , Rank2Types+ , RecordWildCards+ , PatternGuards+ , ScopedTypeVariables++ build-depends: base+ , aeson+ , base16-bytestring+ , bytestring+ , containers+ , cryptohash+ , filepath+ , tasty+ , tasty-hunit+ , tasty-golden+ , HUnit+ , pg+ , text+ , time+ , vector++ if !impl(ghc >= 7.6)+ build-depends:+ ghc-prim
+ src/Database/PostgreSQL/Simple.hs view
@@ -0,0 +1,1001 @@+{-# 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 <leon@melding-monads.com>+-- 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.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, intDec )+import Control.Applicative ((<$>))+import Control.Exception as E+import Control.Monad (unless)+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.FromField (ResultError(..))+import Database.PostgreSQL.Simple.FromRow (FromRow(..))+import Database.PostgreSQL.Simple.Ok+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.Transaction+import Database.PostgreSQL.Simple.TypeInfo+import qualified Database.PostgreSQL.LibPQ as PQ+import qualified Data.ByteString.Char8 as B+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State.Strict+++-- | 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 =+ let (h,t) = B.break (=='?') s+ in byteString h+ : if B.null t+ then []+ else split (B.tail t)+ zipParams (t:ts) (p:ps) = t <> p <> zipParams ts ps+ zipParams [t] [] = t+ zipParams _ _ = fmtError (show (B.count '?' template) +++ " '?' characters, but " +++ show (length xs) ++ " parameters") q xs++-- | 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 sometable.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++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 pg 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 = do+ name <- newTempName conn+ _ <- execute_ conn $ mconcat+ [ "DECLARE ", name, " NO SCROLL CURSOR FOR ", q ]+ return name+ close name =+ (execute_ conn ("CLOSE " <> name) >> return ()) `E.catch` \ex ->+ -- Don't throw exception if CLOSE failed because the transaction is+ -- aborted. Otherwise, it will throw away the original error.+ unless (isFailedTransactionError ex) $ throwIO ex++ go = bracket declare close $ \(Query name) ->+ let q = toByteString (byteString "FETCH FORWARD "+ <> intDec chunkSize+ <> byteString " FROM "+ <> byteString name+ )+ loop a = do+ result <- exec conn q+ status <- PQ.resultStatus result+ case status of+ PQ.TuplesOk -> do+ nrows <- PQ.ntuples result+ ncols <- PQ.nfields result+ if nrows > 0+ then do+ let inner a row = do+ x <- getRowWith parser row ncols conn result+ f a x+ foldM' inner a 0 (nrows - 1) >>= loop+ else return a+ _ -> throwResultError "fold" result status+ in loop a0++-- FIXME: choose the Automatic chunkSize more intelligently+-- 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_ #-}++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' #-}++foldM' :: (Ord n, Num n) => (a -> n -> IO a) -> a -> n -> n -> IO a+foldM' f a lo hi = loop a lo+ where+ loop a !n+ | n > hi = return a+ | otherwise = do+ a' <- f a n+ loop a' (n+1)+{-# INLINE foldM' #-}++finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r]+finishQueryWith parser conn q result = do+ status <- PQ.resultStatus result+ case status of+ PQ.EmptyQuery ->+ throwIO $ QueryError "query: Empty query" q+ PQ.CommandOk ->+ throwIO $ QueryError "query resulted in a command response" q+ PQ.TuplesOk -> do+ nrows <- PQ.ntuples result+ ncols <- PQ.nfields result+ forM' 0 (nrows-1) $ \row ->+ getRowWith parser row ncols conn result+ PQ.CopyOut ->+ throwIO $ QueryError "query: COPY TO is not supported" q+ PQ.CopyIn ->+ throwIO $ QueryError "query: COPY FROM is not supported" q+ PQ.BadResponse -> throwResultError "query" result status+ PQ.NonfatalError -> throwResultError "query" result status+ PQ.FatalError -> throwResultError "query" result status++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+++-- $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 compatble 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.
+ src/Database/PostgreSQL/Simple.hs-boot view
@@ -0,0 +1,23 @@+module 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
+ src/Database/PostgreSQL/Simple/Arrays.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE PatternGuards #-}++------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.Arrays+-- Copyright: (c) 2012 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- 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.
+ src/Database/PostgreSQL/Simple/Compat.hs view
@@ -0,0 +1,94 @@+{-# 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
+ src/Database/PostgreSQL/Simple/Copy.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE CPP, DeriveDataTypeable #-}++------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.Copy+-- Copyright: (c) 2013 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+--+-- mid-level support for COPY IN and COPY OUT. See+-- <https://www.postgresql.org/docs/9.5/static/sql-copy.html> 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(..)+ , 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+++-- | Issue a @COPY FROM STDIN@ or @COPY TO STDOUT@ query. In the former+-- case, the connection's state will change to @CopyIn@; in the latter,+-- @CopyOut@. The connection must be in the ready state in order+-- to call this function. Performs parameter subsitution.++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 err = throwIO $ QueryError+ (B.unpack funcName ++ " " ++ show status)+ template+ case status of+ PQ.EmptyQuery -> err+ PQ.CommandOk -> err+ PQ.TuplesOk -> err+ PQ.CopyOut -> return ()+ PQ.CopyIn -> return ()+ 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)+++-- | 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
+ src/Database/PostgreSQL/Simple/Errors.hs view
@@ -0,0 +1,139 @@+{-# 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 <leon@melding-monads.com>+-- 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+-- succeedes only if able to parse sqlErrorMsg.+--+-- > createUser = catchJust constraintViolation catcher $ execute conn ...+-- > where+-- > catcher UniqueViolation "user_login_key" = ...+-- > catcher _ = ...+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 = catchJust constraintViolationE catcher $ execute conn ...+-- > where+-- > catcher (_, UniqueViolation "user_login_key") = ...+-- > catcher (e, _) = throwIO e+--+constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation)+constraintViolationE e = fmap ((,) e) $ constraintViolation e++-- | Catches SqlError, tries to convert to ConstraintViolation, re-throws+-- on fail. Provides alternative interface to catchJust+--+-- > 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
+ src/Database/PostgreSQL/Simple/FromField.hs view
@@ -0,0 +1,654 @@+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards, TemplateHaskell #-}++{- |+Module: Database.PostgreSQL.Simple.FromField+Copyright: (c) 2011 MailRank, Inc.+ (c) 2011-2013 Leon P Smith+License: BSD3+Maintainer: Leon P Smith <leon@melding-monads.com>+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 pg. This is+particularly useful for supporting PostgreSQL types that pg+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 pg.++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++ , optionalField+ , fromJSONField+ ) where++#include "MachDeps.h"++import Control.Applicative ( (<|>), (<$>), pure, (*>), (<*) )+import Control.Concurrent.MVar (MVar, newMVar)+import Control.Exception (Exception)+import qualified Data.Aeson as JSON+import qualified Data.Aeson.Parser as JSON (value')+import Data.Attoparsec.ByteString.Char8 hiding (Result)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import Data.Int (Int16, Int32, Int64)+import Data.IORef (IORef, newIORef)+import Data.Ratio (Ratio)+import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )+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.TypeInfo.Macro 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)++-- | 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, pg will check+-- the built-in, static table. If the type oid is not there,+-- pg 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+-- off the associated table column. Numbering starts from 0. 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 /= $(inlineTypoid TI.void) = returnError Incompatible f ""+ | otherwise = pure ()++-- | 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 /= $(inlineTypoid TI.bool) = returnError Incompatible f ""+ | bs == Nothing = returnError UnexpectedNull f ""+ | bs == Just "t" = pure True+ | bs == Just "f" = pure False+ | otherwise = returnError ConversionFailed f ""++-- | \"char\"+instance FromField Char where+ fromField f bs =+ if typeOid f /= $(inlineTypoid TI.char)+ then returnError Incompatible f ""+ else case bs of+ Nothing -> returnError UnexpectedNull f ""+ Just bs -> if B.length bs /= 1+ then returnError ConversionFailed f "length not 1"+ else return $! (B.head bs)++-- | int2+instance FromField Int16 where+ fromField = atto ok16 $ signed decimal++-- | int2, int4+instance FromField Int32 where+ fromField = atto 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 = atto okInt $ signed decimal++-- | int2, int4, int8+instance FromField Int64 where+ fromField = atto ok64 $ signed decimal++-- | int2, int4, int8+instance FromField Integer where+ fromField = atto ok64 $ signed decimal++-- | int2, float4 (Uses attoparsec's 'double' routine, for+-- better accuracy convert to 'Scientific' or 'Rational' first)+instance FromField Float where+ fromField = atto ok (realToFrac <$> pg_double)+ where ok = $(mkCompats [TI.float4,TI.int2])++-- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for+-- better accuracy convert to 'Scientific' or 'Rational' first)+instance FromField Double where+ fromField = atto ok pg_double+ where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4])++-- | int2, int4, int8, float4, float8, numeric+instance FromField (Ratio Integer) where+ fromField = atto ok pg_rational+ where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.int8,TI.numeric])++-- | int2, int4, int8, float4, float8, numeric+instance FromField Scientific where+ fromField = atto ok rational+ where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.int8,TI.numeric])++unBinary :: Binary t -> t+unBinary (Binary x) = x++pg_double :: Parser Double+pg_double+ = (string "NaN" *> pure ( 0 / 0))+ <|> (string "Infinity" *> pure ( 1 / 0))+ <|> (string "-Infinity" *> pure (-1 / 0))+ <|> double++pg_rational :: Parser Rational+pg_rational+ = (string "NaN" *> pure notANumber )+ <|> (string "Infinity" *> pure infinity )+ <|> (string "-Infinity" *> pure (-infinity))+ <|> rational++-- | bytea, name, text, \"char\", bpchar, varchar, unknown+instance FromField SB.ByteString where+ fromField f dat = if typeOid f == $(inlineTypoid TI.bytea)+ then unBinary <$> fromField f dat+ else doFromField f okText' pure dat++-- | oid+instance FromField PQ.Oid where+ fromField f dat = PQ.Oid <$> atto (== $(inlineTypoid TI.oid)) decimal f dat++-- | 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 $(inlineTypoid TI.timestamptz) "UTCTime" parseUTCTime++-- | timestamptz+instance FromField ZonedTime where+ fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTime" parseZonedTime++-- | timestamp+instance FromField LocalTime where+ fromField = ff $(inlineTypoid TI.timestamp) "LocalTime" parseLocalTime++-- | date+instance FromField Day where+ fromField = ff $(inlineTypoid TI.date) "Day" parseDay++-- | time+instance FromField TimeOfDay where+ fromField = ff $(inlineTypoid TI.time) "TimeOfDay" parseTimeOfDay++-- | timestamptz+instance FromField UTCTimestamp where+ fromField = ff $(inlineTypoid TI.timestamptz) "UTCTimestamp" parseUTCTimestamp++-- | timestamptz+instance FromField ZonedTimestamp where+ fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTimestamp" parseZonedTimestamp++-- | timestamp+instance FromField LocalTimestamp where+ fromField = ff $(inlineTypoid TI.timestamp) "LocalTimestamp" parseLocalTimestamp++-- | date+instance FromField Date where+ fromField = ff $(inlineTypoid TI.date) "Date" parseDate++ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)+ -> Field -> Maybe B8.ByteString -> Conversion a+ff compatOid hsType parse f mstr =+ if typeOid f /= compatOid+ then err Incompatible ""+ else case mstr of+ Nothing -> err UnexpectedNull ""+ Just str -> case parse 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 typeInfo f = sequence . (parseIt <$>) <$> array delim+ where+ delim = typdelim (typelem typeInfo)+ fElem = f{ typeOid = typoid (typelem typeInfo) }++ parseIt item =+ fieldParser f' $ if item == Arrays.Plain "NULL" then Nothing else Just item'+ where+ item' = fmt delim item+ f' | Arrays.Array _ <- item = f+ | otherwise = fElem++instance (FromField a, Typeable a) => FromField (Vector a) where+ fromField f v = V.fromList . fromPGArray <$> fromField f v++instance (FromField a, Typeable a) => FromField (IOVector a) where+ fromField f v = liftConversion . V.unsafeThaw =<< fromField f v++-- | uuid+instance FromField UUID where+ fromField f mbs =+ if typeOid f /= $(inlineTypoid TI.uuid)+ 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+instance FromField JSON.Value where+ fromField f mbs =+ if typeOid f /= $(inlineTypoid TI.json) && typeOid f /= $(inlineTypoid TI.jsonb)+ then returnError Incompatible f ""+ else case mbs of+ Nothing -> returnError UnexpectedNull f ""+ Just bs ->+ case parseOnly (JSON.value' <* endOfInput) bs of+ Left err -> returnError ConversionFailed f err+ Right val -> pure val++-- | Parse a field to a JSON 'JSON.Value' and convert that into a+-- Haskell value using 'JSON.fromJSON'.+--+-- 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.fromJSON value of+ JSON.Error err -> returnError ConversionFailed f $+ "JSON decoding error: " ++ err+ JSON.Success x -> pure x++-- | Compatible with the same set of types as @a@. Note that+-- modifying the 'IORef' does not have any effects outside+-- the local process on the local machine.+instance FromField a => FromField (IORef a) where+ fromField f v = liftConversion . newIORef =<< fromField f v++-- | Compatible with the same set of types as @a@. Note that+-- modifying the 'MVar' does not have any effects outside+-- the local process on the local machine.+instance FromField a => FromField (MVar a) where+ fromField f v = liftConversion . newMVar =<< fromField f v++type Compat = PQ.Oid -> Bool++okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat+okText = $( mkCompats [ TI.name, TI.text, TI.char,+ TI.bpchar, TI.varchar ] )+okText' = $( mkCompats [ TI.name, TI.text, TI.char,+ TI.bpchar, TI.varchar, TI.unknown ] )+okBinary = (== $( inlineTypoid TI.bytea ))+ok16 = (== $( inlineTypoid TI.int2 ))+ok32 = $( mkCompats [TI.int2,TI.int4] )+ok64 = $( mkCompats [TI.int2,TI.int4,TI.int8] )+#if WORD_SIZE_IN_BITS < 64+okInt = ok32+#else+okInt = ok64+#endif++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++atto :: forall a. (Typeable a)+ => Compat -> Parser a -> Field -> Maybe ByteString+ -> Conversion a+atto 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
+ src/Database/PostgreSQL/Simple/FromField.hs-boot view
@@ -0,0 +1,11 @@+module 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)
+ src/Database/PostgreSQL/Simple/FromRow.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards, FlexibleInstances, DefaultSignatures #-}+++------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.FromRow+-- Copyright: (c) 2012 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- 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 pg, 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.+--+-- Note that 'field' evaluates its result to WHNF, so the caveats listed in+-- mysql-simple and very early versions of pg 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 => 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
+ src/Database/PostgreSQL/Simple/FromRow.hs-boot view
@@ -0,0 +1,17 @@+module 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)
+ src/Database/PostgreSQL/Simple/HStore.hs view
@@ -0,0 +1,36 @@+------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.HStore+-- Copyright: (c) 2013 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+--+-- Parsers and printers for hstore, a extended type bundled with+-- PostgreSQL providing finite maps from text strings to text strings.+-- See <https://www.postgresql.org/docs/9.5/static/hstore.html> for more+-- information.+--+-- Note that in order to use this type, a database superuser must+-- install it by running a sql script in the share directory. This+-- can be done on PostgreSQL 9.1 and later with the command+-- @CREATE EXTENSION hstore@. See+-- <https://www.postgresql.org/docs/9.5/static/contrib.html> 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
+ src/Database/PostgreSQL/Simple/HStore/Implementation.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE CPP, ViewPatterns, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}++------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.HStore.Implementation+-- Copyright: (c) 2013 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- 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 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 x -> x++toLazyByteString :: HStoreBuilder -> BL.ByteString+toLazyByteString x = case x of+ Empty -> BL.empty+ Comma x -> BU.toLazyByteString x++instance Monoid HStoreBuilder where+ mempty = Empty+ mappend Empty x = x+ mappend (Comma a) x+ = Comma (a `mappend` case x of+ Empty -> mempty+ Comma b -> char8 ',' `mappend` b)++class ToHStoreText a where+ toHStoreText :: a -> HStoreText++-- | Represents escape text, ready to be the key or value to a hstore value+newtype HStoreText = HStoreText Builder deriving (Typeable, Monoid)++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 '"'
+ src/Database/PostgreSQL/Simple/HStore/Internal.hs view
@@ -0,0 +1,19 @@+------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.HStore.Internal+-- Copyright: (c) 2013 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+--+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.HStore.Internal+ ( HStoreBuilder(..)+ , HStoreText(..)+ , parseHStore+ , parseHStoreKeyVal+ , parseHStoreText+ ) where++import Database.PostgreSQL.Simple.HStore.Implementation
+ src/Database/PostgreSQL/Simple/Internal.hs view
@@ -0,0 +1,586 @@+{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}++------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.Internal+-- Copyright: (c) 2011-2015 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- 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 pg+-- 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.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 (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++-- | Attempt to make a connection based on a libpq connection string.+-- See <https://www.postgresql.org/docs/9.5/static/libpq-connect.html#LIBPQ-CONNSTRING>+-- for more information. Also note that environment variables also affect+-- parameters not provided, parameters provided as the empty string, and a+-- few other things; see+-- <https://www.postgresql.org/docs/9.5/static/libpq-envars.html>+-- for details. Here is an example with some of the most commonly used+-- parameters:+--+-- > host='db.somedomain.com' port=5432 ...+--+-- This attempts to connect to @db.somedomain.com:5432@. Omitting the port+-- will normally default to 5432.+--+-- On systems that provide unix domain sockets, omitting the host parameter+-- will cause libpq to attempt to connect via unix domain sockets.+-- The default filesystem path to the socket is constructed from the+-- port number and the @DEFAULT_PGSOCKET_DIR@ constant defined in the+-- @pg_config_manual.h@ header file. Connecting via unix sockets tends+-- to use the @peer@ authentication method, which is very secure and+-- does not require a password.+--+-- On Windows and other systems without unix domain sockets, omitting+-- the host will default to @localhost@.+--+-- > ... dbname='postgres' user='postgres' password='secret \' \\ pw'+--+-- This attempts to connect to a database named @postgres@ with+-- user @postgres@ and password @secret \' \\ pw@. Backslash+-- characters will have to be double-quoted in literal Haskell strings,+-- of course. Omitting @dbname@ and @user@ will both default to the+-- system username that the client process is running as.+--+-- Omitting @password@ will default to an appropriate password found+-- in the @pgpass@ file, or no password at all if a matching line is+-- not found. See+-- <https://www.postgresql.org/docs/9.5/static/libpq-pgpass.html> for+-- more information regarding this file.+--+-- As all parameters are optional and the defaults are sensible, the+-- empty connection string can be useful for development and+-- exploratory use, assuming your system is set up appropriately.+--+-- On Unix, such a setup would typically consist of a local+-- postgresql server listening on port 5432, as well as a system user,+-- database user, and database sharing a common name, with permissions+-- granted to the user on the database.+--+-- On Windows, in addition you will either need @pg_hba.conf@+-- to specify the use of the @trust@ authentication method for+-- the connection, which may not be appropriate for multiuser+-- or production machines, or you will need to use a @pgpass@ file+-- with the @password@ or @md5@ authentication methods.+--+-- See <https://www.postgresql.org/docs/9.5/static/client-authentication.html>+-- for more information regarding the authentication process.+--+-- SSL/TLS will typically "just work" if your postgresql server supports or+-- requires it. However, note that libpq is trivially vulnerable to a MITM+-- attack without setting additional SSL connection parameters. In+-- particular, @sslmode@ needs to be set to @require@, @verify-ca@, or+-- @verify-full@ in order to perform certificate validation. When @sslmode@+-- is @require@, then you will also need to specify a @sslrootcert@ file,+-- otherwise no validation of the server's identity will be performed.+-- Client authentication via certificates is also possible via the+-- @sslcert@ and @sslkey@ parameters. See+-- <https://www.postgresql.org/docs/9.5/static/libpq-ssl.html>+-- for detailed information regarding libpq and SSL.++connectPostgreSQL :: ByteString -> IO Connection+connectPostgreSQL connstr = do+ conn <- 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 . quote value . space+ where value = field connectInfo++ num name field+ | value <= 0 = id+ | otherwise = showString name . shows value . space+ where value = field connectInfo++ quote str rest = '\'' : foldr delta ('\'' : rest) str+ 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+ 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+ 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 -> toInteger 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+ toInteger 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
+ src/Database/PostgreSQL/Simple/LargeObjects.hs view
@@ -0,0 +1,97 @@+-----------------------------------------------------------------------------+-- |+-- 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+-- <https://www.postgresql.org/docs/9.5/static/largeobjects.html> for more+-- information.+--+-- Note that Large Object File Descriptors are only valid within a single+-- database transaction, so if you are interested in using anything beyond+-- 'loCreat', 'loCreate', and 'loUnlink', you will need to run the entire+-- sequence of functions in a transaction. As 'loImport' and 'loExport'+-- are simply C functions that call 'loCreat', 'loOpen', 'loRead', and+-- '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)
+ src/Database/PostgreSQL/Simple/Notification.hs view
@@ -0,0 +1,162 @@+{-# 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+-- <https://www.postgresql.org/docs/9.5/static/sql-notify.html> 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.+--+-- <https://hackage.haskell.org/trac/ghc/ticket/7353>+--+-----------------------------------------------------------------------------++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+ }++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
+ src/Database/PostgreSQL/Simple/Ok.hs view
@@ -0,0 +1,87 @@+{-# 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 pg.+--+-- 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++-- 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++ 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
+ src/Database/PostgreSQL/Simple/Range.hs view
@@ -0,0 +1,313 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}++------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.Range+-- Copyright: (c) 2014-2015 Leonid Onokhov+-- (c) 2014-2015 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+--+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.Range+ ( RangeBound(..)+ , PGRange(..)+ , empty+ , isEmpty, isEmptyBy+ , contains, containsBy+ ) 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 (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 x =+ case lb of+ NegInfinity -> True+ PosInfinity -> False+ Inclusive a -> cmp a x /= GT+ Exclusive a -> cmp a x == LT++ checkUB ub x =+ case ub of+ NegInfinity -> False+ PosInfinity -> True+ Inclusive z -> cmp x z /= GT+ Exclusive z -> cmp x 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 f mdat = do+ info <- typeInfo f+ case info of+ Range{} ->+ let f' = f { typeOid = typoid (rngsubtype info) }+ in case mdat of+ Nothing -> returnError UnexpectedNull f ""+ Just "empty" -> pure $ empty+ Just bs ->+ let parseIt NegInfinity = pure NegInfinity+ parseIt (Inclusive v) = Inclusive <$> fromField f' (Just v)+ parseIt (Exclusive v) = Exclusive <$> fromField f' (Just v)+ parseIt PosInfinity = pure PosInfinity+ in case parseOnly pgrange bs of+ Left e -> returnError ConversionFailed f e+ Right (lb,ub) -> PGRange <$> parseIt lb <*> parseIt ub+ _ -> returnError Incompatible f ""+++instance ToField (PGRange Int8) where+ toField = Plain . rangeToBuilder int8Dec+ {-# INLINE toField #-}++instance ToField (PGRange Int16) where+ toField = Plain . rangeToBuilder int16Dec+ {-# INLINE toField #-}++instance ToField (PGRange Int32) where+ toField = Plain . rangeToBuilder int32Dec+ {-# INLINE toField #-}++instance ToField (PGRange Int) where+ toField = Plain . rangeToBuilder intDec+ {-# INLINE toField #-}++instance ToField (PGRange Int64) where+ toField = Plain . rangeToBuilder int64Dec+ {-# INLINE toField #-}++instance ToField (PGRange Integer) where+ toField = Plain . rangeToBuilder integerDec+ {-# INLINE toField #-}++instance ToField (PGRange Word8) where+ toField = Plain . rangeToBuilder word8Dec+ {-# INLINE toField #-}++instance ToField (PGRange Word16) where+ toField = Plain . rangeToBuilder word16Dec+ {-# INLINE toField #-}++instance ToField (PGRange Word32) where+ toField = Plain . rangeToBuilder word32Dec+ {-# INLINE toField #-}++instance ToField (PGRange Word) where+ toField = Plain . rangeToBuilder wordDec+ {-# INLINE toField #-}++instance ToField (PGRange Word64) where+ toField = Plain . rangeToBuilder word64Dec+ {-# INLINE toField #-}++instance ToField (PGRange Float) where+ toField = Plain . rangeToBuilder floatDec+ {-# INLINE toField #-}++instance ToField (PGRange Double) where+ toField = Plain . rangeToBuilder doubleDec+ {-# INLINE toField #-}++instance ToField (PGRange Scientific) where+ toField = Plain . rangeToBuilder f+ where+ f = lazyByteString . LT.encodeUtf8 . LT.toLazyText . scientificBuilder+ {-# INLINE toField #-}++instance ToField (PGRange UTCTime) where+ toField = Plain . rangeToBuilder utcTimeToBuilder+ {-# INLINE toField #-}++instance ToField (PGRange ZonedTime) where+ toField = Plain . rangeToBuilderBy cmpZonedTime zonedTimeToBuilder+ {-# INLINE toField #-}++cmpZonedTime :: ZonedTime -> ZonedTime -> Ordering+cmpZonedTime = compare `on` zonedTimeToUTC -- FIXME: optimize++instance ToField (PGRange LocalTime) where+ toField = Plain . rangeToBuilder localTimeToBuilder+ {-# INLINE toField #-}++instance ToField (PGRange Day) where+ toField = Plain . rangeToBuilder dayToBuilder+ {-# INLINE toField #-}++instance ToField (PGRange TimeOfDay) where+ toField = Plain . rangeToBuilder timeOfDayToBuilder+ {-# INLINE toField #-}++instance ToField (PGRange UTCTimestamp) where+ toField = Plain . rangeToBuilder utcTimestampToBuilder+ {-# INLINE toField #-}++instance ToField (PGRange ZonedTimestamp) where+ toField = Plain . rangeToBuilderBy cmpZonedTimestamp zonedTimestampToBuilder+ {-# INLINE toField #-}++cmpZonedTimestamp :: ZonedTimestamp -> ZonedTimestamp -> Ordering+cmpZonedTimestamp = compare `on` (zonedTimeToUTC <$>)++instance ToField (PGRange LocalTimestamp) where+ toField = Plain . rangeToBuilder localTimestampToBuilder+ {-# INLINE toField #-}++instance ToField (PGRange Date) where+ toField = Plain . rangeToBuilder dateToBuilder+ {-# INLINE toField #-}++instance ToField (PGRange NominalDiffTime) where+ toField = Plain . rangeToBuilder nominalDiffTimeToBuilder+ {-# INLINE toField #-}
+ src/Database/PostgreSQL/Simple/SqlQQ.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE TemplateHaskell #-}+------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.SqlQQ+-- Copyright: (c) 2011-2012 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- 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 mimimize whitespace; otherwise the above query would+-- consist of approximately half whitespace when sent to the database+-- backend. It also recognizes and strips out standard sql comments "--".+--+-- 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"
+ src/Database/PostgreSQL/Simple/Time.hs view
@@ -0,0 +1,244 @@+{- |+Module: Database.PostgreSQL.Simple.Time+Copyright: (c) 2012-2015 Leon P Smith+License: BSD3+Maintainer: Leon P Smith <leon@melding-monads.com>+Stability: experimental++This module provides time types that supports positive and negative+infinity, as well as some functions for converting to and from strings.++Also, this module also contains commentary regarding postgresql's timestamp+types, civil timekeeping in general, and how it relates to+pg. You can read more about PostgreSQL's date and time types+at <https://www.postgresql.org/docs/9.5/static/datatype-datetime.html>,+and the IANA time zone database at <https://en.wikipedia.org/wiki/Tz_database>.++Stack Overflow also has some excellent commentary on time, if it is a+wiki page or a highly upvoted question and answer. If the answer regarding+time has not received about a hundred upvotes at least, then the answer is+almost invariably completely and painfully wrong, even if it's the chosen+answer or the most highly upvoted answer to a question.++PostgreSQL's @timestamp with time zone@ (hereafter, @timestamptz@) can be+converted to Haskell's 'Data.Time.UTCTime' and 'Data.Time.ZonedTime' types,+because values of these types represent a self-contained, unambiguous point+in time. PostgreSQL's @timestamp without time zone@ (hereafter, @timestamp@)+can be converted to Haskell's 'Data.Time.LocalTime', because values of these+types are ambiguous by themselves, and require context to disambiguate.++While this behavior may be superficially counterintuitive because the+names might suggest otherwise, this behavior is correct. In fact,+the \"timezone\" language in both the postgresql and haskell types would+be better read as \"offset (from UTC)\", thus we have postgresql's+\"timestamp with offset\" corresponding to Haskell's \"time with the+offset \'zero\'\" and Haskell's \"time with an offset (that might be+nonzero)\". Similarly, postgresql's \"timestamp without an offset\"+corresponds to Haskell's \"local time (without an offset)\".++It's important to distinguish between an offset, a standard time, and+a time zone. An offset is simply a difference of a local time from UTC,+such as @+00@, @-05@, or @+05:30@. A standard time specifies an offset+(which may vary throughout the year, due to daylight savings) that a+region follows, such as Universal Coordinated Time (UTC), Eastern Standard+Time\/Eastern Daylight Time (EST\/EDT), or India Standard Time (IST).+And a time zone, much like a standard time, is a function from+timestamps to offsets.++A time zone is different from a standard time because different regions+inside a standard time can be governed by different civil authorities with+different laws and thus have different histories of civil time. An IANA+time zone is any region of the world that has had the same history of+civil time since @1970-01-01 00:00+00@.++For example, as of today, both @America\/New_York@ and+@America\/Indiana\/Indianapolis@ are on the EST\/EDT time standard, but+Indiana used to be on Central Standard Time until 1942, and did not observe+daylight savings time (EST only) until 2006. Thus, the choice between+these two time zones still matters if you are dealing with timestamps+prior to 2006, and could become relevant again if (most of) Indiana+moves back to Central Time. (Of course, if the Central to Eastern switch+was the only difference, then these two time zones would be the same in+IANA's eyes, due to their cutoff date of 1970-01-01.)++Getting back to practicalities, PostgreSQL's @timestamptz@ type does not+actually store an offset; rather, it uses the offset provided to calculate+UTC, and stores the timestamp as UTC. If an offset is not provided, the+given timestamp is assumed to be a local time for whatever the @timezone@+variable is set to, and the IANA TZ database is consulted to calculate an+offset from UTC for the time in question.++Note that while most (local timestamp, time zone) pairs correspond to exactly+one UTC timestamp, some correspond to two UTC timestamps, while others+correspond to none at all. The ambiguous case occurs when the civil time+is rolled back, making a calendar day longer than 24 hours. In this case,+PostgreSQL silently chooses the second, later possibility. The inconsistent+case occurs when the civil time is moved forward, making a calendar day less+than 24 hours. In this case, PostgreSQL silently assumes the local time+was read off a clock that had not been moved forward at the prescribed time,+and moves the clock forward for you. Thus, converting from local time+to UTC need not be monotonic, if these inconsistent cases are allowed.++When retrieving a @timestamptz@, the backend looks at the @time zone@+connection variable and then consults the IANA TZ database to calculate+an offset for the timestamp in the given time zone.++Note that while some of the information contained in the IANA TZ database+is a bit of a standardized fiction, the conversion from UTC time to a+(local time, offset) pair in a particular time zone is always unambiguous,+and the result can always be unambiguously converted back to UTC. Thus,+pg 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, pg 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, pg 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+pg 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 pg+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+ , dayToBuilder+ , utcTimeToBuilder+ , zonedTimeToBuilder+ , localTimeToBuilder+ , timeOfDayToBuilder+ , timeZoneToBuilder+ , dateToBuilder+ , utcTimestampToBuilder+ , zonedTimestampToBuilder+ , localTimestampToBuilder+ , unboundedToBuilder+ , nominalDiffTimeToBuilder+ ) where++import Database.PostgreSQL.Simple.Time.Implementation
+ src/Database/PostgreSQL/Simple/Time/Implementation.hs view
@@ -0,0 +1,166 @@+------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.Time.Implementation+-- Copyright: (c) 2012-2015 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- 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 hiding (getTimeZone, getZonedTime)+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)++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++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
+ src/Database/PostgreSQL/Simple/Time/Internal.hs view
@@ -0,0 +1,27 @@+------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.Time.Internal+-- Copyright: (c) 2012 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- 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
+ src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}++-- |+-- Module: Database.PostgreSQL.Simple.Time.Internal.Parser+-- Copyright: (c) 2012-2015 Leon P Smith+-- (c) 2015 Bryan O'Sullivan+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+--+-- Parsers for parsing dates and times.++module Database.PostgreSQL.Simple.Time.Internal.Parser+ (+ day+ , localTime+ , timeOfDay+ , timeZone+ , UTCOffsetHMS(..)+ , timeZoneHMS+ , localToUTCTimeOfDayHMS+ , utcTime+ , zonedTime+ ) where++import Control.Applicative ((<$>), (<*>), (<*), (*>))+import Database.PostgreSQL.Simple.Compat (toPico)+import Data.Attoparsec.ByteString.Char8 as A+import Data.Bits ((.&.))+import Data.Char (ord)+import Data.Fixed (Pico)+import Data.Int (Int64)+import Data.Maybe (fromMaybe)+import Data.Time.Calendar (Day, fromGregorianValid, addDays)+import Data.Time.Clock (UTCTime(..))+import qualified Data.ByteString.Char8 as B8+import qualified Data.Time.LocalTime 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 ""
+ src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE BangPatterns, ViewPatterns #-}++------------------------------------------------------------------------------+-- Module: Database.PostgreSQL.Simple.Time.Internal.Printer+-- Copyright: (c) 2012-2015 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.Time.Internal.Printer+ (+ day+ , timeOfDay+ , timeZone+ , utcTime+ , localTime+ , zonedTime+ , nominalDiffTime+ ) where++import Control.Arrow ((>>>))+import Data.ByteString.Builder (Builder, integerDec)+import Data.ByteString.Builder.Prim+ ( liftFixedToBounded, (>$<), (>*<)+ , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec)+import Data.Char ( chr )+import Data.Int ( Int32, Int64 )+import Data.Time+ ( UTCTime(..), ZonedTime(..), LocalTime(..), NominalDiffTime+ , Day, toGregorian, TimeOfDay(..), timeToTimeOfDay+ , TimeZone, timeZoneMinutes )+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
+ src/Database/PostgreSQL/Simple/ToField.hs view
@@ -0,0 +1,371 @@+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}++------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.ToField+-- Copyright: (c) 2011 MailRank, Inc.+-- (c) 2011-2012 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+--+-- The 'ToField' typeclass, for rendering a parameter to a SQL query.+--+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.ToField+ (+ Action(..)+ , ToField(..)+ , toJSONField+ , inQuotes+ ) where++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.Int (Int8, Int16, Int32, Int64)+import Data.List (intersperse)+import Data.Monoid (mappend)+import Data.Time (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime)+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 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 (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 #-}+++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 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 a JSON 'JSON.Value' using+-- 'JSON.toJSON' and convert that to a field using 'toField'.+--+-- This can be used as the default implementation for the 'toField'+-- method for Haskell types that have a JSON representation in+-- PostgreSQL.+toJSONField :: JSON.ToJSON a => a -> Action+toJSONField = toField . JSON.toJSON++-- | 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) types rest =+ typedRow (toRow val) types (multiRows vals rest)++ untypedRows :: ToRow a => [a] -> [Action] -> [Action]+ untypedRows [] _ = error funcname+ untypedRows (val:vals) rest =+ untypedRow (toRow val) (multiRows vals rest)++ multiRows :: ToRow a => [a] -> [Action] -> [Action]+ multiRows vals rest = interleaveFoldr+ (untypedRow . toRow)+ (litC ',')+ rest+ vals
+ src/Database/PostgreSQL/Simple/ToField.hs-boot view
@@ -0,0 +1,30 @@+module Database.PostgreSQL.Simple.ToField where++import Database.PostgreSQL.Simple.Types+import Data.ByteString.Builder(Builder)+import Data.ByteString(ByteString)++-- | How to render an element when substituting it into a query.+data Action =+ Plain Builder+ -- ^ Render without escaping or quoting. Use for non-text types+ -- such as numbers, when you are /certain/ that they will not+ -- introduce formatting vulnerabilities via use of characters such+ -- as spaces or \"@'@\".+ | Escape ByteString+ -- ^ Escape and enclose in quotes before substituting. Use for all+ -- text-like types, and anything else that may contain unsafe+ -- characters when rendered.+ | EscapeByteA ByteString+ -- ^ Escape binary data for use as a @bytea@ literal. Include surrounding+ -- quotes. This is used by the 'Binary' newtype wrapper.+ | EscapeIdentifier ByteString+ -- ^ Escape before substituting. Use for all sql identifiers like+ -- table, column names, etc. This is used by the 'Identifier' newtype+ -- wrapper.+ | Many [Action]+ -- ^ Concatenate a series of rendering actions.++class ToField a++instance ToField Oid
+ src/Database/PostgreSQL/Simple/ToRow.hs view
@@ -0,0 +1,113 @@+{-# 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 <leon@melding-monads.com>+-- 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.+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) => ToRow [a] where+ toRow = map toField++instance (ToRow a, ToRow b) => ToRow (a :. b) where+ toRow (a :. b) = toRow a ++ toRow b+++-- Type class for default implementation of ToRow using generics+class GToRow f where+ gtoRow :: f p -> [Action]++instance GToRow f => GToRow (M1 c i f) where+ gtoRow (M1 x) = gtoRow x++instance (GToRow f, GToRow g) => GToRow (f :*: g) where+ gtoRow (f :*: g) = gtoRow f ++ gtoRow g++instance (ToField a) => GToRow (K1 R a) where+ gtoRow (K1 a) = [toField a]++instance GToRow U1 where+ gtoRow _ = []
+ src/Database/PostgreSQL/Simple/ToRow.hs-boot view
@@ -0,0 +1,18 @@+{-# 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)
+ src/Database/PostgreSQL/Simple/Transaction.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}++------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.Transaction+-- Copyright: (c) 2011-2013 Leon P Smith+-- (c) 2013 Joey Adams+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+--+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.Transaction+ (+ -- * Transaction handling+ withTransaction+ , withTransactionLevel+ , withTransactionMode+ , 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 <https://www.postgresql.org/docs/9.5/static/transaction-iso.html>+-- for more information. Note that prior to PostgreSQL 9.0, 'RepeatableRead'+-- was equivalent to 'Serializable'.++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++-- | Like 'withTransactionMode', but also takes a custom callback to+-- determine if a transaction should be retried if an 'SqlError' occurs.+-- If the callback returns True, then the transaction will be retried.+-- If the callback returns False, or an exception other than an 'SqlError'+-- occurs then the transaction will be rolled back and the exception rethrown.+--+-- This is used to implement 'withTransactionSerializable'.+withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a+withTransactionModeRetry mode shouldRetry conn act =+ mask $ \restore ->+ retryLoop $ E.try $ do+ a <- restore act+ commit conn+ return a+ where+ retryLoop :: IO (Either E.SomeException a) -> IO a+ retryLoop act' = do+ beginMode mode conn+ r <- act'+ case r of+ Left e -> do+ rollback_ conn+ case fmap shouldRetry (E.fromException e) of+ Just True -> retryLoop act'+ _ -> E.throwIO e+ Right a ->+ return a++-- | Rollback a transaction.+rollback :: Connection -> IO ()+rollback conn = execute_ conn "ABORT" >> 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 <https://www.postgresql.org/docs/9.5/static/sql-savepoint.html>+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
+ src/Database/PostgreSQL/Simple/TypeInfo.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE RecordWildCards #-}++------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.TypeInfo+-- Copyright: (c) 2013 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- 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 pg'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)
+ src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE TemplateHaskell #-}++------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.TypeInfo.Macro+-- Copyright: (c) 2013 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- 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 = [| \(Oid x) -> $(caseE [| 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 = [| Oid $(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)
+ src/Database/PostgreSQL/Simple/TypeInfo/Static.hs view
@@ -0,0 +1,1232 @@+------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.TypeInfo+-- Copyright: (c) 2011-2012 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+--+-- This module contains portions of the @pg_type@ table that are relevant+-- to pg 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+ , bytea+ , char+ , name+ , int8+ , int2+ , int4+ , regproc+ , text+ , oid+ , tid+ , xid+ , cid+ , xml+ , point+ , lseg+ , path+ , box+ , polygon+ , line+ , cidr+ , float4+ , float8+ , unknown+ , circle+ , money+ , macaddr+ , inet+ , bpchar+ , varchar+ , date+ , time+ , timestamp+ , timestamptz+ , interval+ , timetz+ , bit+ , varbit+ , numeric+ , refcursor+ , record+ , void+ , array_record+ , regprocedure+ , regoper+ , regoperator+ , regclass+ , regtype+ , uuid+ , json+ , jsonb+ , int2vector+ , oidvector+ , array_xml+ , array_json+ , array_line+ , array_cidr+ , array_circle+ , array_money+ , array_bool+ , array_bytea+ , array_char+ , array_name+ , array_int2+ , array_int2vector+ , array_int4+ , array_regproc+ , array_text+ , array_tid+ , array_xid+ , array_cid+ , array_oidvector+ , array_bpchar+ , array_varchar+ , array_int8+ , array_point+ , array_lseg+ , array_path+ , array_box+ , array_float4+ , array_float8+ , array_polygon+ , array_oid+ , array_macaddr+ , array_inet+ , array_timestamp+ , array_date+ , array_time+ , array_timestamptz+ , array_interval+ , array_numeric+ , array_timetz+ , array_bit+ , array_varbit+ , array_refcursor+ , array_regprocedure+ , array_regoper+ , array_regoperator+ , array_regclass+ , array_regtype+ , array_uuid+ , array_jsonb+ , int4range+ , _int4range+ , numrange+ , _numrange+ , tsrange+ , _tsrange+ , tstzrange+ , _tstzrange+ , daterange+ , _daterange+ , int8range+ , _int8range+ ) 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 = Oid 16,+ typcategory = 'B',+ typdelim = ',',+ typname = "bool"+ }++bytea :: TypeInfo+bytea = Basic {+ typoid = Oid 17,+ typcategory = 'U',+ typdelim = ',',+ typname = "bytea"+ }++char :: TypeInfo+char = Basic {+ typoid = Oid 18,+ typcategory = 'S',+ typdelim = ',',+ typname = "char"+ }++name :: TypeInfo+name = Basic {+ typoid = Oid 19,+ typcategory = 'S',+ typdelim = ',',+ typname = "name"+ }++int8 :: TypeInfo+int8 = Basic {+ typoid = Oid 20,+ typcategory = 'N',+ typdelim = ',',+ typname = "int8"+ }++int2 :: TypeInfo+int2 = Basic {+ typoid = Oid 21,+ typcategory = 'N',+ typdelim = ',',+ typname = "int2"+ }++int4 :: TypeInfo+int4 = Basic {+ typoid = Oid 23,+ typcategory = 'N',+ typdelim = ',',+ typname = "int4"+ }++regproc :: TypeInfo+regproc = Basic {+ typoid = Oid 24,+ typcategory = 'N',+ typdelim = ',',+ typname = "regproc"+ }++text :: TypeInfo+text = Basic {+ typoid = Oid 25,+ typcategory = 'S',+ typdelim = ',',+ typname = "text"+ }++oid :: TypeInfo+oid = Basic {+ typoid = Oid 26,+ typcategory = 'N',+ typdelim = ',',+ typname = "oid"+ }++tid :: TypeInfo+tid = Basic {+ typoid = Oid 27,+ typcategory = 'U',+ typdelim = ',',+ typname = "tid"+ }++xid :: TypeInfo+xid = Basic {+ typoid = Oid 28,+ typcategory = 'U',+ typdelim = ',',+ typname = "xid"+ }++cid :: TypeInfo+cid = Basic {+ typoid = Oid 29,+ typcategory = 'U',+ typdelim = ',',+ typname = "cid"+ }++xml :: TypeInfo+xml = Basic {+ typoid = Oid 142,+ typcategory = 'U',+ typdelim = ',',+ typname = "xml"+ }++point :: TypeInfo+point = Basic {+ typoid = Oid 600,+ typcategory = 'G',+ typdelim = ',',+ typname = "point"+ }++lseg :: TypeInfo+lseg = Basic {+ typoid = Oid 601,+ typcategory = 'G',+ typdelim = ',',+ typname = "lseg"+ }++path :: TypeInfo+path = Basic {+ typoid = Oid 602,+ typcategory = 'G',+ typdelim = ',',+ typname = "path"+ }++box :: TypeInfo+box = Basic {+ typoid = Oid 603,+ typcategory = 'G',+ typdelim = ';',+ typname = "box"+ }++polygon :: TypeInfo+polygon = Basic {+ typoid = Oid 604,+ typcategory = 'G',+ typdelim = ',',+ typname = "polygon"+ }++line :: TypeInfo+line = Basic {+ typoid = Oid 628,+ typcategory = 'G',+ typdelim = ',',+ typname = "line"+ }++cidr :: TypeInfo+cidr = Basic {+ typoid = Oid 650,+ typcategory = 'I',+ typdelim = ',',+ typname = "cidr"+ }++float4 :: TypeInfo+float4 = Basic {+ typoid = Oid 700,+ typcategory = 'N',+ typdelim = ',',+ typname = "float4"+ }++float8 :: TypeInfo+float8 = Basic {+ typoid = Oid 701,+ typcategory = 'N',+ typdelim = ',',+ typname = "float8"+ }++unknown :: TypeInfo+unknown = Basic {+ typoid = Oid 705,+ typcategory = 'X',+ typdelim = ',',+ typname = "unknown"+ }++circle :: TypeInfo+circle = Basic {+ typoid = Oid 718,+ typcategory = 'G',+ typdelim = ',',+ typname = "circle"+ }++money :: TypeInfo+money = Basic {+ typoid = Oid 790,+ typcategory = 'N',+ typdelim = ',',+ typname = "money"+ }++macaddr :: TypeInfo+macaddr = Basic {+ typoid = Oid 829,+ typcategory = 'U',+ typdelim = ',',+ typname = "macaddr"+ }++inet :: TypeInfo+inet = Basic {+ typoid = Oid 869,+ typcategory = 'I',+ typdelim = ',',+ typname = "inet"+ }++bpchar :: TypeInfo+bpchar = Basic {+ typoid = Oid 1042,+ typcategory = 'S',+ typdelim = ',',+ typname = "bpchar"+ }++varchar :: TypeInfo+varchar = Basic {+ typoid = Oid 1043,+ typcategory = 'S',+ typdelim = ',',+ typname = "varchar"+ }++date :: TypeInfo+date = Basic {+ typoid = Oid 1082,+ typcategory = 'D',+ typdelim = ',',+ typname = "date"+ }++time :: TypeInfo+time = Basic {+ typoid = Oid 1083,+ typcategory = 'D',+ typdelim = ',',+ typname = "time"+ }++timestamp :: TypeInfo+timestamp = Basic {+ typoid = Oid 1114,+ typcategory = 'D',+ typdelim = ',',+ typname = "timestamp"+ }++timestamptz :: TypeInfo+timestamptz = Basic {+ typoid = Oid 1184,+ typcategory = 'D',+ typdelim = ',',+ typname = "timestamptz"+ }++interval :: TypeInfo+interval = Basic {+ typoid = Oid 1186,+ typcategory = 'T',+ typdelim = ',',+ typname = "interval"+ }++timetz :: TypeInfo+timetz = Basic {+ typoid = Oid 1266,+ typcategory = 'D',+ typdelim = ',',+ typname = "timetz"+ }++bit :: TypeInfo+bit = Basic {+ typoid = Oid 1560,+ typcategory = 'V',+ typdelim = ',',+ typname = "bit"+ }++varbit :: TypeInfo+varbit = Basic {+ typoid = Oid 1562,+ typcategory = 'V',+ typdelim = ',',+ typname = "varbit"+ }++numeric :: TypeInfo+numeric = Basic {+ typoid = Oid 1700,+ typcategory = 'N',+ typdelim = ',',+ typname = "numeric"+ }++refcursor :: TypeInfo+refcursor = Basic {+ typoid = Oid 1790,+ typcategory = 'U',+ typdelim = ',',+ typname = "refcursor"+ }++record :: TypeInfo+record = Basic {+ typoid = Oid 2249,+ typcategory = 'P',+ typdelim = ',',+ typname = "record"+ }++void :: TypeInfo+void = Basic {+ typoid = Oid 2278,+ typcategory = 'P',+ typdelim = ',',+ typname = "void"+ }++array_record :: TypeInfo+array_record = Array {+ typoid = Oid 2287,+ typcategory = 'P',+ typdelim = ',',+ typname = "_record",+ typelem = record+ }++regprocedure :: TypeInfo+regprocedure = Basic {+ typoid = Oid 2202,+ typcategory = 'N',+ typdelim = ',',+ typname = "regprocedure"+ }++regoper :: TypeInfo+regoper = Basic {+ typoid = Oid 2203,+ typcategory = 'N',+ typdelim = ',',+ typname = "regoper"+ }++regoperator :: TypeInfo+regoperator = Basic {+ typoid = Oid 2204,+ typcategory = 'N',+ typdelim = ',',+ typname = "regoperator"+ }++regclass :: TypeInfo+regclass = Basic {+ typoid = Oid 2205,+ typcategory = 'N',+ typdelim = ',',+ typname = "regclass"+ }++regtype :: TypeInfo+regtype = Basic {+ typoid = Oid 2206,+ typcategory = 'N',+ typdelim = ',',+ typname = "regtype"+ }++uuid :: TypeInfo+uuid = Basic {+ typoid = Oid 2950,+ typcategory = 'U',+ typdelim = ',',+ typname = "uuid"+ }++json :: TypeInfo+json = Basic {+ typoid = Oid 114,+ typcategory = 'U',+ typdelim = ',',+ typname = "json"+ }++jsonb :: TypeInfo+jsonb = Basic {+ typoid = Oid 3802,+ typcategory = 'U',+ typdelim = ',',+ typname = "jsonb"+ }++int2vector :: TypeInfo+int2vector = Array {+ typoid = Oid 22,+ typcategory = 'A',+ typdelim = ',',+ typname = "int2vector",+ typelem = int2+ }++oidvector :: TypeInfo+oidvector = Array {+ typoid = Oid 30,+ typcategory = 'A',+ typdelim = ',',+ typname = "oidvector",+ typelem = oid+ }++array_xml :: TypeInfo+array_xml = Array {+ typoid = Oid 143,+ typcategory = 'A',+ typdelim = ',',+ typname = "_xml",+ typelem = xml+ }++array_json :: TypeInfo+array_json = Array {+ typoid = Oid 199,+ typcategory = 'A',+ typdelim = ',',+ typname = "_json",+ typelem = json+ }++array_line :: TypeInfo+array_line = Array {+ typoid = Oid 629,+ typcategory = 'A',+ typdelim = ',',+ typname = "_line",+ typelem = line+ }++array_cidr :: TypeInfo+array_cidr = Array {+ typoid = Oid 651,+ typcategory = 'A',+ typdelim = ',',+ typname = "_cidr",+ typelem = cidr+ }++array_circle :: TypeInfo+array_circle = Array {+ typoid = Oid 719,+ typcategory = 'A',+ typdelim = ',',+ typname = "_circle",+ typelem = circle+ }++array_money :: TypeInfo+array_money = Array {+ typoid = Oid 791,+ typcategory = 'A',+ typdelim = ',',+ typname = "_money",+ typelem = money+ }++array_bool :: TypeInfo+array_bool = Array {+ typoid = Oid 1000,+ typcategory = 'A',+ typdelim = ',',+ typname = "_bool",+ typelem = bool+ }++array_bytea :: TypeInfo+array_bytea = Array {+ typoid = Oid 1001,+ typcategory = 'A',+ typdelim = ',',+ typname = "_bytea",+ typelem = bytea+ }++array_char :: TypeInfo+array_char = Array {+ typoid = Oid 1002,+ typcategory = 'A',+ typdelim = ',',+ typname = "_char",+ typelem = char+ }++array_name :: TypeInfo+array_name = Array {+ typoid = Oid 1003,+ typcategory = 'A',+ typdelim = ',',+ typname = "_name",+ typelem = name+ }++array_int2 :: TypeInfo+array_int2 = Array {+ typoid = Oid 1005,+ typcategory = 'A',+ typdelim = ',',+ typname = "_int2",+ typelem = int2+ }++array_int2vector :: TypeInfo+array_int2vector = Array {+ typoid = Oid 1006,+ typcategory = 'A',+ typdelim = ',',+ typname = "_int2vector",+ typelem = int2vector+ }++array_int4 :: TypeInfo+array_int4 = Array {+ typoid = Oid 1007,+ typcategory = 'A',+ typdelim = ',',+ typname = "_int4",+ typelem = int4+ }++array_regproc :: TypeInfo+array_regproc = Array {+ typoid = Oid 1008,+ typcategory = 'A',+ typdelim = ',',+ typname = "_regproc",+ typelem = regproc+ }++array_text :: TypeInfo+array_text = Array {+ typoid = Oid 1009,+ typcategory = 'A',+ typdelim = ',',+ typname = "_text",+ typelem = text+ }++array_tid :: TypeInfo+array_tid = Array {+ typoid = Oid 1010,+ typcategory = 'A',+ typdelim = ',',+ typname = "_tid",+ typelem = tid+ }++array_xid :: TypeInfo+array_xid = Array {+ typoid = Oid 1011,+ typcategory = 'A',+ typdelim = ',',+ typname = "_xid",+ typelem = xid+ }++array_cid :: TypeInfo+array_cid = Array {+ typoid = Oid 1012,+ typcategory = 'A',+ typdelim = ',',+ typname = "_cid",+ typelem = cid+ }++array_oidvector :: TypeInfo+array_oidvector = Array {+ typoid = Oid 1013,+ typcategory = 'A',+ typdelim = ',',+ typname = "_oidvector",+ typelem = oidvector+ }++array_bpchar :: TypeInfo+array_bpchar = Array {+ typoid = Oid 1014,+ typcategory = 'A',+ typdelim = ',',+ typname = "_bpchar",+ typelem = bpchar+ }++array_varchar :: TypeInfo+array_varchar = Array {+ typoid = Oid 1015,+ typcategory = 'A',+ typdelim = ',',+ typname = "_varchar",+ typelem = varchar+ }++array_int8 :: TypeInfo+array_int8 = Array {+ typoid = Oid 1016,+ typcategory = 'A',+ typdelim = ',',+ typname = "_int8",+ typelem = int8+ }++array_point :: TypeInfo+array_point = Array {+ typoid = Oid 1017,+ typcategory = 'A',+ typdelim = ',',+ typname = "_point",+ typelem = point+ }++array_lseg :: TypeInfo+array_lseg = Array {+ typoid = Oid 1018,+ typcategory = 'A',+ typdelim = ',',+ typname = "_lseg",+ typelem = lseg+ }++array_path :: TypeInfo+array_path = Array {+ typoid = Oid 1019,+ typcategory = 'A',+ typdelim = ',',+ typname = "_path",+ typelem = path+ }++array_box :: TypeInfo+array_box = Array {+ typoid = Oid 1020,+ typcategory = 'A',+ typdelim = ';',+ typname = "_box",+ typelem = box+ }++array_float4 :: TypeInfo+array_float4 = Array {+ typoid = Oid 1021,+ typcategory = 'A',+ typdelim = ',',+ typname = "_float4",+ typelem = float4+ }++array_float8 :: TypeInfo+array_float8 = Array {+ typoid = Oid 1022,+ typcategory = 'A',+ typdelim = ',',+ typname = "_float8",+ typelem = float8+ }++array_polygon :: TypeInfo+array_polygon = Array {+ typoid = Oid 1027,+ typcategory = 'A',+ typdelim = ',',+ typname = "_polygon",+ typelem = polygon+ }++array_oid :: TypeInfo+array_oid = Array {+ typoid = Oid 1028,+ typcategory = 'A',+ typdelim = ',',+ typname = "_oid",+ typelem = oid+ }++array_macaddr :: TypeInfo+array_macaddr = Array {+ typoid = Oid 1040,+ typcategory = 'A',+ typdelim = ',',+ typname = "_macaddr",+ typelem = macaddr+ }++array_inet :: TypeInfo+array_inet = Array {+ typoid = Oid 1041,+ typcategory = 'A',+ typdelim = ',',+ typname = "_inet",+ typelem = inet+ }++array_timestamp :: TypeInfo+array_timestamp = Array {+ typoid = Oid 1115,+ typcategory = 'A',+ typdelim = ',',+ typname = "_timestamp",+ typelem = timestamp+ }++array_date :: TypeInfo+array_date = Array {+ typoid = Oid 1182,+ typcategory = 'A',+ typdelim = ',',+ typname = "_date",+ typelem = date+ }++array_time :: TypeInfo+array_time = Array {+ typoid = Oid 1183,+ typcategory = 'A',+ typdelim = ',',+ typname = "_time",+ typelem = time+ }++array_timestamptz :: TypeInfo+array_timestamptz = Array {+ typoid = Oid 1185,+ typcategory = 'A',+ typdelim = ',',+ typname = "_timestamptz",+ typelem = timestamptz+ }++array_interval :: TypeInfo+array_interval = Array {+ typoid = Oid 1187,+ typcategory = 'A',+ typdelim = ',',+ typname = "_interval",+ typelem = interval+ }++array_numeric :: TypeInfo+array_numeric = Array {+ typoid = Oid 1231,+ typcategory = 'A',+ typdelim = ',',+ typname = "_numeric",+ typelem = numeric+ }++array_timetz :: TypeInfo+array_timetz = Array {+ typoid = Oid 1270,+ typcategory = 'A',+ typdelim = ',',+ typname = "_timetz",+ typelem = timetz+ }++array_bit :: TypeInfo+array_bit = Array {+ typoid = Oid 1561,+ typcategory = 'A',+ typdelim = ',',+ typname = "_bit",+ typelem = bit+ }++array_varbit :: TypeInfo+array_varbit = Array {+ typoid = Oid 1563,+ typcategory = 'A',+ typdelim = ',',+ typname = "_varbit",+ typelem = varbit+ }++array_refcursor :: TypeInfo+array_refcursor = Array {+ typoid = Oid 2201,+ typcategory = 'A',+ typdelim = ',',+ typname = "_refcursor",+ typelem = refcursor+ }++array_regprocedure :: TypeInfo+array_regprocedure = Array {+ typoid = Oid 2207,+ typcategory = 'A',+ typdelim = ',',+ typname = "_regprocedure",+ typelem = regprocedure+ }++array_regoper :: TypeInfo+array_regoper = Array {+ typoid = Oid 2208,+ typcategory = 'A',+ typdelim = ',',+ typname = "_regoper",+ typelem = regoper+ }++array_regoperator :: TypeInfo+array_regoperator = Array {+ typoid = Oid 2209,+ typcategory = 'A',+ typdelim = ',',+ typname = "_regoperator",+ typelem = regoperator+ }++array_regclass :: TypeInfo+array_regclass = Array {+ typoid = Oid 2210,+ typcategory = 'A',+ typdelim = ',',+ typname = "_regclass",+ typelem = regclass+ }++array_regtype :: TypeInfo+array_regtype = Array {+ typoid = Oid 2211,+ typcategory = 'A',+ typdelim = ',',+ typname = "_regtype",+ typelem = regtype+ }++array_uuid :: TypeInfo+array_uuid = Array {+ typoid = Oid 2951,+ typcategory = 'A',+ typdelim = ',',+ typname = "_uuid",+ typelem = uuid+ }++array_jsonb :: TypeInfo+array_jsonb = Array {+ typoid = Oid 3807,+ typcategory = 'A',+ typdelim = ',',+ typname = "_jsonb",+ typelem = jsonb+ }++int4range :: TypeInfo+int4range = Range {+ typoid = Oid 3904,+ typcategory = 'R',+ typdelim = ',',+ typname = "int4range",+ rngsubtype = int4+ }++_int4range :: TypeInfo+_int4range = Array {+ typoid = Oid 3905,+ typcategory = 'A',+ typdelim = ',',+ typname = "_int4range",+ typelem = int4range+ }++numrange :: TypeInfo+numrange = Range {+ typoid = Oid 3906,+ typcategory = 'R',+ typdelim = ',',+ typname = "numrange",+ rngsubtype = numeric+ }++_numrange :: TypeInfo+_numrange = Array {+ typoid = Oid 3907,+ typcategory = 'A',+ typdelim = ',',+ typname = "_numrange",+ typelem = numrange+ }++tsrange :: TypeInfo+tsrange = Range {+ typoid = Oid 3908,+ typcategory = 'R',+ typdelim = ',',+ typname = "tsrange",+ rngsubtype = timestamp+ }++_tsrange :: TypeInfo+_tsrange = Array {+ typoid = Oid 3909,+ typcategory = 'A',+ typdelim = ',',+ typname = "_tsrange",+ typelem = tsrange+ }++tstzrange :: TypeInfo+tstzrange = Range {+ typoid = Oid 3910,+ typcategory = 'R',+ typdelim = ',',+ typname = "tstzrange",+ rngsubtype = timestamptz+ }++_tstzrange :: TypeInfo+_tstzrange = Array {+ typoid = Oid 3911,+ typcategory = 'A',+ typdelim = ',',+ typname = "_tstzrange",+ typelem = tstzrange+ }++daterange :: TypeInfo+daterange = Range {+ typoid = Oid 3912,+ typcategory = 'R',+ typdelim = ',',+ typname = "daterange",+ rngsubtype = date+ }++_daterange :: TypeInfo+_daterange = Array {+ typoid = Oid 3913,+ typcategory = 'A',+ typdelim = ',',+ typname = "_daterange",+ typelem = daterange+ }++int8range :: TypeInfo+int8range = Range {+ typoid = Oid 3926,+ typcategory = 'R',+ typdelim = ',',+ typname = "int8range",+ rngsubtype = int8+ }++_int8range :: TypeInfo+_int8range = Array {+ typoid = Oid 3927,+ typcategory = 'A',+ typdelim = ',',+ typname = "_int8range",+ typelem = int8range+ }
+ src/Database/PostgreSQL/Simple/TypeInfo/Types.hs view
@@ -0,0 +1,56 @@+------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.TypeInfo.Types+-- Copyright: (c) 2013 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- 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)
+ src/Database/PostgreSQL/Simple/Types.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE 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 <leon@melding-monads.com>+-- 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.Monoid (Monoid(..))+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 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 Monoid Query where+ mempty = Query B.empty+ mappend (Query a) (Query b) = Query (B.append a b)+ {-# INLINE mappend #-}+ mconcat xs = Query (B.concat (map fromQuery xs))++-- | A single-value \"collection\".+--+-- This is useful if you need to supply a single parameter to a SQL+-- query, or extract a single column from a SQL result.+--+-- Parameter example:+--+-- @query c \"select x from scores where x > ?\" ('Only' (42::Int))@+--+-- Result example:+--+-- @xs <- query_ c \"select id from users\"+--forM_ xs $ \\('Only' id) -> {- ... -}@+newtype Only a = Only {+ fromOnly :: a+ } deriving (Eq, Ord, Read, Show, Typeable, Functor)++-- | Wrap a list of values for use in an @IN@ clause. Replaces a+-- single \"@?@\" character with a parenthesized list of rendered+-- values.+--+-- 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, pg will throw an exception+-- without issuing the query. In the second case, the postgres server+-- will return an error which will be turned into a @SqlError@ exception.+--+-- See <https://www.postgresql.org/docs/9.5/static/sql-values.html> for+-- more information.+data Values a = Values [QualifiedIdentifier] [a]+ deriving (Eq, Ord, Show, Read, Typeable)
+ test/Common.hs view
@@ -0,0 +1,32 @@+module 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
+ test/Main.hs view
@@ -0,0 +1,485 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE ScopedTypeVariables #-}+import Common+import Database.PostgreSQL.Simple.FromField (FromField)+import Database.PostgreSQL.Simple.Types(Query(..),Values(..))+import Database.PostgreSQL.Simple.HStore+import Database.PostgreSQL.Simple.Copy+import qualified Database.PostgreSQL.Simple.Transaction as ST++import Control.Applicative+import Control.Exception as E+import Control.Monad+import Data.Char+import Data.List (sort)+import Data.IORef+import Data.Typeable+import GHC.Generics (Generic)++import Data.Aeson+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy.Char8 as BL+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(getCurrentTime, diffUTCTime)++import Test.Tasty+import Test.Tasty.Golden+import Notify+import Serializable+import Time++tests :: TestEnv -> TestTree+tests env = testGroup "tests"+ $ map ($ env)+ [ testBytea+ , testCase "ExecuteMany" . testExecuteMany+ , testCase "Fold" . testFold+ , testCase "Notify" . testNotify+ , testCase "Serializable" . testSerializable+ , testCase "Time" . testTime+ , testCase "Array" . testArray+ , testCase "Array of nullables" . testNullableArray+ , testCase "HStore" . testHStore+ , testCase "JSON" . testJSON+ , testCase "Savepoint" . testSavepoint+ , testCase "Unicode" . testUnicode+ , testCase "Values" . testValues+ , testCase "Copy" . testCopy+ , 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) | a <- [1..100], b <- [1..50]]++ -- 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'++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'++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+ 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 =+ goldenVsString testName (resultsDir </> fileName<.>"expected")+ where+ resultsDir = "test" </> "results"+ fileName = map normalize testName+ normalize c | not (isAlpha c) = '-'+ | otherwise = c++-- | 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"++------------------------------------------------------------------------++-- | Action for connecting to the database that will be used for testing.+--+-- Note that some tests, such as Notify, use multiple connections, and assume+-- that 'testConnect' connects to the same database every time it is called.+testConnect :: IO Connection+testConnect = connectPostgreSQL ""++withTestEnv :: (TestEnv -> IO a) -> IO a+withTestEnv cb =+ withConn $ \conn ->+ cb TestEnv+ { conn = conn+ , withConn = withConn+ }+ where+ withConn = bracket testConnect close++main :: IO ()+main = withTestEnv $ defaultMain . tests
+ test/Notify.hs view
@@ -0,0 +1,41 @@+module 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]
+ test/Serializable.hs view
@@ -0,0 +1,68 @@+module 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 ()
+ test/Time.hs view
@@ -0,0 +1,119 @@+{-# 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+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]