@@ -2,6 +2,7 @@
22{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
33{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}
44{-# LANGUAGE RecordWildCards #-}
5+{-# LANGUAGE PolyKinds #-}
56
67{- |
78Module: Database.PostgreSQL.Simple.FromField
@@ -106,26 +107,27 @@ module Database.PostgreSQL.Simple.FromField
106107 , PQ.Oid(..)
107108 , PQ.Format(..)
108109 , pgArrayFieldParser
110+ , attoFieldParser
109111
110112 , optionalField
111113 , fromJSONField
114+ , fromFieldJSONByteString
112115 ) where
113116
114117#include "MachDeps.h"
115118
116−import Control.Applicative ( (<|>), (<$>), pure, (*>), (<*) )
119+import Control.Applicative ( Const(Const), (<|>), (<$>), pure, (*>), (<*) )
117120import Control.Concurrent.MVar (MVar, newMVar)
118−import Control.Exception (Exception)
121+import Control.Exception (Exception (toException, fromException))
119122import qualified Data.Aeson as JSON
120−import qualified Data.Aeson.Internal as JSON
121−import qualified Data.Aeson.Parser as JSON (value')
122123import Data.Attoparsec.ByteString.Char8 hiding (Result)
123124import Data.ByteString (ByteString)
124125import qualified Data.ByteString.Char8 as B
126+import Data.Functor.Identity (Identity(Identity))
125127import Data.Int (Int16, Int32, Int64)
126128import Data.IORef (IORef, newIORef)
127129import Data.Ratio (Ratio)
128−import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )
130+import Data.Time.Compat ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay, CalendarDiffTime )
129131import Data.Typeable (Typeable, typeOf)
130132import Data.Vector (Vector)
131133import Data.Vector.Mutable (IOVector)
@@ -152,6 +154,8 @@ import qualified Data.UUID.Types as UUID
152154import Data.Scientific (Scientific)
153155import GHC.Real (infinity, notANumber)
154156
157+import qualified Data.Aeson.Types as JSON
158+
155159-- | Exception thrown if conversion from a SQL value to a Haskell
156160-- value fails.
157161data ResultError = Incompatible { errSQLType :: String
@@ -178,7 +182,9 @@ data ResultError = Incompatible { errSQLType :: String
178182 -- between metadata and actual data in a row).
179183 deriving (Eq, Show, Typeable)
180184
181−instance Exception ResultError
185+instance Exception ResultError where
186+ toException = postgresqlExceptionToException
187+ fromException = postgresqlExceptionFromException
182188
183189left :: Exception a => a -> Conversion b
184190left = conversionError
@@ -267,6 +273,12 @@ instance FromField () where
267273 | typeOid f /= TI.voidOid = returnError Incompatible f ""
268274 | otherwise = pure ()
269275
276+instance (FromField a) => FromField (Const a b) where
277+ fromField f bs = Const <$> fromField f bs
278+
279+instance (FromField a) => FromField (Identity a) where
280+ fromField f bs = Identity <$> fromField f bs
281+
270282-- | For dealing with null values. Compatible with any postgresql type
271283-- compatible with type @a@. Note that the type is not checked if
272284-- the value is null, although it is inadvisable to rely on this
@@ -313,11 +325,11 @@ instance FromField Char where
313325
314326-- | int2
315327instance FromField Int16 where
316− fromField = atto ok16 $ signed decimal
328+ fromField = attoFieldParser ok16 $ signed decimal
317329
318330-- | int2, int4
319331instance FromField Int32 where
320− fromField = atto ok32 $ signed decimal
332+ fromField = attoFieldParser ok32 $ signed decimal
321333
322334#if WORD_SIZE_IN_BITS < 64
323335-- | int2, int4, and if compiled as 64-bit code, int8 as well.
@@ -327,36 +339,36 @@ instance FromField Int32 where
327339-- This library was compiled as 64-bit code.
328340#endif
329341instance FromField Int where
330− fromField = atto okInt $ signed decimal
342+ fromField = attoFieldParser okInt $ signed decimal
331343
332344-- | int2, int4, int8
333345instance FromField Int64 where
334− fromField = atto ok64 $ signed decimal
346+ fromField = attoFieldParser ok64 $ signed decimal
335347
336348-- | int2, int4, int8
337349instance FromField Integer where
338− fromField = atto ok64 $ signed decimal
350+ fromField = attoFieldParser ok64 $ signed decimal
339351
340352-- | int2, float4 (Uses attoparsec's 'double' routine, for
341353-- better accuracy convert to 'Scientific' or 'Rational' first)
342354instance FromField Float where
343− fromField = atto ok (realToFrac <$> pg_double)
355+ fromField = attoFieldParser ok (realToFrac <$> pg_double)
344356 where ok = eq TI.float4Oid \/ eq TI.int2Oid
345357
346358-- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for
347359-- better accuracy convert to 'Scientific' or 'Rational' first)
348360instance FromField Double where
349− fromField = atto ok pg_double
361+ fromField = attoFieldParser ok pg_double
350362 where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid
351363
352364-- | int2, int4, int8, float4, float8, numeric
353365instance FromField (Ratio Integer) where
354− fromField = atto ok pg_rational
366+ fromField = attoFieldParser ok pg_rational
355367 where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid
356368
357369-- | int2, int4, int8, float4, float8, numeric
358370instance FromField Scientific where
359− fromField = atto ok rational
371+ fromField = attoFieldParser ok rational
360372 where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid
361373
362374unBinary :: Binary t -> t
@@ -384,7 +396,7 @@ instance FromField SB.ByteString where
384396
385397-- | oid
386398instance FromField PQ.Oid where
387− fromField f dat = PQ.Oid <$> atto (== TI.oidOid) decimal f dat
399+ fromField f dat = PQ.Oid <$> attoFieldParser (== TI.oidOid) decimal f dat
388400
389401-- | bytea, name, text, \"char\", bpchar, varchar, unknown
390402instance FromField LB.ByteString where
@@ -477,6 +489,15 @@ instance FromField LocalTimestamp where
477489instance FromField Date where
478490 fromField = ff TI.dateOid "Date" parseDate
479491
492+-- | interval. Requires you to configure intervalstyle as @iso_8601@.
493+--
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;@ .
497+--
498+instance FromField CalendarDiffTime where
499+ fromField = ff TI.intervalOid "CalendarDiffTime" parseCalendarDiffTime
500+
480501ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)
481502 -> Field -> Maybe B8.ByteString -> Conversion a
482503ff compatOid hsType parseBS f mstr =
@@ -555,11 +576,13 @@ instance FromField UUID where
555576-- | json, jsonb
556577instance FromField JSON.Value where
557578 fromField f mbs = parseBS =<< fromFieldJSONByteString f mbs
558− where parseBS bs = case parseOnly (JSON.value' <* endOfInput) bs of
579+ where parseBS bs = case JSON.eitherDecodeStrict' bs of
559580 Left err -> returnError ConversionFailed f err
560581 Right val -> pure val
561582
562583-- | Return the JSON ByteString directly
584+--
585+-- @since 0.6.3
563586fromFieldJSONByteString :: Field -> Maybe ByteString -> Conversion ByteString
564587fromFieldJSONByteString f mbs =
565588 if typeOid f /= TI.jsonOid && typeOid f /= TI.jsonbOid
@@ -661,10 +684,22 @@ returnError mkErr f msg = do
661684 (show (typeOf (undefined :: a)))
662685 msg
663686
664−atto :: forall a. (Typeable a)
665− => Compat -> Parser a -> Field -> Maybe ByteString
666− -> Conversion a
667−atto types p0 f dat = doFromField f types (go p0) dat
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.
689+--
690+-- @
691+-- instance FromField Int16 where
692+-- fromField = attoFieldParser ok16 (signed decimal)
693+-- @
694+--
695+-- @since 0.6.3
696+attoFieldParser :: forall a. (Typeable a)
697+ => (PQ.Oid -> Bool)
698+ -- ^ Predicate for whether the postgresql type oid is compatible with this parser
699+ -> Parser a
700+ -- ^ An attoparsec parser.
701+ -> FieldParser a
702+attoFieldParser types p0 f dat = doFromField f types (go p0) dat
668703 where
669704 go :: Parser a -> ByteString -> Conversion a
670705 go p s =