Tuple.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Description: newtype to support FromSql instances for row types.

module Preql.FromSql.Tuple where

import Preql.FromSql.Class (FieldDecoder(..))
import Preql.Wire.Errors (PgType(..))

import Control.Monad (unless)
import Data.Bits ((.|.), Bits, shiftL)
import Data.Int (Int32)
import qualified BinaryParser as BP
import qualified Data.ByteString as BS
import qualified Data.Text as T
import qualified Database.PostgreSQL.LibPQ as PQ

-- | Wrapper for Postgres anonymous row types (sometimes called record
-- types), so instance resolution picks the right decoder.  The useful
-- instances are for (Haskell) tuples.  Postgres allows row types with
-- a single field, but the instances would overlap with those for
-- nested row types, so we do not provide them.
newtype Tuple r = Tuple r
  deriving (Eq, Ord, Show)

-- Unlike the same-named functions in PostgreSQL.Binary.Decoding, these check
-- the number of components and the OIDs of each component.

-- | Helper for decoding composites
newtype Composite a = Composite (BP.BinaryParser a)
  deriving newtype (Functor, Applicative)

composite :: Int -> Composite a -> BP.BinaryParser a
composite n (Composite parser) = do
  size <- intOfSize 4
  unless (size == n) (BP.failure "composite has wrong size")
  parser

valueComposite :: FieldDecoder a -> Composite a
valueComposite (FieldDecoder pgType parser) = Composite $ do
  case pgType of
    -- For now, we only confirm statically-known OIDs.  To do more, we'll need
    -- to feed through the OID cache (not yet implemented) and the Connection
    -- (which will be a problem if we ever implement lazy decoding)
    -- Statically-known OIDs seems like a reasonable compromise for now, until
    -- other parts of the design stabilize.
    Oid (PQ.Oid expected) _ -> do
      actual <- intOfSize 4
      unless (actual == expected) (BP.failure $ "OID in composite expected=" <> showt expected <> " actual=" <> showt actual)
    TypeName _ -> BP.unitOfSize 4 -- TODO check cache, maybe query DB
  onContent parser >>=
    maybe (BP.failure "unexpected null") pure
  where showt = T.pack . show

{-# INLINE intOfSize #-}
intOfSize :: (Integral a, Bits a) => Int -> BP.BinaryParser a
intOfSize x =
  fmap (BS.foldl' (\n h -> shiftL n 8 .|. fromIntegral h) 0) (BP.bytesOfSize x)

{-# INLINABLE onContent #-}
onContent :: BP.BinaryParser a -> BP.BinaryParser ( Maybe a )
onContent decoder = do
  size :: Int32 <- intOfSize 4
  case size of
    (-1) -> pure Nothing
    n -> fmap Just (BP.sized (fromIntegral n) decoder)