@@ -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
@@ -28,10 +29,10 @@ conversion routine, which sacrifices some accuracy for speed. If you
28need accuracy, consider first converting data to a 'Scientific' or 'Rational'
29need accuracy, consider first converting data to a 'Scientific' or 'Rational'
29type, and then converting to a floating-point type. If you are defining
30type, and then converting to a floating-point type. If you are defining
30your own 'Database.PostgreSQL.Simple.FromRow.FromRow' instances, this can be
31your own 'Database.PostgreSQL.Simple.FromRow.FromRow' instances, this can be
31−acheived simply by
32+achieved simply by
32@'fromRational' '<$>' 'Database.PostgreSQL.Simple.FromRow.field'@, although
33@'fromRational' '<$>' 'Database.PostgreSQL.Simple.FromRow.field'@, although
33−this idiom is additionally compatible with PostgreSQL's @numeric@ type.
34+this idiom is additionally compatible with PostgreSQL's @int8@ and @numeric@
34−If this is unacceptable, you may find
35+types. If this is unacceptable, you may find
35'Database.PostgreSQL.Simple.FromRow.fieldWith' useful.
36'Database.PostgreSQL.Simple.FromRow.fieldWith' useful.
37Also note that while converting to a 'Double' through the 'Scientific' type
38Also note that while converting to a 'Double' through the 'Scientific' type
@@ -105,23 +106,28 @@ module Database.PostgreSQL.Simple.FromField
105 , typeOid
106 , typeOid
106 , PQ.Oid(..)
107 , PQ.Oid(..)
107 , PQ.Format(..)
108 , PQ.Format(..)
109+ , pgArrayFieldParser
109 , fromJSONField
113 , fromJSONField
114+ , fromFieldJSONByteString
112#include "MachDeps.h"
117#include "MachDeps.h"
114−import Control.Applicative ( (<|>), (<$>), pure, (*>) )
119+import Control.Applicative ( Const(Const), (<|>), (<$>), pure, (*>), (<*) )
115import Control.Concurrent.MVar (MVar, newMVar)
120import Control.Concurrent.MVar (MVar, newMVar)
116−import Control.Exception (Exception)
121+import Control.Exception (Exception (toException, fromException))
117import qualified Data.Aeson as JSON
122import qualified Data.Aeson as JSON
118import Data.Attoparsec.ByteString.Char8 hiding (Result)
123import Data.Attoparsec.ByteString.Char8 hiding (Result)
119import Data.ByteString (ByteString)
124import Data.ByteString (ByteString)
120import qualified Data.ByteString.Char8 as B
125import qualified Data.ByteString.Char8 as B
126+import Data.Functor.Identity (Identity(Identity))
121import Data.Int (Int16, Int32, Int64)
127import Data.Int (Int16, Int32, Int64)
122import Data.IORef (IORef, newIORef)
128import Data.IORef (IORef, newIORef)
123import Data.Ratio (Ratio)
129import Data.Ratio (Ratio)
124−import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )
130+import Data.Time.Compat ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay, CalendarDiffTime )
125import Data.Typeable (Typeable, typeOf)
131import Data.Typeable (Typeable, typeOf)
126import Data.Vector (Vector)
132import Data.Vector (Vector)
127import Data.Vector.Mutable (IOVector)
133import Data.Vector.Mutable (IOVector)
@@ -132,7 +138,6 @@ import Database.PostgreSQL.Simple.Ok
132import Database.PostgreSQL.Simple.Types
138import Database.PostgreSQL.Simple.Types
133import Database.PostgreSQL.Simple.TypeInfo as TI
139import Database.PostgreSQL.Simple.TypeInfo as TI
134import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI
140import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI
135−import Database.PostgreSQL.Simple.TypeInfo.Macro as TI
136import Database.PostgreSQL.Simple.Time
141import Database.PostgreSQL.Simple.Time
137import Database.PostgreSQL.Simple.Arrays as Arrays
142import Database.PostgreSQL.Simple.Arrays as Arrays
138import qualified Database.PostgreSQL.LibPQ as PQ
143import qualified Database.PostgreSQL.LibPQ as PQ
@@ -142,11 +147,15 @@ import qualified Data.ByteString.Lazy as LB
142import qualified Data.Text as ST
147import qualified Data.Text as ST
143import qualified Data.Text.Encoding as ST
148import qualified Data.Text.Encoding as ST
144import qualified Data.Text.Lazy as LT
149import qualified Data.Text.Lazy as LT
145−import Data.UUID (UUID)
150+import Data.CaseInsensitive (CI)
151+import qualified Data.CaseInsensitive as CI
152+import Data.UUID.Types (UUID)
146−import qualified Data.UUID as UUID
153+import qualified Data.UUID.Types as UUID
147import Data.Scientific (Scientific)
154import Data.Scientific (Scientific)
148import GHC.Real (infinity, notANumber)
155import GHC.Real (infinity, notANumber)
157+import qualified Data.Aeson.Types as JSON
150-- | Exception thrown if conversion from a SQL value to a Haskell
159-- | Exception thrown if conversion from a SQL value to a Haskell
151-- value fails.
160-- value fails.
152data ResultError = Incompatible { errSQLType :: String
161data ResultError = Incompatible { errSQLType :: String
@@ -173,7 +182,9 @@ data ResultError = Incompatible { errSQLType :: String
173 -- between metadata and actual data in a row).
182 -- between metadata and actual data in a row).
174 deriving (Eq, Show, Typeable)
183 deriving (Eq, Show, Typeable)
176−instance Exception ResultError
185+instance Exception ResultError where
186+ toException = postgresqlExceptionToException
187+ fromException = postgresqlExceptionFromException
178left :: Exception a => a -> Conversion b
189left :: Exception a => a -> Conversion b
179left = conversionError
190left = conversionError
@@ -214,7 +225,7 @@ typename field = typname <$> typeInfo field
215typeInfo :: Field -> Conversion TypeInfo
226typeInfo :: Field -> Conversion TypeInfo
216typeInfo Field{..} = Conversion $ \conn -> do
227typeInfo Field{..} = Conversion $ \conn -> do
217− Ok <$> (getTypeInfo conn =<< PQ.ftype result column)
228+ Ok <$> (getTypeInfo conn typeOid)
219typeInfoByOid :: PQ.Oid -> Conversion TypeInfo
230typeInfoByOid :: PQ.Oid -> Conversion TypeInfo
220typeInfoByOid oid = Conversion $ \conn -> do
231typeInfoByOid oid = Conversion $ \conn -> do
@@ -239,9 +250,11 @@ tableOid Field{..} = toMaybeOid (unsafeDupablePerformIO (PQ.ftable result column
239 then Nothing
250 then Nothing
240 else Just x
251 else Just x
242−-- | 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
243−-- 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
244−-- to libpq's @PQftablecol@.
257+-- protocol. Analogous to libpq's @PQftablecol@.
246tableColumn :: Field -> Int
259tableColumn :: Field -> Int
247tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column))
260tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column))
@@ -257,16 +270,33 @@ format Field{..} = unsafeDupablePerformIO (PQ.fformat result column)
258instance FromField () where
271instance FromField () where
259 fromField f _bs
272 fromField f _bs
260− | typeOid f /= $(inlineTypoid TI.void) = returnError Incompatible f ""
273+ | typeOid f /= TI.voidOid = returnError Incompatible f ""
261 | 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
263-- | For dealing with null values. Compatible with any postgresql type
282-- | For dealing with null values. Compatible with any postgresql type
264-- 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
265-- 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
266-- behavior.
285-- behavior.
267−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 =
268− fromField _ Nothing = pure Nothing
297+ Nothing -> pure Nothing
269− fromField f bs = Just <$> fromField f bs
298+ Just _ -> Just <$> p f mv
299+{-# INLINE optionalField #-}
271-- | compatible with any data type, but the value must be null
301-- | compatible with any data type, but the value must be null
272instance FromField Null where
302instance FromField Null where
@@ -276,30 +306,30 @@ instance FromField Null where
277instance FromField Bool where
307instance FromField Bool where
278 fromField f bs
308 fromField f bs
279− | typeOid f /= $(inlineTypoid TI.bool) = returnError Incompatible f ""
309+ | typeOid f /= TI.boolOid = returnError Incompatible f ""
280 | bs == Nothing = returnError UnexpectedNull f ""
310 | bs == Nothing = returnError UnexpectedNull f ""
281 | bs == Just "t" = pure True
311 | bs == Just "t" = pure True
282 | bs == Just "f" = pure False
312 | bs == Just "f" = pure False
283 | otherwise = returnError ConversionFailed f ""
313 | otherwise = returnError ConversionFailed f ""
285−-- | \"char\"
315+-- | \"char\", bpchar
286instance FromField Char where
316instance FromField Char where
287− fromField f bs =
317+ fromField f bs0 =
288− if typeOid f /= $(inlineTypoid TI.char)
318+ if (eq TI.charOid \/ eq TI.bpcharOid) (typeOid f)
289− then returnError Incompatible f ""
290− else case bs of
319+ then case bs0 of
291 Nothing -> returnError UnexpectedNull f ""
320 Nothing -> returnError UnexpectedNull f ""
292 Just bs -> if B.length bs /= 1
321 Just bs -> if B.length bs /= 1
293 then returnError ConversionFailed f "length not 1"
322 then returnError ConversionFailed f "length not 1"
294 else return $! (B.head bs)
323 else return $! (B.head bs)
324+ else returnError Incompatible f ""
297instance FromField Int16 where
327instance FromField Int16 where
298− fromField = atto ok16 $ signed decimal
328+ fromField = attoFieldParser ok16 $ signed decimal
300-- | int2, int4
330-- | int2, int4
301instance FromField Int32 where
331instance FromField Int32 where
302− fromField = atto ok32 $ signed decimal
332+ fromField = attoFieldParser ok32 $ signed decimal
304#if WORD_SIZE_IN_BITS < 64
334#if WORD_SIZE_IN_BITS < 64
305-- | 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.
@@ -309,37 +339,37 @@ instance FromField Int32 where
309-- This library was compiled as 64-bit code.
339-- This library was compiled as 64-bit code.
311instance FromField Int where
341instance FromField Int where
312− fromField = atto okInt $ signed decimal
342+ fromField = attoFieldParser okInt $ signed decimal
314-- | int2, int4, int8
344-- | int2, int4, int8
315instance FromField Int64 where
345instance FromField Int64 where
316− fromField = atto ok64 $ signed decimal
346+ fromField = attoFieldParser ok64 $ signed decimal
318-- | int2, int4, int8
348-- | int2, int4, int8
319instance FromField Integer where
349instance FromField Integer where
320− fromField = atto ok64 $ signed decimal
350+ fromField = attoFieldParser ok64 $ signed decimal
322-- | int2, float4 (Uses attoparsec's 'double' routine, for
352-- | int2, float4 (Uses attoparsec's 'double' routine, for
323-- better accuracy convert to 'Scientific' or 'Rational' first)
353-- better accuracy convert to 'Scientific' or 'Rational' first)
324instance FromField Float where
354instance FromField Float where
325− fromField = atto ok (realToFrac <$> pg_double)
355+ fromField = attoFieldParser ok (realToFrac <$> pg_double)
326− where ok = $(mkCompats [TI.float4,TI.int2])
356+ where ok = eq TI.float4Oid \/ eq TI.int2Oid
328-- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for
358-- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for
329-- better accuracy convert to 'Scientific' or 'Rational' first)
359-- better accuracy convert to 'Scientific' or 'Rational' first)
330instance FromField Double where
360instance FromField Double where
331− fromField = atto ok pg_double
361+ fromField = attoFieldParser ok pg_double
332− 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
334−-- | int2, int4, float4, float8, numeric
364+-- | int2, int4, int8, float4, float8, numeric
335instance FromField (Ratio Integer) where
365instance FromField (Ratio Integer) where
336− fromField = atto ok pg_rational
366+ fromField = attoFieldParser ok pg_rational
337− 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
339−-- | int2, int4, float4, float8, numeric
369+-- | int2, int4, int8, float4, float8, numeric
340instance FromField Scientific where
370instance FromField Scientific where
341− fromField = atto ok rational
371+ fromField = attoFieldParser ok rational
342− where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.numeric])
372+ where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid
344unBinary :: Binary t -> t
374unBinary :: Binary t -> t
345unBinary (Binary x) = x
375unBinary (Binary x) = x
@@ -360,13 +390,13 @@ pg_rational
361-- | bytea, name, text, \"char\", bpchar, varchar, unknown
391-- | bytea, name, text, \"char\", bpchar, varchar, unknown
362instance FromField SB.ByteString where
392instance FromField SB.ByteString where
363− fromField f dat = if typeOid f == $(inlineTypoid TI.bytea)
393+ fromField f dat = if typeOid f == TI.byteaOid
364 then unBinary <$> fromField f dat
394 then unBinary <$> fromField f dat
365 else doFromField f okText' pure dat
395 else doFromField f okText' pure dat
368instance FromField PQ.Oid where
398instance FromField PQ.Oid where
369− fromField f dat = PQ.Oid <$> atto (== $(inlineTypoid TI.oid)) decimal f dat
399+ fromField f dat = PQ.Oid <$> attoFieldParser (== TI.oidOid) decimal f dat
371-- | bytea, name, text, \"char\", bpchar, varchar, unknown
401-- | bytea, name, text, \"char\", bpchar, varchar, unknown
372instance FromField LB.ByteString where
402instance FromField LB.ByteString where
@@ -374,7 +404,7 @@ instance FromField LB.ByteString where
375unescapeBytea :: Field -> SB.ByteString
405unescapeBytea :: Field -> SB.ByteString
376 -> Conversion (Binary SB.ByteString)
406 -> Conversion (Binary SB.ByteString)
377−unescapeBytea f str = case unsafeDupablePerformIO (PQ.unescapeBytea str) of
407+unescapeBytea f str' = case unsafeDupablePerformIO (PQ.unescapeBytea str') of
378 Nothing -> returnError ConversionFailed f "unescapeBytea failed"
408 Nothing -> returnError ConversionFailed f "unescapeBytea failed"
379 Just str -> pure (Binary str)
409 Just str -> pure (Binary str)
@@ -397,54 +427,85 @@ instance FromField ST.Text where
397instance FromField LT.Text where
427instance FromField LT.Text where
398 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)
400-- | name, text, \"char\", bpchar, varchar
452-- | name, text, \"char\", bpchar, varchar
401instance FromField [Char] where
453instance FromField [Char] where
402 fromField f dat = ST.unpack <$> fromField f dat
454 fromField f dat = ST.unpack <$> fromField f dat
404-- | timestamptz
456-- | timestamptz
405instance FromField UTCTime where
457instance FromField UTCTime where
406− fromField = ff $(inlineTypoid TI.timestamptz) "UTCTime" parseUTCTime
458+ fromField = ff TI.timestamptzOid "UTCTime" parseUTCTime
408-- | timestamptz
460-- | timestamptz
409instance FromField ZonedTime where
461instance FromField ZonedTime where
410− fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTime" parseZonedTime
462+ fromField = ff TI.timestamptzOid "ZonedTime" parseZonedTime
412-- | timestamp
464-- | timestamp
413instance FromField LocalTime where
465instance FromField LocalTime where
414− fromField = ff $(inlineTypoid TI.timestamp) "LocalTime" parseLocalTime
466+ fromField = ff TI.timestampOid "LocalTime" parseLocalTime
417instance FromField Day where
469instance FromField Day where
418− fromField = ff $(inlineTypoid TI.date) "Day" parseDay
470+ fromField = ff TI.dateOid "Day" parseDay
421instance FromField TimeOfDay where
473instance FromField TimeOfDay where
422− fromField = ff $(inlineTypoid TI.time) "TimeOfDay" parseTimeOfDay
474+ fromField = ff TI.timeOid "TimeOfDay" parseTimeOfDay
424-- | timestamptz
476-- | timestamptz
425instance FromField UTCTimestamp where
477instance FromField UTCTimestamp where
426− fromField = ff $(inlineTypoid TI.timestamptz) "UTCTimestamp" parseUTCTimestamp
478+ fromField = ff TI.timestamptzOid "UTCTimestamp" parseUTCTimestamp
428-- | timestamptz
480-- | timestamptz
429instance FromField ZonedTimestamp where
481instance FromField ZonedTimestamp where
430− fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTimestamp" parseZonedTimestamp
482+ fromField = ff TI.timestamptzOid "ZonedTimestamp" parseZonedTimestamp
432-- | timestamp
484-- | timestamp
433instance FromField LocalTimestamp where
485instance FromField LocalTimestamp where
434− fromField = ff $(inlineTypoid TI.timestamp) "LocalTimestamp" parseLocalTimestamp
486+ fromField = ff TI.timestampOid "LocalTimestamp" parseLocalTimestamp
437instance FromField Date where
489instance FromField Date where
438− 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
440ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)
501ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)
441 -> Field -> Maybe B8.ByteString -> Conversion a
502 -> Field -> Maybe B8.ByteString -> Conversion a
442−ff compatOid hsType parse f mstr =
503+ff compatOid hsType parseBS f mstr =
443 if typeOid f /= compatOid
504 if typeOid f /= compatOid
444 then err Incompatible ""
505 then err Incompatible ""
445 else case mstr of
506 else case mstr of
446 Nothing -> err UnexpectedNull ""
507 Nothing -> err UnexpectedNull ""
447− Just str -> case parse str of
508+ Just str -> case parseBS str of
448 Left msg -> err ConversionFailed msg
509 Left msg -> err ConversionFailed msg
449 Right val -> return val
510 Right val -> return val
@@ -466,27 +527,29 @@ instance (FromField a, FromField b) => FromField (Either a b) where
467-- | any postgresql array whose elements are compatible with type @a@
528-- | any postgresql array whose elements are compatible with type @a@
468instance (FromField a, Typeable a) => FromField (PGArray a) where
529instance (FromField a, Typeable a) => FromField (PGArray a) where
469− fromField f mdat = do
530+ fromField = pgArrayFieldParser fromField
532+pgArrayFieldParser :: Typeable a => FieldParser a -> FieldParser (PGArray a)
533+pgArrayFieldParser fieldParser f mdat = do
470 info <- typeInfo f
534 info <- typeInfo f
471 case info of
535 case info of
472 TI.Array{} ->
536 TI.Array{} ->
473 case mdat of
537 case mdat of
474 Nothing -> returnError UnexpectedNull f ""
538 Nothing -> returnError UnexpectedNull f ""
475 Just dat -> do
539 Just dat -> do
476− case parseOnly (fromArray info f) dat of
540+ case parseOnly (fromArray fieldParser info f) dat of
477 Left err -> returnError ConversionFailed f err
541 Left err -> returnError ConversionFailed f err
478 Right conv -> PGArray <$> conv
542 Right conv -> PGArray <$> conv
479 _ -> returnError Incompatible f ""
543 _ -> returnError Incompatible f ""
481−fromArray :: (FromField a)
482− => TypeInfo -> Field -> Parser (Conversion [a])
545+fromArray :: FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a])
483−fromArray typeInfo f = sequence . (parseIt <$>) <$> array delim
546+fromArray fieldParser typInfo f = sequence . (parseIt <$>) <$> array delim
485− delim = typdelim (typelem typeInfo)
548+ delim = typdelim (typelem typInfo)
486− fElem = f{ typeOid = typoid (typelem typeInfo) }
549+ fElem = f{ typeOid = typoid (typelem typInfo) }
488 parseIt item =
551 parseIt item =
489− fromField f' $ if item' == "NULL" then Nothing else Just item'
552+ fieldParser f' $ if item == Arrays.Plain "NULL" then Nothing else Just item'
491 item' = fmt delim item
554 item' = fmt delim item
492 f' | Arrays.Array _ <- item = f
555 f' | Arrays.Array _ <- item = f
@@ -501,7 +564,7 @@ instance (FromField a, Typeable a) => FromField (IOVector a) where
502instance FromField UUID where
565instance FromField UUID where
503 fromField f mbs =
566 fromField f mbs =
504− if typeOid f /= $(inlineTypoid TI.uuid)
567+ if typeOid f /= TI.uuidOid
505 then returnError Incompatible f ""
568 then returnError Incompatible f ""
506 else case mbs of
569 else case mbs of
507 Nothing -> returnError UnexpectedNull f ""
570 Nothing -> returnError UnexpectedNull f ""
@@ -510,26 +573,26 @@ instance FromField UUID where
510 Nothing -> returnError ConversionFailed f "Invalid UUID"
573 Nothing -> returnError ConversionFailed f "Invalid UUID"
511 Just uuid -> pure uuid
574 Just uuid -> pure uuid
513−-- | json
576+-- | json, jsonb
514instance FromField JSON.Value where
577instance FromField JSON.Value where
515− fromField f mbs =
578+ fromField f mbs = parseBS =<< fromFieldJSONByteString f mbs
579+ where parseBS bs = case JSON.eitherDecodeStrict' bs of
580+ Left err -> returnError ConversionFailed f err
581+ Right val -> pure val
583+-- | Return the JSON ByteString directly
586+fromFieldJSONByteString :: Field -> Maybe ByteString -> Conversion ByteString
587+fromFieldJSONByteString f mbs =
516− if typeOid f /= $(inlineTypoid TI.json) && typeOid f /= $(inlineTypoid TI.jsonb)
588+ if typeOid f /= TI.jsonOid && typeOid f /= TI.jsonbOid
517 then returnError Incompatible f ""
589 then returnError Incompatible f ""
518 else case mbs of
590 else case mbs of
519 Nothing -> returnError UnexpectedNull f ""
591 Nothing -> returnError UnexpectedNull f ""
520− Just bs ->
592+ Just bs -> pure bs
521−#if MIN_VERSION_aeson(0,6,3)
522− case JSON.eitherDecodeStrict' bs of
523−#elif MIN_VERSION_bytestring(0,10,0)
524− case JSON.eitherDecode' $ LB.fromStrict bs of
526− case JSON.eitherDecode' $ LB.fromChunks [bs] of
528− Left err -> returnError ConversionFailed f err
529− Right val -> pure val
531-- | 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
532−-- Haskell value using 'JSON.fromJSON'.
595+-- Haskell value using the 'JSON.FromJSON' instance.
534-- This can be used as the default implementation for the 'fromField'
597-- This can be used as the default implementation for the 'fromField'
535-- method for Haskell types that have a JSON representation in
598-- method for Haskell types that have a JSON representation in
@@ -537,14 +600,23 @@ instance FromField JSON.Value where
538-- The 'Typeable' constraint is required to show more informative
601-- The 'Typeable' constraint is required to show more informative
539-- 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@
540fromJSONField :: (JSON.FromJSON a, Typeable a) => FieldParser a
613fromJSONField :: (JSON.FromJSON a, Typeable a) => FieldParser a
541fromJSONField f mbBs = do
614fromJSONField f mbBs = do
542 value <- fromField f mbBs
615 value <- fromField f mbBs
543− case JSON.fromJSON value of
616+ case JSON.ifromJSON value of
544− JSON.Error err -> returnError ConversionFailed f $
617+ JSON.IError path err -> returnError ConversionFailed f $
545− "JSON decoding error: " ++ err
618+ "JSON decoding error: " ++ (JSON.formatError path err)
546− JSON.Success x -> pure x
619+ JSON.ISuccess x -> pure x
549-- | Compatible with the same set of types as @a@. Note that
621-- | Compatible with the same set of types as @a@. Note that
550-- modifying the 'IORef' does not have any effects outside
622-- modifying the 'IORef' does not have any effects outside
@@ -561,20 +633,33 @@ instance FromField a => FromField (MVar a) where
561type Compat = PQ.Oid -> Bool
633type Compat = PQ.Oid -> Bool
563okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat
635okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat
564−okText = $( mkCompats [ TI.name, TI.text, TI.char,
636+okText = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid
565− TI.bpchar, TI.varchar ] )
637+ \/ eq TI.bpcharOid \/ eq TI.varcharOid
566−okText' = $( mkCompats [ TI.name, TI.text, TI.char,
638+okText' = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid
567− TI.bpchar, TI.varchar, TI.unknown ] )
639+ \/ eq TI.bpcharOid \/ eq TI.varcharOid \/ eq TI.unknownOid
568−okBinary = (== $( inlineTypoid TI.bytea ))
640+okBinary = eq TI.byteaOid
569−ok16 = (== $( inlineTypoid TI.int2 ))
641+ok16 = eq TI.int2Oid
570−ok32 = $( mkCompats [TI.int2,TI.int4] )
642+ok32 = eq TI.int2Oid \/ eq TI.int4Oid
571−ok64 = $( mkCompats [TI.int2,TI.int4,TI.int8] )
643+ok64 = eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid
572#if WORD_SIZE_IN_BITS < 64
644#if WORD_SIZE_IN_BITS < 64
573okInt = ok32
645okInt = ok32
575okInt = 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
578doFromField :: forall a . (Typeable a)
663doFromField :: forall a . (Typeable a)
579 => Field -> Compat -> (ByteString -> Conversion a)
664 => Field -> Compat -> (ByteString -> Conversion a)
580 -> Maybe ByteString -> Conversion a
665 -> Maybe ByteString -> Conversion a
@@ -599,10 +684,22 @@ returnError mkErr f msg = do
599 (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)
602−atto :: forall a. (Typeable a)
696+attoFieldParser :: forall a. (Typeable a)
603− => Compat -> Parser a -> Field -> Maybe ByteString
697+ => (PQ.Oid -> Bool)
604− -> Conversion a
698+ -- ^ Predicate for whether the postgresql type oid is compatible with this parser
700+ -- ^ An attoparsec parser.
605−atto types p0 f dat = doFromField f types (go p0) dat
702+attoFieldParser types p0 f dat = doFromField f types (go p0) dat
607 go :: Parser a -> ByteString -> Conversion a
704 go :: Parser a -> ByteString -> Conversion a