@@ -0,0 +1,283 @@
1+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, FlexibleInstances #-}
2+{-# LANGUAGE PatternGuards, ScopedTypeVariables, OverloadedStrings #-}
3+------------------------------------------------------------------------------
4+-- |
5+-- Module: Database.PostgreSQL.Simple.FromField
6+-- Copyright: (c) 2011 MailRank, Inc.
7+-- (c) 2011 Leon P Smith
8+-- License: BSD3
9+-- Maintainer: Leon P Smith <leon@melding-monads.com>
10+-- Stability: experimental
11+-- Portability: portable
12+--
13+-- The 'Result' typeclass, for converting a single value in a row
14+-- returned by a SQL query into a more useful Haskell representation.
15+--
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.
22+--
23+------------------------------------------------------------------------------
24+
25+module Database.PostgreSQL.Simple.FromField
26+ (
27+ FromField(..)
28+ , ResultError(..)
29+ , returnError
30+ ) where
31+
32+#include "MachDeps.h"
33+
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
64+
65+-- | Exception thrown if conversion from a SQL value to a Haskell
66+-- value fails.
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)
84+
85+instance Exception ResultError
86+
87+left :: Exception a => a -> Ok b
88+left = Errors . (:[]) . SomeException
89+
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.
94+ --
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'.
98+
99+instance (FromField a) => FromField (Maybe a) where
100+ fromField _ Nothing = pure Nothing
101+ fromField f bs = Just <$> fromField f bs
102+
103+instance FromField Null where
104+ fromField _ Nothing = pure Null
105+ fromField f (Just _) = returnError ConversionFailed f "data is not null"
106+
107+instance FromField Bool where
108+ fromField f bs
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 ""
114+
115+instance FromField Int16 where
116+ fromField = atto ok16 $ signed decimal
117+
118+instance FromField Int32 where
119+ fromField = atto ok32 $ signed decimal
120+
121+instance FromField Int where
122+ fromField = atto okInt $ signed decimal
123+
124+instance FromField Int64 where
125+ fromField = atto ok64 $ signed decimal
126+
127+instance FromField Integer where
128+ fromField = atto ok64 $ signed decimal
129+
130+instance FromField Float where
131+ fromField = atto ok (realToFrac <$> double)
132+ where ok = mkCompats [Float4,Int2]
133+
134+instance FromField Double where
135+ fromField = atto ok double
136+ where ok = mkCompats [Float4,Float8,Int2,Int4]
137+
138+instance FromField (Ratio Integer) where
139+ fromField = atto ok rational
140+ where ok = mkCompats [Float4,Float8,Int2,Int4,Numeric]
141+
142+unBinary (Binary x) = x
143+
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
148+
149+instance FromField PQ.Oid where
150+ fromField f dat = PQ.Oid <$> atto (mkCompat Oid) decimal f dat
151+
152+instance FromField LB.ByteString where
153+ fromField f dat = LB.fromChunks . (:[]) <$> fromField f dat
154+
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)
160+
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
165+
166+instance FromField (Binary LB.ByteString) where
167+ fromField f dat = Binary . LB.fromChunks . (:[]) . unBinary <$> fromField f dat
168+
169+instance FromField ST.Text where
170+ fromField f = doFromField f okText $ (either left pure . ST.decodeUtf8')
171+ -- FIXME: check character encoding
172+
173+instance FromField LT.Text where
174+ fromField f dat = LT.fromStrict <$> fromField f dat
175+
176+instance FromField [Char] where
177+ fromField f dat = ST.unpack <$> fromField f dat
178+
179+instance FromField UTCTime where
180+ fromField f =
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"
185+ where
186+ doIt _ _ Nothing = returnError UnexpectedNull f ""
187+ doIt fmt preprocess (Just bs) =
188+ case parseTime defaultTimeLocale fmt str of
189+ Just t -> pure t
190+ Nothing -> returnError ConversionFailed f "could not parse"
191+ where str = preprocess (B8.unpack bs)
192+
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 '-')
198+ <*> decimal
199+
200+instance FromField TimeOfDay where
201+ fromField f = atto' ok time f
202+ where ok = mkCompats [Time]
203+ time = do
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")
210+
211+instance (FromField a, FromField b) => FromField (Either a b) where
212+ fromField f dat = (Right <$> fromField f dat)
213+ <|> (Left <$> fromField f dat)
214+
215+newtype Compat = Compat Word64
216+
217+mkCompats :: [BuiltinType] -> Compat
218+mkCompats = foldl' f (Compat 0) . map mkCompat
219+ where f (Compat a) (Compat b) = Compat (a .|. b)
220+
221+mkCompat :: BuiltinType -> Compat
222+mkCompat = Compat . shiftL 1 . fromEnum
223+
224+compat :: Compat -> Compat -> Bool
225+compat (Compat a) (Compat b) = a .&. b /= 0
226+
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
235+okInt = ok32
236+#else
237+okInt = ok64
238+#endif
239+
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 ""
248+
249+
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'
253+-- constructor.
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)))
259+
260+atto :: forall a. (Typeable a)
261+ => Compat -> Parser a -> Field -> Maybe ByteString
262+ -> Ok a
263+atto types p0 f dat = doFromField f types (go p0) dat
264+ where
265+ go :: Parser a -> ByteString -> Ok a
266+ go p s =
267+ case parseOnly p s of
268+ Left err -> returnError ConversionFailed f err
269+ Right v -> pure v
270+
271+atto' :: forall a. (Typeable a)
272+ => Compat -> Parser (Ok a) -> Field -> Maybe ByteString
273+ -> Ok a
274+atto' types p0 f dat = doFromField f types (go p0) dat
275+ where
276+ go :: Parser (Ok a) -> ByteString -> Ok a
277+ go p s =
278+ case parseOnly p s of
279+ Left err -> returnError ConversionFailed f err
280+ Right v -> v
281+
282+instance FromField RawResult where
283+ fromField field rawData = pure (RawResult field rawData)