ToSQL.hs

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

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

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 x conv = alloca $ \ptr -> poke ptr x >> conv ptr

-- NULLables

instance ToSQL t => ToSQL (Maybe t) where
  type PQDest (Maybe t) = PQDest t
  toSQL mt allocParam conv = case mt of
    Nothing -> conv nullPtr
    Just t -> toSQL t allocParam conv

-- NUMERICS

instance ToSQL Int16 where
  type PQDest Int16 = CShort
  toSQL n _ = putAsPtr (fromIntegral n)

instance ToSQL Int32 where
  type PQDest Int32 = CInt
  toSQL n _ = putAsPtr (fromIntegral n)

instance ToSQL Int64 where
  type PQDest Int64 = CLLong
  toSQL n _ = putAsPtr (fromIntegral n)

instance ToSQL Int where
  type PQDest Int = CLLong
  toSQL n _ = putAsPtr (fromIntegral n)

instance ToSQL Float where
  type PQDest Float = CFloat
  toSQL n _ = putAsPtr (realToFrac n)

instance ToSQL Double where
  type PQDest Double = CDouble
  toSQL n _ = putAsPtr (realToFrac n)

-- CHAR

instance ToSQL Char where
  type PQDest Char = CChar
  toSQL c _ conv
    | c > '\255' = hpqTypesError $ "toSQL (Char): character " ++ show c ++ " cannot be losslessly converted to CChar"
    | otherwise = putAsPtr (castCharToCChar c) conv

instance ToSQL Word8 where
  type PQDest Word8 = CChar
  toSQL c _ = putAsPtr (fromIntegral 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 = toSQL . 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 = toSQL . 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 = toSQL . T.pack

instance ToSQL U.UUID where
  type PQDest U.UUID = PGuuid
  toSQL uuid _ = putAsPtr $ PGuuid w1 w2 w3 w4
    where
      (w1, w2, w3, w4) = U.toWords uuid

-- BYTEA

instance ToSQL BS.ByteString where
  type PQDest BS.ByteString = PGbytea
  toSQL bs _ conv = unsafeUseAsCStringLen bs $ \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.
    flip putAsPtr conv . cStringLenToBytea $
      if fst cslen == nullPtr
        then nullStringCStringLen
        else cslen

instance ToSQL BSL.ByteString where
  type PQDest BSL.ByteString = PGbytea
  toSQL = toSQL . BSL.toStrict

-- DATE

instance ToSQL Day where
  type PQDest Day = PGdate
  toSQL day _ = putAsPtr (dayToPGdate day)

-- TIME

instance ToSQL TimeOfDay where
  type PQDest TimeOfDay = PGtime
  toSQL tod _ = putAsPtr (timeOfDayToPGtime tod)

-- TIMESTAMP

instance ToSQL LocalTime where
  type PQDest LocalTime = PGtimestamp
  toSQL LocalTime {..} _ =
    putAsPtr
      PGtimestamp
        { pgTimestampEpoch = 0
        , pgTimestampDate = dayToPGdate localDay
        , pgTimestampTime = timeOfDayToPGtime localTimeOfDay
        }

-- TIMESTAMPTZ

instance ToSQL UTCTime where
  type PQDest UTCTime = PGtimestamp
  toSQL UTCTime {..} _ =
    putAsPtr
      PGtimestamp
        { pgTimestampEpoch = 0
        , pgTimestampDate = dayToPGdate utctDay
        , pgTimestampTime = timeOfDayToPGtime $ timeToTimeOfDay utctDayTime
        }

instance ToSQL ZonedTime where
  type PQDest ZonedTime = PGtimestamp
  toSQL ZonedTime {..} _ =
    putAsPtr
      PGtimestamp
        { pgTimestampEpoch = 0
        , pgTimestampDate = dayToPGdate $ localDay zonedTimeToLocalTime
        , pgTimestampTime =
            (timeOfDayToPGtime $ localTimeOfDay zonedTimeToLocalTime)
              { pgTimeGMTOff = fromIntegral (timeZoneMinutes zonedTimeZone) * 60
              }
        }

-- BOOL

instance ToSQL Bool where
  type PQDest Bool = CInt
  toSQL True _ = putAsPtr 1
  toSQL False _ = putAsPtr 0

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

timeOfDayToPGtime :: TimeOfDay -> PGtime
timeOfDayToPGtime TimeOfDay {..} =
  PGtime
    { pgTimeHour = fromIntegral todHour
    , pgTimeMin = fromIntegral todMin
    , pgTimeSec = sec
    , pgTimeUSec = usec
    , pgTimeWithTZ = 0
    , pgTimeIsDST = 0
    , pgTimeGMTOff = 0
    , pgTimeTZAbbr = BS.empty
    }
  where
    (sec, usec) = floor (toRational todSec * 1000000) `divMod` 1000000

dayToPGdate :: Day -> PGdate
dayToPGdate day =
  PGdate
    { pgDateIsBC = isBC
    , pgDateYear = fromIntegral $ adjustBC year
    , pgDateMon = fromIntegral $ mon - 1
    , pgDateMDay = fromIntegral mday
    , pgDateJDay = 0
    , pgDateYDay = 0
    , pgDateWDay = 0
    }
  where
    (year, mon, mday) = toGregorian day

    -- Note: inverses of appropriate functions
    -- in pgDateToDay defined in FromSQL module
    isBC = if year <= 0 then 1 else 0
    adjustBC = if isBC == 1 then succ . negate else id