{-# LANGUAGE CPP, FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, FlexibleContexts, DataKinds, KindSignatures, TypeFamilies, DeriveDataTypeable #-}
#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE OverlappingInstances #-}
#endif
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE UndecidableSuperClasses #-}
#endif
-- |
-- Module: Database.PostgreSQL.Typed.Types
-- Copyright: 2015 Dylan Simon
-- 
-- Classes to support type inference, value encoding/decoding, and instances to support built-in PostgreSQL types.

module Database.PostgreSQL.Typed.Types 
  (
  -- * Basic types
    OID
  , PGValue(..)
  , PGValues
  , PGTypeID(..)
  , PGTypeEnv(..), unknownPGTypeEnv
  , PGName(..), pgNameBS, pgNameString
  , PGRecord(..)

  -- * Marshalling classes
  , PGType(..)
  , PGParameter(..)
  , PGColumn(..)
  , PGStringType
  , PGRecordType

  -- * Marshalling interface
  , pgEncodeParameter
  , pgEscapeParameter
  , pgDecodeColumn
  , pgDecodeColumnNotNull

  -- * Conversion utilities
  , pgQuote
  , pgDQuote
  , pgDQuoteFrom
  , parsePGDQuote
  , buildPGValue
  ) where

import qualified Codec.Binary.UTF8.String as UTF8
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), (<$), (<*), (*>))
#endif
import Control.Arrow ((&&&))
#ifdef VERSION_aeson
import qualified Data.Aeson as JSON
#endif
import qualified Data.Attoparsec.ByteString as P (anyWord8)
import qualified Data.Attoparsec.ByteString.Char8 as P
import Data.Bits (shiftL, (.|.))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Builder.Prim as BSBP
import qualified Data.ByteString.Char8 as BSC
import Data.ByteString.Internal (c2w, w2c)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.UTF8 as BSU
import Data.Char (isSpace, isDigit, digitToInt, intToDigit, toLower)
import Data.Data (Data)
import Data.Int
import Data.List (intersperse)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (mempty, mconcat)
#endif
import Data.Ratio ((%), numerator, denominator)
#ifdef VERSION_scientific
import Data.Scientific (Scientific)
#endif
import Data.String (IsString(..))
#ifdef VERSION_text
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
#endif
import qualified Data.Time as Time
#if MIN_VERSION_time(1,5,0)
import Data.Time (defaultTimeLocale)
#else
import System.Locale (defaultTimeLocale)
#endif
import Data.Typeable (Typeable)
#ifdef VERSION_uuid
import qualified Data.UUID as UUID
#endif
import Data.Word (Word8, Word32)
import GHC.TypeLits (Symbol, symbolVal, KnownSymbol)
import Numeric (readFloat)
#ifdef VERSION_postgresql_binary
#if MIN_VERSION_postgresql_binary(0,12,0)
import qualified PostgreSQL.Binary.Decoding as BinD
import qualified PostgreSQL.Binary.Encoding as BinE
#else
import qualified PostgreSQL.Binary.Decoder as BinD
import qualified PostgreSQL.Binary.Encoder as BinE
#endif
#endif

type PGTextValue = BS.ByteString
type PGBinaryValue = BS.ByteString
-- |A value passed to or from PostgreSQL in raw format.
data PGValue
  = PGNullValue
  | PGTextValue { PGValue -> ByteString
pgTextValue :: PGTextValue } -- ^ The standard text encoding format (also used for unknown formats)
  | PGBinaryValue { PGValue -> ByteString
pgBinaryValue :: PGBinaryValue } -- ^ Special binary-encoded data.  Not supported in all cases.
  deriving (Int -> PGValue -> ShowS
[PGValue] -> ShowS
PGValue -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PGValue] -> ShowS
$cshowList :: [PGValue] -> ShowS
show :: PGValue -> String
$cshow :: PGValue -> String
showsPrec :: Int -> PGValue -> ShowS
$cshowsPrec :: Int -> PGValue -> ShowS
Show, PGValue -> PGValue -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PGValue -> PGValue -> Bool
$c/= :: PGValue -> PGValue -> Bool
== :: PGValue -> PGValue -> Bool
$c== :: PGValue -> PGValue -> Bool
Eq)
-- |A list of (nullable) data values, e.g. a single row or query parameters.
type PGValues = [PGValue]

-- |Parameters that affect how marshalling happens.
-- Currenly we force all other relevant parameters at connect time.
-- Nothing values represent unknown.
data PGTypeEnv = PGTypeEnv
  { PGTypeEnv -> Maybe Bool
pgIntegerDatetimes :: Maybe Bool -- ^ If @integer_datetimes@ is @on@; only relevant for binary encoding.
  , PGTypeEnv -> Maybe ByteString
pgServerVersion :: Maybe BS.ByteString -- ^ The @server_version@ parameter
  } deriving (Int -> PGTypeEnv -> ShowS
[PGTypeEnv] -> ShowS
PGTypeEnv -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PGTypeEnv] -> ShowS
$cshowList :: [PGTypeEnv] -> ShowS
show :: PGTypeEnv -> String
$cshow :: PGTypeEnv -> String
showsPrec :: Int -> PGTypeEnv -> ShowS
$cshowsPrec :: Int -> PGTypeEnv -> ShowS
Show)

unknownPGTypeEnv :: PGTypeEnv
unknownPGTypeEnv :: PGTypeEnv
unknownPGTypeEnv = PGTypeEnv
  { pgIntegerDatetimes :: Maybe Bool
pgIntegerDatetimes = forall a. Maybe a
Nothing
  , pgServerVersion :: Maybe ByteString
pgServerVersion = forall a. Maybe a
Nothing
  }

-- |A PostgreSQL literal identifier, generally corresponding to the \"name\" type (63-byte strings), but as it would be entered in a query, so may include double-quoting for special characters or schema-qualification.
newtype PGName = PGName
  { PGName -> [Word8]
pgNameBytes :: [Word8] -- ^Raw bytes of the identifier (should really be a 'BS.ByteString', but we need a working 'Data' instance for annotations).
  }
  deriving (PGName -> PGName -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PGName -> PGName -> Bool
$c/= :: PGName -> PGName -> Bool
== :: PGName -> PGName -> Bool
$c== :: PGName -> PGName -> Bool
Eq, Eq PGName
PGName -> PGName -> Bool
PGName -> PGName -> Ordering
PGName -> PGName -> PGName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PGName -> PGName -> PGName
$cmin :: PGName -> PGName -> PGName
max :: PGName -> PGName -> PGName
$cmax :: PGName -> PGName -> PGName
>= :: PGName -> PGName -> Bool
$c>= :: PGName -> PGName -> Bool
> :: PGName -> PGName -> Bool
$c> :: PGName -> PGName -> Bool
<= :: PGName -> PGName -> Bool
$c<= :: PGName -> PGName -> Bool
< :: PGName -> PGName -> Bool
$c< :: PGName -> PGName -> Bool
compare :: PGName -> PGName -> Ordering
$ccompare :: PGName -> PGName -> Ordering
Ord, Typeable, Typeable PGName
PGName -> DataType
PGName -> Constr
(forall b. Data b => b -> b) -> PGName -> PGName
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> PGName -> u
forall u. (forall d. Data d => d -> u) -> PGName -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> PGName -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> PGName -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> PGName -> m PGName
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PGName -> m PGName
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c PGName
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> PGName -> c PGName
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c PGName)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c PGName)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PGName -> m PGName
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PGName -> m PGName
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PGName -> m PGName
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PGName -> m PGName
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> PGName -> m PGName
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> PGName -> m PGName
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> PGName -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> PGName -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> PGName -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> PGName -> [u]
gmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> PGName -> r
$cgmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> PGName -> r
gmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> PGName -> r
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> PGName -> r
gmapT :: (forall b. Data b => b -> b) -> PGName -> PGName
$cgmapT :: (forall b. Data b => b -> b) -> PGName -> PGName
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c PGName)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c PGName)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c PGName)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c PGName)
dataTypeOf :: PGName -> DataType
$cdataTypeOf :: PGName -> DataType
toConstr :: PGName -> Constr
$ctoConstr :: PGName -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c PGName
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c PGName
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> PGName -> c PGName
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> PGName -> c PGName
Data)

-- |The literal identifier as used in a query.
pgNameBS :: PGName -> BS.ByteString
pgNameBS :: PGName -> ByteString
pgNameBS = [Word8] -> ByteString
BS.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGName -> [Word8]
pgNameBytes

-- |Applies utf-8 encoding.
instance IsString PGName where
  fromString :: String -> PGName
fromString = [Word8] -> PGName
PGName forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Word8]
UTF8.encode
-- |Unquoted 'pgNameString'.
instance Show PGName where
  show :: PGName -> String
show = PGName -> String
pgNameString

-- |Reverses the 'IsString' instantce.
pgNameString :: PGName -> String
pgNameString :: PGName -> String
pgNameString = [Word8] -> String
UTF8.decode forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGName -> [Word8]
pgNameBytes

-- |A proxy type for PostgreSQL types.  The type argument should be an (internal) name of a database type, as per @format_type(OID)@ (usually the same as @\\dT+@).
-- When the type's namespace (schema) is not in @search_path@, this will be explicitly qualified, so you should be sure to have a consistent @search_path@ for all database connections.
-- The underlying 'Symbol' should be considered a lifted 'PGName'.
data PGTypeID (t :: Symbol) = PGTypeProxy

-- |A valid PostgreSQL type, its metadata, and corresponding Haskell representation.
-- For conversion the other way (from Haskell type to PostgreSQL), see 'Database.PostgreSQL.Typed.Dynamic.PGRep'.
-- Unfortunately any instances of this will be orphans.
class (KnownSymbol t
#if __GLASGOW_HASKELL__ >= 800
    , PGParameter t (PGVal t), PGColumn t (PGVal t)
#endif
    ) => PGType t where
  -- |The default, native Haskell representation of this type, which should be as close as possible to the PostgreSQL representation.
  type PGVal t :: *
  -- |The string name of this type: specialized version of 'symbolVal'.
  pgTypeName :: PGTypeID t -> PGName
  pgTypeName = forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal
  -- |Does this type support binary decoding?
  -- If so, 'pgDecodeBinary' must be implemented for every 'PGColumn' instance of this type.
  pgBinaryColumn :: PGTypeEnv -> PGTypeID t -> Bool
  pgBinaryColumn PGTypeEnv
_ PGTypeID t
_ = Bool
False

-- |A @PGParameter t a@ instance describes how to encode a PostgreSQL type @t@ from @a@.
class PGType t => PGParameter t a where
  -- |Encode a value to a PostgreSQL text representation.
  pgEncode :: PGTypeID t -> a -> PGTextValue
  -- |Encode a value to a (quoted) literal value for use in SQL statements.
  -- Defaults to a quoted version of 'pgEncode'
  pgLiteral :: PGTypeID t -> a -> BS.ByteString
  pgLiteral PGTypeID t
t = ByteString -> ByteString
pgQuote forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgEncode PGTypeID t
t
  -- |Encode a value to a PostgreSQL representation.
  -- Defaults to the text representation by pgEncode
  pgEncodeValue :: PGTypeEnv -> PGTypeID t -> a -> PGValue
  pgEncodeValue PGTypeEnv
_ PGTypeID t
t = ByteString -> PGValue
PGTextValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgEncode PGTypeID t
t

-- |A @PGColumn t a@ instance describes how te decode a PostgreSQL type @t@ to @a@.
class PGType t => PGColumn t a where
  -- |Decode the PostgreSQL text representation into a value.
  pgDecode :: PGTypeID t -> PGTextValue -> a
  -- |Decode the PostgreSQL binary representation into a value.
  -- Only needs to be implemented if 'pgBinaryColumn' is true.
  pgDecodeBinary :: PGTypeEnv -> PGTypeID t -> PGBinaryValue -> a
  pgDecodeBinary PGTypeEnv
_ PGTypeID t
t ByteString
_ = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"pgDecodeBinary " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: Symbol). PGType t => PGTypeID t -> PGName
pgTypeName PGTypeID t
t) forall a. [a] -> [a] -> [a]
++ String
": not supported"
  pgDecodeValue :: PGTypeEnv -> PGTypeID t -> PGValue -> a
  pgDecodeValue PGTypeEnv
_ PGTypeID t
t (PGTextValue ByteString
v) = forall (t :: Symbol) a.
PGColumn t a =>
PGTypeID t -> ByteString -> a
pgDecode PGTypeID t
t ByteString
v
  pgDecodeValue PGTypeEnv
e PGTypeID t
t (PGBinaryValue ByteString
v) = forall (t :: Symbol) a.
PGColumn t a =>
PGTypeEnv -> PGTypeID t -> ByteString -> a
pgDecodeBinary PGTypeEnv
e PGTypeID t
t ByteString
v
  pgDecodeValue PGTypeEnv
_ PGTypeID t
t PGValue
PGNullValue = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"NULL in " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: Symbol). PGType t => PGTypeID t -> PGName
pgTypeName PGTypeID t
t) forall a. [a] -> [a] -> [a]
++ String
" column (use Maybe or COALESCE)"

instance PGParameter t a => PGParameter t (Maybe a) where
  pgEncode :: PGTypeID t -> Maybe a -> ByteString
pgEncode PGTypeID t
t = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"pgEncode " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: Symbol). PGType t => PGTypeID t -> PGName
pgTypeName PGTypeID t
t) forall a. [a] -> [a] -> [a]
++ String
": Nothing") (forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgEncode PGTypeID t
t)
  pgLiteral :: PGTypeID t -> Maybe a -> ByteString
pgLiteral = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ByteString
BSC.pack String
"NULL") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgLiteral
  pgEncodeValue :: PGTypeEnv -> PGTypeID t -> Maybe a -> PGValue
pgEncodeValue PGTypeEnv
e = forall b a. b -> (a -> b) -> Maybe a -> b
maybe PGValue
PGNullValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Symbol) a.
PGParameter t a =>
PGTypeEnv -> PGTypeID t -> a -> PGValue
pgEncodeValue PGTypeEnv
e

instance PGColumn t a => PGColumn t (Maybe a) where
  pgDecode :: PGTypeID t -> ByteString -> Maybe a
pgDecode PGTypeID t
t = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Symbol) a.
PGColumn t a =>
PGTypeID t -> ByteString -> a
pgDecode PGTypeID t
t
  pgDecodeBinary :: PGTypeEnv -> PGTypeID t -> ByteString -> Maybe a
pgDecodeBinary PGTypeEnv
e PGTypeID t
t = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Symbol) a.
PGColumn t a =>
PGTypeEnv -> PGTypeID t -> ByteString -> a
pgDecodeBinary PGTypeEnv
e PGTypeID t
t
  pgDecodeValue :: PGTypeEnv -> PGTypeID t -> PGValue -> Maybe a
pgDecodeValue PGTypeEnv
_ PGTypeID t
_ PGValue
PGNullValue = forall a. Maybe a
Nothing
  pgDecodeValue PGTypeEnv
e PGTypeID t
t PGValue
v = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: Symbol) a.
PGColumn t a =>
PGTypeEnv -> PGTypeID t -> PGValue -> a
pgDecodeValue PGTypeEnv
e PGTypeID t
t PGValue
v

-- |Final parameter encoding function used when a (nullable) parameter is passed to a prepared query.
pgEncodeParameter :: PGParameter t a => PGTypeEnv -> PGTypeID t -> a -> PGValue
pgEncodeParameter :: forall (t :: Symbol) a.
PGParameter t a =>
PGTypeEnv -> PGTypeID t -> a -> PGValue
pgEncodeParameter = forall (t :: Symbol) a.
PGParameter t a =>
PGTypeEnv -> PGTypeID t -> a -> PGValue
pgEncodeValue

-- |Final parameter escaping function used when a (nullable) parameter is passed to be substituted into a simple query.
pgEscapeParameter :: PGParameter t a => PGTypeEnv -> PGTypeID t -> a -> BS.ByteString
pgEscapeParameter :: forall (t :: Symbol) a.
PGParameter t a =>
PGTypeEnv -> PGTypeID t -> a -> ByteString
pgEscapeParameter PGTypeEnv
_ = forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgLiteral

-- |Final column decoding function used for a nullable result value.
pgDecodeColumn :: PGColumn t (Maybe a) => PGTypeEnv -> PGTypeID t -> PGValue -> Maybe a
pgDecodeColumn :: forall (t :: Symbol) a.
PGColumn t (Maybe a) =>
PGTypeEnv -> PGTypeID t -> PGValue -> Maybe a
pgDecodeColumn = forall (t :: Symbol) a.
PGColumn t a =>
PGTypeEnv -> PGTypeID t -> PGValue -> a
pgDecodeValue

-- |Final column decoding function used for a non-nullable result value.
pgDecodeColumnNotNull :: PGColumn t a => PGTypeEnv -> PGTypeID t -> PGValue -> a
pgDecodeColumnNotNull :: forall (t :: Symbol) a.
PGColumn t a =>
PGTypeEnv -> PGTypeID t -> PGValue -> a
pgDecodeColumnNotNull = forall (t :: Symbol) a.
PGColumn t a =>
PGTypeEnv -> PGTypeID t -> PGValue -> a
pgDecodeValue


pgQuoteUnsafe :: BS.ByteString -> BS.ByteString
pgQuoteUnsafe :: ByteString -> ByteString
pgQuoteUnsafe = (ByteString -> Char -> ByteString
`BSC.snoc` Char
'\'') forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ByteString -> ByteString
BSC.cons Char
'\''

-- |Produce a SQL string literal by wrapping (and escaping) a string with single quotes.
pgQuote :: BS.ByteString -> BS.ByteString
pgQuote :: ByteString -> ByteString
pgQuote ByteString
s
  | Char
'\0' Char -> ByteString -> Bool
`BSC.elem` ByteString
s = forall a. HasCallStack => String -> a
error String
"pgQuote: unhandled null in literal"
  | Bool
otherwise = ByteString -> ByteString
pgQuoteUnsafe forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString] -> ByteString
BSC.intercalate (String -> ByteString
BSC.pack String
"''") forall a b. (a -> b) -> a -> b
$ Char -> ByteString -> [ByteString]
BSC.split Char
'\'' ByteString
s

-- |Shorthand for @'BSL.toStrict' . 'BSB.toLazyByteString'@
buildPGValue :: BSB.Builder -> BS.ByteString
buildPGValue :: Builder -> ByteString
buildPGValue = ByteString -> ByteString
BSL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BSB.toLazyByteString

-- |Double-quote a value (e.g., as an identifier).
-- Does not properly handle unicode escaping (yet).
pgDQuote :: BS.ByteString -> BSB.Builder
pgDQuote :: ByteString -> Builder
pgDQuote ByteString
s = Builder
dq forall a. Semigroup a => a -> a -> a
<> BoundedPrim Word8 -> ByteString -> Builder
BSBP.primMapByteStringBounded BoundedPrim Word8
ec ByteString
s forall a. Semigroup a => a -> a -> a
<> Builder
dq where
  dq :: Builder
dq = Char -> Builder
BSB.char7 Char
'"'
  ec :: BoundedPrim Word8
ec = forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
BSBP.condB (\Word8
c -> Word8
c forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'"' Bool -> Bool -> Bool
|| Word8
c forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'\\') BoundedPrim Word8
bs (forall a. FixedPrim a -> BoundedPrim a
BSBP.liftFixedToBounded FixedPrim Word8
BSBP.word8)
  bs :: BoundedPrim Word8
bs = forall a. FixedPrim a -> BoundedPrim a
BSBP.liftFixedToBounded forall a b. (a -> b) -> a -> b
$ ((,) Char
'\\') forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
BSBP.>$< (FixedPrim Char
BSBP.char7 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
BSBP.>*< FixedPrim Word8
BSBP.word8)

-- |Double-quote a value if it's \"\", \"null\", or contains any whitespace, \'\"\', \'\\\', or the characters given in the first argument.
pgDQuoteFrom :: [Char] -> BS.ByteString -> BSB.Builder
pgDQuoteFrom :: String -> ByteString -> Builder
pgDQuoteFrom String
unsafe ByteString
s
  | ByteString -> Bool
BS.null ByteString
s Bool -> Bool -> Bool
|| (Char -> Bool) -> ByteString -> Bool
BSC.any (\Char
c -> Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
|| Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
unsafe) ByteString
s Bool -> Bool -> Bool
|| (Char -> Char) -> ByteString -> ByteString
BSC.map Char -> Char
toLower ByteString
s forall a. Eq a => a -> a -> Bool
== String -> ByteString
BSC.pack String
"null" = ByteString -> Builder
pgDQuote ByteString
s
  | Bool
otherwise = ByteString -> Builder
BSB.byteString ByteString
s

-- |Parse double-quoted values ala 'pgDQuote'.
parsePGDQuote :: Bool -> [Char] -> (BS.ByteString -> Bool) -> P.Parser (Maybe BS.ByteString)
parsePGDQuote :: Bool -> String -> (ByteString -> Bool) -> Parser (Maybe ByteString)
parsePGDQuote Bool
blank String
unsafe ByteString -> Bool
isnul = (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString
q) forall a. Semigroup a => a -> a -> a
<> (ByteString -> Maybe ByteString
mnul forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString
uq) where
  q :: Parser ByteString ByteString
q = Char -> Parser Char
P.char Char
'"' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([ByteString] -> ByteString
BS.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString [ByteString]
qs)
  qs :: Parser ByteString [ByteString]
qs = do
    ByteString
p <- (Char -> Bool) -> Parser ByteString ByteString
P.takeTill (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\\')
    Char
e <- Parser Char
P.anyChar
    if Char
e forall a. Eq a => a -> a -> Bool
== Char
'"'
      then forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString
p]
      else do
        Word8
c <- Parser Word8
P.anyWord8
        (ByteString
p forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> ByteString
BS.singleton Word8
c forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString [ByteString]
qs
  uq :: Parser ByteString ByteString
uq = (if Bool
blank then (Char -> Bool) -> Parser ByteString ByteString
P.takeWhile else (Char -> Bool) -> Parser ByteString ByteString
P.takeWhile1) (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (Char
'"'forall a. a -> [a] -> [a]
:Char
'\\'forall a. a -> [a] -> [a]
:String
unsafe))
  mnul :: ByteString -> Maybe ByteString
mnul ByteString
s
    | ByteString -> Bool
isnul ByteString
s = forall a. Maybe a
Nothing
    | Bool
otherwise = forall a. a -> Maybe a
Just ByteString
s

#ifdef VERSION_postgresql_binary
binEnc :: BinEncoder a -> a -> BS.ByteString
binEnc :: forall a. BinEncoder a -> a -> ByteString
binEnc = forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)
#if MIN_VERSION_postgresql_binary(0,12,0)
  Encoding -> ByteString
BinE.encodingBytes

type BinDecoder = BinD.Value
type BinEncoder a = a -> BinE.Encoding
#else
  buildPGValue

type BinDecoder = BinD.Decoder
type BinEncoder a = BinE.Encoder a
#endif

binDec :: PGType t => BinDecoder a -> PGTypeID t -> PGBinaryValue -> a
binDec :: forall (t :: Symbol) a.
PGType t =>
BinDecoder a -> PGTypeID t -> ByteString -> a
binDec BinDecoder a
d PGTypeID t
t = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\Text
e -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"pgDecodeBinary " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: Symbol). PGType t => PGTypeID t -> PGName
pgTypeName PGTypeID t
t) forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
e) forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. 
#if MIN_VERSION_postgresql_binary(0,12,0)
  forall a. Value a -> ByteString -> Either Text a
BinD.valueParser
#else
  BinD.run
#endif
  BinDecoder a
d

#define BIN_COL pgBinaryColumn _ _ = True
#define BIN_ENC(F) pgEncodeValue _ _ = PGBinaryValue . binEnc (F)
#define BIN_DEC(F) pgDecodeBinary _ = binDec (F)
#else
#define BIN_COL
#define BIN_ENC(F)
#define BIN_DEC(F)
#endif

instance PGType "any" where
  type PGVal "any" = PGValue
instance PGType t => PGColumn t PGValue where
  pgDecode :: PGTypeID t -> ByteString -> PGValue
pgDecode PGTypeID t
_ = ByteString -> PGValue
PGTextValue
  pgDecodeBinary :: PGTypeEnv -> PGTypeID t -> ByteString -> PGValue
pgDecodeBinary PGTypeEnv
_ PGTypeID t
_ = ByteString -> PGValue
PGBinaryValue
  pgDecodeValue :: PGTypeEnv -> PGTypeID t -> PGValue -> PGValue
pgDecodeValue PGTypeEnv
_ PGTypeID t
_ = forall a. a -> a
id
instance PGParameter "any" PGValue where
  pgEncode :: PGTypeID "any" -> PGValue -> ByteString
pgEncode PGTypeID "any"
_ (PGTextValue ByteString
v) = ByteString
v
  pgEncode PGTypeID "any"
_ PGValue
PGNullValue = forall a. HasCallStack => String -> a
error String
"pgEncode any: NULL"
  pgEncode PGTypeID "any"
_ (PGBinaryValue ByteString
_) = forall a. HasCallStack => String -> a
error String
"pgEncode any: binary"
  pgEncodeValue :: PGTypeEnv -> PGTypeID "any" -> PGValue -> PGValue
pgEncodeValue PGTypeEnv
_ PGTypeID "any"
_ = forall a. a -> a
id

instance PGType "void" where
  type PGVal "void" = ()
instance PGParameter "void" () where
  pgEncode :: PGTypeID "void" -> () -> ByteString
pgEncode PGTypeID "void"
_ ()
_ = ByteString
BSC.empty
instance PGColumn "void" () where
  pgDecode :: PGTypeID "void" -> ByteString -> ()
pgDecode PGTypeID "void"
_ ByteString
_ = ()
  pgDecodeBinary :: PGTypeEnv -> PGTypeID "void" -> ByteString -> ()
pgDecodeBinary PGTypeEnv
_ PGTypeID "void"
_ ByteString
_ = ()
  pgDecodeValue :: PGTypeEnv -> PGTypeID "void" -> PGValue -> ()
pgDecodeValue PGTypeEnv
_ PGTypeID "void"
_ PGValue
_ = ()

instance PGType "boolean" where
  type PGVal "boolean" = Bool
  BIN_COL
instance PGParameter "boolean" Bool where
  pgEncode :: PGTypeID "boolean" -> Bool -> ByteString
pgEncode PGTypeID "boolean"
_ Bool
False = Char -> ByteString
BSC.singleton Char
'f'
  pgEncode PGTypeID "boolean"
_ Bool
True = Char -> ByteString
BSC.singleton Char
't'
  pgLiteral :: PGTypeID "boolean" -> Bool -> ByteString
pgLiteral PGTypeID "boolean"
_ Bool
False = String -> ByteString
BSC.pack String
"false"
  pgLiteral PGTypeID "boolean"
_ Bool
True = String -> ByteString
BSC.pack String
"true"
  BIN_ENC(BinE.bool)
instance PGColumn "boolean" Bool where
  pgDecode :: PGTypeID "boolean" -> ByteString -> Bool
pgDecode PGTypeID "boolean"
_ ByteString
s = case ByteString -> Char
BSC.head ByteString
s of
    Char
'f' -> Bool
False
    Char
't' -> Bool
True
    Char
c -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"pgDecode boolean: " forall a. [a] -> [a] -> [a]
++ [Char
c]
  BIN_DEC(BinD.bool)

type OID = Word32
instance PGType "oid" where
  type PGVal "oid" = OID
  BIN_COL
instance PGParameter "oid" OID where
  pgEncode :: PGTypeID "oid" -> OID -> ByteString
pgEncode PGTypeID "oid"
_ = String -> ByteString
BSC.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
  pgLiteral :: PGTypeID "oid" -> OID -> ByteString
pgLiteral = forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgEncode
  BIN_ENC(BinE.int4_word32)
instance PGColumn "oid" OID where
  pgDecode :: PGTypeID "oid" -> ByteString -> OID
pgDecode PGTypeID "oid"
_ = forall a. Read a => String -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BSC.unpack
  BIN_DEC(BinD.int)

instance PGType "smallint" where
  type PGVal "smallint" = Int16
  BIN_COL
instance PGParameter "smallint" Int16 where
  pgEncode :: PGTypeID "smallint" -> Int16 -> ByteString
pgEncode PGTypeID "smallint"
_ = String -> ByteString
BSC.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
  pgLiteral :: PGTypeID "smallint" -> Int16 -> ByteString
pgLiteral = forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgEncode
  BIN_ENC(BinE.int2_int16)
instance PGColumn "smallint" Int16 where
  pgDecode :: PGTypeID "smallint" -> ByteString -> Int16
pgDecode PGTypeID "smallint"
_ = forall a. Read a => String -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BSC.unpack
  BIN_DEC(BinD.int)

instance PGType "integer" where 
  type PGVal "integer" = Int32
  BIN_COL
instance PGParameter "integer" Int32 where
  pgEncode :: PGTypeID "integer" -> Int32 -> ByteString
pgEncode PGTypeID "integer"
_ = String -> ByteString
BSC.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
  pgLiteral :: PGTypeID "integer" -> Int32 -> ByteString
pgLiteral = forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgEncode
  BIN_ENC(BinE.int4_int32)
instance PGColumn "integer" Int32 where
  pgDecode :: PGTypeID "integer" -> ByteString -> Int32
pgDecode PGTypeID "integer"
_ = forall a. Read a => String -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BSC.unpack
  BIN_DEC(BinD.int)

instance PGType "bigint" where
  type PGVal "bigint" = Int64
  BIN_COL
instance PGParameter "bigint" Int64 where
  pgEncode :: PGTypeID "bigint" -> Int64 -> ByteString
pgEncode PGTypeID "bigint"
_ = String -> ByteString
BSC.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
  pgLiteral :: PGTypeID "bigint" -> Int64 -> ByteString
pgLiteral = forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgEncode
  BIN_ENC(BinE.int8_int64)
instance PGColumn "bigint" Int64 where
  pgDecode :: PGTypeID "bigint" -> ByteString -> Int64
pgDecode PGTypeID "bigint"
_ = forall a. Read a => String -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BSC.unpack
  BIN_DEC(BinD.int)

instance PGType "real" where
  type PGVal "real" = Float
  BIN_COL
instance PGParameter "real" Float where
  pgEncode :: PGTypeID "real" -> Float -> ByteString
pgEncode PGTypeID "real"
_ = String -> ByteString
BSC.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
  pgLiteral :: PGTypeID "real" -> Float -> ByteString
pgLiteral = forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgEncode
  BIN_ENC(BinE.float4)
instance PGColumn "real" Float where
  pgDecode :: PGTypeID "real" -> ByteString -> Float
pgDecode PGTypeID "real"
_ = forall a. Read a => String -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BSC.unpack
  BIN_DEC(BinD.float4)
instance PGColumn "real" Double where
  pgDecode :: PGTypeID "real" -> ByteString -> Double
pgDecode PGTypeID "real"
_ = forall a. Read a => String -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BSC.unpack
  BIN_DEC(realToFrac <$> BinD.float4)

instance PGType "double precision" where
  type PGVal "double precision" = Double
  BIN_COL
instance PGParameter "double precision" Double where
  pgEncode :: PGTypeID "double precision" -> Double -> ByteString
pgEncode PGTypeID "double precision"
_ = String -> ByteString
BSC.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
  pgLiteral :: PGTypeID "double precision" -> Double -> ByteString
pgLiteral = forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgEncode
  BIN_ENC(BinE.float8)
instance PGParameter "double precision" Float where
  pgEncode :: PGTypeID "double precision" -> Float -> ByteString
pgEncode PGTypeID "double precision"
_ = String -> ByteString
BSC.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
  pgLiteral :: PGTypeID "double precision" -> Float -> ByteString
pgLiteral = forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgEncode
  BIN_ENC(BinE.float8 . realToFrac)
instance PGColumn "double precision" Double where
  pgDecode :: PGTypeID "double precision" -> ByteString -> Double
pgDecode PGTypeID "double precision"
_ = forall a. Read a => String -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BSC.unpack
  BIN_DEC(BinD.float8)

-- XXX need real encoding as text
-- but then no one should be using this type really...
instance PGType "\"char\"" where
  type PGVal "\"char\"" = Word8
  BIN_COL
instance PGParameter "\"char\"" Word8 where
  pgEncode :: PGTypeID "\"char\"" -> Word8 -> ByteString
pgEncode PGTypeID "\"char\""
_ = Word8 -> ByteString
BS.singleton
  pgEncodeValue :: PGTypeEnv -> PGTypeID "\"char\"" -> Word8 -> PGValue
pgEncodeValue PGTypeEnv
_ PGTypeID "\"char\""
_ = ByteString -> PGValue
PGBinaryValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString
BS.singleton
instance PGColumn "\"char\"" Word8 where
  pgDecode :: PGTypeID "\"char\"" -> ByteString -> Word8
pgDecode PGTypeID "\"char\""
_ = HasCallStack => ByteString -> Word8
BS.head
  pgDecodeBinary :: PGTypeEnv -> PGTypeID "\"char\"" -> ByteString -> Word8
pgDecodeBinary PGTypeEnv
_ PGTypeID "\"char\""
_ = HasCallStack => ByteString -> Word8
BS.head
instance PGParameter "\"char\"" Char where
  pgEncode :: PGTypeID "\"char\"" -> Char -> ByteString
pgEncode PGTypeID "\"char\""
_ = Char -> ByteString
BSC.singleton
  pgEncodeValue :: PGTypeEnv -> PGTypeID "\"char\"" -> Char -> PGValue
pgEncodeValue PGTypeEnv
_ PGTypeID "\"char\""
_ = ByteString -> PGValue
PGBinaryValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ByteString
BSC.singleton
instance PGColumn "\"char\"" Char where
  pgDecode :: PGTypeID "\"char\"" -> ByteString -> Char
pgDecode PGTypeID "\"char\""
_ = ByteString -> Char
BSC.head
  pgDecodeBinary :: PGTypeEnv -> PGTypeID "\"char\"" -> ByteString -> Char
pgDecodeBinary PGTypeEnv
_ PGTypeID "\"char\""
_ = ByteString -> Char
BSC.head


class PGType t => PGStringType t

instance PGStringType t => PGParameter t String where
  pgEncode :: PGTypeID t -> String -> ByteString
pgEncode PGTypeID t
_ = String -> ByteString
BSU.fromString
  BIN_ENC(BinE.text_strict . T.pack)
instance PGStringType t => PGColumn t String where
  pgDecode :: PGTypeID t -> ByteString -> String
pgDecode PGTypeID t
_ = ByteString -> String
BSU.toString
  BIN_DEC(T.unpack <$> BinD.text_strict)

instance
#if __GLASGOW_HASKELL__ >= 710
    {-# OVERLAPPABLE #-}
#endif
    PGStringType t => PGParameter t BS.ByteString where
  pgEncode :: PGTypeID t -> ByteString -> ByteString
pgEncode PGTypeID t
_ = forall a. a -> a
id
  BIN_ENC(BinE.text_strict . TE.decodeUtf8)
instance
#if __GLASGOW_HASKELL__ >= 710
    {-# OVERLAPPABLE #-}
#endif
    PGStringType t => PGColumn t BS.ByteString where
  pgDecode :: PGTypeID t -> ByteString -> ByteString
pgDecode PGTypeID t
_ = forall a. a -> a
id
  BIN_DEC(TE.encodeUtf8 <$> BinD.text_strict)

instance
#if __GLASGOW_HASKELL__ >= 710
    {-# OVERLAPPABLE #-}
#endif
    PGStringType t => PGParameter t PGName where
  pgEncode :: PGTypeID t -> PGName -> ByteString
pgEncode PGTypeID t
_ = PGName -> ByteString
pgNameBS
  BIN_ENC(BinE.text_strict . TE.decodeUtf8 . pgNameBS)
instance
#if __GLASGOW_HASKELL__ >= 710
    {-# OVERLAPPABLE #-}
#endif
    PGStringType t => PGColumn t PGName where
  pgDecode :: PGTypeID t -> ByteString -> PGName
pgDecode PGTypeID t
_ = [Word8] -> PGName
PGName forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack
  BIN_DEC(PGName PGTypeEnv
. BS.unpack . TE.encodeUtf8 <$> BinD.text_strict)

instance
#if __GLASGOW_HASKELL__ >= 710
    {-# OVERLAPPABLE #-}
#endif
    PGStringType t => PGParameter t BSL.ByteString where
  pgEncode :: PGTypeID t -> ByteString -> ByteString
pgEncode PGTypeID t
_ = ByteString -> ByteString
BSL.toStrict
  BIN_ENC(BinE.text_lazy . TLE.decodeUtf8)
instance
#if __GLASGOW_HASKELL__ >= 710
    {-# OVERLAPPABLE #-}
#endif
    PGStringType t => PGColumn t BSL.ByteString where
  pgDecode :: PGTypeID t -> ByteString -> ByteString
pgDecode PGTypeID t
_ = ByteString -> ByteString
BSL.fromStrict
  BIN_DEC(TLE.encodeUtf8 <$> BinD.text_lazy)

#ifdef VERSION_text
instance PGStringType t => PGParameter t T.Text where
  pgEncode :: PGTypeID t -> Text -> ByteString
pgEncode PGTypeID t
_ = Text -> ByteString
TE.encodeUtf8
  BIN_ENC(BinE.text_strict)
instance PGStringType t => PGColumn t T.Text where
  pgDecode :: PGTypeID t -> ByteString -> Text
pgDecode PGTypeID t
_ = ByteString -> Text
TE.decodeUtf8
  BIN_DEC(BinD.text_strict)

instance PGStringType t => PGParameter t TL.Text where
  pgEncode :: PGTypeID t -> Text -> ByteString
pgEncode PGTypeID t
_ = ByteString -> ByteString
BSL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TLE.encodeUtf8
  BIN_ENC(BinE.text_lazy)
instance PGStringType t => PGColumn t TL.Text where
  pgDecode :: PGTypeID t -> ByteString -> Text
pgDecode PGTypeID t
_ = Text -> Text
TL.fromStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8
  BIN_DEC(BinD.text_lazy)
#define PGVALSTRING T.Text
#else
#define PGVALSTRING String
#endif

instance PGType "text" where
  type PGVal "text" = PGVALSTRING
  BIN_COL
instance PGType "character varying" where
  type PGVal "character varying" = PGVALSTRING
  BIN_COL
instance PGType "name" where
  type PGVal "name" = PGVALSTRING
  BIN_COL
instance PGType "bpchar" where
  type PGVal "bpchar" = PGVALSTRING
  BIN_COL
instance PGStringType "text"
instance PGStringType "character varying"
instance PGStringType "name" -- limit 63 characters; not strictly textsend but essentially the same
instance PGStringType "bpchar" -- blank padded


encodeBytea :: BSB.Builder -> PGTextValue
encodeBytea :: Builder -> ByteString
encodeBytea Builder
h = Builder -> ByteString
buildPGValue forall a b. (a -> b) -> a -> b
$ String -> Builder
BSB.string7 String
"\\x" forall a. Semigroup a => a -> a -> a
<> Builder
h

decodeBytea :: PGTextValue -> [Word8]
decodeBytea :: ByteString -> [Word8]
decodeBytea ByteString
s
  | String
sm forall a. Eq a => a -> a -> Bool
/= String
"\\x" = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"pgDecode bytea: " forall a. [a] -> [a] -> [a]
++ String
sm
  | Bool
otherwise = [Word8] -> [Word8]
pd forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BS.unpack ByteString
d where
  (ByteString
m, ByteString
d) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
2 ByteString
s
  sm :: String
sm = ByteString -> String
BSC.unpack ByteString
m
  pd :: [Word8] -> [Word8]
pd [] = []
  pd (Word8
h:Word8
l:[Word8]
r) = (forall a. Bits a => a -> Int -> a
shiftL (Word8 -> Word8
unhex Word8
h) Int
4 forall a. Bits a => a -> a -> a
.|. Word8 -> Word8
unhex Word8
l) forall a. a -> [a] -> [a]
: [Word8] -> [Word8]
pd [Word8]
r
  pd [Word8
x] = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"pgDecode bytea: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word8
x
  unhex :: Word8 -> Word8
unhex = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
digitToInt forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Char
w2c

instance PGType "bytea" where
  type PGVal "bytea" = BS.ByteString
  BIN_COL
instance
#if __GLASGOW_HASKELL__ >= 710
    {-# OVERLAPPING #-}
#endif
    PGParameter "bytea" BSL.ByteString where
  pgEncode :: PGTypeID "bytea" -> ByteString -> ByteString
pgEncode PGTypeID "bytea"
_ = Builder -> ByteString
encodeBytea forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
BSB.lazyByteStringHex
  pgLiteral :: PGTypeID "bytea" -> ByteString -> ByteString
pgLiteral PGTypeID "bytea"
t = ByteString -> ByteString
pgQuoteUnsafe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgEncode PGTypeID "bytea"
t
  BIN_ENC(BinE.bytea_lazy)
instance
#if __GLASGOW_HASKELL__ >= 710
    {-# OVERLAPPING #-}
#endif
    PGColumn "bytea" BSL.ByteString where
  pgDecode :: PGTypeID "bytea" -> ByteString -> ByteString
pgDecode PGTypeID "bytea"
_ = [Word8] -> ByteString
BSL.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
decodeBytea
  BIN_DEC(BinD.bytea_lazy)
instance
#if __GLASGOW_HASKELL__ >= 710
    {-# OVERLAPPING #-}
#endif
    PGParameter "bytea" BS.ByteString where
  pgEncode :: PGTypeID "bytea" -> ByteString -> ByteString
pgEncode PGTypeID "bytea"
_ = Builder -> ByteString
encodeBytea forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
BSB.byteStringHex
  pgLiteral :: PGTypeID "bytea" -> ByteString -> ByteString
pgLiteral PGTypeID "bytea"
t = ByteString -> ByteString
pgQuoteUnsafe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgEncode PGTypeID "bytea"
t
  BIN_ENC(BinE.bytea_strict)
instance
#if __GLASGOW_HASKELL__ >= 710
    {-# OVERLAPPING #-}
#endif
    PGColumn "bytea" BS.ByteString where
  pgDecode :: PGTypeID "bytea" -> ByteString -> ByteString
pgDecode PGTypeID "bytea"
_ = [Word8] -> ByteString
BS.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
decodeBytea
  BIN_DEC(BinD.bytea_strict)

readTime :: Time.ParseTime t => String -> String -> t
readTime :: forall t. ParseTime t => String -> String -> t
readTime =
#if MIN_VERSION_time(1,5,0)
  forall t.
ParseTime t =>
Bool -> TimeLocale -> String -> String -> t
Time.parseTimeOrError Bool
False
#else
  Time.readTime
#endif
    TimeLocale
defaultTimeLocale

instance PGType "date" where
  type PGVal "date" = Time.Day
  BIN_COL
instance PGParameter "date" Time.Day where
  pgEncode :: PGTypeID "date" -> Day -> ByteString
pgEncode PGTypeID "date"
_ = String -> ByteString
BSC.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> String
Time.showGregorian
  pgLiteral :: PGTypeID "date" -> Day -> ByteString
pgLiteral PGTypeID "date"
t = ByteString -> ByteString
pgQuoteUnsafe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgEncode PGTypeID "date"
t
  BIN_ENC(BinE.date)
instance PGColumn "date" Time.Day where
  pgDecode :: PGTypeID "date" -> ByteString -> Day
pgDecode PGTypeID "date"
_ = forall t. ParseTime t => String -> String -> t
readTime String
"%F" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BSC.unpack
  BIN_DEC(BinD.date)

binColDatetime :: PGTypeEnv -> PGTypeID t -> Bool
#ifdef VERSION_postgresql_binary
binColDatetime :: forall (t :: Symbol). PGTypeEnv -> PGTypeID t -> Bool
binColDatetime PGTypeEnv{ pgIntegerDatetimes :: PGTypeEnv -> Maybe Bool
pgIntegerDatetimes = Just Bool
_ } PGTypeID t
_ = Bool
True
#endif
binColDatetime PGTypeEnv
_ PGTypeID t
_ = Bool
False

#ifdef VERSION_postgresql_binary
binEncDatetime :: PGParameter t a => BinEncoder a -> BinEncoder a -> PGTypeEnv -> PGTypeID t -> a -> PGValue
binEncDatetime :: forall (t :: Symbol) a.
PGParameter t a =>
BinEncoder a
-> BinEncoder a -> PGTypeEnv -> PGTypeID t -> a -> PGValue
binEncDatetime BinEncoder a
_ BinEncoder a
ff PGTypeEnv{ pgIntegerDatetimes :: PGTypeEnv -> Maybe Bool
pgIntegerDatetimes = Just Bool
False } PGTypeID t
_ = ByteString -> PGValue
PGBinaryValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. BinEncoder a -> a -> ByteString
binEnc BinEncoder a
ff
binEncDatetime BinEncoder a
fi BinEncoder a
_ PGTypeEnv{ pgIntegerDatetimes :: PGTypeEnv -> Maybe Bool
pgIntegerDatetimes = Just Bool
True } PGTypeID t
_ = ByteString -> PGValue
PGBinaryValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. BinEncoder a -> a -> ByteString
binEnc BinEncoder a
fi
binEncDatetime BinEncoder a
_ BinEncoder a
_ PGTypeEnv{ pgIntegerDatetimes :: PGTypeEnv -> Maybe Bool
pgIntegerDatetimes = Maybe Bool
Nothing } PGTypeID t
t = ByteString -> PGValue
PGTextValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgEncode PGTypeID t
t

binDecDatetime :: PGColumn t a => BinDecoder a -> BinDecoder a -> PGTypeEnv -> PGTypeID t -> PGBinaryValue -> a
binDecDatetime :: forall (t :: Symbol) a.
PGColumn t a =>
BinDecoder a
-> BinDecoder a -> PGTypeEnv -> PGTypeID t -> ByteString -> a
binDecDatetime BinDecoder a
_ BinDecoder a
ff PGTypeEnv{ pgIntegerDatetimes :: PGTypeEnv -> Maybe Bool
pgIntegerDatetimes = Just Bool
False } = forall (t :: Symbol) a.
PGType t =>
BinDecoder a -> PGTypeID t -> ByteString -> a
binDec BinDecoder a
ff
binDecDatetime BinDecoder a
fi BinDecoder a
_ PGTypeEnv{ pgIntegerDatetimes :: PGTypeEnv -> Maybe Bool
pgIntegerDatetimes = Just Bool
True } = forall (t :: Symbol) a.
PGType t =>
BinDecoder a -> PGTypeID t -> ByteString -> a
binDec BinDecoder a
fi
binDecDatetime BinDecoder a
_ BinDecoder a
_ PGTypeEnv{ pgIntegerDatetimes :: PGTypeEnv -> Maybe Bool
pgIntegerDatetimes = Maybe Bool
Nothing } = forall a. HasCallStack => String -> a
error String
"pgDecodeBinary: unknown integer_datetimes value"
#endif

-- PostgreSQL uses "[+-]HH[:MM]" timezone offsets, while "%z" uses "+HHMM" by default.
-- readTime can successfully parse both formats, but PostgreSQL needs the colon.
fixTZ :: String -> String
fixTZ :: ShowS
fixTZ String
"" = String
""
fixTZ [Char
'+',Char
h1,Char
h2] | Char -> Bool
isDigit Char
h1 Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
h2 = [Char
'+',Char
h1,Char
h2,Char
':',Char
'0',Char
'0']
fixTZ [Char
'-',Char
h1,Char
h2] | Char -> Bool
isDigit Char
h1 Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
h2 = [Char
'-',Char
h1,Char
h2,Char
':',Char
'0',Char
'0']
fixTZ [Char
'+',Char
h1,Char
h2,Char
m1,Char
m2] | Char -> Bool
isDigit Char
h1 Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
h2 Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
m1 Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
m2 = [Char
'+',Char
h1,Char
h2,Char
':',Char
m1,Char
m2]
fixTZ [Char
'-',Char
h1,Char
h2,Char
m1,Char
m2] | Char -> Bool
isDigit Char
h1 Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
h2 Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
m1 Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
m2 = [Char
'-',Char
h1,Char
h2,Char
':',Char
m1,Char
m2]
fixTZ (Char
c:String
s) = Char
cforall a. a -> [a] -> [a]
:ShowS
fixTZ String
s

instance PGType "time without time zone" where
  type PGVal "time without time zone" = Time.TimeOfDay
  pgBinaryColumn :: PGTypeEnv -> PGTypeID "time without time zone" -> Bool
pgBinaryColumn = forall (t :: Symbol). PGTypeEnv -> PGTypeID t -> Bool
binColDatetime
instance PGParameter "time without time zone" Time.TimeOfDay where
  pgEncode :: PGTypeID "time without time zone" -> TimeOfDay -> ByteString
pgEncode PGTypeID "time without time zone"
_ = String -> ByteString
BSC.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. FormatTime t => TimeLocale -> String -> t -> String
Time.formatTime TimeLocale
defaultTimeLocale String
"%T%Q"
  pgLiteral :: PGTypeID "time without time zone" -> TimeOfDay -> ByteString
pgLiteral PGTypeID "time without time zone"
t = ByteString -> ByteString
pgQuoteUnsafe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgEncode PGTypeID "time without time zone"
t
#ifdef VERSION_postgresql_binary
  pgEncodeValue :: PGTypeEnv
-> PGTypeID "time without time zone" -> TimeOfDay -> PGValue
pgEncodeValue = forall (t :: Symbol) a.
PGParameter t a =>
BinEncoder a
-> BinEncoder a -> PGTypeEnv -> PGTypeID t -> a -> PGValue
binEncDatetime TimeOfDay -> Encoding
BinE.time_int TimeOfDay -> Encoding
BinE.time_float
#endif
instance PGColumn "time without time zone" Time.TimeOfDay where
  pgDecode :: PGTypeID "time without time zone" -> ByteString -> TimeOfDay
pgDecode PGTypeID "time without time zone"
_ = forall t. ParseTime t => String -> String -> t
readTime String
"%T%Q" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BSC.unpack
#ifdef VERSION_postgresql_binary
  pgDecodeBinary :: PGTypeEnv
-> PGTypeID "time without time zone" -> ByteString -> TimeOfDay
pgDecodeBinary = forall (t :: Symbol) a.
PGColumn t a =>
BinDecoder a
-> BinDecoder a -> PGTypeEnv -> PGTypeID t -> ByteString -> a
binDecDatetime Value TimeOfDay
BinD.time_int Value TimeOfDay
BinD.time_float
#endif

instance PGType "time with time zone" where
  type PGVal "time with time zone" = (Time.TimeOfDay, Time.TimeZone)
  pgBinaryColumn :: PGTypeEnv -> PGTypeID "time with time zone" -> Bool
pgBinaryColumn = forall (t :: Symbol). PGTypeEnv -> PGTypeID t -> Bool
binColDatetime
instance PGParameter "time with time zone" (Time.TimeOfDay, Time.TimeZone) where
  pgEncode :: PGTypeID "time with time zone"
-> (TimeOfDay, TimeZone) -> ByteString
pgEncode PGTypeID "time with time zone"
_ (TimeOfDay
t, TimeZone
z) = String -> ByteString
BSC.pack forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> String -> t -> String
Time.formatTime TimeLocale
defaultTimeLocale String
"%T%Q" TimeOfDay
t forall a. [a] -> [a] -> [a]
++ ShowS
fixTZ (forall t. FormatTime t => TimeLocale -> String -> t -> String
Time.formatTime TimeLocale
defaultTimeLocale String
"%z" TimeZone
z)
  pgLiteral :: PGTypeID "time with time zone"
-> (TimeOfDay, TimeZone) -> ByteString
pgLiteral PGTypeID "time with time zone"
t = ByteString -> ByteString
pgQuoteUnsafe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgEncode PGTypeID "time with time zone"
t
#ifdef VERSION_postgresql_binary
  pgEncodeValue :: PGTypeEnv
-> PGTypeID "time with time zone"
-> (TimeOfDay, TimeZone)
-> PGValue
pgEncodeValue = forall (t :: Symbol) a.
PGParameter t a =>
BinEncoder a
-> BinEncoder a -> PGTypeEnv -> PGTypeID t -> a -> PGValue
binEncDatetime (TimeOfDay, TimeZone) -> Encoding
BinE.timetz_int (TimeOfDay, TimeZone) -> Encoding
BinE.timetz_float
#endif
instance PGColumn "time with time zone" (Time.TimeOfDay, Time.TimeZone) where
  pgDecode :: PGTypeID "time with time zone"
-> ByteString -> (TimeOfDay, TimeZone)
pgDecode PGTypeID "time with time zone"
_ = (LocalTime -> TimeOfDay
Time.localTimeOfDay forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZonedTime -> LocalTime
Time.zonedTimeToLocalTime forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ZonedTime -> TimeZone
Time.zonedTimeZone) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. ParseTime t => String -> String -> t
readTime String
"%T%Q%z" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
fixTZ forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BSC.unpack
#ifdef VERSION_postgresql_binary
  pgDecodeBinary :: PGTypeEnv
-> PGTypeID "time with time zone"
-> ByteString
-> (TimeOfDay, TimeZone)
pgDecodeBinary = forall (t :: Symbol) a.
PGColumn t a =>
BinDecoder a
-> BinDecoder a -> PGTypeEnv -> PGTypeID t -> ByteString -> a
binDecDatetime Value (TimeOfDay, TimeZone)
BinD.timetz_int Value (TimeOfDay, TimeZone)
BinD.timetz_float
#endif

instance PGType "timestamp without time zone" where
  type PGVal "timestamp without time zone" = Time.LocalTime
  pgBinaryColumn :: PGTypeEnv -> PGTypeID "timestamp without time zone" -> Bool
pgBinaryColumn = forall (t :: Symbol). PGTypeEnv -> PGTypeID t -> Bool
binColDatetime
instance PGParameter "timestamp without time zone" Time.LocalTime where
  pgEncode :: PGTypeID "timestamp without time zone" -> LocalTime -> ByteString
pgEncode PGTypeID "timestamp without time zone"
_ = String -> ByteString
BSC.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. FormatTime t => TimeLocale -> String -> t -> String
Time.formatTime TimeLocale
defaultTimeLocale String
"%F %T%Q"
  pgLiteral :: PGTypeID "timestamp without time zone" -> LocalTime -> ByteString
pgLiteral PGTypeID "timestamp without time zone"
t = ByteString -> ByteString
pgQuoteUnsafe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgEncode PGTypeID "timestamp without time zone"
t
#ifdef VERSION_postgresql_binary
  pgEncodeValue :: PGTypeEnv
-> PGTypeID "timestamp without time zone" -> LocalTime -> PGValue
pgEncodeValue = forall (t :: Symbol) a.
PGParameter t a =>
BinEncoder a
-> BinEncoder a -> PGTypeEnv -> PGTypeID t -> a -> PGValue
binEncDatetime LocalTime -> Encoding
BinE.timestamp_int LocalTime -> Encoding
BinE.timestamp_float
#endif
instance PGColumn "timestamp without time zone" Time.LocalTime where
  pgDecode :: PGTypeID "timestamp without time zone" -> ByteString -> LocalTime
pgDecode PGTypeID "timestamp without time zone"
_ = forall t. ParseTime t => String -> String -> t
readTime String
"%F %T%Q" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BSC.unpack
#ifdef VERSION_postgresql_binary
  pgDecodeBinary :: PGTypeEnv
-> PGTypeID "timestamp without time zone"
-> ByteString
-> LocalTime
pgDecodeBinary = forall (t :: Symbol) a.
PGColumn t a =>
BinDecoder a
-> BinDecoder a -> PGTypeEnv -> PGTypeID t -> ByteString -> a
binDecDatetime Value LocalTime
BinD.timestamp_int Value LocalTime
BinD.timestamp_float
#endif

instance PGType "timestamp with time zone" where
  type PGVal "timestamp with time zone" = Time.UTCTime
  pgBinaryColumn :: PGTypeEnv -> PGTypeID "timestamp with time zone" -> Bool
pgBinaryColumn = forall (t :: Symbol). PGTypeEnv -> PGTypeID t -> Bool
binColDatetime
instance PGParameter "timestamp with time zone" Time.UTCTime where
  pgEncode :: PGTypeID "timestamp with time zone" -> UTCTime -> ByteString
pgEncode PGTypeID "timestamp with time zone"
_ = String -> ByteString
BSC.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
fixTZ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. FormatTime t => TimeLocale -> String -> t -> String
Time.formatTime TimeLocale
defaultTimeLocale String
"%F %T%Q%z"
  -- pgLiteral t = pgQuoteUnsafe . pgEncode t
#ifdef VERSION_postgresql_binary
  pgEncodeValue :: PGTypeEnv
-> PGTypeID "timestamp with time zone" -> UTCTime -> PGValue
pgEncodeValue = forall (t :: Symbol) a.
PGParameter t a =>
BinEncoder a
-> BinEncoder a -> PGTypeEnv -> PGTypeID t -> a -> PGValue
binEncDatetime UTCTime -> Encoding
BinE.timestamptz_int UTCTime -> Encoding
BinE.timestamptz_float
#endif
instance PGColumn "timestamp with time zone" Time.UTCTime where
  pgDecode :: PGTypeID "timestamp with time zone" -> ByteString -> UTCTime
pgDecode PGTypeID "timestamp with time zone"
_ = forall t. ParseTime t => String -> String -> t
readTime String
"%F %T%Q%z" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
fixTZ forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BSC.unpack
#ifdef VERSION_postgresql_binary
  pgDecodeBinary :: PGTypeEnv
-> PGTypeID "timestamp with time zone" -> ByteString -> UTCTime
pgDecodeBinary = forall (t :: Symbol) a.
PGColumn t a =>
BinDecoder a
-> BinDecoder a -> PGTypeEnv -> PGTypeID t -> ByteString -> a
binDecDatetime Value UTCTime
BinD.timestamptz_int Value UTCTime
BinD.timestamptz_float
#endif

instance PGType "interval" where
  type PGVal "interval" = Time.DiffTime
  pgBinaryColumn :: PGTypeEnv -> PGTypeID "interval" -> Bool
pgBinaryColumn = forall (t :: Symbol). PGTypeEnv -> PGTypeID t -> Bool
binColDatetime
instance PGParameter "interval" Time.DiffTime where
  pgEncode :: PGTypeID "interval" -> DiffTime -> ByteString
pgEncode PGTypeID "interval"
_ = String -> ByteString
BSC.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
  pgLiteral :: PGTypeID "interval" -> DiffTime -> ByteString
pgLiteral PGTypeID "interval"
t = ByteString -> ByteString
pgQuoteUnsafe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgEncode PGTypeID "interval"
t
#ifdef VERSION_postgresql_binary
  pgEncodeValue :: PGTypeEnv -> PGTypeID "interval" -> DiffTime -> PGValue
pgEncodeValue = forall (t :: Symbol) a.
PGParameter t a =>
BinEncoder a
-> BinEncoder a -> PGTypeEnv -> PGTypeID t -> a -> PGValue
binEncDatetime DiffTime -> Encoding
BinE.interval_int DiffTime -> Encoding
BinE.interval_float
#endif
-- |Representation of DiffTime as interval.
-- PostgreSQL stores months and days separately in intervals, but DiffTime does not.
-- We collapse all interval fields into seconds
instance PGColumn "interval" Time.DiffTime where
  pgDecode :: PGTypeID "interval" -> ByteString -> DiffTime
pgDecode PGTypeID "interval"
_ ByteString
a = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"pgDecode interval (" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ (String
"): " forall a. [a] -> [a] -> [a]
++ ByteString -> String
BSC.unpack ByteString
a))) forall a b. (Real a, Fractional b) => a -> b
realToFrac forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> ByteString -> Either String a
P.parseOnly Parser ByteString Scientific
ps ByteString
a where
    ps :: Parser ByteString Scientific
ps = do
      Char
_ <- Char -> Parser Char
P.char Char
'P'
      Scientific
d <- [(Char, Scientific)] -> Parser ByteString Scientific
units [(Char
'Y', Scientific
12forall a. Num a => a -> a -> a
*Scientific
month), (Char
'M', Scientific
month), (Char
'W', Scientific
7forall a. Num a => a -> a -> a
*Scientific
day), (Char
'D', Scientific
day)]
      ((Scientific
d forall a. Num a => a -> a -> a
+) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Scientific
pt) forall a. Semigroup a => a -> a -> a
<> (Scientific
d forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall t. Chunk t => Parser t ()
P.endOfInput)
    pt :: Parser ByteString Scientific
pt = do
      Char
_ <- Char -> Parser Char
P.char Char
'T'
      Scientific
t <- [(Char, Scientific)] -> Parser ByteString Scientific
units [(Char
'H', Scientific
3600), (Char
'M', Scientific
60), (Char
'S', Scientific
1)]
      forall t. Chunk t => Parser t ()
P.endOfInput
      forall (m :: * -> *) a. Monad m => a -> m a
return Scientific
t
    units :: [(Char, Scientific)] -> Parser ByteString Scientific
units [(Char, Scientific)]
l = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many' forall a b. (a -> b) -> a -> b
$ do
      Scientific
x <- forall a. Num a => Parser a -> Parser a
P.signed Parser ByteString Scientific
P.scientific
      Scientific
u <- forall (f :: * -> *) a. Alternative f => [f a] -> f a
P.choice forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Char
c, Scientific
u) -> Scientific
u forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Char
P.char Char
c) [(Char, Scientific)]
l
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Scientific
x forall a. Num a => a -> a -> a
* Scientific
u
    day :: Scientific
day = Scientific
86400
    month :: Scientific
month = Scientific
2629746
#ifdef VERSION_postgresql_binary
  pgDecodeBinary :: PGTypeEnv -> PGTypeID "interval" -> ByteString -> DiffTime
pgDecodeBinary = forall (t :: Symbol) a.
PGColumn t a =>
BinDecoder a
-> BinDecoder a -> PGTypeEnv -> PGTypeID t -> ByteString -> a
binDecDatetime Value DiffTime
BinD.interval_int Value DiffTime
BinD.interval_float
#endif

instance PGType "numeric" where
  type PGVal "numeric" = 
#ifdef VERSION_scientific
    Scientific
#else
    Rational
#endif
  BIN_COL
instance PGParameter "numeric" Rational where
  pgEncode :: PGTypeID "numeric" -> Rational -> ByteString
pgEncode PGTypeID "numeric"
_ Rational
r
    | forall a. Ratio a -> a
denominator Rational
r forall a. Eq a => a -> a -> Bool
== Integer
0 = String -> ByteString
BSC.pack String
"NaN" -- this can't happen
    | Bool
otherwise = String -> ByteString
BSC.pack forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
30 (Rational -> String
showRational (Rational
r forall a. Fractional a => a -> a -> a
/ (Rational
10 forall a b. (Fractional a, Integral b) => a -> b -> a
^^ Int
e))) forall a. [a] -> [a] -> [a]
++ Char
'e' forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show Int
e where
    e :: Int
e = forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ forall a. Floating a => a -> a -> a
logBase (Double
10 :: Double) forall a b. (a -> b) -> a -> b
$ forall a. Fractional a => Rational -> a
fromRational forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a
abs Rational
r :: Int -- not great, and arbitrarily truncate somewhere
  pgLiteral :: PGTypeID "numeric" -> Rational -> ByteString
pgLiteral PGTypeID "numeric"
_ Rational
r
    | forall a. Ratio a -> a
denominator Rational
r forall a. Eq a => a -> a -> Bool
== Integer
0 = String -> ByteString
BSC.pack String
"'NaN'" -- this can't happen
    | Bool
otherwise = String -> ByteString
BSC.pack forall a b. (a -> b) -> a -> b
$ Char
'(' forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show (forall a. Ratio a -> a
numerator Rational
r) forall a. [a] -> [a] -> [a]
++ Char
'/' forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show (forall a. Ratio a -> a
denominator Rational
r) forall a. [a] -> [a] -> [a]
++ String
"::numeric)"
  BIN_ENC(BinE.numeric . realToFrac)
-- |High-precision representation of Rational as numeric.
-- Unfortunately, numeric has an NaN, while Rational does not.
-- NaN numeric values will produce exceptions.
instance PGColumn "numeric" Rational where
  pgDecode :: PGTypeID "numeric" -> ByteString -> Rational
pgDecode PGTypeID "numeric"
_ ByteString
bs
    | String
s forall a. Eq a => a -> a -> Bool
== String
"NaN" = Integer
0 forall a. Integral a => a -> a -> Ratio a
% Integer
0 -- this won't work
    | Bool
otherwise = [(Rational, String)] -> Rational
ur forall a b. (a -> b) -> a -> b
$ forall a. RealFrac a => ReadS a
readFloat String
s where
    ur :: [(Rational, String)] -> Rational
ur [(Rational
x,String
"")] = Rational
x
    ur [(Rational, String)]
_ = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"pgDecode numeric: " forall a. [a] -> [a] -> [a]
++ String
s
    s :: String
s = ByteString -> String
BSC.unpack ByteString
bs
  BIN_DEC(realToFrac <$> BinD.numeric)

-- This will produce infinite(-precision) strings
showRational :: Rational -> String
showRational :: Rational -> String
showRational Rational
r = forall a. Show a => a -> String
show (Integer
ri :: Integer) forall a. [a] -> [a] -> [a]
++ Char
'.' forall a. a -> [a] -> [a]
: forall {t}. RealFrac t => t -> String
frac (forall a. Num a => a -> a
abs Rational
rf) where
  (Integer
ri, Rational
rf) = forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction Rational
r
  frac :: t -> String
frac t
0 = String
""
  frac t
f = Int -> Char
intToDigit Int
i forall a. a -> [a] -> [a]
: t -> String
frac t
f' where (Int
i, t
f') = forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction (t
10 forall a. Num a => a -> a -> a
* t
f)

#ifdef VERSION_scientific
instance PGParameter "numeric" Scientific where
  pgEncode :: PGTypeID "numeric" -> Scientific -> ByteString
pgEncode PGTypeID "numeric"
_ = String -> ByteString
BSC.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
  pgLiteral :: PGTypeID "numeric" -> Scientific -> ByteString
pgLiteral = forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgEncode
  BIN_ENC(BinE.numeric)
instance PGColumn "numeric" Scientific where
  pgDecode :: PGTypeID "numeric" -> ByteString -> Scientific
pgDecode PGTypeID "numeric"
_ = forall a. Read a => String -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BSC.unpack
  BIN_DEC(BinD.numeric)
#endif

#ifdef VERSION_uuid
instance PGType "uuid" where
  type PGVal "uuid" = UUID.UUID
  BIN_COL
instance PGParameter "uuid" UUID.UUID where
  pgEncode :: PGTypeID "uuid" -> UUID -> ByteString
pgEncode PGTypeID "uuid"
_ = UUID -> ByteString
UUID.toASCIIBytes
  pgLiteral :: PGTypeID "uuid" -> UUID -> ByteString
pgLiteral PGTypeID "uuid"
t = ByteString -> ByteString
pgQuoteUnsafe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgEncode PGTypeID "uuid"
t
  BIN_ENC(BinE.uuid)
instance PGColumn "uuid" UUID.UUID where
  pgDecode :: PGTypeID "uuid" -> ByteString -> UUID
pgDecode PGTypeID "uuid"
_ ByteString
u = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"pgDecode uuid: " forall a. [a] -> [a] -> [a]
++ ByteString -> String
BSC.unpack ByteString
u) forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe UUID
UUID.fromASCIIBytes ByteString
u
  BIN_DEC(BinD.uuid)
#endif

-- |Generic class of composite (row or record) types.
newtype PGRecord = PGRecord [Maybe PGTextValue]
class PGType t => PGRecordType t
instance PGRecordType t => PGParameter t PGRecord where
  pgEncode :: PGTypeID t -> PGRecord -> ByteString
pgEncode PGTypeID t
_ (PGRecord [Maybe ByteString]
l) =
    Builder -> ByteString
buildPGValue forall a b. (a -> b) -> a -> b
$ Char -> Builder
BSB.char7 Char
'(' forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
intersperse (Char -> Builder
BSB.char7 Char
',') forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (String -> ByteString -> Builder
pgDQuoteFrom String
"(),")) [Maybe ByteString]
l) forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BSB.char7 Char
')'
  pgLiteral :: PGTypeID t -> PGRecord -> ByteString
pgLiteral PGTypeID t
_ (PGRecord [Maybe ByteString]
l) =
    String -> ByteString
BSC.pack String
"ROW(" forall a. Semigroup a => a -> a -> a
<> ByteString -> [ByteString] -> ByteString
BS.intercalate (Char -> ByteString
BSC.singleton Char
',') (forall a b. (a -> b) -> [a] -> [b]
map (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ByteString
BSC.pack String
"NULL") ByteString -> ByteString
pgQuote) [Maybe ByteString]
l) ByteString -> Char -> ByteString
`BSC.snoc` Char
')'
instance PGRecordType t => PGColumn t PGRecord where
  pgDecode :: PGTypeID t -> ByteString -> PGRecord
pgDecode PGTypeID t
_ ByteString
a = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"pgDecode record (" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ (String
"): " forall a. [a] -> [a] -> [a]
++ ByteString -> String
BSC.unpack ByteString
a))) [Maybe ByteString] -> PGRecord
PGRecord forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> ByteString -> Either String a
P.parseOnly Parser ByteString [Maybe ByteString]
pa ByteString
a where
    pa :: Parser ByteString [Maybe ByteString]
pa = Char -> Parser Char
P.char Char
'(' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
P.sepBy Parser (Maybe ByteString)
el (Char -> Parser Char
P.char Char
',') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
P.char Char
')' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
P.endOfInput
    el :: Parser (Maybe ByteString)
el = Bool -> String -> (ByteString -> Bool) -> Parser (Maybe ByteString)
parsePGDQuote Bool
True String
"()," ByteString -> Bool
BS.null

instance PGType "record" where
  type PGVal "record" = PGRecord
-- |The generic anonymous record type, as created by @ROW@.
-- In this case we can not know the types, and in fact, PostgreSQL does not accept values of this type regardless (except as literals).
instance PGRecordType "record"

#ifdef VERSION_aeson
instance PGType "json" where
  type PGVal "json" = JSON.Value
  BIN_COL
instance PGParameter "json" JSON.Value where
  pgEncode :: PGTypeID "json" -> Value -> ByteString
pgEncode PGTypeID "json"
_ = ByteString -> ByteString
BSL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
JSON.encode
  BIN_ENC(BinE.json_ast)
instance PGColumn "json" JSON.Value where
  pgDecode :: PGTypeID "json" -> ByteString -> Value
pgDecode PGTypeID "json"
_ ByteString
j = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"pgDecode json (" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ (String
"): " forall a. [a] -> [a] -> [a]
++ ByteString -> String
BSC.unpack ByteString
j))) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> ByteString -> Either String a
P.parseOnly Parser Value
JSON.json ByteString
j
  BIN_DEC(BinD.json_ast)

instance PGType "jsonb" where
  type PGVal "jsonb" = JSON.Value
  BIN_COL
instance PGParameter "jsonb" JSON.Value where
  pgEncode :: PGTypeID "jsonb" -> Value -> ByteString
pgEncode PGTypeID "jsonb"
_ = ByteString -> ByteString
BSL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
JSON.encode
  BIN_ENC(BinE.jsonb_ast)
instance PGColumn "jsonb" JSON.Value where
  pgDecode :: PGTypeID "jsonb" -> ByteString -> Value
pgDecode PGTypeID "jsonb"
_ ByteString
j = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"pgDecode jsonb (" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ (String
"): " forall a. [a] -> [a] -> [a]
++ ByteString -> String
BSC.unpack ByteString
j))) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> ByteString -> Either String a
P.parseOnly Parser Value
JSON.json ByteString
j
  BIN_DEC(BinD.jsonb_ast)
#endif

{-
--, ( 142,  143, "xml",         ?)
--, ( 600, 1017, "point",       ?)
--, ( 650,  651, "cidr",        ?)
--, ( 790,  791, "money",       Centi? Fixed?)
--, ( 829, 1040, "macaddr",     ?)
--, ( 869, 1041, "inet",        ?)
--, (1266, 1270, "timetz",      ?)
--, (1560, 1561, "bit",         Bool?)
--, (1562, 1563, "varbit",      ?)
-}