@@ -1,287 +0,0 @@
1−{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, FlexibleInstances #-}
2−{-# LANGUAGE PatternGuards, ScopedTypeVariables, OverloadedStrings #-}
3−------------------------------------------------------------------------------
4−-- |
5−-- Module: Database.PostgreSQL.Simple.QueryResults
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.Result
26− (
27− Result(..)
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.Types (Binary(..), Null(..))
53−import qualified Database.PostgreSQL.LibPQ as PQ
54−import System.IO.Unsafe (unsafePerformIO)
55−import System.Locale (defaultTimeLocale)
56−import qualified Data.ByteString as SB
57−import qualified Data.ByteString.Char8 as B8
58−import qualified Data.ByteString.Lazy as LB
59−import qualified Data.Text as ST
60−import qualified Data.Text.Encoding as ST
61−import qualified Data.Text.Encoding.Error (UnicodeException)
62−import qualified Data.Text.Lazy as LT
63−
64−-- | Exception thrown if conversion from a SQL value to a Haskell
65−-- value fails.
66−data ResultError = Incompatible { errSQLType :: String
67− , errHaskellType :: String
68− , errMessage :: String }
69− -- ^ The SQL and Haskell types are not compatible.
70− | UnexpectedNull { errSQLType :: String
71− , errHaskellType :: String
72− , errMessage :: String }
73− -- ^ A SQL @NULL@ was encountered when the Haskell
74− -- type did not permit it.
75− | ConversionFailed { errSQLType :: String
76− , errHaskellType :: String
77− , errMessage :: String }
78− -- ^ The SQL value could not be parsed, or could not
79− -- be represented as a valid Haskell value, or an
80− -- unexpected low-level error occurred (e.g. mismatch
81− -- between metadata and actual data in a row).
82− deriving (Eq, Show, Typeable)
83−
84−instance Exception ResultError
85−
86−type Status = Either SomeException
87−
88−left :: Exception a => a -> Status b
89−left = Left . SomeException
90−
91−-- | A type that may be converted from a SQL type.
92−class Result a where
93− convert :: Field -> Maybe ByteString -> Either SomeException a
94− -- ^ Convert a SQL value to a Haskell value.
95− --
96− -- Returns an exception if the conversion fails. In the case of
97− -- library instances, this will usually be a 'ResultError', but may
98− -- be a 'UnicodeException'.
99−
100−instance (Result a) => Result (Maybe a) where
101− convert _ Nothing = pure Nothing
102− convert f bs = Just <$> convert f bs
103−
104−instance Result Null where
105− convert _ Nothing = pure Null
106− convert f (Just _) = returnError ConversionFailed f "data is not null"
107−
108−instance Result Bool where
109− convert f bs
110− | typeOid f /= builtin2oid Bool = returnError Incompatible f ""
111− | bs == Nothing = returnError UnexpectedNull f ""
112− | bs == Just "t" = pure True
113− | bs == Just "f" = pure False
114− | otherwise = returnError ConversionFailed f ""
115−
116−instance Result Int16 where
117− convert = atto ok16 $ signed decimal
118−
119−instance Result Int32 where
120− convert = atto ok32 $ signed decimal
121−
122−instance Result Int where
123− convert = atto okInt $ signed decimal
124−
125−instance Result Int64 where
126− convert = atto ok64 $ signed decimal
127−
128−instance Result Integer where
129− convert = atto ok64 $ signed decimal
130−
131−instance Result Float where
132− convert = atto ok (realToFrac <$> double)
133− where ok = mkCompats [Float4,Int2]
134−
135−instance Result Double where
136− convert = atto ok double
137− where ok = mkCompats [Float4,Float8,Int2,Int4]
138−
139−instance Result (Ratio Integer) where
140− convert = atto ok rational
141− where ok = mkCompats [Float4,Float8,Int2,Int4,Numeric]
142−
143−unBinary (Binary x) = x
144−
145−instance Result SB.ByteString where
146− convert f dat = if typeOid f == builtin2oid Bytea
147− then unBinary <$> convert f dat
148− else doConvert f okText' (pure . B.copy) dat
149−
150−instance Result PQ.Oid where
151− convert f dat = PQ.Oid <$> atto (mkCompat Oid) decimal f dat
152−
153−instance Result LB.ByteString where
154− convert f dat = LB.fromChunks . (:[]) <$> convert f dat
155−
156−unescapeBytea :: Field -> SB.ByteString
157− -> Status (Binary SB.ByteString)
158−unescapeBytea f str = case unsafePerformIO (PQ.unescapeBytea str) of
159− Nothing -> returnError ConversionFailed f "unescapeBytea failed"
160− Just str -> pure (Binary str)
161−
162−instance Result (Binary SB.ByteString) where
163− convert f dat = case format f of
164− PQ.Text -> doConvert f okBinary (unescapeBytea f) dat
165− PQ.Binary -> doConvert f okBinary (pure . Binary . B.copy) dat
166−
167−instance Result (Binary LB.ByteString) where
168− convert f dat = Binary . LB.fromChunks . (:[]) . unBinary <$> convert f dat
169−
170−instance Result ST.Text where
171− convert f = doConvert f okText $ (either left Right . ST.decodeUtf8')
172− -- FIXME: check character encoding
173−
174−instance Result LT.Text where
175− convert f dat = LT.fromStrict <$> convert f dat
176−
177−instance Result [Char] where
178− convert f dat = ST.unpack <$> convert f dat
179−
180−instance Result UTCTime where
181− convert f =
182− case oid2builtin (typeOid f) of
183− Just Timestamp -> doIt "%F %T%Q" id
184− Just TimestampWithTimeZone -> doIt "%F %T%Q%z" (++ "00")
185− _ -> const $ returnError Incompatible f "types incompatible"
186− where
187− doIt _ _ Nothing = returnError UnexpectedNull f ""
188− doIt fmt preprocess (Just bs) =
189− case parseTime defaultTimeLocale fmt str of
190− Just t -> Right t
191− Nothing -> returnError ConversionFailed f "could not parse"
192− where str = preprocess (B8.unpack bs)
193−
194−instance Result Day where
195− convert f = atto ok date f
196− where ok = mkCompats [Date]
197− date = fromGregorian <$> (decimal <* char '-')
198− <*> (decimal <* char '-')
199− <*> decimal
200−
201−instance Result TimeOfDay where
202− convert f = atto' ok time f
203− where ok = mkCompats [Time]
204− time = do
205− hours <- decimal <* char ':'
206− mins <- decimal <* char ':'
207− secs <- decimal :: Parser Int
208− case makeTimeOfDayValid hours mins (fromIntegral secs) of
209− Just t -> return (pure t)
210− _ -> return (returnError ConversionFailed f "could not parse")
211−
212−instance (Result a, Result b) => Result (Either a b) where
213− convert f dat = case convert f dat of
214− Right x -> Right (Right x)
215− Left _ -> case convert f dat of
216− Right x -> Right (Left x)
217− Left e -> Left e
218−
219−newtype Compat = Compat Word64
220−
221−mkCompats :: [BuiltinType] -> Compat
222−mkCompats = foldl' f (Compat 0) . map mkCompat
223− where f (Compat a) (Compat b) = Compat (a .|. b)
224−
225−mkCompat :: BuiltinType -> Compat
226−mkCompat = Compat . shiftL 1 . fromEnum
227−
228−compat :: Compat -> Compat -> Bool
229−compat (Compat a) (Compat b) = a .&. b /= 0
230−
231−okText, okText', ok16, ok32, ok64 :: Compat
232−okText = mkCompats [Name,Text,Char,Bpchar,Varchar]
233−okText' = mkCompats [Name,Text,Char,Bpchar,Varchar,Unknown]
234−okBinary = mkCompats [Bytea]
235−ok16 = mkCompats [Int2]
236−ok32 = mkCompats [Int2,Int4]
237−ok64 = mkCompats [Int2,Int4,Int8]
238−#if WORD_SIZE_IN_BITS < 64
239−okInt = ok32
240−#else
241−okInt = ok64
242−#endif
243−
244−doConvert :: forall a . (Typeable a)
245− => Field -> Compat -> (ByteString -> Status a)
246− -> Maybe ByteString -> Status a
247−doConvert f types cvt (Just bs)
248− | Just typ <- oid2builtin (typeOid f)
249− , mkCompat typ `compat` types = cvt bs
250− | otherwise = returnError Incompatible f "types incompatible"
251−doConvert f _ _ _ = returnError UnexpectedNull f ""
252−
253−
254−-- | Given one of the constructors from 'ResultError', the field,
255−-- and an 'errMessage', this fills in the other fields in the
256−-- exception value and returns it in a 'Left . SomeException'
257−-- constructor.
258−returnError :: forall a err . (Typeable a, Exception err)
259− => (String -> String -> String -> err)
260− -> Field -> String -> Either SomeException a
261−returnError mkErr f = left . mkErr (B.unpack (typename f))
262− (show (typeOf (undefined :: a)))
263−
264−atto :: forall a. (Typeable a)
265− => Compat -> Parser a -> Field -> Maybe ByteString
266− -> Status a
267−atto types p0 f dat = doConvert f types (go p0) dat
268− where
269− go :: Parser a -> ByteString -> Status a
270− go p s =
271− case parseOnly p s of
272− Left err -> returnError ConversionFailed f err
273− Right v -> Right v
274−
275−atto' :: forall a. (Typeable a)
276− => Compat -> Parser (Status a) -> Field -> Maybe ByteString
277− -> Status a
278−atto' types p0 f dat = doConvert f types (go p0) dat
279− where
280− go :: Parser (Status a) -> ByteString -> Status a
281− go p s =
282− case parseOnly p s of
283− Left err -> returnError ConversionFailed f err
284− Right v -> v
285−
286−instance Result RawResult where
287− convert field rawData = Right (RawResult field rawData)