module Database.PostgreSQL.Simple.FromField
(
FromField(..)
, FieldParser
, Conversion()
, runConversion
, conversionMap
, conversionError
, ResultError(..)
, returnError
, Field
, typename
, TypeInfo(..)
, Attribute(..)
, typeInfo
, typeInfoByOid
, name
, tableOid
, tableColumn
, format
, typeOid
, PQ.Oid(..)
, PQ.Format(..)
) where
#include "MachDeps.h"
import Control.Applicative
( Applicative, (<|>), (<$>), pure )
import Control.Exception (Exception)
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 ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )
import Data.Typeable (Typeable, typeOf)
import Data.Vector (Vector)
import qualified Data.Vector as V
import Data.Word (Word64)
import Database.PostgreSQL.Simple.Internal
import Database.PostgreSQL.Simple.BuiltinTypes
import Database.PostgreSQL.Simple.Compat
import Database.PostgreSQL.Simple.Ok
import Database.PostgreSQL.Simple.Types (Binary(..), Null(..))
import Database.PostgreSQL.Simple.TypeInfo as TypeInfo
import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TypeInfo
import Database.PostgreSQL.Simple.Time
import Database.PostgreSQL.Simple.Arrays as Arrays
import qualified Database.PostgreSQL.LibPQ as PQ
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.Lazy as LT
data ResultError = Incompatible { errSQLType :: String
, errSQLTableOid :: Maybe PQ.Oid
, errSQLField :: String
, errHaskellType :: String
, errMessage :: String }
| UnexpectedNull { errSQLType :: String
, errSQLTableOid :: Maybe PQ.Oid
, errSQLField :: String
, errHaskellType :: String
, errMessage :: String }
| ConversionFailed { errSQLType :: String
, errSQLTableOid :: Maybe PQ.Oid
, errSQLField :: String
, errHaskellType :: String
, errMessage :: String }
deriving (Eq, Show, Typeable)
instance Exception ResultError
left :: Exception a => a -> Conversion b
left = conversionError
type FieldParser a = Field -> Maybe ByteString -> Conversion a
class FromField a where
fromField :: FieldParser a
typename :: Field -> Conversion ByteString
typename field = typname <$> typeInfo field
typeInfo :: Field -> Conversion TypeInfo
typeInfo Field{..} = Conversion $ \conn -> do
Ok <$> (getTypeInfo conn =<< PQ.ftype result column)
typeInfoByOid :: PQ.Oid -> Conversion TypeInfo
typeInfoByOid oid = Conversion $ \conn -> do
Ok <$> (getTypeInfo conn oid)
name :: Field -> Maybe ByteString
name Field{..} = unsafeDupablePerformIO (PQ.fname result column)
tableOid :: Field -> Maybe PQ.Oid
tableOid Field{..} = toMaybeOid (unsafeDupablePerformIO (PQ.ftable result column))
where
toMaybeOid x
= if x == PQ.invalidOid
then Nothing
else Just x
tableColumn :: Field -> Int
tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column))
where
fromCol (PQ.Col x) = fromIntegral x
format :: Field -> PQ.Format
format Field{..} = unsafeDupablePerformIO (PQ.fformat result column)
instance (FromField a) => FromField (Maybe a) where
fromField _ Nothing = pure Nothing
fromField f bs = Just <$> fromField f bs
instance FromField Null where
fromField _ Nothing = pure Null
fromField f (Just _) = returnError ConversionFailed f "data is not null"
instance FromField Bool where
fromField f bs
| typeOid f /= typoid (TypeInfo.bool) = returnError Incompatible f ""
| bs == Nothing = returnError UnexpectedNull f ""
| bs == Just "t" = pure True
| bs == Just "f" = pure False
| otherwise = returnError ConversionFailed f ""
instance FromField Char where
fromField f bs =
if typeOid f /= typoid (TypeInfo.char)
then returnError Incompatible f ""
else case bs of
Nothing -> returnError UnexpectedNull f ""
Just bs -> if B.length bs /= 1
then returnError ConversionFailed f "length not 1"
else return $! (B.head bs)
instance FromField Int16 where
fromField = atto ok16 $ signed decimal
instance FromField Int32 where
fromField = atto ok32 $ signed decimal
#if WORD_SIZE_IN_BITS < 64
#else
#endif
instance FromField Int where
fromField = atto okInt $ signed decimal
instance FromField Int64 where
fromField = atto ok64 $ signed decimal
instance FromField Integer where
fromField = atto ok64 $ signed decimal
instance FromField Float where
fromField = atto ok (realToFrac <$> double)
where ok = mkCompats [Float4,Int2]
instance FromField Double where
fromField = atto ok double
where ok = mkCompats [Float4,Float8,Int2,Int4]
instance FromField (Ratio Integer) where
fromField = atto ok rational
where ok = mkCompats [Float4,Float8,Int2,Int4,Numeric]
unBinary :: Binary t -> t
unBinary (Binary x) = x
instance FromField SB.ByteString where
fromField f dat = if typeOid f == typoid TypeInfo.bytea
then unBinary <$> fromField f dat
else doFromField f okText' (pure . B.copy) dat
instance FromField PQ.Oid where
fromField f dat = PQ.Oid <$> atto (mkCompat Oid) decimal f dat
instance FromField LB.ByteString where
fromField f dat = LB.fromChunks . (:[]) <$> fromField f dat
unescapeBytea :: Field -> SB.ByteString
-> Conversion (Binary SB.ByteString)
unescapeBytea f str = case unsafeDupablePerformIO (PQ.unescapeBytea str) of
Nothing -> returnError ConversionFailed f "unescapeBytea failed"
Just str -> pure (Binary str)
instance FromField (Binary SB.ByteString) where
fromField f dat = case format f of
PQ.Text -> doFromField f okBinary (unescapeBytea f) dat
PQ.Binary -> doFromField f okBinary (pure . Binary . B.copy) dat
instance FromField (Binary LB.ByteString) where
fromField f dat = Binary . LB.fromChunks . (:[]) . unBinary <$> fromField f dat
instance FromField ST.Text where
fromField f = doFromField f okText $ (either left pure . ST.decodeUtf8')
instance FromField LT.Text where
fromField f dat = LT.fromStrict <$> fromField f dat
instance FromField [Char] where
fromField f dat = ST.unpack <$> fromField f dat
instance FromField UTCTime where
fromField = ff TypeInfo.timestamptz "UTCTime" parseUTCTime
instance FromField ZonedTime where
fromField = ff TypeInfo.timestamptz "ZonedTime" parseZonedTime
instance FromField LocalTime where
fromField = ff TypeInfo.timestamp "LocalTime" parseLocalTime
instance FromField Day where
fromField = ff TypeInfo.date "Day" parseDay
instance FromField TimeOfDay where
fromField = ff TypeInfo.time "TimeOfDay" parseTimeOfDay
instance FromField UTCTimestamp where
fromField = ff TypeInfo.timestamptz "UTCTimestamp" parseUTCTimestamp
instance FromField ZonedTimestamp where
fromField = ff TypeInfo.timestamptz "ZonedTimestamp" parseZonedTimestamp
instance FromField LocalTimestamp where
fromField = ff TypeInfo.timestamp "LocalTimestamp" parseLocalTimestamp
instance FromField Date where
fromField = ff TypeInfo.date "Date" parseDate
ff :: TypeInfo -> String -> (B8.ByteString -> Either String a)
-> Field -> Maybe B8.ByteString -> Conversion a
ff pgType hsType parse f mstr =
if typeOid f /= typoid pgType
then err Incompatible ""
else case mstr of
Nothing -> err UnexpectedNull ""
Just str -> case parse str of
Left msg -> err ConversionFailed msg
Right val -> return val
where
err errC msg = do
typnam <- typename f
left $ errC (B8.unpack typnam)
(tableOid f)
(maybe "" B8.unpack (name f))
hsType
msg
instance (FromField a, FromField b) => FromField (Either a b) where
fromField f dat = (Right <$> fromField f dat)
<|> (Left <$> fromField f dat)
instance (FromField a, Typeable a) => FromField (Vector a) where
fromField f mdat = do
info <- typeInfo f
case info of
TypeInfo.Array{} ->
case mdat of
Nothing -> returnError UnexpectedNull f ""
Just dat -> do
case parseOnly (fromArray info f) dat of
Left err -> returnError ConversionFailed f err
Right conv -> V.fromList <$> conv
_ -> returnError Incompatible f ""
fromArray :: (FromField a)
=> TypeInfo -> Field -> Parser (Conversion [a])
fromArray typeInfo f = sequence . (parseIt <$>) <$> array delim
where
delim = typdelim (typelem typeInfo)
fElem = f{ typeOid = typoid (typelem typeInfo) }
parseIt item = (fromField f' . Just . fmt delim) item
where f' | Arrays.Array _ <- item = f
| otherwise = fElem
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', okBinary, ok16, ok32, ok64, okInt :: 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
doFromField :: forall a . (Typeable a)
=> Field -> Compat -> (ByteString -> Conversion a)
-> Maybe ByteString -> Conversion a
doFromField f types cvt (Just bs)
| Just typ <- oid2builtin (typeOid f)
, mkCompat typ `compat` types = cvt bs
| otherwise = returnError Incompatible f "types incompatible"
doFromField f _ _ _ = returnError UnexpectedNull f ""
returnError :: forall a err . (Typeable a, Exception err)
=> (String -> Maybe PQ.Oid -> String -> String -> String -> err)
-> Field -> String -> Conversion a
returnError mkErr f msg = do
typnam <- typename f
left $ mkErr (B.unpack typnam)
(tableOid f)
(maybe "" B.unpack (name f))
(show (typeOf (undefined :: a)))
msg
atto :: forall a. (Typeable a)
=> Compat -> Parser a -> Field -> Maybe ByteString
-> Conversion a
atto types p0 f dat = doFromField f types (go p0) dat
where
go :: Parser a -> ByteString -> Conversion a
go p s =
case parseOnly p s of
Left err -> returnError ConversionFailed f err
Right v -> pure v