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