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 :: forall t r. Storable t => t -> (Ptr t -> IO r) -> IO r
putAsPtr t
x Ptr t -> IO r
conv = forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr t
ptr -> forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr t
ptr t
x 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 :: forall r.
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 forall a. Ptr a
nullPtr
    Just t
t  -> forall t r.
ToSQL t =>
t -> ParamAllocator -> (Ptr (PQDest t) -> IO r) -> IO r
toSQL t
t ParamAllocator
allocParam Ptr (PQDest (Maybe t)) -> IO r
conv

-- NUMERICS

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

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

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

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

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

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

-- CHAR

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

instance ToSQL Word8 where
  type PQDest Word8 = CChar
  toSQL :: forall r.
Word8 -> ParamAllocator -> (Ptr (PQDest Word8) -> IO r) -> IO r
toSQL Word8
c ParamAllocator
_ = forall t r. Storable t => t -> (Ptr t -> IO r) -> IO r
putAsPtr (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 :: forall r.
Text -> ParamAllocator -> (Ptr (PQDest Text) -> IO r) -> IO r
toSQL = forall t r.
ToSQL t =>
t -> ParamAllocator -> (Ptr (PQDest t) -> IO r) -> IO r
toSQL 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 :: forall r.
Text -> ParamAllocator -> (Ptr (PQDest Text) -> IO r) -> IO r
toSQL = forall t r.
ToSQL t =>
t -> ParamAllocator -> (Ptr (PQDest t) -> IO r) -> IO r
toSQL 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 :: forall r.
[Char] -> ParamAllocator -> (Ptr (PQDest [Char]) -> IO r) -> IO r
toSQL = forall t r.
ToSQL t =>
t -> ParamAllocator -> (Ptr (PQDest t) -> IO r) -> IO r
toSQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack

instance ToSQL U.UUID where
  type PQDest U.UUID = PGuuid
  toSQL :: forall r.
UUID -> ParamAllocator -> (Ptr (PQDest UUID) -> IO r) -> IO r
toSQL UUID
uuid ParamAllocator
_ = forall t r. Storable t => t -> (Ptr t -> IO r) -> IO r
putAsPtr 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 :: forall r.
ByteString
-> ParamAllocator -> (Ptr (PQDest ByteString) -> IO r) -> IO r
toSQL ByteString
bs ParamAllocator
_ Ptr (PQDest ByteString) -> IO r
conv = forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
bs 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.
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall t r. Storable t => t -> (Ptr t -> IO r) -> IO r
putAsPtr Ptr (PQDest ByteString) -> IO r
conv forall b c a. (b -> c) -> (a -> b) -> a -> c
. CStringLen -> PGbytea
cStringLenToBytea forall a b. (a -> b) -> a -> b
$
      if forall a b. (a, b) -> a
fst CStringLen
cslen forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr
        then CStringLen
nullStringCStringLen
        else CStringLen
cslen

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

-- DATE

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

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

-- BOOL

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

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

timeOfDayToPGtime :: TimeOfDay -> PGtime
timeOfDayToPGtime :: TimeOfDay -> PGtime
timeOfDayToPGtime TimeOfDay{MonthOfYear
Pico
todHour :: TimeOfDay -> MonthOfYear
todMin :: TimeOfDay -> MonthOfYear
todSec :: TimeOfDay -> Pico
todSec :: Pico
todMin :: MonthOfYear
todHour :: MonthOfYear
..} = PGtime {
    pgTimeHour :: CInt
pgTimeHour   = forall a b. (Integral a, Num b) => a -> b
fromIntegral MonthOfYear
todHour
  , pgTimeMin :: CInt
pgTimeMin    = forall a b. (Integral a, Num b) => a -> b
fromIntegral MonthOfYear
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) = forall a b. (RealFrac a, Integral b) => a -> b
floor ((forall a. Real a => a -> Rational
toRational Pico
todSec) forall a. Num a => a -> a -> a
* Rational
1000000) forall a. Integral a => a -> a -> (a, a)
`divMod` CInt
1000000

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

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