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