FromSQL.hs

module Database.PostgreSQL.PQTypes.FromSQL
  ( FromSQL (..)
  ) where

import Control.Exception qualified as E
import Data.ByteString.Char8 qualified as BS
import Data.ByteString.Lazy.Char8 qualified as BSL
import Data.Int
import Data.Kind (Type)
import Data.Ratio
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.Storable

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

-- | Class which represents \"from SQL (libpqtypes)
-- type to Haskell type\" transformation.
class (PQFormat t, Storable (PQBase t)) => FromSQL t where
  -- | Base type (used by libpqtypes).
  type PQBase t :: Type

  -- | Convert value of base type to target one.
  fromSQL
    :: Maybe (PQBase t)
    -- ^ base value (Nothing if NULL was delivered)
    -> IO t

-- NULLables

instance FromSQL t => FromSQL (Maybe t) where
  type PQBase (Maybe t) = PQBase t
  fromSQL mbase = case mbase of
    Just _ -> Just <$> fromSQL mbase
    Nothing -> pure Nothing

-- NUMERICS

instance FromSQL Int16 where
  type PQBase Int16 = CShort
  fromSQL Nothing = unexpectedNULL
  fromSQL (Just n) = pure . fromIntegral $ n

instance FromSQL Int32 where
  type PQBase Int32 = CInt
  fromSQL Nothing = unexpectedNULL
  fromSQL (Just n) = pure . fromIntegral $ n

instance FromSQL Int64 where
  type PQBase Int64 = CLLong
  fromSQL Nothing = unexpectedNULL
  fromSQL (Just n) = pure . fromIntegral $ n

instance FromSQL Float where
  type PQBase Float = CFloat
  fromSQL Nothing = unexpectedNULL
  fromSQL (Just n) = pure . realToFrac $ n

instance FromSQL Double where
  type PQBase Double = CDouble
  fromSQL Nothing = unexpectedNULL
  fromSQL (Just n) = pure . realToFrac $ n

-- CHAR

instance FromSQL Char where
  type PQBase Char = CChar
  fromSQL Nothing = unexpectedNULL
  fromSQL (Just c) = pure . castCCharToChar $ c

instance FromSQL Word8 where
  type PQBase Word8 = CChar
  fromSQL Nothing = unexpectedNULL
  fromSQL (Just c) = pure . fromIntegral $ c

-- VARIABLE-LENGTH CHARACTER TYPES

-- | Assumes that source C string is UTF-8, so if you are working
-- with a different encoding, you should not rely on this instance.
instance FromSQL T.Text where
  type PQBase T.Text = PGbytea
  fromSQL mbytea = either E.throwIO pure . decodeUtf8' =<< fromSQL mbytea

-- | Assumes that source C string is UTF-8, so if you are working
-- with a different encoding, you should not rely on this instance
instance FromSQL TL.Text where
  type PQBase TL.Text = PGbytea
  fromSQL = fmap TL.fromStrict . fromSQL

-- | Assumes that source C string is UTF-8, so if you are working
-- with a different encoding, you should not rely on this instance.
instance FromSQL String where
  type PQBase String = PGbytea
  fromSQL mbytea = T.unpack <$> fromSQL mbytea

instance FromSQL U.UUID where
  type PQBase U.UUID = PGuuid
  fromSQL Nothing = unexpectedNULL
  fromSQL (Just (PGuuid w1 w2 w3 w4)) = pure $ U.fromWords w1 w2 w3 w4

-- BYTEA

instance FromSQL BS.ByteString where
  type PQBase BS.ByteString = PGbytea
  fromSQL Nothing = unexpectedNULL
  fromSQL (Just bytea) = BS.packCStringLen $ byteaToCStringLen bytea

instance FromSQL BSL.ByteString where
  type PQBase BSL.ByteString = PGbytea
  fromSQL = fmap BSL.fromStrict . fromSQL

-- DATE

instance FromSQL Day where
  type PQBase Day = PGdate
  fromSQL Nothing = unexpectedNULL
  fromSQL (Just date) = pure . pgDateToDay $ date

-- TIME

instance FromSQL TimeOfDay where
  type PQBase TimeOfDay = PGtime
  fromSQL Nothing = unexpectedNULL
  fromSQL (Just time) = pure . pgTimeToTimeOfDay $ time

-- TIMESTAMP

instance FromSQL LocalTime where
  type PQBase LocalTime = PGtimestamp
  fromSQL Nothing = unexpectedNULL
  fromSQL (Just PGtimestamp {..}) = pure $ LocalTime day tod
    where
      day = pgDateToDay pgTimestampDate
      tod = pgTimeToTimeOfDay pgTimestampTime

-- TIMESTAMPTZ

-- | 'FromSQL' instance for 'ZonedTime' doesn't exist because
-- PostgreSQL doesn't provide zone offset information when returning
-- timestamps with time zone in a binary format.
instance FromSQL UTCTime where
  type PQBase UTCTime = PGtimestamp
  fromSQL Nothing = unexpectedNULL
  fromSQL jts@(Just PGtimestamp {..}) = do
    localTime <- fromSQL jts
    case rest of
      0 -> pure . localTimeToUTC (minutesToTimeZone mins) $ localTime
      _ -> hpqTypesError $ "Invalid gmtoff: " ++ show gmtoff
    where
      gmtoff = pgTimeGMTOff pgTimestampTime
      (mins, rest) = fromIntegral gmtoff `divMod` 60

-- BOOL

instance FromSQL Bool where
  type PQBase Bool = CInt
  fromSQL Nothing = unexpectedNULL
  fromSQL (Just n) = case n of
    0 -> pure False
    _ -> pure True

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

-- | Convert PGtime to Day.
pgDateToDay :: PGdate -> Day
pgDateToDay PGdate {..} = fromGregorian year mon mday
  where
    year = adjustBC $ fromIntegral pgDateYear
    -- Note: libpqtypes represents months as numbers in range
    -- [0, 11], whereas Haskell uses [1, 12], hence plus one.
    mon = fromIntegral $ pgDateMon + 1
    mday = fromIntegral pgDateMDay
    -- Note: PostgreSQL has no notion of '0th year', it's 1 AD
    -- and then before that 1 BC for it. Since Haskell represents
    -- date according to ISO-8601, where 0th year means 1 BC, we
    -- want to change the sign and adjust the year by one here,
    -- if appropriate.
    adjustBC = if pgDateIsBC == 1 then negate . pred else id

-- | Convert PGtime to TimeOfDay.
pgTimeToTimeOfDay :: PGtime -> TimeOfDay
pgTimeToTimeOfDay PGtime {..} = TimeOfDay hour mins $ sec + fromRational (usec % 1000000)
  where
    hour = fromIntegral pgTimeHour
    mins = fromIntegral pgTimeMin
    sec = fromIntegral pgTimeSec
    usec = fromIntegral pgTimeUSec