Added generic ToField and FromField classes

src/Database/PostgreSQL/Simple/FromField.hs

@@ -2,6 +2,8 @@
 {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
 {-# LANGUAGE PatternGuards, ScopedTypeVariables      #-}
 {-# LANGUAGE RecordWildCards, TemplateHaskell        #-}
+{-# LANGUAGE MultiWayIf, DefaultSignatures           #-}
+{-# LANGUAGE FlexibleContexts                        #-}
 
 {- |
 Module:      Database.PostgreSQL.Simple.FromField
@@ -83,6 +85,7 @@ instances use 'typename' instead.
 module Database.PostgreSQL.Simple.FromField
     (
       FromField(..)
+    , genericFromField
     , FieldParser
     , Conversion()
 
@@ -113,16 +116,19 @@ module Database.PostgreSQL.Simple.FromField
 
 #include "MachDeps.h"
 
-import           Control.Applicative ( (<|>), (<$>), pure, (*>), (<*) )
+import           Control.Applicative ( Alternative(..), (<|>), (<$>), pure, (*>), (<*), liftA2 )
 import           Control.Concurrent.MVar (MVar, newMVar)
 import           Control.Exception (Exception)
 import qualified Data.Aeson as JSON
 import qualified Data.Aeson.Parser as JSON (value')
 import           Data.Attoparsec.ByteString.Char8 hiding (Result)
 import           Data.ByteString (ByteString)
+import           Data.ByteString.Builder (Builder, toLazyByteString, byteString)
 import qualified Data.ByteString.Char8 as B
+import           Data.Char (toLower)
 import           Data.Int (Int16, Int32, Int64)
 import           Data.IORef (IORef, newIORef)
+import           Data.Proxy (Proxy(..))
 import           Data.Ratio (Ratio)
 import           Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )
 import           Data.Typeable (Typeable, typeOf)
@@ -150,6 +156,7 @@ import qualified Data.CaseInsensitive as CI
 import           Data.UUID.Types   (UUID)
 import qualified Data.UUID.Types as UUID
 import           Data.Scientific (Scientific)
+import           GHC.Generics (Generic, Rep, M1(..), K1(..), D1, C1, S1, Rec0, Constructor, (:*:)(..), to, conName)
 import           GHC.Real (infinity, notANumber)
 
 -- | Exception thrown if conversion from a SQL value to a Haskell
@@ -188,6 +195,8 @@ type FieldParser a = Field -> Maybe ByteString -> Conversion a
 -- | A type that may be converted from a SQL type.
 class FromField a where
     fromField :: FieldParser a
+    default fromField :: (Generic a, Typeable a, GFromField (Rep a)) => FieldParser a
+    fromField = genericFromField (map toLower)
     -- ^ Convert a SQL value to a Haskell value.
     --
     -- Returns a list of exceptions if the conversion fails.  In the case of
@@ -214,17 +223,18 @@ class FromField a where
 --   postgresql-simple will check a per-connection cache,  and then
 --   finally query the database's meta-schema.
 
-typename :: Field -> Conversion ByteString
-typename field = typname <$> typeInfo field
+typename :: Field -> Conversion (Maybe ByteString)
+typename field = fmap typname <$> typeInfo field
 
-typeInfo :: Field -> Conversion TypeInfo
+typeInfo :: Field -> Conversion (Maybe TypeInfo)
 typeInfo Field{..} = Conversion $ \conn -> do
-                       Ok <$> (getTypeInfo conn typeOid)
+  Ok <$> (maybe (return Nothing) (fmap Just . getTypeInfo conn) typeOid)
 
 typeInfoByOid :: PQ.Oid -> Conversion TypeInfo
 typeInfoByOid oid = Conversion $ \conn -> do
                       Ok <$> (getTypeInfo conn oid)
 
+
 -- | Returns the name of the column.  This is often determined by a table
 --   definition,  but it can be set using an @as@ clause.
 
@@ -262,7 +272,7 @@ format Field{..} = unsafeDupablePerformIO (PQ.fformat result column)
 -- | void
 instance FromField () where
   fromField f _bs
-     | typeOid f /= $(inlineTypoid TI.void) = returnError Incompatible f ""
+     | maybe False (/= $(inlineTypoid TI.void)) (typeOid f) = returnError Incompatible f ""
      | otherwise = pure ()
 
 -- | For dealing with null values.  Compatible with any postgresql type
@@ -292,7 +302,7 @@ instance FromField Null where
 -- | bool
 instance FromField Bool where
     fromField f bs
-      | typeOid f /= $(inlineTypoid TI.bool) = returnError Incompatible f ""
+      | maybe False (/= $(inlineTypoid TI.bool)) (typeOid f) = returnError Incompatible f ""
       | bs == Nothing                 = returnError UnexpectedNull f ""
       | bs == Just "t"                = pure True
       | bs == Just "f"                = pure False
@@ -301,7 +311,7 @@ instance FromField Bool where
 -- | \"char\"
 instance FromField Char where
     fromField f bs =
-        if typeOid f /= $(inlineTypoid TI.char)
+        if maybe False (/= $(inlineTypoid TI.char)) (typeOid f)
         then returnError Incompatible f ""
         else case bs of
                Nothing -> returnError UnexpectedNull f ""
@@ -376,7 +386,7 @@ pg_rational
 
 -- | bytea, name, text, \"char\", bpchar, varchar, unknown
 instance FromField SB.ByteString where
-    fromField f dat = if typeOid f == $(inlineTypoid TI.bytea)
+    fromField f dat = if maybe True (== $(inlineTypoid TI.bytea)) (typeOid f)
                       then unBinary <$> fromField f dat
                       else doFromField f okText' pure dat
 
@@ -417,7 +427,7 @@ instance FromField LT.Text where
 instance FromField (CI ST.Text) where
     fromField f mdat = do
        typ <- typename f
-       if typ /= "citext"
+       if maybe False (/= "citext") typ
          then returnError Incompatible f ""
          else case mdat of
                 Nothing  -> returnError UnexpectedNull f ""
@@ -428,7 +438,7 @@ instance FromField (CI ST.Text) where
 instance FromField (CI LT.Text) where
     fromField f mdat = do
        typ <- typename f
-       if typ /= "citext"
+       if maybe False (/= "citext") typ
          then returnError Incompatible f ""
          else case mdat of
                 Nothing  -> returnError UnexpectedNull f ""
@@ -478,7 +488,7 @@ instance FromField Date where
 ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)
    -> Field -> Maybe B8.ByteString -> Conversion a
 ff compatOid hsType parse f mstr =
-  if typeOid f /= compatOid
+  if maybe False (/= compatOid) (typeOid f)
   then err Incompatible ""
   else case mstr of
          Nothing -> err UnexpectedNull ""
@@ -488,7 +498,7 @@ ff compatOid hsType parse f mstr =
  where
    err errC msg = do
      typnam <- typename f
-     left $ errC (B8.unpack typnam)
+     left $ errC (maybe "" B8.unpack typnam)
                  (tableOid f)
                  (maybe "" B8.unpack (name f))
                  hsType
@@ -507,23 +517,24 @@ instance (FromField a, Typeable a) => FromField (PGArray a) where
   fromField = pgArrayFieldParser fromField
 
 pgArrayFieldParser :: Typeable a => FieldParser a -> FieldParser (PGArray a)
-pgArrayFieldParser fieldParser f mdat = do
-        info <- typeInfo f
-        case info of
-          TI.Array{} ->
-              case mdat of
-                Nothing  -> returnError UnexpectedNull f ""
-                Just dat -> do
-                   case parseOnly (fromArray fieldParser info f) dat of
-                     Left  err  -> returnError ConversionFailed f err
-                     Right conv -> PGArray <$> conv
-          _ -> returnError Incompatible f ""
+pgArrayFieldParser fieldParser f mdat = typeInfo f >>= maybe
+  (returnError Incompatible f "arrays w/o typeinfo are not supported")
+  (\info -> case info of
+    TI.Array{} ->
+        case mdat of
+          Nothing  -> returnError UnexpectedNull f ""
+          Just dat -> do
+             case parseOnly (fromArray fieldParser info f) dat of
+               Left  err  -> returnError ConversionFailed f err
+               Right conv -> PGArray <$> conv
+    _ -> returnError Incompatible f "")
+
 
 fromArray :: FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a])
 fromArray fieldParser typeInfo f = sequence . (parseIt <$>) <$> array delim
   where
     delim = typdelim (typelem typeInfo)
-    fElem = f{ typeOid = typoid (typelem typeInfo) }
+    fElem = f{ typeOid = Just $ typoid (typelem typeInfo) }
 
     parseIt item =
         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
 -- | uuid
 instance FromField UUID where
     fromField f mbs =
-      if typeOid f /= $(inlineTypoid TI.uuid)
+      if maybe False (/= $(inlineTypoid TI.uuid)) (typeOid f)
       then returnError Incompatible f ""
       else case mbs of
              Nothing -> returnError UnexpectedNull f ""
@@ -553,7 +564,8 @@ instance FromField UUID where
 -- | json
 instance FromField JSON.Value where
     fromField f mbs =
-      if typeOid f /= $(inlineTypoid TI.json) && typeOid f /= $(inlineTypoid TI.jsonb)
+      if maybe False
+         (\t -> t /= $(inlineTypoid TI.json) && t /= $(inlineTypoid TI.jsonb)) (typeOid f)
       then returnError Incompatible f ""
       else case mbs of
              Nothing -> returnError UnexpectedNull f ""
@@ -621,8 +633,8 @@ okInt = ok64
 doFromField :: forall a . (Typeable a)
           => Field -> Compat -> (ByteString -> Conversion a)
           -> Maybe ByteString -> Conversion a
-doFromField f isCompat cvt (Just bs)
-    | isCompat (typeOid f) = cvt bs
+doFromField f@(Field{..}) isCompat cvt (Just bs)
+    | maybe True isCompat typeOid = cvt bs
     | otherwise = returnError Incompatible f "types incompatible"
 doFromField f _ _ _ = returnError UnexpectedNull f ""
 
@@ -636,7 +648,7 @@ returnError :: forall a err . (Typeable a, Exception err)
             -> Field -> String -> Conversion a
 returnError mkErr f msg = do
   typnam <- typename f
-  left $ mkErr (B.unpack typnam)
+  left $ mkErr (maybe "" B.unpack typnam)
                (tableOid f)
                (maybe "" B.unpack (name f))
                (show (typeOf (undefined :: a)))
@@ -652,3 +664,86 @@ atto types p0 f dat = doFromField f types (go p0) dat
         case parseOnly p s of
           Left err -> returnError ConversionFailed f err
           Right  v -> pure v
+
+
+-- | Type class for default implementation of FromField using generics.
+class GFromField f where
+  gfromField :: (Typeable p)
+    => Proxy p
+    -> (String -> String)
+    -> Field
+    -> [Maybe ByteString]
+    -> Conversion (f p)
+
+instance (GFromField f) => GFromField (D1 i f) where
+  gfromField w t f v = M1 <$> gfromField w t f v
+
+instance (GFromField f, Typeable f, Constructor i) => GFromField (C1 i f) where
+  gfromField w t f (v:[]) = let
+    tname = B8.pack . t . conName $ (undefined::(C1 i f t))
+    tcheck = maybe False (\t -> t /= "record" && t /= tname)
+    in tcheck <$> typename f >>= \b -> M1 <$> case b of
+      True  -> returnError Incompatible f ""
+      False -> maybe
+        (returnError UnexpectedNull f "")
+        (either
+          (returnError ConversionFailed f)
+          (gfromField w t f)
+          . (parseOnly record)) v
+  gfromField _ _ f _ = M1 <$> returnError ConversionFailed f errUnexpectedArgs
+
+instance (GFromField f, Typeable f, GFromField g) => GFromField (f :*: g) where
+  gfromField _ _ f []     = liftA2 (:*:) (returnError ConversionFailed f errTooFewValues) empty
+  gfromField w t f (v:vs) = liftA2 (:*:) (gfromField w t f [v]) (gfromField w t f vs)
+
+instance (GFromField f, Typeable f) => GFromField (S1 i f) where
+  gfromField _ _ f []     = M1 <$> returnError ConversionFailed f errTooFewValues
+  gfromField w t f (v:[]) = M1 <$> gfromField w t f [v]
+  gfromField _ _ f _      = M1 <$> returnError ConversionFailed f errTooManyValues
+
+instance (FromField f, Typeable f) => GFromField (Rec0 f) where
+  gfromField _ _ f [v] = K1 <$> fromField (f {typeOid = Nothing}) v
+  gfromField _ _ f _   = K1 <$> returnError ConversionFailed f errUnexpectedArgs
+
+
+-- | Common error messages for GFromField instances.
+errTooFewValues, errTooManyValues, errUnexpectedArgs :: String
+errTooFewValues = "too few values"
+errTooManyValues = "too many values"
+errUnexpectedArgs = "unexpected arguments"
+
+-- | Parser of a postgresql record.
+record :: Parser [Maybe ByteString]
+record = (char '(') *> (recordField `sepBy` (char ',')) <* (char ')')
+
+-- | Parser of a postgresql record's field.
+recordField :: Parser (Maybe ByteString)
+recordField = (Just <$> quotedString) <|> (Just <$> unquotedString) <|> (pure Nothing) where
+  quotedString = unescape <$> (char '"' *> scan False updateState) where
+    updateState isBalanced c = if
+      | c == '"'             -> Just . not $ isBalanced
+      | not isBalanced       -> Just False
+      | c == ',' || c == ')' -> Nothing
+      | otherwise            -> fail $ "unexpected symbol: " ++ [c]
+
+    unescape = unescape' '\\' . unescape' '"' . B8.init where
+      unescape' c = halve c (byteString SB.empty) . groupByChar c
+
+      groupByChar c = B8.groupBy $ \a b -> (a == c) == (b == c)
+
+      halve :: Char -> Builder -> [ByteString] -> ByteString
+      halve _ b []     = LB.toStrict . toLazyByteString $ b
+      halve c b (s:ss) = halve c (b <> b') ss where
+        b' = if
+           | (/= c) . B8.head $ s -> byteString s
+           | otherwise            -> byteString . SB.take ((SB.length s) `div` 2) $ s
+
+  unquotedString = takeWhile1 (\c -> c /= ',' && c /= ')')
+
+-- | Function that creates fromField for a given type.
+genericFromField :: forall a. (Generic a, Typeable a, GFromField (Rep a))
+  => (String -> String) -- ^ How to transform constructor's name to match
+                        --   postgresql type's name.
+  -> FieldParser a
+genericFromField t f v = (to <$> (gfromField (Proxy :: Proxy a) t f [v]))
+

src/Database/PostgreSQL/Simple/FromRow.hs

@@ -113,7 +113,7 @@ fieldWith fieldP = RP $ do
         conversionError err
     else do
       let !result = rowresult
-          !typeOid = unsafeDupablePerformIO (PQ.ftype result column)
+          !typeOid = Just $ unsafeDupablePerformIO (PQ.ftype result column)
           !field = Field{..}
       lift (lift (fieldP field (getvalue result row column)))
 

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

@@ -126,7 +126,7 @@ instance ToField HStoreList where
 instance FromField HStoreList where
     fromField f mdat = do
       typ <- typename f
-      if typ /= "hstore"
+      if maybe False (/= "hstore") typ
         then returnError Incompatible f ""
         else case mdat of
                Nothing  -> returnError UnexpectedNull f ""

src/Database/PostgreSQL/Simple/Internal.hs

@@ -64,7 +64,7 @@ import           Control.Concurrent(threadWaitRead, threadWaitWrite)
 data Field = Field {
      result   :: !PQ.Result
    , column   :: {-# UNPACK #-} !PQ.Column
-   , typeOid  :: {-# UNPACK #-} !PQ.Oid
+   , typeOid  :: {-# UNPACK #-} !(Maybe PQ.Oid)
      -- ^ This returns the type oid associated with the column.  Analogous
      --   to libpq's @PQftype@.
    }

src/Database/PostgreSQL/Simple/Range.hs

@@ -189,11 +189,11 @@ rangeToBuilderBy cmp f x =
 
 
 instance (FromField a, Typeable a) => FromField (PGRange a) where
-  fromField f mdat = do
-    info <- typeInfo f
-    case info of
+  fromField f mdat = typeInfo f >>= maybe
+    (returnError Incompatible f "ranges w/o typeinfo are not supported")
+    (\info -> case info of
       Range{} ->
-        let f' = f { typeOid = typoid (rngsubtype info) }
+        let f' = f { typeOid = Just $ typoid (rngsubtype info) }
         in case mdat of
           Nothing -> returnError UnexpectedNull f ""
           Just "empty" -> pure $ empty
@@ -205,7 +205,7 @@ instance (FromField a, Typeable a) => FromField (PGRange a) where
             in case parseOnly pgrange bs of
                 Left e -> returnError ConversionFailed f e
                 Right (lb,ub) -> PGRange <$> parseIt lb <*> parseIt ub
-      _ -> returnError Incompatible f ""
+      _ -> returnError Incompatible f "")
 
 
 instance ToField (PGRange Int8) where