@@ -0,0 +1,283 @@
1+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, FlexibleInstances #-}
2+{-# LANGUAGE PatternGuards, ScopedTypeVariables, OverloadedStrings #-}
3+------------------------------------------------------------------------------
5+-- Module: Database.PostgreSQL.Simple.FromField
6+-- Copyright: (c) 2011 MailRank, Inc.
7+-- (c) 2011 Leon P Smith
9+-- Maintainer: Leon P Smith <leon@melding-monads.com>
10+-- Stability: experimental
11+-- Portability: portable
13+-- The 'Result' typeclass, for converting a single value in a row
14+-- returned by a SQL query into a more useful Haskell representation.
16+-- A Haskell numeric type is considered to be compatible with all
17+-- PostgreSQL numeric types that are less accurate than it. For instance,
18+-- the Haskell 'Double' type is compatible with the PostgreSQL's 32-bit
19+-- @Int@ type because it can represent a @Int@ exactly. On the other hand,
20+-- since a 'Double' might lose precision if representing a 64-bit @BigInt@,
21+-- the two are /not/ considered compatible.
23+------------------------------------------------------------------------------
25+module Database.PostgreSQL.Simple.FromField
34+import Control.Applicative (Applicative, (<|>), (<$>), (<*>), (<*), pure)
35+import Control.Exception (SomeException(..), Exception, throw)
36+import Data.Attoparsec.Char8 hiding (Result)
37+import Data.Bits ((.&.), (.|.), shiftL)
38+import Data.ByteString (ByteString)
39+import qualified Data.ByteString.Char8 as B
40+import Data.Int (Int16, Int32, Int64)
41+import Data.List (foldl')
42+import Data.Ratio (Ratio)
43+import Data.Time.Calendar (Day, fromGregorian)
44+import Data.Time.Clock (UTCTime)
45+import Data.Time.Format (parseTime)
46+import Data.Time.LocalTime (TimeOfDay, makeTimeOfDayValid)
47+import Data.Typeable (TypeRep, Typeable, typeOf)
48+import Data.Word (Word64)
49+import Database.PostgreSQL.Simple.Internal
50+import Database.PostgreSQL.Simple.Field (Field(..), RawResult(..))
51+import Database.PostgreSQL.Simple.BuiltinTypes
52+import Database.PostgreSQL.Simple.Ok
53+import Database.PostgreSQL.Simple.Types (Binary(..), Null(..))
54+import qualified Database.PostgreSQL.LibPQ as PQ
55+import System.IO.Unsafe (unsafePerformIO)
56+import System.Locale (defaultTimeLocale)
57+import qualified Data.ByteString as SB
58+import qualified Data.ByteString.Char8 as B8
59+import qualified Data.ByteString.Lazy as LB
60+import qualified Data.Text as ST
61+import qualified Data.Text.Encoding as ST
62+import qualified Data.Text.Encoding.Error (UnicodeException)
63+import qualified Data.Text.Lazy as LT
65+-- | Exception thrown if conversion from a SQL value to a Haskell
67+data ResultError = Incompatible { errSQLType :: String
68+ , errHaskellType :: String
69+ , errMessage :: String }
70+ -- ^ The SQL and Haskell types are not compatible.
71+ | UnexpectedNull { errSQLType :: String
72+ , errHaskellType :: String
73+ , errMessage :: String }
74+ -- ^ A SQL @NULL@ was encountered when the Haskell
75+ -- type did not permit it.
76+ | ConversionFailed { errSQLType :: String
77+ , errHaskellType :: String
78+ , errMessage :: String }
79+ -- ^ The SQL value could not be parsed, or could not
80+ -- be represented as a valid Haskell value, or an
81+ -- unexpected low-level error occurred (e.g. mismatch
82+ -- between metadata and actual data in a row).
83+ deriving (Eq, Show, Typeable)
85+instance Exception ResultError
87+left :: Exception a => a -> Ok b
88+left = Errors . (:[]) . SomeException
90+-- | A type that may be converted from a SQL type.
91+class FromField a where
92+ fromField :: Field -> Maybe ByteString -> Ok a
93+ -- ^ Convert a SQL value to a Haskell value.
95+ -- Returns an exception if the conversion fails. In the case of
96+ -- library instances, this will usually be a 'ResultError', but may
97+ -- be a 'UnicodeException'.
99+instance (FromField a) => FromField (Maybe a) where
100+ fromField _ Nothing = pure Nothing
101+ fromField f bs = Just <$> fromField f bs
103+instance FromField Null where
104+ fromField _ Nothing = pure Null
105+ fromField f (Just _) = returnError ConversionFailed f "data is not null"
107+instance FromField Bool where
109+ | typeOid f /= builtin2oid Bool = returnError Incompatible f ""
110+ | bs == Nothing = returnError UnexpectedNull f ""
111+ | bs == Just "t" = pure True
112+ | bs == Just "f" = pure False
113+ | otherwise = returnError ConversionFailed f ""
115+instance FromField Int16 where
116+ fromField = atto ok16 $ signed decimal
118+instance FromField Int32 where
119+ fromField = atto ok32 $ signed decimal
121+instance FromField Int where
122+ fromField = atto okInt $ signed decimal
124+instance FromField Int64 where
125+ fromField = atto ok64 $ signed decimal
127+instance FromField Integer where
128+ fromField = atto ok64 $ signed decimal
130+instance FromField Float where
131+ fromField = atto ok (realToFrac <$> double)
132+ where ok = mkCompats [Float4,Int2]
134+instance FromField Double where
135+ fromField = atto ok double
136+ where ok = mkCompats [Float4,Float8,Int2,Int4]
138+instance FromField (Ratio Integer) where
139+ fromField = atto ok rational
140+ where ok = mkCompats [Float4,Float8,Int2,Int4,Numeric]
142+unBinary (Binary x) = x
144+instance FromField SB.ByteString where
145+ fromField f dat = if typeOid f == builtin2oid Bytea
146+ then unBinary <$> fromField f dat
147+ else doFromField f okText' (pure . B.copy) dat
149+instance FromField PQ.Oid where
150+ fromField f dat = PQ.Oid <$> atto (mkCompat Oid) decimal f dat
152+instance FromField LB.ByteString where
153+ fromField f dat = LB.fromChunks . (:[]) <$> fromField f dat
155+unescapeBytea :: Field -> SB.ByteString
156+ -> Ok (Binary SB.ByteString)
157+unescapeBytea f str = case unsafePerformIO (PQ.unescapeBytea str) of
158+ Nothing -> returnError ConversionFailed f "unescapeBytea failed"
159+ Just str -> pure (Binary str)
161+instance FromField (Binary SB.ByteString) where
162+ fromField f dat = case format f of
163+ PQ.Text -> doFromField f okBinary (unescapeBytea f) dat
164+ PQ.Binary -> doFromField f okBinary (pure . Binary . B.copy) dat
166+instance FromField (Binary LB.ByteString) where
167+ fromField f dat = Binary . LB.fromChunks . (:[]) . unBinary <$> fromField f dat
169+instance FromField ST.Text where
170+ fromField f = doFromField f okText $ (either left pure . ST.decodeUtf8')
171+ -- FIXME: check character encoding
173+instance FromField LT.Text where
174+ fromField f dat = LT.fromStrict <$> fromField f dat
176+instance FromField [Char] where
177+ fromField f dat = ST.unpack <$> fromField f dat
179+instance FromField UTCTime where
181+ case oid2builtin (typeOid f) of
182+ Just Timestamp -> doIt "%F %T%Q" id
183+ Just TimestampWithTimeZone -> doIt "%F %T%Q%z" (++ "00")
184+ _ -> const $ returnError Incompatible f "types incompatible"
186+ doIt _ _ Nothing = returnError UnexpectedNull f ""
187+ doIt fmt preprocess (Just bs) =
188+ case parseTime defaultTimeLocale fmt str of
190+ Nothing -> returnError ConversionFailed f "could not parse"
191+ where str = preprocess (B8.unpack bs)
193+instance FromField Day where
194+ fromField f = atto ok date f
195+ where ok = mkCompats [Date]
196+ date = fromGregorian <$> (decimal <* char '-')
197+ <*> (decimal <* char '-')
200+instance FromField TimeOfDay where
201+ fromField f = atto' ok time f
202+ where ok = mkCompats [Time]
204+ hours <- decimal <* char ':'
205+ mins <- decimal <* char ':'
206+ secs <- decimal :: Parser Int
207+ case makeTimeOfDayValid hours mins (fromIntegral secs) of
208+ Just t -> return (pure t)
209+ _ -> return (returnError ConversionFailed f "could not parse")
211+instance (FromField a, FromField b) => FromField (Either a b) where
212+ fromField f dat = (Right <$> fromField f dat)
213+ <|> (Left <$> fromField f dat)
215+newtype Compat = Compat Word64
217+mkCompats :: [BuiltinType] -> Compat
218+mkCompats = foldl' f (Compat 0) . map mkCompat
219+ where f (Compat a) (Compat b) = Compat (a .|. b)
221+mkCompat :: BuiltinType -> Compat
222+mkCompat = Compat . shiftL 1 . fromEnum
224+compat :: Compat -> Compat -> Bool
225+compat (Compat a) (Compat b) = a .&. b /= 0
227+okText, okText', ok16, ok32, ok64 :: Compat
228+okText = mkCompats [Name,Text,Char,Bpchar,Varchar]
229+okText' = mkCompats [Name,Text,Char,Bpchar,Varchar,Unknown]
230+okBinary = mkCompats [Bytea]
231+ok16 = mkCompats [Int2]
232+ok32 = mkCompats [Int2,Int4]
233+ok64 = mkCompats [Int2,Int4,Int8]
234+#if WORD_SIZE_IN_BITS < 64
240+doFromField :: forall a . (Typeable a)
241+ => Field -> Compat -> (ByteString -> Ok a)
242+ -> Maybe ByteString -> Ok a
243+doFromField f types cvt (Just bs)
244+ | Just typ <- oid2builtin (typeOid f)
245+ , mkCompat typ `compat` types = cvt bs
246+ | otherwise = returnError Incompatible f "types incompatible"
247+doFromField f _ _ _ = returnError UnexpectedNull f ""
250+-- | Given one of the constructors from 'ResultError', the field,
251+-- and an 'errMessage', this fills in the other fields in the
252+-- exception value and returns it in a 'Left . SomeException'
254+returnError :: forall a err . (Typeable a, Exception err)
255+ => (String -> String -> String -> err)
256+ -> Field -> String -> Ok a
257+returnError mkErr f = left . mkErr (B.unpack (typename f))
258+ (show (typeOf (undefined :: a)))
260+atto :: forall a. (Typeable a)
261+ => Compat -> Parser a -> Field -> Maybe ByteString
263+atto types p0 f dat = doFromField f types (go p0) dat
265+ go :: Parser a -> ByteString -> Ok a
267+ case parseOnly p s of
268+ Left err -> returnError ConversionFailed f err
271+atto' :: forall a. (Typeable a)
272+ => Compat -> Parser (Ok a) -> Field -> Maybe ByteString
274+atto' types p0 f dat = doFromField f types (go p0) dat
276+ go :: Parser (Ok a) -> ByteString -> Ok a
278+ case parseOnly p s of
279+ Left err -> returnError ConversionFailed f err
282+instance FromField RawResult where
283+ fromField field rawData = pure (RawResult field rawData)