@@ -2,6 +2,7 @@
2{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
2{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
3{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}
3{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}
4{-# LANGUAGE RecordWildCards #-}
4{-# LANGUAGE RecordWildCards #-}
5+{-# LANGUAGE PolyKinds #-}
7Module: Database.PostgreSQL.Simple.FromField
8Module: Database.PostgreSQL.Simple.FromField
@@ -106,26 +107,27 @@ module Database.PostgreSQL.Simple.FromField
106 , PQ.Oid(..)
107 , PQ.Oid(..)
107 , PQ.Format(..)
108 , PQ.Format(..)
108 , pgArrayFieldParser
109 , pgArrayFieldParser
110 , optionalField
112 , optionalField
111 , fromJSONField
113 , fromJSONField
114+ , fromFieldJSONByteString
114#include "MachDeps.h"
117#include "MachDeps.h"
116−import Control.Applicative ( (<|>), (<$>), pure, (*>), (<*) )
119+import Control.Applicative ( Const(Const), (<|>), (<$>), pure, (*>), (<*) )
117import Control.Concurrent.MVar (MVar, newMVar)
120import Control.Concurrent.MVar (MVar, newMVar)
118−import Control.Exception (Exception)
121+import Control.Exception (Exception (toException, fromException))
119import qualified Data.Aeson as JSON
122import qualified Data.Aeson as JSON
120−import qualified Data.Aeson.Internal as JSON
121−import qualified Data.Aeson.Parser as JSON (value')
122import Data.Attoparsec.ByteString.Char8 hiding (Result)
123import Data.Attoparsec.ByteString.Char8 hiding (Result)
123import Data.ByteString (ByteString)
124import Data.ByteString (ByteString)
124import qualified Data.ByteString.Char8 as B
125import qualified Data.ByteString.Char8 as B
126+import Data.Functor.Identity (Identity(Identity))
125import Data.Int (Int16, Int32, Int64)
127import Data.Int (Int16, Int32, Int64)
126import Data.IORef (IORef, newIORef)
128import Data.IORef (IORef, newIORef)
127import Data.Ratio (Ratio)
129import Data.Ratio (Ratio)
128−import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )
130+import Data.Time.Compat ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay, CalendarDiffTime )
129import Data.Typeable (Typeable, typeOf)
131import Data.Typeable (Typeable, typeOf)
130import Data.Vector (Vector)
132import Data.Vector (Vector)
131import Data.Vector.Mutable (IOVector)
133import Data.Vector.Mutable (IOVector)
@@ -152,6 +154,8 @@ import qualified Data.UUID.Types as UUID
152import Data.Scientific (Scientific)
154import Data.Scientific (Scientific)
153import GHC.Real (infinity, notANumber)
155import GHC.Real (infinity, notANumber)
157+import qualified Data.Aeson.Types as JSON
155-- | Exception thrown if conversion from a SQL value to a Haskell
159-- | Exception thrown if conversion from a SQL value to a Haskell
156-- value fails.
160-- value fails.
157data ResultError = Incompatible { errSQLType :: String
161data ResultError = Incompatible { errSQLType :: String
@@ -178,7 +182,9 @@ data ResultError = Incompatible { errSQLType :: String
178 -- between metadata and actual data in a row).
182 -- between metadata and actual data in a row).
179 deriving (Eq, Show, Typeable)
183 deriving (Eq, Show, Typeable)
181−instance Exception ResultError
185+instance Exception ResultError where
186+ toException = postgresqlExceptionToException
187+ fromException = postgresqlExceptionFromException
183left :: Exception a => a -> Conversion b
189left :: Exception a => a -> Conversion b
184left = conversionError
190left = conversionError
@@ -244,9 +250,11 @@ tableOid Field{..} = toMaybeOid (unsafeDupablePerformIO (PQ.ftable result column
244 then Nothing
250 then Nothing
245 else Just x
251 else Just x
247−-- | If the column has a table associated with it, this returns the number
253+-- | If the column has a table associated with it, this returns the
248−-- off the associated table column. Numbering starts from 0. Analogous
254+-- number of the associated table column. Table columns have
255+-- nonzero numbers. Zero is returned if the specified column is not
256+-- a simple reference to a table column, or when using pre-3.0
249−-- to libpq's @PQftablecol@.
257+-- protocol. Analogous to libpq's @PQftablecol@.
251tableColumn :: Field -> Int
259tableColumn :: Field -> Int
252tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column))
260tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column))
@@ -265,6 +273,12 @@ instance FromField () where
265 | typeOid f /= TI.voidOid = returnError Incompatible f ""
273 | typeOid f /= TI.voidOid = returnError Incompatible f ""
266 | otherwise = pure ()
274 | otherwise = pure ()
276+instance (FromField a) => FromField (Const a b) where
277+ fromField f bs = Const <$> fromField f bs
279+instance (FromField a) => FromField (Identity a) where
280+ fromField f bs = Identity <$> fromField f bs
268-- | For dealing with null values. Compatible with any postgresql type
282-- | For dealing with null values. Compatible with any postgresql type
269-- compatible with type @a@. Note that the type is not checked if
283-- compatible with type @a@. Note that the type is not checked if
270-- the value is null, although it is inadvisable to rely on this
284-- the value is null, although it is inadvisable to rely on this
@@ -300,9 +314,9 @@ instance FromField Bool where
301-- | \"char\", bpchar
315-- | \"char\", bpchar
302instance FromField Char where
316instance FromField Char where
303− fromField f bs =
317+ fromField f bs0 =
304 if (eq TI.charOid \/ eq TI.bpcharOid) (typeOid f)
318 if (eq TI.charOid \/ eq TI.bpcharOid) (typeOid f)
305− then case bs of
319+ then case bs0 of
306 Nothing -> returnError UnexpectedNull f ""
320 Nothing -> returnError UnexpectedNull f ""
307 Just bs -> if B.length bs /= 1
321 Just bs -> if B.length bs /= 1
308 then returnError ConversionFailed f "length not 1"
322 then returnError ConversionFailed f "length not 1"
@@ -311,11 +325,11 @@ instance FromField Char where
313instance FromField Int16 where
327instance FromField Int16 where
314− fromField = atto ok16 $ signed decimal
328+ fromField = attoFieldParser ok16 $ signed decimal
316-- | int2, int4
330-- | int2, int4
317instance FromField Int32 where
331instance FromField Int32 where
318− fromField = atto ok32 $ signed decimal
332+ fromField = attoFieldParser ok32 $ signed decimal
320#if WORD_SIZE_IN_BITS < 64
334#if WORD_SIZE_IN_BITS < 64
321-- | int2, int4, and if compiled as 64-bit code, int8 as well.
335-- | int2, int4, and if compiled as 64-bit code, int8 as well.
@@ -325,36 +339,36 @@ instance FromField Int32 where
325-- This library was compiled as 64-bit code.
339-- This library was compiled as 64-bit code.
327instance FromField Int where
341instance FromField Int where
328− fromField = atto okInt $ signed decimal
342+ fromField = attoFieldParser okInt $ signed decimal
330-- | int2, int4, int8
344-- | int2, int4, int8
331instance FromField Int64 where
345instance FromField Int64 where
332− fromField = atto ok64 $ signed decimal
346+ fromField = attoFieldParser ok64 $ signed decimal
334-- | int2, int4, int8
348-- | int2, int4, int8
335instance FromField Integer where
349instance FromField Integer where
336− fromField = atto ok64 $ signed decimal
350+ fromField = attoFieldParser ok64 $ signed decimal
338-- | int2, float4 (Uses attoparsec's 'double' routine, for
352-- | int2, float4 (Uses attoparsec's 'double' routine, for
339-- better accuracy convert to 'Scientific' or 'Rational' first)
353-- better accuracy convert to 'Scientific' or 'Rational' first)
340instance FromField Float where
354instance FromField Float where
341− fromField = atto ok (realToFrac <$> pg_double)
355+ fromField = attoFieldParser ok (realToFrac <$> pg_double)
342 where ok = eq TI.float4Oid \/ eq TI.int2Oid
356 where ok = eq TI.float4Oid \/ eq TI.int2Oid
344-- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for
358-- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for
345-- better accuracy convert to 'Scientific' or 'Rational' first)
359-- better accuracy convert to 'Scientific' or 'Rational' first)
346instance FromField Double where
360instance FromField Double where
347− fromField = atto ok pg_double
361+ fromField = attoFieldParser ok pg_double
348 where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid
362 where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid
350-- | int2, int4, int8, float4, float8, numeric
364-- | int2, int4, int8, float4, float8, numeric
351instance FromField (Ratio Integer) where
365instance FromField (Ratio Integer) where
352− fromField = atto ok pg_rational
366+ fromField = attoFieldParser ok pg_rational
353 where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid
367 where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid
355-- | int2, int4, int8, float4, float8, numeric
369-- | int2, int4, int8, float4, float8, numeric
356instance FromField Scientific where
370instance FromField Scientific where
357− fromField = atto ok rational
371+ fromField = attoFieldParser ok rational
358 where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid
372 where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid
360unBinary :: Binary t -> t
374unBinary :: Binary t -> t
@@ -382,7 +396,7 @@ instance FromField SB.ByteString where
384instance FromField PQ.Oid where
398instance FromField PQ.Oid where
385− fromField f dat = PQ.Oid <$> atto (== TI.oidOid) decimal f dat
399+ fromField f dat = PQ.Oid <$> attoFieldParser (== TI.oidOid) decimal f dat
387-- | bytea, name, text, \"char\", bpchar, varchar, unknown
401-- | bytea, name, text, \"char\", bpchar, varchar, unknown
388instance FromField LB.ByteString where
402instance FromField LB.ByteString where
@@ -390,7 +404,7 @@ instance FromField LB.ByteString where
391unescapeBytea :: Field -> SB.ByteString
405unescapeBytea :: Field -> SB.ByteString
392 -> Conversion (Binary SB.ByteString)
406 -> Conversion (Binary SB.ByteString)
393−unescapeBytea f str = case unsafeDupablePerformIO (PQ.unescapeBytea str) of
407+unescapeBytea f str' = case unsafeDupablePerformIO (PQ.unescapeBytea str') of
394 Nothing -> returnError ConversionFailed f "unescapeBytea failed"
408 Nothing -> returnError ConversionFailed f "unescapeBytea failed"
395 Just str -> pure (Binary str)
409 Just str -> pure (Binary str)
@@ -475,14 +489,23 @@ instance FromField LocalTimestamp where
475instance FromField Date where
489instance FromField Date where
476 fromField = ff TI.dateOid "Date" parseDate
490 fromField = ff TI.dateOid "Date" parseDate
492+-- | interval. Requires you to configure intervalstyle as @iso_8601@.
494+-- You can configure intervalstyle on every connection with a @SET@ command,
495+-- but for better performance you may want to configure it permanently in the
496+-- file found with @SHOW config_file;@ .
498+instance FromField CalendarDiffTime where
499+ fromField = ff TI.intervalOid "CalendarDiffTime" parseCalendarDiffTime
478ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)
501ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)
479 -> Field -> Maybe B8.ByteString -> Conversion a
502 -> Field -> Maybe B8.ByteString -> Conversion a
480−ff compatOid hsType parse f mstr =
503+ff compatOid hsType parseBS f mstr =
481 if typeOid f /= compatOid
504 if typeOid f /= compatOid
482 then err Incompatible ""
505 then err Incompatible ""
483 else case mstr of
506 else case mstr of
484 Nothing -> err UnexpectedNull ""
507 Nothing -> err UnexpectedNull ""
485− Just str -> case parse str of
508+ Just str -> case parseBS str of
486 Left msg -> err ConversionFailed msg
509 Left msg -> err ConversionFailed msg
487 Right val -> return val
510 Right val -> return val
@@ -520,10 +543,10 @@ pgArrayFieldParser fieldParser f mdat = do
520 _ -> returnError Incompatible f ""
543 _ -> returnError Incompatible f ""
522fromArray :: FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a])
545fromArray :: FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a])
523−fromArray fieldParser typeInfo f = sequence . (parseIt <$>) <$> array delim
546+fromArray fieldParser typInfo f = sequence . (parseIt <$>) <$> array delim
525− delim = typdelim (typelem typeInfo)
548+ delim = typdelim (typelem typInfo)
526− fElem = f{ typeOid = typoid (typelem typeInfo) }
549+ fElem = f{ typeOid = typoid (typelem typInfo) }
528 parseIt item =
551 parseIt item =
529 fieldParser f' $ if item == Arrays.Plain "NULL" then Nothing else Just item'
552 fieldParser f' $ if item == Arrays.Plain "NULL" then Nothing else Just item'
@@ -552,12 +575,14 @@ instance FromField UUID where
553-- | json, jsonb
576-- | json, jsonb
554instance FromField JSON.Value where
577instance FromField JSON.Value where
555− fromField f mbs = parse =<< fromFieldJSONByteString f mbs
578+ fromField f mbs = parseBS =<< fromFieldJSONByteString f mbs
556− where parse bs = case parseOnly (JSON.value' <* endOfInput) bs of
579+ where parseBS bs = case JSON.eitherDecodeStrict' bs of
557 Left err -> returnError ConversionFailed f err
580 Left err -> returnError ConversionFailed f err
558 Right val -> pure val
581 Right val -> pure val
560-- | Return the JSON ByteString directly
583-- | Return the JSON ByteString directly
561fromFieldJSONByteString :: Field -> Maybe ByteString -> Conversion ByteString
586fromFieldJSONByteString :: Field -> Maybe ByteString -> Conversion ByteString
562fromFieldJSONByteString f mbs =
587fromFieldJSONByteString f mbs =
563 if typeOid f /= TI.jsonOid && typeOid f /= TI.jsonbOid
588 if typeOid f /= TI.jsonOid && typeOid f /= TI.jsonbOid
@@ -659,10 +684,22 @@ returnError mkErr f msg = do
659 (show (typeOf (undefined :: a)))
684 (show (typeOf (undefined :: a)))
687+-- | Construct a field parser from an attoparsec parser. An 'Incompatible' error is thrown if the
688+-- PostgreSQL oid does not match the specified predicate.
691+-- instance FromField Int16 where
692+-- fromField = attoFieldParser ok16 (signed decimal)
662−atto :: forall a. (Typeable a)
696+attoFieldParser :: forall a. (Typeable a)
663− => Compat -> Parser a -> Field -> Maybe ByteString
697+ => (PQ.Oid -> Bool)
664− -> Conversion a
698+ -- ^ Predicate for whether the postgresql type oid is compatible with this parser
700+ -- ^ An attoparsec parser.
665−atto types p0 f dat = doFromField f types (go p0) dat
702+attoFieldParser types p0 f dat = doFromField f types (go p0) dat
667 go :: Parser a -> ByteString -> Conversion a
704 go :: Parser a -> ByteString -> Conversion a