{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor  #-}
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
{-# LANGUAGE PolyKinds #-}

------------------------------------------------------------------------------
-- |
-- Module:      Database.PostgreSQL.Simple.ToField
-- Copyright:   (c) 2011 MailRank, Inc.
--              (c) 2011-2012 Leon P Smith
-- License:     BSD3
-- Maintainer:  Leon P Smith <leon@melding-monads.com>
-- Stability:   experimental
--
-- The 'ToField' typeclass, for rendering a parameter to a SQL query.
--
------------------------------------------------------------------------------

module Database.PostgreSQL.Simple.ToField
    (
      Action(..)
    , ToField(..)
    , toJSONField
    , inQuotes
    ) where

import Control.Applicative (Const(Const))
import qualified Data.Aeson as JSON
import           Data.ByteString (ByteString)
import           Data.ByteString.Builder
                   ( Builder, byteString, char8, stringUtf8
                   , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec
                   , wordDec, word8Dec, word16Dec, word32Dec, word64Dec
                   , floatDec, doubleDec
                   )
import Data.Functor.Identity (Identity(Identity))
import Data.Int (Int8, Int16, Int32, Int64)
import Data.List (intersperse)
import Data.Monoid (mappend)
import Data.Time (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime)
import Data.Typeable (Typeable)
import Data.Word (Word, Word8, Word16, Word32, Word64)
import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow
import Database.PostgreSQL.Simple.Types
import Database.PostgreSQL.Simple.Compat (toByteString)

import qualified Data.ByteString as SB
import qualified Data.ByteString.Lazy as LB
import           Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import qualified Data.Text as ST
import qualified Data.Text.Encoding as ST
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as LT
import           Data.UUID.Types   (UUID)
import qualified Data.UUID.Types as UUID
import           Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Database.PostgreSQL.LibPQ as PQ
import           Database.PostgreSQL.Simple.Time
import           Data.Scientific (Scientific)
#if MIN_VERSION_scientific(0,3,0)
import           Data.Text.Lazy.Builder.Scientific (scientificBuilder)
#else
import           Data.Scientific (scientificBuilder)
#endif
import           Foreign.C.Types (CUInt(..))

-- | How to render an element when substituting it into a query.
data Action =
    Plain Builder
    -- ^ Render without escaping or quoting. Use for non-text types
    -- such as numbers, when you are /certain/ that they will not
    -- introduce formatting vulnerabilities via use of characters such
    -- as spaces or \"@'@\".
  | Escape ByteString
    -- ^ Escape and enclose in quotes before substituting. Use for all
    -- text-like types, and anything else that may contain unsafe
    -- characters when rendered.
  | EscapeByteA ByteString
    -- ^ Escape binary data for use as a @bytea@ literal.  Include surrounding
    -- quotes.  This is used by the 'Binary' newtype wrapper.
  | EscapeIdentifier ByteString
    -- ^ Escape before substituting. Use for all sql identifiers like
    -- table, column names, etc. This is used by the 'Identifier' newtype
    -- wrapper.
  | Many [Action]
    -- ^ Concatenate a series of rendering actions.
    deriving (Typeable)

instance Show Action where
    show :: Action -> String
show (Plain Builder
b)            = String
"Plain " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show (Builder -> ByteString
toByteString Builder
b)
    show (Escape ByteString
b)           = String
"Escape " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
b
    show (EscapeByteA ByteString
b)      = String
"EscapeByteA " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
b
    show (EscapeIdentifier ByteString
b) = String
"EscapeIdentifier " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
b
    show (Many [Action]
b)             = String
"Many " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Action] -> String
forall a. Show a => a -> String
show [Action]
b

-- | A type that may be used as a single parameter to a SQL query.
class ToField a where
    toField :: a -> Action
    -- ^ Prepare a value for substitution into a query string.

instance ToField Action where
    toField :: Action -> Action
toField Action
a = Action
a
    {-# INLINE toField #-}

instance (ToField a) => ToField (Const a b) where
  toField :: Const a b -> Action
toField (Const a
a) = a -> Action
forall a. ToField a => a -> Action
toField a
a
  {-# INLINE toField #-}

instance (ToField a) => ToField (Identity a) where
  toField :: Identity a -> Action
toField (Identity a
a) = a -> Action
forall a. ToField a => a -> Action
toField a
a
  {-# INLINE toField #-}

instance (ToField a) => ToField (Maybe a) where
    toField :: Maybe a -> Action
toField Maybe a
Nothing  = Action
renderNull
    toField (Just a
a) = a -> Action
forall a. ToField a => a -> Action
toField a
a
    {-# INLINE toField #-}

instance (ToField a) => ToField (In [a]) where
    toField :: In [a] -> Action
toField (In []) = Builder -> Action
Plain (Builder -> Action) -> Builder -> Action
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
"(null)"
    toField (In [a]
xs) = [Action] -> Action
Many ([Action] -> Action) -> [Action] -> Action
forall a b. (a -> b) -> a -> b
$
        Builder -> Action
Plain (Char -> Builder
char8 Char
'(') Action -> [Action] -> [Action]
forall a. a -> [a] -> [a]
:
        (Action -> [Action] -> [Action]
forall a. a -> [a] -> [a]
intersperse (Builder -> Action
Plain (Char -> Builder
char8 Char
',')) ([Action] -> [Action]) -> ([a] -> [Action]) -> [a] -> [Action]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Action) -> [a] -> [Action]
forall a b. (a -> b) -> [a] -> [b]
map a -> Action
forall a. ToField a => a -> Action
toField ([a] -> [Action]) -> [a] -> [Action]
forall a b. (a -> b) -> a -> b
$ [a]
xs) [Action] -> [Action] -> [Action]
forall a. [a] -> [a] -> [a]
++
        [Builder -> Action
Plain (Char -> Builder
char8 Char
')')]

renderNull :: Action
renderNull :: Action
renderNull = Builder -> Action
Plain (ByteString -> Builder
byteString ByteString
"null")

instance ToField Null where
    toField :: Null -> Action
toField Null
_ = Action
renderNull
    {-# INLINE toField #-}

instance ToField Default where
    toField :: Default -> Action
toField Default
_ = Builder -> Action
Plain (ByteString -> Builder
byteString ByteString
"default")
    {-# INLINE toField #-}

instance ToField Bool where
    toField :: Bool -> Action
toField Bool
True  = Builder -> Action
Plain (ByteString -> Builder
byteString ByteString
"true")
    toField Bool
False = Builder -> Action
Plain (ByteString -> Builder
byteString ByteString
"false")
    {-# INLINE toField #-}

instance ToField Int8 where
    toField :: Int8 -> Action
toField = Builder -> Action
Plain (Builder -> Action) -> (Int8 -> Builder) -> Int8 -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> Builder
int8Dec
    {-# INLINE toField #-}

instance ToField Int16 where
    toField :: Int16 -> Action
toField = Builder -> Action
Plain (Builder -> Action) -> (Int16 -> Builder) -> Int16 -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Builder
int16Dec
    {-# INLINE toField #-}

instance ToField Int32 where
    toField :: Int32 -> Action
toField = Builder -> Action
Plain (Builder -> Action) -> (Int32 -> Builder) -> Int32 -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Builder
int32Dec
    {-# INLINE toField #-}

instance ToField Int where
    toField :: Int -> Action
toField = Builder -> Action
Plain (Builder -> Action) -> (Int -> Builder) -> Int -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Builder
intDec
    {-# INLINE toField #-}

instance ToField Int64 where
    toField :: Int64 -> Action
toField = Builder -> Action
Plain (Builder -> Action) -> (Int64 -> Builder) -> Int64 -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Builder
int64Dec
    {-# INLINE toField #-}

instance ToField Integer where
    toField :: Integer -> Action
toField = Builder -> Action
Plain (Builder -> Action) -> (Integer -> Builder) -> Integer -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Builder
integerDec
    {-# INLINE toField #-}

instance ToField Word8 where
    toField :: Word8 -> Action
toField = Builder -> Action
Plain (Builder -> Action) -> (Word8 -> Builder) -> Word8 -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Builder
word8Dec
    {-# INLINE toField #-}

instance ToField Word16 where
    toField :: Word16 -> Action
toField = Builder -> Action
Plain (Builder -> Action) -> (Word16 -> Builder) -> Word16 -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Builder
word16Dec
    {-# INLINE toField #-}

instance ToField Word32 where
    toField :: Word32 -> Action
toField = Builder -> Action
Plain (Builder -> Action) -> (Word32 -> Builder) -> Word32 -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Builder
word32Dec
    {-# INLINE toField #-}

instance ToField Word where
    toField :: Word -> Action
toField = Builder -> Action
Plain (Builder -> Action) -> (Word -> Builder) -> Word -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Builder
wordDec
    {-# INLINE toField #-}

instance ToField Word64 where
    toField :: Word64 -> Action
toField = Builder -> Action
Plain (Builder -> Action) -> (Word64 -> Builder) -> Word64 -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Builder
word64Dec
    {-# INLINE toField #-}

instance ToField PQ.Oid where
    toField :: Oid -> Action
toField = Builder -> Action
Plain (Builder -> Action) -> (Oid -> Builder) -> Oid -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \(PQ.Oid (CUInt Word32
x)) -> Word32 -> Builder
word32Dec Word32
x
    {-# INLINE toField #-}

instance ToField Float where
    toField :: Float -> Action
toField Float
v | Float -> Bool
forall a. RealFloat a => a -> Bool
isNaN Float
v Bool -> Bool -> Bool
|| Float -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Float
v = Builder -> Action
Plain (Builder -> Builder
inQuotes (Float -> Builder
floatDec Float
v))
              | Bool
otherwise               = Builder -> Action
Plain (Float -> Builder
floatDec Float
v)
    {-# INLINE toField #-}

instance ToField Double where
    toField :: Double -> Action
toField Double
v | Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
v Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
v = Builder -> Action
Plain (Builder -> Builder
inQuotes (Double -> Builder
doubleDec Double
v))
              | Bool
otherwise               = Builder -> Action
Plain (Double -> Builder
doubleDec Double
v)
    {-# INLINE toField #-}

instance ToField Scientific where
    toField :: Scientific -> Action
toField Scientific
x = Text -> Action
forall a. ToField a => a -> Action
toField (Builder -> Text
LT.toLazyText (Scientific -> Builder
scientificBuilder Scientific
x))
    {-# INLINE toField #-}

instance ToField (Binary SB.ByteString) where
    toField :: Binary ByteString -> Action
toField (Binary ByteString
bs) = ByteString -> Action
EscapeByteA ByteString
bs
    {-# INLINE toField #-}

instance ToField (Binary LB.ByteString) where
    toField :: Binary ByteString -> Action
toField (Binary ByteString
bs) = (ByteString -> Action
EscapeByteA (ByteString -> Action)
-> (ByteString -> ByteString) -> ByteString -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
SB.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
LB.toChunks) ByteString
bs
    {-# INLINE toField #-}

instance ToField Identifier where
    toField :: Identifier -> Action
toField (Identifier Text
bs) = ByteString -> Action
EscapeIdentifier (Text -> ByteString
ST.encodeUtf8 Text
bs)
    {-# INLINE toField #-}

instance ToField QualifiedIdentifier where
    toField :: QualifiedIdentifier -> Action
toField (QualifiedIdentifier (Just Text
s) Text
t) =
        [Action] -> Action
Many [ ByteString -> Action
EscapeIdentifier (Text -> ByteString
ST.encodeUtf8 Text
s)
             , Builder -> Action
Plain (Char -> Builder
char8 Char
'.')
             , ByteString -> Action
EscapeIdentifier (Text -> ByteString
ST.encodeUtf8 Text
t)
             ]
    toField (QualifiedIdentifier Maybe Text
Nothing  Text
t) =
               ByteString -> Action
EscapeIdentifier (Text -> ByteString
ST.encodeUtf8 Text
t)
    {-# INLINE toField #-}

instance ToField SB.ByteString where
    toField :: ByteString -> Action
toField = ByteString -> Action
Escape
    {-# INLINE toField #-}

instance ToField LB.ByteString where
    toField :: ByteString -> Action
toField = ByteString -> Action
forall a. ToField a => a -> Action
toField (ByteString -> Action)
-> (ByteString -> ByteString) -> ByteString -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
SB.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
LB.toChunks
    {-# INLINE toField #-}

instance ToField ST.Text where
    toField :: Text -> Action
toField = ByteString -> Action
Escape (ByteString -> Action) -> (Text -> ByteString) -> Text -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
ST.encodeUtf8
    {-# INLINE toField #-}

instance ToField [Char] where
    toField :: String -> Action
toField = ByteString -> Action
Escape (ByteString -> Action)
-> (String -> ByteString) -> String -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toByteString (Builder -> ByteString)
-> (String -> Builder) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
stringUtf8
    {-# INLINE toField #-}

instance ToField LT.Text where
    toField :: Text -> Action
toField = Text -> Action
forall a. ToField a => a -> Action
toField (Text -> Action) -> (Text -> Text) -> Text -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
LT.toStrict
    {-# INLINE toField #-}

-- | citext
instance ToField (CI ST.Text) where
    toField :: CI Text -> Action
toField = Text -> Action
forall a. ToField a => a -> Action
toField (Text -> Action) -> (CI Text -> Text) -> CI Text -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI Text -> Text
forall s. CI s -> s
CI.original
    {-# INLINE toField #-}

-- | citext
instance ToField (CI LT.Text) where
    toField :: CI Text -> Action
toField = Text -> Action
forall a. ToField a => a -> Action
toField (Text -> Action) -> (CI Text -> Text) -> CI Text -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
LT.toStrict (Text -> Text) -> (CI Text -> Text) -> CI Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI Text -> Text
forall s. CI s -> s
CI.original
    {-# INLINE toField #-}

instance ToField UTCTime where
    toField :: UTCTime -> Action
toField = Builder -> Action
Plain (Builder -> Action) -> (UTCTime -> Builder) -> UTCTime -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder
inQuotes (Builder -> Builder) -> (UTCTime -> Builder) -> UTCTime -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Builder
utcTimeToBuilder
    {-# INLINE toField #-}

instance ToField ZonedTime where
    toField :: ZonedTime -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (ZonedTime -> Builder) -> ZonedTime -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder
inQuotes (Builder -> Builder)
-> (ZonedTime -> Builder) -> ZonedTime -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZonedTime -> Builder
zonedTimeToBuilder
    {-# INLINE toField #-}

instance ToField LocalTime where
    toField :: LocalTime -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (LocalTime -> Builder) -> LocalTime -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder
inQuotes (Builder -> Builder)
-> (LocalTime -> Builder) -> LocalTime -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalTime -> Builder
localTimeToBuilder
    {-# INLINE toField #-}

instance ToField Day where
    toField :: Day -> Action
toField = Builder -> Action
Plain (Builder -> Action) -> (Day -> Builder) -> Day -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder
inQuotes (Builder -> Builder) -> (Day -> Builder) -> Day -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> Builder
dayToBuilder
    {-# INLINE toField #-}

instance ToField TimeOfDay where
    toField :: TimeOfDay -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (TimeOfDay -> Builder) -> TimeOfDay -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder
inQuotes (Builder -> Builder)
-> (TimeOfDay -> Builder) -> TimeOfDay -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeOfDay -> Builder
timeOfDayToBuilder
    {-# INLINE toField #-}

instance ToField UTCTimestamp where
    toField :: UTCTimestamp -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (UTCTimestamp -> Builder) -> UTCTimestamp -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder
inQuotes (Builder -> Builder)
-> (UTCTimestamp -> Builder) -> UTCTimestamp -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTimestamp -> Builder
utcTimestampToBuilder
    {-# INLINE toField #-}

instance ToField ZonedTimestamp where
    toField :: ZonedTimestamp -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (ZonedTimestamp -> Builder) -> ZonedTimestamp -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder
inQuotes (Builder -> Builder)
-> (ZonedTimestamp -> Builder) -> ZonedTimestamp -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZonedTimestamp -> Builder
zonedTimestampToBuilder
    {-# INLINE toField #-}

instance ToField LocalTimestamp where
    toField :: LocalTimestamp -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (LocalTimestamp -> Builder) -> LocalTimestamp -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder
inQuotes (Builder -> Builder)
-> (LocalTimestamp -> Builder) -> LocalTimestamp -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalTimestamp -> Builder
localTimestampToBuilder
    {-# INLINE toField #-}

instance ToField Date where
    toField :: Date -> Action
toField = Builder -> Action
Plain (Builder -> Action) -> (Date -> Builder) -> Date -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder
inQuotes (Builder -> Builder) -> (Date -> Builder) -> Date -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Date -> Builder
dateToBuilder
    {-# INLINE toField #-}

instance ToField NominalDiffTime where
    toField :: NominalDiffTime -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (NominalDiffTime -> Builder) -> NominalDiffTime -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder
inQuotes (Builder -> Builder)
-> (NominalDiffTime -> Builder) -> NominalDiffTime -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Builder
nominalDiffTimeToBuilder
    {-# INLINE toField #-}

instance (ToField a) => ToField (PGArray a) where
    toField :: PGArray a -> Action
toField PGArray a
pgArray =
      case PGArray a -> [a]
forall a. PGArray a -> [a]
fromPGArray PGArray a
pgArray of
        [] -> Builder -> Action
Plain (ByteString -> Builder
byteString ByteString
"'{}'")
        [a]
xs -> [Action] -> Action
Many ([Action] -> Action) -> [Action] -> Action
forall a b. (a -> b) -> a -> b
$
          Builder -> Action
Plain (ByteString -> Builder
byteString ByteString
"ARRAY[") Action -> [Action] -> [Action]
forall a. a -> [a] -> [a]
:
          (Action -> [Action] -> [Action]
forall a. a -> [a] -> [a]
intersperse (Builder -> Action
Plain (Char -> Builder
char8 Char
',')) ([Action] -> [Action]) -> ([a] -> [Action]) -> [a] -> [Action]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Action) -> [a] -> [Action]
forall a b. (a -> b) -> [a] -> [b]
map a -> Action
forall a. ToField a => a -> Action
toField ([a] -> [Action]) -> [a] -> [Action]
forall a b. (a -> b) -> a -> b
$ [a]
xs) [Action] -> [Action] -> [Action]
forall a. [a] -> [a] -> [a]
++
          [Builder -> Action
Plain (Char -> Builder
char8 Char
']')]
          -- Because the ARRAY[...] input syntax is being used, it is possible
          -- that the use of type-specific separator characters is unnecessary.

instance (ToField a) => ToField (Vector a) where
    toField :: Vector a -> Action
toField = PGArray a -> Action
forall a. ToField a => a -> Action
toField (PGArray a -> Action)
-> (Vector a -> PGArray a) -> Vector a -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> PGArray a
forall a. [a] -> PGArray a
PGArray ([a] -> PGArray a) -> (Vector a -> [a]) -> Vector a -> PGArray a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector a -> [a]
forall a. Vector a -> [a]
V.toList

instance ToField UUID where
    toField :: UUID -> Action
toField = Builder -> Action
Plain (Builder -> Action) -> (UUID -> Builder) -> UUID -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder
inQuotes (Builder -> Builder) -> (UUID -> Builder) -> UUID -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
byteString (ByteString -> Builder) -> (UUID -> ByteString) -> UUID -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> ByteString
UUID.toASCIIBytes

instance ToField JSON.Value where
    toField :: Value -> Action
toField = ByteString -> Action
forall a. ToField a => a -> Action
toField (ByteString -> Action) -> (Value -> ByteString) -> Value -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode

-- | Convert a Haskell value to a JSON 'JSON.Value' using
-- 'JSON.toJSON' and convert that to a field using 'toField'.
--
-- This can be used as the default implementation for the 'toField'
-- method for Haskell types that have a JSON representation in
-- PostgreSQL.
toJSONField :: JSON.ToJSON a => a -> Action
toJSONField :: a -> Action
toJSONField = Value -> Action
forall a. ToField a => a -> Action
toField (Value -> Action) -> (a -> Value) -> a -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON

-- | Surround a string with single-quote characters: \"@'@\"
--
-- This function /does not/ perform any other escaping.
inQuotes :: Builder -> Builder
inQuotes :: Builder -> Builder
inQuotes Builder
b = Builder
quote Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
b Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
quote
  where quote :: Builder
quote = Char -> Builder
char8 Char
'\''

interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b]
interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b]
interleaveFoldr a -> [b] -> [b]
f b
b [b]
bs' [a]
as = (a -> [b] -> [b]) -> [b] -> [a] -> [b]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
a [b]
bs -> b
b b -> [b] -> [b]
forall a. a -> [a] -> [a]
: a -> [b] -> [b]
f a
a [b]
bs) [b]
bs' [a]
as
{-# INLINE interleaveFoldr #-}

instance ToRow a => ToField (Values a) where
    toField :: Values a -> Action
toField (Values [QualifiedIdentifier]
types [a]
rows) =
        case [a]
rows of
          []    -> case [QualifiedIdentifier]
types of
                     []    -> String -> Action
forall a. HasCallStack => String -> a
error String
norows
                     (QualifiedIdentifier
_:[QualifiedIdentifier]
_) -> [Action] -> Action
values ([Action] -> Action) -> [Action] -> Action
forall a b. (a -> b) -> a -> b
$ [Action] -> [QualifiedIdentifier] -> [Action] -> [Action]
typedRow (Action -> [Action]
forall a. a -> [a]
repeat (ByteString -> Action
lit ByteString
"null"))
                                                [QualifiedIdentifier]
types
                                                [ByteString -> Action
lit ByteString
" LIMIT 0)"]
          (a
_:[a]
_) -> case [QualifiedIdentifier]
types of
                     []    -> [Action] -> Action
values ([Action] -> Action) -> [Action] -> Action
forall a b. (a -> b) -> a -> b
$ [a] -> [Action] -> [Action]
forall a. ToRow a => [a] -> [Action] -> [Action]
untypedRows [a]
rows [Char -> Action
litC Char
')']
                     (QualifiedIdentifier
_:[QualifiedIdentifier]
_) -> [Action] -> Action
values ([Action] -> Action) -> [Action] -> Action
forall a b. (a -> b) -> a -> b
$ [a] -> [QualifiedIdentifier] -> [Action] -> [Action]
forall a.
ToRow a =>
[a] -> [QualifiedIdentifier] -> [Action] -> [Action]
typedRows [a]
rows [QualifiedIdentifier]
types [Char -> Action
litC Char
')']
      where
        funcname :: String
funcname = String
"Database.PostgreSQL.Simple.toField :: Values a -> Action"
        norows :: String
norows   = String
funcname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"  either values or types must be non-empty"
        emptyrow :: String
emptyrow = String
funcname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"  each row must contain at least one column"
        lit :: ByteString -> Action
lit  = Builder -> Action
Plain (Builder -> Action)
-> (ByteString -> Builder) -> ByteString -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
byteString
        litC :: Char -> Action
litC = Builder -> Action
Plain (Builder -> Action) -> (Char -> Builder) -> Char -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Builder
char8
        values :: [Action] -> Action
values [Action]
x = [Action] -> Action
Many (ByteString -> Action
lit ByteString
"(VALUES "Action -> [Action] -> [Action]
forall a. a -> [a] -> [a]
: [Action]
x)

        typedField :: (Action, QualifiedIdentifier) -> [Action] -> [Action]
        typedField :: (Action, QualifiedIdentifier) -> [Action] -> [Action]
typedField (Action
val,QualifiedIdentifier
typ) [Action]
rest = Action
val Action -> [Action] -> [Action]
forall a. a -> [a] -> [a]
: ByteString -> Action
lit ByteString
"::" Action -> [Action] -> [Action]
forall a. a -> [a] -> [a]
: QualifiedIdentifier -> Action
forall a. ToField a => a -> Action
toField QualifiedIdentifier
typ Action -> [Action] -> [Action]
forall a. a -> [a] -> [a]
: [Action]
rest

        typedRow :: [Action] -> [QualifiedIdentifier] -> [Action] -> [Action]
        typedRow :: [Action] -> [QualifiedIdentifier] -> [Action] -> [Action]
typedRow (Action
val:[Action]
vals) (QualifiedIdentifier
typ:[QualifiedIdentifier]
typs) [Action]
rest =
            Char -> Action
litC Char
'(' Action -> [Action] -> [Action]
forall a. a -> [a] -> [a]
:
              (Action, QualifiedIdentifier) -> [Action] -> [Action]
typedField (Action
val,QualifiedIdentifier
typ) ( ((Action, QualifiedIdentifier) -> [Action] -> [Action])
-> Action
-> [Action]
-> [(Action, QualifiedIdentifier)]
-> [Action]
forall a b. (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b]
interleaveFoldr
                                        (Action, QualifiedIdentifier) -> [Action] -> [Action]
typedField
                                        (Char -> Action
litC Char
',')
                                        (Char -> Action
litC Char
')' Action -> [Action] -> [Action]
forall a. a -> [a] -> [a]
: [Action]
rest)
                                        ([Action]
-> [QualifiedIdentifier] -> [(Action, QualifiedIdentifier)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Action]
vals [QualifiedIdentifier]
typs)   )
        typedRow [Action]
_ [QualifiedIdentifier]
_ [Action]
_ = String -> [Action]
forall a. HasCallStack => String -> a
error String
emptyrow

        untypedRow :: [Action] -> [Action] -> [Action]
        untypedRow :: [Action] -> [Action] -> [Action]
untypedRow (Action
val:[Action]
vals) [Action]
rest =
            Char -> Action
litC Char
'(' Action -> [Action] -> [Action]
forall a. a -> [a] -> [a]
: Action
val Action -> [Action] -> [Action]
forall a. a -> [a] -> [a]
:
            (Action -> [Action] -> [Action])
-> Action -> [Action] -> [Action] -> [Action]
forall a b. (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b]
interleaveFoldr
                 (:)
                 (Char -> Action
litC Char
',')
                 (Char -> Action
litC Char
')' Action -> [Action] -> [Action]
forall a. a -> [a] -> [a]
: [Action]
rest)
                 [Action]
vals
        untypedRow [Action]
_ [Action]
_ = String -> [Action]
forall a. HasCallStack => String -> a
error String
emptyrow

        typedRows :: ToRow a => [a] -> [QualifiedIdentifier] -> [Action] -> [Action]
        typedRows :: [a] -> [QualifiedIdentifier] -> [Action] -> [Action]
typedRows [] [QualifiedIdentifier]
_ [Action]
_ = String -> [Action]
forall a. HasCallStack => String -> a
error String
funcname
        typedRows (a
val:[a]
vals) [QualifiedIdentifier]
typs [Action]
rest =
            [Action] -> [QualifiedIdentifier] -> [Action] -> [Action]
typedRow (a -> [Action]
forall a. ToRow a => a -> [Action]
toRow a
val) [QualifiedIdentifier]
typs ([a] -> [Action] -> [Action]
forall a. ToRow a => [a] -> [Action] -> [Action]
multiRows [a]
vals [Action]
rest)

        untypedRows :: ToRow a => [a] -> [Action] -> [Action]
        untypedRows :: [a] -> [Action] -> [Action]
untypedRows [] [Action]
_ = String -> [Action]
forall a. HasCallStack => String -> a
error String
funcname
        untypedRows (a
val:[a]
vals) [Action]
rest =
            [Action] -> [Action] -> [Action]
untypedRow (a -> [Action]
forall a. ToRow a => a -> [Action]
toRow a
val) ([a] -> [Action] -> [Action]
forall a. ToRow a => [a] -> [Action] -> [Action]
multiRows [a]
vals [Action]
rest)

        multiRows :: ToRow a => [a] -> [Action] -> [Action]
        multiRows :: [a] -> [Action] -> [Action]
multiRows [a]
vals [Action]
rest = (a -> [Action] -> [Action])
-> Action -> [Action] -> [a] -> [Action]
forall a b. (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b]
interleaveFoldr
                                ([Action] -> [Action] -> [Action]
untypedRow ([Action] -> [Action] -> [Action])
-> (a -> [Action]) -> a -> [Action] -> [Action]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Action]
forall a. ToRow a => a -> [Action]
toRow)
                                (Char -> Action
litC Char
',')
                                [Action]
rest
                                [a]
vals