diff -Nru haskell-postgresql-simple-0.4.10.0/CONTRIBUTORS haskell-postgresql-simple-0.5.1.2/CONTRIBUTORS --- haskell-postgresql-simple-0.4.10.0/CONTRIBUTORS 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/CONTRIBUTORS 2015-12-14 19:49:35.000000000 +0000 @@ -20,3 +20,13 @@ Chris Allen Simon Hengel Tom Ellis +Mike Ledger +João Cristóvão +Bardur Arantsson +Travis Staton +Sam Rijs +Janne Hellsten +Timmy Tofu +Alexey Khudyakov +Timo von Holtz +Amit Levy diff -Nru haskell-postgresql-simple-0.4.10.0/debian/changelog haskell-postgresql-simple-0.5.1.2/debian/changelog --- haskell-postgresql-simple-0.4.10.0/debian/changelog 2015-12-04 05:05:10.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/debian/changelog 2016-01-25 12:54:14.000000000 +0000 @@ -1,3 +1,15 @@ +haskell-postgresql-simple (0.5.1.2-1build1) xenial; urgency=medium + + * Rebuild for new GHC ABIs. + + -- Colin Watson Mon, 25 Jan 2016 12:54:14 +0000 + +haskell-postgresql-simple (0.5.1.2-1) unstable; urgency=medium + + * New upstream release + + -- Clint Adams Sun, 10 Jan 2016 23:55:03 -0500 + haskell-postgresql-simple (0.4.10.0-5) unstable; urgency=medium * Switch Vcs-Git/Vcs-Browser headers to new location. diff -Nru haskell-postgresql-simple-0.4.10.0/debian/control haskell-postgresql-simple-0.5.1.2/debian/control --- haskell-postgresql-simple-0.4.10.0/debian/control 2015-12-04 05:05:10.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/debian/control 2016-01-11 04:55:20.000000000 +0000 @@ -12,10 +12,6 @@ libghc-aeson-prof, libghc-attoparsec-dev (>= 0.10.3), libghc-attoparsec-prof, - libghc-blaze-builder-dev, - libghc-blaze-builder-prof, - libghc-blaze-textual-dev, - libghc-blaze-textual-prof, libghc-case-insensitive-dev, libghc-case-insensitive-prof, libghc-hashable-dev, @@ -27,21 +23,19 @@ libghc-scientific-prof, libghc-text-dev (>= 0.11.1), libghc-text-prof, - libghc-uuid-dev (>= 1.3.1), - libghc-uuid-prof, + libghc-uuid-types-dev (>= 1.0.0), + libghc-uuid-types-prof, libghc-vector-dev, libghc-vector-prof, Build-Depends-Indep: ghc-doc, libghc-aeson-doc, libghc-attoparsec-doc, - libghc-blaze-builder-doc, - libghc-blaze-textual-doc, libghc-case-insensitive-doc, libghc-hashable-doc, libghc-postgresql-libpq-doc, libghc-scientific-doc, libghc-text-doc, - libghc-uuid-doc, + libghc-uuid-types-doc, libghc-vector-doc, Standards-Version: 3.9.6 Homepage: http://hackage.haskell.org/package/postgresql-simple diff -Nru haskell-postgresql-simple-0.4.10.0/debian/patches/no-bytestring-builder haskell-postgresql-simple-0.5.1.2/debian/patches/no-bytestring-builder --- haskell-postgresql-simple-0.4.10.0/debian/patches/no-bytestring-builder 1970-01-01 00:00:00.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/debian/patches/no-bytestring-builder 2016-01-11 04:55:45.000000000 +0000 @@ -0,0 +1,10 @@ +--- a/postgresql-simple.cabal ++++ b/postgresql-simple.cabal +@@ -58,7 +58,6 @@ + attoparsec >= 0.10.3, + base >= 4.4 && < 5, + bytestring >= 0.9, +- bytestring-builder, + case-insensitive, + containers, + hashable, diff -Nru haskell-postgresql-simple-0.4.10.0/debian/patches/series haskell-postgresql-simple-0.5.1.2/debian/patches/series --- haskell-postgresql-simple-0.4.10.0/debian/patches/series 1970-01-01 00:00:00.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/debian/patches/series 2016-01-11 04:55:34.000000000 +0000 @@ -0,0 +1 @@ +no-bytestring-builder diff -Nru haskell-postgresql-simple-0.4.10.0/postgresql-simple.cabal haskell-postgresql-simple-0.5.1.2/postgresql-simple.cabal --- haskell-postgresql-simple-0.4.10.0/postgresql-simple.cabal 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/postgresql-simple.cabal 2015-12-14 19:49:35.000000000 +0000 @@ -1,5 +1,5 @@ Name: postgresql-simple -Version: 0.4.10.0 +Version: 0.5.1.2 Synopsis: Mid-Level PostgreSQL client library Description: Mid-Level PostgreSQL client library, forked from mysql-simple. @@ -8,7 +8,7 @@ Author: Bryan O'Sullivan, Leon P Smith Maintainer: Leon P Smith Copyright: (c) 2011 MailRank, Inc. - (c) 2011-2013 Leon P Smith + (c) 2011-2015 Leon P Smith Category: Database Build-type: Simple @@ -22,7 +22,6 @@ Exposed-modules: Database.PostgreSQL.Simple Database.PostgreSQL.Simple.Arrays - Database.PostgreSQL.Simple.BuiltinTypes Database.PostgreSQL.Simple.Copy Database.PostgreSQL.Simple.FromField Database.PostgreSQL.Simple.FromRow @@ -31,6 +30,7 @@ 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 @@ -49,15 +49,16 @@ Database.PostgreSQL.Simple.Compat Database.PostgreSQL.Simple.HStore.Implementation Database.PostgreSQL.Simple.Time.Implementation + Database.PostgreSQL.Simple.Time.Internal.Parser + Database.PostgreSQL.Simple.Time.Internal.Printer Database.PostgreSQL.Simple.TypeInfo.Types Build-depends: aeson >= 0.6, attoparsec >= 0.10.3, - base < 5, - blaze-builder, - blaze-textual, + base >= 4.4 && < 5, bytestring >= 0.9, + bytestring-builder, case-insensitive, containers, hashable, @@ -66,10 +67,14 @@ text >= 0.11.1, time, transformers, - uuid >= 1.3.1, + uuid-types >= 1.0.0, scientific, vector + if !impl(ghc >= 7.6) + Build-depends: + ghc-prim + extensions: DoAndIfThenElse, OverloadedStrings, BangPatterns, ViewPatterns TypeOperators @@ -82,7 +87,7 @@ source-repository this type: git location: http://github.com/lpsmith/postgresql-simple - tag: v0.4.10.0 + tag: v0.5.1.2 test-suite test type: exitcode-stdio-1.0 @@ -115,3 +120,7 @@ , text , time , vector + + if !impl(ghc >= 7.6) + build-depends: + ghc-prim diff -Nru haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/BuiltinTypes.hs haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/BuiltinTypes.hs --- haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/BuiltinTypes.hs 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/BuiltinTypes.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,428 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} - ------------------------------------------------------------------------------- --- | --- Module: Database.PostgreSQL.Simple.BuiltinTypes --- Copyright: (c) 2011-2012 Leon P Smith --- License: BSD3 --- Maintainer: Leon P Smith --- Stability: experimental --- ------------------------------------------------------------------------------- - --- Note that this file is generated by tools/GenBuiltinTypes.hs, and should --- not be edited directly - -module Database.PostgreSQL.Simple.BuiltinTypes - {-# DEPRECATED "Use TypeInfo instead" #-} - ( BuiltinType (..) - , builtin2oid - , oid2builtin - , builtin2typname - , oid2typname - ) where - -import Data.Typeable -import Data.ByteString (ByteString) -import qualified Database.PostgreSQL.LibPQ as PQ - -data BuiltinType - = Bool - | ByteA - | Char - | Name - | Int8 - | Int2 - | Int4 - | RegProc - | Text - | Oid - | Tid - | Xid - | Cid - | Xml - | Point - | LSeg - | Path - | Box - | Polygon - | Line - | Cidr - | Float4 - | Float8 - | AbsTime - | RelTime - | TInterval - | Unknown - | Circle - | Money - | MacAddr - | Inet - | BpChar - | VarChar - | Date - | Time - | Timestamp - | TimestampTZ - | Interval - | TimeTZ - | Bit - | VarBit - | Numeric - | RefCursor - | Record - | Void - | UUID - | JSON - | JSONB - deriving (Eq, Ord, Enum, Bounded, Read, Show, Typeable) - -builtin2oid :: BuiltinType -> PQ.Oid -builtin2oid typ = PQ.Oid $ case typ of - Bool -> 16 - ByteA -> 17 - Char -> 18 - Name -> 19 - Int8 -> 20 - Int2 -> 21 - Int4 -> 23 - RegProc -> 24 - Text -> 25 - Oid -> 26 - Tid -> 27 - Xid -> 28 - Cid -> 29 - Xml -> 142 - Point -> 600 - LSeg -> 601 - Path -> 602 - Box -> 603 - Polygon -> 604 - Line -> 628 - Cidr -> 650 - Float4 -> 700 - Float8 -> 701 - AbsTime -> 702 - RelTime -> 703 - TInterval -> 704 - Unknown -> 705 - Circle -> 718 - Money -> 790 - MacAddr -> 829 - Inet -> 869 - BpChar -> 1042 - VarChar -> 1043 - Date -> 1082 - Time -> 1083 - Timestamp -> 1114 - TimestampTZ -> 1184 - Interval -> 1186 - TimeTZ -> 1266 - Bit -> 1560 - VarBit -> 1562 - Numeric -> 1700 - RefCursor -> 1790 - Record -> 2249 - Void -> 2278 - UUID -> 2950 - JSON -> 114 - JSONB -> 3802 - -oid2builtin :: PQ.Oid -> Maybe BuiltinType -oid2builtin (PQ.Oid x) = case x of - 16 -> Just Bool - 17 -> Just ByteA - 18 -> Just Char - 19 -> Just Name - 20 -> Just Int8 - 21 -> Just Int2 - 23 -> Just Int4 - 24 -> Just RegProc - 25 -> Just Text - 26 -> Just Oid - 27 -> Just Tid - 28 -> Just Xid - 29 -> Just Cid - 142 -> Just Xml - 600 -> Just Point - 601 -> Just LSeg - 602 -> Just Path - 603 -> Just Box - 604 -> Just Polygon - 628 -> Just Line - 650 -> Just Cidr - 700 -> Just Float4 - 701 -> Just Float8 - 702 -> Just AbsTime - 703 -> Just RelTime - 704 -> Just TInterval - 705 -> Just Unknown - 718 -> Just Circle - 790 -> Just Money - 829 -> Just MacAddr - 869 -> Just Inet - 1042 -> Just BpChar - 1043 -> Just VarChar - 1082 -> Just Date - 1083 -> Just Time - 1114 -> Just Timestamp - 1184 -> Just TimestampTZ - 1186 -> Just Interval - 1266 -> Just TimeTZ - 1560 -> Just Bit - 1562 -> Just VarBit - 1700 -> Just Numeric - 1790 -> Just RefCursor - 2249 -> Just Record - 2278 -> Just Void - 2950 -> Just UUID - 114 -> Just JSON - 3802 -> Just JSONB - _ -> Nothing - -builtin2typname :: BuiltinType -> ByteString -builtin2typname typ = case typ of - Bool -> bool - ByteA -> bytea - Char -> char - Name -> name - Int8 -> int8 - Int2 -> int2 - Int4 -> int4 - RegProc -> regproc - Text -> text - Oid -> oid - Tid -> tid - Xid -> xid - Cid -> cid - Xml -> xml - Point -> point - LSeg -> lseg - Path -> path - Box -> box - Polygon -> polygon - Line -> line - Cidr -> cidr - Float4 -> float4 - Float8 -> float8 - AbsTime -> abstime - RelTime -> reltime - TInterval -> tinterval - Unknown -> unknown - Circle -> circle - Money -> money - MacAddr -> macaddr - Inet -> inet - BpChar -> bpchar - VarChar -> varchar - Date -> date - Time -> time - Timestamp -> timestamp - TimestampTZ -> timestamptz - Interval -> interval - TimeTZ -> timetz - Bit -> bit - VarBit -> varbit - Numeric -> numeric - RefCursor -> refcursor - Record -> record - Void -> void - UUID -> uuid - JSON -> json - JSONB -> jsonb - -oid2typname :: PQ.Oid -> Maybe ByteString -oid2typname (PQ.Oid x) = case x of - 16 -> Just bool - 17 -> Just bytea - 18 -> Just char - 19 -> Just name - 20 -> Just int8 - 21 -> Just int2 - 23 -> Just int4 - 24 -> Just regproc - 25 -> Just text - 26 -> Just oid - 27 -> Just tid - 28 -> Just xid - 29 -> Just cid - 142 -> Just xml - 600 -> Just point - 601 -> Just lseg - 602 -> Just path - 603 -> Just box - 604 -> Just polygon - 628 -> Just line - 650 -> Just cidr - 700 -> Just float4 - 701 -> Just float8 - 702 -> Just abstime - 703 -> Just reltime - 704 -> Just tinterval - 705 -> Just unknown - 718 -> Just circle - 790 -> Just money - 829 -> Just macaddr - 869 -> Just inet - 1042 -> Just bpchar - 1043 -> Just varchar - 1082 -> Just date - 1083 -> Just time - 1114 -> Just timestamp - 1184 -> Just timestamptz - 1186 -> Just interval - 1266 -> Just timetz - 1560 -> Just bit - 1562 -> Just varbit - 1700 -> Just numeric - 1790 -> Just refcursor - 2249 -> Just record - 2278 -> Just void - 2950 -> Just uuid - 114 -> Just json - 3802 -> Just jsonb - _ -> Nothing - -bool :: ByteString -bool = "bool" - -bytea :: ByteString -bytea = "bytea" - -char :: ByteString -char = "char" - -name :: ByteString -name = "name" - -int8 :: ByteString -int8 = "int8" - -int2 :: ByteString -int2 = "int2" - -int4 :: ByteString -int4 = "int4" - -regproc :: ByteString -regproc = "regproc" - -text :: ByteString -text = "text" - -oid :: ByteString -oid = "oid" - -tid :: ByteString -tid = "tid" - -xid :: ByteString -xid = "xid" - -cid :: ByteString -cid = "cid" - -xml :: ByteString -xml = "xml" - -point :: ByteString -point = "point" - -lseg :: ByteString -lseg = "lseg" - -path :: ByteString -path = "path" - -box :: ByteString -box = "box" - -polygon :: ByteString -polygon = "polygon" - -line :: ByteString -line = "line" - -cidr :: ByteString -cidr = "cidr" - -float4 :: ByteString -float4 = "float4" - -float8 :: ByteString -float8 = "float8" - -abstime :: ByteString -abstime = "abstime" - -reltime :: ByteString -reltime = "reltime" - -tinterval :: ByteString -tinterval = "tinterval" - -unknown :: ByteString -unknown = "unknown" - -circle :: ByteString -circle = "circle" - -money :: ByteString -money = "money" - -macaddr :: ByteString -macaddr = "macaddr" - -inet :: ByteString -inet = "inet" - -bpchar :: ByteString -bpchar = "bpchar" - -varchar :: ByteString -varchar = "varchar" - -date :: ByteString -date = "date" - -time :: ByteString -time = "time" - -timestamp :: ByteString -timestamp = "timestamp" - -timestamptz :: ByteString -timestamptz = "timestamptz" - -interval :: ByteString -interval = "interval" - -timetz :: ByteString -timetz = "timetz" - -bit :: ByteString -bit = "bit" - -varbit :: ByteString -varbit = "varbit" - -numeric :: ByteString -numeric = "numeric" - -refcursor :: ByteString -refcursor = "refcursor" - -record :: ByteString -record = "record" - -void :: ByteString -void = "void" - -uuid :: ByteString -uuid = "uuid" - -json :: ByteString -json = "json" - -jsonb :: ByteString -jsonb = "jsonb" diff -Nru haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/Compat.hs haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Compat.hs --- haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/Compat.hs 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Compat.hs 2015-12-14 19:49:35.000000000 +0000 @@ -5,10 +5,28 @@ ( mask , (<>) , unsafeDupablePerformIO + , toByteString + , scientificBuilder + , toPico + , fromPico ) where import qualified Control.Exception as E import Data.Monoid +import Data.ByteString (ByteString) +#if MIN_VERSION_bytestring(0,10,0) +import Data.ByteString.Lazy (toStrict) +#else +import qualified Data.ByteString as B +import Data.ByteString.Lazy (toChunks) +#endif +import Data.ByteString.Builder (Builder, toLazyByteString) + +#if MIN_VERSION_scientific(0,3,0) +import Data.Text.Lazy.Builder.Scientific (scientificBuilder) +#else +import Data.Scientific (scientificBuilder) +#endif #if __GLASGOW_HASKELL__ >= 702 import System.IO.Unsafe (unsafeDupablePerformIO) @@ -18,6 +36,12 @@ 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. -- @@ -43,3 +67,28 @@ (<>) = 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 -Nru haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/Errors.hs haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Errors.hs --- haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/Errors.hs 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Errors.hs 2015-12-14 19:49:35.000000000 +0000 @@ -55,6 +55,8 @@ -- ^ Name of violated constraint | CheckViolation ByteString ByteString -- ^ Relation name (usually table), constraint name + | ExclusionViolation ByteString + -- ^ Name of the exclusion violation constraint deriving (Show, Eq, Ord, Typeable) -- Default instance should be enough @@ -75,6 +77,7 @@ "23503" -> uncurry ForeignKeyViolation <$> parseMaybe parseQ2 msg "23505" -> UniqueViolation <$> parseMaybe parseQ1 msg "23514" -> uncurry CheckViolation <$> parseMaybe parseQ2 msg + "23P01" -> ExclusionViolation <$> parseMaybe parseQ1 msg _ -> Nothing where msg = sqlErrorMsg e diff -Nru haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/FromField.hs haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/FromField.hs --- haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/FromField.hs 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/FromField.hs 2015-12-14 19:49:35.000000000 +0000 @@ -28,10 +28,10 @@ need accuracy, consider first converting data to a 'Scientific' or 'Rational' type, and then converting to a floating-point type. If you are defining your own 'Database.PostgreSQL.Simple.FromRow.FromRow' instances, this can be -acheived simply by +achieved simply by @'fromRational' '<$>' 'Database.PostgreSQL.Simple.FromRow.field'@, although -this idiom is additionally compatible with PostgreSQL's @numeric@ type. -If this is unacceptable, you may find +this idiom is additionally compatible with PostgreSQL's @int8@ and @numeric@ +types. If this is unacceptable, you may find 'Database.PostgreSQL.Simple.FromRow.fieldWith' useful. Also note that while converting to a 'Double' through the 'Scientific' type @@ -112,10 +112,11 @@ #include "MachDeps.h" -import Control.Applicative ( (<|>), (<$>), pure, (*>) ) +import Control.Applicative ( (<|>), (<$>), pure, (*>), (<*) ) import Control.Concurrent.MVar (MVar, newMVar) import Control.Exception (Exception) import qualified Data.Aeson as JSON +import qualified Data.Aeson.Parser as JSON (value') import Data.Attoparsec.ByteString.Char8 hiding (Result) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B @@ -145,8 +146,8 @@ import qualified Data.Text.Lazy as LT import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI -import Data.UUID (UUID) -import qualified Data.UUID as UUID +import Data.UUID.Types (UUID) +import qualified Data.UUID.Types as UUID import Data.Scientific (Scientific) import GHC.Real (infinity, notANumber) @@ -217,7 +218,7 @@ typeInfo :: Field -> Conversion TypeInfo typeInfo Field{..} = Conversion $ \conn -> do - Ok <$> (getTypeInfo conn =<< PQ.ftype result column) + Ok <$> (getTypeInfo conn typeOid) typeInfoByOid :: PQ.Oid -> Conversion TypeInfo typeInfoByOid oid = Conversion $ \conn -> do @@ -334,15 +335,15 @@ fromField = atto ok pg_double where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4]) --- | int2, int4, float4, float8, numeric +-- | 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.numeric]) + where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.int8,TI.numeric]) --- | int2, int4, float4, float8, numeric +-- | int2, int4, int8, float4, float8, numeric instance FromField Scientific where fromField = atto ok rational - where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.numeric]) + where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.int8,TI.numeric]) unBinary :: Binary t -> t unBinary (Binary x) = x @@ -545,13 +546,7 @@ else case mbs of Nothing -> returnError UnexpectedNull f "" Just bs -> -#if MIN_VERSION_aeson(0,6,3) - case JSON.eitherDecodeStrict' bs of -#elif MIN_VERSION_bytestring(0,10,0) - case JSON.eitherDecode' $ LB.fromStrict bs of -#else - case JSON.eitherDecode' $ LB.fromChunks [bs] of -#endif + case parseOnly (JSON.value' <* endOfInput) bs of Left err -> returnError ConversionFailed f err Right val -> pure val diff -Nru haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/FromRow.hs haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/FromRow.hs --- haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/FromRow.hs 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/FromRow.hs 2015-12-14 19:49:35.000000000 +0000 @@ -1,4 +1,6 @@ -{-# LANGUAGE RecordWildCards, FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards, FlexibleInstances, DefaultSignatures #-} + ------------------------------------------------------------------------------ -- | @@ -27,7 +29,7 @@ ) where import Prelude hiding (null) -import Control.Applicative (Applicative(..), (<$>), (<|>), (*>)) +import Control.Applicative (Applicative(..), (<$>), (<|>), (*>), liftA2) import Control.Monad (replicateM, replicateM_) import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader @@ -45,13 +47,17 @@ import Database.PostgreSQL.Simple.Types ((:.)(..), Null) import Database.PostgreSQL.Simple.TypeInfo +import GHC.Generics + + -- | A collection type that can be converted from a sequence of fields. -- Instances are provided for tuples up to 10 elements and lists of any length. -- -- Note that instances can be defined outside of postgresql-simple, which is -- often useful. For example, here's an instance for a user-defined pair: -- --- @data User = User { name :: String, fileQuota :: Int } +-- @ +-- data User = User { name :: String, fileQuota :: Int } -- -- instance 'FromRow' User where -- fromRow = User \<$\> 'field' \<*\> 'field' @@ -68,6 +74,8 @@ class FromRow a where fromRow :: RowParser a + default fromRow :: (Generic a, GFromRow (Rep a)) => RowParser a + fromRow = to <$> gfromRow getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString getvalue result row col = unsafeDupablePerformIO (PQ.getvalue' result row col) @@ -252,3 +260,21 @@ instance (FromRow a, FromRow b) => FromRow (a :. b) where fromRow = (:.) <$> fromRow <*> fromRow + + + +-- Type class for default implementation of FromRow using generics +class GFromRow f where + gfromRow :: RowParser (f p) + +instance GFromRow f => GFromRow (M1 c i f) where + gfromRow = M1 <$> gfromRow + +instance (GFromRow f, GFromRow g) => GFromRow (f :*: g) where + gfromRow = liftA2 (:*:) gfromRow gfromRow + +instance (FromField a) => GFromRow (K1 R a) where + gfromRow = K1 <$> field + +instance GFromRow U1 where + gfromRow = pure U1 diff -Nru haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/HStore/Implementation.hs haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/HStore/Implementation.hs --- haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/HStore/Implementation.hs 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/HStore/Implementation.hs 2015-12-14 19:49:35.000000000 +0000 @@ -15,12 +15,11 @@ module Database.PostgreSQL.Simple.HStore.Implementation where import Control.Applicative -import Blaze.ByteString.Builder as Blaze - ( Builder, toLazyByteString, copyByteString ) -import Blaze.ByteString.Builder.Char8 (fromChar) import qualified Data.Attoparsec.ByteString as P import qualified Data.Attoparsec.ByteString.Char8 as P (isSpace_w8) import qualified Data.ByteString as BS +import Data.ByteString.Builder (Builder, byteString, char8) +import qualified Data.ByteString.Builder as BU import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy as BL #if !MIN_VERSION_bytestring(0,10,0) @@ -58,7 +57,7 @@ toLazyByteString :: HStoreBuilder -> BL.ByteString toLazyByteString x = case x of Empty -> BL.empty - Comma x -> Blaze.toLazyByteString x + Comma x -> BU.toLazyByteString x instance Monoid HStoreBuilder where mempty = Empty @@ -66,7 +65,7 @@ mappend (Comma a) x = Comma (a `mappend` case x of Empty -> mempty - Comma b -> fromChar ',' `mappend` b) + Comma b -> char8 ',' `mappend` b) class ToHStoreText a where toHStoreText :: a -> HStoreText @@ -95,24 +94,24 @@ escapeAppend = loop where loop (BS.break quoteNeeded -> (a,b)) rest - = copyByteString a `mappend` + = byteString a `mappend` case BS.uncons b of Nothing -> rest Just (c,d) -> quoteChar c `mappend` loop d rest quoteNeeded c = c == c2w '\"' || c == c2w '\\' quoteChar c - | c == c2w '\"' = copyByteString "\\\"" - | otherwise = copyByteString "\\\\" + | c == c2w '\"' = byteString "\\\"" + | otherwise = byteString "\\\\" hstore :: (ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder hstore (toHStoreText -> (HStoreText key)) (toHStoreText -> (HStoreText val)) = - Comma (fromChar '"' `mappend` key `mappend` copyByteString "\"=>\"" - `mappend` val `mappend` fromChar '"') + Comma (char8 '"' `mappend` key `mappend` byteString "\"=>\"" + `mappend` val `mappend` char8 '"') instance ToField HStoreBuilder where toField Empty = toField (BS.empty) - toField (Comma x) = toField (Blaze.toLazyByteString x) + toField (Comma x) = toField (BU.toLazyByteString x) newtype HStoreList = HStoreList {fromHStoreList :: [(Text,Text)]} deriving (Typeable, Show) diff -Nru haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/HStore/Internal.hs haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/HStore/Internal.hs --- haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/HStore/Internal.hs 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/HStore/Internal.hs 2015-12-14 19:49:35.000000000 +0000 @@ -1,5 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} - ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.HStore.Internal diff -Nru haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/Internal.hs haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Internal.hs --- haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/Internal.hs 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Internal.hs 2015-12-14 19:49:35.000000000 +0000 @@ -20,8 +20,6 @@ module Database.PostgreSQL.Simple.Internal where -import Blaze.ByteString.Builder - ( Builder, fromByteString, toByteString ) import Control.Applicative import Control.Exception import Control.Concurrent.MVar @@ -29,6 +27,7 @@ import Data.ByteString(ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 +import Data.ByteString.Builder ( Builder, byteString ) import Data.Char (ord) import Data.Int (Int64) import qualified Data.IntMap as IntMap @@ -43,6 +42,7 @@ import Database.PostgreSQL.LibPQ(Oid(..)) import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.LibPQ(ExecStatus(..)) +import Database.PostgreSQL.Simple.Compat ( toByteString ) import Database.PostgreSQL.Simple.Ok import Database.PostgreSQL.Simple.ToField (Action(..), inQuotes) import Database.PostgreSQL.Simple.Types (Query(..)) @@ -75,7 +75,10 @@ connectionHandle :: {-# UNPACK #-} !(MVar PQ.Connection) , connectionObjects :: {-# UNPACK #-} !(MVar TypeInfoCache) , connectionTempNameCounter :: {-# UNPACK #-} !(IORef Int64) - } + } deriving (Typeable) + +instance Eq Connection where + x == y = connectionHandle x == connectionHandle y data SqlError = SqlError { sqlState :: ByteString @@ -152,8 +155,11 @@ -- | Attempt to make a connection based on a libpq connection string. -- See --- for more information. Here is an example with some --- of the most commonly used parameters: +-- for more information. Also note that environment variables also affect +-- parameters not provided, parameters provided as the empty string, and a +-- few other things; see +-- for details. Here is an example with some of the most commonly used +-- parameters: -- -- > host='db.somedomain.com' port=5432 ... -- @@ -206,9 +212,9 @@ -- SSL/TLS will typically "just work" if your postgresql server supports or -- requires it. However, note that libpq is trivially vulnerable to a MITM -- attack without setting additional SSL parameters in the connection string. --- In particular, @sslmode@ needs to set be @require@, @verify-ca@, or --- @verify-full@ to perform certificate validation. When @sslmode@ is --- @require@, then you will also need to have a @sslrootcert@ file, +-- In particular, @sslmode@ needs to be set to @require@, @verify-ca@, or +-- @verify-full@ in order to perform certificate validation. When @sslmode@ +-- is @require@, then you will also need to specify a @sslrootcert@ file, -- otherwise no validation of the server's identity will be performed. -- Client authentication via certificates is also possible via the -- @sslcert@ and @sslkey@ parameters. @@ -225,8 +231,8 @@ let wconn = Connection{..} version <- PQ.serverVersion conn let settings - | version < 80200 = "SET datestyle TO ISO" - | otherwise = "SET standard_conforming_strings TO on;SET datestyle TO ISO" + | version < 80200 = "SET datestyle TO ISO;SET client_encoding TO UTF8" + | otherwise = "SET datestyle TO ISO;SET client_encoding TO UTF8;SET standard_conforming_strings TO on" _ <- execute_ wconn settings return wconn _ -> do @@ -538,7 +544,7 @@ -- | Quote bytestring or throw 'FormatError' quote :: Query -> [Action] -> Either ByteString ByteString -> Builder -quote q xs = either (fmtErrorBs q xs) (inQuotes . fromByteString) +quote q xs = either (fmtErrorBs q xs) (inQuotes . byteString) buildAction :: Connection -- ^ Connection for string escaping -> Query -- ^ Query for message error @@ -549,7 +555,7 @@ buildAction conn q xs (Escape s) = quote q xs <$> escapeStringConn conn s buildAction conn q xs (EscapeByteA s) = quote q xs <$> escapeByteaConn conn s buildAction conn q xs (EscapeIdentifier s) = - either (fmtErrorBs q xs) fromByteString <$> escapeIdentifier conn s + either (fmtErrorBs q xs) byteString <$> escapeIdentifier conn s buildAction conn q xs (Many ys) = mconcat <$> mapM (buildAction conn q xs) ys diff -Nru haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/LargeObjects.hs haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/LargeObjects.hs --- haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/LargeObjects.hs 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/LargeObjects.hs 2015-12-14 19:49:35.000000000 +0000 @@ -14,7 +14,7 @@ -- database transaction, so if you are interested in using anything beyond -- 'loCreat', 'loCreate', and 'loUnlink', you will need to run the entire -- sequence of functions in a transaction. As 'loImport' and 'loExport' --- are simply C functions that call 'loCreat', 'loOpen', 'loRead', and +-- are simply C functions that call 'loCreat', 'loOpen', 'loRead', and -- 'loWrite', and do not perform any transaction handling themselves, -- they also need to be wrapped in an explicit transaction. -- diff -Nru haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/Range.hs haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Range.hs --- haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/Range.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Range.hs 2015-12-14 19:49:35.000000000 +0000 @@ -0,0 +1,313 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.Range +-- Copyright: (c) 2014-2015 Leonid Onokhov +-- (c) 2014-2015 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- +------------------------------------------------------------------------------ + +module Database.PostgreSQL.Simple.Range + ( RangeBound(..) + , PGRange(..) + , empty + , isEmpty, isEmptyBy + , contains, containsBy + ) where + +import Control.Applicative hiding (empty) +import Data.Attoparsec.ByteString.Char8 (Parser, parseOnly) +import qualified Data.Attoparsec.ByteString.Char8 as A +import qualified Data.ByteString as B +import Data.ByteString.Builder + ( Builder, byteString, lazyByteString, char8 + , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec + , wordDec, word8Dec, word16Dec, word32Dec, word64Dec + , doubleDec, floatDec ) +import Data.Int (Int16, Int32, Int64, + Int8) +import Data.Function (on) +import Data.Monoid (mempty) +import Data.Scientific (Scientific) +import qualified Data.Text.Lazy.Builder as LT +import qualified Data.Text.Lazy.Encoding as LT +import Data.Time (Day, LocalTime, + NominalDiffTime, + TimeOfDay, UTCTime, + ZonedTime, + zonedTimeToUTC) +import Data.Typeable (Typeable) +import Data.Word (Word, Word16, Word32, + Word64, Word8) + +import Database.PostgreSQL.Simple.Compat (scientificBuilder, (<>), toByteString) +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.Time + hiding (PosInfinity, NegInfinity) +-- import qualified Database.PostgreSQL.Simple.Time as Time +import Database.PostgreSQL.Simple.ToField + +-- | Represents boundary of a range +data RangeBound a = NegInfinity + | Inclusive !a + | Exclusive !a + | PosInfinity + deriving (Show, Typeable, Eq, Functor) + +-- | Generic range type +data PGRange a = PGRange !(RangeBound a) !(RangeBound a) + deriving (Show, Typeable, Functor) + +empty :: PGRange a +empty = PGRange PosInfinity NegInfinity + +instance Ord a => Eq (PGRange a) where + x == y = eq x y || (isEmpty x && isEmpty y) + where eq (PGRange a m) (PGRange b n) = a == b && m == n + +isEmptyBy :: (a -> a -> Ordering) -> PGRange a -> Bool +isEmptyBy cmp v = + case v of + (PGRange PosInfinity _) -> True + (PGRange _ NegInfinity) -> True + (PGRange NegInfinity _) -> False + (PGRange _ PosInfinity) -> False + (PGRange (Inclusive x) (Inclusive y)) -> cmp x y == GT + (PGRange (Inclusive x) (Exclusive y)) -> cmp x y /= LT + (PGRange (Exclusive x) (Inclusive y)) -> cmp x y /= LT + (PGRange (Exclusive x) (Exclusive y)) -> cmp x y /= LT + +-- | Is a range empty? If this returns 'True', then the 'contains' +-- predicate will always return 'False'. However, if this returns +-- 'False', it is not necessarily true that there exists a point for +-- which 'contains' returns 'True'. +-- Consider @'PGRange' ('Excludes' 2) ('Excludes' 3) :: PGRange Int@, +-- for example. +isEmpty :: Ord a => PGRange a -> Bool +isEmpty = isEmptyBy compare + + +-- | Does a range contain a given point? Note that in some cases, this may +-- not correspond exactly with a server-side computation. Consider @UTCTime@ +-- for example, which has a resolution of a picosecond, whereas postgresql's +-- @timestamptz@ types have a resolution of a microsecond. Putting such +-- Haskell values into the database will result in them being rounded, which +-- can change the value of the containment predicate. + +contains :: Ord a => PGRange a -> (a -> Bool) +contains = containsBy compare + +containsBy :: (a -> a -> Ordering) -> PGRange a -> (a -> Bool) +containsBy cmp rng x = + case rng of + PGRange _lb NegInfinity -> False + PGRange lb ub -> checkLB lb x && checkUB ub x + where + checkLB lb x = + case lb of + NegInfinity -> True + PosInfinity -> False + Inclusive a -> cmp a x /= GT + Exclusive a -> cmp a x == LT + + checkUB ub x = + case ub of + NegInfinity -> False + PosInfinity -> True + Inclusive z -> cmp x z /= GT + Exclusive z -> cmp x z == LT + +lowerBound :: Parser (a -> RangeBound a) +lowerBound = (A.char '(' *> pure Exclusive) <|> (A.char '[' *> pure Inclusive) +{-# INLINE lowerBound #-} + +upperBound :: Parser (a -> RangeBound a) +upperBound = (A.char ')' *> pure Exclusive) <|> (A.char ']' *> pure Inclusive) +{-# INLINE upperBound #-} + +-- | Generic range parser +pgrange :: Parser (RangeBound B.ByteString, RangeBound B.ByteString) +pgrange = do + lb <- lowerBound + v1 <- (A.char ',' *> "") <|> (rangeElem (==',') <* A.char ',') + v2 <- rangeElem $ \c -> c == ')' || c == ']' + ub <- upperBound + A.endOfInput + let low = if B.null v1 then NegInfinity else lb v1 + up = if B.null v2 then PosInfinity else ub v2 + return (low, up) + +rangeElem :: (Char -> Bool) -> Parser B.ByteString +rangeElem end = (A.char '"' *> doubleQuoted) + <|> A.takeTill end +{-# INLINE rangeElem #-} + +-- | Simple double quoted value parser +doubleQuoted :: Parser B.ByteString +doubleQuoted = toByteString <$> go mempty + where + go acc = do + h <- byteString <$> A.takeTill (\c -> c == '\\' || c == '"') + let rest = do + start <- A.anyChar + case start of + '\\' -> do + c <- A.anyChar + go (acc <> h <> char8 c) + '"' -> (A.char '"' *> go (acc <> h <> char8 '"')) + <|> pure (acc <> h) + _ -> error "impossible in doubleQuoted" + rest + +rangeToBuilder :: Ord a => (a -> Builder) -> PGRange a -> Builder +rangeToBuilder = rangeToBuilderBy compare + +-- | Generic range to builder for plain values +rangeToBuilderBy :: (a -> a -> Ordering) -> (a -> Builder) -> PGRange a -> Builder +rangeToBuilderBy cmp f x = + if isEmptyBy cmp x + then byteString "'empty'" + else let (PGRange a b) = x + in buildLB a <> buildUB b + where + buildLB NegInfinity = byteString "'[," + buildLB (Inclusive v) = byteString "'[\"" <> f v <> byteString "\"," + buildLB (Exclusive v) = byteString "'(\"" <> f v <> byteString "\"," + buildLB PosInfinity = error "impossible in rangeToBuilder" + + buildUB NegInfinity = error "impossible in rangeToBuilder" + buildUB (Inclusive v) = char8 '"' <> f v <> byteString "\"]'" + buildUB (Exclusive v) = char8 '"' <> f v <> byteString "\")'" + buildUB PosInfinity = byteString "]'" +{-# INLINE rangeToBuilder #-} + + +instance (FromField a, Typeable a) => FromField (PGRange a) where + fromField f mdat = do + info <- typeInfo f + case info of + Range{} -> + let f' = f { typeOid = typoid (rngsubtype info) } + in case mdat of + Nothing -> returnError UnexpectedNull f "" + Just "empty" -> pure $ empty + Just bs -> + let parseIt NegInfinity = pure NegInfinity + parseIt (Inclusive v) = Inclusive <$> fromField f' (Just v) + parseIt (Exclusive v) = Exclusive <$> fromField f' (Just v) + parseIt PosInfinity = pure PosInfinity + in case parseOnly pgrange bs of + Left e -> returnError ConversionFailed f e + Right (lb,ub) -> PGRange <$> parseIt lb <*> parseIt ub + _ -> returnError Incompatible f "" + + +instance ToField (PGRange Int8) where + toField = Plain . rangeToBuilder int8Dec + {-# INLINE toField #-} + +instance ToField (PGRange Int16) where + toField = Plain . rangeToBuilder int16Dec + {-# INLINE toField #-} + +instance ToField (PGRange Int32) where + toField = Plain . rangeToBuilder int32Dec + {-# INLINE toField #-} + +instance ToField (PGRange Int) where + toField = Plain . rangeToBuilder intDec + {-# INLINE toField #-} + +instance ToField (PGRange Int64) where + toField = Plain . rangeToBuilder int64Dec + {-# INLINE toField #-} + +instance ToField (PGRange Integer) where + toField = Plain . rangeToBuilder integerDec + {-# INLINE toField #-} + +instance ToField (PGRange Word8) where + toField = Plain . rangeToBuilder word8Dec + {-# INLINE toField #-} + +instance ToField (PGRange Word16) where + toField = Plain . rangeToBuilder word16Dec + {-# INLINE toField #-} + +instance ToField (PGRange Word32) where + toField = Plain . rangeToBuilder word32Dec + {-# INLINE toField #-} + +instance ToField (PGRange Word) where + toField = Plain . rangeToBuilder wordDec + {-# INLINE toField #-} + +instance ToField (PGRange Word64) where + toField = Plain . rangeToBuilder word64Dec + {-# INLINE toField #-} + +instance ToField (PGRange Float) where + toField = Plain . rangeToBuilder floatDec + {-# INLINE toField #-} + +instance ToField (PGRange Double) where + toField = Plain . rangeToBuilder doubleDec + {-# INLINE toField #-} + +instance ToField (PGRange Scientific) where + toField = Plain . rangeToBuilder f + where + f = lazyByteString . LT.encodeUtf8 . LT.toLazyText . scientificBuilder + {-# INLINE toField #-} + +instance ToField (PGRange UTCTime) where + toField = Plain . rangeToBuilder utcTimeToBuilder + {-# INLINE toField #-} + +instance ToField (PGRange ZonedTime) where + toField = Plain . rangeToBuilderBy cmpZonedTime zonedTimeToBuilder + {-# INLINE toField #-} + +cmpZonedTime :: ZonedTime -> ZonedTime -> Ordering +cmpZonedTime = compare `on` zonedTimeToUTC -- FIXME: optimize + +instance ToField (PGRange LocalTime) where + toField = Plain . rangeToBuilder localTimeToBuilder + {-# INLINE toField #-} + +instance ToField (PGRange Day) where + toField = Plain . rangeToBuilder dayToBuilder + {-# INLINE toField #-} + +instance ToField (PGRange TimeOfDay) where + toField = Plain . rangeToBuilder timeOfDayToBuilder + {-# INLINE toField #-} + +instance ToField (PGRange UTCTimestamp) where + toField = Plain . rangeToBuilder utcTimestampToBuilder + {-# INLINE toField #-} + +instance ToField (PGRange ZonedTimestamp) where + toField = Plain . rangeToBuilderBy cmpZonedTimestamp zonedTimestampToBuilder + {-# INLINE toField #-} + +cmpZonedTimestamp :: ZonedTimestamp -> ZonedTimestamp -> Ordering +cmpZonedTimestamp = compare `on` (zonedTimeToUTC <$>) + +instance ToField (PGRange LocalTimestamp) where + toField = Plain . rangeToBuilder localTimestampToBuilder + {-# INLINE toField #-} + +instance ToField (PGRange Date) where + toField = Plain . rangeToBuilder dateToBuilder + {-# INLINE toField #-} + +instance ToField (PGRange NominalDiffTime) where + toField = Plain . rangeToBuilder nominalDiffTimeToBuilder + {-# INLINE toField #-} diff -Nru haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/SqlQQ.hs haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/SqlQQ.hs --- haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/SqlQQ.hs 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/SqlQQ.hs 2015-12-14 19:49:35.000000000 +0000 @@ -1,3 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.SqlQQ @@ -9,15 +10,16 @@ ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.SqlQQ (sql) where - +import Database.PostgreSQL.Simple.Types (Query) import Language.Haskell.TH import Language.Haskell.TH.Quote import Data.Char +import Data.String -- | 'sql' is a quasiquoter that eases the syntactic burden -- of writing big sql statements in Haskell source code. For example: -- --- > {-# LANGUAGE OverloadedStrings, QuasiQuotes #-} +-- > {-# LANGUAGE QuasiQuotes #-} -- > -- > query conn [sql| SELECT column_a, column_b -- > FROM table1 NATURAL JOIN table2 @@ -27,10 +29,10 @@ -- > LIMIT 100 |] -- > (beginTime,endTime,string) -- --- This quasiquoter attempts to mimimize whitespace; otherwise the --- above query would consist of approximately half whitespace when sent --- to the database backend. It also recognizes and strips out standard --- sql comments "--". +-- This quasiquoter returns a literal string expression of type 'Query', +-- and attempts to mimimize whitespace; otherwise the above query would +-- consist of approximately half whitespace when sent to the database +-- backend. It also recognizes and strips out standard sql comments "--". -- -- The implementation of the whitespace reducer is currently incomplete. -- Thus it can mess up your syntax in cases where whitespace should be @@ -60,7 +62,7 @@ } sqlExp :: String -> Q Exp -sqlExp = stringE . minimizeSpace +sqlExp = appE [| fromString :: String -> Query |] . stringE . minimizeSpace minimizeSpace :: String -> String minimizeSpace = drop 1 . reduceSpace diff -Nru haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/Time/Implementation.hs haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Time/Implementation.hs --- haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/Time/Implementation.hs 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Time/Implementation.hs 2015-12-14 19:49:35.000000000 +0000 @@ -1,51 +1,43 @@ ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Time.Implementation --- Copyright: (c) 2012 Leon P Smith +-- Copyright: (c) 2012-2015 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- ------------------------------------------------------------------------------ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-} module Database.PostgreSQL.Simple.Time.Implementation where -import Prelude hiding (take, (++)) -import Blaze.ByteString.Builder(Builder, fromByteString) -import Blaze.ByteString.Builder.Char8(fromChar) -import Blaze.Text.Int(integral) +import Prelude hiding (take) +import Data.ByteString.Builder(Builder, byteString) +import Data.ByteString.Builder.Prim(primBounded) import Control.Arrow((***)) import Control.Applicative -import Control.Monad(when) -import Data.Bits((.&.)) import qualified Data.ByteString as B -import Data.ByteString.Internal (c2w, w2c) import Data.Time hiding (getTimeZone, getZonedTime) import Data.Typeable -import Data.Word(Word8) +import Data.Maybe (fromMaybe) import qualified Data.Attoparsec.ByteString.Char8 as A -import Data.Monoid(Monoid(..)) -import Data.Fixed (Pico) -import Unsafe.Coerce - -(++) :: Monoid a => a -> a -> a -(++) = mappend -infixr 5 ++ +import Database.PostgreSQL.Simple.Compat ((<>)) +import qualified Database.PostgreSQL.Simple.Time.Internal.Parser as TP +import qualified Database.PostgreSQL.Simple.Time.Internal.Printer as TPP data Unbounded a = NegInfinity | Finite !a | PosInfinity - deriving (Eq, Ord, Typeable) + deriving (Eq, Ord, Typeable, Functor) instance Show a => Show (Unbounded a) where showsPrec prec x rest = case x of - NegInfinity -> "-infinity" ++ rest + NegInfinity -> "-infinity" <> rest Finite time -> showsPrec prec time rest - PosInfinity -> "infinity" ++ rest + PosInfinity -> "infinity" <> rest instance Read a => Read (Unbounded a) where readsPrec prec = readParen False $ \str -> case str of @@ -92,160 +84,71 @@ <|> (Finite <$> getFinite) getDay :: A.Parser Day -getDay = do - yearStr <- A.takeWhile A.isDigit - when (B.length yearStr < 4) (fail "year must consist of at least 4 digits") - - let !year = toNum yearStr - _ <- A.char '-' - !month <- digits "month" - _ <- A.char '-' - day <- digits "day" - - case fromGregorianValid year month day of - Nothing -> fail "invalid date" - Just x -> return $! x +getDay = TP.day getDate :: A.Parser Date getDate = getUnbounded getDay -decimal :: Fractional a => B.ByteString -> a -decimal str = toNum str / 10^(B.length str) -{-# INLINE decimal #-} - getTimeOfDay :: A.Parser TimeOfDay -getTimeOfDay = do - !hour <- digits "hours" - _ <- A.char ':' - minute <- digits "minutes" - _ <- A.char ':' - second <- digits "seconds" - subsec <- (A.char '.' *> (decimal <$> A.takeWhile1 A.isDigit)) <|> return 0 - - let !picos' = second + subsec - - case makeTimeOfDayValid hour minute picos' of - Nothing -> fail "invalid time of day" - Just x -> return $! x +getTimeOfDay = TP.timeOfDay getLocalTime :: A.Parser LocalTime -getLocalTime = LocalTime <$> getDay <*> (A.char ' ' *> getTimeOfDay) +getLocalTime = TP.localTime getLocalTimestamp :: A.Parser LocalTimestamp getLocalTimestamp = getUnbounded getLocalTime getTimeZone :: A.Parser TimeZone -getTimeZone = do - !sign <- A.satisfy (\c -> c == '+' || c == '-') - !hours <- digits "timezone" - !mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0 - let !absset = 60 * hours + mins - !offset = if sign == '+' then absset else -absset - return $! minutesToTimeZone offset +getTimeZone = fromMaybe utc <$> TP.timeZone type TimeZoneHMS = (Int,Int,Int) getTimeZoneHMS :: A.Parser TimeZoneHMS -getTimeZoneHMS = do - !sign <- A.satisfy (\c -> c == '+' || c == '-') - !hours <- digits "timezone" - !mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0 - !secs <- (A.char ':' *> digits "timezone seconds") <|> pure 0 - if sign == '+' - then return $! (hours, mins, secs) - else return $! (\ !h !m !s -> (h,m,s)) (-hours) (-mins) (-secs) +getTimeZoneHMS = munge <$> TP.timeZoneHMS + where + munge Nothing = (0,0,0) + munge (Just (TP.UTCOffsetHMS h m s)) = (h,m,s) localToUTCTimeOfDayHMS :: TimeZoneHMS -> TimeOfDay -> (Integer, TimeOfDay) -localToUTCTimeOfDayHMS (dh, dm, ds) (TimeOfDay h m s) = - (\ !a !b -> (a,b)) dday (TimeOfDay h'' m'' s'') - where - s' = s - fromIntegral ds - (!s'', m') - | s' < 0 = (s' + 60, m - dm - 1) - | s' >= 60 = (s' - 60, m - dm + 1) - | otherwise = (s' , m - dm ) - (!m'', h') - | m' < 0 = (m' + 60, h - dh - 1) - | m' >= 60 = (m' - 60, h - dh + 1) - | otherwise = (m' , h - dh ) - (!h'', dday) - | h' < 0 = (h' + 24, -1) - | h' >= 24 = (h' - 24, 1) - | otherwise = (h' , 0) +localToUTCTimeOfDayHMS (dh, dm, ds) tod = + TP.localToUTCTimeOfDayHMS (TP.UTCOffsetHMS dh dm ds) tod getZonedTime :: A.Parser ZonedTime -getZonedTime = ZonedTime <$> getLocalTime <*> getTimeZone +getZonedTime = TP.zonedTime getZonedTimestamp :: A.Parser ZonedTimestamp getZonedTimestamp = getUnbounded getZonedTime getUTCTime :: A.Parser UTCTime -getUTCTime = do - day <- getDay - _ <- A.char ' ' - time <- getTimeOfDay - zone <- getTimeZoneHMS - let !(dayDelta,time') = localToUTCTimeOfDayHMS zone time - let !day' = addDays dayDelta day - let !time'' = timeOfDayToTime time' - return $! UTCTime day' time'' +getUTCTime = TP.utcTime getUTCTimestamp :: A.Parser UTCTimestamp getUTCTimestamp = getUnbounded getUTCTime -toNum :: Num n => B.ByteString -> n -toNum = B.foldl' (\a c -> 10*a + digit c) 0 -{-# INLINE toNum #-} - -digit :: Num n => Word8 -> n -digit c = fromIntegral (c .&. 0x0f) -{-# INLINE digit #-} - -digits :: Num n => String -> A.Parser n -digits msg = do - x <- A.anyChar - y <- A.anyChar - if A.isDigit x && A.isDigit y - then return $! (10 * digit (c2w x) + digit (c2w y)) - else fail (msg ++ " is not 2 digits") -{-# INLINE digits #-} - dayToBuilder :: Day -> Builder -dayToBuilder (toGregorian -> (y,m,d)) = do - pad4 y ++ fromChar '-' ++ pad2 m ++ fromChar '-' ++ pad2 d +dayToBuilder = primBounded TPP.day timeOfDayToBuilder :: TimeOfDay -> Builder -timeOfDayToBuilder (TimeOfDay h m s) = do - pad2 h ++ fromChar ':' ++ pad2 m ++ fromChar ':' ++ showSeconds s +timeOfDayToBuilder = primBounded TPP.timeOfDay timeZoneToBuilder :: TimeZone -> Builder -timeZoneToBuilder tz - | m == 0 = sign h ++ pad2 (abs h) - | otherwise = sign h ++ pad2 (abs h) ++ fromChar ':' ++ pad2 (abs m) - where - (h,m) = timeZoneMinutes tz `quotRem` 60 - sign h | h >= 0 = fromChar '+' - | otherwise = fromChar '-' +timeZoneToBuilder = primBounded TPP.timeZone utcTimeToBuilder :: UTCTime -> Builder -utcTimeToBuilder (UTCTime day time) = - dayToBuilder day ++ fromChar ' ' - ++ timeOfDayToBuilder (timeToTimeOfDay time) ++ fromByteString "+00" +utcTimeToBuilder = primBounded TPP.utcTime zonedTimeToBuilder :: ZonedTime -> Builder -zonedTimeToBuilder (ZonedTime localTime tz) = - localTimeToBuilder localTime ++ timeZoneToBuilder tz +zonedTimeToBuilder = primBounded TPP.zonedTime localTimeToBuilder :: LocalTime -> Builder -localTimeToBuilder (LocalTime day tod) = - dayToBuilder day ++ fromChar ' ' ++ timeOfDayToBuilder tod +localTimeToBuilder = primBounded TPP.localTime unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder) unboundedToBuilder finiteToBuilder unbounded = case unbounded of - NegInfinity -> fromByteString "-infinity" + NegInfinity -> byteString "-infinity" Finite a -> finiteToBuilder a - PosInfinity -> fromByteString "infinity" + PosInfinity -> byteString "infinity" utcTimestampToBuilder :: UTCTimestamp -> Builder utcTimestampToBuilder = unboundedToBuilder utcTimeToBuilder @@ -260,64 +163,4 @@ dateToBuilder = unboundedToBuilder dayToBuilder nominalDiffTimeToBuilder :: NominalDiffTime -> Builder -nominalDiffTimeToBuilder xyz - | yz < 500000 = sign ++ integral x - | otherwise = sign ++ integral x ++ fromChar '.' ++ showD6 y - where - -- A kludge to work around the fact that Data.Fixed isn't very fast and - -- doesn't give me access to the MkFixed constructor. - sign = if xyz >= 0 then mempty else fromChar '-' - (x,yz) = ((unsafeCoerce (abs xyz) :: Integer) + 500000) `quotRem` 1000000000000 - (fromIntegral -> y, _z) = yz `quotRem` 1000000 - -showSeconds :: Pico -> Builder -showSeconds xyz - | yz == 0 = pad2 x - | z == 0 = pad2 x ++ fromChar '.' ++ showD6 y - | otherwise = pad2 x ++ fromChar '.' ++ pad6 y ++ showD6 z - where - -- A kludge to work around the fact that Data.Fixed isn't very fast and - -- doesn't give me access to the MkFixed constructor. - (x_,yz) = (unsafeCoerce xyz :: Integer) `quotRem` 1000000000000 - x = fromIntegral x_ :: Int - (fromIntegral -> y, fromIntegral -> z) = yz `quotRem` 1000000 - -pad6 :: Int -> Builder -pad6 xy = let (x,y) = xy `quotRem` 1000 - in pad3 x ++ pad3 y - -showD6 :: Int -> Builder -showD6 xy = case xy `quotRem` 1000 of - (x,0) -> showD3 x - (x,y) -> pad3 x ++ showD3 y - -pad3 :: Int -> Builder -pad3 abc = let (ab,c) = abc `quotRem` 10 - (a,b) = ab `quotRem` 10 - in p a ++ p b ++ p c - -showD3 :: Int -> Builder -showD3 abc = case abc `quotRem` 100 of - (a, 0) -> p a - (a,bc) -> case bc `quotRem` 10 of - (b,0) -> p a ++ p b - (b,c) -> p a ++ p b ++ p c - --- | p assumes its input is in the range [0..9] -p :: Integral n => n -> Builder -p n = fromChar (w2c (fromIntegral (n + 48))) -{-# INLINE p #-} - --- | pad2 assumes its input is in the range [0..99] -pad2 :: Integral n => n -> Builder -pad2 n = let (a,b) = n `quotRem` 10 in p a ++ p b -{-# INLINE pad2 #-} - --- | pad4 assumes its input is positive -pad4 :: (Integral n, Show n) => n -> Builder -pad4 abcd | abcd >= 10000 = integral abcd - | otherwise = p a ++ p b ++ p c ++ p d - where (ab,cd) = abcd `quotRem` 100 - (a,b) = ab `quotRem` 10 - (c,d) = cd `quotRem` 10 -{-# INLINE pad4 #-} +nominalDiffTimeToBuilder = TPP.nominalDiffTime diff -Nru haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs --- haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs 2015-12-14 19:49:35.000000000 +0000 @@ -0,0 +1,192 @@ +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} + +-- | +-- Module: Database.PostgreSQL.Simple.Time.Internal.Parser +-- Copyright: (c) 2012-2015 Leon P Smith +-- (c) 2015 Bryan O'Sullivan +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- Parsers for parsing dates and times. + +module Database.PostgreSQL.Simple.Time.Internal.Parser + ( + day + , localTime + , timeOfDay + , timeZone + , UTCOffsetHMS(..) + , timeZoneHMS + , localToUTCTimeOfDayHMS + , utcTime + , zonedTime + ) where + +import Control.Applicative ((<$>), (<*>), (<*), (*>)) +import Database.PostgreSQL.Simple.Compat (toPico) +import Data.Attoparsec.ByteString.Char8 as A +import Data.Bits ((.&.)) +import Data.Char (ord) +import Data.Fixed (Pico) +import Data.Int (Int64) +import Data.Maybe (fromMaybe) +import Data.Time.Calendar (Day, fromGregorianValid, addDays) +import Data.Time.Clock (UTCTime(..)) +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Time.LocalTime as Local + +-- | Parse a date of the form @YYYY-MM-DD@. +day :: Parser Day +day = do + y <- decimal <* char '-' + m <- twoDigits <* char '-' + d <- twoDigits + maybe (fail "invalid date") return (fromGregorianValid y m d) + +-- | Parse a two-digit integer (e.g. day of month, hour). +twoDigits :: Parser Int +twoDigits = do + a <- digit + b <- digit + let c2d c = ord c .&. 15 + return $! c2d a * 10 + c2d b + +-- | Parse a time of the form @HH:MM:SS[.SSS]@. +timeOfDay :: Parser Local.TimeOfDay +timeOfDay = do + h <- twoDigits <* char ':' + m <- twoDigits <* char ':' + s <- seconds + if h < 24 && m < 60 && s <= 60 + then return (Local.TimeOfDay h m s) + else fail "invalid time" + +-- | Parse a count of seconds, with the integer part being two digits +-- long. +seconds :: Parser Pico +seconds = do + real <- twoDigits + mc <- peekChar + case mc of + Just '.' -> do + t <- anyChar *> takeWhile1 isDigit + return $! parsePicos (fromIntegral real) t + _ -> return $! fromIntegral real + where + parsePicos :: Int64 -> B8.ByteString -> Pico + parsePicos a0 t = toPico (fromIntegral (t' * 10^n)) + where n = max 0 (12 - B8.length t) + t' = B8.foldl' (\a c -> 10 * a + fromIntegral (ord c .&. 15)) a0 + (B8.take 12 t) + +-- | Parse a time zone, and return 'Nothing' if the offset from UTC is +-- zero. (This makes some speedups possible.) +timeZone :: Parser (Maybe Local.TimeZone) +timeZone = do + ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z' + if ch == 'Z' + then return Nothing + else do + h <- twoDigits + mm <- peekChar + m <- case mm of + Just ':' -> anyChar *> twoDigits + _ -> return 0 + let off | ch == '-' = negate off0 + | otherwise = off0 + off0 = h * 60 + m + case undefined of + _ | off == 0 -> + return Nothing + | h > 23 || m > 59 -> + fail "invalid time zone offset" + | otherwise -> + let !tz = Local.minutesToTimeZone off + in return (Just tz) + +data UTCOffsetHMS = UTCOffsetHMS {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int + +-- | Parse a time zone, and return 'Nothing' if the offset from UTC is +-- zero. (This makes some speedups possible.) +timeZoneHMS :: Parser (Maybe UTCOffsetHMS) +timeZoneHMS = do + ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z' + if ch == 'Z' + then return Nothing + else do + h <- twoDigits + m <- maybeTwoDigits + s <- maybeTwoDigits + case undefined of + _ | h == 0 && m == 0 && s == 0 -> + return Nothing + | h > 23 || m >= 60 || s >= 60 -> + fail "invalid time zone offset" + | otherwise -> + if ch == '+' + then let !tz = UTCOffsetHMS h m s + in return (Just tz) + else let !tz = UTCOffsetHMS (-h) (-m) (-s) + in return (Just tz) + where + maybeTwoDigits = do + ch <- peekChar + case ch of + Just ':' -> anyChar *> twoDigits + _ -> return 0 + +localToUTCTimeOfDayHMS :: UTCOffsetHMS -> Local.TimeOfDay -> (Integer, Local.TimeOfDay) +localToUTCTimeOfDayHMS (UTCOffsetHMS dh dm ds) (Local.TimeOfDay h m s) = + (\ !a !b -> (a,b)) dday (Local.TimeOfDay h'' m'' s'') + where + s' = s - fromIntegral ds + (!s'', m') + | s' < 0 = (s' + 60, m - dm - 1) + | s' >= 60 = (s' - 60, m - dm + 1) + | otherwise = (s' , m - dm ) + (!m'', h') + | m' < 0 = (m' + 60, h - dh - 1) + | m' >= 60 = (m' - 60, h - dh + 1) + | otherwise = (m' , h - dh ) + (!h'', dday) + | h' < 0 = (h' + 24, -1) + | h' >= 24 = (h' - 24, 1) + | otherwise = (h' , 0) + + +-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@. +-- The space may be replaced with a @T@. The number of seconds may be +-- followed by a fractional component. +localTime :: Parser Local.LocalTime +localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay + where daySep = satisfy (\c -> c == ' ' || c == 'T') + +-- | Behaves as 'zonedTime', but converts any time zone offset into a +-- UTC time. +utcTime :: Parser UTCTime +utcTime = do + (Local.LocalTime d t) <- localTime + mtz <- timeZoneHMS + case mtz of + Nothing -> let !tt = Local.timeOfDayToTime t + in return (UTCTime d tt) + Just tz -> let !(dd,t') = localToUTCTimeOfDayHMS tz t + !d' = addDays dd d + !tt = Local.timeOfDayToTime t' + in return (UTCTime d' tt) + +-- | Parse a date with time zone info. Acceptable formats: +-- +-- @YYYY-MM-DD HH:MM:SS Z@ +-- +-- The first space may instead be a @T@, and the second space is +-- optional. The @Z@ represents UTC. The @Z@ may be replaced with a +-- time zone offset of the form @+0000@ or @-08:00@, where the first +-- two digits are hours, the @:@ is optional and the second two digits +-- (also optional) are minutes. +zonedTime :: Parser Local.ZonedTime +zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone) + +utc :: Local.TimeZone +utc = Local.TimeZone 0 False "" diff -Nru haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs --- haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs 2015-12-14 19:49:35.000000000 +0000 @@ -0,0 +1,123 @@ +{-# LANGUAGE BangPatterns, ViewPatterns #-} + +------------------------------------------------------------------------------ +-- Module: Database.PostgreSQL.Simple.Time.Internal.Printer +-- Copyright: (c) 2012-2015 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +------------------------------------------------------------------------------ + +module Database.PostgreSQL.Simple.Time.Internal.Printer + ( + day + , timeOfDay + , timeZone + , utcTime + , localTime + , zonedTime + , nominalDiffTime + ) where + +import Control.Arrow ((>>>)) +import Data.ByteString.Builder (Builder, integerDec) +import Data.ByteString.Builder.Prim + ( liftFixedToBounded, (>$<), (>*<) + , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec) +import Data.Char ( chr ) +import Data.Int ( Int32, Int64 ) +import Data.Time + ( UTCTime(..), ZonedTime(..), LocalTime(..), NominalDiffTime + , Day, toGregorian, TimeOfDay(..), timeToTimeOfDay + , TimeZone, timeZoneMinutes ) +import Database.PostgreSQL.Simple.Compat ((<>), fromPico) +import Unsafe.Coerce (unsafeCoerce) + +liftB :: FixedPrim a -> BoundedPrim a +liftB = liftFixedToBounded + +digit :: FixedPrim Int +digit = (\x -> chr (x + 48)) >$< char8 + +digits2 :: FixedPrim Int +digits2 = (`quotRem` 10) >$< (digit >*< digit) + +digits3 :: FixedPrim Int +digits3 = (`quotRem` 10) >$< (digits2 >*< digit) + +digits4 :: FixedPrim Int +digits4 = (`quotRem` 10) >$< (digits3 >*< digit) + +frac :: BoundedPrim Int64 +frac = condB (== 0) emptyB ((,) '.' >$< (liftB char8 >*< trunc12)) + where + trunc12 :: BoundedPrim Int64 + trunc12 = (`quotRem` 1000000) >$< + condB (\(_,y) -> y == 0) + (fst >$< trunc6) + (liftB digits6 >*< trunc6) + + digitB = liftB digit + + digits6 = (fromIntegral >>> (`quotRem` 10)) >$< (digits5 >*< digit) + digits5 = (`quotRem` 10) >$< (digits4 >*< digit) + + trunc6 = (fromIntegral >>> (`quotRem` 100000)) >$< (digitB >*< trunc5) + trunc5 = condB (== 0) emptyB ((`quotRem` 10000) >$< (digitB >*< trunc4)) + trunc4 = condB (== 0) emptyB ((`quotRem` 1000) >$< (digitB >*< trunc3)) + trunc3 = condB (== 0) emptyB ((`quotRem` 100) >$< (digitB >*< trunc2)) + trunc2 = condB (== 0) emptyB ((`quotRem` 10) >$< (digitB >*< trunc1)) + trunc1 = condB (== 0) emptyB digitB + + +year :: BoundedPrim Int32 +year = condB (> 10000) int32Dec (checkBCE >$< liftB digits4) + where + checkBCE :: Int32 -> Int + checkBCE y + | y > 0 = fromIntegral y + | otherwise = error msg + + msg = "Database.PostgreSQL.Simple.Time.Printer.year: years BCE not supported" + +day :: BoundedPrim Day +day = toYMD >$< (year >*< liftB (char8 >*< digits2 >*< char8 >*< digits2)) + where + toYMD (toGregorian -> (fromIntegral -> !y, !m,!d)) = (y,('-',(m,('-',d)))) + +timeOfDay :: BoundedPrim TimeOfDay +timeOfDay = f >$< (hh_mm_ >*< ss) + where + f (TimeOfDay h m s) = ((h,(':',(m,':'))),s) + + hh_mm_ = liftB (digits2 >*< char8 >*< digits2 >*< char8) + + ss = (\s -> fromIntegral (fromPico s) `quotRem` 1000000000000) >$< + (liftB (fromIntegral >$< digits2) >*< frac) + +timeZone :: BoundedPrim TimeZone +timeZone = ((`quotRem` 60) . timeZoneMinutes) >$< (liftB tzh >*< tzm) + where + f h = if h >= 0 then ('+', h) else (,) '-' $! (-h) + + tzh = f >$< (char8 >*< digits2) + + tzm = condB (==0) emptyB ((,) ':' . abs >$< liftB (char8 >*< digits2)) + +utcTime :: BoundedPrim UTCTime +utcTime = f >$< (day >*< liftB char8 >*< timeOfDay >*< liftB char8) + where f (UTCTime d (timeToTimeOfDay -> tod)) = (d,(' ',(tod,'Z'))) + +localTime :: BoundedPrim LocalTime +localTime = f >$< (day >*< liftB char8 >*< timeOfDay) + where f (LocalTime d tod) = (d, (' ', tod)) + +zonedTime :: BoundedPrim ZonedTime +zonedTime = f >$< (localTime >*< timeZone) + where f (ZonedTime lt tz) = (lt, tz) + + +nominalDiffTime :: NominalDiffTime -> Builder +nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y)) + where + (x,y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000 diff -Nru haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/Time.hs haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Time.hs --- haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/Time.hs 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Time.hs 2015-12-14 19:49:35.000000000 +0000 @@ -1,53 +1,216 @@ ------------------------------------------------------------------------------- --- | --- Module: Database.PostgreSQL.Simple.Time --- Copyright: (c) 2012 Leon P Smith --- License: BSD3 --- Maintainer: Leon P Smith --- Stability: experimental --- --- Time types that supports positive and negative infinity. Also includes --- new time parsers and printers with better performance than GHC's time --- package. --- --- The parsers only understand the specific variant of ISO 8601 that --- PostgreSQL emits, and the printers attempt to duplicate this syntax. --- Thus the @datestyle@ parameter for the connection must be set to @ISO@. --- --- These parsers and printers likely have problems and shortcomings. Some --- that I know of: --- --- 1 @TimestampTZ@s before a timezone-dependent point in time cannot be --- parsed, because the parsers can only handle timezone offsets of a --- integer number of minutes. However, PostgreSQL will include seconds --- in the offset, depending on the historical time standards for the city --- identifying the time zone. --- --- This boundary point often marks an event of some interest. In the US --- for example, @timestamptz@s before @1883-Nov-18 12:00:00@ local time --- cannot be parsed. This is the moment Standard Railway Time went live. --- Concretely, PostgreSQL will emit @1883-11-18 12:03:57-04:56:02@ --- instead of @1883-11-18 11:59:59-05@ when the @timezone@ parameter --- for the connection is set to @America/New_York@. --- --- 2. Dates and times surrounding @1582-Feb-24@, the date the Gregorian --- Calendar was introduced, should be investigated for conversion errors. --- --- 3. Points in time Before Christ are not also not supported. For example, --- PostgreSQL will emit @0045-01-01 BC@ for a value of a @date@ type. --- This is the year that the Julian Calendar was adopted. --- --- However, it should be noted that the old parsers also had issues 1 and 3. --- Also, the new parsers now correctly handle time zones that include minutes --- in their offset. Most notably, this includes all of India and parts of --- Canada and Australia. --- --- PostgreSQL uses the zoneinfo database for its time zone information. --- You can read more about PostgreSQL's date and time types at --- , --- and zoneinfo at . --- ------------------------------------------------------------------------------- +{- | +Module: Database.PostgreSQL.Simple.Time +Copyright: (c) 2012-2015 Leon P Smith +License: BSD3 +Maintainer: Leon P Smith +Stability: experimental + +This module provides time types that supports positive and negative +infinity, as well as some functions for converting to and from strings. + +Also, this module also contains commentary regarding postgresql's timestamp +types, civil timekeeping in general, and how it relates to +postgresql-simple. You can read more about PostgreSQL's date and time types +at , +and the IANA time zone database at . + +Stack Overflow also has some excellent commentary on time, if it is a +wiki page or a highly upvoted question and answer. If the answer regarding +time has not received about a hundred upvotes at least, then the answer is +almost invariably completely and painfully wrong, even if it's the chosen +answer or the most highly upvoted answer to a question. + +PostgreSQL's @timestamp with time zone@ (hereafter, @timestamptz@) can be +converted to Haskell's 'Data.Time.UTCTime' and 'Data.Time.ZonedTime' types, +because values of these types represent a self-contained, unambiguous point +in time. PostgreSQL's @timestamp without time zone@ (hereafter, @timestamp@) +can be converted to Haskell's 'Data.Time.LocalTime', because values of these +types are ambiguous by themselves, and require context to disambiguate. + +While this behavior may be superficially counterintuitive because the +names might suggest otherwise, this behavior is correct. In fact, +the \"timezone\" language in both the postgresql and haskell types would +be better read as \"offset (from UTC)\", thus we have postgresql's +\"timestamp with offset\" corresponding to Haskell's \"time with the +offset \'zero\'\" and Haskell's \"time with an offset (that might be +nonzero)\". Similarly, postgresql's \"timestamp without an offset\" +corresponds to Haskell's \"local time (without an offset)\". + +It's important to distinguish between an offset, a standard time, and +a time zone. An offset is simply a difference of a local time from UTC, +such as @+00@, @-05@, or @+05:30@. A standard time specifies an offset +(which may vary throughout the year, due to daylight savings) that a +region follows, such as Universal Coordinated Time (UTC), Eastern Standard +Time\/Eastern Daylight Time (EST\/EDT), or India Standard Time (IST). +And a time zone, much like a standard time, is a function from +timestamps to offsets. + +A time zone is different from a standard time because different regions +inside a standard time can be governed by different civil authorities with +different laws and thus have different histories of civil time. An IANA +time zone is any region of the world that has had the same history of +civil time since @1970-01-01 00:00+00@. + +For example, as of today, both @America\/New_York@ and +@America\/Indiana\/Indianapolis@ are on the EST\/EDT time standard, but +Indiana used to be on Central Standard Time until 1942, and did not observe +daylight savings time (EST only) until 2006. Thus, the choice between +these two time zones still matters if you are dealing with timestamps +prior to 2006, and could become relevant again if (most of) Indiana +moves back to Central Time. (Of course, if the Central to Eastern switch +was the only difference, then these two time zones would be the same in +IANA's eyes, due to their cutoff date of 1970-01-01.) + +Getting back to practicalities, PostgreSQL's @timestamptz@ type does not +actually store an offset; rather, it uses the offset provided to calculate +UTC, and stores the timestamp as UTC. If an offset is not provided, the +given timestamp is assumed to be a local time for whatever the @timezone@ +variable is set to, and the IANA TZ database is consulted to calculate an +offset from UTC for the time in question. + +Note that while most (local timestamp, time zone) pairs correspond to exactly +one UTC timestamp, some correspond to two UTC timestamps, while others +correspond to none at all. The ambiguous case occurs when the civil time +is rolled back, making a calendar day longer than 24 hours. In this case, +PostgreSQL silently chooses the second, later possibility. The inconsistent +case occurs when the civil time is moved forward, making a calendar day less +than 24 hours. In this case, PostgreSQL silently assumes the local time +was read off a clock that had not been moved forward at the prescribed time, +and moves the clock forward for you. Thus, converting from local time +to UTC need not be monotonic, if these inconsistent cases are allowed. + +When retrieving a @timestamptz@, the backend looks at the @time zone@ +connection variable and then consults the IANA TZ database to calculate +an offset for the timestamp in the given time zone. + +Note that while some of the information contained in the IANA TZ database +is a bit of a standardized fiction, the conversion from UTC time to a +(local time, offset) pair in a particular time zone is always unambiguous, +and the result can always be unambiguously converted back to UTC. Thus, +postgresql-simple can interpret such a result as a 'Data.Time.ZonedTime', +or use the offset to convert back to 'Data.Time.UTCTime'. + +By contrast, the @timestamp@ type ignores any offsets provided to it, +and never sends back an offset. Thus, postgresql-simple equates this +with 'Data.Time.LocalTime', which has no concept of an offset. One can +convert between @timestamptz@ and @timestamp@ using the @AT TIME ZONE@ +operator, whose semantics also demonstrates that @timestamptz@ is +'Data.Time.UTCTime' whereas @timestamp@ is 'Data.Time.LocalTime'. + +PostgreSQL's @timezone@ is a per-connection variable that by default is +initialized to @\'localtime\'@, which normally corresponds to the server's +time zone. However, this default can be modified on the server side for an +entire cluster, or on a per-user or per-database basis. Moreover, a client +can modify their instance of the variable at any time, and can apply that +change to the remaining duration of the connection, the current transaction, +or the execution context of a server-side function. In addition, upon +connection initialization, the libpq client checks for the existence of +the @PGTZ@ environment variable, and if it exists, modifies @timezone@ +accordingly. + +With a few caveats, postgresql-simple is designed so that you can both send +and receive timestamps with the server and get a correct result, no matter +what the @timezone@ setting is. But it is important to understand the caveats: + +1. The correctness of server-side computations can depend on the @timezone@ + setting. Examples include adding an @interval@ to a @timestamptz@, or + type casting between @timestamp@ and @timestamptz@, or applying + the @DATE@ function to a @timestamptz@. + +2. The (localtime, offset) pair contained in a 'Data.Time.ZonedTime' result + will depend on the @timezone@ setting, although the result will always + represent the same instant in time regardless of the time zone. + +3. Sending a 'Data.Time.LocalTime' and interpreting it as a @timestamptz@ + can be useful, as it will be converted to UTC via the tz database, + but correctness will depend on the @timezone@ setting. You may prefer + to use an explicit @AT TIME ZONE@ conversion instead, which would avoid + this contextual dependence. + +Furthermore, although these following points don't involve the @timezone@ +setting, they are related to the last point above: + +1. Sending a 'Data.Time.UTCTime' and interpreting it as a @timestamp@ can + be useful. In practice, the most common context used to disambiguate + @timestamp@ is that it represents UTC, and this coding technique will + work as expected in this situation. + +2. Sending a 'Data.Time.ZonedTime' and interpreting it as a @timestamp@ is + almost always the wrong thing to do, as the offset will be ignored and + discarded. This is likely to lead to inconsistencies in the database, + and may lead to partial data loss. + +When dealing with local timestamps that refer to the future, it is often +useful to store it as a local time in a @timestamp@ column and store the +time zone in a second column. One reason to do this is so that you can +convert to UTC on the fly as needed, and be protected against future changes +to the TZ database due to changes in local time standards. In any case, +'Data.Time.ZonedTime' is not suitable for this application, because despite +its name, it represents an offset and not a time zone. Time zones can change; +offsets do not. In reality, we can't convert a local timestamp that occurs +sufficiently far in the future to UTC, because we don't know how to do it yet. + +There are a few limitations and caveats that one might need to be aware +of with the current implementation when dealing with older timestamps: + +For sufficiently old timestamps in almost all time zones, the IANA TZ +database specifies offsets from UTC that is not an integral number of +minutes. This corresponds to local mean time; that is, astronomical +time in the city that defines the time zone. Different time zones moved +away from local mean time to a standard time at different points in +history, so \"sufficiently old\" depends on the time zone in question. + +Thus, when retrieving a @timestamptz@ postgresql will in some cases +provide seconds in the offset. For example: + +@ +$ psql +psql (9.4.5) +Type \"help\" for help. + +lpsmith=> SET timezone TO \'America/New_York\'; +SET +lpsmith=> VALUES (\'1883-11-18 16:59:59+00\'::timestamptz), + (\'1883-11-18 17:00:00+00\'::timestamptz); + column1 +------------------------------ + 1883-11-18 12:03:57-04:56:02 + 1883-11-18 12:00:00-05 +(2 rows) +@ + +Both of these timestamps can be parsed as a 'Data.Time.UTCTime' type, +however 'Data.Time.ZonedTime' will fail on the former timestamp. +Because 'Data.Time.ZonedTime' assumes that offsets are an integer number +of minutes, there isn't an particularly good solution here. + +PostgreSQL, like most software, uses the proleptic Gregorian calendar +for its date calculations, extending the Gregorian calendar backwards +in time before its introduction and pretending that the Julian calendar +does not exist. For most purposes, the adoption of the Gregorian calendar +ranges from @1582-10-15@ to @1923-03-01@, depending on location and +sometimes even political allegiances within a single location. + +Timestamps BCE are not supported. For example, PostgreSQL +will emit \"@0045-01-01 BC@\" for the first proleptic Gregorian day of +the year the Roman Empire adopted the Julian Calendar, but +postgresql-simple does not (yet?) have the ability to either parse or +generate this syntax. Unfortunately this syntax isn't convenient to +print or especially parse. + +Also, postgresql itself cannot parse or print dates before @4714-11-24 BC@, +which is the Julian date on the proleptic Gregorian Calendar. Although +postgresql's timestamp types are perfectly capable of representing timestamps +nearly 300,000 years in the past, using this would require postgresql-simple +and other client programs to support binary parameters and results. + +Dealing with years BCE is also complicated slightly by the fact that +Haskell's time library has a year \"0000\", which is a convention often +used by astronomers, while postgresql adopts the more historically +accurate convention that there is no year zero, but rather \"1 BCE\" +was immediately followed by \"1 CE\". + +-} module Database.PostgreSQL.Simple.Time ( Unbounded(..) diff -Nru haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/ToField.hs haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/ToField.hs --- haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/ToField.hs 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/ToField.hs 2015-12-14 19:49:35.000000000 +0000 @@ -22,11 +22,14 @@ , inQuotes ) where -import Blaze.ByteString.Builder (Builder, fromByteString, toByteString) -import Blaze.ByteString.Builder.Char8 (fromChar) -import Blaze.Text (integral, double, float) import qualified Data.Aeson as JSON -import Data.ByteString (ByteString) +import Data.ByteString (ByteString) +import Data.ByteString.Builder + ( Builder, byteString, char8, stringUtf8 + , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec + , wordDec, word8Dec, word16Dec, word32Dec, word64Dec + , floatDec, doubleDec + ) import Data.Int (Int8, Int16, Int32, Int64) import Data.List (intersperse) import Data.Monoid (mappend) @@ -35,15 +38,16 @@ import Data.Word (Word, Word8, Word16, Word32, Word64) import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow import Database.PostgreSQL.Simple.Types -import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8 +import Database.PostgreSQL.Simple.Compat (toByteString) + import qualified Data.ByteString as SB import qualified Data.ByteString.Lazy as LB import qualified Data.Text as ST import qualified Data.Text.Encoding as ST import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Builder as LT -import Data.UUID (UUID) -import qualified Data.UUID as UUID +import Data.UUID.Types (UUID) +import qualified Data.UUID.Types as UUID import Data.Vector (Vector) import qualified Data.Vector as V import qualified Database.PostgreSQL.LibPQ as PQ @@ -54,6 +58,7 @@ #else import Data.Scientific (scientificBuilder) #endif +import Foreign.C.Types (CUInt(..)) -- | How to render an element when substituting it into a query. data Action = @@ -99,84 +104,84 @@ {-# INLINE toField #-} instance (ToField a) => ToField (In [a]) where - toField (In []) = Plain $ fromByteString "(null)" + toField (In []) = Plain $ byteString "(null)" toField (In xs) = Many $ - Plain (fromChar '(') : - (intersperse (Plain (fromChar ',')) . map toField $ xs) ++ - [Plain (fromChar ')')] + Plain (char8 '(') : + (intersperse (Plain (char8 ',')) . map toField $ xs) ++ + [Plain (char8 ')')] renderNull :: Action -renderNull = Plain (fromByteString "null") +renderNull = Plain (byteString "null") instance ToField Null where toField _ = renderNull {-# INLINE toField #-} instance ToField Default where - toField _ = Plain (fromByteString "default") + toField _ = Plain (byteString "default") {-# INLINE toField #-} instance ToField Bool where - toField True = Plain (fromByteString "true") - toField False = Plain (fromByteString "false") + toField True = Plain (byteString "true") + toField False = Plain (byteString "false") {-# INLINE toField #-} instance ToField Int8 where - toField = Plain . integral + toField = Plain . int8Dec {-# INLINE toField #-} instance ToField Int16 where - toField = Plain . integral + toField = Plain . int16Dec {-# INLINE toField #-} instance ToField Int32 where - toField = Plain . integral + toField = Plain . int32Dec {-# INLINE toField #-} instance ToField Int where - toField = Plain . integral + toField = Plain . intDec {-# INLINE toField #-} instance ToField Int64 where - toField = Plain . integral + toField = Plain . int64Dec {-# INLINE toField #-} instance ToField Integer where - toField = Plain . integral + toField = Plain . integerDec {-# INLINE toField #-} instance ToField Word8 where - toField = Plain . integral + toField = Plain . word8Dec {-# INLINE toField #-} instance ToField Word16 where - toField = Plain . integral + toField = Plain . word16Dec {-# INLINE toField #-} instance ToField Word32 where - toField = Plain . integral + toField = Plain . word32Dec {-# INLINE toField #-} instance ToField Word where - toField = Plain . integral + toField = Plain . wordDec {-# INLINE toField #-} instance ToField Word64 where - toField = Plain . integral + toField = Plain . word64Dec {-# INLINE toField #-} instance ToField PQ.Oid where - toField = Plain . integral . \(PQ.Oid x) -> x + toField = Plain . \(PQ.Oid (CUInt x)) -> word32Dec x {-# INLINE toField #-} instance ToField Float where - toField v | isNaN v || isInfinite v = Plain (inQuotes (float v)) - | otherwise = Plain (float v) + toField v | isNaN v || isInfinite v = Plain (inQuotes (floatDec v)) + | otherwise = Plain (floatDec v) {-# INLINE toField #-} instance ToField Double where - toField v | isNaN v || isInfinite v = Plain (inQuotes (double v)) - | otherwise = Plain (double v) + toField v | isNaN v || isInfinite v = Plain (inQuotes (doubleDec v)) + | otherwise = Plain (doubleDec v) {-# INLINE toField #-} instance ToField Scientific where @@ -198,7 +203,7 @@ instance ToField QualifiedIdentifier where toField (QualifiedIdentifier (Just s) t) = Many [ EscapeIdentifier (ST.encodeUtf8 s) - , Plain (fromChar '.') + , Plain (char8 '.') , EscapeIdentifier (ST.encodeUtf8 t) ] toField (QualifiedIdentifier Nothing t) = @@ -218,7 +223,7 @@ {-# INLINE toField #-} instance ToField [Char] where - toField = Escape . toByteString . Utf8.fromString + toField = Escape . toByteString . stringUtf8 {-# INLINE toField #-} instance ToField LT.Text where @@ -267,18 +272,21 @@ {-# INLINE toField #-} instance (ToField a) => ToField (PGArray a) where - toField xs = Many $ - Plain (fromByteString "ARRAY[") : - (intersperse (Plain (fromChar ',')) . map toField $ fromPGArray xs) ++ - [Plain (fromChar ']')] - -- Because the ARRAY[...] input syntax is being used, it is possible - -- that the use of type-specific separator characters is unnecessary. + toField pgArray = + case fromPGArray pgArray of + [] -> Plain (byteString "'{}'") + xs -> Many $ + Plain (byteString "ARRAY[") : + (intersperse (Plain (char8 ',')) . map toField $ xs) ++ + [Plain (char8 ']')] + -- Because the ARRAY[...] input syntax is being used, it is possible + -- that the use of type-specific separator characters is unnecessary. instance (ToField a) => ToField (Vector a) where toField = toField . PGArray . V.toList instance ToField UUID where - toField = Plain . inQuotes . fromByteString . UUID.toASCIIBytes + toField = Plain . inQuotes . byteString . UUID.toASCIIBytes instance ToField JSON.Value where toField = toField . JSON.encode @@ -297,7 +305,7 @@ -- This function /does not/ perform any other escaping. inQuotes :: Builder -> Builder inQuotes b = quote `mappend` b `mappend` quote - where quote = Utf8.fromChar '\'' + where quote = char8 '\'' interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b] interleaveFoldr f b bs as = foldr (\a bs -> b : f a bs) bs as @@ -318,8 +326,8 @@ funcname = "Database.PostgreSQL.Simple.toField :: Values a -> Action" norows = funcname ++ " either values or types must be non-empty" emptyrow = funcname ++ " each row must contain at least one column" - lit = Plain . fromByteString - litC = Plain . fromChar + lit = Plain . byteString + litC = Plain . char8 values x = Many (lit "(VALUES ": x) typedField :: (Action, QualifiedIdentifier) -> [Action] -> [Action] diff -Nru haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/ToField.hs-boot haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/ToField.hs-boot --- haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/ToField.hs-boot 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/ToField.hs-boot 2015-12-14 19:49:35.000000000 +0000 @@ -1,7 +1,7 @@ module Database.PostgreSQL.Simple.ToField where import Database.PostgreSQL.Simple.Types -import Blaze.ByteString.Builder(Builder) +import Data.ByteString.Builder(Builder) import Data.ByteString(ByteString) -- | How to render an element when substituting it into a query. diff -Nru haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/ToRow.hs haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/ToRow.hs --- haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/ToRow.hs 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/ToRow.hs 2015-12-14 19:49:35.000000000 +0000 @@ -1,3 +1,4 @@ +{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.ToRow @@ -22,6 +23,7 @@ import Database.PostgreSQL.Simple.ToField (Action(..), ToField(..)) import Database.PostgreSQL.Simple.Types (Only(..), (:.)(..)) +import GHC.Generics -- | A collection type that can be turned into a list of rendering -- 'Action's. @@ -30,6 +32,8 @@ -- to perform conversion of each element of the collection. class ToRow a where toRow :: a -> [Action] + default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action] + toRow = gtoRow . from -- ^ ToField a collection of values. instance ToRow () where @@ -90,3 +94,20 @@ instance (ToRow a, ToRow b) => ToRow (a :. b) where toRow (a :. b) = toRow a ++ toRow b + + +-- Type class for default implementation of ToRow using generics +class GToRow f where + gtoRow :: f p -> [Action] + +instance GToRow f => GToRow (M1 c i f) where + gtoRow (M1 x) = gtoRow x + +instance (GToRow f, GToRow g) => GToRow (f :*: g) where + gtoRow (f :*: g) = gtoRow f ++ gtoRow g + +instance (ToField a) => GToRow (K1 R a) where + gtoRow (K1 a) = [toField a] + +instance GToRow U1 where + gtoRow _ = [] diff -Nru haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/ToRow.hs-boot haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/ToRow.hs-boot --- haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/ToRow.hs-boot 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/ToRow.hs-boot 2015-12-14 19:49:35.000000000 +0000 @@ -1,9 +1,18 @@ -module Database.PostgreSQL.Simple.ToRow where +{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-} +module Database.PostgreSQL.Simple.ToRow ( + ToRow(..) + ) where import Database.PostgreSQL.Simple.Types import {-# SOURCE #-} Database.PostgreSQL.Simple.ToField +import GHC.Generics class ToRow a where toRow :: a -> [Action] + default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action] + toRow = gtoRow . from + +class GToRow f where + gtoRow :: f p -> [Action] instance ToField a => ToRow (Only a) diff -Nru haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs --- haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs 2015-12-14 19:49:35.000000000 +0000 @@ -41,9 +41,6 @@ , cidr , float4 , float8 - , abstime - , reltime - , tinterval , unknown , circle , money @@ -63,9 +60,78 @@ , refcursor , record , void + , array_record + , regprocedure + , regoper + , regoperator + , regclass + , regtype , uuid , json , jsonb + , int2vector + , oidvector + , array_xml + , array_json + , array_line + , array_cidr + , array_circle + , array_money + , array_bool + , array_bytea + , array_char + , array_name + , array_int2 + , array_int2vector + , array_int4 + , array_regproc + , array_text + , array_tid + , array_xid + , array_cid + , array_oidvector + , array_bpchar + , array_varchar + , array_int8 + , array_point + , array_lseg + , array_path + , array_box + , array_float4 + , array_float8 + , array_polygon + , array_oid + , array_macaddr + , array_inet + , array_timestamp + , array_date + , array_time + , array_timestamptz + , array_interval + , array_numeric + , array_timetz + , array_bit + , array_varbit + , array_refcursor + , array_regprocedure + , array_regoper + , array_regoperator + , array_regclass + , array_regtype + , array_uuid + , array_jsonb + , int4range + , _int4range + , numrange + , _numrange + , tsrange + , _tsrange + , tstzrange + , _tstzrange + , daterange + , _daterange + , int8range + , _int8range ) where import Database.PostgreSQL.LibPQ (Oid(..)) @@ -96,9 +162,6 @@ 650 -> Just cidr 700 -> Just float4 701 -> Just float8 - 702 -> Just abstime - 703 -> Just reltime - 704 -> Just tinterval 705 -> Just unknown 718 -> Just circle 790 -> Just money @@ -118,9 +181,78 @@ 1790 -> Just refcursor 2249 -> Just record 2278 -> Just void + 2287 -> Just array_record + 2202 -> Just regprocedure + 2203 -> Just regoper + 2204 -> Just regoperator + 2205 -> Just regclass + 2206 -> Just regtype 2950 -> Just uuid 114 -> Just json 3802 -> Just jsonb + 22 -> Just int2vector + 30 -> Just oidvector + 143 -> Just array_xml + 199 -> Just array_json + 629 -> Just array_line + 651 -> Just array_cidr + 719 -> Just array_circle + 791 -> Just array_money + 1000 -> Just array_bool + 1001 -> Just array_bytea + 1002 -> Just array_char + 1003 -> Just array_name + 1005 -> Just array_int2 + 1006 -> Just array_int2vector + 1007 -> Just array_int4 + 1008 -> Just array_regproc + 1009 -> Just array_text + 1010 -> Just array_tid + 1011 -> Just array_xid + 1012 -> Just array_cid + 1013 -> Just array_oidvector + 1014 -> Just array_bpchar + 1015 -> Just array_varchar + 1016 -> Just array_int8 + 1017 -> Just array_point + 1018 -> Just array_lseg + 1019 -> Just array_path + 1020 -> Just array_box + 1021 -> Just array_float4 + 1022 -> Just array_float8 + 1027 -> Just array_polygon + 1028 -> Just array_oid + 1040 -> Just array_macaddr + 1041 -> Just array_inet + 1115 -> Just array_timestamp + 1182 -> Just array_date + 1183 -> Just array_time + 1185 -> Just array_timestamptz + 1187 -> Just array_interval + 1231 -> Just array_numeric + 1270 -> Just array_timetz + 1561 -> Just array_bit + 1563 -> Just array_varbit + 2201 -> Just array_refcursor + 2207 -> Just array_regprocedure + 2208 -> Just array_regoper + 2209 -> Just array_regoperator + 2210 -> Just array_regclass + 2211 -> Just array_regtype + 2951 -> Just array_uuid + 3807 -> Just array_jsonb + 3904 -> Just int4range + 3905 -> Just _int4range + 3906 -> Just numrange + 3907 -> Just _numrange + 3908 -> Just tsrange + 3909 -> Just _tsrange + 3910 -> Just tstzrange + 3911 -> Just _tstzrange + 3912 -> Just daterange + 3913 -> Just _daterange + 3926 -> Just int8range + 3927 -> Just _int8range _ -> Nothing bool :: TypeInfo @@ -307,30 +439,6 @@ typname = "float8" } -abstime :: TypeInfo -abstime = Basic { - typoid = Oid 702, - typcategory = 'D', - typdelim = ',', - typname = "abstime" - } - -reltime :: TypeInfo -reltime = Basic { - typoid = Oid 703, - typcategory = 'T', - typdelim = ',', - typname = "reltime" - } - -tinterval :: TypeInfo -tinterval = Basic { - typoid = Oid 704, - typcategory = 'T', - typdelim = ',', - typname = "tinterval" - } - unknown :: TypeInfo unknown = Basic { typoid = Oid 705, @@ -483,6 +591,55 @@ typname = "void" } +array_record :: TypeInfo +array_record = Array { + typoid = Oid 2287, + typcategory = 'P', + typdelim = ',', + typname = "_record", + typelem = record + } + +regprocedure :: TypeInfo +regprocedure = Basic { + typoid = Oid 2202, + typcategory = 'N', + typdelim = ',', + typname = "regprocedure" + } + +regoper :: TypeInfo +regoper = Basic { + typoid = Oid 2203, + typcategory = 'N', + typdelim = ',', + typname = "regoper" + } + +regoperator :: TypeInfo +regoperator = Basic { + typoid = Oid 2204, + typcategory = 'N', + typdelim = ',', + typname = "regoperator" + } + +regclass :: TypeInfo +regclass = Basic { + typoid = Oid 2205, + typcategory = 'N', + typdelim = ',', + typname = "regclass" + } + +regtype :: TypeInfo +regtype = Basic { + typoid = Oid 2206, + typcategory = 'N', + typdelim = ',', + typname = "regtype" + } + uuid :: TypeInfo uuid = Basic { typoid = Oid 2950, @@ -506,3 +663,570 @@ typdelim = ',', typname = "jsonb" } + +int2vector :: TypeInfo +int2vector = Array { + typoid = Oid 22, + typcategory = 'A', + typdelim = ',', + typname = "int2vector", + typelem = int2 + } + +oidvector :: TypeInfo +oidvector = Array { + typoid = Oid 30, + typcategory = 'A', + typdelim = ',', + typname = "oidvector", + typelem = oid + } + +array_xml :: TypeInfo +array_xml = Array { + typoid = Oid 143, + typcategory = 'A', + typdelim = ',', + typname = "_xml", + typelem = xml + } + +array_json :: TypeInfo +array_json = Array { + typoid = Oid 199, + typcategory = 'A', + typdelim = ',', + typname = "_json", + typelem = json + } + +array_line :: TypeInfo +array_line = Array { + typoid = Oid 629, + typcategory = 'A', + typdelim = ',', + typname = "_line", + typelem = line + } + +array_cidr :: TypeInfo +array_cidr = Array { + typoid = Oid 651, + typcategory = 'A', + typdelim = ',', + typname = "_cidr", + typelem = cidr + } + +array_circle :: TypeInfo +array_circle = Array { + typoid = Oid 719, + typcategory = 'A', + typdelim = ',', + typname = "_circle", + typelem = circle + } + +array_money :: TypeInfo +array_money = Array { + typoid = Oid 791, + typcategory = 'A', + typdelim = ',', + typname = "_money", + typelem = money + } + +array_bool :: TypeInfo +array_bool = Array { + typoid = Oid 1000, + typcategory = 'A', + typdelim = ',', + typname = "_bool", + typelem = bool + } + +array_bytea :: TypeInfo +array_bytea = Array { + typoid = Oid 1001, + typcategory = 'A', + typdelim = ',', + typname = "_bytea", + typelem = bytea + } + +array_char :: TypeInfo +array_char = Array { + typoid = Oid 1002, + typcategory = 'A', + typdelim = ',', + typname = "_char", + typelem = char + } + +array_name :: TypeInfo +array_name = Array { + typoid = Oid 1003, + typcategory = 'A', + typdelim = ',', + typname = "_name", + typelem = name + } + +array_int2 :: TypeInfo +array_int2 = Array { + typoid = Oid 1005, + typcategory = 'A', + typdelim = ',', + typname = "_int2", + typelem = int2 + } + +array_int2vector :: TypeInfo +array_int2vector = Array { + typoid = Oid 1006, + typcategory = 'A', + typdelim = ',', + typname = "_int2vector", + typelem = int2vector + } + +array_int4 :: TypeInfo +array_int4 = Array { + typoid = Oid 1007, + typcategory = 'A', + typdelim = ',', + typname = "_int4", + typelem = int4 + } + +array_regproc :: TypeInfo +array_regproc = Array { + typoid = Oid 1008, + typcategory = 'A', + typdelim = ',', + typname = "_regproc", + typelem = regproc + } + +array_text :: TypeInfo +array_text = Array { + typoid = Oid 1009, + typcategory = 'A', + typdelim = ',', + typname = "_text", + typelem = text + } + +array_tid :: TypeInfo +array_tid = Array { + typoid = Oid 1010, + typcategory = 'A', + typdelim = ',', + typname = "_tid", + typelem = tid + } + +array_xid :: TypeInfo +array_xid = Array { + typoid = Oid 1011, + typcategory = 'A', + typdelim = ',', + typname = "_xid", + typelem = xid + } + +array_cid :: TypeInfo +array_cid = Array { + typoid = Oid 1012, + typcategory = 'A', + typdelim = ',', + typname = "_cid", + typelem = cid + } + +array_oidvector :: TypeInfo +array_oidvector = Array { + typoid = Oid 1013, + typcategory = 'A', + typdelim = ',', + typname = "_oidvector", + typelem = oidvector + } + +array_bpchar :: TypeInfo +array_bpchar = Array { + typoid = Oid 1014, + typcategory = 'A', + typdelim = ',', + typname = "_bpchar", + typelem = bpchar + } + +array_varchar :: TypeInfo +array_varchar = Array { + typoid = Oid 1015, + typcategory = 'A', + typdelim = ',', + typname = "_varchar", + typelem = varchar + } + +array_int8 :: TypeInfo +array_int8 = Array { + typoid = Oid 1016, + typcategory = 'A', + typdelim = ',', + typname = "_int8", + typelem = int8 + } + +array_point :: TypeInfo +array_point = Array { + typoid = Oid 1017, + typcategory = 'A', + typdelim = ',', + typname = "_point", + typelem = point + } + +array_lseg :: TypeInfo +array_lseg = Array { + typoid = Oid 1018, + typcategory = 'A', + typdelim = ',', + typname = "_lseg", + typelem = lseg + } + +array_path :: TypeInfo +array_path = Array { + typoid = Oid 1019, + typcategory = 'A', + typdelim = ',', + typname = "_path", + typelem = path + } + +array_box :: TypeInfo +array_box = Array { + typoid = Oid 1020, + typcategory = 'A', + typdelim = ';', + typname = "_box", + typelem = box + } + +array_float4 :: TypeInfo +array_float4 = Array { + typoid = Oid 1021, + typcategory = 'A', + typdelim = ',', + typname = "_float4", + typelem = float4 + } + +array_float8 :: TypeInfo +array_float8 = Array { + typoid = Oid 1022, + typcategory = 'A', + typdelim = ',', + typname = "_float8", + typelem = float8 + } + +array_polygon :: TypeInfo +array_polygon = Array { + typoid = Oid 1027, + typcategory = 'A', + typdelim = ',', + typname = "_polygon", + typelem = polygon + } + +array_oid :: TypeInfo +array_oid = Array { + typoid = Oid 1028, + typcategory = 'A', + typdelim = ',', + typname = "_oid", + typelem = oid + } + +array_macaddr :: TypeInfo +array_macaddr = Array { + typoid = Oid 1040, + typcategory = 'A', + typdelim = ',', + typname = "_macaddr", + typelem = macaddr + } + +array_inet :: TypeInfo +array_inet = Array { + typoid = Oid 1041, + typcategory = 'A', + typdelim = ',', + typname = "_inet", + typelem = inet + } + +array_timestamp :: TypeInfo +array_timestamp = Array { + typoid = Oid 1115, + typcategory = 'A', + typdelim = ',', + typname = "_timestamp", + typelem = timestamp + } + +array_date :: TypeInfo +array_date = Array { + typoid = Oid 1182, + typcategory = 'A', + typdelim = ',', + typname = "_date", + typelem = date + } + +array_time :: TypeInfo +array_time = Array { + typoid = Oid 1183, + typcategory = 'A', + typdelim = ',', + typname = "_time", + typelem = time + } + +array_timestamptz :: TypeInfo +array_timestamptz = Array { + typoid = Oid 1185, + typcategory = 'A', + typdelim = ',', + typname = "_timestamptz", + typelem = timestamptz + } + +array_interval :: TypeInfo +array_interval = Array { + typoid = Oid 1187, + typcategory = 'A', + typdelim = ',', + typname = "_interval", + typelem = interval + } + +array_numeric :: TypeInfo +array_numeric = Array { + typoid = Oid 1231, + typcategory = 'A', + typdelim = ',', + typname = "_numeric", + typelem = numeric + } + +array_timetz :: TypeInfo +array_timetz = Array { + typoid = Oid 1270, + typcategory = 'A', + typdelim = ',', + typname = "_timetz", + typelem = timetz + } + +array_bit :: TypeInfo +array_bit = Array { + typoid = Oid 1561, + typcategory = 'A', + typdelim = ',', + typname = "_bit", + typelem = bit + } + +array_varbit :: TypeInfo +array_varbit = Array { + typoid = Oid 1563, + typcategory = 'A', + typdelim = ',', + typname = "_varbit", + typelem = varbit + } + +array_refcursor :: TypeInfo +array_refcursor = Array { + typoid = Oid 2201, + typcategory = 'A', + typdelim = ',', + typname = "_refcursor", + typelem = refcursor + } + +array_regprocedure :: TypeInfo +array_regprocedure = Array { + typoid = Oid 2207, + typcategory = 'A', + typdelim = ',', + typname = "_regprocedure", + typelem = regprocedure + } + +array_regoper :: TypeInfo +array_regoper = Array { + typoid = Oid 2208, + typcategory = 'A', + typdelim = ',', + typname = "_regoper", + typelem = regoper + } + +array_regoperator :: TypeInfo +array_regoperator = Array { + typoid = Oid 2209, + typcategory = 'A', + typdelim = ',', + typname = "_regoperator", + typelem = regoperator + } + +array_regclass :: TypeInfo +array_regclass = Array { + typoid = Oid 2210, + typcategory = 'A', + typdelim = ',', + typname = "_regclass", + typelem = regclass + } + +array_regtype :: TypeInfo +array_regtype = Array { + typoid = Oid 2211, + typcategory = 'A', + typdelim = ',', + typname = "_regtype", + typelem = regtype + } + +array_uuid :: TypeInfo +array_uuid = Array { + typoid = Oid 2951, + typcategory = 'A', + typdelim = ',', + typname = "_uuid", + typelem = uuid + } + +array_jsonb :: TypeInfo +array_jsonb = Array { + typoid = Oid 3807, + typcategory = 'A', + typdelim = ',', + typname = "_jsonb", + typelem = jsonb + } + +int4range :: TypeInfo +int4range = Range { + typoid = Oid 3904, + typcategory = 'R', + typdelim = ',', + typname = "int4range", + rngsubtype = int4 + } + +_int4range :: TypeInfo +_int4range = Array { + typoid = Oid 3905, + typcategory = 'A', + typdelim = ',', + typname = "_int4range", + typelem = int4range + } + +numrange :: TypeInfo +numrange = Range { + typoid = Oid 3906, + typcategory = 'R', + typdelim = ',', + typname = "numrange", + rngsubtype = numeric + } + +_numrange :: TypeInfo +_numrange = Array { + typoid = Oid 3907, + typcategory = 'A', + typdelim = ',', + typname = "_numrange", + typelem = numrange + } + +tsrange :: TypeInfo +tsrange = Range { + typoid = Oid 3908, + typcategory = 'R', + typdelim = ',', + typname = "tsrange", + rngsubtype = timestamp + } + +_tsrange :: TypeInfo +_tsrange = Array { + typoid = Oid 3909, + typcategory = 'A', + typdelim = ',', + typname = "_tsrange", + typelem = tsrange + } + +tstzrange :: TypeInfo +tstzrange = Range { + typoid = Oid 3910, + typcategory = 'R', + typdelim = ',', + typname = "tstzrange", + rngsubtype = timestamptz + } + +_tstzrange :: TypeInfo +_tstzrange = Array { + typoid = Oid 3911, + typcategory = 'A', + typdelim = ',', + typname = "_tstzrange", + typelem = tstzrange + } + +daterange :: TypeInfo +daterange = Range { + typoid = Oid 3912, + typcategory = 'R', + typdelim = ',', + typname = "daterange", + rngsubtype = date + } + +_daterange :: TypeInfo +_daterange = Array { + typoid = Oid 3913, + typcategory = 'A', + typdelim = ',', + typname = "_daterange", + typelem = daterange + } + +int8range :: TypeInfo +int8range = Range { + typoid = Oid 3926, + typcategory = 'R', + typdelim = ',', + typname = "int8range", + rngsubtype = int8 + } + +_int8range :: TypeInfo +_int8range = Array { + typoid = Oid 3927, + typcategory = 'A', + typdelim = ',', + typname = "_int8range", + typelem = int8range + } diff -Nru haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/Types.hs haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Types.hs --- haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple/Types.hs 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple/Types.hs 2015-12-14 19:49:35.000000000 +0000 @@ -30,18 +30,18 @@ , Values(..) ) where -import Blaze.ByteString.Builder (toByteString) import Control.Arrow (first) import Data.ByteString (ByteString) import Data.Hashable (Hashable(hashWithSalt)) import Data.Monoid (Monoid(..)) import Data.String (IsString(..)) import Data.Typeable (Typeable) -import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8 +import Data.ByteString.Builder ( stringUtf8 ) import qualified Data.ByteString as B import Data.Text (Text) import qualified Data.Text as T import Database.PostgreSQL.LibPQ (Oid(..)) +import Database.PostgreSQL.Simple.Compat (toByteString) -- | A placeholder for the SQL @NULL@ value. data Null = Null @@ -85,7 +85,7 @@ readsPrec i = fmap (first Query) . readsPrec i instance IsString Query where - fromString = Query . toByteString . Utf8.fromString + fromString = Query . toByteString . stringUtf8 instance Monoid Query where mempty = Query B.empty diff -Nru haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple.hs haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple.hs --- haskell-postgresql-simple-0.4.10.0/src/Database/PostgreSQL/Simple.hs 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/src/Database/PostgreSQL/Simple.hs 2015-12-14 19:49:35.000000000 +0000 @@ -42,7 +42,7 @@ -- ** Modifying multiple rows at once -- $many - -- ** @RETURNING@: modifications that returns results + -- ** @RETURNING@: modifications that return results -- $returning -- * Extracting results @@ -93,6 +93,14 @@ , forEach , forEach_ , returning + -- ** Queries that stream results taking a parser as an argument + , foldWith + , foldWithOptionsAndParser + , foldWith_ + , foldWithOptionsAndParser_ + , forEachWith + , forEachWith_ + , returningWith -- * Statements that do not return results , execute , execute_ @@ -110,18 +118,16 @@ , formatQuery ) where -import Blaze.ByteString.Builder - ( Builder, fromByteString, toByteString ) -import Blaze.ByteString.Builder.Char8 (fromChar) -import Blaze.Text ( integral ) +import Data.ByteString.Builder + ( Builder, byteString, char8, intDec ) import Control.Applicative ((<$>)) import Control.Exception as E -import Control.Monad (foldM) +import Control.Monad (unless) import Data.ByteString (ByteString) import Data.Int (Int64) import Data.List (intersperse) import Data.Monoid (mconcat) -import Database.PostgreSQL.Simple.Compat ( (<>) ) +import Database.PostgreSQL.Simple.Compat ( (<>), toByteString ) import Database.PostgreSQL.Simple.FromField (ResultError(..)) import Database.PostgreSQL.Simple.FromRow (FromRow(..)) import Database.PostgreSQL.Simple.Ok @@ -173,9 +179,9 @@ case parseTemplate template of Just (before, qbits, after) -> do bs <- mapM (buildQuery conn q qbits . toRow) qs - return . toByteString . mconcat $ fromByteString before : - intersperse (fromChar ',') bs ++ - [fromByteString after] + return . toByteString . mconcat $ byteString before : + intersperse (char8 ',') bs ++ + [byteString after] Nothing -> fmtError "syntax error in multi-row template" q [] -- Split the input string into three pieces, @before@, @qbits@, and @after@, @@ -280,7 +286,7 @@ zipParams (split template) <$> mapM (buildAction conn q xs) xs where split s = let (h,t) = B.break (=='?') s - in fromByteString h + in byteString h : if B.null t then [] else split (B.tail t) @@ -329,7 +335,7 @@ -- SET sometable.y = upd.y -- FROM (VALUES (?,?)) as upd(x,y) -- WHERE sometable.x = upd.x --- |] [(1, \"hello\"),(2, \"world\") +-- |] [(1, \"hello\"),(2, \"world\")] -- @ executeMany :: (ToRow q) => Connection -> Query -> [q] -> IO Int64 @@ -351,10 +357,13 @@ -- -- Throws 'FormatError' if the query could not be formatted correctly. returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO [r] -returning _ _ [] = return [] -returning conn q qs = do +returning = returningWith fromRow + +returningWith :: (ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO [r] +returningWith _ _ _ [] = return [] +returningWith parser conn q qs = do result <- exec conn =<< formatMany conn q qs - finishQuery conn q result + finishQueryWith parser conn q result -- | Perform a @SELECT@ or other SQL query that is expected to return -- results. All results are retrieved and converted before this @@ -429,6 +438,17 @@ -> IO a fold = foldWithOptions defaultFoldOptions +-- | A version of 'fold' taking a parser as an argument +foldWith :: ( ToRow params ) + => RowParser row + -> Connection + -> Query + -> params + -> a + -> (a -> row -> IO a) + -> IO a +foldWith = foldWithOptionsAndParser defaultFoldOptions + -- | Number of rows to fetch at a time. 'Automatic' currently defaults -- to 256 rows, although it might be nice to make this more intelligent -- based on e.g. the average size of the rows. @@ -463,9 +483,21 @@ -> a -> (a -> row -> IO a) -> IO a -foldWithOptions opts conn template qs a f = do +foldWithOptions opts = foldWithOptionsAndParser opts fromRow + +-- | A version of 'foldWithOptions' taking a parser as an argument +foldWithOptionsAndParser :: (ToRow params) + => FoldOptions + -> RowParser row + -> Connection + -> Query + -> params + -> a + -> (a -> row -> IO a) + -> IO a +foldWithOptionsAndParser opts parser conn template qs a f = do q <- formatQuery conn template qs - doFold opts conn template (Query q) a f + doFold opts parser conn template (Query q) a f -- | A version of 'fold' that does not perform query substitution. fold_ :: (FromRow r) => @@ -476,6 +508,14 @@ -> IO a fold_ = foldWithOptions_ defaultFoldOptions +-- | A version of 'fold_' taking a parser as an argument +foldWith_ :: RowParser r + -> Connection + -> Query + -> a + -> (a -> r -> IO a) + -> IO a +foldWith_ = foldWithOptionsAndParser_ defaultFoldOptions foldWithOptions_ :: (FromRow r) => FoldOptions @@ -484,18 +524,27 @@ -> a -- ^ Initial state for result consumer. -> (a -> r -> IO a) -- ^ Result consumer. -> IO a -foldWithOptions_ opts conn query a f = doFold opts conn query query a f +foldWithOptions_ opts conn query a f = doFold opts fromRow conn query query a f +-- | A version of 'foldWithOptions_' taking a parser as an argument +foldWithOptionsAndParser_ :: FoldOptions + -> RowParser r + -> Connection + -> Query -- ^ Query. + -> a -- ^ Initial state for result consumer. + -> (a -> r -> IO a) -- ^ Result consumer. + -> IO a +foldWithOptionsAndParser_ opts parser conn query a f = doFold opts parser conn query query a f -doFold :: ( FromRow row ) - => FoldOptions +doFold :: FoldOptions + -> RowParser row -> Connection -> Query -> Query -> a -> (a -> row -> IO a) -> IO a -doFold FoldOptions{..} conn _template q a0 f = do +doFold FoldOptions{..} parser conn _template q a0 f = do stat <- withConnection conn PQ.transactionStatus case stat of PQ.TransIdle -> withTransactionMode transactionMode conn go @@ -518,22 +567,33 @@ _ <- execute_ conn $ mconcat [ "DECLARE ", name, " NO SCROLL CURSOR FOR ", q ] return name - fetch (Query name) = query_ conn $ - Query (toByteString (fromByteString "FETCH FORWARD " - <> integral chunkSize - <> fromByteString " FROM " - <> fromByteString name - )) close name = (execute_ conn ("CLOSE " <> name) >> return ()) `E.catch` \ex -> -- Don't throw exception if CLOSE failed because the transaction is -- aborted. Otherwise, it will throw away the original error. - if isFailedTransactionError ex then return () else throwIO ex + unless (isFailedTransactionError ex) $ throwIO ex - go = bracket declare close $ \name -> - let loop a = do - rs <- fetch name - if null rs then return a else foldM f a rs >>= loop + go = bracket declare close $ \(Query name) -> + let q = toByteString (byteString "FETCH FORWARD " + <> intDec chunkSize + <> byteString " FROM " + <> byteString name + ) + loop a = do + result <- exec conn q + status <- PQ.resultStatus result + case status of + PQ.TuplesOk -> do + nrows <- PQ.ntuples result + ncols <- PQ.nfields result + if nrows > 0 + then do + let inner a row = do + x <- getRowWith parser row ncols conn result + f a x + foldM' inner a 0 (nrows - 1) >>= loop + else return a + _ -> throwResultError "fold" result status in loop a0 -- FIXME: choose the Automatic chunkSize more intelligently @@ -553,18 +613,37 @@ -> q -- ^ Query parameters. -> (r -> IO ()) -- ^ Result consumer. -> IO () -forEach conn template qs = fold conn template qs () . const +forEach = forEachWith fromRow {-# INLINE forEach #-} +-- | A version of 'forEach' taking a parser as an argument +forEachWith :: ( ToRow q ) + => RowParser r + -> Connection + -> Query + -> q + -> (r -> IO ()) + -> IO () +forEachWith parser conn template qs = foldWith parser conn template qs () . const +{-# INLINE forEachWith #-} + -- | A version of 'forEach' that does not perform query substitution. forEach_ :: (FromRow r) => Connection -> Query -- ^ Query template. -> (r -> IO ()) -- ^ Result consumer. -> IO () -forEach_ conn template = fold_ conn template () . const +forEach_ = forEachWith_ fromRow {-# INLINE forEach_ #-} +forEachWith_ :: RowParser r + -> Connection + -> Query + -> (r -> IO ()) + -> IO () +forEachWith_ parser conn template = foldWith_ parser conn template () . const +{-# INLINE forEachWith_ #-} + forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a] forM' lo hi m = loop hi [] where @@ -573,9 +652,17 @@ | otherwise = do a <- m n loop (n-1) (a:as) +{-# INLINE forM' #-} -finishQuery :: FromRow r => Connection -> Query -> PQ.Result -> IO [r] -finishQuery = finishQueryWith fromRow +foldM' :: (Ord n, Num n) => (a -> n -> IO a) -> a -> n -> n -> IO a +foldM' f a lo hi = loop a lo + where + loop a !n + | n > hi = return a + | otherwise = do + a' <- f a n + loop a' (n+1) +{-# INLINE foldM' #-} finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r] finishQueryWith parser conn q result = do @@ -583,33 +670,13 @@ case status of PQ.EmptyQuery -> throwIO $ QueryError "query: Empty query" q - PQ.CommandOk -> do + PQ.CommandOk -> throwIO $ QueryError "query resulted in a command response" q PQ.TuplesOk -> do - let unCol (PQ.Col x) = fromIntegral x :: Int nrows <- PQ.ntuples result ncols <- PQ.nfields result - forM' 0 (nrows-1) $ \row -> do - let rw = Row row result - okvc <- runConversion (runStateT (runReaderT (unRP parser) rw) 0) conn - case okvc of - Ok (val,col) | col == ncols -> return val - | otherwise -> do - vals <- forM' 0 (ncols-1) $ \c -> do - tinfo <- getTypeInfo conn =<< PQ.ftype result c - v <- PQ.getvalue result row c - return ( tinfo - , fmap ellipsis v ) - throw (ConversionFailed - (show (unCol ncols) ++ " values: " ++ show vals) - Nothing - "" - (show (unCol col) ++ " slots in target type") - "mismatch between number of columns to \ - \convert and number in target type") - Errors [] -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error" - Errors [x] -> throwIO x - Errors xs -> throwIO $ ManyErrors xs + forM' 0 (nrows-1) $ \row -> + getRowWith parser row ncols conn result PQ.CopyOut -> throwIO $ QueryError "query: COPY TO is not supported" q PQ.CopyIn -> @@ -618,6 +685,30 @@ PQ.NonfatalError -> throwResultError "query" result status PQ.FatalError -> throwResultError "query" result status +getRowWith :: RowParser r -> PQ.Row -> PQ.Column -> Connection -> PQ.Result -> IO r +getRowWith parser row ncols conn result = do + let rw = Row row result + let unCol (PQ.Col x) = fromIntegral x :: Int + okvc <- runConversion (runStateT (runReaderT (unRP parser) rw) 0) conn + case okvc of + Ok (val,col) | col == ncols -> return val + | otherwise -> do + vals <- forM' 0 (ncols-1) $ \c -> do + tinfo <- getTypeInfo conn =<< PQ.ftype result c + v <- PQ.getvalue result row c + return ( tinfo + , fmap ellipsis v ) + throw (ConversionFailed + (show (unCol ncols) ++ " values: " ++ show vals) + Nothing + "" + (show (unCol col) ++ " slots in target type") + "mismatch between number of columns to \ + \convert and number in target type") + Errors [] -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error" + Errors [x] -> throwIO x + Errors xs -> throwIO $ ManyErrors xs + ellipsis :: ByteString -> ByteString ellipsis bs | B.length bs > 15 = B.take 10 bs `B.append` "[...]" diff -Nru haskell-postgresql-simple-0.4.10.0/test/Main.hs haskell-postgresql-simple-0.5.1.2/test/Main.hs --- haskell-postgresql-simple-0.4.10.0/test/Main.hs 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/test/Main.hs 2015-12-14 19:49:35.000000000 +0000 @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -23,6 +24,7 @@ import System.IO import qualified Data.Vector as V import Data.Aeson +import GHC.Generics (Generic) import Notify import Serializable @@ -44,6 +46,9 @@ , TestLabel "Values" . testValues , TestLabel "Copy" . testCopy , TestLabel "Double" . testDouble + , TestLabel "1-ary generic" . testGeneric1 + , TestLabel "2-ary generic" . testGeneric2 + , TestLabel "3-ary generic" . testGeneric3 ] testBytea :: TestEnv -> Test @@ -184,6 +189,8 @@ roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text) roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text) roundTrip (V.fromList [1,2,3,4,5::Int]) + roundTrip ("foo" :: Text) + roundTrip (42 :: Int) where roundTrip :: ToJSON a => a -> Assertion roundTrip a = do @@ -318,6 +325,45 @@ x @?= (-1 / 0) +testGeneric1 :: TestEnv -> Test +testGeneric1 TestEnv{..} = TestCase $ do + roundTrip conn (Gen1 123) + where + roundTrip conn x0 = do + r <- query conn "SELECT ?::int" (x0 :: Gen1) + r @?= [x0] + +testGeneric2 :: TestEnv -> Test +testGeneric2 TestEnv{..} = TestCase $ do + roundTrip conn (Gen2 123 "asdf") + where + roundTrip conn x0 = do + r <- query conn "SELECT ?::int, ?::text" x0 + r @?= [x0] + +testGeneric3 :: TestEnv -> Test +testGeneric3 TestEnv{..} = TestCase $ do + roundTrip conn (Gen3 123 "asdf" True) + where + roundTrip conn x0 = do + r <- query conn "SELECT ?::int, ?::text, ?::bool" x0 + r @?= [x0] + +data Gen1 = Gen1 Int + deriving (Show,Eq,Generic) +instance FromRow Gen1 +instance ToRow Gen1 + +data Gen2 = Gen2 Int Text + deriving (Show,Eq,Generic) +instance FromRow Gen2 +instance ToRow Gen2 + +data Gen3 = Gen3 Int Text Bool + deriving (Show,Eq,Generic) +instance FromRow Gen3 +instance ToRow Gen3 + data TestException = TestException deriving (Eq, Show, Typeable) diff -Nru haskell-postgresql-simple-0.4.10.0/test/Time.hs haskell-postgresql-simple-0.5.1.2/test/Time.hs --- haskell-postgresql-simple-0.4.10.0/test/Time.hs 2015-02-26 13:40:52.000000000 +0000 +++ haskell-postgresql-simple-0.5.1.2/test/Time.hs 2015-12-14 19:49:35.000000000 +0000 @@ -47,15 +47,15 @@ testTime env@TestEnv{..} = TestCase $ do initializeTable env execute_ conn "SET timezone TO 'UTC'" - checkRoundTrips env + checkRoundTrips env "1860-01-01 00:00:00+00" execute_ conn "SET timezone TO 'America/Chicago'" -- -5:00 - checkRoundTrips env + checkRoundTrips env "1883-11-18 12:00:00-06" execute_ conn "SET timezone TO 'Asia/Tokyo'" -- +9:00 - checkRoundTrips env + checkRoundTrips env "1888-01-01 00:00:00+09" execute_ conn "SET timezone TO 'Asia/Kathmandu'" -- +5:45 - checkRoundTrips env + checkRoundTrips env "1919-12-31 23:48:44+05:30" execute_ conn "SET timezone TO 'America/St_Johns'" -- -3:30 - checkRoundTrips env + checkRoundTrips env "1935-03-30 00:00:52-03:30" initializeTable :: TestEnv -> IO () initializeTable TestEnv{..} = withTransaction conn $ do @@ -102,10 +102,18 @@ pop "100 milliseconds" 6.3113904e10 pop "1 second" 6.3113904e9 -checkRoundTrips :: TestEnv -> IO () -checkRoundTrips TestEnv{..} = do +checkRoundTrips :: TestEnv -> ByteString -> IO () +checkRoundTrips TestEnv{..} limit = do yxs :: [(UTCTime, Int)] <- query_ conn [sql| SELECT y, x FROM testtime |] forM_ yxs $ \yx -> do res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx assertBool "UTCTime did not round-trip from SQL to Haskell and back" $ res == [Only True] + + yxs :: [(ZonedTime, Int)] <- query conn [sql| + SELECT y, x FROM testtime WHERE y > ? + |] (Only limit) + forM_ yxs $ \yx -> do + res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx + assertBool "ZonedTime did not round-trip from SQL to Haskell and back" $ + res == [Only True]