@@ -1,7 +1,8 @@
1{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
1{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
2{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
2{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
3{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}
3{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}
4−{-# LANGUAGE RecordWildCards, TemplateHaskell #-}
4+{-# LANGUAGE RecordWildCards #-}
5+{-# LANGUAGE PolyKinds #-}
7Module: Database.PostgreSQL.Simple.FromField
8Module: Database.PostgreSQL.Simple.FromField
@@ -23,6 +24,24 @@ the Haskell 'Double' type is compatible with the PostgreSQL's 32-bit
23since a 'Double' might lose precision if representing PostgreSQL's 64-bit
24since a 'Double' might lose precision if representing PostgreSQL's 64-bit
24@bigint@, the two are /not/ considered compatible.
25@bigint@, the two are /not/ considered compatible.
27+Note that the 'Float' and 'Double' instances use attoparsec's 'double'
28+conversion routine, which sacrifices some accuracy for speed. If you
29+need accuracy, consider first converting data to a 'Scientific' or 'Rational'
30+type, and then converting to a floating-point type. If you are defining
31+your own 'Database.PostgreSQL.Simple.FromRow.FromRow' instances, this can be
33+@'fromRational' '<$>' 'Database.PostgreSQL.Simple.FromRow.field'@, although
34+this idiom is additionally compatible with PostgreSQL's @int8@ and @numeric@
35+types. If this is unacceptable, you may find
36+'Database.PostgreSQL.Simple.FromRow.fieldWith' useful.
38+Also note that while converting to a 'Double' through the 'Scientific' type
39+is likely somewhat faster than converting through the 'Rational' type,
40+the 'Scientific' type has no way to represent @NaN@ and @±Infinity@ values.
41+Thus, if you need precision conversion of regular floating point values
42+and the possibility of receiving these special values from the backend,
43+stick with 'Rational'.
26Because 'FromField' is a typeclass, one may provide conversions to
45Because 'FromField' is a typeclass, one may provide conversions to
27additional Haskell types without modifying postgresql-simple. This is
46additional Haskell types without modifying postgresql-simple. This is
28particularly useful for supporting PostgreSQL types that postgresql-simple
47particularly useful for supporting PostgreSQL types that postgresql-simple
@@ -87,32 +106,38 @@ module Database.PostgreSQL.Simple.FromField
87 , typeOid
106 , typeOid
88 , PQ.Oid(..)
107 , PQ.Oid(..)
89 , PQ.Format(..)
108 , PQ.Format(..)
109+ , pgArrayFieldParser
91 , fromJSONField
113 , fromJSONField
114+ , fromFieldJSONByteString
94#include "MachDeps.h"
117#include "MachDeps.h"
96−import Control.Applicative
119+import Control.Applicative ( Const(Const), (<|>), (<$>), pure, (*>), (<*) )
97− ( Applicative, (<|>), (<$>), pure )
120+import Control.Concurrent.MVar (MVar, newMVar)
98−import Control.Exception (Exception)
121+import Control.Exception (Exception (toException, fromException))
99import qualified Data.Aeson as JSON
122import qualified Data.Aeson as JSON
100−import Data.Attoparsec.Char8 hiding (Result)
123+import Data.Attoparsec.ByteString.Char8 hiding (Result)
101import Data.ByteString (ByteString)
124import Data.ByteString (ByteString)
102import qualified Data.ByteString.Char8 as B
125import qualified Data.ByteString.Char8 as B
126+import Data.Functor.Identity (Identity(Identity))
103import Data.Int (Int16, Int32, Int64)
127import Data.Int (Int16, Int32, Int64)
128+import Data.IORef (IORef, newIORef)
104import Data.Ratio (Ratio)
129import Data.Ratio (Ratio)
105−import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )
130+import Data.Time.Compat ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay, CalendarDiffTime )
106import Data.Typeable (Typeable, typeOf)
131import Data.Typeable (Typeable, typeOf)
107import Data.Vector (Vector)
132import Data.Vector (Vector)
133+import Data.Vector.Mutable (IOVector)
108import qualified Data.Vector as V
134import qualified Data.Vector as V
109import Database.PostgreSQL.Simple.Internal
135import Database.PostgreSQL.Simple.Internal
110import Database.PostgreSQL.Simple.Compat
136import Database.PostgreSQL.Simple.Compat
111import Database.PostgreSQL.Simple.Ok
137import Database.PostgreSQL.Simple.Ok
112−import Database.PostgreSQL.Simple.Types (Binary(..), Null(..))
138+import Database.PostgreSQL.Simple.Types
113import Database.PostgreSQL.Simple.TypeInfo as TI
139import Database.PostgreSQL.Simple.TypeInfo as TI
114import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI
140import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI
115−import Database.PostgreSQL.Simple.TypeInfo.Macro as TI
116import Database.PostgreSQL.Simple.Time
141import Database.PostgreSQL.Simple.Time
117import Database.PostgreSQL.Simple.Arrays as Arrays
142import Database.PostgreSQL.Simple.Arrays as Arrays
118import qualified Database.PostgreSQL.LibPQ as PQ
143import qualified Database.PostgreSQL.LibPQ as PQ
@@ -122,6 +147,14 @@ import qualified Data.ByteString.Lazy as LB
122import qualified Data.Text as ST
147import qualified Data.Text as ST
123import qualified Data.Text.Encoding as ST
148import qualified Data.Text.Encoding as ST
124import qualified Data.Text.Lazy as LT
149import qualified Data.Text.Lazy as LT
150+import Data.CaseInsensitive (CI)
151+import qualified Data.CaseInsensitive as CI
152+import Data.UUID.Types (UUID)
153+import qualified Data.UUID.Types as UUID
154+import Data.Scientific (Scientific)
155+import GHC.Real (infinity, notANumber)
157+import qualified Data.Aeson.Types as JSON
126-- | Exception thrown if conversion from a SQL value to a Haskell
159-- | Exception thrown if conversion from a SQL value to a Haskell
127-- value fails.
160-- value fails.
@@ -149,7 +182,9 @@ data ResultError = Incompatible { errSQLType :: String
149 -- between metadata and actual data in a row).
182 -- between metadata and actual data in a row).
150 deriving (Eq, Show, Typeable)
183 deriving (Eq, Show, Typeable)
152−instance Exception ResultError
185+instance Exception ResultError where
186+ toException = postgresqlExceptionToException
187+ fromException = postgresqlExceptionFromException
154left :: Exception a => a -> Conversion b
189left :: Exception a => a -> Conversion b
155left = conversionError
190left = conversionError
@@ -165,16 +200,15 @@ class FromField a where
165 -- library instances, this will usually be a single 'ResultError', but
200 -- library instances, this will usually be a single 'ResultError', but
166 -- may be a 'UnicodeException'.
201 -- may be a 'UnicodeException'.
168− -- Note that retaining any reference to the 'Field' or 'ByteString'
203+ -- Note that retaining any reference to the 'Field' argument causes
169− -- arguments causes the entire @LibPQ.'PQ.Result'@ to be retained.
204+ -- the entire @LibPQ.'PQ.Result'@ to be retained. Thus, implementations
170− -- Thus, as a rule of thumb, implementations of 'fromField' should
205+ -- of 'fromField' should return results that do not refer to this value
171− -- not refer to these values after the result has been evaluated
206+ -- after the result have been evaluated to WHNF.
172− -- to WHNF. But it can be profitable to break this rule when you
173− -- know it won't cause memory management problems.
175− -- The instances included with postgresql-simple follow this rule
208+ -- Note that as of @postgresql-simple-0.4.0.0@, the 'ByteString' value
176− -- of thumb (modulo bugs). For example, the instance for 'ByteString'
209+ -- has already been copied out of the @LibPQ.'PQ.Result'@ before it has
177− -- uses 'B.copy' to avoid such a reference.
210+ -- been passed to 'fromField'. This is because for short strings, it's
211+ -- cheaper to copy the string than to set up a finalizer.
179-- | Returns the data type name. This is the preferred way of identifying
213-- | Returns the data type name. This is the preferred way of identifying
180-- types that do not have a stable type oid, such as types provided by
214-- types that do not have a stable type oid, such as types provided by
@@ -191,7 +225,7 @@ typename field = typname <$> typeInfo field
192typeInfo :: Field -> Conversion TypeInfo
226typeInfo :: Field -> Conversion TypeInfo
193typeInfo Field{..} = Conversion $ \conn -> do
227typeInfo Field{..} = Conversion $ \conn -> do
194− Ok <$> (getTypeInfo conn =<< PQ.ftype result column)
228+ Ok <$> (getTypeInfo conn typeOid)
196typeInfoByOid :: PQ.Oid -> Conversion TypeInfo
230typeInfoByOid :: PQ.Oid -> Conversion TypeInfo
197typeInfoByOid oid = Conversion $ \conn -> do
231typeInfoByOid oid = Conversion $ \conn -> do
@@ -216,9 +250,11 @@ tableOid Field{..} = toMaybeOid (unsafeDupablePerformIO (PQ.ftable result column
216 then Nothing
250 then Nothing
217 else Just x
251 else Just x
219−-- | 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
220−-- 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
221−-- to libpq's @PQftablecol@.
257+-- protocol. Analogous to libpq's @PQftablecol@.
223tableColumn :: Field -> Int
259tableColumn :: Field -> Int
224tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column))
260tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column))
@@ -234,16 +270,33 @@ format Field{..} = unsafeDupablePerformIO (PQ.fformat result column)
235instance FromField () where
271instance FromField () where
236 fromField f _bs
272 fromField f _bs
237− | typeOid f /= $(inlineTypoid TI.void) = returnError Incompatible f ""
273+ | typeOid f /= TI.voidOid = returnError Incompatible f ""
238 | 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
240-- | For dealing with null values. Compatible with any postgresql type
282-- | For dealing with null values. Compatible with any postgresql type
241-- 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
242-- 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
243-- behavior.
285-- behavior.
244−instance (FromField a) => FromField (Maybe a) where
286+instance FromField a => FromField (Maybe a) where
287+ fromField = optionalField fromField
289+-- | For dealing with SQL @null@ values outside of the 'FromField' class.
290+-- Alternatively, one could use 'Control.Applicative.optional', but that
291+-- also turns type and conversion errors into 'Nothing', whereas this is
292+-- more specific and turns only @null@ values into 'Nothing'.
294+optionalField :: FieldParser a -> FieldParser (Maybe a)
295+optionalField p f mv =
245− fromField _ Nothing = pure Nothing
297+ Nothing -> pure Nothing
246− fromField f bs = Just <$> fromField f bs
298+ Just _ -> Just <$> p f mv
299+{-# INLINE optionalField #-}
248-- | compatible with any data type, but the value must be null
301-- | compatible with any data type, but the value must be null
249instance FromField Null where
302instance FromField Null where
@@ -253,30 +306,30 @@ instance FromField Null where
254instance FromField Bool where
307instance FromField Bool where
255 fromField f bs
308 fromField f bs
256− | typeOid f /= $(inlineTypoid TI.bool) = returnError Incompatible f ""
309+ | typeOid f /= TI.boolOid = returnError Incompatible f ""
257 | bs == Nothing = returnError UnexpectedNull f ""
310 | bs == Nothing = returnError UnexpectedNull f ""
258 | bs == Just "t" = pure True
311 | bs == Just "t" = pure True
259 | bs == Just "f" = pure False
312 | bs == Just "f" = pure False
260 | otherwise = returnError ConversionFailed f ""
313 | otherwise = returnError ConversionFailed f ""
262−-- | \"char\"
315+-- | \"char\", bpchar
263instance FromField Char where
316instance FromField Char where
264− fromField f bs =
317+ fromField f bs0 =
265− if typeOid f /= $(inlineTypoid TI.char)
318+ if (eq TI.charOid \/ eq TI.bpcharOid) (typeOid f)
266− then returnError Incompatible f ""
267− else case bs of
319+ then case bs0 of
268 Nothing -> returnError UnexpectedNull f ""
320 Nothing -> returnError UnexpectedNull f ""
269 Just bs -> if B.length bs /= 1
321 Just bs -> if B.length bs /= 1
270 then returnError ConversionFailed f "length not 1"
322 then returnError ConversionFailed f "length not 1"
271 else return $! (B.head bs)
323 else return $! (B.head bs)
324+ else returnError Incompatible f ""
274instance FromField Int16 where
327instance FromField Int16 where
275− fromField = atto ok16 $ signed decimal
328+ fromField = attoFieldParser ok16 $ signed decimal
277-- | int2, int4
330-- | int2, int4
278instance FromField Int32 where
331instance FromField Int32 where
279− fromField = atto ok32 $ signed decimal
332+ fromField = attoFieldParser ok32 $ signed decimal
281#if WORD_SIZE_IN_BITS < 64
334#if WORD_SIZE_IN_BITS < 64
282-- | 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.
@@ -286,43 +339,64 @@ instance FromField Int32 where
286-- This library was compiled as 64-bit code.
339-- This library was compiled as 64-bit code.
288instance FromField Int where
341instance FromField Int where
289− fromField = atto okInt $ signed decimal
342+ fromField = attoFieldParser okInt $ signed decimal
291-- | int2, int4, int8
344-- | int2, int4, int8
292instance FromField Int64 where
345instance FromField Int64 where
293− fromField = atto ok64 $ signed decimal
346+ fromField = attoFieldParser ok64 $ signed decimal
295-- | int2, int4, int8
348-- | int2, int4, int8
296instance FromField Integer where
349instance FromField Integer where
297− fromField = atto ok64 $ signed decimal
350+ fromField = attoFieldParser ok64 $ signed decimal
299−-- | int2, float4
352+-- | int2, float4 (Uses attoparsec's 'double' routine, for
353+-- better accuracy convert to 'Scientific' or 'Rational' first)
300instance FromField Float where
354instance FromField Float where
301− fromField = atto ok (realToFrac <$> double)
355+ fromField = attoFieldParser ok (realToFrac <$> pg_double)
302− where ok = $(mkCompats [TI.float4,TI.int2])
356+ where ok = eq TI.float4Oid \/ eq TI.int2Oid
304−-- | int2, int4, float4, float8
358+-- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for
359+-- better accuracy convert to 'Scientific' or 'Rational' first)
305instance FromField Double where
360instance FromField Double where
306− fromField = atto ok double
361+ fromField = attoFieldParser ok pg_double
307− where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4])
362+ where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid
309−-- | int2, int4, float4, float8, numeric
364+-- | int2, int4, int8, float4, float8, numeric
310instance FromField (Ratio Integer) where
365instance FromField (Ratio Integer) where
311− fromField = atto ok rational
366+ fromField = attoFieldParser ok pg_rational
312− where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.numeric])
367+ where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid
369+-- | int2, int4, int8, float4, float8, numeric
370+instance FromField Scientific where
371+ fromField = attoFieldParser ok rational
372+ where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid
314unBinary :: Binary t -> t
374unBinary :: Binary t -> t
315unBinary (Binary x) = x
375unBinary (Binary x) = x
377+pg_double :: Parser Double
379+ = (string "NaN" *> pure ( 0 / 0))
380+ <|> (string "Infinity" *> pure ( 1 / 0))
381+ <|> (string "-Infinity" *> pure (-1 / 0))
384+pg_rational :: Parser Rational
386+ = (string "NaN" *> pure notANumber )
387+ <|> (string "Infinity" *> pure infinity )
388+ <|> (string "-Infinity" *> pure (-infinity))
317-- | bytea, name, text, \"char\", bpchar, varchar, unknown
391-- | bytea, name, text, \"char\", bpchar, varchar, unknown
318instance FromField SB.ByteString where
392instance FromField SB.ByteString where
319− fromField f dat = if typeOid f == $(inlineTypoid TI.bytea)
393+ fromField f dat = if typeOid f == TI.byteaOid
320 then unBinary <$> fromField f dat
394 then unBinary <$> fromField f dat
321− else doFromField f okText' (pure . B.copy) dat
395+ else doFromField f okText' pure dat
324instance FromField PQ.Oid where
398instance FromField PQ.Oid where
325− fromField f dat = PQ.Oid <$> atto (== $(inlineTypoid TI.oid)) decimal f dat
399+ fromField f dat = PQ.Oid <$> attoFieldParser (== TI.oidOid) decimal f dat
327-- | bytea, name, text, \"char\", bpchar, varchar, unknown
401-- | bytea, name, text, \"char\", bpchar, varchar, unknown
328instance FromField LB.ByteString where
402instance FromField LB.ByteString where
@@ -330,7 +404,7 @@ instance FromField LB.ByteString where
331unescapeBytea :: Field -> SB.ByteString
405unescapeBytea :: Field -> SB.ByteString
332 -> Conversion (Binary SB.ByteString)
406 -> Conversion (Binary SB.ByteString)
333−unescapeBytea f str = case unsafeDupablePerformIO (PQ.unescapeBytea str) of
407+unescapeBytea f str' = case unsafeDupablePerformIO (PQ.unescapeBytea str') of
334 Nothing -> returnError ConversionFailed f "unescapeBytea failed"
408 Nothing -> returnError ConversionFailed f "unescapeBytea failed"
335 Just str -> pure (Binary str)
409 Just str -> pure (Binary str)
@@ -338,7 +412,7 @@ unescapeBytea f str = case unsafeDupablePerformIO (PQ.unescapeBytea str) of
338instance FromField (Binary SB.ByteString) where
412instance FromField (Binary SB.ByteString) where
339 fromField f dat = case format f of
413 fromField f dat = case format f of
340 PQ.Text -> doFromField f okBinary (unescapeBytea f) dat
414 PQ.Text -> doFromField f okBinary (unescapeBytea f) dat
341− PQ.Binary -> doFromField f okBinary (pure . Binary . B.copy) dat
415+ PQ.Binary -> doFromField f okBinary (pure . Binary) dat
343-- | bytea
417-- | bytea
344instance FromField (Binary LB.ByteString) where
418instance FromField (Binary LB.ByteString) where
@@ -353,54 +427,85 @@ instance FromField ST.Text where
353instance FromField LT.Text where
427instance FromField LT.Text where
354 fromField f dat = LT.fromStrict <$> fromField f dat
428 fromField f dat = LT.fromStrict <$> fromField f dat
431+instance FromField (CI ST.Text) where
432+ fromField f mdat = do
435+ then returnError Incompatible f ""
437+ Nothing -> returnError UnexpectedNull f ""
438+ Just dat -> either left (pure . CI.mk)
439+ (ST.decodeUtf8' dat)
442+instance FromField (CI LT.Text) where
443+ fromField f mdat = do
446+ then returnError Incompatible f ""
448+ Nothing -> returnError UnexpectedNull f ""
449+ Just dat -> either left (pure . CI.mk . LT.fromStrict)
450+ (ST.decodeUtf8' dat)
356-- | name, text, \"char\", bpchar, varchar
452-- | name, text, \"char\", bpchar, varchar
357instance FromField [Char] where
453instance FromField [Char] where
358 fromField f dat = ST.unpack <$> fromField f dat
454 fromField f dat = ST.unpack <$> fromField f dat
360-- | timestamptz
456-- | timestamptz
361instance FromField UTCTime where
457instance FromField UTCTime where
362− fromField = ff $(inlineTypoid TI.timestamptz) "UTCTime" parseUTCTime
458+ fromField = ff TI.timestamptzOid "UTCTime" parseUTCTime
364-- | timestamptz
460-- | timestamptz
365instance FromField ZonedTime where
461instance FromField ZonedTime where
366− fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTime" parseZonedTime
462+ fromField = ff TI.timestamptzOid "ZonedTime" parseZonedTime
368-- | timestamp
464-- | timestamp
369instance FromField LocalTime where
465instance FromField LocalTime where
370− fromField = ff $(inlineTypoid TI.timestamp) "LocalTime" parseLocalTime
466+ fromField = ff TI.timestampOid "LocalTime" parseLocalTime
373instance FromField Day where
469instance FromField Day where
374− fromField = ff $(inlineTypoid TI.date) "Day" parseDay
470+ fromField = ff TI.dateOid "Day" parseDay
377instance FromField TimeOfDay where
473instance FromField TimeOfDay where
378− fromField = ff $(inlineTypoid TI.time) "TimeOfDay" parseTimeOfDay
474+ fromField = ff TI.timeOid "TimeOfDay" parseTimeOfDay
380-- | timestamptz
476-- | timestamptz
381instance FromField UTCTimestamp where
477instance FromField UTCTimestamp where
382− fromField = ff $(inlineTypoid TI.timestamptz) "UTCTimestamp" parseUTCTimestamp
478+ fromField = ff TI.timestamptzOid "UTCTimestamp" parseUTCTimestamp
384-- | timestamptz
480-- | timestamptz
385instance FromField ZonedTimestamp where
481instance FromField ZonedTimestamp where
386− fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTimestamp" parseZonedTimestamp
482+ fromField = ff TI.timestamptzOid "ZonedTimestamp" parseZonedTimestamp
388-- | timestamp
484-- | timestamp
389instance FromField LocalTimestamp where
485instance FromField LocalTimestamp where
390− fromField = ff $(inlineTypoid TI.timestamp) "LocalTimestamp" parseLocalTimestamp
486+ fromField = ff TI.timestampOid "LocalTimestamp" parseLocalTimestamp
393instance FromField Date where
489instance FromField Date where
394− fromField = ff $(inlineTypoid TI.date) "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
396ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)
501ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)
397 -> Field -> Maybe B8.ByteString -> Conversion a
502 -> Field -> Maybe B8.ByteString -> Conversion a
398−ff compatOid hsType parse f mstr =
503+ff compatOid hsType parseBS f mstr =
399 if typeOid f /= compatOid
504 if typeOid f /= compatOid
400 then err Incompatible ""
505 then err Incompatible ""
401 else case mstr of
506 else case mstr of
402 Nothing -> err UnexpectedNull ""
507 Nothing -> err UnexpectedNull ""
403− Just str -> case parse str of
508+ Just str -> case parseBS str of
404 Left msg -> err ConversionFailed msg
509 Left msg -> err ConversionFailed msg
405 Right val -> return val
510 Right val -> return val
@@ -421,43 +526,73 @@ instance (FromField a, FromField b) => FromField (Either a b) where
421 <|> (Left <$> fromField f dat)
526 <|> (Left <$> fromField f dat)
423-- | any postgresql array whose elements are compatible with type @a@
528-- | any postgresql array whose elements are compatible with type @a@
424−instance (FromField a, Typeable a) => FromField (Vector a) where
529+instance (FromField a, Typeable a) => FromField (PGArray a) where
425− fromField f mdat = do
530+ fromField = pgArrayFieldParser fromField
532+pgArrayFieldParser :: Typeable a => FieldParser a -> FieldParser (PGArray a)
533+pgArrayFieldParser fieldParser f mdat = do
426 info <- typeInfo f
534 info <- typeInfo f
427 case info of
535 case info of
428 TI.Array{} ->
536 TI.Array{} ->
429 case mdat of
537 case mdat of
430 Nothing -> returnError UnexpectedNull f ""
538 Nothing -> returnError UnexpectedNull f ""
431 Just dat -> do
539 Just dat -> do
432− case parseOnly (fromArray info f) dat of
540+ case parseOnly (fromArray fieldParser info f) dat of
433 Left err -> returnError ConversionFailed f err
541 Left err -> returnError ConversionFailed f err
434− Right conv -> V.fromList <$> conv
542+ Right conv -> PGArray <$> conv
435 _ -> returnError Incompatible f ""
543 _ -> returnError Incompatible f ""
437−fromArray :: (FromField a)
438− => TypeInfo -> Field -> Parser (Conversion [a])
545+fromArray :: FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a])
439−fromArray typeInfo f = sequence . (parseIt <$>) <$> array delim
546+fromArray fieldParser typInfo f = sequence . (parseIt <$>) <$> array delim
441− delim = typdelim (typelem typeInfo)
548+ delim = typdelim (typelem typInfo)
442− fElem = f{ typeOid = typoid (typelem typeInfo) }
549+ fElem = f{ typeOid = typoid (typelem typInfo) }
443− parseIt item = (fromField f' . Just . fmt delim) item
444− where f' | Arrays.Array _ <- item = f
447−-- | json
551+ parseIt item =
552+ fieldParser f' $ if item == Arrays.Plain "NULL" then Nothing else Just item'
554+ item' = fmt delim item
555+ f' | Arrays.Array _ <- item = f
558+instance (FromField a, Typeable a) => FromField (Vector a) where
559+ fromField f v = V.fromList . fromPGArray <$> fromField f v
561+instance (FromField a, Typeable a) => FromField (IOVector a) where
562+ fromField f v = liftConversion . V.unsafeThaw =<< fromField f v
448−instance FromField JSON.Value where
565+instance FromField UUID where
449 fromField f mbs =
566 fromField f mbs =
450− if typeOid f /= $(inlineTypoid TI.json)
567+ if typeOid f /= TI.uuidOid
451 then returnError Incompatible f ""
568 then returnError Incompatible f ""
452 else case mbs of
569 else case mbs of
453 Nothing -> returnError UnexpectedNull f ""
570 Nothing -> returnError UnexpectedNull f ""
454 Just bs ->
571 Just bs ->
572+ case UUID.fromASCIIBytes bs of
573+ Nothing -> returnError ConversionFailed f "Invalid UUID"
574+ Just uuid -> pure uuid
577+instance FromField JSON.Value where
578+ fromField f mbs = parseBS =<< fromFieldJSONByteString f mbs
455− case JSON.eitherDecodeStrict' bs of
579+ where parseBS bs = case JSON.eitherDecodeStrict' bs of
456 Left err -> returnError ConversionFailed f err
580 Left err -> returnError ConversionFailed f err
457 Right val -> pure val
581 Right val -> pure val
583+-- | Return the JSON ByteString directly
586+fromFieldJSONByteString :: Field -> Maybe ByteString -> Conversion ByteString
587+fromFieldJSONByteString f mbs =
588+ if typeOid f /= TI.jsonOid && typeOid f /= TI.jsonbOid
589+ then returnError Incompatible f ""
591+ Nothing -> returnError UnexpectedNull f ""
459-- | Parse a field to a JSON 'JSON.Value' and convert that into a
594-- | Parse a field to a JSON 'JSON.Value' and convert that into a
460−-- Haskell value using 'JSON.fromJSON'.
595+-- Haskell value using the 'JSON.FromJSON' instance.
462-- This can be used as the default implementation for the 'fromField'
597-- This can be used as the default implementation for the 'fromField'
463-- method for Haskell types that have a JSON representation in
598-- method for Haskell types that have a JSON representation in
@@ -465,31 +600,66 @@ instance FromField JSON.Value where
466-- The 'Typeable' constraint is required to show more informative
601-- The 'Typeable' constraint is required to show more informative
467-- error messages when parsing fails.
602-- error messages when parsing fails.
604+-- Note that @fromJSONField :: FieldParser ('Maybe' Foo)@ will return
605+-- @'Nothing'@ on the json @null@ value, and return an exception on SQL @null@
606+-- value. Alternatively, one could write @'optionalField' fromJSONField@
607+-- that will return @Nothing@ on SQL @null@, and otherwise will call
608+-- @fromJSONField :: FieldParser Foo@ and then return @'Just'@ the
609+-- result value, or return its exception. If one would
610+-- like to return @Nothing@ on both the SQL @null@ and json @null@ values,
611+-- one way to do it would be to write
612+-- @\\f mv -> 'Control.Monad.join' '<$>' optionalField fromJSONField f mv@
468fromJSONField :: (JSON.FromJSON a, Typeable a) => FieldParser a
613fromJSONField :: (JSON.FromJSON a, Typeable a) => FieldParser a
469fromJSONField f mbBs = do
614fromJSONField f mbBs = do
470 value <- fromField f mbBs
615 value <- fromField f mbBs
471− case JSON.fromJSON value of
616+ case JSON.ifromJSON value of
472− JSON.Error err -> returnError ConversionFailed f $
617+ JSON.IError path err -> returnError ConversionFailed f $
473− "JSON decoding error: " ++ err
618+ "JSON decoding error: " ++ (JSON.formatError path err)
474− JSON.Success x -> pure x
619+ JSON.ISuccess x -> pure x
621+-- | Compatible with the same set of types as @a@. Note that
622+-- modifying the 'IORef' does not have any effects outside
623+-- the local process on the local machine.
624+instance FromField a => FromField (IORef a) where
625+ fromField f v = liftConversion . newIORef =<< fromField f v
627+-- | Compatible with the same set of types as @a@. Note that
628+-- modifying the 'MVar' does not have any effects outside
629+-- the local process on the local machine.
630+instance FromField a => FromField (MVar a) where
631+ fromField f v = liftConversion . newMVar =<< fromField f v
476type Compat = PQ.Oid -> Bool
633type Compat = PQ.Oid -> Bool
478okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat
635okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat
479−okText = $( mkCompats [ TI.name, TI.text, TI.char,
636+okText = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid
480− TI.bpchar, TI.varchar ] )
637+ \/ eq TI.bpcharOid \/ eq TI.varcharOid
481−okText' = $( mkCompats [ TI.name, TI.text, TI.char,
638+okText' = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid
482− TI.bpchar, TI.varchar, TI.unknown ] )
639+ \/ eq TI.bpcharOid \/ eq TI.varcharOid \/ eq TI.unknownOid
483−okBinary = (== $( inlineTypoid TI.bytea ))
640+okBinary = eq TI.byteaOid
484−ok16 = (== $( inlineTypoid TI.int2 ))
641+ok16 = eq TI.int2Oid
485−ok32 = $( mkCompats [TI.int2,TI.int4] )
642+ok32 = eq TI.int2Oid \/ eq TI.int4Oid
486−ok64 = $( mkCompats [TI.int2,TI.int4,TI.int8] )
643+ok64 = eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid
487#if WORD_SIZE_IN_BITS < 64
644#if WORD_SIZE_IN_BITS < 64
488okInt = ok32
645okInt = ok32
490okInt = ok64
647okInt = ok64
650+-- | eq and \/ are used to imlement what Macro stuff did,
651+-- i.e. mkCompats and inlineTypoid
652+eq :: PQ.Oid -> PQ.Oid -> Bool
657+(\/) :: (PQ.Oid -> Bool)
660+f \/ g = \x -> f x || g x
493doFromField :: forall a . (Typeable a)
663doFromField :: forall a . (Typeable a)
494 => Field -> Compat -> (ByteString -> Conversion a)
664 => Field -> Compat -> (ByteString -> Conversion a)
495 -> Maybe ByteString -> Conversion a
665 -> Maybe ByteString -> Conversion a
@@ -514,10 +684,22 @@ returnError mkErr f msg = do
514 (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)
517−atto :: forall a. (Typeable a)
696+attoFieldParser :: forall a. (Typeable a)
518− => Compat -> Parser a -> Field -> Maybe ByteString
697+ => (PQ.Oid -> Bool)
519− -> Conversion a
698+ -- ^ Predicate for whether the postgresql type oid is compatible with this parser
700+ -- ^ An attoparsec parser.
520−atto types p0 f dat = doFromField f types (go p0) dat
702+attoFieldParser types p0 f dat = doFromField f types (go p0) dat
522 go :: Parser a -> ByteString -> Conversion a
704 go :: Parser a -> ByteString -> Conversion a