Skip to content

Commit affe03e

Browse files
zohlzohl
committed
Added generic ToField and FromField classes
1 parent a8f6a90 commit affe03e

File tree

7 files changed

+228
-70
lines changed

7 files changed

+228
-70
lines changed

‎src/Database/PostgreSQL/Simple/FromField.hs‎

Lines changed: 125 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,8 @@
22
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
33
{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}
44
{-# LANGUAGE RecordWildCards, TemplateHaskell #-}
5+
{-# LANGUAGE MultiWayIf, DefaultSignatures #-}
6+
{-# LANGUAGE FlexibleContexts #-}
57

68
{- |
79
Module: Database.PostgreSQL.Simple.FromField
@@ -83,6 +85,7 @@ instances use 'typename' instead.
8385
module Database.PostgreSQL.Simple.FromField
8486
(
8587
FromField(..)
88+
, genericFromField
8689
, FieldParser
8790
, Conversion()
8891

@@ -113,16 +116,19 @@ module Database.PostgreSQL.Simple.FromField
113116

114117
#include "MachDeps.h"
115118

116-
import Control.Applicative ( (<|>), (<$>), pure, (*>), (<*) )
119+
import Control.Applicative ( Alternative(..), (<|>), (<$>), pure, (*>), (<*), liftA2 )
117120
import Control.Concurrent.MVar (MVar, newMVar)
118121
import Control.Exception (Exception)
119122
import qualified Data.Aeson as JSON
120123
import qualified Data.Aeson.Parser as JSON (value')
121124
import Data.Attoparsec.ByteString.Char8 hiding (Result)
122125
import Data.ByteString (ByteString)
126+
import Data.ByteString.Builder (Builder, toLazyByteString, byteString)
123127
import qualified Data.ByteString.Char8 as B
128+
import Data.Char (toLower)
124129
import Data.Int (Int16, Int32, Int64)
125130
import Data.IORef (IORef, newIORef)
131+
import Data.Proxy (Proxy(..))
126132
import Data.Ratio (Ratio)
127133
import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )
128134
import Data.Typeable (Typeable, typeOf)
@@ -150,6 +156,7 @@ import qualified Data.CaseInsensitive as CI
150156
import Data.UUID.Types (UUID)
151157
import qualified Data.UUID.Types as UUID
152158
import Data.Scientific (Scientific)
159+
import GHC.Generics (Generic, Rep, M1(..), K1(..), D1, C1, S1, Rec0, Constructor, (:*:)(..), to, conName)
153160
import GHC.Real (infinity, notANumber)
154161

155162
-- | Exception thrown if conversion from a SQL value to a Haskell
@@ -188,6 +195,8 @@ type FieldParser a = Field -> Maybe ByteString -> Conversion a
188195
-- | A type that may be converted from a SQL type.
189196
class FromField a where
190197
fromField :: FieldParser a
198+
default fromField :: (Generic a, Typeable a, GFromField (Rep a)) => FieldParser a
199+
fromField = genericFromField (map toLower)
191200
-- ^ Convert a SQL value to a Haskell value.
192201
--
193202
-- Returns a list of exceptions if the conversion fails. In the case of
@@ -214,17 +223,18 @@ class FromField a where
214223
-- postgresql-simple will check a per-connection cache, and then
215224
-- finally query the database's meta-schema.
216225

217-
typename :: Field -> Conversion ByteString
218-
typename field = typname <$> typeInfo field
226+
typename :: Field -> Conversion (Maybe ByteString)
227+
typename field = fmap typname <$> typeInfo field
219228

220-
typeInfo :: Field -> Conversion TypeInfo
229+
typeInfo :: Field -> Conversion (Maybe TypeInfo)
221230
typeInfo Field{..} = Conversion $ \conn -> do
222-
Ok <$> (getTypeInfo conn typeOid)
231+
Ok <$> (maybe (return Nothing) (fmap Just . getTypeInfo conn) typeOid)
223232

224233
typeInfoByOid :: PQ.Oid -> Conversion TypeInfo
225234
typeInfoByOid oid = Conversion $ \conn -> do
226235
Ok <$> (getTypeInfo conn oid)
227236

237+
228238
-- | Returns the name of the column. This is often determined by a table
229239
-- definition, but it can be set using an @as@ clause.
230240

@@ -262,7 +272,7 @@ format Field{..} = unsafeDupablePerformIO (PQ.fformat result column)
262272
-- | void
263273
instance FromField () where
264274
fromField f _bs
265-
| typeOid f /= $(inlineTypoid TI.void) = returnError Incompatible f ""
275+
| maybe False (/= $(inlineTypoid TI.void)) (typeOid f) = returnError Incompatible f ""
266276
| otherwise = pure ()
267277

268278
-- | For dealing with null values. Compatible with any postgresql type
@@ -292,7 +302,7 @@ instance FromField Null where
292302
-- | bool
293303
instance FromField Bool where
294304
fromField f bs
295-
| typeOid f /= $(inlineTypoid TI.bool) = returnError Incompatible f ""
305+
| maybe False (/= $(inlineTypoid TI.bool)) (typeOid f) = returnError Incompatible f ""
296306
| bs == Nothing = returnError UnexpectedNull f ""
297307
| bs == Just "t" = pure True
298308
| bs == Just "f" = pure False
@@ -301,7 +311,7 @@ instance FromField Bool where
301311
-- | \"char\"
302312
instance FromField Char where
303313
fromField f bs =
304-
if typeOid f /= $(inlineTypoid TI.char)
314+
if maybe False (/= $(inlineTypoid TI.char)) (typeOid f)
305315
then returnError Incompatible f ""
306316
else case bs of
307317
Nothing -> returnError UnexpectedNull f ""
@@ -376,7 +386,7 @@ pg_rational
376386

377387
-- | bytea, name, text, \"char\", bpchar, varchar, unknown
378388
instance FromField SB.ByteString where
379-
fromField f dat = if typeOid f == $(inlineTypoid TI.bytea)
389+
fromField f dat = if maybe True (== $(inlineTypoid TI.bytea)) (typeOid f)
380390
then unBinary <$> fromField f dat
381391
else doFromField f okText' pure dat
382392

@@ -417,7 +427,7 @@ instance FromField LT.Text where
417427
instance FromField (CI ST.Text) where
418428
fromField f mdat = do
419429
typ <- typename f
420-
if typ /= "citext"
430+
if maybe False (/= "citext") typ
421431
then returnError Incompatible f ""
422432
else case mdat of
423433
Nothing -> returnError UnexpectedNull f ""
@@ -428,7 +438,7 @@ instance FromField (CI ST.Text) where
428438
instance FromField (CI LT.Text) where
429439
fromField f mdat = do
430440
typ <- typename f
431-
if typ /= "citext"
441+
if maybe False (/= "citext") typ
432442
then returnError Incompatible f ""
433443
else case mdat of
434444
Nothing -> returnError UnexpectedNull f ""
@@ -478,7 +488,7 @@ instance FromField Date where
478488
ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)
479489
-> Field -> Maybe B8.ByteString -> Conversion a
480490
ff compatOid hsType parse f mstr =
481-
if typeOid f /= compatOid
491+
if maybe False (/= compatOid) (typeOid f)
482492
then err Incompatible ""
483493
else case mstr of
484494
Nothing -> err UnexpectedNull ""
@@ -488,7 +498,7 @@ ff compatOid hsType parse f mstr =
488498
where
489499
err errC msg = do
490500
typnam <- typename f
491-
left $ errC (B8.unpack typnam)
501+
left $ errC (maybe "" B8.unpack typnam)
492502
(tableOid f)
493503
(maybe "" B8.unpack (name f))
494504
hsType
@@ -507,23 +517,24 @@ instance (FromField a, Typeable a) => FromField (PGArray a) where
507517
fromField = pgArrayFieldParser fromField
508518

509519
pgArrayFieldParser :: Typeable a => FieldParser a -> FieldParser (PGArray a)
510-
pgArrayFieldParser fieldParser f mdat = do
511-
info <- typeInfo f
512-
case info of
513-
TI.Array{} ->
514-
case mdat of
515-
Nothing -> returnError UnexpectedNull f ""
516-
Just dat -> do
517-
case parseOnly (fromArray fieldParser info f) dat of
518-
Left err -> returnError ConversionFailed f err
519-
Right conv -> PGArray <$> conv
520-
_ -> returnError Incompatible f ""
520+
pgArrayFieldParser fieldParser f mdat = typeInfo f >>= maybe
521+
(returnError Incompatible f "arrays w/o typeinfo are not supported")
522+
(\info -> case info of
523+
TI.Array{} ->
524+
case mdat of
525+
Nothing -> returnError UnexpectedNull f ""
526+
Just dat -> do
527+
case parseOnly (fromArray fieldParser info f) dat of
528+
Left err -> returnError ConversionFailed f err
529+
Right conv -> PGArray <$> conv
530+
_ -> returnError Incompatible f "")
531+
521532

522533
fromArray :: FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a])
523534
fromArray fieldParser typeInfo f = sequence . (parseIt <$>) <$> array delim
524535
where
525536
delim = typdelim (typelem typeInfo)
526-
fElem = f{ typeOid = typoid (typelem typeInfo) }
537+
fElem = f{ typeOid = Just $ typoid (typelem typeInfo) }
527538

528539
parseIt item =
529540
fieldParser f' $ if item == Arrays.Plain "NULL" then Nothing else Just item'
@@ -541,7 +552,7 @@ instance (FromField a, Typeable a) => FromField (IOVector a) where
541552
-- | uuid
542553
instance FromField UUID where
543554
fromField f mbs =
544-
if typeOid f /= $(inlineTypoid TI.uuid)
555+
if maybe False (/= $(inlineTypoid TI.uuid)) (typeOid f)
545556
then returnError Incompatible f ""
546557
else case mbs of
547558
Nothing -> returnError UnexpectedNull f ""
@@ -553,7 +564,8 @@ instance FromField UUID where
553564
-- | json
554565
instance FromField JSON.Value where
555566
fromField f mbs =
556-
if typeOid f /= $(inlineTypoid TI.json) && typeOid f /= $(inlineTypoid TI.jsonb)
567+
if maybe False
568+
(\t -> t /= $(inlineTypoid TI.json) && t /= $(inlineTypoid TI.jsonb)) (typeOid f)
557569
then returnError Incompatible f ""
558570
else case mbs of
559571
Nothing -> returnError UnexpectedNull f ""
@@ -621,8 +633,8 @@ okInt = ok64
621633
doFromField :: forall a . (Typeable a)
622634
=> Field -> Compat -> (ByteString -> Conversion a)
623635
-> Maybe ByteString -> Conversion a
624-
doFromField f isCompat cvt (Just bs)
625-
| isCompat (typeOid f) = cvt bs
636+
doFromField f@(Field{..}) isCompat cvt (Just bs)
637+
| maybe True isCompat typeOid = cvt bs
626638
| otherwise = returnError Incompatible f "types incompatible"
627639
doFromField f _ _ _ = returnError UnexpectedNull f ""
628640

@@ -636,7 +648,7 @@ returnError :: forall a err . (Typeable a, Exception err)
636648
-> Field -> String -> Conversion a
637649
returnError mkErr f msg = do
638650
typnam <- typename f
639-
left $ mkErr (B.unpack typnam)
651+
left $ mkErr (maybe "" B.unpack typnam)
640652
(tableOid f)
641653
(maybe "" B.unpack (name f))
642654
(show (typeOf (undefined :: a)))
@@ -652,3 +664,86 @@ atto types p0 f dat = doFromField f types (go p0) dat
652664
case parseOnly p s of
653665
Left err -> returnError ConversionFailed f err
654666
Right v -> pure v
667+
668+
669+
-- | Type class for default implementation of FromField using generics.
670+
class GFromField f where
671+
gfromField :: (Typeable p)
672+
=> Proxy p
673+
-> (String -> String)
674+
-> Field
675+
-> [Maybe ByteString]
676+
-> Conversion (f p)
677+
678+
instance (GFromField f) => GFromField (D1 i f) where
679+
gfromField w t f v = M1 <$> gfromField w t f v
680+
681+
instance (GFromField f, Typeable f, Constructor i) => GFromField (C1 i f) where
682+
gfromField w t f (v:[]) = let
683+
tname = B8.pack . t . conName $ (undefined::(C1 i f t))
684+
tcheck = maybe False (\t -> t /= "record" && t /= tname)
685+
in tcheck <$> typename f >>= \b -> M1 <$> case b of
686+
True -> returnError Incompatible f ""
687+
False -> maybe
688+
(returnError UnexpectedNull f "")
689+
(either
690+
(returnError ConversionFailed f)
691+
(gfromField w t f)
692+
. (parseOnly record)) v
693+
gfromField _ _ f _ = M1 <$> returnError ConversionFailed f errUnexpectedArgs
694+
695+
instance (GFromField f, Typeable f, GFromField g) => GFromField (f :*: g) where
696+
gfromField _ _ f [] = liftA2 (:*:) (returnError ConversionFailed f errTooFewValues) empty
697+
gfromField w t f (v:vs) = liftA2 (:*:) (gfromField w t f [v]) (gfromField w t f vs)
698+
699+
instance (GFromField f, Typeable f) => GFromField (S1 i f) where
700+
gfromField _ _ f [] = M1 <$> returnError ConversionFailed f errTooFewValues
701+
gfromField w t f (v:[]) = M1 <$> gfromField w t f [v]
702+
gfromField _ _ f _ = M1 <$> returnError ConversionFailed f errTooManyValues
703+
704+
instance (FromField f, Typeable f) => GFromField (Rec0 f) where
705+
gfromField _ _ f [v] = K1 <$> fromField (f {typeOid = Nothing}) v
706+
gfromField _ _ f _ = K1 <$> returnError ConversionFailed f errUnexpectedArgs
707+
708+
709+
-- | Common error messages for GFromField instances.
710+
errTooFewValues, errTooManyValues, errUnexpectedArgs :: String
711+
errTooFewValues = "too few values"
712+
errTooManyValues = "too many values"
713+
errUnexpectedArgs = "unexpected arguments"
714+
715+
-- | Parser of a postgresql record.
716+
record :: Parser [Maybe ByteString]
717+
record = (char '(') *> (recordField `sepBy` (char ',')) <* (char ')')
718+
719+
-- | Parser of a postgresql record's field.
720+
recordField :: Parser (Maybe ByteString)
721+
recordField = (Just <$> quotedString) <|> (Just <$> unquotedString) <|> (pure Nothing) where
722+
quotedString = unescape <$> (char '"' *> scan False updateState) where
723+
updateState isBalanced c = if
724+
| c == '"' -> Just . not $ isBalanced
725+
| not isBalanced -> Just False
726+
| c == ',' || c == ')' -> Nothing
727+
| otherwise -> fail $ "unexpected symbol: " ++ [c]
728+
729+
unescape = unescape' '\\' . unescape' '"' . B8.init where
730+
unescape' c = halve c (byteString SB.empty) . groupByChar c
731+
732+
groupByChar c = B8.groupBy $ \a b -> (a == c) == (b == c)
733+
734+
halve :: Char -> Builder -> [ByteString] -> ByteString
735+
halve _ b [] = LB.toStrict . toLazyByteString $ b
736+
halve c b (s:ss) = halve c (b <> b') ss where
737+
b' = if
738+
| (/= c) . B8.head $ s -> byteString s
739+
| otherwise -> byteString . SB.take ((SB.length s) `div` 2) $ s
740+
741+
unquotedString = takeWhile1 (\c -> c /= ',' && c /= ')')
742+
743+
-- | Function that creates fromField for a given type.
744+
genericFromField :: forall a. (Generic a, Typeable a, GFromField (Rep a))
745+
=> (String -> String) -- ^ How to transform constructor's name to match
746+
-- postgresql type's name.
747+
-> FieldParser a
748+
genericFromField t f v = (to <$> (gfromField (Proxy :: Proxy a) t f [v]))
749+

‎src/Database/PostgreSQL/Simple/FromRow.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -113,7 +113,7 @@ fieldWith fieldP = RP $ do
113113
conversionError err
114114
else do
115115
let !result = rowresult
116-
!typeOid = unsafeDupablePerformIO (PQ.ftype result column)
116+
!typeOid = Just $ unsafeDupablePerformIO (PQ.ftype result column)
117117
!field = Field{..}
118118
lift (lift (fieldP field (getvalue result row column)))
119119

‎src/Database/PostgreSQL/Simple/HStore/Implementation.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -126,7 +126,7 @@ instance ToField HStoreList where
126126
instance FromField HStoreList where
127127
fromField f mdat = do
128128
typ <- typename f
129-
if typ /= "hstore"
129+
if maybe False (/= "hstore") typ
130130
then returnError Incompatible f ""
131131
else case mdat of
132132
Nothing -> returnError UnexpectedNull f ""

‎src/Database/PostgreSQL/Simple/Internal.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -64,7 +64,7 @@ import Control.Concurrent(threadWaitRead, threadWaitWrite)
6464
data Field = Field {
6565
result :: !PQ.Result
6666
, column :: {-# UNPACK #-} !PQ.Column
67-
, typeOid :: {-# UNPACK #-} !PQ.Oid
67+
, typeOid :: {-# UNPACK #-} !(Maybe PQ.Oid)
6868
-- ^ This returns the type oid associated with the column. Analogous
6969
-- to libpq's @PQftype@.
7070
}

‎src/Database/PostgreSQL/Simple/Range.hs‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -189,11 +189,11 @@ rangeToBuilderBy cmp f x =
189189

190190

191191
instance (FromField a, Typeable a) => FromField (PGRange a) where
192-
fromField f mdat = do
193-
info <- typeInfo f
194-
case info of
192+
fromField f mdat = typeInfo f >>= maybe
193+
(returnError Incompatible f "ranges w/o typeinfo are not supported")
194+
(\info -> case info of
195195
Range{} ->
196-
let f' = f { typeOid = typoid (rngsubtype info) }
196+
let f' = f { typeOid = Just $ typoid (rngsubtype info) }
197197
in case mdat of
198198
Nothing -> returnError UnexpectedNull f ""
199199
Just "empty" -> pure $ empty
@@ -205,7 +205,7 @@ instance (FromField a, Typeable a) => FromField (PGRange a) where
205205
in case parseOnly pgrange bs of
206206
Left e -> returnError ConversionFailed f e
207207
Right (lb,ub) -> PGRange <$> parseIt lb <*> parseIt ub
208-
_ -> returnError Incompatible f ""
208+
_ -> returnError Incompatible f "")
209209

210210

211211
instance ToField (PGRange Int8) where

0 commit comments

Comments
 (0)