{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Preql.Wire.ToSql where

import Preql.Imports
import Preql.Wire.Tuples (deriveToSqlTuple)
import Preql.Wire.Types

import Data.Functor.Contravariant
import Data.Int
import Data.Time (Day, TimeOfDay, UTCTime)
import Data.UUID (UUID)

import qualified ByteString.StrictBuilder as B
import qualified Data.Aeson as JSON
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Database.PostgreSQL.LibPQ as PQ
import qualified PostgreSQL.Binary.Encoding as PGB
import qualified Preql.Wire.TypeInfo.Static as OID

-- | A @FieldEncoder@ for a type @a@ consists of a function from @a@ to
-- it's binary representation, and an Postgres OID which tells
-- Postgres it's type & how to decode it.
data FieldEncoder a = FieldEncoder PQ.Oid (a -> B.Builder)

instance Contravariant FieldEncoder where
    contramap :: (a -> b) -> FieldEncoder b -> FieldEncoder a
contramap a -> b
f (FieldEncoder Oid
oid b -> Builder
enc) = Oid -> (a -> Builder) -> FieldEncoder a
forall a. Oid -> (a -> Builder) -> FieldEncoder a
FieldEncoder Oid
oid (b -> Builder
enc (b -> Builder) -> (a -> b) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

runFieldEncoder :: FieldEncoder p -> p -> (PQ.Oid, ByteString)
runFieldEncoder :: FieldEncoder p -> p -> (Oid, ByteString)
runFieldEncoder (FieldEncoder Oid
oid p -> Builder
enc) p
p = (Oid
oid, Builder -> ByteString
B.builderBytes (p -> Builder
enc p
p))

type RowEncoder a = a -> [(PQ.Oid, ByteString)]

runEncoder :: RowEncoder p -> p -> [Maybe (PQ.Oid, ByteString, PQ.Format)]
runEncoder :: RowEncoder p -> p -> [Maybe (Oid, ByteString, Format)]
runEncoder RowEncoder p
fields p
p = RowEncoder p
fields p
p [(Oid, ByteString)]
-> ((Oid, ByteString) -> Maybe (Oid, ByteString, Format))
-> [Maybe (Oid, ByteString, Format)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Oid
oid, ByteString
bs) -> (Oid, ByteString, Format) -> Maybe (Oid, ByteString, Format)
forall a. a -> Maybe a
Just (Oid
oid, ByteString
bs, Format
PQ.Binary)

oneField :: FieldEncoder a -> RowEncoder a
oneField :: FieldEncoder a -> RowEncoder a
oneField FieldEncoder a
enc = \a
p -> [FieldEncoder a -> a -> (Oid, ByteString)
forall p. FieldEncoder p -> p -> (Oid, ByteString)
runFieldEncoder FieldEncoder a
enc a
p]

-- | Types which can be encoded to a single Postgres field.
class ToSqlField a where
    toSqlField :: FieldEncoder a

-- | @ToSql a@ is sufficient to pass @a@ as parameters to a paramaterized query.
class ToSql a where
    toSql :: RowEncoder a

instance ToSqlField Bool where
    toSqlField :: FieldEncoder Bool
toSqlField = Oid -> (Bool -> Builder) -> FieldEncoder Bool
forall a. Oid -> (a -> Builder) -> FieldEncoder a
FieldEncoder Oid
OID.boolOid Bool -> Builder
PGB.bool
instance ToSql Bool where toSql :: RowEncoder Bool
toSql = FieldEncoder Bool -> RowEncoder Bool
forall a. FieldEncoder a -> RowEncoder a
oneField FieldEncoder Bool
forall a. ToSqlField a => FieldEncoder a
toSqlField

instance ToSqlField Int16 where
    toSqlField :: FieldEncoder Int16
toSqlField = Oid -> (Int16 -> Builder) -> FieldEncoder Int16
forall a. Oid -> (a -> Builder) -> FieldEncoder a
FieldEncoder Oid
OID.int2Oid Int16 -> Builder
PGB.int2_int16
instance ToSql Int16 where toSql :: RowEncoder Int16
toSql = FieldEncoder Int16 -> RowEncoder Int16
forall a. FieldEncoder a -> RowEncoder a
oneField FieldEncoder Int16
forall a. ToSqlField a => FieldEncoder a
toSqlField

instance ToSqlField Int32 where
    toSqlField :: FieldEncoder Int32
toSqlField = Oid -> (Int32 -> Builder) -> FieldEncoder Int32
forall a. Oid -> (a -> Builder) -> FieldEncoder a
FieldEncoder Oid
OID.int4Oid Int32 -> Builder
PGB.int4_int32
instance ToSql Int32 where toSql :: RowEncoder Int32
toSql = FieldEncoder Int32 -> RowEncoder Int32
forall a. FieldEncoder a -> RowEncoder a
oneField FieldEncoder Int32
forall a. ToSqlField a => FieldEncoder a
toSqlField

instance ToSqlField Int64 where
    toSqlField :: FieldEncoder Int64
toSqlField = Oid -> (Int64 -> Builder) -> FieldEncoder Int64
forall a. Oid -> (a -> Builder) -> FieldEncoder a
FieldEncoder Oid
OID.int8Oid Int64 -> Builder
PGB.int8_int64
instance ToSql Int64 where toSql :: RowEncoder Int64
toSql = FieldEncoder Int64 -> RowEncoder Int64
forall a. FieldEncoder a -> RowEncoder a
oneField FieldEncoder Int64
forall a. ToSqlField a => FieldEncoder a
toSqlField

instance ToSqlField Float where
    toSqlField :: FieldEncoder Float
toSqlField = Oid -> (Float -> Builder) -> FieldEncoder Float
forall a. Oid -> (a -> Builder) -> FieldEncoder a
FieldEncoder Oid
OID.float4Oid Float -> Builder
PGB.float4
instance ToSql Float where toSql :: RowEncoder Float
toSql = FieldEncoder Float -> RowEncoder Float
forall a. FieldEncoder a -> RowEncoder a
oneField FieldEncoder Float
forall a. ToSqlField a => FieldEncoder a
toSqlField

instance ToSqlField Double where
    toSqlField :: FieldEncoder Double
toSqlField = Oid -> (Double -> Builder) -> FieldEncoder Double
forall a. Oid -> (a -> Builder) -> FieldEncoder a
FieldEncoder Oid
OID.float8Oid Double -> Builder
PGB.float8
instance ToSql Double where toSql :: RowEncoder Double
toSql = FieldEncoder Double -> RowEncoder Double
forall a. FieldEncoder a -> RowEncoder a
oneField FieldEncoder Double
forall a. ToSqlField a => FieldEncoder a
toSqlField

instance ToSqlField Char where
    toSqlField :: FieldEncoder Char
toSqlField = Oid -> (Char -> Builder) -> FieldEncoder Char
forall a. Oid -> (a -> Builder) -> FieldEncoder a
FieldEncoder Oid
OID.charOid Char -> Builder
PGB.char_utf8
instance ToSql Char where toSql :: RowEncoder Char
toSql = FieldEncoder Char -> RowEncoder Char
forall a. FieldEncoder a -> RowEncoder a
oneField FieldEncoder Char
forall a. ToSqlField a => FieldEncoder a
toSqlField

instance ToSqlField String where
    toSqlField :: FieldEncoder String
toSqlField = Oid -> (String -> Builder) -> FieldEncoder String
forall a. Oid -> (a -> Builder) -> FieldEncoder a
FieldEncoder Oid
OID.textOid (Text -> Builder
PGB.text_strict (Text -> Builder) -> (String -> Text) -> String -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack)
instance ToSql String where toSql :: RowEncoder String
toSql = FieldEncoder String -> RowEncoder String
forall a. FieldEncoder a -> RowEncoder a
oneField FieldEncoder String
forall a. ToSqlField a => FieldEncoder a
toSqlField

instance ToSqlField Text where
    toSqlField :: FieldEncoder Text
toSqlField = Oid -> (Text -> Builder) -> FieldEncoder Text
forall a. Oid -> (a -> Builder) -> FieldEncoder a
FieldEncoder Oid
OID.textOid Text -> Builder
PGB.text_strict
instance ToSql Text where toSql :: RowEncoder Text
toSql = FieldEncoder Text -> RowEncoder Text
forall a. FieldEncoder a -> RowEncoder a
oneField FieldEncoder Text
forall a. ToSqlField a => FieldEncoder a
toSqlField

instance ToSqlField TL.Text where
    toSqlField :: FieldEncoder Text
toSqlField = Oid -> (Text -> Builder) -> FieldEncoder Text
forall a. Oid -> (a -> Builder) -> FieldEncoder a
FieldEncoder Oid
OID.textOid Text -> Builder
PGB.text_lazy
instance ToSql TL.Text where toSql :: RowEncoder Text
toSql = FieldEncoder Text -> RowEncoder Text
forall a. FieldEncoder a -> RowEncoder a
oneField FieldEncoder Text
forall a. ToSqlField a => FieldEncoder a
toSqlField

-- | If you want to encode some more specific Haskell type via JSON,
-- it is more efficient to use 'Data.Aeson.encode' and
-- 'PostgreSQL.Binary.Encoding.jsonb_bytes' directly, rather than this
-- instance.
instance ToSqlField ByteString where
    toSqlField :: FieldEncoder ByteString
toSqlField = Oid -> (ByteString -> Builder) -> FieldEncoder ByteString
forall a. Oid -> (a -> Builder) -> FieldEncoder a
FieldEncoder Oid
OID.byteaOid ByteString -> Builder
PGB.bytea_strict
instance ToSql ByteString where toSql :: RowEncoder ByteString
toSql = FieldEncoder ByteString -> RowEncoder ByteString
forall a. FieldEncoder a -> RowEncoder a
oneField FieldEncoder ByteString
forall a. ToSqlField a => FieldEncoder a
toSqlField

instance ToSqlField BSL.ByteString where
    toSqlField :: FieldEncoder ByteString
toSqlField = Oid -> (ByteString -> Builder) -> FieldEncoder ByteString
forall a. Oid -> (a -> Builder) -> FieldEncoder a
FieldEncoder Oid
OID.byteaOid ByteString -> Builder
PGB.bytea_lazy
instance ToSql BSL.ByteString where toSql :: RowEncoder ByteString
toSql = FieldEncoder ByteString -> RowEncoder ByteString
forall a. FieldEncoder a -> RowEncoder a
oneField FieldEncoder ByteString
forall a. ToSqlField a => FieldEncoder a
toSqlField

-- TODO check for integer_datetimes setting
instance ToSqlField UTCTime where
    toSqlField :: FieldEncoder UTCTime
toSqlField = Oid -> (UTCTime -> Builder) -> FieldEncoder UTCTime
forall a. Oid -> (a -> Builder) -> FieldEncoder a
FieldEncoder Oid
OID.timestamptzOid UTCTime -> Builder
PGB.timestamptz_int
instance ToSql UTCTime where toSql :: RowEncoder UTCTime
toSql = FieldEncoder UTCTime -> RowEncoder UTCTime
forall a. FieldEncoder a -> RowEncoder a
oneField FieldEncoder UTCTime
forall a. ToSqlField a => FieldEncoder a
toSqlField

instance ToSqlField Day where
    toSqlField :: FieldEncoder Day
toSqlField = Oid -> (Day -> Builder) -> FieldEncoder Day
forall a. Oid -> (a -> Builder) -> FieldEncoder a
FieldEncoder Oid
OID.dateOid Day -> Builder
PGB.date
instance ToSql Day where toSql :: RowEncoder Day
toSql = FieldEncoder Day -> RowEncoder Day
forall a. FieldEncoder a -> RowEncoder a
oneField FieldEncoder Day
forall a. ToSqlField a => FieldEncoder a
toSqlField

instance ToSqlField TimeOfDay where
    toSqlField :: FieldEncoder TimeOfDay
toSqlField = Oid -> (TimeOfDay -> Builder) -> FieldEncoder TimeOfDay
forall a. Oid -> (a -> Builder) -> FieldEncoder a
FieldEncoder Oid
OID.timeOid TimeOfDay -> Builder
PGB.time_int
instance ToSql TimeOfDay where toSql :: RowEncoder TimeOfDay
toSql = FieldEncoder TimeOfDay -> RowEncoder TimeOfDay
forall a. FieldEncoder a -> RowEncoder a
oneField FieldEncoder TimeOfDay
forall a. ToSqlField a => FieldEncoder a
toSqlField

instance ToSqlField TimeTZ where
    toSqlField :: FieldEncoder TimeTZ
toSqlField = Oid -> (TimeTZ -> Builder) -> FieldEncoder TimeTZ
forall a. Oid -> (a -> Builder) -> FieldEncoder a
FieldEncoder Oid
OID.timetzOid (\(TimeTZ TimeOfDay
tod TimeZone
tz) -> (TimeOfDay, TimeZone) -> Builder
PGB.timetz_int (TimeOfDay
tod, TimeZone
tz))
instance ToSql TimeTZ where toSql :: RowEncoder TimeTZ
toSql = FieldEncoder TimeTZ -> RowEncoder TimeTZ
forall a. FieldEncoder a -> RowEncoder a
oneField FieldEncoder TimeTZ
forall a. ToSqlField a => FieldEncoder a
toSqlField

instance ToSqlField UUID where
    toSqlField :: FieldEncoder UUID
toSqlField = Oid -> (UUID -> Builder) -> FieldEncoder UUID
forall a. Oid -> (a -> Builder) -> FieldEncoder a
FieldEncoder Oid
OID.uuidOid UUID -> Builder
PGB.uuid
instance ToSql UUID where toSql :: RowEncoder UUID
toSql = FieldEncoder UUID -> RowEncoder UUID
forall a. FieldEncoder a -> RowEncoder a
oneField FieldEncoder UUID
forall a. ToSqlField a => FieldEncoder a
toSqlField

-- | If you want to encode some more specific Haskell type via JSON,
-- it is more efficient to use 'toSqlJsonField' rather than this
-- instance.
instance ToSqlField JSON.Value where
    toSqlField :: FieldEncoder Value
toSqlField = Oid -> (Value -> Builder) -> FieldEncoder Value
forall a. Oid -> (a -> Builder) -> FieldEncoder a
FieldEncoder Oid
OID.jsonbOid Value -> Builder
PGB.jsonb_ast
instance ToSql JSON.Value where toSql :: RowEncoder Value
toSql = FieldEncoder Value -> RowEncoder Value
forall a. FieldEncoder a -> RowEncoder a
oneField FieldEncoder Value
forall a. ToSqlField a => FieldEncoder a
toSqlField

toSqlJsonField :: JSON.ToJSON a => FieldEncoder a
toSqlJsonField :: FieldEncoder a
toSqlJsonField = Oid -> (a -> Builder) -> FieldEncoder a
forall a. Oid -> (a -> Builder) -> FieldEncoder a
FieldEncoder Oid
OID.jsonbOid (ByteString -> Builder
PGB.jsonb_bytes (ByteString -> Builder) -> (a -> ByteString) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode)

instance ToSql () where
    toSql :: RowEncoder ()
toSql () = []

instance (ToSqlField a, ToSqlField b) => ToSql (a, b) where
    toSql :: RowEncoder (a, b)
toSql (a
a, b
b) = [FieldEncoder a -> a -> (Oid, ByteString)
forall p. FieldEncoder p -> p -> (Oid, ByteString)
runFieldEncoder FieldEncoder a
forall a. ToSqlField a => FieldEncoder a
toSqlField a
a, FieldEncoder b -> b -> (Oid, ByteString)
forall p. FieldEncoder p -> p -> (Oid, ByteString)
runFieldEncoder FieldEncoder b
forall a. ToSqlField a => FieldEncoder a
toSqlField b
b]

instance (ToSqlField a, ToSqlField b, ToSqlField c) => ToSql (a, b, c) where
    toSql :: RowEncoder (a, b, c)
toSql (a
a, b
b, c
c) =
        [FieldEncoder a -> a -> (Oid, ByteString)
forall p. FieldEncoder p -> p -> (Oid, ByteString)
runFieldEncoder FieldEncoder a
forall a. ToSqlField a => FieldEncoder a
toSqlField a
a, FieldEncoder b -> b -> (Oid, ByteString)
forall p. FieldEncoder p -> p -> (Oid, ByteString)
runFieldEncoder FieldEncoder b
forall a. ToSqlField a => FieldEncoder a
toSqlField b
b, FieldEncoder c -> c -> (Oid, ByteString)
forall p. FieldEncoder p -> p -> (Oid, ByteString)
runFieldEncoder FieldEncoder c
forall a. ToSqlField a => FieldEncoder a
toSqlField c
c]

-- The instances below all follow the pattern laid out by the tuple
-- instances above.  The ones above are written out without the macro
-- to illustrate the pattern.

$(deriveToSqlTuple 4)
$(deriveToSqlTuple 5)
$(deriveToSqlTuple 6)
$(deriveToSqlTuple 7)
$(deriveToSqlTuple 8)
$(deriveToSqlTuple 9)
$(deriveToSqlTuple 10)
$(deriveToSqlTuple 11)
$(deriveToSqlTuple 12)
$(deriveToSqlTuple 13)
$(deriveToSqlTuple 14)
$(deriveToSqlTuple 15)
$(deriveToSqlTuple 16)
$(deriveToSqlTuple 17)
$(deriveToSqlTuple 18)
$(deriveToSqlTuple 19)
$(deriveToSqlTuple 20)
$(deriveToSqlTuple 21)
$(deriveToSqlTuple 22)
$(deriveToSqlTuple 23)
$(deriveToSqlTuple 24)
$(deriveToSqlTuple 25)