module Database.PostgreSQL.PQTypes.ToSQL (
    ParamAllocator(..)
  , ToSQL(..)
  , putAsPtr
  ) where

import Data.ByteString.Unsafe
import Data.Int
import Data.Kind (Type)
import Data.Text.Encoding
import Data.Time
import Data.Word
import Foreign.C
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BSL
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.UUID.Types as U

import Database.PostgreSQL.PQTypes.Format
import Database.PostgreSQL.PQTypes.Internal.C.Interface
import Database.PostgreSQL.PQTypes.Internal.C.Types
import Database.PostgreSQL.PQTypes.Internal.Utils

-- | 'alloca'-like producer of 'PGparam' objects.
newtype ParamAllocator = ParamAllocator (forall r. (Ptr PGparam -> IO r) -> IO r)

-- | Class which represents \"from Haskell type
-- to SQL (libpqtypes) type\" transformation.
class PQFormat t => ToSQL t where
  -- | Destination type (used by libpqtypes).
  type PQDest t :: Type
  -- | Put supplied value into inner 'PGparam'.
  toSQL :: t -- ^ Value to be put.
        -> ParamAllocator -- ^ 'PGparam' allocator.
        -> (Ptr (PQDest t) -> IO r) -- ^ Continuation that puts
        -- converted value into inner 'PGparam'.
        -> IO r

-- | Function that abstracts away common elements of most 'ToSQL'
-- instance definitions to make them easier to write and less verbose.
putAsPtr :: Storable t => t -> (Ptr t -> IO r) -> IO r
putAsPtr :: t -> (Ptr t -> IO r) -> IO r
putAsPtr t
x Ptr t -> IO r
conv = (Ptr t -> IO r) -> IO r
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr t -> IO r) -> IO r) -> (Ptr t -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \Ptr t
ptr -> Ptr t -> t -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr t
ptr t
x IO () -> IO r -> IO r
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr t -> IO r
conv Ptr t
ptr

-- NULLables

instance ToSQL t => ToSQL (Maybe t) where
  type PQDest (Maybe t) = PQDest t
  toSQL :: Maybe t
-> ParamAllocator -> (Ptr (PQDest (Maybe t)) -> IO r) -> IO r
toSQL Maybe t
mt ParamAllocator
allocParam Ptr (PQDest (Maybe t)) -> IO r
conv = case Maybe t
mt of
    Maybe t
Nothing -> Ptr (PQDest (Maybe t)) -> IO r
conv Ptr (PQDest (Maybe t))
forall a. Ptr a
nullPtr
    Just t
t  -> t -> ParamAllocator -> (Ptr (PQDest t) -> IO r) -> IO r
forall t r.
ToSQL t =>
t -> ParamAllocator -> (Ptr (PQDest t) -> IO r) -> IO r
toSQL t
t ParamAllocator
allocParam Ptr (PQDest t) -> IO r
Ptr (PQDest (Maybe t)) -> IO r
conv

-- NUMERICS

instance ToSQL Int16 where
  type PQDest Int16 = CShort
  toSQL :: Int16 -> ParamAllocator -> (Ptr (PQDest Int16) -> IO r) -> IO r
toSQL Int16
n ParamAllocator
_ = CShort -> (Ptr CShort -> IO r) -> IO r
forall t r. Storable t => t -> (Ptr t -> IO r) -> IO r
putAsPtr (Int16 -> CShort
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
n)

instance ToSQL Int32 where
  type PQDest Int32 = CInt
  toSQL :: Int32 -> ParamAllocator -> (Ptr (PQDest Int32) -> IO r) -> IO r
toSQL Int32
n ParamAllocator
_ = CInt -> (Ptr CInt -> IO r) -> IO r
forall t r. Storable t => t -> (Ptr t -> IO r) -> IO r
putAsPtr (Int32 -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n)

instance ToSQL Int64 where
  type PQDest Int64 = CLLong
  toSQL :: Int64 -> ParamAllocator -> (Ptr (PQDest Int64) -> IO r) -> IO r
toSQL Int64
n ParamAllocator
_ = CLLong -> (Ptr CLLong -> IO r) -> IO r
forall t r. Storable t => t -> (Ptr t -> IO r) -> IO r
putAsPtr (Int64 -> CLLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
n)

instance ToSQL Int where
  type PQDest Int = CLLong
  toSQL :: Int -> ParamAllocator -> (Ptr (PQDest Int) -> IO r) -> IO r
toSQL Int
n ParamAllocator
_ = CLLong -> (Ptr CLLong -> IO r) -> IO r
forall t r. Storable t => t -> (Ptr t -> IO r) -> IO r
putAsPtr (Int -> CLLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)

instance ToSQL Float where
  type PQDest Float = CFloat
  toSQL :: Float -> ParamAllocator -> (Ptr (PQDest Float) -> IO r) -> IO r
toSQL Float
n ParamAllocator
_ = CFloat -> (Ptr CFloat -> IO r) -> IO r
forall t r. Storable t => t -> (Ptr t -> IO r) -> IO r
putAsPtr (Float -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
n)

instance ToSQL Double where
  type PQDest Double = CDouble
  toSQL :: Double -> ParamAllocator -> (Ptr (PQDest Double) -> IO r) -> IO r
toSQL Double
n ParamAllocator
_ = CDouble -> (Ptr CDouble -> IO r) -> IO r
forall t r. Storable t => t -> (Ptr t -> IO r) -> IO r
putAsPtr (Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
n)

-- CHAR

instance ToSQL Char where
  type PQDest Char = CChar
  toSQL :: Char -> ParamAllocator -> (Ptr (PQDest Char) -> IO r) -> IO r
toSQL Char
c ParamAllocator
_ Ptr (PQDest Char) -> IO r
conv
    | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
> Char
'\255' = String -> IO r
forall a. String -> IO a
hpqTypesError (String -> IO r) -> String -> IO r
forall a b. (a -> b) -> a -> b
$ String
"toSQL (Char): character " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" cannot be losslessly converted to CChar"
    | Bool
otherwise = CChar -> (Ptr CChar -> IO r) -> IO r
forall t r. Storable t => t -> (Ptr t -> IO r) -> IO r
putAsPtr (Char -> CChar
castCharToCChar Char
c) Ptr CChar -> IO r
Ptr (PQDest Char) -> IO r
conv

instance ToSQL Word8 where
  type PQDest Word8 = CChar
  toSQL :: Word8 -> ParamAllocator -> (Ptr (PQDest Word8) -> IO r) -> IO r
toSQL Word8
c ParamAllocator
_ = CChar -> (Ptr CChar -> IO r) -> IO r
forall t r. Storable t => t -> (Ptr t -> IO r) -> IO r
putAsPtr (Word8 -> CChar
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
c)

-- VARIABLE-LENGTH CHARACTER TYPES

-- | Encodes underlying C string as UTF-8, so if you are working
-- with a different encoding, you should not rely on this instance.
instance ToSQL T.Text where
  type PQDest T.Text = PGbytea
  toSQL :: Text -> ParamAllocator -> (Ptr (PQDest Text) -> IO r) -> IO r
toSQL = ByteString -> ParamAllocator -> (Ptr PGbytea -> IO r) -> IO r
forall t r.
ToSQL t =>
t -> ParamAllocator -> (Ptr (PQDest t) -> IO r) -> IO r
toSQL (ByteString -> ParamAllocator -> (Ptr PGbytea -> IO r) -> IO r)
-> (Text -> ByteString)
-> Text
-> ParamAllocator
-> (Ptr PGbytea -> IO r)
-> IO r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8

-- | Encodes underlying C string as UTF-8, so if you are working
-- with a different encoding, you should not rely on this instance.
instance ToSQL TL.Text where
  type PQDest TL.Text = PGbytea
  toSQL :: Text -> ParamAllocator -> (Ptr (PQDest Text) -> IO r) -> IO r
toSQL = Text -> ParamAllocator -> (Ptr PGbytea -> IO r) -> IO r
forall t r.
ToSQL t =>
t -> ParamAllocator -> (Ptr (PQDest t) -> IO r) -> IO r
toSQL (Text -> ParamAllocator -> (Ptr PGbytea -> IO r) -> IO r)
-> (Text -> Text)
-> Text
-> ParamAllocator
-> (Ptr PGbytea -> IO r)
-> IO r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toStrict

-- | Encodes underlying C string as UTF-8, so if you are working
-- with a different encoding, you should not rely on this instance.
instance ToSQL String where
  type PQDest String = PGbytea
  toSQL :: String -> ParamAllocator -> (Ptr (PQDest String) -> IO r) -> IO r
toSQL = Text -> ParamAllocator -> (Ptr PGbytea -> IO r) -> IO r
forall t r.
ToSQL t =>
t -> ParamAllocator -> (Ptr (PQDest t) -> IO r) -> IO r
toSQL (Text -> ParamAllocator -> (Ptr PGbytea -> IO r) -> IO r)
-> (String -> Text)
-> String
-> ParamAllocator
-> (Ptr PGbytea -> IO r)
-> IO r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

instance ToSQL U.UUID where
  type PQDest U.UUID = PGuuid
  toSQL :: UUID -> ParamAllocator -> (Ptr (PQDest UUID) -> IO r) -> IO r
toSQL UUID
uuid ParamAllocator
_ = PGuuid -> (Ptr PGuuid -> IO r) -> IO r
forall t r. Storable t => t -> (Ptr t -> IO r) -> IO r
putAsPtr (PGuuid -> (Ptr PGuuid -> IO r) -> IO r)
-> PGuuid -> (Ptr PGuuid -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32 -> Word32 -> Word32 -> PGuuid
PGuuid Word32
w1 Word32
w2 Word32
w3 Word32
w4
    where
      (Word32
w1, Word32
w2, Word32
w3, Word32
w4) = UUID -> (Word32, Word32, Word32, Word32)
U.toWords UUID
uuid

-- BYTEA

instance ToSQL BS.ByteString where
  type PQDest BS.ByteString = PGbytea
  toSQL :: ByteString
-> ParamAllocator -> (Ptr (PQDest ByteString) -> IO r) -> IO r
toSQL ByteString
bs ParamAllocator
_ Ptr (PQDest ByteString) -> IO r
conv = ByteString -> (CStringLen -> IO r) -> IO r
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO r) -> IO r) -> (CStringLen -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \CStringLen
cslen ->
    -- Note: it seems that ByteString can actually store NULL pointer
    -- inside. This is bad, since NULL pointers are treated by libpqtypes
    -- as NULL values. To get around that, nullStringCStringLen is used
    -- (a static pointer to empty string defined on C level). Actually,
    -- it would be sufficient to pass any non-NULL pointer there, but
    -- this is much uglier and dangerous.
    (PGbytea -> (Ptr PGbytea -> IO r) -> IO r)
-> (Ptr PGbytea -> IO r) -> PGbytea -> IO r
forall a b c. (a -> b -> c) -> b -> a -> c
flip PGbytea -> (Ptr PGbytea -> IO r) -> IO r
forall t r. Storable t => t -> (Ptr t -> IO r) -> IO r
putAsPtr Ptr PGbytea -> IO r
Ptr (PQDest ByteString) -> IO r
conv (PGbytea -> IO r) -> (CStringLen -> PGbytea) -> CStringLen -> IO r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CStringLen -> PGbytea
cStringLenToBytea (CStringLen -> IO r) -> CStringLen -> IO r
forall a b. (a -> b) -> a -> b
$
      if CStringLen -> Ptr CChar
forall a b. (a, b) -> a
fst CStringLen
cslen Ptr CChar -> Ptr CChar -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr CChar
forall a. Ptr a
nullPtr
        then CStringLen
nullStringCStringLen
        else CStringLen
cslen

instance ToSQL BSL.ByteString where
  type PQDest BSL.ByteString = PGbytea
  toSQL :: ByteString
-> ParamAllocator -> (Ptr (PQDest ByteString) -> IO r) -> IO r
toSQL = ByteString -> ParamAllocator -> (Ptr PGbytea -> IO r) -> IO r
forall t r.
ToSQL t =>
t -> ParamAllocator -> (Ptr (PQDest t) -> IO r) -> IO r
toSQL (ByteString -> ParamAllocator -> (Ptr PGbytea -> IO r) -> IO r)
-> (ByteString -> ByteString)
-> ByteString
-> ParamAllocator
-> (Ptr PGbytea -> IO r)
-> IO r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict

-- DATE

instance ToSQL Day where
  type PQDest Day = PGdate
  toSQL :: Day -> ParamAllocator -> (Ptr (PQDest Day) -> IO r) -> IO r
toSQL Day
day ParamAllocator
_ = PGdate -> (Ptr PGdate -> IO r) -> IO r
forall t r. Storable t => t -> (Ptr t -> IO r) -> IO r
putAsPtr (Day -> PGdate
dayToPGdate Day
day)

-- TIME

instance ToSQL TimeOfDay where
  type PQDest TimeOfDay = PGtime
  toSQL :: TimeOfDay
-> ParamAllocator -> (Ptr (PQDest TimeOfDay) -> IO r) -> IO r
toSQL TimeOfDay
tod ParamAllocator
_ = PGtime -> (Ptr PGtime -> IO r) -> IO r
forall t r. Storable t => t -> (Ptr t -> IO r) -> IO r
putAsPtr (TimeOfDay -> PGtime
timeOfDayToPGtime TimeOfDay
tod)

-- TIMESTAMP

instance ToSQL LocalTime where
  type PQDest LocalTime = PGtimestamp
  toSQL :: LocalTime
-> ParamAllocator -> (Ptr (PQDest LocalTime) -> IO r) -> IO r
toSQL LocalTime{TimeOfDay
Day
localDay :: LocalTime -> Day
localTimeOfDay :: LocalTime -> TimeOfDay
localTimeOfDay :: TimeOfDay
localDay :: Day
..} ParamAllocator
_ = PGtimestamp -> (Ptr PGtimestamp -> IO r) -> IO r
forall t r. Storable t => t -> (Ptr t -> IO r) -> IO r
putAsPtr PGtimestamp :: CLLong -> PGdate -> PGtime -> PGtimestamp
PGtimestamp {
    pgTimestampEpoch :: CLLong
pgTimestampEpoch = CLLong
0
  , pgTimestampDate :: PGdate
pgTimestampDate = Day -> PGdate
dayToPGdate Day
localDay
  , pgTimestampTime :: PGtime
pgTimestampTime = TimeOfDay -> PGtime
timeOfDayToPGtime TimeOfDay
localTimeOfDay
  }

-- TIMESTAMPTZ

instance ToSQL UTCTime where
  type PQDest UTCTime = PGtimestamp
  toSQL :: UTCTime -> ParamAllocator -> (Ptr (PQDest UTCTime) -> IO r) -> IO r
toSQL UTCTime{DiffTime
Day
utctDay :: UTCTime -> Day
utctDayTime :: UTCTime -> DiffTime
utctDayTime :: DiffTime
utctDay :: Day
..} ParamAllocator
_ = PGtimestamp -> (Ptr PGtimestamp -> IO r) -> IO r
forall t r. Storable t => t -> (Ptr t -> IO r) -> IO r
putAsPtr PGtimestamp :: CLLong -> PGdate -> PGtime -> PGtimestamp
PGtimestamp {
    pgTimestampEpoch :: CLLong
pgTimestampEpoch = CLLong
0
  , pgTimestampDate :: PGdate
pgTimestampDate = Day -> PGdate
dayToPGdate Day
utctDay
  , pgTimestampTime :: PGtime
pgTimestampTime = TimeOfDay -> PGtime
timeOfDayToPGtime (TimeOfDay -> PGtime) -> TimeOfDay -> PGtime
forall a b. (a -> b) -> a -> b
$ DiffTime -> TimeOfDay
timeToTimeOfDay DiffTime
utctDayTime
  }

instance ToSQL ZonedTime where
  type PQDest ZonedTime = PGtimestamp
  toSQL :: ZonedTime
-> ParamAllocator -> (Ptr (PQDest ZonedTime) -> IO r) -> IO r
toSQL ZonedTime{LocalTime
TimeZone
zonedTimeToLocalTime :: ZonedTime -> LocalTime
zonedTimeZone :: ZonedTime -> TimeZone
zonedTimeZone :: TimeZone
zonedTimeToLocalTime :: LocalTime
..} ParamAllocator
_ = PGtimestamp -> (Ptr PGtimestamp -> IO r) -> IO r
forall t r. Storable t => t -> (Ptr t -> IO r) -> IO r
putAsPtr PGtimestamp :: CLLong -> PGdate -> PGtime -> PGtimestamp
PGtimestamp {
    pgTimestampEpoch :: CLLong
pgTimestampEpoch = CLLong
0
  , pgTimestampDate :: PGdate
pgTimestampDate = Day -> PGdate
dayToPGdate (Day -> PGdate) -> Day -> PGdate
forall a b. (a -> b) -> a -> b
$ LocalTime -> Day
localDay LocalTime
zonedTimeToLocalTime
  , pgTimestampTime :: PGtime
pgTimestampTime = (TimeOfDay -> PGtime
timeOfDayToPGtime (TimeOfDay -> PGtime) -> TimeOfDay -> PGtime
forall a b. (a -> b) -> a -> b
$ LocalTime -> TimeOfDay
localTimeOfDay LocalTime
zonedTimeToLocalTime) {
      pgTimeGMTOff :: CInt
pgTimeGMTOff = Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TimeZone -> Int
timeZoneMinutes TimeZone
zonedTimeZone) CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
* CInt
60
    }
  }

-- BOOL

instance ToSQL Bool where
  type PQDest Bool = CInt
  toSQL :: Bool -> ParamAllocator -> (Ptr (PQDest Bool) -> IO r) -> IO r
toSQL Bool
True  ParamAllocator
_ = CInt -> (Ptr CInt -> IO r) -> IO r
forall t r. Storable t => t -> (Ptr t -> IO r) -> IO r
putAsPtr CInt
1
  toSQL Bool
False ParamAllocator
_ = CInt -> (Ptr CInt -> IO r) -> IO r
forall t r. Storable t => t -> (Ptr t -> IO r) -> IO r
putAsPtr CInt
0

----------------------------------------

timeOfDayToPGtime :: TimeOfDay -> PGtime
timeOfDayToPGtime :: TimeOfDay -> PGtime
timeOfDayToPGtime TimeOfDay{Int
Pico
todHour :: TimeOfDay -> Int
todMin :: TimeOfDay -> Int
todSec :: TimeOfDay -> Pico
todSec :: Pico
todMin :: Int
todHour :: Int
..} = PGtime :: CInt
-> CInt
-> CInt
-> CInt
-> CInt
-> CInt
-> CInt
-> ByteString
-> PGtime
PGtime {
    pgTimeHour :: CInt
pgTimeHour   = Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
todHour
  , pgTimeMin :: CInt
pgTimeMin    = Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
todMin
  , pgTimeSec :: CInt
pgTimeSec    = CInt
sec
  , pgTimeUSec :: CInt
pgTimeUSec   = CInt
usec
  , pgTimeWithTZ :: CInt
pgTimeWithTZ = CInt
0
  , pgTimeIsDST :: CInt
pgTimeIsDST  = CInt
0
  , pgTimeGMTOff :: CInt
pgTimeGMTOff = CInt
0
  , pgTimeTZAbbr :: ByteString
pgTimeTZAbbr = ByteString
BS.empty
  }
  where
    (CInt
sec, CInt
usec) = Rational -> CInt
forall a b. (RealFrac a, Integral b) => a -> b
floor ((Pico -> Rational
forall a. Real a => a -> Rational
toRational Pico
todSec) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
1000000) CInt -> CInt -> (CInt, CInt)
forall a. Integral a => a -> a -> (a, a)
`divMod` CInt
1000000

dayToPGdate :: Day -> PGdate
dayToPGdate :: Day -> PGdate
dayToPGdate Day
day = PGdate :: CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> PGdate
PGdate {
    pgDateIsBC :: CInt
pgDateIsBC  = CInt
isBC
  , pgDateYear :: CInt
pgDateYear  = Integer -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> CInt) -> Integer -> CInt
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
adjustBC Integer
year
  , pgDateMon :: CInt
pgDateMon   = Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ Int
mon Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
  , pgDateMDay :: CInt
pgDateMDay  = Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
mday
  , pgDateJDay :: CInt
pgDateJDay  = CInt
0
  , pgDateYDay :: CInt
pgDateYDay  = CInt
0
  , pgDateWDay :: CInt
pgDateWDay  = CInt
0
  }
  where
    (Integer
year, Int
mon, Int
mday) = Day -> (Integer, Int, Int)
toGregorian Day
day

    -- Note: inverses of appropriate functions
    -- in pgDateToDay defined in FromSQL module
    isBC :: CInt
isBC = if Integer
year Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 then CInt
1 else CInt
0
    adjustBC :: Integer -> Integer
adjustBC = if CInt
isBC CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
1 then Integer -> Integer
forall a. Enum a => a -> a
succ (Integer -> Integer) -> (Integer -> Integer) -> Integer -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer
forall a. Num a => a -> a
negate else Integer -> Integer
forall a. a -> a
id