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