diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -20,3 +20,10 @@ Chris Allen Simon Hengel Tom Ellis +Mike Ledger +João Cristóvão +Bardur Arantsson +Travis Staton +Sam Rijs +Janne Hellsten +Timmy Tofu diff --git a/postgresql-simple.cabal b/postgresql-simple.cabal --- a/postgresql-simple.cabal +++ b/postgresql-simple.cabal @@ -1,5 +1,5 @@ Name: postgresql-simple -Version: 0.4.10.0 +Version: 0.5.0.0 Synopsis: Mid-Level PostgreSQL client library Description: Mid-Level PostgreSQL client library, forked from mysql-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, bytestring >= 0.9, + bytestring-builder, case-insensitive, containers, hashable, @@ -66,7 +67,7 @@ text >= 0.11.1, time, transformers, - uuid >= 1.3.1, + uuid-types >= 1.0.0, scientific, vector @@ -82,7 +83,7 @@ source-repository this type: git location: http://github.com/lpsmith/postgresql-simple - tag: v0.4.10.0 + tag: v0.5.0.0 test-suite test type: exitcode-stdio-1.0 diff --git a/src/Database/PostgreSQL/Simple.hs b/src/Database/PostgreSQL/Simple.hs --- a/src/Database/PostgreSQL/Simple.hs +++ b/src/Database/PostgreSQL/Simple.hs @@ -42,7 +42,7 @@ -- ** Modifying multiple rows at once -- $many - -- ** @RETURNING@: modifications that returns results + -- ** @RETURNING@: modifications that return results -- $returning -- * Extracting results @@ -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,10 +118,8 @@ , 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) @@ -121,7 +127,7 @@ 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) @@ -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 'foldWith' 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,11 +567,11 @@ _ <- 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 + fetch (Query name) = queryWith_ parser conn $ + Query (toByteString (byteString "FETCH FORWARD " + <> intDec chunkSize + <> byteString " FROM " + <> byteString name )) close name = (execute_ conn ("CLOSE " <> name) >> return ()) `E.catch` \ex -> @@ -553,17 +602,36 @@ -> 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 [] diff --git a/src/Database/PostgreSQL/Simple/BuiltinTypes.hs b/src/Database/PostgreSQL/Simple/BuiltinTypes.hs deleted file mode 100644 --- a/src/Database/PostgreSQL/Simple/BuiltinTypes.hs +++ /dev/null @@ -1,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 --git a/src/Database/PostgreSQL/Simple/Compat.hs b/src/Database/PostgreSQL/Simple/Compat.hs --- a/src/Database/PostgreSQL/Simple/Compat.hs +++ b/src/Database/PostgreSQL/Simple/Compat.hs @@ -5,11 +5,24 @@ ( mask , (<>) , unsafeDupablePerformIO + , toByteString + , scientificBuilder + , toPico + , fromPico ) where import qualified Control.Exception as E import Data.Monoid +import Data.ByteString (ByteString) +import Data.ByteString.Lazy (toStrict) +import Data.ByteString.Builder (Builder, toLazyByteString) +#if MIN_VERSION_scientific(0,3,0) +import Data.Text.Lazy.Builder.Scientific (scientificBuilder) +#else +import Data.Scientific (scientificBuilder) +#endif + #if __GLASGOW_HASKELL__ >= 702 import System.IO.Unsafe (unsafeDupablePerformIO) #elif __GLASGOW_HASKELL__ >= 611 @@ -18,6 +31,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. -- @@ -42,4 +61,25 @@ (<>) :: Monoid m => m -> m -> m (<>) = mappend {-# INLINE (<>) #-} +#endif + +toByteString :: Builder -> ByteString +toByteString x = toStrict (toLazyByteString x) + +#if MIN_VERSION_base(4,7,0) + +toPico :: Integer -> Pico +toPico = MkFixed + +fromPico :: Pico -> Integer +fromPico (MkFixed i) = i + +#else + +toPico :: Integer -> Pico +toPico = unsafeCoerce + +fromPico :: Pico -> Integer +fromPico = unsafeCoerce + #endif diff --git a/src/Database/PostgreSQL/Simple/Errors.hs b/src/Database/PostgreSQL/Simple/Errors.hs --- a/src/Database/PostgreSQL/Simple/Errors.hs +++ b/src/Database/PostgreSQL/Simple/Errors.hs @@ -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 --git a/src/Database/PostgreSQL/Simple/FromField.hs b/src/Database/PostgreSQL/Simple/FromField.hs --- a/src/Database/PostgreSQL/Simple/FromField.hs +++ b/src/Database/PostgreSQL/Simple/FromField.hs @@ -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 --git a/src/Database/PostgreSQL/Simple/HStore/Implementation.hs b/src/Database/PostgreSQL/Simple/HStore/Implementation.hs --- a/src/Database/PostgreSQL/Simple/HStore/Implementation.hs +++ b/src/Database/PostgreSQL/Simple/HStore/Implementation.hs @@ -15,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 --git a/src/Database/PostgreSQL/Simple/Internal.hs b/src/Database/PostgreSQL/Simple/Internal.hs --- a/src/Database/PostgreSQL/Simple/Internal.hs +++ b/src/Database/PostgreSQL/Simple/Internal.hs @@ -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,8 +75,11 @@ connectionHandle :: {-# UNPACK #-} !(MVar PQ.Connection) , connectionObjects :: {-# UNPACK #-} !(MVar TypeInfoCache) , connectionTempNameCounter :: {-# UNPACK #-} !(IORef Int64) - } + } deriving (Typeable) +instance Eq Connection where + x == y = connectionHandle x == connectionHandle y + data SqlError = SqlError { sqlState :: ByteString , sqlExecStatus :: ExecStatus @@ -206,9 +209,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 +228,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 +541,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 +552,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 --git a/src/Database/PostgreSQL/Simple/LargeObjects.hs b/src/Database/PostgreSQL/Simple/LargeObjects.hs --- a/src/Database/PostgreSQL/Simple/LargeObjects.hs +++ b/src/Database/PostgreSQL/Simple/LargeObjects.hs @@ -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 --git a/src/Database/PostgreSQL/Simple/Range.hs b/src/Database/PostgreSQL/Simple/Range.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Range.hs @@ -0,0 +1,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 --git a/src/Database/PostgreSQL/Simple/SqlQQ.hs b/src/Database/PostgreSQL/Simple/SqlQQ.hs --- a/src/Database/PostgreSQL/Simple/SqlQQ.hs +++ b/src/Database/PostgreSQL/Simple/SqlQQ.hs @@ -1,3 +1,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 --git a/src/Database/PostgreSQL/Simple/Time/Implementation.hs b/src/Database/PostgreSQL/Simple/Time/Implementation.hs --- a/src/Database/PostgreSQL/Simple/Time/Implementation.hs +++ b/src/Database/PostgreSQL/Simple/Time/Implementation.hs @@ -1,51 +1,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 --git a/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs b/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs @@ -0,0 +1,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 --git a/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs b/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs @@ -0,0 +1,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 ((,) ':' >$< 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 --git a/src/Database/PostgreSQL/Simple/ToField.hs b/src/Database/PostgreSQL/Simple/ToField.hs --- a/src/Database/PostgreSQL/Simple/ToField.hs +++ b/src/Database/PostgreSQL/Simple/ToField.hs @@ -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 @@ -268,9 +273,9 @@ instance (ToField a) => ToField (PGArray a) where toField xs = Many $ - Plain (fromByteString "ARRAY[") : - (intersperse (Plain (fromChar ',')) . map toField $ fromPGArray xs) ++ - [Plain (fromChar ']')] + Plain (byteString "ARRAY[") : + (intersperse (Plain (char8 ',')) . map toField $ fromPGArray xs) ++ + [Plain (char8 ']')] -- Because the ARRAY[...] input syntax is being used, it is possible -- that the use of type-specific separator characters is unnecessary. @@ -278,7 +283,7 @@ 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 +302,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 +323,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 --git a/src/Database/PostgreSQL/Simple/ToField.hs-boot b/src/Database/PostgreSQL/Simple/ToField.hs-boot --- a/src/Database/PostgreSQL/Simple/ToField.hs-boot +++ b/src/Database/PostgreSQL/Simple/ToField.hs-boot @@ -1,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 --git a/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs b/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs --- a/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs +++ b/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs @@ -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, @@ -505,4 +662,571 @@ typcategory = 'U', typdelim = ',', typname = "jsonb" + } + +int2vector :: TypeInfo +int2vector = Array { + typoid = Oid 22, + typcategory = 'A', + typdelim = ',', + typname = "int2vector", + typelem = int2 + } + +oidvector :: TypeInfo +oidvector = Array { + typoid = Oid 30, + typcategory = 'A', + typdelim = ',', + typname = "oidvector", + typelem = oid + } + +array_xml :: TypeInfo +array_xml = Array { + typoid = Oid 143, + typcategory = 'A', + typdelim = ',', + typname = "_xml", + typelem = xml + } + +array_json :: TypeInfo +array_json = Array { + typoid = Oid 199, + typcategory = 'A', + typdelim = ',', + typname = "_json", + typelem = json + } + +array_line :: TypeInfo +array_line = Array { + typoid = Oid 629, + typcategory = 'A', + typdelim = ',', + typname = "_line", + typelem = line + } + +array_cidr :: TypeInfo +array_cidr = Array { + typoid = Oid 651, + typcategory = 'A', + typdelim = ',', + typname = "_cidr", + typelem = cidr + } + +array_circle :: TypeInfo +array_circle = Array { + typoid = Oid 719, + typcategory = 'A', + typdelim = ',', + typname = "_circle", + typelem = circle + } + +array_money :: TypeInfo +array_money = Array { + typoid = Oid 791, + typcategory = 'A', + typdelim = ',', + typname = "_money", + typelem = money + } + +array_bool :: TypeInfo +array_bool = Array { + typoid = Oid 1000, + typcategory = 'A', + typdelim = ',', + typname = "_bool", + typelem = bool + } + +array_bytea :: TypeInfo +array_bytea = Array { + typoid = Oid 1001, + typcategory = 'A', + typdelim = ',', + typname = "_bytea", + typelem = bytea + } + +array_char :: TypeInfo +array_char = Array { + typoid = Oid 1002, + typcategory = 'A', + typdelim = ',', + typname = "_char", + typelem = char + } + +array_name :: TypeInfo +array_name = Array { + typoid = Oid 1003, + typcategory = 'A', + typdelim = ',', + typname = "_name", + typelem = name + } + +array_int2 :: TypeInfo +array_int2 = Array { + typoid = Oid 1005, + typcategory = 'A', + typdelim = ',', + typname = "_int2", + typelem = int2 + } + +array_int2vector :: TypeInfo +array_int2vector = Array { + typoid = Oid 1006, + typcategory = 'A', + typdelim = ',', + typname = "_int2vector", + typelem = int2vector + } + +array_int4 :: TypeInfo +array_int4 = Array { + typoid = Oid 1007, + typcategory = 'A', + typdelim = ',', + typname = "_int4", + typelem = int4 + } + +array_regproc :: TypeInfo +array_regproc = Array { + typoid = Oid 1008, + typcategory = 'A', + typdelim = ',', + typname = "_regproc", + typelem = regproc + } + +array_text :: TypeInfo +array_text = Array { + typoid = Oid 1009, + typcategory = 'A', + typdelim = ',', + typname = "_text", + typelem = text + } + +array_tid :: TypeInfo +array_tid = Array { + typoid = Oid 1010, + typcategory = 'A', + typdelim = ',', + typname = "_tid", + typelem = tid + } + +array_xid :: TypeInfo +array_xid = Array { + typoid = Oid 1011, + typcategory = 'A', + typdelim = ',', + typname = "_xid", + typelem = xid + } + +array_cid :: TypeInfo +array_cid = Array { + typoid = Oid 1012, + typcategory = 'A', + typdelim = ',', + typname = "_cid", + typelem = cid + } + +array_oidvector :: TypeInfo +array_oidvector = Array { + typoid = Oid 1013, + typcategory = 'A', + typdelim = ',', + typname = "_oidvector", + typelem = oidvector + } + +array_bpchar :: TypeInfo +array_bpchar = Array { + typoid = Oid 1014, + typcategory = 'A', + typdelim = ',', + typname = "_bpchar", + typelem = bpchar + } + +array_varchar :: TypeInfo +array_varchar = Array { + typoid = Oid 1015, + typcategory = 'A', + typdelim = ',', + typname = "_varchar", + typelem = varchar + } + +array_int8 :: TypeInfo +array_int8 = Array { + typoid = Oid 1016, + typcategory = 'A', + typdelim = ',', + typname = "_int8", + typelem = int8 + } + +array_point :: TypeInfo +array_point = Array { + typoid = Oid 1017, + typcategory = 'A', + typdelim = ',', + typname = "_point", + typelem = point + } + +array_lseg :: TypeInfo +array_lseg = Array { + typoid = Oid 1018, + typcategory = 'A', + typdelim = ',', + typname = "_lseg", + typelem = lseg + } + +array_path :: TypeInfo +array_path = Array { + typoid = Oid 1019, + typcategory = 'A', + typdelim = ',', + typname = "_path", + typelem = path + } + +array_box :: TypeInfo +array_box = Array { + typoid = Oid 1020, + typcategory = 'A', + typdelim = ';', + typname = "_box", + typelem = box + } + +array_float4 :: TypeInfo +array_float4 = Array { + typoid = Oid 1021, + typcategory = 'A', + typdelim = ',', + typname = "_float4", + typelem = float4 + } + +array_float8 :: TypeInfo +array_float8 = Array { + typoid = Oid 1022, + typcategory = 'A', + typdelim = ',', + typname = "_float8", + typelem = float8 + } + +array_polygon :: TypeInfo +array_polygon = Array { + typoid = Oid 1027, + typcategory = 'A', + typdelim = ',', + typname = "_polygon", + typelem = polygon + } + +array_oid :: TypeInfo +array_oid = Array { + typoid = Oid 1028, + typcategory = 'A', + typdelim = ',', + typname = "_oid", + typelem = oid + } + +array_macaddr :: TypeInfo +array_macaddr = Array { + typoid = Oid 1040, + typcategory = 'A', + typdelim = ',', + typname = "_macaddr", + typelem = macaddr + } + +array_inet :: TypeInfo +array_inet = Array { + typoid = Oid 1041, + typcategory = 'A', + typdelim = ',', + typname = "_inet", + typelem = inet + } + +array_timestamp :: TypeInfo +array_timestamp = Array { + typoid = Oid 1115, + typcategory = 'A', + typdelim = ',', + typname = "_timestamp", + typelem = timestamp + } + +array_date :: TypeInfo +array_date = Array { + typoid = Oid 1182, + typcategory = 'A', + typdelim = ',', + typname = "_date", + typelem = date + } + +array_time :: TypeInfo +array_time = Array { + typoid = Oid 1183, + typcategory = 'A', + typdelim = ',', + typname = "_time", + typelem = time + } + +array_timestamptz :: TypeInfo +array_timestamptz = Array { + typoid = Oid 1185, + typcategory = 'A', + typdelim = ',', + typname = "_timestamptz", + typelem = timestamptz + } + +array_interval :: TypeInfo +array_interval = Array { + typoid = Oid 1187, + typcategory = 'A', + typdelim = ',', + typname = "_interval", + typelem = interval + } + +array_numeric :: TypeInfo +array_numeric = Array { + typoid = Oid 1231, + typcategory = 'A', + typdelim = ',', + typname = "_numeric", + typelem = numeric + } + +array_timetz :: TypeInfo +array_timetz = Array { + typoid = Oid 1270, + typcategory = 'A', + typdelim = ',', + typname = "_timetz", + typelem = timetz + } + +array_bit :: TypeInfo +array_bit = Array { + typoid = Oid 1561, + typcategory = 'A', + typdelim = ',', + typname = "_bit", + typelem = bit + } + +array_varbit :: TypeInfo +array_varbit = Array { + typoid = Oid 1563, + typcategory = 'A', + typdelim = ',', + typname = "_varbit", + typelem = varbit + } + +array_refcursor :: TypeInfo +array_refcursor = Array { + typoid = Oid 2201, + typcategory = 'A', + typdelim = ',', + typname = "_refcursor", + typelem = refcursor + } + +array_regprocedure :: TypeInfo +array_regprocedure = Array { + typoid = Oid 2207, + typcategory = 'A', + typdelim = ',', + typname = "_regprocedure", + typelem = regprocedure + } + +array_regoper :: TypeInfo +array_regoper = Array { + typoid = Oid 2208, + typcategory = 'A', + typdelim = ',', + typname = "_regoper", + typelem = regoper + } + +array_regoperator :: TypeInfo +array_regoperator = Array { + typoid = Oid 2209, + typcategory = 'A', + typdelim = ',', + typname = "_regoperator", + typelem = regoperator + } + +array_regclass :: TypeInfo +array_regclass = Array { + typoid = Oid 2210, + typcategory = 'A', + typdelim = ',', + typname = "_regclass", + typelem = regclass + } + +array_regtype :: TypeInfo +array_regtype = Array { + typoid = Oid 2211, + typcategory = 'A', + typdelim = ',', + typname = "_regtype", + typelem = regtype + } + +array_uuid :: TypeInfo +array_uuid = Array { + typoid = Oid 2951, + typcategory = 'A', + typdelim = ',', + typname = "_uuid", + typelem = uuid + } + +array_jsonb :: TypeInfo +array_jsonb = Array { + typoid = Oid 3807, + typcategory = 'A', + typdelim = ',', + typname = "_jsonb", + typelem = jsonb + } + +int4range :: TypeInfo +int4range = Range { + typoid = Oid 3904, + typcategory = 'R', + typdelim = ',', + typname = "int4range", + rngsubtype = int4 + } + +_int4range :: TypeInfo +_int4range = Array { + typoid = Oid 3905, + typcategory = 'A', + typdelim = ',', + typname = "_int4range", + typelem = int4range + } + +numrange :: TypeInfo +numrange = Range { + typoid = Oid 3906, + typcategory = 'R', + typdelim = ',', + typname = "numrange", + rngsubtype = numeric + } + +_numrange :: TypeInfo +_numrange = Array { + typoid = Oid 3907, + typcategory = 'A', + typdelim = ',', + typname = "_numrange", + typelem = numrange + } + +tsrange :: TypeInfo +tsrange = Range { + typoid = Oid 3908, + typcategory = 'R', + typdelim = ',', + typname = "tsrange", + rngsubtype = timestamp + } + +_tsrange :: TypeInfo +_tsrange = Array { + typoid = Oid 3909, + typcategory = 'A', + typdelim = ',', + typname = "_tsrange", + typelem = tsrange + } + +tstzrange :: TypeInfo +tstzrange = Range { + typoid = Oid 3910, + typcategory = 'R', + typdelim = ',', + typname = "tstzrange", + rngsubtype = timestamptz + } + +_tstzrange :: TypeInfo +_tstzrange = Array { + typoid = Oid 3911, + typcategory = 'A', + typdelim = ',', + typname = "_tstzrange", + typelem = tstzrange + } + +daterange :: TypeInfo +daterange = Range { + typoid = Oid 3912, + typcategory = 'R', + typdelim = ',', + typname = "daterange", + rngsubtype = date + } + +_daterange :: TypeInfo +_daterange = Array { + typoid = Oid 3913, + typcategory = 'A', + typdelim = ',', + typname = "_daterange", + typelem = daterange + } + +int8range :: TypeInfo +int8range = Range { + typoid = Oid 3926, + typcategory = 'R', + typdelim = ',', + typname = "int8range", + rngsubtype = int8 + } + +_int8range :: TypeInfo +_int8range = Array { + typoid = Oid 3927, + typcategory = 'A', + typdelim = ',', + typname = "_int8range", + typelem = int8range } diff --git a/src/Database/PostgreSQL/Simple/Types.hs b/src/Database/PostgreSQL/Simple/Types.hs --- a/src/Database/PostgreSQL/Simple/Types.hs +++ b/src/Database/PostgreSQL/Simple/Types.hs @@ -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 --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -184,6 +184,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