51e1dfc · typeable/postgresql-simple

git.iko.soy/typeable/postgresql-simple

on master help sign in

Switch to FromRow and FromField

51e1dfcLeon P Smith15 years ago

postgresql-simple.cabal+2−2

compare with master

unifiedsplit

@@ -27,8 +27,6 @@ Library

27 Database.PostgreSQL.Simple.Ok

28 Database.PostgreSQL.Simple.Param

29 Database.PostgreSQL.Simple.QueryParams

30− Database.PostgreSQL.Simple.QueryResults

31− Database.PostgreSQL.Simple.Result

32 Database.PostgreSQL.Simple.SqlQQ

30 Database.PostgreSQL.Simple.SqlQQ

33 Database.PostgreSQL.Simple.Types

31 Database.PostgreSQL.Simple.Types

34-- Other-modules:

32-- Other-modules:

@@ -51,6 +49,8 @@ Library

51 transformers,

49 transformers,

52 vector

50 vector

52+ extensions: DoAndIfThenElse, OverloadedStrings, BangPatterns, ViewPatterns

53+

54source-repository head

55 type: git

56 location: http://github.com/lpsmith/postgresql-simple

src/Database/PostgreSQL/Simple.hs+88−52

@@ -1,5 +1,5 @@

1−{-# LANGUAGE BangPatterns, DeriveDataTypeable, OverloadedStrings #-}

2−{-# LANGUAGE DoAndIfThenElse, RecordWildCards, NamedFieldPuns #-}

1+{-# LANGUAGE DeriveDataTypeable, RecordWildCards, NamedFieldPuns #-}

3------------------------------------------------------------------------------

4-- |

5-- Module: Database.PostgreSQL.Simple

@@ -104,30 +104,39 @@ module Database.PostgreSQL.Simple

104 , formatQuery

105 ) where

106

107+import Blaze.ByteString.Builder

107−import Blaze.ByteString.Builder (Builder, fromByteString, toByteString)

108+ ( Builder, fromByteString, toByteString )

108−import Blaze.ByteString.Builder.Char8 (fromChar)

109+import Blaze.ByteString.Builder.Char8 (fromChar)

109−import Control.Applicative ((<$>), pure)

110+import Control.Applicative ((<$>), pure)

110−import Control.Concurrent.MVar

111+import Control.Concurrent.MVar

112+import Control.Exception

111−import Control.Exception (Exception, bracket, onException, throw, throwIO, finally)

113+ ( Exception, bracket, onException, throw, throwIO, finally )

112−import Control.Monad (foldM)

114+import Control.Monad (foldM)

113−import Control.Monad.Fix (fix)

115+import Control.Monad.Fix (fix)

114−import Data.ByteString (ByteString)

116+import Data.ByteString (ByteString)

115−import Data.Char(ord)

117+import Data.Char(ord)

116−import Data.Int (Int64)

118+import Data.Int (Int64)

117import qualified Data.IntMap as IntMap

119import qualified Data.IntMap as IntMap

118−import Data.List (intersperse)

120+import Data.List (intersperse)

119−import Data.Monoid (mappend, mconcat)

121+import Data.Monoid (mappend, mconcat)

120−import Data.Typeable (Typeable)

122+import Data.Typeable (Typeable)

121−import Database.PostgreSQL.Simple.BuiltinTypes (oid2builtin, builtin2typname)

123+import Database.PostgreSQL.Simple.BuiltinTypes

124+ ( oid2builtin, builtin2typname )

125+import Database.PostgreSQL.Simple.FromField (ResultError(..))

126+import Database.PostgreSQL.Simple.FromRow (FromRow(..))

127+import Database.PostgreSQL.Simple.Ok

122−import Database.PostgreSQL.Simple.Param (Action(..), inQuotes)

128+import Database.PostgreSQL.Simple.Param (Action(..), inQuotes)

123−import Database.PostgreSQL.Simple.QueryParams (QueryParams(..))

129+import Database.PostgreSQL.Simple.QueryParams (QueryParams(..))

124−import Database.PostgreSQL.Simple.Result (ResultError(..))

125−import Database.PostgreSQL.Simple.QueryResults (QueryResults(..))

126−import Database.PostgreSQL.Simple.Types (Binary(..), In(..), Only(..), Query(..))

130+import Database.PostgreSQL.Simple.Types

131+ ( Binary(..), In(..), Only(..), Query(..) )

127−import Database.PostgreSQL.Simple.Internal as Base

132+import Database.PostgreSQL.Simple.Internal as Base

128import qualified Database.PostgreSQL.LibPQ as PQ

133import qualified Database.PostgreSQL.LibPQ as PQ

129−import Text.Regex.PCRE.Light (compile, caseless, match)

134+import Text.Regex.PCRE.Light (compile, caseless, match)

130import qualified Data.ByteString.Char8 as B

135import qualified Data.ByteString.Char8 as B

136+import qualified Data.Vector as V

137+import Control.Exception

138+import Control.Monad.Trans.Reader

139+import Control.Monad.Trans.State.Strict

131

140

132-- | Exception thrown if a 'Query' could not be formatted correctly.

141-- | Exception thrown if a 'Query' could not be formatted correctly.

133-- This may occur if the number of \'@?@\' characters in the query

142-- This may occur if the number of \'@?@\' characters in the query

@@ -293,14 +302,14 @@ finishExecute conn q result = do

293-- using 'execute' instead of 'query').

302-- using 'execute' instead of 'query').

294--

303--

295-- * 'ResultError': result conversion failed.

304-- * 'ResultError': result conversion failed.

296−query :: (QueryParams q, QueryResults r)

305+query :: (QueryParams q, FromRow r)

297 => Connection -> Query -> q -> IO [r]

306 => Connection -> Query -> q -> IO [r]

298query conn template qs = do

307query conn template qs = do

299 result <- exec conn =<< formatQuery conn template qs

308 result <- exec conn =<< formatQuery conn template qs

300 finishQuery conn template result

309 finishQuery conn template result

301

310

302-- | A version of 'query' that does not perform query substitution.

311-- | A version of 'query' that does not perform query substitution.

303−query_ :: (QueryResults r) => Connection -> Query -> IO [r]

312+query_ :: (FromRow r) => Connection -> Query -> IO [r]

304query_ conn q@(Query que) = do

313query_ conn q@(Query que) = do

305 result <- exec conn que

314 result <- exec conn que

306 finishQuery conn q result

315 finishQuery conn q result

@@ -324,7 +333,7 @@ query_ conn q@(Query que) = do

324--

333--

325-- * 'ResultError': result conversion failed.

334-- * 'ResultError': result conversion failed.

326

335

327−fold :: ( QueryResults row, QueryParams params )

336+fold :: ( FromRow row, QueryParams params )

328 => Connection

337 => Connection

329 -> Query

338 -> Query

330 -> params

339 -> params

@@ -348,7 +357,7 @@ defaultFoldOptions = FoldOptions {

348 transactionMode = TransactionMode ReadCommitted ReadOnly

357 transactionMode = TransactionMode ReadCommitted ReadOnly

349 }

358 }

350

359

351−foldWithOptions :: ( QueryResults row, QueryParams params )

360+foldWithOptions :: ( FromRow row, QueryParams params )

352 => FoldOptions

361 => FoldOptions

353 -> Connection

362 -> Connection

354 -> Query

363 -> Query

@@ -361,7 +370,7 @@ foldWithOptions opts conn template qs a f = do

361 doFold opts conn template (Query q) a f

370 doFold opts conn template (Query q) a f

362

371

363-- | A version of 'fold' that does not perform query substitution.

372-- | A version of 'fold' that does not perform query substitution.

364−fold_ :: (QueryResults r) =>

373+fold_ :: (FromRow r) =>

365 Connection

374 Connection

366 -> Query -- ^ Query.

375 -> Query -- ^ Query.

367 -> a -- ^ Initial state for result consumer.

376 -> a -- ^ Initial state for result consumer.

@@ -370,7 +379,7 @@ fold_ :: (QueryResults r) =>

370fold_ = foldWithOptions_ defaultFoldOptions

379fold_ = foldWithOptions_ defaultFoldOptions

371

380

372

381

373−foldWithOptions_ :: (QueryResults r) =>

382+foldWithOptions_ :: (FromRow r) =>

374 FoldOptions

383 FoldOptions

375 -> Connection

384 -> Connection

376 -> Query -- ^ Query.

385 -> Query -- ^ Query.

@@ -380,7 +389,7 @@ foldWithOptions_ :: (QueryResults r) =>

380foldWithOptions_ opts conn query a f = doFold opts conn query query a f

389foldWithOptions_ opts conn query a f = doFold opts conn query query a f

381

390

382

391

383−doFold :: ( QueryResults row )

392+doFold :: ( FromRow row )

384 => FoldOptions

393 => FoldOptions

385 -> Connection

394 -> Connection

386 -> Query

395 -> Query

@@ -426,7 +435,7 @@ doFold FoldOptions{..} conn _template q a f = do

426 if null rs then return a else foldM f a rs >>= loop

435 if null rs then return a else foldM f a rs >>= loop

427

436

428-- | A version of 'fold' that does not transform a state value.

437-- | A version of 'fold' that does not transform a state value.

429−forEach :: (QueryParams q, QueryResults r) =>

438+forEach :: (QueryParams q, FromRow r) =>

430 Connection

439 Connection

431 -> Query -- ^ Query template.

440 -> Query -- ^ Query template.

432 -> q -- ^ Query parameters.

441 -> q -- ^ Query parameters.

@@ -436,7 +445,7 @@ forEach conn template qs = fold conn template qs () . const

436{-# INLINE forEach #-}

445{-# INLINE forEach #-}

437

446

438-- | A version of 'forEach' that does not perform query substitution.

447-- | A version of 'forEach' that does not perform query substitution.

439−forEach_ :: (QueryResults r) =>

448+forEach_ :: (FromRow r) =>

440 Connection

449 Connection

441 -> Query -- ^ Query template.

450 -> Query -- ^ Query template.

442 -> (r -> IO ()) -- ^ Result consumer.

451 -> (r -> IO ()) -- ^ Result consumer.

@@ -453,7 +462,7 @@ forM' lo hi m = loop hi []

453 a <- m n

462 a <- m n

454 loop (n-1) (a:as)

463 loop (n-1) (a:as)

455

464

456−finishQuery :: (QueryResults r) => Connection -> Query -> PQ.Result -> IO [r]

465+finishQuery :: (FromRow r) => Connection -> Query -> PQ.Result -> IO [r]

457finishQuery conn q result = do

466finishQuery conn q result = do

458 status <- PQ.resultStatus result

467 status <- PQ.resultStatus result

459 case status of

468 case status of

@@ -461,26 +470,53 @@ finishQuery conn q result = do

461 throwIO $ QueryError "query resulted in a command response" q

470 throwIO $ QueryError "query resulted in a command response" q

462 PQ.TuplesOk -> do

471 PQ.TuplesOk -> do

463 ncols <- PQ.nfields result

472 ncols <- PQ.nfields result

464− fields <- forM' 0 (ncols-1) $ \column -> do

473+ let unCol (PQ.Col x) = fromIntegral x

465− type_oid <- PQ.ftype result column

474+ typenames <- V.generateM (unCol ncols)

475+ (\(PQ.Col . fromIntegral -> col) -> do

466− typename <- getTypename conn type_oid

476+ getTypename conn =<< PQ.ftype result col)

467− return Field{..}

468 nrows <- PQ.ntuples result

477 nrows <- PQ.ntuples result

478+ ncols <- PQ.nfields result

469 forM' 0 (nrows-1) $ \row -> do

479 forM' 0 (nrows-1) $ \row -> do

480+ let rw = Row row typenames result

481+ case runStateT (runReaderT (unRP fromRow) rw) 0 of

482+ Ok (val,col) | col == ncols -> return val

483+ | otherwise -> do

484+ vals <- forM' 0 (ncols-1) $ \c -> do

470− values <- forM' 0 (ncols-1) (\col -> PQ.getvalue result row col)

485+ v <- PQ.getvalue result row c

471− case convertResults fields values of

486+ return ( typenames V.! unCol c

472− Left err -> throwIO err

487+ , fmap ellipsis v )

473− Right a -> return a

488+ throw (ConversionFailed

474− PQ.CopyIn -> fail "FIXME: postgresql-simple does not currently support COPY IN"

489+ (show (unCol ncols) ++ " values: " ++ show vals)

475− PQ.CopyOut -> fail "FIXME: postgresql-simple does not currently support COPY OUT"

490+ (show (unCol col) ++ " slots in target type")

476− _ -> do

491+ "mismatch between number of columns to \

477− errormsg <- maybe "" id <$> PQ.resultErrorMessage result

492+ \convert and number in target type")

478− statusmsg <- PQ.resStatus status

493+ Errors [] -> throwIO $ ConversionFailed "" "" "unknown error"

479− state <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate

494+ Errors [x] -> throwIO x

480− throwIO $ SqlError { sqlState = state

495+ Errors xs -> throwIO $ ManyErrors xs

481− , sqlNativeError = fromEnum status

496+

482− , sqlErrorMsg = B.concat [ "query: ", statusmsg

497+ellipsis :: ByteString -> ByteString

483− , ": ", errormsg ]}

498+ellipsis bs

499+ | B.length bs > 15 = B.take 10 bs `B.append` "[...]"

500+ | otherwise = bs

501+

502+-- | Throw a 'ConversionFailed' exception, indicating a mismatch

503+-- between the number of columns in the 'Field' and row, and the

504+-- number in the collection to be converted to.

505+convertError :: [Field]

506+ -- ^ Descriptors of fields to be converted.

507+ -> [Maybe ByteString]

508+ -- ^ Contents of the row to be converted.

509+ -> Int

510+ -- ^ Number of columns expected for conversion. For

511+ -- instance, if converting to a 3-tuple, the number to

512+ -- provide here would be 3.

513+ -> Either SomeException a

514+convertError fs vs n = Left . SomeException $ ConversionFailed

515+ (show (length fs) ++ " values: " ++ show (zip (map typename fs)

516+ (map (fmap ellipsis) vs)))

517+ (show n ++ " slots in target type")

518+ "mismatch between number of columns to convert and number in target type"

519+

484

520

485-- | Of the four isolation levels defined by the SQL standard,

521-- | Of the four isolation levels defined by the SQL standard,

486-- these are the three levels distinguished by PostgreSQL as of version 9.0.

522-- these are the three levels distinguished by PostgreSQL as of version 9.0.

@@ -759,7 +795,7 @@ fmtError msg q xs = throw FormatError {

759-- $result

795-- $result

760--

796--

761-- The 'query' and 'query_' functions return a list of values in the

797-- The 'query' and 'query_' functions return a list of values in the

762−-- 'QueryResults' typeclass. This class performs automatic extraction

798+-- 'FromRow' typeclass. This class performs automatic extraction

763-- and type conversion of rows from a query result.

799-- and type conversion of rows from a query result.

764--

800--

765-- Here is a simple example of how to extract results:

801-- Here is a simple example of how to extract results:

src/Database/PostgreSQL/Simple/FromRow.hs+41−8

@@ -1,4 +1,20 @@

1−{-# LANGUAGE RecordWildCards, BangPatterns #-}

1+{-# LANGUAGE RecordWildCards #-}

3+------------------------------------------------------------------------------

4+-- |

5+-- Module: Database.PostgreSQL.Simple.FromRow

7+-- License: BSD3

8+-- Maintainer: Leon P Smith <leon@melding-monads.com>

9+-- Stability: experimental

10+-- Portability: portable

11+--

12+-- The 'FromRow' typeclass, for converting a row of results

13+-- returned by a SQL query into a more useful Haskell representation.

14+--

15+-- Predefined instances are provided for tuples containing up to ten

16+-- elements.

17+------------------------------------------------------------------------------

3module Database.PostgreSQL.Simple.FromRow

19module Database.PostgreSQL.Simple.FromRow

4 ( FromRow(..)

20 ( FromRow(..)

@@ -13,7 +29,6 @@ import Control.Monad (replicateM)

13import Data.ByteString (ByteString)

29import Data.ByteString (ByteString)

14import qualified Data.ByteString.Char8 as B

30import qualified Data.ByteString.Char8 as B

15import Database.PostgreSQL.Simple.Internal

31import Database.PostgreSQL.Simple.Internal

16−import Database.PostgreSQL.Simple.Result (ResultError(..), Result(..))

17import Database.PostgreSQL.Simple.Types (Only(..))

32import Database.PostgreSQL.Simple.Types (Only(..))

18import Database.PostgreSQL.Simple.Ok

33import Database.PostgreSQL.Simple.Ok

19import qualified Database.PostgreSQL.LibPQ as PQ

34import qualified Database.PostgreSQL.LibPQ as PQ

@@ -33,21 +48,39 @@ class FromRow a where

34field :: FromField a => RowParser a

49field :: FromField a => RowParser a

35field = RP $ do

50field = RP $ do

51+ let unCol (PQ.Col x) = fromIntegral x

36 Row{..} <- ask

52 Row{..} <- ask

37 column <- lift get

53 column <- lift get

38 lift (put (column + 1))

54 lift (put (column + 1))

55+ let ncols = nfields rowresult

56+ if (column >= ncols)

57+ then do

58+ let vals = map (\c -> ( typenames ! (unCol c)

59+ , fmap ellipsis (getvalue rowresult row c) ))

60+ [0..ncols-1]

61+ convertError = ConversionFailed

62+ (show (unCol ncols) ++ " values: " ++ show vals)

63+ ("at least " ++ show (unCol column + 1)

64+ ++ " slots in target type")

65+ "mismatch between number of columns to \

66+ \convert and number in target type"

67+ lift (lift (Errors [SomeException convertError]))

68+ else do

39− let typename = typenames ! (\(PQ.Col x) -> fromIntegral x) column

69+ let typename = typenames ! unCol column

40− result = rowresult

70+ result = rowresult

41− field = Field{..}

71+ field = Field{..}

42− if (column > nfields rowresult) then lift (lift (Errors [])) else return ()

72+ lift (lift (fromField field (getvalue result row column)))

43− lift (lift (fromField field (getvalue result row column)))

73+

74+ellipsis :: ByteString -> ByteString

75+ellipsis bs

76+ | B.length bs > 15 = B.take 10 bs `B.append` "[...]"

77+ | otherwise = bs

45numFieldsRemaining :: RowParser Int

79numFieldsRemaining :: RowParser Int

46numFieldsRemaining = RP $ do

80numFieldsRemaining = RP $ do

47 Row{..} <- ask

81 Row{..} <- ask

48 column <- lift get

82 column <- lift get

49 return $! (\(PQ.Col x) -> fromIntegral x) (nfields rowresult - column)

83 return $! (\(PQ.Col x) -> fromIntegral x) (nfields rowresult - column)

50−

52instance (FromField a) => FromRow (Only a) where

85instance (FromField a) => FromRow (Only a) where

53 fromRow = do

86 fromRow = do

src/Database/PostgreSQL/Simple/Ok.hs+5

@@ -8,6 +8,11 @@ import Control.Exception

8import Control.Monad(MonadPlus(..))

9import Data.Typeable

11+newtype ManyErrors = ManyErrors [SomeException]

12+ deriving (Show, Typeable)

13+

14+instance Exception ManyErrors

15+

11-- FIXME: [SomeException] should probably be a difference list

16-- FIXME: [SomeException] should probably be a difference list

13data Ok a = Errors [SomeException] | Ok !a

18data Ok a = Errors [SomeException] | Ok !a

src/Database/PostgreSQL/Simple/QueryResults.hsdeleted−245

@@ -1,245 +0,0 @@

1−{-# LANGUAGE BangPatterns, OverloadedStrings #-}

2−

3−------------------------------------------------------------------------------

4−-- |

5−-- Module: Database.PostgreSQL.Simple.QueryResults

8−-- License: BSD3

9−-- Maintainer: Leon P Smith <leon@melding-monads.com>

10−-- Stability: experimental

11−-- Portability: portable

12−--

13−-- The 'QueryResults' typeclass, for converting a row of results

14−-- returned by a SQL query into a more useful Haskell representation.

15−--

16−-- Predefined instances are provided for tuples containing up to ten

17−-- elements.

18−------------------------------------------------------------------------------

19−

20−module Database.PostgreSQL.Simple.QueryResults

21− (

22− QueryResults(..)

23− , convertError

24− ) where

25−

26−import Control.Applicative (Applicative(..), (<$>))

27−import Control.Exception (SomeException(..), throw)

28−import Data.ByteString (ByteString)

29−import qualified Data.ByteString.Char8 as B

30−import Data.Either()

31−import Database.PostgreSQL.Simple.Internal

32−import Database.PostgreSQL.Simple.Result (ResultError(..), Result(..))

33−import Database.PostgreSQL.Simple.Types (Only(..))

34−import qualified Database.PostgreSQL.LibPQ as LibPQ (Result)

35−

36−-- | A collection type that can be converted from a list of strings.

37−--

38−-- Instances should use the 'convert' method of the 'Result' class

39−-- to perform conversion of each element of the collection.

40−--

41−-- This example instance demonstrates how to convert a two-column row

42−-- into a Haskell pair. Each field in the metadata is paired up with

43−-- each value from the row, and the two are passed to 'convert'.

44−--

45−-- @

46−-- instance ('Result' a, 'Result' b) => 'QueryResults' (a,b) where

47−-- 'convertResults' [fa,fb] [va,vb] = do

48−-- !a <- 'convert' fa va

49−-- !b <- 'convert' fb vb

50−-- 'return' (a,b)

51−-- 'convertResults' fs vs = 'convertError' fs vs 2

52−-- @

53−--

54−-- Notice that this instance evaluates each element to WHNF before

55−-- constructing the pair. This property is important enough that its

56−-- a rule all 'QueryResult' instances should follow:

57−--

58−-- * Evaluate every 'Result' value to WHNF before constructing

59−-- the result

60−--

61−-- Doing so keeps resource usage under local control by preventing the

62−-- construction of potentially long-lived thunks that are forced

63−-- (or not) by the consumer.

64−--

65−-- This is important to postgresql-simple-0.0.4 because a wayward thunk

66−-- causes the entire LibPQ.'LibPQ.Result' to be retained. This could lead

67−-- to a memory leak, depending on how the thunk is consumed.

68−--

69−-- Note that instances can be defined outside of postgresql-simple,

70−-- which is often useful. For example, here is an attempt at an

71−-- instance for a user-defined pair:

72−--

73−-- @

74−-- data User = User { firstName :: String, lastName :: String }

75−--

76−-- instance 'QueryResults' User where

77−-- 'convertResults' [fa,qfb] [va,vb] = User \<$\> a \<*\> b

78−-- where !a = 'convert' fa va

79−-- !b = 'convert' fb vb

80−-- 'convertResults' fs vs = 'convertError' fs vs 2

81−-- @

82−--

83−-- In this example, the bang patterns are not used correctly. They force

84−-- the data constructors of the 'Either' type, and are not forcing the

85−-- 'Result' values we need to force. This gives the consumer of the

86−-- 'QueryResult' the ability to cause the memory leak, which is an

87−-- undesirable state of affairs.

88−

89−class QueryResults a where

90− convertResults :: [Field] -> [Maybe ByteString] -> Either SomeException a

91− -- ^ Convert values from a row into a Haskell collection.

92− --

93− -- This function will return a 'ResultError' if conversion of the

94− -- collection fails.

95−

96−instance (Result a) => QueryResults (Only a) where

97− convertResults [fa] [va] = do

98− !a <- convert fa va

99− return (Only a)

100− convertResults fs vs = convertError fs vs 1

101−

102−instance (Result a, Result b) => QueryResults (a,b) where

103− convertResults [fa,fb] [va,vb] = do

104− !a <- convert fa va

105− !b <- convert fb vb

106− return (a,b)

107− convertResults fs vs = convertError fs vs 2

108−

109−instance (Result a, Result b, Result c) => QueryResults (a,b,c) where

110− convertResults [fa,fb,fc] [va,vb,vc] = do

111− !a <- convert fa va

112− !b <- convert fb vb

113− !c <- convert fc vc

114− return (a,b,c)

115− convertResults fs vs = convertError fs vs 3

116−

117−instance (Result a, Result b, Result c, Result d) =>

118− QueryResults (a,b,c,d) where

119− convertResults [fa,fb,fc,fd] [va,vb,vc,vd] = do

120− !a <- convert fa va

121− !b <- convert fb vb

122− !c <- convert fc vc

123− !d <- convert fd vd

124− return (a,b,c,d)

125− convertResults fs vs = convertError fs vs 4

126−

127−instance (Result a, Result b, Result c, Result d, Result e) =>

128− QueryResults (a,b,c,d,e) where

129− convertResults [fa,fb,fc,fd,fe] [va,vb,vc,vd,ve] = do

130− !a <- convert fa va

131− !b <- convert fb vb

132− !c <- convert fc vc

133− !d <- convert fd vd

134− !e <- convert fe ve

135− return (a,b,c,d,e)

136− convertResults fs vs = convertError fs vs 5

137−

138−instance (Result a, Result b, Result c, Result d, Result e, Result f) =>

139− QueryResults (a,b,c,d,e,f) where

140− convertResults [fa,fb,fc,fd,fe,ff] [va,vb,vc,vd,ve,vf] = do

141− !a <- convert fa va

142− !b <- convert fb vb

143− !c <- convert fc vc

144− !d <- convert fd vd

145− !e <- convert fe ve

146− !f <- convert ff vf

147− return (a,b,c,d,e,f)

148− convertResults fs vs = convertError fs vs 6

149−

150−instance (Result a, Result b, Result c, Result d, Result e, Result f,

151− Result g) =>

152− QueryResults (a,b,c,d,e,f,g) where

153− convertResults [fa,fb,fc,fd,fe,ff,fg] [va,vb,vc,vd,ve,vf,vg] = do

154− !a <- convert fa va

155− !b <- convert fb vb

156− !c <- convert fc vc

157− !d <- convert fd vd

158− !e <- convert fe ve

159− !f <- convert ff vf

160− !g <- convert fg vg

161− return (a,b,c,d,e,f,g)

162− convertResults fs vs = convertError fs vs 7

163−

164−instance (Result a, Result b, Result c, Result d, Result e, Result f,

165− Result g, Result h) =>

166− QueryResults (a,b,c,d,e,f,g,h) where

167− convertResults [fa,fb,fc,fd,fe,ff,fg,fh] [va,vb,vc,vd,ve,vf,vg,vh] = do

168− !a <- convert fa va

169− !b <- convert fb vb

170− !c <- convert fc vc

171− !d <- convert fd vd

172− !e <- convert fe ve

173− !f <- convert ff vf

174− !g <- convert fg vg

175− !h <- convert fh vh

176− return (a,b,c,d,e,f,g,h)

177− convertResults fs vs = convertError fs vs 8

178−

179−instance (Result a, Result b, Result c, Result d, Result e, Result f,

180− Result g, Result h, Result i) =>

181− QueryResults (a,b,c,d,e,f,g,h,i) where

182− convertResults [fa,fb,fc,fd,fe,ff,fg,fh,fi] [va,vb,vc,vd,ve,vf,vg,vh,vi] =

183− do

184− !a <- convert fa va

185− !b <- convert fb vb

186− !c <- convert fc vc

187− !d <- convert fd vd

188− !e <- convert fe ve

189− !f <- convert ff vf

190− !g <- convert fg vg

191− !h <- convert fh vh

192− !i <- convert fi vi

193− return (a,b,c,d,e,f,g,h,i)

194− convertResults fs vs = convertError fs vs 9

195−

196−instance (Result a, Result b, Result c, Result d, Result e, Result f,

197− Result g, Result h, Result i, Result j) =>

198− QueryResults (a,b,c,d,e,f,g,h,i,j) where

199− convertResults [fa,fb,fc,fd,fe,ff,fg,fh,fi,fj]

200− [va,vb,vc,vd,ve,vf,vg,vh,vi,vj] =

201− do

202− !a <- convert fa va

203− !b <- convert fb vb

204− !c <- convert fc vc

205− !d <- convert fd vd

206− !e <- convert fe ve

207− !f <- convert ff vf

208− !g <- convert fg vg

209− !h <- convert fh vh

210− !i <- convert fi vi

211− !j <- convert fj vj

212− return (a,b,c,d,e,f,g,h,i,j)

213− convertResults fs vs = convertError fs vs 10

214−

215−f <$!> (!x) = f <$> x

216−infixl 4 <$!>

217−

218−instance Result a => QueryResults [a] where

219− convertResults fs vs = foldr convert' (pure []) (zip fs vs)

220− where convert' (f,v) as = (:) <$!> convert f v <*> as

221− {-# INLINE convertResults #-}

222−

223−-- | Throw a 'ConversionFailed' exception, indicating a mismatch

224−-- between the number of columns in the 'Field' and row, and the

225−-- number in the collection to be converted to.

226−convertError :: [Field]

227− -- ^ Descriptors of fields to be converted.

228− -> [Maybe ByteString]

229− -- ^ Contents of the row to be converted.

230− -> Int

231− -- ^ Number of columns expected for conversion. For

232− -- instance, if converting to a 3-tuple, the number to

233− -- provide here would be 3.

234− -> Either SomeException a

235−convertError fs vs n = Left . SomeException $ ConversionFailed

236− (show (length fs) ++ " values: " ++ show (zip (map typename fs)

237− (map (fmap ellipsis) vs)))

238− (show n ++ " slots in target type")

239− "mismatch between number of columns to convert and number in target type"

240−

241−ellipsis :: ByteString -> ByteString

242−ellipsis bs

243− | B.length bs > 15 = B.take 10 bs `B.append` "[...]"

244− | otherwise = bs

245−

src/Database/PostgreSQL/Simple/Result.hsdeleted−287

@@ -1,287 +0,0 @@

1−{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, FlexibleInstances #-}

2−{-# LANGUAGE PatternGuards, ScopedTypeVariables, OverloadedStrings #-}

3−------------------------------------------------------------------------------

4−-- |

5−-- Module: Database.PostgreSQL.Simple.QueryResults

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)