From d618b767a892af278466e75299f232c85479d71d Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Wed, 12 Aug 2026 14:21:35 -0300 Subject: [PATCH 01/35] Faster Generically derived row decoders This improves our "Record Stream" benchmarks by ~8.2%, even if total memory allocated goes up a bit. --- Runfile | 6 ++++ hpgsql-benchmarks/src/Main.hs | 2 ++ hpgsql-tests/RowDecoderGhcCore.hs | 53 +++++++++++++++++++++++++++++++ hpgsql-tests/hpgsql-tests.cabal | 1 + hpgsql/src/Hpgsql/Encoding.hs | 9 +++++- 5 files changed, 70 insertions(+), 1 deletion(-) create mode 100644 hpgsql-tests/RowDecoderGhcCore.hs diff --git a/Runfile b/Runfile index bcb45a5..5592c6a 100644 --- a/Runfile +++ b/Runfile @@ -104,3 +104,9 @@ tests-compat: cabal build hpgsql-simple-compat-tests nix-shell -A "shellPg${pg}" ./default.nix --run "./scripts/run-hpgsql-simple-compat-tests-db-internal.sh $TARGS" done + +ghc-core: + set -eo pipefail + rm -f dist-newstyle/build/x86_64-linux/ghc-9.10.3/hpgsql-tests-0.1.0.0/x/hpgsql-tests/build/hpgsql-tests/hpgsql-tests-tmp/RowDecoderGhcCore.thr.dump-simpl + cabal build hpgsql-tests 1>&2 + cat dist-newstyle/build/x86_64-linux/ghc-9.10.3/hpgsql-tests-0.1.0.0/x/hpgsql-tests/build/hpgsql-tests/hpgsql-tests-tmp/RowDecoderGhcCore.thr.dump-simpl diff --git a/hpgsql-benchmarks/src/Main.hs b/hpgsql-benchmarks/src/Main.hs index 081cc9f..139bd82 100644 --- a/hpgsql-benchmarks/src/Main.hs +++ b/hpgsql-benchmarks/src/Main.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -ddump-simpl -ddump-to-file #-} + module Main where import Control.Concurrent.Async (mapConcurrently) diff --git a/hpgsql-tests/RowDecoderGhcCore.hs b/hpgsql-tests/RowDecoderGhcCore.hs new file mode 100644 index 0000000..e53d8a5 --- /dev/null +++ b/hpgsql-tests/RowDecoderGhcCore.hs @@ -0,0 +1,53 @@ +{-# OPTIONS_GHC -ddump-simpl -ddump-to-file #-} + +-- | +-- This is not a real test module. It's just a type deriving `FromPgRow` +-- so we can look at GHC Core output. +module RowDecoderGhcCore where + +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (Day, UTCTime) +import GHC.Generics (Generic) +import Hpgsql.Encoding (FromPgRow (..), fieldDecoder, genericFromPgRow, singleField) + +data BenchRow = BenchRow + { brId :: !Int, + brDate1 :: !Day, + brDate2 :: !Day, + brTimestamp1 :: !UTCTime, + brTimestamp2 :: !UTCTime, + brText1 :: !Text, + brText2 :: !Text, + brDouble1 :: !Double, + brDouble2 :: !Double, + brMaybeInt :: !(Maybe Int), + brMaybeText :: !(Maybe Text), + brMaybeDouble :: !(Maybe Double), + brMaybeDay :: !(Maybe Day) + } + +-- Generically deriving section. + +deriving instance Generic BenchRow + +instance FromPgRow BenchRow where + rowDecoder = genericFromPgRow + +-- Hand-written applicative style deriving section. +-- instance FromPgRow BenchRow where +-- rowDecoder = +-- SomeRecord +-- <$> singleField fieldDecoder +-- <*> singleField fieldDecoder +-- <*> singleField fieldDecoder +-- <*> singleField fieldDecoder +-- <*> singleField fieldDecoder +-- <*> singleField fieldDecoder +-- <*> singleField fieldDecoder +-- <*> singleField fieldDecoder +-- <*> singleField fieldDecoder +-- <*> singleField fieldDecoder +-- <*> singleField fieldDecoder +-- <*> singleField fieldDecoder +-- <*> singleField fieldDecoder diff --git a/hpgsql-tests/hpgsql-tests.cabal b/hpgsql-tests/hpgsql-tests.cabal index 4a16b6b..8528097 100644 --- a/hpgsql-tests/hpgsql-tests.cabal +++ b/hpgsql-tests/hpgsql-tests.cabal @@ -36,6 +36,7 @@ executable hpgsql-tests ParsingSpec PipelineSpec PreparedStatementsSpec + RowDecoderGhcCore SqlQuasiquoterSpec TestUtils ThreadSafetySpec diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index f653109..6a1e771 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -76,6 +76,7 @@ import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as LBS import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI +import Data.Coerce (coerce) import Data.Fixed (divMod') import Data.Functor.Contravariant (Contravariant (..)) import Data.Int (Int16, Int32, Int64) @@ -1192,13 +1193,19 @@ class ProductTypeDecoder f where genRowDecoder :: RowDecoder (f a) instance (ProductTypeDecoder a, ProductTypeDecoder b) => ProductTypeDecoder (a :*: b) where + {-# INLINE genRowDecoder #-} genRowDecoder = (:*:) <$> genRowDecoder <*> genRowDecoder instance (ProductTypeDecoder f) => ProductTypeDecoder (M1 a c f) where + {-# INLINE genRowDecoder #-} genRowDecoder = M1 <$> genRowDecoder instance (FromPgField a) => ProductTypeDecoder (K1 r a) where - genRowDecoder = fmap K1 $ singleField $ fieldDecoder @a + {-# INLINE genRowDecoder #-} + -- coercing instead of fmap reduces memory usage, apparently + -- by reducing (unnecessary) closures in the final row decoder, + -- as per looking at GHC Core + genRowDecoder = coerce $ singleField $ fieldDecoder @a genericToPgRow :: forall a. (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a genericToPgRow = contramap from genRowEncoder From 668a3edc1ec068d668c52636f4c12b24aefa106d Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Tue, 11 Aug 2026 14:20:00 -0300 Subject: [PATCH 02/35] Add decoding offset to hopefully reduce ByteString allocations --- hpgsql/src/Hpgsql/Encoding.hs | 28 +++--- .../src/Hpgsql/Encoding/BinarySerializer.hs | 47 +++++---- hpgsql/src/Hpgsql/Internal.hs | 2 +- hpgsql/src/Hpgsql/Msgs.hs | 10 +- hpgsql/src/Hpgsql/SimpleParser.hs | 96 +++++++++++-------- 5 files changed, 100 insertions(+), 83 deletions(-) diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index 6a1e771..dd5378f 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -735,9 +735,9 @@ binaryIntDecoder typOid = \bs -> maxBoundPgType :: Integer intDecoder :: ByteString -> Either String a (maxBoundPgType, intDecoder) - | typOid == int8Oid = (fromIntegral $ maxBound @Int64, fmap fromIntegral . BinSer.decodeInt64BE) - | typOid == int4Oid = (fromIntegral $ maxBound @Int32, fmap fromIntegral . BinSer.decodeInt32BE) - | typOid == int2Oid = (fromIntegral $ maxBound @Int16, fmap fromIntegral . BinSer.decodeInt16BE) + | typOid == int8Oid = (fromIntegral $ maxBound @Int64, fmap fromIntegral . BinSer.decodeInt64BE 0) + | typOid == int4Oid = (fromIntegral $ maxBound @Int32, fmap fromIntegral . BinSer.decodeInt32BE 0) + | typOid == int2Oid = (fromIntegral $ maxBound @Int16, fmap fromIntegral . BinSer.decodeInt16BE 0) | otherwise = error "Bug in Hpgsql. Decoding binary integral type not an int2, int4 or int8" doesFit = maxBoundPgType <= fromIntegral (maxBound @a) @@ -991,7 +991,7 @@ instance FromPgField UTCTime where fieldDecoder = parsePgType [timestamptzOid] $ \case Just bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- BinSer.decodeInt64BE bs + totalusecs <- BinSer.decodeInt64BE 0 bs let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 Right $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) @@ -1001,7 +1001,7 @@ instance FromPgField (Unbounded UTCTime) where fieldDecoder = parsePgType [timestamptzOid] $ \case Just bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- BinSer.decodeInt64BE bs + totalusecs <- BinSer.decodeInt64BE 0 bs Right $ if totalusecs == minBound then NegInfinity @@ -1018,7 +1018,7 @@ instance FromPgField ZonedTime where fieldDecoder = parsePgType [timestamptzOid] $ \case Just bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- BinSer.decodeInt64BE bs + totalusecs <- BinSer.decodeInt64BE 0 bs let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 Right $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) @@ -1028,7 +1028,7 @@ instance FromPgField (Unbounded ZonedTime) where fieldDecoder = parsePgType [timestamptzOid] $ \case Just bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- BinSer.decodeInt64BE bs + totalusecs <- BinSer.decodeInt64BE 0 bs Right $ if totalusecs == minBound then NegInfinity @@ -1044,7 +1044,7 @@ instance FromPgField (Unbounded ZonedTime) where instance FromPgField LocalTime where fieldDecoder = parsePgType [timestampOid] $ \case Just bs -> do - totalusecs <- BinSer.decodeInt64BE bs + totalusecs <- BinSer.decodeInt64BE 0 bs let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 Right $ LocalTime parsedDate (timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) @@ -1053,7 +1053,7 @@ instance FromPgField LocalTime where instance FromPgField TimeOfDay where fieldDecoder = parsePgType [timeOid] $ \case Just bs -> do - usecs <- BinSer.decodeInt64BE bs + usecs <- BinSer.decodeInt64BE 0 bs Right $ timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral usecs * 1_000_000 Nothing -> Left "Cannot decode SQL null as the Haskell TimeOfDay type. Use a `Maybe TimeOfDay`" @@ -1063,7 +1063,7 @@ instance FromPgField Day where -- There is a very specific conversion function for these, which I poorly translated to Haskell -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 -- But I found a simpler way to do this. Let's see if it works in our property based tests - jd <- BinSer.decodeInt32BE bs + jd <- BinSer.decodeInt32BE 0 bs Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 Nothing -> Left "Cannot decode SQL null as the Haskell Day type. Use a `Maybe Day`" @@ -1073,7 +1073,7 @@ instance FromPgField (Unbounded Day) where -- There is a very specific conversion function for these, which I poorly translated to Haskell -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 -- But I found a simpler way to do this. Let's see if it works in our property based tests - jd <- BinSer.decodeInt32BE bs + jd <- BinSer.decodeInt32BE 0 bs Right $ if jd == minBound then NegInfinity @@ -1087,9 +1087,9 @@ instance FromPgField (Unbounded Day) where instance FromPgField CalendarDiffTime where fieldDecoder = parsePgType [intervalOid] $ \case Just bs -> do - nMicrosecs <- BinSer.decodeInt64BE bs - nDays <- BinSer.decodeInt32BE (BS.drop 8 bs) - nMonths <- BinSer.decodeInt32BE (BS.drop 12 bs) + nMicrosecs <- BinSer.decodeInt64BE 0 bs + nDays <- BinSer.decodeInt32BE 8 bs + nMonths <- BinSer.decodeInt32BE 12 bs Right $ CalendarDiffTime {ctMonths = fromIntegral nMonths, ctTime = secondsToNominalDiffTime (fromIntegral nDays * 86400) + realToFrac (picosecondsToDiffTime (fromIntegral nMicrosecs * 1_000_000))} Nothing -> Left "Cannot decode SQL null as the Haskell CalendarDiffTime type. Use a `Maybe CalendarDiffTime`" diff --git a/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs b/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs index a21dd27..da6983c 100644 --- a/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs +++ b/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs @@ -9,7 +9,8 @@ -- The caveat is that this module makes unaligned memory access. For the target -- CPU architectures of this library, this should be fine. module Hpgsql.Encoding.BinarySerializer - ( decodeInt16BE, + ( ByteStringIdx (..), + decodeInt16BE, decodeInt32BE, decodeInt64BE, decodeWord32BE, @@ -37,7 +38,7 @@ import Data.Bits (Bits (unsafeShiftR)) import qualified Data.ByteString as BS import Data.Coerce (coerce) import Data.Maybe (fromMaybe) -import Foreign (Storable (..), peek, (.&.)) +import Foreign (Storable (..), (.&.)) import Foreign.ForeignPtr (withForeignPtr) import GHC.Float (castDoubleToWord64, castFloatToWord32) import System.IO.Unsafe (unsafeDupablePerformIO) @@ -64,12 +65,12 @@ fromBigEndian16 = byteSwap16 #endif {-# INLINE unsafeDecodeWord #-} -unsafeDecodeWord :: (Storable a) => ByteString -> Int -> (a -> a) -> Either String a -unsafeDecodeWord (InternalBS.BS bytesPtr len) minLen endianConvert = - if len >= minLen +unsafeDecodeWord :: (Storable a) => ByteStringIdx -> ByteString -> Int -> (a -> a) -> Either String a +unsafeDecodeWord idx (InternalBS.BS bytesPtr len) minLen endianConvert = + if len >= minLen + idx.idx then -- A bang (strictness) in `decodedWord` makes our benchmarks allocate more memory and run slower! - let decodedWord = endianConvert $ unsafeDupablePerformIO $ withForeignPtr bytesPtr $ \ptr -> peek (coerce ptr) + let decodedWord = endianConvert $ unsafeDupablePerformIO $ withForeignPtr bytesPtr $ \ptr -> peekByteOff (coerce ptr) idx.idx in Right decodedWord else Left "Less than enough bytes to decode" @@ -79,9 +80,12 @@ unsafeEncodeWord n endianConvert len = InternalBS.unsafeCreate len $ \bufferPtr -> poke (coerce bufferPtr) $ endianConvert n +newtype ByteStringIdx = ByteStringIdx {idx :: Int} + deriving newtype (Num) + {-# INLINE decodeInt16BE #-} -decodeInt16BE :: ByteString -> Either String Int16 -decodeInt16BE bs = fromIntegral <$> unsafeDecodeWord bs 2 fromBigEndian16 +decodeInt16BE :: ByteStringIdx -> ByteString -> Either String Int16 +decodeInt16BE idx bs = fromIntegral <$> unsafeDecodeWord idx bs 2 fromBigEndian16 {-# INLINE encodeInt16BE #-} encodeInt16BE :: Int16 -> ByteString @@ -89,23 +93,23 @@ encodeInt16BE n = unsafeEncodeWord (fromIntegral n) fromBigEndian16 2 {-# INLINE decodeWord32BE #-} decodeWord32BE :: ByteString -> Either String Word32 -decodeWord32BE bs = unsafeDecodeWord bs 4 fromBigEndian32 +decodeWord32BE bs = unsafeDecodeWord 0 bs 4 fromBigEndian32 {-# INLINE decodeWord64BE #-} decodeWord64BE :: ByteString -> Either String Word64 -decodeWord64BE bs = unsafeDecodeWord bs 8 fromBigEndian64 +decodeWord64BE bs = unsafeDecodeWord 0 bs 8 fromBigEndian64 {-# INLINE decodeInt32BE #-} -decodeInt32BE :: ByteString -> Either String Int32 -decodeInt32BE bs = fromIntegral <$> unsafeDecodeWord bs 4 fromBigEndian32 +decodeInt32BE :: ByteStringIdx -> ByteString -> Either String Int32 +decodeInt32BE idx bs = fromIntegral <$> unsafeDecodeWord idx bs 4 fromBigEndian32 {-# INLINE encodeInt32BE #-} encodeInt32BE :: Int32 -> ByteString encodeInt32BE n = unsafeEncodeWord (fromIntegral n) fromBigEndian32 4 {-# INLINE decodeInt64BE #-} -decodeInt64BE :: ByteString -> Either String Int64 -decodeInt64BE bs = fromIntegral <$> unsafeDecodeWord bs 8 fromBigEndian64 +decodeInt64BE :: ByteStringIdx -> ByteString -> Either String Int64 +decodeInt64BE idx bs = fromIntegral <$> unsafeDecodeWord idx bs 8 fromBigEndian64 {-# INLINE encodeInt64BE #-} encodeInt64BE :: Int64 -> ByteString @@ -128,16 +132,16 @@ encodePgBoolean v = if v then "\SOH" else "\NUL" -- | A super specialized decoder to decode a postgres DataRow message -- more quickly than a naive implementation. -- Returns first the parsed DataRow (only column sizes and values) and second --- the left-unparsed original bytestring. -decodeDataRow :: ByteString -> Either String (ByteString, ByteString) -decodeDataRow bs@(InternalBS.BS _bytesPtr len) = +-- the index into the left-unparsed contents of the supplied bytestring. +decodeDataRow :: ByteStringIdx -> ByteString -> Either String (ByteString, ByteStringIdx) +decodeDataRow idx bs@(InternalBS.BS _bytesPtr len) = -- We have a fast path when rows are at least 8 bytes long (should be the case -- for all but 0-column query results or bytestring chunks "cut in the middle of the message") -- by playing with bitwise operations. -- Whether this is worth keeping is sort of questionable. It's complex -- (even if I think it's safe and well tested) and reduces runtime of one of -- our benchmarks by 2% compared to not having it. - case unsafeDecodeWord bs 8 fromBigEndian64 of + case unsafeDecodeWord idx bs 8 fromBigEndian64 of Right (w64 :: Word64) -> -- After fromBigEndian64, the Word64 has bytes in big-endian order: -- byte 0 (msg type) in MSB, bytes 1-4 (length) next, bytes 5-6 (col count), byte 7 in LSB. @@ -153,13 +157,14 @@ decodeDataRow bs@(InternalBS.BS _bytesPtr len) = -- we still have to try to parse that. if len >= 5 then - let (InternalBS.w2c -> msgIdentChar, lenbs) = fromMaybe (error "impossible") $ BS.uncons bs - lenFullMsg = fromIntegral $ either error id (decodeInt32BE lenbs) + -- TODO: Don't allocate "lenbs" and decodeInt32BE with offset=1? + let (InternalBS.w2c -> msgIdentChar, lenbs) = fromMaybe (error "impossible") $ BS.uncons $ BS.drop idx.idx bs + lenFullMsg = fromIntegral $ either error id (decodeInt32BE 0 lenbs) in if msgIdentChar == 'D' then toResult lenFullMsg else Left "Not a DataRow" else Left "Less than enough bytes to decode a DataRow" where toResult lenFullMsg - | len >= 1 + lenFullMsg = let (a, rest) = BS.splitAt (1 + lenFullMsg) bs in Right (BS.drop 7 a, rest) + | len >= 1 + lenFullMsg + idx.idx = let a = BS.take (lenFullMsg - 6) (BS.drop (7 + idx.idx) bs) in Right (a, ByteStringIdx $ 1 + lenFullMsg + idx.idx) | otherwise = Left "Less than enough bytes to decode a full DataRow" diff --git a/hpgsql/src/Hpgsql/Internal.hs b/hpgsql/src/Hpgsql/Internal.hs index 71d6de0..9bd70f2 100644 --- a/hpgsql/src/Hpgsql/Internal.hs +++ b/hpgsql/src/Hpgsql/Internal.hs @@ -534,7 +534,7 @@ receiveNextMsgGeneric conn@HPgConnection {socket, recvBuffer} receiveWhat = do (initialBuf, initialBufLen) <- receiveUntilBufferHasAtLeast 5 let charAndLength = LBS.take 5 initialBuf let (w2c -> msgIdentChar, lenbs) = fromMaybe (error "impossible") $ LBS.uncons charAndLength - lenLeftToFetch :: Int64 = fromIntegral $ either error id (BinSer.decodeInt32BE $ LBS.toStrict lenbs) - 4 + lenLeftToFetch :: Int64 = fromIntegral $ either error id (BinSer.decodeInt32BE 0 $ LBS.toStrict lenbs) - 4 fullMessageLen = 5 + lenLeftToFetch (nowBuf, _nowBufLen) <- if initialBufLen >= fullMessageLen then pure (initialBuf, initialBufLen) else receiveUntilBufferHasAtLeast fullMessageLen let restOfMsg = LBS.drop 5 $ LBS.take fullMessageLen nowBuf diff --git a/hpgsql/src/Hpgsql/Msgs.hs b/hpgsql/src/Hpgsql/Msgs.hs index 9e1f6cf..50fe22c 100644 --- a/hpgsql/src/Hpgsql/Msgs.hs +++ b/hpgsql/src/Hpgsql/Msgs.hs @@ -54,7 +54,7 @@ colParser = do colName <- nulTerminatedCStringParser -- Column name as C string void $ Parsec.take (4 + 2) -- TODO: OIDs are unsigned integers! Try `select (-1)::oid` to see. Change to UInt32 somehow - typOid <- either fail pure . BinSer.decodeInt32BE =<< Parsec.take 4 + typOid <- either fail pure . BinSer.decodeInt32BE 0 =<< Parsec.take 4 void $ Parsec.take (2 + 4 + 2) pure (colName, Oid (fromIntegral typOid)) @@ -138,7 +138,7 @@ data Terminate = Terminate instance FromPgMessage AuthenticationResponse where msgParser = PgMsgParser $ \c restOfMsg -> case c of - 'R' -> case first (BinSer.decodeInt32BE . LBS.toStrict) $ LBS.splitAt 4 restOfMsg of + 'R' -> case first (BinSer.decodeInt32BE 0 . LBS.toStrict) $ LBS.splitAt 4 restOfMsg of (Right 0, _) -> Just $ AuthenticationResponse AuthOk (Right 2, _) -> Just $ AuthenticationResponse AuthKerberosV5 (Right 3, _) -> Just $ AuthenticationResponse AuthCleartextPassword @@ -155,7 +155,7 @@ instance FromPgMessage AuthenticationResponse where instance FromPgMessage BackendKeyData where msgParser = PgMsgParser $ \c (LBS.splitAt 4 -> (pidBS, backendSecretKey)) -> case c of - 'K' -> case BinSer.decodeInt32BE $ LBS.toStrict pidBS of + 'K' -> case BinSer.decodeInt32BE 0 $ LBS.toStrict pidBS of Right pid -> Just $ BackendKeyData {backendPid = pid, backendSecretKey = LBS.toStrict backendSecretKey} Left _ -> Nothing _ -> Nothing @@ -359,7 +359,7 @@ instance FromPgMessage RowDescription where if c == 'T' then let (numColsBS, colContents) = LBS.splitAt 2 restOfMsg - numCols = either error id $ BinSer.decodeInt16BE $ LBS.toStrict numColsBS + numCols = either error id $ BinSer.decodeInt16BE 0 $ LBS.toStrict numColsBS allColOidsParser :: Parsec.Parser [(Text, Oid)] allColOidsParser = replicateM (fromIntegral numCols) colParser in case LazyParsec.parseOnly (allColOidsParser <* Parsec.endOfInput) colContents of @@ -406,7 +406,7 @@ instance FromPgMessage NotificationResponse where then Nothing else let (notifierPidBs, channelNameAndPayload) = LBS.splitAt 4 restOfMsg - notifierPid = either error id $ BinSer.decodeInt32BE $ LBS.toStrict notifierPidBs + notifierPid = either error id $ BinSer.decodeInt32BE 0 $ LBS.toStrict notifierPidBs in case LazyParsec.parseOnly ((NotificationResponse notifierPid <$> nulTerminatedCStringParser <*> nulTerminatedCStringParser) <* Parsec.endOfInput) channelNameAndPayload of diff --git a/hpgsql/src/Hpgsql/SimpleParser.hs b/hpgsql/src/Hpgsql/SimpleParser.hs index 64a13bd..d4f4b1d 100644 --- a/hpgsql/src/Hpgsql/SimpleParser.hs +++ b/hpgsql/src/Hpgsql/SimpleParser.hs @@ -28,6 +28,7 @@ where import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Int (Int16, Int32, Int64) +import Hpgsql.Encoding.BinarySerializer (ByteStringIdx (..)) import qualified Hpgsql.Encoding.BinarySerializer as BinSer import Prelude hiding (take) @@ -40,128 +41,139 @@ data ParseResult a newtype Parser a = Parser { unParser :: forall r. + ByteStringIdx -> ByteString -> (String -> r) -> -- \^ failure continuation - (a -> ByteString -> r) -> - -- \^ success continuation, taking left-unparsed ByteString and parsed value + (a -> ByteStringIdx -> ByteString -> r) -> + -- \^ success continuation, taking original or new ByteString, the index into the original/new bytestring of the first yet-unparsed byte, and parsed value r } instance Functor Parser where - fmap f (Parser p) = Parser $ \bs kf ks -> - p bs kf (\a bs' -> ks (f a) bs') + fmap f (Parser p) = Parser $ \idx bs kf ks -> + p idx bs kf (\a bs' -> ks (f a) bs') {-# INLINE fmap #-} instance Applicative Parser where - pure a = Parser $ \bs _ ks -> ks a bs + pure a = Parser $ \idx bs _ ks -> ks a idx bs {-# INLINE pure #-} - Parser pf <*> Parser pa = Parser $ \bs kf ks -> - pf bs kf (\f bs' -> pa bs' kf (\a bs'' -> ks (f a) bs'')) + Parser pf <*> Parser pa = Parser $ \idx bs kf ks -> + pf idx bs kf (\f bs' idx' -> pa bs' idx' kf (\a bs'' idx'' -> ks (f a) bs'' idx'')) {-# INLINE (<*>) #-} instance Monad Parser where return = pure {-# INLINE return #-} - Parser p >>= k = Parser $ \bs kf ks -> - p bs kf (\a bs' -> unParser (k a) bs' kf ks) + Parser p >>= k = Parser $ \idx bs kf ks -> + p idx bs kf (\a bs' idx' -> unParser (k a) bs' idx' kf ks) {-# INLINE (>>=) #-} instance MonadFail Parser where - fail msg = Parser $ \_ kf _ -> kf msg + fail msg = Parser $ \_ _ kf _ -> kf msg {-# INLINE fail #-} -- | Run a parser and return either an error message or the parsed value, -- using the strict 'ParseResult' type. Any unconsumed trailing input is -- discarded. parseOnly :: Parser a -> ByteString -> ParseResult a -parseOnly (Parser p) bs = p bs ParseFail (\a _ -> ParseOk a) +parseOnly p = parseOnlyOffset p 0 {-# INLINE parseOnly #-} +-- | Run a parser and return either an error message or the parsed value, +-- using the strict 'ParseResult' type. Any unconsumed trailing input is +-- discarded. +parseOnlyOffset :: Parser a -> ByteStringIdx -> ByteString -> ParseResult a +parseOnlyOffset (Parser p) idx bs = p idx bs ParseFail (\a _ _ -> ParseOk a) +{-# INLINE parseOnlyOffset #-} + -- | Consume exactly @n@ bytes of input, failing if fewer than @n@ bytes -- remain. take :: Int -> Parser ByteString -take n = Parser $ \bs kf ks -> +take n = Parser $ \idx bs kf ks -> -- Special-casing n>0 helps reduce memory usage - -- by ~1.5% in our benchmarks without a measurable + -- by ~1.5% in our behmarks without a measurable -- difference in run time if n > 0 then - if BS.length bs >= n - then case BS.splitAt n bs of - (!h, !t) -> ks h t - else kf ("take: wanted " <> show n <> " bytes but only " <> show (BS.length bs) <> " remain") + let skip = n + idx.idx + in if BS.length bs >= skip + then case BS.take n $ BS.drop idx.idx bs of + !h -> ks h (ByteStringIdx skip) bs + else kf ("take: wanted " <> show skip <> " bytes but only " <> show (BS.length bs) <> " remain") else - ks mempty bs + ks mempty idx bs {-# INLINE take #-} {-# INLINE takeInt16BE #-} takeInt16BE :: Parser Int16 -takeInt16BE = Parser $ \bs kf ks -> - case BinSer.decodeInt16BE bs of +takeInt16BE = Parser $ \idx bs kf ks -> + case BinSer.decodeInt16BE idx bs of Left err -> kf err - Right v -> ks v (BS.drop 2 bs) + Right v -> ks v (idx + 2) bs {-# INLINE takeInt32BE #-} takeInt32BE :: Parser Int32 -takeInt32BE = Parser $ \bs kf ks -> - case BinSer.decodeInt32BE bs of +takeInt32BE = Parser $ \idx bs kf ks -> + case BinSer.decodeInt32BE idx bs of Left err -> kf err - Right v -> ks v (BS.drop 4 bs) + Right v -> ks v (idx + 4) bs {-# INLINE takeInt64BE #-} takeInt64BE :: Parser Int64 -takeInt64BE = Parser $ \bs kf ks -> - case BinSer.decodeInt64BE bs of +takeInt64BE = Parser $ \idx bs kf ks -> + case BinSer.decodeInt64BE idx bs of Left err -> kf err - Right v -> ks v (BS.drop 8 bs) + Right v -> ks v (idx + 8) bs {-# INLINE takeDataRow #-} -- | A specialized parser to parse a postgres DataRow. takeDataRow :: Parser ByteString -takeDataRow = Parser $ \bs kf ks -> - case BinSer.decodeDataRow bs of +takeDataRow = Parser $ \idx bs kf ks -> + case BinSer.decodeDataRow idx bs of Left err -> kf err - Right (thisDataRow, rest) -> ks thisDataRow rest + Right (thisDataRow, idxRest) -> ks thisDataRow idxRest bs parseMany :: Parser a -> Parser [a] -parseMany p = Parser $ \bs' _kf ks -> let (vs, rest) = go bs' in ks vs rest +parseMany p = Parser $ \bs' idx _kf ks -> let (vs, rest) = go bs' idx in ks vs 0 rest where - go bs = case parseOnly (matchLeftUnconsumed p) bs of - ParseOk (unconsumed, v) -> let (vs, rest) = go unconsumed in (v : vs, rest) + go idx bs = case parseOnlyOffset (matchLeftUnconsumed p) idx bs of + ParseOk (unconsumed, v) -> let (vs, rest) = go 0 unconsumed in (v : vs, rest) ParseFail _ -> ([], bs) {-# INLINE parseMany #-} -- | Succeeds only when the input has been fully consumed. endOfInput :: Parser () -endOfInput = Parser $ \bs kf ks -> - if BS.null bs then ks () bs else kf "endOfInput: input remaining" +endOfInput = Parser $ \idx bs kf ks -> + if BS.length bs <= idx.idx then ks () idx bs else kf "endOfInput: input remaining" {-# INLINE endOfInput #-} -- | Run a parser and additionally return the slice of input it consumed. -- Because the input is a strict 'ByteString', the returned slice is a view -- over the original buffer and allocates no extra memory. match :: Parser a -> Parser (ByteString, a) -match (Parser p) = Parser $ \bs kf ks -> +match (Parser p) = Parser $ \idx bs kf ks -> p + idx bs kf - ( \a bs' -> - let !consumed = BS.take (BS.length bs - BS.length bs') bs - in ks (consumed, a) bs' + ( \a idx' bs' -> + let !consumed = BS.take (idx'.idx - idx.idx) $ BS.drop idx.idx bs + in ks (consumed, a) idx' bs' ) {-# INLINE match #-} -- | Run a parser and additionally return the unconsumed/unparsed ByteString. matchLeftUnconsumed :: Parser a -> Parser (ByteString, a) -matchLeftUnconsumed (Parser p) = Parser $ \bs kf ks -> +matchLeftUnconsumed (Parser p) = Parser $ \idx bs kf ks -> p + idx bs kf - ( \a bs' -> - ks (bs', a) bs' + ( \a idx' bs' -> + ks (BS.drop idx'.idx bs', a) idx' bs' ) {-# INLINE matchLeftUnconsumed #-} From 75c6d2c9dda6e12e77afa05bcf242de9dc6d8cbd Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Tue, 11 Aug 2026 18:10:00 -0300 Subject: [PATCH 03/35] Multiple-rows-at-once decoding --- .../src/Hpgsql/Encoding/BinarySerializer.hs | 2 +- hpgsql/src/Hpgsql/Internal.hs | 79 ++++++++++--------- hpgsql/src/Hpgsql/Msgs.hs | 3 +- hpgsql/src/Hpgsql/SimpleParser.hs | 23 ++++-- 4 files changed, 61 insertions(+), 46 deletions(-) diff --git a/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs b/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs index da6983c..bc8845f 100644 --- a/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs +++ b/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs @@ -155,7 +155,7 @@ decodeDataRow idx bs@(InternalBS.BS _bytesPtr len) = Left _ -> -- It is possible the DataRow has length less than 8 bytes, so -- we still have to try to parse that. - if len >= 5 + if len >= 5 + idx.idx then -- TODO: Don't allocate "lenbs" and decodeInt32BE with offset=1? let (InternalBS.w2c -> msgIdentChar, lenbs) = fromMaybe (error "impossible") $ BS.uncons $ BS.drop idx.idx bs diff --git a/hpgsql/src/Hpgsql/Internal.hs b/hpgsql/src/Hpgsql/Internal.hs index 9bd70f2..9fa032c 100644 --- a/hpgsql/src/Hpgsql/Internal.hs +++ b/hpgsql/src/Hpgsql/Internal.hs @@ -115,6 +115,7 @@ import qualified Control.Concurrent.STM as STM import Control.Exception.Safe (Exception (..), MonadThrow, SomeException, bracket, bracketOnError, finally, handleJust, mask, mask_, onException, throw, toException, tryJust) import Control.Monad (forM, forM_, join, unless, void, when) import Data.ByteString (ByteString) +import qualified Data.ByteString as BS import Data.ByteString.Internal (w2c) import qualified Data.ByteString.Lazy as LBS import Data.Data (Proxy (..)) @@ -506,7 +507,7 @@ receiveNextMsgWithMaskedContinuation conn parser f = Left (msgIdentChar, mPgError) -> throw IrrecoverableHpgsqlError {hpgsqlDetails = "Could not parse postgres message with ident char " <> Text.pack (show msgIdentChar) <> ". This is an internal error in Hpgsql. Please report it.", innerException = toException <$> mPgError, relatedStatement = Nothing} data ReceiveWhat a b where - ReceiveDataRows :: ReceiveWhat DataRow [DataRow] + ReceiveDataRows :: ReceiveWhat DataRow ByteString ReceiveArbitraryMsg :: PgMsgParser a -> (Either (Char, Maybe PostgresError) a -> STM b) -> ReceiveWhat a b -- | Masks asynchronous exceptions in between the moment the message is extracted from @@ -583,11 +584,13 @@ receiveNextMsgGeneric conn@HPgConnection {socket, recvBuffer} receiveWhat = do case receiveWhat of ReceiveDataRows -> -- Parse as many DataRows as we can to do as much work as we can per buffer "churn" - case Parser.parseOnly (Parser.matchLeftUnconsumed (Parser.parseMany customDataRowParser)) (LBS.toStrict nowBuf) of - Parser.ParseOk (unconsumedBuffer, msgs@(_ : _)) -> do - debugPrint $ "Received " ++ show msgs - pure (LBS.fromStrict unconsumedBuffer, Just msgs) - _ -> handleUnexpectedMsg $ const $ pure [] -- No error when we stop receiving DataRows, only emptiness + let fullBuf = LBS.toStrict nowBuf + in case Parser.parseOnly Parser.parseManyRows fullBuf of + Parser.ParseOk unconsumedBufferBegin | unconsumedBufferBegin.idx > 0 -> do + let (msgs, unconsumedBuffer) = BS.splitAt unconsumedBufferBegin.idx fullBuf + debugPrint $ "Received one or more messages with total length " ++ show (BS.length msgs) + pure (LBS.fromStrict unconsumedBuffer, Just msgs) + _ -> handleUnexpectedMsg $ const $ pure "" -- No error when we stop receiving DataRows, only emptiness ReceiveArbitraryMsg parser f -> case parsePgMessage msgIdentChar restOfMsg parser of Just msg -> do @@ -595,8 +598,6 @@ receiveNextMsgGeneric conn@HPgConnection {socket, recvBuffer} receiveWhat = do fmap (bufferWithoutMsg,) $ Just <$> STM.atomically (f (Right msg)) Nothing -> handleUnexpectedMsg (f . Left) - customDataRowParser = DataRow <$> Parser.takeDataRow - -- \| Appends into the internal buffer by reading from the socket -- until the buffer has at least N bytes. -- Returns the current buffer and its length. @@ -843,6 +844,8 @@ receiveOutstandingResponseMsgsAtomically thisThreadId conn qryId = do } pure (Just respMsg, newState) +newtype DataRows = DataRows ByteString + -- | After sending one or more queries to the backend, run this function for each query to fetch that query's results. -- You must call the returned IO function and consume the returned Stream completely until you get to the -- `Either ErrorResponse CommandComplete` object. @@ -855,7 +858,7 @@ receiveOutstandingResponseMsgsAtomically thisThreadId conn qryId = do consumeResults :: HPgConnection -> QueryId -> - IO (Maybe (Either3 NoData RowDescription CopyInResponse), Stream (Of DataRow) IO (Either ErrorResponse CommandComplete)) + IO (Maybe (Either3 NoData RowDescription CopyInResponse), Stream (Of DataRows) IO (Either ErrorResponse CommandComplete)) consumeResults conn qryId = do -- debugPrint "++++ Inside consumeResults" -- We assume it's possible to receive a DataRow here even in the first call because `consumeResults` @@ -886,29 +889,28 @@ consumeResults conn qryId = do pure (mERowDesc, pure $ Right cmd) (mERowDesc, Middle3 mDataRow) -> do let allOtherRows = - S.concat $ - S.unfold - ( \() -> do - mRow <- receiveNextMsgGeneric conn ReceiveDataRows - case mRow of - rows@(_ : _) -> pure $ Right (rows :> ()) - [] -> do - stateAfterNextMsg <- snd <$> receiveOutstandingResponseMsgsAtomically thisThreadId conn qryId - case stateAfterNextMsg of - ErrorResponseReceived _ err -> do - receiveReadyForQueryIfNecessary thisThreadId - pure $ Left $ Left err - CommandCompleteReceived _ cmd -> do - receiveReadyForQueryIfNecessary thisThreadId - pure $ Left $ Right cmd - ReadyForQueryReceived errOrCmd _ -> pure $ Left errOrCmd - st -> throwIrrecoverableError $ "Internal error in Hpgsql. After the last DataRow we should get either an ErrorResponse or a CommandComplete message. State: " <> Text.pack (show st) - ) - () + S.unfold + ( \() -> do + mRow <- receiveNextMsgGeneric conn ReceiveDataRows + case mRow of + rows | not (BS.null rows) -> pure $ Right (DataRows rows :> ()) + _ -> do + stateAfterNextMsg <- snd <$> receiveOutstandingResponseMsgsAtomically thisThreadId conn qryId + case stateAfterNextMsg of + ErrorResponseReceived _ err -> do + receiveReadyForQueryIfNecessary thisThreadId + pure $ Left $ Left err + CommandCompleteReceived _ cmd -> do + receiveReadyForQueryIfNecessary thisThreadId + pure $ Left $ Right cmd + ReadyForQueryReceived errOrCmd _ -> pure $ Left errOrCmd + st -> throwIrrecoverableError $ "Internal error in Hpgsql. After the last DataRow we should get either an ErrorResponse or a CommandComplete message. State: " <> Text.pack (show st) + ) + () finalStream = case mDataRow of Nothing -> allOtherRows Just dr -> - dr `S.cons` allOtherRows + DataRows dr.rowColumnData `S.cons` allOtherRows pure (mERowDesc, finalStream) where receiveReadyForQueryIfNecessary :: WeakThreadId -> IO () @@ -1409,17 +1411,18 @@ consumeStreamingResults rp conn qryId = S.effect $ do let typecheckedColInfos = rtypecheck colInfos unless (numResultColumns == expectedNumCols) $ throwIrrecoverableErrorWithStatement qText $ "Query result contains " <> Text.pack (show numResultColumns) <> " columns but row parser expected " <> Text.pack (show expectedNumCols) unless (all snd typecheckedColInfos) $ throwIrrecoverableErrorWithStatement qText "Query result column types do not match expected column types" - pure $ rparser colInfos <* Parser.endOfInput - MonadicRowDecoder (RowDecoderMonadic rparser) -> pure $ fmap fst $ rparser ConversionState {colsLeftToParse = colInfos} <* Parser.endOfInput + pure $ Parser.take 7 *> rparser colInfos -- Skip msg ident., length, number of columns, then parse fields + MonadicRowDecoder (RowDecoderMonadic rparser) -> pure $ Parser.take 7 *> fmap fst (rparser ConversionState {colsLeftToParse = colInfos}) pure $ do errOrCmdComplete <- - S.mapM - ( \(DataRow rowColumnData) -> - case Parser.parseOnly rowparser rowColumnData of - Parser.ParseOk row -> pure row - Parser.ParseFail err -> throwIrrecoverableErrorWithStatement qText $ "Failed parsing a row: " <> Text.pack (show err) - ) - rowsStream + S.concat $ + S.mapM + ( \(DataRows rowColumnData) -> + case Parser.parseOnly (Parser.parseMany rowparser <* Parser.endOfInput) rowColumnData of + Parser.ParseOk rows -> pure rows + Parser.ParseFail err -> throwIrrecoverableErrorWithStatement qText $ "Failed parsing a row: " <> Text.pack (show err) + ) + rowsStream S.effect $ case errOrCmdComplete of Left err -> throwPostgresError qText err Right _cmdComplete -> pure mempty diff --git a/hpgsql/src/Hpgsql/Msgs.hs b/hpgsql/src/Hpgsql/Msgs.hs index 50fe22c..e19822e 100644 --- a/hpgsql/src/Hpgsql/Msgs.hs +++ b/hpgsql/src/Hpgsql/Msgs.hs @@ -225,7 +225,8 @@ instance FromPgMessage CopyInResponse where instance FromPgMessage DataRow where msgParser = PgMsgParser $ \c !restOfMsg -> case c of - 'D' -> Just $ DataRow {rowColumnData = LBS.toStrict $ LBS.drop 2 restOfMsg} + -- TODO: Double-check the re-encoding here is correct! + 'D' -> Just $ DataRow {rowColumnData = BS.singleton 68 <> BinSer.encodeInt32BE (fromIntegral $ LBS.length restOfMsg + 4) <> LBS.toStrict restOfMsg} _ -> Nothing instance FromPgMessage NoData where diff --git a/hpgsql/src/Hpgsql/SimpleParser.hs b/hpgsql/src/Hpgsql/SimpleParser.hs index d4f4b1d..f8ea42e 100644 --- a/hpgsql/src/Hpgsql/SimpleParser.hs +++ b/hpgsql/src/Hpgsql/SimpleParser.hs @@ -22,6 +22,7 @@ module Hpgsql.SimpleParser takeInt32BE, takeInt64BE, takeDataRow, + parseManyRows, ) where @@ -137,14 +138,23 @@ takeDataRow = Parser $ \idx bs kf ks -> Left err -> kf err Right (thisDataRow, idxRest) -> ks thisDataRow idxRest bs +-- TODO: Get rid of parseMany to save on List allocations for DataRows? parseMany :: Parser a -> Parser [a] -parseMany p = Parser $ \bs' idx _kf ks -> let (vs, rest) = go bs' idx in ks vs 0 rest +parseMany p = Parser $ \idx' bs' _kf ks -> let (vs, restIdx) = go idx' bs' in ks vs restIdx bs' where go idx bs = case parseOnlyOffset (matchLeftUnconsumed p) idx bs of - ParseOk (unconsumed, v) -> let (vs, rest) = go 0 unconsumed in (v : vs, rest) - ParseFail _ -> ([], bs) + ParseOk (unconsumedIdx, v) -> let (vs, rest) = go unconsumedIdx bs in (v : vs, rest) + ParseFail _ -> ([], idx) {-# INLINE parseMany #-} +parseManyRows :: Parser ByteStringIdx +parseManyRows = Parser $ \idx' bs' _kf ks -> let restIdx = go idx' bs' in ks restIdx restIdx bs' + where + go idx bs = case parseOnlyOffset (matchLeftUnconsumed takeDataRow) idx bs of + ParseOk (unconsumedIdx, _) -> go unconsumedIdx bs + ParseFail _ -> idx +{-# INLINE parseManyRows #-} + -- | Succeeds only when the input has been fully consumed. endOfInput :: Parser () endOfInput = Parser $ \idx bs kf ks -> @@ -166,14 +176,15 @@ match (Parser p) = Parser $ \idx bs kf ks -> ) {-# INLINE match #-} --- | Run a parser and additionally return the unconsumed/unparsed ByteString. -matchLeftUnconsumed :: Parser a -> Parser (ByteString, a) +-- | Run a parser and additionally return the index to the first unconsumed/unparsed byte +-- in the supplied ByteString. +matchLeftUnconsumed :: Parser a -> Parser (ByteStringIdx, a) matchLeftUnconsumed (Parser p) = Parser $ \idx bs kf ks -> p idx bs kf ( \a idx' bs' -> - ks (BS.drop idx'.idx bs', a) idx' bs' + ks (idx', a) idx' bs' ) {-# INLINE matchLeftUnconsumed #-} From eeef5df8f22e049013615d3d816c43809d60f714 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Tue, 11 Aug 2026 19:31:50 -0300 Subject: [PATCH 04/35] Get rid of all ByteStrings during parsing --- .../src/Hpgsql/Encoding/BinarySerializer.hs | 7 ++--- hpgsql/src/Hpgsql/Internal.hs | 4 +-- hpgsql/src/Hpgsql/SimpleParser.hs | 29 ++++++++++++------- 3 files changed, 24 insertions(+), 16 deletions(-) diff --git a/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs b/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs index bc8845f..9cf1eab 100644 --- a/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs +++ b/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs @@ -131,9 +131,8 @@ encodePgBoolean v = if v then "\SOH" else "\NUL" -- | A super specialized decoder to decode a postgres DataRow message -- more quickly than a naive implementation. --- Returns first the parsed DataRow (only column sizes and values) and second --- the index into the left-unparsed contents of the supplied bytestring. -decodeDataRow :: ByteStringIdx -> ByteString -> Either String (ByteString, ByteStringIdx) +-- Returns the index into the left-unparsed contents of the supplied bytestring. +decodeDataRow :: ByteStringIdx -> ByteString -> Either String ByteStringIdx decodeDataRow idx bs@(InternalBS.BS _bytesPtr len) = -- We have a fast path when rows are at least 8 bytes long (should be the case -- for all but 0-column query results or bytestring chunks "cut in the middle of the message") @@ -166,5 +165,5 @@ decodeDataRow idx bs@(InternalBS.BS _bytesPtr len) = else Left "Less than enough bytes to decode a DataRow" where toResult lenFullMsg - | len >= 1 + lenFullMsg + idx.idx = let a = BS.take (lenFullMsg - 6) (BS.drop (7 + idx.idx) bs) in Right (a, ByteStringIdx $ 1 + lenFullMsg + idx.idx) + | len >= 1 + lenFullMsg + idx.idx = Right $ ByteStringIdx $ 1 + lenFullMsg + idx.idx | otherwise = Left "Less than enough bytes to decode a full DataRow" diff --git a/hpgsql/src/Hpgsql/Internal.hs b/hpgsql/src/Hpgsql/Internal.hs index 9fa032c..a9d3dd6 100644 --- a/hpgsql/src/Hpgsql/Internal.hs +++ b/hpgsql/src/Hpgsql/Internal.hs @@ -1411,8 +1411,8 @@ consumeStreamingResults rp conn qryId = S.effect $ do let typecheckedColInfos = rtypecheck colInfos unless (numResultColumns == expectedNumCols) $ throwIrrecoverableErrorWithStatement qText $ "Query result contains " <> Text.pack (show numResultColumns) <> " columns but row parser expected " <> Text.pack (show expectedNumCols) unless (all snd typecheckedColInfos) $ throwIrrecoverableErrorWithStatement qText "Query result column types do not match expected column types" - pure $ Parser.take 7 *> rparser colInfos -- Skip msg ident., length, number of columns, then parse fields - MonadicRowDecoder (RowDecoderMonadic rparser) -> pure $ Parser.take 7 *> fmap fst (rparser ConversionState {colsLeftToParse = colInfos}) + pure $ Parser.skip 7 *> rparser colInfos -- Skip msg ident., length, number of columns, then parse fields + MonadicRowDecoder (RowDecoderMonadic rparser) -> pure $ Parser.skip 7 *> fmap fst (rparser ConversionState {colsLeftToParse = colInfos}) pure $ do errOrCmdComplete <- S.concat $ diff --git a/hpgsql/src/Hpgsql/SimpleParser.hs b/hpgsql/src/Hpgsql/SimpleParser.hs index f8ea42e..b60c175 100644 --- a/hpgsql/src/Hpgsql/SimpleParser.hs +++ b/hpgsql/src/Hpgsql/SimpleParser.hs @@ -23,6 +23,7 @@ module Hpgsql.SimpleParser takeInt64BE, takeDataRow, parseManyRows, + skip, ) where @@ -97,17 +98,25 @@ take n = Parser $ \idx bs kf ks -> -- Special-casing n>0 helps reduce memory usage -- by ~1.5% in our behmarks without a measurable -- difference in run time + -- TODO check if the comment above still holds if n > 0 then - let skip = n + idx.idx - in if BS.length bs >= skip + let skip' = n + idx.idx + in if BS.length bs >= skip' then case BS.take n $ BS.drop idx.idx bs of - !h -> ks h (ByteStringIdx skip) bs - else kf ("take: wanted " <> show skip <> " bytes but only " <> show (BS.length bs) <> " remain") + !h -> ks h (ByteStringIdx skip') bs + else kf ("take: wanted " <> show skip' <> " bytes but only " <> show (BS.length bs) <> " remain") else ks mempty idx bs {-# INLINE take #-} +-- | Consume exactly @n@ bytes of input, failing if fewer than @n@ bytes +-- remain. +skip :: Int -> Parser () +skip n = Parser $ \idx bs _ ks -> + ks () (ByteStringIdx $ idx.idx + n) bs +{-# INLINE skip #-} + {-# INLINE takeInt16BE #-} takeInt16BE :: Parser Int16 takeInt16BE = Parser $ \idx bs kf ks -> @@ -131,14 +140,14 @@ takeInt64BE = Parser $ \idx bs kf ks -> {-# INLINE takeDataRow #-} --- | A specialized parser to parse a postgres DataRow. -takeDataRow :: Parser ByteString +-- | A specialized parser to parse a postgres DataRow, +-- returning the index of the byte after this DataRow's last. +takeDataRow :: Parser ByteStringIdx takeDataRow = Parser $ \idx bs kf ks -> case BinSer.decodeDataRow idx bs of Left err -> kf err - Right (thisDataRow, idxRest) -> ks thisDataRow idxRest bs + Right idxRest -> ks idxRest idxRest bs --- TODO: Get rid of parseMany to save on List allocations for DataRows? parseMany :: Parser a -> Parser [a] parseMany p = Parser $ \idx' bs' _kf ks -> let (vs, restIdx) = go idx' bs' in ks vs restIdx bs' where @@ -150,8 +159,8 @@ parseMany p = Parser $ \idx' bs' _kf ks -> let (vs, restIdx) = go idx' bs' in ks parseManyRows :: Parser ByteStringIdx parseManyRows = Parser $ \idx' bs' _kf ks -> let restIdx = go idx' bs' in ks restIdx restIdx bs' where - go idx bs = case parseOnlyOffset (matchLeftUnconsumed takeDataRow) idx bs of - ParseOk (unconsumedIdx, _) -> go unconsumedIdx bs + go idx bs = case parseOnlyOffset takeDataRow idx bs of + ParseOk unconsumedIdx -> go unconsumedIdx bs ParseFail _ -> idx {-# INLINE parseManyRows #-} From 6ead1471635d064bc0be060de053d800b77bae11 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Tue, 11 Aug 2026 20:54:30 -0300 Subject: [PATCH 05/35] Special n>0 optimization makes no sense anymore It's only used to fetch field values, and values with length exactly 0 are extremely rare --- hpgsql/src/Hpgsql/SimpleParser.hs | 18 +++++------------- 1 file changed, 5 insertions(+), 13 deletions(-) diff --git a/hpgsql/src/Hpgsql/SimpleParser.hs b/hpgsql/src/Hpgsql/SimpleParser.hs index b60c175..57849c7 100644 --- a/hpgsql/src/Hpgsql/SimpleParser.hs +++ b/hpgsql/src/Hpgsql/SimpleParser.hs @@ -95,19 +95,11 @@ parseOnlyOffset (Parser p) idx bs = p idx bs ParseFail (\a _ _ -> ParseOk a) -- remain. take :: Int -> Parser ByteString take n = Parser $ \idx bs kf ks -> - -- Special-casing n>0 helps reduce memory usage - -- by ~1.5% in our behmarks without a measurable - -- difference in run time - -- TODO check if the comment above still holds - if n > 0 - then - let skip' = n + idx.idx - in if BS.length bs >= skip' - then case BS.take n $ BS.drop idx.idx bs of - !h -> ks h (ByteStringIdx skip') bs - else kf ("take: wanted " <> show skip' <> " bytes but only " <> show (BS.length bs) <> " remain") - else - ks mempty idx bs + let skip' = n + idx.idx + in if BS.length bs >= skip' + then case BS.take n $ BS.drop idx.idx bs of + !h -> ks h (ByteStringIdx skip') bs + else kf ("take: wanted " <> show skip' <> " bytes but only " <> show (BS.length bs) <> " remain") {-# INLINE take #-} -- | Consume exactly @n@ bytes of input, failing if fewer than @n@ bytes From 862c1f077880bb8faba9e60cfddaf5cb2aaf93d6 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Tue, 11 Aug 2026 21:00:26 -0300 Subject: [PATCH 06/35] Add comment on strictness --- hpgsql/src/Hpgsql/SimpleParser.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/hpgsql/src/Hpgsql/SimpleParser.hs b/hpgsql/src/Hpgsql/SimpleParser.hs index 57849c7..abac6d4 100644 --- a/hpgsql/src/Hpgsql/SimpleParser.hs +++ b/hpgsql/src/Hpgsql/SimpleParser.hs @@ -98,6 +98,9 @@ take n = Parser $ \idx bs kf ks -> let skip' = n + idx.idx in if BS.length bs >= skip' then case BS.take n $ BS.drop idx.idx bs of + -- Strict on the bytestring because we're pretty sure + -- the field decoder will need to evaluate this anyway, + -- so no need for an extra thunk !h -> ks h (ByteStringIdx skip') bs else kf ("take: wanted " <> show skip' <> " bytes but only " <> show (BS.length bs) <> " remain") {-# INLINE take #-} From d39eaa9b3df4cb533aaa07aaa2c6a3a3029bcd8d Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Tue, 11 Aug 2026 21:06:27 -0300 Subject: [PATCH 07/35] Slightly better (but not any faster) specialized row decoder --- .../src/Hpgsql/Encoding/BinarySerializer.hs | 21 ++++++++++--------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs b/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs index 9cf1eab..35b50fe 100644 --- a/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs +++ b/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs @@ -32,12 +32,10 @@ import Prelude hiding (encodeFloat) #if WORDS_BIGENDIAN import Data.Word (Word16, Word32, Word64) #else -import Data.Word (Word16, Word32, Word64, byteSwap16, byteSwap32, byteSwap64) +import Data.Word (Word16, Word32, Word64, byteSwap16, byteSwap32, byteSwap64, Word8) #endif import Data.Bits (Bits (unsafeShiftR)) -import qualified Data.ByteString as BS import Data.Coerce (coerce) -import Data.Maybe (fromMaybe) import Foreign (Storable (..), (.&.)) import Foreign.ForeignPtr (withForeignPtr) import GHC.Float (castDoubleToWord64, castFloatToWord32) @@ -91,6 +89,10 @@ decodeInt16BE idx bs = fromIntegral <$> unsafeDecodeWord idx bs 2 fromBigEndian1 encodeInt16BE :: Int16 -> ByteString encodeInt16BE n = unsafeEncodeWord (fromIntegral n) fromBigEndian16 2 +{-# INLINE decodeWord8 #-} +decodeWord8 :: ByteStringIdx -> ByteString -> Either String Word8 +decodeWord8 idx bs = unsafeDecodeWord idx bs 1 Prelude.id + {-# INLINE decodeWord32BE #-} decodeWord32BE :: ByteString -> Either String Word32 decodeWord32BE bs = unsafeDecodeWord 0 bs 4 fromBigEndian32 @@ -155,13 +157,12 @@ decodeDataRow idx bs@(InternalBS.BS _bytesPtr len) = -- It is possible the DataRow has length less than 8 bytes, so -- we still have to try to parse that. if len >= 5 + idx.idx - then - -- TODO: Don't allocate "lenbs" and decodeInt32BE with offset=1? - let (InternalBS.w2c -> msgIdentChar, lenbs) = fromMaybe (error "impossible") $ BS.uncons $ BS.drop idx.idx bs - lenFullMsg = fromIntegral $ either error id (decodeInt32BE 0 lenbs) - in if msgIdentChar == 'D' - then toResult lenFullMsg - else Left "Not a DataRow" + then do + msgIdentChar <- decodeWord8 idx bs + lenFullMsg <- decodeInt32BE (1 + idx) bs + if msgIdentChar == 68 -- Letter 'D' + then toResult (fromIntegral lenFullMsg) + else Left "Not a DataRow" else Left "Less than enough bytes to decode a DataRow" where toResult lenFullMsg From e9d01e1980fcffcd3b02266127e662250f35e7c9 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Tue, 11 Aug 2026 22:13:51 -0300 Subject: [PATCH 08/35] Add a test for the FromPgMessage DataRow decoder --- hpgsql-tests/EncodingDecodingSpec.hs | 53 +++++++++++++++++++++++++++- hpgsql/src/Hpgsql/Internal.hs | 2 +- hpgsql/src/Hpgsql/InternalTypes.hs | 4 ++- hpgsql/src/Hpgsql/Msgs.hs | 2 +- 4 files changed, 57 insertions(+), 4 deletions(-) diff --git a/hpgsql-tests/EncodingDecodingSpec.hs b/hpgsql-tests/EncodingDecodingSpec.hs index 37e63cd..03462c6 100644 --- a/hpgsql-tests/EncodingDecodingSpec.hs +++ b/hpgsql-tests/EncodingDecodingSpec.hs @@ -1,10 +1,11 @@ module EncodingDecodingSpec where -import Control.Monad (join, void) +import Control.Monad (join, replicateM, void) import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as Aeson import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Lazy as LBS import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI @@ -42,6 +43,7 @@ import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Gen import Hpgsql import Hpgsql.Connection (ConnectOpts (..), connect, connectOpts, defaultConnectOpts, refreshTypeInfoCache, withConnectionOpts) +import Hpgsql.InternalTypes (DataRow (..)) import Hpgsql.Encoding (EncodingContext (..), FieldDecoder (..), FieldEncoder (..), FieldInfo (..), FromPgField (..), FromPgRow (..), LowerCasedPgEnum (..), RowEncoder (..), ToPgField (..), ToPgRow (..), compositeTypeDecoder, compositeTypeEncoder, nullableField, rawBytesFieldDecoder, singleField, typeFieldDecoder, typeFieldEncoder, typeMustBeNamed, typeOidWithName) import Hpgsql.Pipeline (pipeline, pipelineWith, runPipeline) import Hpgsql.Query (mkQuery, sql, vALUES) @@ -160,6 +162,9 @@ spec = parallel $ do it "0-columns results can be decoded" zeroColumnsResults + it + "Specialized DataRow decoding consistency" + specializedDataRowDecodingConsistency zeroColumnsResults :: IO () zeroColumnsResults = do @@ -872,3 +877,49 @@ valuesTypeRoundTrip conn = hedgehog $ do data Person = Person {name :: Text, born :: Day, heightMeters :: Double} deriving stock (Generic) deriving anyclass (FromPgRow) + +specializedDataRowDecodingConsistency :: PropertyT IO () +specializedDataRowDecodingConsistency = hedgehog $ do + dataRows <- Gen.forAll $ Gen.list (Gen.linear 0 20) genDataRowBS + mapM_ (\drBS -> do + let restOfMsg = LBS.fromStrict (BS.drop 5 drBS) + parsed = parseDataRowFromPgMsg 'D' restOfMsg + fmap fullDataRow parsed === Just drBS + ) dataRows + +-- | Copy of the FromPgMessage DataRow instance's parsing logic from Hpgsql.Msgs. +-- Keep in sync with that module's @instance FromPgMessage DataRow@. +parseDataRowFromPgMsg :: Char -> LBS.ByteString -> Maybe DataRow +parseDataRowFromPgMsg c !restOfMsg = case c of + 'D' -> Just $ DataRow $ BS.singleton 68 <> testEncodeInt32BE (fromIntegral $ LBS.length restOfMsg + 4) <> LBS.toStrict restOfMsg + _ -> Nothing + +genDataRowBS :: Gen.Gen ByteString +genDataRowBS = do + numFields <- Gen.int (Gen.linear 0 10) + -- Each NULL field adds 4 bytes overhead (length = -1). Each non-NULL field adds 4 + n bytes. + -- A 0-field DataRow is 7 bytes: 1 ('D') + 4 (msg length) + 2 (field count). + -- We target a max total of 100 bytes, so 93 bytes are available for fields. + let maxPerField = if numFields == 0 then 0 else max 0 ((93 - 4 * numFields) `div` numFields) + fields <- replicateM numFields (genField maxPerField) + pure $ buildDataRow fields + where + genField maxBytes = Gen.choice + [ pure Nothing + , Just <$> Gen.bytes (Gen.linear 0 maxBytes) + ] + buildDataRow :: [Maybe ByteString] -> ByteString + buildDataRow fields = + let nFields = length fields + fieldsBS = BS.concat $ map encodeField fields + payload = testEncodeInt16BE (fromIntegral nFields) <> fieldsBS + lenVal = fromIntegral (BS.length payload + 4) :: Int32 + in BS.singleton 68 <> testEncodeInt32BE lenVal <> payload + encodeField Nothing = testEncodeInt32BE (-1) + encodeField (Just bs) = testEncodeInt32BE (fromIntegral (BS.length bs)) <> bs + +testEncodeInt32BE :: Int32 -> ByteString +testEncodeInt32BE = LBS.toStrict . Builder.toLazyByteString . Builder.int32BE + +testEncodeInt16BE :: Int16 -> ByteString +testEncodeInt16BE = LBS.toStrict . Builder.toLazyByteString . Builder.int16BE diff --git a/hpgsql/src/Hpgsql/Internal.hs b/hpgsql/src/Hpgsql/Internal.hs index a9d3dd6..8c427fe 100644 --- a/hpgsql/src/Hpgsql/Internal.hs +++ b/hpgsql/src/Hpgsql/Internal.hs @@ -910,7 +910,7 @@ consumeResults conn qryId = do finalStream = case mDataRow of Nothing -> allOtherRows Just dr -> - DataRows dr.rowColumnData `S.cons` allOtherRows + DataRows dr.fullDataRow `S.cons` allOtherRows pure (mERowDesc, finalStream) where receiveReadyForQueryIfNecessary :: WeakThreadId -> IO () diff --git a/hpgsql/src/Hpgsql/InternalTypes.hs b/hpgsql/src/Hpgsql/InternalTypes.hs index 7b9534e..af81141 100644 --- a/hpgsql/src/Hpgsql/InternalTypes.hs +++ b/hpgsql/src/Hpgsql/InternalTypes.hs @@ -368,7 +368,9 @@ newtype ErrorResponse = ErrorResponse (Map ErrorDetail LBS.ByteString) newtype CommandComplete = CommandComplete {numRows :: Int64} deriving stock (Show) -newtype DataRow = DataRow {rowColumnData :: ByteString} +-- | A DataRow with its leading identifying character ('D'), the 32bits self-length, +-- the 2 bytes for the number of fields and the fields' lengths and values themselves. +newtype DataRow = DataRow {fullDataRow :: ByteString} instance Show DataRow where show _ = "DataRow" diff --git a/hpgsql/src/Hpgsql/Msgs.hs b/hpgsql/src/Hpgsql/Msgs.hs index e19822e..3171079 100644 --- a/hpgsql/src/Hpgsql/Msgs.hs +++ b/hpgsql/src/Hpgsql/Msgs.hs @@ -226,7 +226,7 @@ instance FromPgMessage CopyInResponse where instance FromPgMessage DataRow where msgParser = PgMsgParser $ \c !restOfMsg -> case c of -- TODO: Double-check the re-encoding here is correct! - 'D' -> Just $ DataRow {rowColumnData = BS.singleton 68 <> BinSer.encodeInt32BE (fromIntegral $ LBS.length restOfMsg + 4) <> LBS.toStrict restOfMsg} + 'D' -> Just $ DataRow {fullDataRow = BS.singleton 68 <> BinSer.encodeInt32BE (fromIntegral $ LBS.length restOfMsg + 4) <> LBS.toStrict restOfMsg} _ -> Nothing instance FromPgMessage NoData where From 682125ced42716dbed5b1650974bc3f68f958367 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 8 Aug 2026 18:39:01 -0300 Subject: [PATCH 09/35] Try a new kind of very specialized parser for small types --- hpgsql-tests/EncodingDecodingSpec.hs | 60 ++++++++- hpgsql/src/Hpgsql/Encoding.hs | 123 ++++++++++++++---- .../src/Hpgsql/Encoding/BinarySerializer.hs | 55 ++++++++ hpgsql/src/Hpgsql/SimpleParser.hs | 46 +++++++ 4 files changed, 258 insertions(+), 26 deletions(-) diff --git a/hpgsql-tests/EncodingDecodingSpec.hs b/hpgsql-tests/EncodingDecodingSpec.hs index 03462c6..f03bf77 100644 --- a/hpgsql-tests/EncodingDecodingSpec.hs +++ b/hpgsql-tests/EncodingDecodingSpec.hs @@ -11,7 +11,7 @@ import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Data.Functor ((<&>)) import Data.Functor.Contravariant (contramap) -import Data.Int (Int16, Int32, Int64) +import Data.Int (Int16, Int32, Int64, Int8) import qualified Data.List as List import qualified Data.Map.Strict as Map import Data.Maybe (isNothing) @@ -35,6 +35,7 @@ import DbUtils testConnInfo, withRollback, ) +import Debug.Trace import GHC.Float (float2Double) import GHC.Generics (Generic) import Hedgehog (PropertyT, annotateShow, (===)) @@ -45,7 +46,7 @@ import Hpgsql import Hpgsql.Connection (ConnectOpts (..), connect, connectOpts, defaultConnectOpts, refreshTypeInfoCache, withConnectionOpts) import Hpgsql.InternalTypes (DataRow (..)) import Hpgsql.Encoding (EncodingContext (..), FieldDecoder (..), FieldEncoder (..), FieldInfo (..), FromPgField (..), FromPgRow (..), LowerCasedPgEnum (..), RowEncoder (..), ToPgField (..), ToPgRow (..), compositeTypeDecoder, compositeTypeEncoder, nullableField, rawBytesFieldDecoder, singleField, typeFieldDecoder, typeFieldEncoder, typeMustBeNamed, typeOidWithName) -import Hpgsql.Pipeline (pipeline, pipelineWith, runPipeline) +import Hpgsql.Pipeline (pipeline, pipeline1With, pipelineWith, runPipeline) import Hpgsql.Query (mkQuery, sql, vALUES) import Hpgsql.Time (Unbounded (..)) import Hpgsql.TypeInfo (Oid, TypeInfo (..), lookupTypeByOid) @@ -142,6 +143,9 @@ spec = parallel $ do it "Values type round-trip" valuesTypeRoundTrip + it + "Especially optimized less-than-4-bytes long value decoders work" + smallerThan4BytesValuesAndNullsRoundtrip aroundConn $ describe "Custom types" $ do it "Composite type" queryCompositeType it @@ -178,9 +182,59 @@ zeroColumnsResults = do valuesRoundTrip :: HPgConnection -> IO () valuesRoundTrip conn = do - let row = ((-49) :: Int, False :: Bool, 2 :: Int16, 3 :: Int32, fromGregorian 1900 02 28, 42 :: Int64, UTCTime (fromGregorian 1999 12 31) 0, '意' :: Char, '&' :: Char, CalendarDiffTime 3 86403, Aeson.Null) + let row = ((-49) :: Int, False :: Bool, 2 :: Int16, 3 :: Int32, fromGregorian 1900 02 28, 42 :: Int64, UTCTime (fromGregorian 1999 12 31) 0, '意' :: Char, '&' :: Char, CalendarDiffTime 3 86403, Nothing :: Maybe Bool) queryWith rowDecoder conn (mkQuery "SELECT $1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11" row) `shouldReturn` [row] +smallerThan4BytesValuesAndNullsRoundtrip :: HPgConnection -> PropertyT IO () +smallerThan4BytesValuesAndNullsRoundtrip conn = hedgehog $ do + yearForDate :: Integer <- Gen.forAll $ Gen.integral (Gen.linear 1 9999) + month :: Int <- Gen.forAll $ Gen.int $ Gen.linear 1 12 + day :: Int <- Gen.forAll $ Gen.int $ Gen.linear 1 28 + date <- Gen.forAll $ Gen.element [Just $ fromGregorian yearForDate month day, Nothing] + let i16Boundary :: [Int16] + i16Boundary = + [minBound .. minBound + 10] + ++ [maxBound - 10 .. maxBound] + ++ [2 ^ (14 :: Int) - 10 .. 2 ^ (14 :: Int) + 10] + ++ [-(2 ^ (14 :: Int)) - 10 .. -(2 ^ (14 :: Int)) + 10] + i32Boundary :: [Int32] + i32Boundary = + [minBound .. minBound + 10] + ++ [maxBound - 10 .. maxBound] + ++ [2 ^ (30 :: Int) - 10 .. 2 ^ (30 :: Int) + 10] + ++ [-(2 ^ (30 :: Int)) - 10 .. -(2 ^ (30 :: Int)) + 10] + i16 :: Maybe Int16 <- Gen.forAll $ Gen.choice [Just <$> Gen.element i16Boundary, Just <$> Gen.integral (Gen.linear (-10) 10), pure Nothing] + i32 :: Maybe Int32 <- Gen.forAll $ Gen.choice [Just <$> Gen.element i32Boundary, Just <$> Gen.integral (Gen.linear (-10) 10), pure Nothing] + b :: Maybe Bool <- Gen.forAll $ Gen.choice [Just <$> Gen.bool, pure Nothing] + -- TODO: float4, char + -- TODO: Varying recvChunkSize sizes for this test + -- TODO: More variations of rows + -- TODO: Test `singleField fieldDecoder` as well: we now have two implementations to test for each + -- of these types. + -- TODO: test errors when trying to decode NULL::type into a non-Maybe in Haskell + let r1 = (date, i16, i32, b) + r2 = (i16, date, i32, b) + r3 = (i32, date, i16, b) + r4 = (b, date, i16, i32) + r5 = (b, i32, i16, date) + r6 = (b, date, i32, i16) + (resR1, resR2, resR3, resR4, resR5, resR6) <- + liftIO $ + runPipeline conn $ + (,,,,,) + <$> pipeline1With rowDecoder [sql|SELECT * FROM (^{vALUES [r1]}) subq|] + <*> pipeline1With rowDecoder [sql|SELECT * FROM (^{vALUES [r2]}) subq|] + <*> pipeline1With rowDecoder [sql|SELECT * FROM (^{vALUES [r3]}) subq|] + <*> pipeline1With rowDecoder [sql|SELECT * FROM (^{vALUES [r4]}) subq|] + <*> pipeline1With rowDecoder [sql|SELECT * FROM (^{vALUES [r5]}) subq|] + <*> pipeline1With rowDecoder [sql|SELECT * FROM (^{vALUES [r6]}) subq|] + liftIO resR1 >>= (=== r1) + liftIO resR2 >>= (=== r2) + liftIO resR3 >>= (=== r3) + liftIO resR4 >>= (=== r4) + liftIO resR5 >>= (=== r5) + liftIO resR6 >>= (=== r6) + byteaValuesRoundTrip :: HPgConnection -> PropertyT IO () byteaValuesRoundTrip conn = hedgehog $ do let genBs = Gen.bytes (Gen.linear 0 50) diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index dd5378f..02d1d6a 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -181,8 +181,17 @@ singleField (FieldDecoder {..}) = } class FromPgField a where + -- | A decoder that takes fieldDecoder :: FieldDecoder a + -- | This should be semantically equivalent to `singleField fieldDecoder`, and + -- it is automatically derived to be exactly that. + -- So as a user, you don't need to override this. + -- This field exists for a performance optimization within hpgsql, or for users + -- that really know what they're doing. + singleFieldRowDecoder :: RowDecoder a + singleFieldRowDecoder = singleField fieldDecoder + class FromPgRow a where rowDecoder :: RowDecoder a default rowDecoder :: (Generic a, ProductTypeDecoder (Rep a)) => RowDecoder a @@ -254,43 +263,43 @@ compositeTypeEncoder rowEnc = } instance (FromPgField a) => FromPgRow (Only a) where - rowDecoder = Only <$> singleField fieldDecoder + rowDecoder = Only <$> singleFieldRowDecoder instance (FromPgField a, FromPgField b) => FromPgRow (a, b) where - rowDecoder = (,) <$> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c) => FromPgRow (a, b, c) where - rowDecoder = (,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d) => FromPgRow (a, b, c, d) where - rowDecoder = (,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e) => FromPgRow (a, b, c, d, e) where - rowDecoder = (,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f) => FromPgRow (a, b, c, d, e, f) where - rowDecoder = (,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g) => FromPgRow (a, b, c, d, e, f, g) where - rowDecoder = (,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h) => FromPgRow (a, b, c, d, e, f, g, h) where - rowDecoder = (,,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i) => FromPgRow (a, b, c, d, e, f, g, h, i) where - rowDecoder = (,,,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j) => FromPgRow (a, b, c, d, e, f, g, h, i, j) where - rowDecoder = (,,,,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k) where - rowDecoder = (,,,,,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,,,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k, FromPgField l) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k, l) where - rowDecoder = (,,,,,,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,,,,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k, FromPgField l, FromPgField m) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k, l, m) where - rowDecoder = (,,,,,,,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,,,,,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder data FieldEncoder a = FieldEncoder { toTypeOid :: !(EncodingContext -> Maybe Oid), @@ -741,6 +750,19 @@ binaryIntDecoder typOid = \bs -> | otherwise = error "Bug in Hpgsql. Decoding binary integral type not an int2, int4 or int8" doesFit = maxBoundPgType <= fromIntegral (maxBound @a) +-- | Specialized/performance-oriented Big-Endian binary decoder for Haskell's various IntXX types. +binaryIntSpecializedRowDecoder :: Parser.Parser (Maybe Int) +binaryIntSpecializedRowDecoder = do + fieldLen <- Parser.takeInt32BE + -- TODO: We're assuming `Int` is always 64 bits, so 64bit CPUs? Is that ok? + -- TODO: Is there a way to optimistically assume <=4 bytes and use our custom new parser? + case fieldLen of + 4 -> Just . fromIntegral <$> Parser.takeInt32BE + (-1) -> pure Nothing + 8 -> Just . fromIntegral <$> Parser.takeInt64BE + 2 -> Just . fromIntegral <$> Parser.takeInt16BE + _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" + binaryFloat4Decoder :: ByteString -> Float binaryFloat4Decoder = castWord32ToFloat . either error id . BinSer.decodeWord32BE @@ -774,6 +796,37 @@ instance FromPgField Int where Nothing -> Left "Cannot decode SQL null as the Haskell Int type. Use a `Maybe Int`", allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid } + singleFieldRowDecoder = + let fromNullable = \case + Nothing -> fail "Cannot decode SQL null as the Haskell Int type. Use a `Maybe Int`" + Just i -> pure i + in RowDecoder + { fullRowDecoder = const $ binaryIntSpecializedRowDecoder >>= fromNullable, + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid `elem` haskellIntOids)] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } + +-- instance {-# OVERLAPPING #-} FromPgField (Maybe Int) where +-- fieldDecoder = error "NOOO" + +-- -- FieldDecoder +-- -- { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> +-- -- let !decode = binaryIntDecoder oid +-- -- in \case +-- -- Just bs -> Just <$> decode bs +-- -- Nothing -> Right Nothing, +-- -- allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid +-- -- } +-- singleFieldRowDecoder = +-- RowDecoder +-- { fullRowDecoder = const binaryIntSpecializedRowDecoder, +-- rowColumnsTypeCheck = \case +-- [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid `elem` haskellIntOids)] +-- _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", +-- numExpectedColumns = 1 +-- } instance FromPgField Int16 where fieldDecoder = @@ -922,6 +975,18 @@ instance FromPgField Bool where fieldDecoder = parsePgType [boolOid] $ \case Just bs -> Right $ bs == binaryTrue Nothing -> Left "Cannot decode SQL null as the Haskell Bool type. Use a `Maybe Bool`" + singleFieldRowDecoder = + let dec = Parser.parsePgFieldWithAtMost4Bytes BinSer.TypeSize1 + word8ToBool = \case + Nothing -> fail "Cannot decode SQL null as the Haskell Bool type. Use a `Maybe Bool`" + Just w8 -> pure $ w8 == 1 + in RowDecoder + { fullRowDecoder = const $ dec >>= word8ToBool, + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid == boolOid)] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } instance FromPgField Char where fieldDecoder = @@ -1066,6 +1131,18 @@ instance FromPgField Day where jd <- BinSer.decodeInt32BE 0 bs Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 Nothing -> Left "Cannot decode SQL null as the Haskell Day type. Use a `Maybe Day`" + singleFieldRowDecoder = + let dec = Parser.takeInt32BEWithFieldLength + int32ToDay = \case + Nothing -> fail "Cannot decode SQL null as the Haskell Day type. Use a `Maybe Day`" + Just i32 -> let jd = fromIntegral i32 :: Integer in pure $ addJulianDurationClip (CalendarDiffDays 0 (jd - 13)) $ fromJulian 2000 01 01 + in RowDecoder + { fullRowDecoder = const $ dec >>= int32ToDay, + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid == dateOid)] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } instance FromPgField (Unbounded Day) where fieldDecoder = parsePgType [dateOid] $ \case @@ -1105,15 +1182,13 @@ instance FromPgField Aeson.Value where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let - -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in - \case - Just bs -> case Aeson.decodeStrict $ fixJsonb bs of - Just d -> Right d - Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid." - Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls", + let -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in \case + Just bs -> case Aeson.decodeStrict $ fixJsonb bs of + Just d -> Right d + Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid." + Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } @@ -1151,7 +1226,7 @@ instance {-# OVERLAPPING #-} forall a. (FromPgField a) => FromPgField (Vector (V { fieldValueDecoder = \colInfo -> let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput in \case - Nothing -> Left "Cannot decode SQL null as the Haskell Vector type. Use a `Maybe (Vector (Vector a))`" + Nothing -> Left "Cannot decode SQL null as the Haskell (Vector (Vector a)) type. Use a `Maybe (Vector (Vector a))`" Just bs -> case Parser.parseOnly arrayFieldDecoder bs of Parser.ParseOk v -> Right v Parser.ParseFail err -> Left err, @@ -1185,6 +1260,8 @@ instance {-# OVERLAPPING #-} forall a. (FromPgField a) => FromPgField (Vector (V Left err -> fail $ "Error parsing array element: " ++ show err Right el -> pure el +{-# INLINE genericFromPgRow #-} + -- | Derives `FromPgRow` generically. genericFromPgRow :: forall a. (Generic a, ProductTypeDecoder (Rep a)) => RowDecoder a genericFromPgRow = to <$> genRowDecoder @(Rep a) diff --git a/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs b/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs index 35b50fe..ac199c6 100644 --- a/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs +++ b/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs @@ -22,10 +22,13 @@ module Hpgsql.Encoding.BinarySerializer encodeInt16BE, encodePgBoolean, decodeDataRow, + decodePgFieldWithAtMost4Bytes, + WordDecoding (..), ) where import Data.ByteString (ByteString) +import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as InternalBS import Data.Int (Int16, Int32, Int64) import Prelude hiding (encodeFloat) @@ -125,6 +128,8 @@ encodeFloat n = unsafeEncodeWord (castFloatToWord32 n) fromBigEndian32 4 encodeDouble :: Double -> ByteString encodeDouble n = unsafeEncodeWord (castDoubleToWord64 n) fromBigEndian64 8 +-- TODO: Encode field length together with value for small types. +-- This can also be a performance boost by having fewer bytestrings? {-# INLINE encodePgBoolean #-} encodePgBoolean :: Bool -> ByteString encodePgBoolean v = if v then "\SOH" else "\NUL" @@ -168,3 +173,53 @@ decodeDataRow idx bs@(InternalBS.BS _bytesPtr len) = toResult lenFullMsg | len >= 1 + lenFullMsg + idx.idx = Right $ ByteStringIdx $ 1 + lenFullMsg + idx.idx | otherwise = Left "Less than enough bytes to decode a full DataRow" + +{-# INLINE decodePgFieldWithAtMost4Bytes #-} + +data WordDecoding a where + TypeSize1 :: WordDecoding Word8 + TypeSize2 :: WordDecoding Word16 + TypeSize4 :: WordDecoding Word32 + +-- | A specialized decoder that decoders a query result's +-- field's contents, but only for PG fields at most 4 bytes long and +-- at least 1 byte long (so no text or void types, for example). +-- This includes essentially int32, int16, and booleans. +-- Pass in as type argument a Word8, Word16 or Word32 to indicate +-- the size of the PG type you're decoding. +decodePgFieldWithAtMost4Bytes :: forall a. (Storable a, Integral a) => WordDecoding a -> ByteString -> Either String (Maybe a, ByteString) +decodePgFieldWithAtMost4Bytes wdec = + let (pgTypeSize, endianSwap, valueMask :: Word64) = case wdec of + TypeSize1 -> (1, Prelude.id, 0b00000000_00000000_00000000_00000000_11111111_00000000_00000000_00000000) + TypeSize2 -> (2, fromBigEndian16, 0b00000000_00000000_00000000_00000000_11111111_11111111_00000000_00000000) + TypeSize4 -> (4, fromBigEndian32, 0b00000000_00000000_00000000_00000000_11111111_11111111_11111111_11111111) + valueShift :: Int = 8 * (4 - pgTypeSize) + in \bs -> + -- We try the most optimistic case first: + -- - Non-null 4 byte long types (like int32) + -- - Null int32 followed by at least one other field (not the last field in the row) + -- - Shorter types (int16, bool) followed by at least one other field (not the last field in the row) + -- In all the cases above, there are at least 8 bytes in the row, so our decoding into a Word64 will succeed. + case unsafeDecodeWord bs 8 fromBigEndian64 of + Right (w64 :: Word64) -> + let fieldLenW64 :: Word64 = flip unsafeShiftR 32 $ w64 .&. 0b11111111_11111111_11111111_11111111_00000000_00000000_00000000_00000000 + fieldIfNotNull :: a = fromIntegral $ unsafeShiftR (w64 .&. valueMask) valueShift + in if fieldLenW64 == 0xFFFFFFFF -- (-1) in two's-complement + then + Right (Nothing, BS.drop 4 bs) + else + if fieldLenW64 <= 4 -- TODO: Maybe we omit this check and make this an unsafe function? + then + Right $ (Just fieldIfNotNull, BS.drop (4 + fromIntegral fieldLenW64) bs) -- This avoids another load instruction + else Left "You cannot use decodePgFieldWithAtMost4Bytes to decode fields of types potentially more than 4 bytes long" + Left _ -> do + -- This is the not-as-optimistic case, which includes: + -- - A NULL int32 as the last field in the row + -- - A bool/int8/int16 that is the last field in the row + lenField <- decodeInt32BE 0 bs + if lenField >= 0 + then do + -- peek after the next 4 bytes for @a + fieldValue <- unsafeDecodeWordOffset 4 bs (fromIntegral pgTypeSize) endianSwap + Right (Just fieldValue, BS.drop (4 + fromIntegral lenField) bs) + else Right (Nothing, BS.drop 4 bs) -- TODO: Return "" as an empty bytestring diff --git a/hpgsql/src/Hpgsql/SimpleParser.hs b/hpgsql/src/Hpgsql/SimpleParser.hs index abac6d4..a9a6203 100644 --- a/hpgsql/src/Hpgsql/SimpleParser.hs +++ b/hpgsql/src/Hpgsql/SimpleParser.hs @@ -24,6 +24,10 @@ module Hpgsql.SimpleParser takeDataRow, parseManyRows, skip, + parsePgFieldWithAtMost4Bytes, + takeInt64BEWithFieldLength, + takeInt32BEWithFieldLength, + takeInt16BEWithFieldLength, ) where @@ -31,6 +35,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Int (Int16, Int32, Int64) import Hpgsql.Encoding.BinarySerializer (ByteStringIdx (..)) +import Foreign.Storable (Storable) import qualified Hpgsql.Encoding.BinarySerializer as BinSer import Prelude hiding (take) @@ -119,6 +124,15 @@ takeInt16BE = Parser $ \idx bs kf ks -> Left err -> kf err Right v -> ks v (idx + 2) bs +{-# INLINE takeInt16BEWithFieldLength #-} + +-- | Parses both a field length and the field itself, for +-- an Int16 in a row. +takeInt16BEWithFieldLength :: Parser (Maybe Int16) +takeInt16BEWithFieldLength = do + mi16 <- parsePgFieldWithAtMost4Bytes BinSer.TypeSize2 + pure $ fromIntegral <$> mi16 + {-# INLINE takeInt32BE #-} takeInt32BE :: Parser Int32 takeInt32BE = Parser $ \idx bs kf ks -> @@ -126,6 +140,26 @@ takeInt32BE = Parser $ \idx bs kf ks -> Left err -> kf err Right v -> ks v (idx + 4) bs +{-# INLINE takeInt32BEWithFieldLength #-} + +-- | Parses both a field length and the field itself, for +-- an Int32 in a row. +takeInt32BEWithFieldLength :: Parser (Maybe Int32) +takeInt32BEWithFieldLength = do + mi32 <- parsePgFieldWithAtMost4Bytes BinSer.TypeSize4 + pure $ fromIntegral <$> mi32 + +{-# INLINE takeInt64BEWithFieldLength #-} + +-- | Parses both a field length and the field itself, for +-- an Int64 in a row. +takeInt64BEWithFieldLength :: Parser (Maybe Int64) +takeInt64BEWithFieldLength = do + fieldLen <- takeInt32BE + if fieldLen == (-1) + then pure Nothing + else Just <$> takeInt64BE + {-# INLINE takeInt64BE #-} takeInt64BE :: Parser Int64 takeInt64BE = Parser $ \idx bs kf ks -> @@ -143,6 +177,18 @@ takeDataRow = Parser $ \idx bs kf ks -> Left err -> kf err Right idxRest -> ks idxRest idxRest bs +{-# INLINE parsePgFieldWithAtMost4Bytes #-} + +-- | A specialized parser that reads a query result's +-- field's contents. +parsePgFieldWithAtMost4Bytes :: forall a. (Storable a, Integral a) => BinSer.WordDecoding a -> Parser (Maybe a) +parsePgFieldWithAtMost4Bytes wdec = + let dec = BinSer.decodePgFieldWithAtMost4Bytes wdec + in Parser $ \bs kf ks -> + case dec bs of + Left err -> kf err + Right (v, rest) -> ks v rest + parseMany :: Parser a -> Parser [a] parseMany p = Parser $ \idx' bs' _kf ks -> let (vs, restIdx) = go idx' bs' in ks vs restIdx bs' where From f6a80a5dbbee47d7bf743e6d32a976ec78ae2b6e Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Wed, 12 Aug 2026 15:01:42 -0300 Subject: [PATCH 10/35] Post-rebase fixing --- hpgsql-tests/EncodingDecodingSpec.hs | 25 +++++++++++-------- hpgsql/src/Hpgsql/Encoding.hs | 18 +++++++------ .../src/Hpgsql/Encoding/BinarySerializer.hs | 22 ++++++++-------- hpgsql/src/Hpgsql/SimpleParser.hs | 8 +++--- 4 files changed, 39 insertions(+), 34 deletions(-) diff --git a/hpgsql-tests/EncodingDecodingSpec.hs b/hpgsql-tests/EncodingDecodingSpec.hs index f03bf77..efdbdfc 100644 --- a/hpgsql-tests/EncodingDecodingSpec.hs +++ b/hpgsql-tests/EncodingDecodingSpec.hs @@ -44,8 +44,8 @@ import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Gen import Hpgsql import Hpgsql.Connection (ConnectOpts (..), connect, connectOpts, defaultConnectOpts, refreshTypeInfoCache, withConnectionOpts) -import Hpgsql.InternalTypes (DataRow (..)) import Hpgsql.Encoding (EncodingContext (..), FieldDecoder (..), FieldEncoder (..), FieldInfo (..), FromPgField (..), FromPgRow (..), LowerCasedPgEnum (..), RowEncoder (..), ToPgField (..), ToPgRow (..), compositeTypeDecoder, compositeTypeEncoder, nullableField, rawBytesFieldDecoder, singleField, typeFieldDecoder, typeFieldEncoder, typeMustBeNamed, typeOidWithName) +import Hpgsql.InternalTypes (DataRow (..)) import Hpgsql.Pipeline (pipeline, pipeline1With, pipelineWith, runPipeline) import Hpgsql.Query (mkQuery, sql, vALUES) import Hpgsql.Time (Unbounded (..)) @@ -935,11 +935,13 @@ data Person = Person {name :: Text, born :: Day, heightMeters :: Double} specializedDataRowDecodingConsistency :: PropertyT IO () specializedDataRowDecodingConsistency = hedgehog $ do dataRows <- Gen.forAll $ Gen.list (Gen.linear 0 20) genDataRowBS - mapM_ (\drBS -> do - let restOfMsg = LBS.fromStrict (BS.drop 5 drBS) - parsed = parseDataRowFromPgMsg 'D' restOfMsg - fmap fullDataRow parsed === Just drBS - ) dataRows + mapM_ + ( \drBS -> do + let restOfMsg = LBS.fromStrict (BS.drop 5 drBS) + parsed = parseDataRowFromPgMsg 'D' restOfMsg + fmap fullDataRow parsed === Just drBS + ) + dataRows -- | Copy of the FromPgMessage DataRow instance's parsing logic from Hpgsql.Msgs. -- Keep in sync with that module's @instance FromPgMessage DataRow@. @@ -958,17 +960,18 @@ genDataRowBS = do fields <- replicateM numFields (genField maxPerField) pure $ buildDataRow fields where - genField maxBytes = Gen.choice - [ pure Nothing - , Just <$> Gen.bytes (Gen.linear 0 maxBytes) - ] + genField maxBytes = + Gen.choice + [ pure Nothing, + Just <$> Gen.bytes (Gen.linear 0 maxBytes) + ] buildDataRow :: [Maybe ByteString] -> ByteString buildDataRow fields = let nFields = length fields fieldsBS = BS.concat $ map encodeField fields payload = testEncodeInt16BE (fromIntegral nFields) <> fieldsBS lenVal = fromIntegral (BS.length payload + 4) :: Int32 - in BS.singleton 68 <> testEncodeInt32BE lenVal <> payload + in BS.singleton 68 <> testEncodeInt32BE lenVal <> payload encodeField Nothing = testEncodeInt32BE (-1) encodeField (Just bs) = testEncodeInt32BE (fromIntegral (BS.length bs)) <> bs diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index 02d1d6a..6df4a8a 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -1182,13 +1182,15 @@ instance FromPgField Aeson.Value where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in \case - Just bs -> case Aeson.decodeStrict $ fixJsonb bs of - Just d -> Right d - Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid." - Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls", + let + -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in + \case + Just bs -> case Aeson.decodeStrict $ fixJsonb bs of + Just d -> Right d + Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid." + Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } @@ -1282,7 +1284,7 @@ instance (FromPgField a) => ProductTypeDecoder (K1 r a) where -- coercing instead of fmap reduces memory usage, apparently -- by reducing (unnecessary) closures in the final row decoder, -- as per looking at GHC Core - genRowDecoder = coerce $ singleField $ fieldDecoder @a + genRowDecoder = coerce $ singleFieldRowDecoder @a genericToPgRow :: forall a. (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a genericToPgRow = contramap from genRowEncoder diff --git a/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs b/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs index ac199c6..34de8e6 100644 --- a/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs +++ b/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs @@ -28,7 +28,6 @@ module Hpgsql.Encoding.BinarySerializer where import Data.ByteString (ByteString) -import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as InternalBS import Data.Int (Int16, Int32, Int64) import Prelude hiding (encodeFloat) @@ -187,39 +186,40 @@ data WordDecoding a where -- This includes essentially int32, int16, and booleans. -- Pass in as type argument a Word8, Word16 or Word32 to indicate -- the size of the PG type you're decoding. -decodePgFieldWithAtMost4Bytes :: forall a. (Storable a, Integral a) => WordDecoding a -> ByteString -> Either String (Maybe a, ByteString) +-- Returns the index into the first yet-unparsed byte. +decodePgFieldWithAtMost4Bytes :: forall a. (Storable a, Integral a) => WordDecoding a -> ByteStringIdx -> ByteString -> Either String (Maybe a, ByteStringIdx) decodePgFieldWithAtMost4Bytes wdec = let (pgTypeSize, endianSwap, valueMask :: Word64) = case wdec of TypeSize1 -> (1, Prelude.id, 0b00000000_00000000_00000000_00000000_11111111_00000000_00000000_00000000) TypeSize2 -> (2, fromBigEndian16, 0b00000000_00000000_00000000_00000000_11111111_11111111_00000000_00000000) TypeSize4 -> (4, fromBigEndian32, 0b00000000_00000000_00000000_00000000_11111111_11111111_11111111_11111111) valueShift :: Int = 8 * (4 - pgTypeSize) - in \bs -> + in \idx bs -> -- We try the most optimistic case first: -- - Non-null 4 byte long types (like int32) -- - Null int32 followed by at least one other field (not the last field in the row) -- - Shorter types (int16, bool) followed by at least one other field (not the last field in the row) -- In all the cases above, there are at least 8 bytes in the row, so our decoding into a Word64 will succeed. - case unsafeDecodeWord bs 8 fromBigEndian64 of + case unsafeDecodeWord idx bs 8 fromBigEndian64 of Right (w64 :: Word64) -> let fieldLenW64 :: Word64 = flip unsafeShiftR 32 $ w64 .&. 0b11111111_11111111_11111111_11111111_00000000_00000000_00000000_00000000 fieldIfNotNull :: a = fromIntegral $ unsafeShiftR (w64 .&. valueMask) valueShift in if fieldLenW64 == 0xFFFFFFFF -- (-1) in two's-complement then - Right (Nothing, BS.drop 4 bs) + Right (Nothing, idx + 4) else - if fieldLenW64 <= 4 -- TODO: Maybe we omit this check and make this an unsafe function? + if fieldLenW64 <= 4 then - Right $ (Just fieldIfNotNull, BS.drop (4 + fromIntegral fieldLenW64) bs) -- This avoids another load instruction + Right (Just fieldIfNotNull, idx + 4 + fromIntegral fieldLenW64) else Left "You cannot use decodePgFieldWithAtMost4Bytes to decode fields of types potentially more than 4 bytes long" Left _ -> do -- This is the not-as-optimistic case, which includes: -- - A NULL int32 as the last field in the row -- - A bool/int8/int16 that is the last field in the row - lenField <- decodeInt32BE 0 bs + lenField <- decodeInt32BE idx bs if lenField >= 0 then do -- peek after the next 4 bytes for @a - fieldValue <- unsafeDecodeWordOffset 4 bs (fromIntegral pgTypeSize) endianSwap - Right (Just fieldValue, BS.drop (4 + fromIntegral lenField) bs) - else Right (Nothing, BS.drop 4 bs) -- TODO: Return "" as an empty bytestring + fieldValue <- unsafeDecodeWord (idx + 4) bs (fromIntegral pgTypeSize) endianSwap + Right (Just fieldValue, idx + 4 + fromIntegral lenField) + else Right (Nothing, idx + 4) diff --git a/hpgsql/src/Hpgsql/SimpleParser.hs b/hpgsql/src/Hpgsql/SimpleParser.hs index a9a6203..898177d 100644 --- a/hpgsql/src/Hpgsql/SimpleParser.hs +++ b/hpgsql/src/Hpgsql/SimpleParser.hs @@ -34,8 +34,8 @@ where import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Int (Int16, Int32, Int64) -import Hpgsql.Encoding.BinarySerializer (ByteStringIdx (..)) import Foreign.Storable (Storable) +import Hpgsql.Encoding.BinarySerializer (ByteStringIdx (..)) import qualified Hpgsql.Encoding.BinarySerializer as BinSer import Prelude hiding (take) @@ -184,10 +184,10 @@ takeDataRow = Parser $ \idx bs kf ks -> parsePgFieldWithAtMost4Bytes :: forall a. (Storable a, Integral a) => BinSer.WordDecoding a -> Parser (Maybe a) parsePgFieldWithAtMost4Bytes wdec = let dec = BinSer.decodePgFieldWithAtMost4Bytes wdec - in Parser $ \bs kf ks -> - case dec bs of + in Parser $ \idx bs kf ks -> + case dec idx bs of Left err -> kf err - Right (v, rest) -> ks v rest + Right (v, restIdx) -> ks v restIdx bs parseMany :: Parser a -> Parser [a] parseMany p = Parser $ \idx' bs' _kf ks -> let (vs, restIdx) = go idx' bs' in ks vs restIdx bs' From 5c16f6bf6541277a84e3ea517319ae6cc66cf34b Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Wed, 12 Aug 2026 16:41:25 -0300 Subject: [PATCH 11/35] More specialized instances, more confirmation of benefits --- hpgsql/src/Hpgsql/Encoding.hs | 46 +++++++++++++------ .../src/Hpgsql/Encoding/BinarySerializer.hs | 8 ++-- hpgsql/src/Hpgsql/SimpleParser.hs | 25 ++++++++-- 3 files changed, 57 insertions(+), 22 deletions(-) diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index 6df4a8a..b092942 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -157,6 +157,7 @@ instance Applicative RowDecoder where instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in Hpgsql because Hpgsql type-checks the result types of queries before having access to even the first data row. Use the Applicative class to write your instances or use the Monadic decoding variants.")) => Monad RowDecoder where (>>=) = error "inaccessible bind in Monad RowDecoder instance" +{-# INLINE singleField #-} -- 1.2% wall time perf. gain with this singleField :: FieldDecoder a -> RowDecoder a singleField (FieldDecoder {..}) = RowDecoder @@ -764,10 +765,10 @@ binaryIntSpecializedRowDecoder = do _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" binaryFloat4Decoder :: ByteString -> Float -binaryFloat4Decoder = castWord32ToFloat . either error id . BinSer.decodeWord32BE +binaryFloat4Decoder = castWord32ToFloat . either error id . BinSer.decodeWord32BE 0 binaryFloat8Decoder :: ByteString -> Double -binaryFloat8Decoder = castWord64ToDouble . either error id . BinSer.decodeWord64BE +binaryFloat8Decoder = castWord64ToDouble . either error id . BinSer.decodeWord64BE 0 parsePgType :: [Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a parsePgType !requiredTypeOids !fieldValueDecoder = @@ -808,6 +809,8 @@ instance FromPgField Int where numExpectedColumns = 1 } +-- The instance below makes our Records benchmark faster and use less +-- memory, but makes our Tuples benchmark slower. Worth investigating. -- instance {-# OVERLAPPING #-} FromPgField (Maybe Int) where -- fieldDecoder = error "NOOO" @@ -831,9 +834,9 @@ instance FromPgField Int where instance FromPgField Int16 where fieldDecoder = FieldDecoder - { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> - let !decode = binaryIntDecoder oid - in \case + { fieldValueDecoder = + let !decode = binaryIntDecoder int2Oid + in const $ \case Just bs -> decode bs Nothing -> Left "Cannot decode SQL null as the Haskell Int16 type. Use a `Maybe Int16`", allowedPgTypes = (== int2Oid) . fieldTypeOid @@ -905,6 +908,23 @@ instance FromPgField Double where Nothing -> Left "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`", allowedPgTypes = (`elem` [float8Oid, float4Oid]) . fieldTypeOid } + singleFieldRowDecoder = + let fromNullable = \case + Nothing -> fail "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`" + Just i -> pure i + float4OrDouble8Decoder = do + len <- Parser.takeInt32BE + case len of + 8 -> Just <$> Parser.takeDoubleBE + 4 -> Just . float2Double <$> Parser.takeFloatBE + _ -> pure Nothing + in RowDecoder + { fullRowDecoder = const $ float4OrDouble8Decoder >>= fromNullable, + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid `elem` [float8Oid, float4Oid])] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } -- | Allows you to specify a type (and other checks, possibly) for a `FieldDecoder`. -- This can be useful to ensure you're not accidentally decoding a different type. @@ -1182,15 +1202,13 @@ instance FromPgField Aeson.Value where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let - -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in - \case - Just bs -> case Aeson.decodeStrict $ fixJsonb bs of - Just d -> Right d - Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid." - Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls", + let -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in \case + Just bs -> case Aeson.decodeStrict $ fixJsonb bs of + Just d -> Right d + Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid." + Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } diff --git a/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs b/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs index 34de8e6..ba348a4 100644 --- a/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs +++ b/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs @@ -96,12 +96,12 @@ decodeWord8 :: ByteStringIdx -> ByteString -> Either String Word8 decodeWord8 idx bs = unsafeDecodeWord idx bs 1 Prelude.id {-# INLINE decodeWord32BE #-} -decodeWord32BE :: ByteString -> Either String Word32 -decodeWord32BE bs = unsafeDecodeWord 0 bs 4 fromBigEndian32 +decodeWord32BE :: ByteStringIdx -> ByteString -> Either String Word32 +decodeWord32BE idx bs = unsafeDecodeWord idx bs 4 fromBigEndian32 {-# INLINE decodeWord64BE #-} -decodeWord64BE :: ByteString -> Either String Word64 -decodeWord64BE bs = unsafeDecodeWord 0 bs 8 fromBigEndian64 +decodeWord64BE :: ByteStringIdx -> ByteString -> Either String Word64 +decodeWord64BE idx bs = unsafeDecodeWord idx bs 8 fromBigEndian64 {-# INLINE decodeInt32BE #-} decodeInt32BE :: ByteStringIdx -> ByteString -> Either String Int32 diff --git a/hpgsql/src/Hpgsql/SimpleParser.hs b/hpgsql/src/Hpgsql/SimpleParser.hs index 898177d..659f9e1 100644 --- a/hpgsql/src/Hpgsql/SimpleParser.hs +++ b/hpgsql/src/Hpgsql/SimpleParser.hs @@ -28,6 +28,8 @@ module Hpgsql.SimpleParser takeInt64BEWithFieldLength, takeInt32BEWithFieldLength, takeInt16BEWithFieldLength, + takeFloatBE, + takeDoubleBE, ) where @@ -35,6 +37,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Int (Int16, Int32, Int64) import Foreign.Storable (Storable) +import GHC.Float (castWord32ToFloat, castWord64ToDouble) import Hpgsql.Encoding.BinarySerializer (ByteStringIdx (..)) import qualified Hpgsql.Encoding.BinarySerializer as BinSer import Prelude hiding (take) @@ -121,8 +124,8 @@ skip n = Parser $ \idx bs _ ks -> takeInt16BE :: Parser Int16 takeInt16BE = Parser $ \idx bs kf ks -> case BinSer.decodeInt16BE idx bs of - Left err -> kf err Right v -> ks v (idx + 2) bs + Left err -> kf err {-# INLINE takeInt16BEWithFieldLength #-} @@ -137,8 +140,8 @@ takeInt16BEWithFieldLength = do takeInt32BE :: Parser Int32 takeInt32BE = Parser $ \idx bs kf ks -> case BinSer.decodeInt32BE idx bs of - Left err -> kf err Right v -> ks v (idx + 4) bs + Left err -> kf err {-# INLINE takeInt32BEWithFieldLength #-} @@ -149,6 +152,20 @@ takeInt32BEWithFieldLength = do mi32 <- parsePgFieldWithAtMost4Bytes BinSer.TypeSize4 pure $ fromIntegral <$> mi32 +{-# INLINE takeFloatBE #-} +takeFloatBE :: Parser Float +takeFloatBE = Parser $ \idx bs kf ks -> + case BinSer.decodeWord32BE idx bs of + Right v -> ks (castWord32ToFloat v) (idx + 4) bs + Left err -> kf err + +{-# INLINE takeDoubleBE #-} +takeDoubleBE :: Parser Double +takeDoubleBE = Parser $ \idx bs kf ks -> + case BinSer.decodeWord64BE idx bs of + Right v -> ks (castWord64ToDouble v) (idx + 8) bs + Left err -> kf err + {-# INLINE takeInt64BEWithFieldLength #-} -- | Parses both a field length and the field itself, for @@ -164,8 +181,8 @@ takeInt64BEWithFieldLength = do takeInt64BE :: Parser Int64 takeInt64BE = Parser $ \idx bs kf ks -> case BinSer.decodeInt64BE idx bs of - Left err -> kf err Right v -> ks v (idx + 8) bs + Left err -> kf err {-# INLINE takeDataRow #-} @@ -186,8 +203,8 @@ parsePgFieldWithAtMost4Bytes wdec = let dec = BinSer.decodePgFieldWithAtMost4Bytes wdec in Parser $ \idx bs kf ks -> case dec idx bs of - Left err -> kf err Right (v, restIdx) -> ks v restIdx bs + Left err -> kf err parseMany :: Parser a -> Parser [a] parseMany p = Parser $ \idx' bs' _kf ks -> let (vs, restIdx) = go idx' bs' in ks vs restIdx bs' From 91aad564dc178d4539cd14e51ce3e408eedbab54 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Wed, 12 Aug 2026 16:45:15 -0300 Subject: [PATCH 12/35] Specialized instance for UTCTime => clear benefits once again --- hpgsql/src/Hpgsql/Encoding.hs | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index b092942..0ffcf29 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -1081,6 +1081,26 @@ instance FromPgField UTCTime where parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 Right $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) Nothing -> Left "Cannot decode SQL null as the Haskell UTCTime type. Use a `Maybe UTCTime`" + singleFieldRowDecoder = + let fromNullable = \case + Nothing -> fail "Cannot decode SQL null as the Haskell UTCTime type. Use a `Maybe UTCTime`" + Just i -> pure i + utcTimeDecoder = do + len <- Parser.takeInt32BE + case len of + 8 -> do + totalusecs <- Parser.takeInt64BE + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + pure $ Just $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + _ -> pure Nothing + in RowDecoder + { fullRowDecoder = const $ utcTimeDecoder >>= fromNullable, + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid `elem` [timestamptzOid])] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } instance FromPgField (Unbounded UTCTime) where fieldDecoder = parsePgType [timestamptzOid] $ \case From 4b6e260b2c6ab34f81c069c9ca71e3bb1f5f7b3d Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Wed, 12 Aug 2026 17:08:08 -0300 Subject: [PATCH 13/35] Tidy up a bit --- hpgsql/src/Hpgsql/Encoding.hs | 58 ++++++++++++++++------------------- 1 file changed, 27 insertions(+), 31 deletions(-) diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index 0ffcf29..d2a1914 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -181,6 +181,28 @@ singleField (FieldDecoder {..}) = numExpectedColumns = 1 } +{-# INLINE uniqueOidRowPa #-} +uniqueOidRowPa :: Oid -> Parser.Parser a -> RowDecoder a +uniqueOidRowPa tyoid p = + -- FromPgField instances that only accept PG values of a single PG type + -- are very dear to us because they allow a very important optimization: + -- their row decoders do not care about the `FieldInfo` argument, which + -- makes them inlinable by GHC at compile time (FieldInfo is only available + -- at run time). + -- These are key to produce compiled to code that almost compiles down to + -- a bunch of `peek` calls to a single ByteString decoding bytes into + -- typed values, to then call the Parser continuation, and repeat. + -- The only allocations (I think) when everything is inlined by this are the + -- decoded values themselves being boxed and the CPS Parser's ByteStringIdx + -- also being passed boxed between continuations. + RowDecoder + { fullRowDecoder = const p, + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid == tyoid)] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } + class FromPgField a where -- | A decoder that takes fieldDecoder :: FieldDecoder a @@ -712,12 +734,6 @@ instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgF instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g, ToPgField h, ToPgField i, ToPgField j, ToPgField k) => ToPgRow (a, b, c, d, e, f, g, h, i, j, k) where rowEncoder = divide (\(a, b, c, d, e, f, g, h, i, j, k) -> ((a, b, c, d, e, f), (g, h, i, j, k))) rowEncoder rowEncoder --- instance (ToPgField a) => ToPgRow [a] where --- rowEncoder = RowEncoder { --- toPgParams = \xs -> concatMap toPgParams xs --- , toTypeOids = \_ -> concatMap (\) --- } $ \cols -> map (\v encodingContext -> let typOid = toTypeOid (Proxy @a) encodingContext in (typOid, toPgField encodingContext v)) cols - -- | The OID for `Data.Int`, which is machine dependent. haskellIntOid :: Oid @@ -996,17 +1012,10 @@ instance FromPgField Bool where Just bs -> Right $ bs == binaryTrue Nothing -> Left "Cannot decode SQL null as the Haskell Bool type. Use a `Maybe Bool`" singleFieldRowDecoder = - let dec = Parser.parsePgFieldWithAtMost4Bytes BinSer.TypeSize1 - word8ToBool = \case + let word8ToBool = \case Nothing -> fail "Cannot decode SQL null as the Haskell Bool type. Use a `Maybe Bool`" Just w8 -> pure $ w8 == 1 - in RowDecoder - { fullRowDecoder = const $ dec >>= word8ToBool, - rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid == boolOid)] - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", - numExpectedColumns = 1 - } + in uniqueOidRowPa boolOid $ Parser.parsePgFieldWithAtMost4Bytes BinSer.TypeSize1 >>= word8ToBool instance FromPgField Char where fieldDecoder = @@ -1094,13 +1103,7 @@ instance FromPgField UTCTime where parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 pure $ Just $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) _ -> pure Nothing - in RowDecoder - { fullRowDecoder = const $ utcTimeDecoder >>= fromNullable, - rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid `elem` [timestamptzOid])] - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", - numExpectedColumns = 1 - } + in uniqueOidRowPa timestamptzOid $ utcTimeDecoder >>= fromNullable instance FromPgField (Unbounded UTCTime) where fieldDecoder = parsePgType [timestamptzOid] $ \case @@ -1172,17 +1175,10 @@ instance FromPgField Day where Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 Nothing -> Left "Cannot decode SQL null as the Haskell Day type. Use a `Maybe Day`" singleFieldRowDecoder = - let dec = Parser.takeInt32BEWithFieldLength - int32ToDay = \case + let int32ToDay = \case Nothing -> fail "Cannot decode SQL null as the Haskell Day type. Use a `Maybe Day`" Just i32 -> let jd = fromIntegral i32 :: Integer in pure $ addJulianDurationClip (CalendarDiffDays 0 (jd - 13)) $ fromJulian 2000 01 01 - in RowDecoder - { fullRowDecoder = const $ dec >>= int32ToDay, - rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid == dateOid)] - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", - numExpectedColumns = 1 - } + in uniqueOidRowPa dateOid $ Parser.takeInt32BEWithFieldLength >>= int32ToDay instance FromPgField (Unbounded Day) where fieldDecoder = parsePgType [dateOid] $ \case From 54ba650afc1b6ed14bb61a09704362f61e92a6f8 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Thu, 13 Aug 2026 12:05:55 -0300 Subject: [PATCH 14/35] Slightly better understanding of inlining, clearer inlining boundaries We're beginning to converge to row decoders not being inlined by default, but their implementations/bodies being as inlined as possible, which feels reasonable. It remains to be seen if we can add a super-inlined version of row decoders for users to choose from if they wish, and what the effects are. --- Runfile | 1 - TODO.md | 4 ++ hpgsql-tests/RowDecoderGhcCore.hs | 55 ++++++++++++------- hpgsql/src/Hpgsql/Encoding.hs | 42 ++++++-------- .../src/Hpgsql/Encoding/BinarySerializer.hs | 4 +- hpgsql/src/Hpgsql/SimpleParser.hs | 8 +++ 6 files changed, 66 insertions(+), 48 deletions(-) create mode 100644 TODO.md diff --git a/Runfile b/Runfile index 5592c6a..406b180 100644 --- a/Runfile +++ b/Runfile @@ -107,6 +107,5 @@ tests-compat: ghc-core: set -eo pipefail - rm -f dist-newstyle/build/x86_64-linux/ghc-9.10.3/hpgsql-tests-0.1.0.0/x/hpgsql-tests/build/hpgsql-tests/hpgsql-tests-tmp/RowDecoderGhcCore.thr.dump-simpl cabal build hpgsql-tests 1>&2 cat dist-newstyle/build/x86_64-linux/ghc-9.10.3/hpgsql-tests-0.1.0.0/x/hpgsql-tests/build/hpgsql-tests/hpgsql-tests-tmp/RowDecoderGhcCore.thr.dump-simpl diff --git a/TODO.md b/TODO.md new file mode 100644 index 0000000..a53416c --- /dev/null +++ b/TODO.md @@ -0,0 +1,4 @@ +- Test both `singleField fieldDecoder` and `singleFieldRowDecoder` for every type in our tests. +- Make every FromPgField instance have a dedicated singleFieldRowDecoder override, change our benchmarks to exercise other types we're not, like `numeric` and `Float` +- Investigate why overlapping (Maybe a) instance is better for record decoding but worse for Tuple decoding +- Try to achieve a 100% inlined row decoder for a small record type diff --git a/hpgsql-tests/RowDecoderGhcCore.hs b/hpgsql-tests/RowDecoderGhcCore.hs index e53d8a5..2e431b9 100644 --- a/hpgsql-tests/RowDecoderGhcCore.hs +++ b/hpgsql-tests/RowDecoderGhcCore.hs @@ -2,37 +2,52 @@ -- | -- This is not a real test module. It's just a type deriving `FromPgRow` --- so we can look at GHC Core output. +-- so we can look at GHC Core output. It's as small as we can make it to +-- facilitate reading GHC Core. module RowDecoderGhcCore where import Data.Int (Int64) import Data.Text (Text) import Data.Time (Day, UTCTime) import GHC.Generics (Generic) -import Hpgsql.Encoding (FromPgRow (..), fieldDecoder, genericFromPgRow, singleField) - -data BenchRow = BenchRow - { brId :: !Int, - brDate1 :: !Day, - brDate2 :: !Day, - brTimestamp1 :: !UTCTime, - brTimestamp2 :: !UTCTime, - brText1 :: !Text, - brText2 :: !Text, - brDouble1 :: !Double, - brDouble2 :: !Double, - brMaybeInt :: !(Maybe Int), - brMaybeText :: !(Maybe Text), - brMaybeDouble :: !(Maybe Double), - brMaybeDay :: !(Maybe Day) +import Hpgsql.Encoding (FromPgRow (..), fieldDecoder, genericFromPgRow, singleField, singleFieldRowDecoder) + +-- | SmallRecord's purpose is to have a very small row decoder in GHC Core +-- for understanding. Also, we expect one day to maybe reach a fully inlined +-- row decoder that only peeks at bytes and allocates 3 values per row (one +-- for each field), plus one `SmallRecord` per row. +-- If we can get there, it'd be fabulous. +data SmallRecord = SmallRecord + { smallId :: !Int, + smallDate :: !Day, + smallText :: !Int } +instance FromPgRow SmallRecord where + rowDecoder = SmallRecord <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + +-- data BenchRow = BenchRow +-- { brId :: !Int, +-- brDate1 :: !Day, +-- brDate2 :: !Day, +-- brTimestamp1 :: !UTCTime, +-- brTimestamp2 :: !UTCTime, +-- brText1 :: !Text, +-- brText2 :: !Text, +-- brDouble1 :: !Double, +-- brDouble2 :: !Double, +-- brMaybeInt :: !(Maybe Int), +-- brMaybeText :: !(Maybe Text), +-- brMaybeDouble :: !(Maybe Double), +-- brMaybeDay :: !(Maybe Day) +-- } + -- Generically deriving section. -deriving instance Generic BenchRow +-- deriving instance Generic BenchRow -instance FromPgRow BenchRow where - rowDecoder = genericFromPgRow +-- instance FromPgRow BenchRow where +-- rowDecoder = genericFromPgRow -- Hand-written applicative style deriving section. -- instance FromPgRow BenchRow where diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index d2a1914..c928c1c 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -181,24 +181,25 @@ singleField (FieldDecoder {..}) = numExpectedColumns = 1 } -{-# INLINE uniqueOidRowPa #-} -uniqueOidRowPa :: Oid -> Parser.Parser a -> RowDecoder a -uniqueOidRowPa tyoid p = - -- FromPgField instances that only accept PG values of a single PG type - -- are very dear to us because they allow a very important optimization: +{-# INLINE inlinableRowDecoder #-} +inlinableRowDecoder :: [Oid] -> Parser.Parser a -> RowDecoder a +inlinableRowDecoder tyoids p = + -- FromPgField instances whose decoders don't care about the OID of the PG type + -- being decoded are very dear to us because they allow a very important optimization: -- their row decoders do not care about the `FieldInfo` argument, which -- makes them inlinable by GHC at compile time (FieldInfo is only available - -- at run time). + -- at run time when the RowDescription message arrives for a given query). -- These are key to produce compiled to code that almost compiles down to -- a bunch of `peek` calls to a single ByteString decoding bytes into -- typed values, to then call the Parser continuation, and repeat. -- The only allocations (I think) when everything is inlined by this are the -- decoded values themselves being boxed and the CPS Parser's ByteStringIdx - -- also being passed boxed between continuations. + -- also being passed boxed between continuations (though reading GHC Core + -- is something I'm still learning). RowDecoder { fullRowDecoder = const p, rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid == tyoid)] + [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid `elem` tyoids)] _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", numExpectedColumns = 1 } @@ -768,6 +769,7 @@ binaryIntDecoder typOid = \bs -> doesFit = maxBoundPgType <= fromIntegral (maxBound @a) -- | Specialized/performance-oriented Big-Endian binary decoder for Haskell's various IntXX types. +{-# INLINE binaryIntSpecializedRowDecoder #-} binaryIntSpecializedRowDecoder :: Parser.Parser (Maybe Int) binaryIntSpecializedRowDecoder = do fieldLen <- Parser.takeInt32BE @@ -813,17 +815,12 @@ instance FromPgField Int where Nothing -> Left "Cannot decode SQL null as the Haskell Int type. Use a `Maybe Int`", allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid } + {-# NOINLINE singleFieldRowDecoder #-} singleFieldRowDecoder = let fromNullable = \case Nothing -> fail "Cannot decode SQL null as the Haskell Int type. Use a `Maybe Int`" Just i -> pure i - in RowDecoder - { fullRowDecoder = const $ binaryIntSpecializedRowDecoder >>= fromNullable, - rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid `elem` haskellIntOids)] - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", - numExpectedColumns = 1 - } + in inlinableRowDecoder haskellIntOids $ binaryIntSpecializedRowDecoder >>= fromNullable -- The instance below makes our Records benchmark faster and use less -- memory, but makes our Tuples benchmark slower. Worth investigating. @@ -934,13 +931,7 @@ instance FromPgField Double where 8 -> Just <$> Parser.takeDoubleBE 4 -> Just . float2Double <$> Parser.takeFloatBE _ -> pure Nothing - in RowDecoder - { fullRowDecoder = const $ float4OrDouble8Decoder >>= fromNullable, - rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid `elem` [float8Oid, float4Oid])] - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", - numExpectedColumns = 1 - } + in inlinableRowDecoder [float8Oid, float4Oid] $ float4OrDouble8Decoder >>= fromNullable -- | Allows you to specify a type (and other checks, possibly) for a `FieldDecoder`. -- This can be useful to ensure you're not accidentally decoding a different type. @@ -1015,7 +1006,7 @@ instance FromPgField Bool where let word8ToBool = \case Nothing -> fail "Cannot decode SQL null as the Haskell Bool type. Use a `Maybe Bool`" Just w8 -> pure $ w8 == 1 - in uniqueOidRowPa boolOid $ Parser.parsePgFieldWithAtMost4Bytes BinSer.TypeSize1 >>= word8ToBool + in inlinableRowDecoder [boolOid] $ Parser.parsePgFieldWithAtMost4Bytes BinSer.TypeSize1 >>= word8ToBool instance FromPgField Char where fieldDecoder = @@ -1103,7 +1094,7 @@ instance FromPgField UTCTime where parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 pure $ Just $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) _ -> pure Nothing - in uniqueOidRowPa timestamptzOid $ utcTimeDecoder >>= fromNullable + in inlinableRowDecoder [timestamptzOid] $ utcTimeDecoder >>= fromNullable instance FromPgField (Unbounded UTCTime) where fieldDecoder = parsePgType [timestamptzOid] $ \case @@ -1174,11 +1165,12 @@ instance FromPgField Day where jd <- BinSer.decodeInt32BE 0 bs Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 Nothing -> Left "Cannot decode SQL null as the Haskell Day type. Use a `Maybe Day`" + {-# NOINLINE singleFieldRowDecoder #-} singleFieldRowDecoder = let int32ToDay = \case Nothing -> fail "Cannot decode SQL null as the Haskell Day type. Use a `Maybe Day`" Just i32 -> let jd = fromIntegral i32 :: Integer in pure $ addJulianDurationClip (CalendarDiffDays 0 (jd - 13)) $ fromJulian 2000 01 01 - in uniqueOidRowPa dateOid $ Parser.takeInt32BEWithFieldLength >>= int32ToDay + in inlinableRowDecoder [dateOid] $ Parser.takeInt32BEWithFieldLength >>= int32ToDay instance FromPgField (Unbounded Day) where fieldDecoder = parsePgType [dateOid] $ \case diff --git a/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs b/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs index ba348a4..a72fc8c 100644 --- a/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs +++ b/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs @@ -173,13 +173,13 @@ decodeDataRow idx bs@(InternalBS.BS _bytesPtr len) = | len >= 1 + lenFullMsg + idx.idx = Right $ ByteStringIdx $ 1 + lenFullMsg + idx.idx | otherwise = Left "Less than enough bytes to decode a full DataRow" -{-# INLINE decodePgFieldWithAtMost4Bytes #-} - data WordDecoding a where TypeSize1 :: WordDecoding Word8 TypeSize2 :: WordDecoding Word16 TypeSize4 :: WordDecoding Word32 +{-# INLINE decodePgFieldWithAtMost4Bytes #-} + -- | A specialized decoder that decoders a query result's -- field's contents, but only for PG fields at most 4 bytes long and -- at least 1 byte long (so no text or void types, for example). diff --git a/hpgsql/src/Hpgsql/SimpleParser.hs b/hpgsql/src/Hpgsql/SimpleParser.hs index 659f9e1..23942e4 100644 --- a/hpgsql/src/Hpgsql/SimpleParser.hs +++ b/hpgsql/src/Hpgsql/SimpleParser.hs @@ -33,6 +33,7 @@ module Hpgsql.SimpleParser ) where +import Control.Applicative (Alternative (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Int (Int16, Int32, Int64) @@ -73,6 +74,13 @@ instance Applicative Parser where pf idx bs kf (\f bs' idx' -> pa bs' idx' kf (\a bs'' idx'' -> ks (f a) bs'' idx'')) {-# INLINE (<*>) #-} +instance Alternative Parser where + empty = fail "empty Alternative" + {-# INLINE empty #-} + Parser p1 <|> Parser p2 = Parser $ \idx bs kf ks -> + p1 idx bs (\_ -> p2 idx bs kf ks) ks + {-# INLINE (<|>) #-} + instance Monad Parser where return = pure {-# INLINE return #-} From 235d9e1dbfb05012699ec5e4427cf5c494d12e93 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Thu, 13 Aug 2026 16:00:09 -0300 Subject: [PATCH 15/35] Add `inlinedSingleFieldDecoder` The boundary here is very nice: users that want to avoid too much code bloat can use the non-inlined decoders, and those that want to max out performance can use the inlined decoders. --- TODO.md | 1 + hpgsql-benchmarks/src/Main.hs | 6 +- hpgsql-tests/RowDecoderGhcCore.hs | 29 ++++--- hpgsql/src/Hpgsql/Encoding.hs | 140 +++++++++++++++++++----------- 4 files changed, 115 insertions(+), 61 deletions(-) diff --git a/TODO.md b/TODO.md index a53416c..e3e3aa8 100644 --- a/TODO.md +++ b/TODO.md @@ -1,4 +1,5 @@ - Test both `singleField fieldDecoder` and `singleFieldRowDecoder` for every type in our tests. - Make every FromPgField instance have a dedicated singleFieldRowDecoder override, change our benchmarks to exercise other types we're not, like `numeric` and `Float` - Investigate why overlapping (Maybe a) instance is better for record decoding but worse for Tuple decoding + - Revert things: derive the overlapping (Maybe a) instance, derive the `FromPgField a` using that under the hood. - Try to achieve a 100% inlined row decoder for a small record type diff --git a/hpgsql-benchmarks/src/Main.hs b/hpgsql-benchmarks/src/Main.hs index 139bd82..41a7f0e 100644 --- a/hpgsql-benchmarks/src/Main.hs +++ b/hpgsql-benchmarks/src/Main.hs @@ -46,6 +46,7 @@ import Hpgsql.Connection (renderLibpqConnectionString) import qualified Hpgsql.Connection import qualified Hpgsql.Connection as Hpgsql import qualified Hpgsql.Copy +import Hpgsql.Encoding (FromPgField (inlinedSingleFieldRowDecoder)) import qualified Hpgsql.Encoding as Hpgsql import qualified Hpgsql.Query as Hpgsql import qualified Hpgsql.Types as Hpgsql @@ -84,7 +85,10 @@ data BenchRow = BenchRow brMaybeDay :: !(Maybe Day) } deriving stock (Generic, Show, Eq) - deriving anyclass (NFData, Hpgsql.FromPgRow, PGSimple.FromRow) + deriving anyclass (NFData, PGSimple.FromRow) + +instance Hpgsql.FromPgRow BenchRow where + rowDecoder = BenchRow <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder data HasqlBenchRow = HasqlBenchRow { hbrId :: !Int32, diff --git a/hpgsql-tests/RowDecoderGhcCore.hs b/hpgsql-tests/RowDecoderGhcCore.hs index 2e431b9..0e1fab9 100644 --- a/hpgsql-tests/RowDecoderGhcCore.hs +++ b/hpgsql-tests/RowDecoderGhcCore.hs @@ -10,21 +10,28 @@ import Data.Int (Int64) import Data.Text (Text) import Data.Time (Day, UTCTime) import GHC.Generics (Generic) -import Hpgsql.Encoding (FromPgRow (..), fieldDecoder, genericFromPgRow, singleField, singleFieldRowDecoder) +import Hpgsql.Encoding (FromPgField (..), FromPgRow (..), genericFromPgRow, singleField) --- | SmallRecord's purpose is to have a very small row decoder in GHC Core --- for understanding. Also, we expect one day to maybe reach a fully inlined +-- | BestCaseScenarioRecord's purpose is to have a very small row decoder in GHC Core +-- for my own understanding/comprehension of what a RowDecoder gets compiled to +-- in the best case scenario. Also, we expect one day to maybe reach a fully inlined -- row decoder that only peeks at bytes and allocates 3 values per row (one --- for each field), plus one `SmallRecord` per row. --- If we can get there, it'd be fabulous. -data SmallRecord = SmallRecord - { smallId :: !Int, - smallDate :: !Day, - smallText :: !Int +-- for each field), plus one `BestCaseScenarioRecord` per row. +-- In the GHC Core of this module (use `run ghc-core` to output it), it helps to: +-- - Look for the Record constructor and grep for it to find where the RowDecoder +-- invokes it, only to find where the RowDecoder is. +-- - Grep for numbers that exist in the decoders' implementation, such as 8#, 13#, 4#. +-- These are a strong indicator that each decoder was inlined into the RowDecoder. +-- There is still unnecessary allocations/boxing even with full inlining, but maybe +-- one day we'll find a way to get rid of all of them. +data BestCaseScenarioRecord = BestCaseScenarioRecord + { bcsId :: !Int, + bcsDate :: !Day, + bcsText :: !Int } -instance FromPgRow SmallRecord where - rowDecoder = SmallRecord <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder +instance FromPgRow BestCaseScenarioRecord where + rowDecoder = BestCaseScenarioRecord <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder -- data BenchRow = BenchRow -- { brId :: !Int, diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index c928c1c..d767f62 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -216,6 +216,14 @@ class FromPgField a where singleFieldRowDecoder :: RowDecoder a singleFieldRowDecoder = singleField fieldDecoder + -- | This is just like `singleFieldDecoder`, but it inlines into your + -- `FromPgRow` instances aggressively. This will increase code size and + -- possibly compilation times somewhat, but in some cases it can make row decoders + -- compile down to a ByteString-peeking implementation with much fewer + -- allocations that can be ~10% faster than the other. + inlinedSingleFieldRowDecoder :: RowDecoder a + inlinedSingleFieldRowDecoder = singleFieldRowDecoder + class FromPgRow a where rowDecoder :: RowDecoder a default rowDecoder :: (Generic a, ProductTypeDecoder (Rep a)) => RowDecoder a @@ -768,20 +776,6 @@ binaryIntDecoder typOid = \bs -> | otherwise = error "Bug in Hpgsql. Decoding binary integral type not an int2, int4 or int8" doesFit = maxBoundPgType <= fromIntegral (maxBound @a) --- | Specialized/performance-oriented Big-Endian binary decoder for Haskell's various IntXX types. -{-# INLINE binaryIntSpecializedRowDecoder #-} -binaryIntSpecializedRowDecoder :: Parser.Parser (Maybe Int) -binaryIntSpecializedRowDecoder = do - fieldLen <- Parser.takeInt32BE - -- TODO: We're assuming `Int` is always 64 bits, so 64bit CPUs? Is that ok? - -- TODO: Is there a way to optimistically assume <=4 bytes and use our custom new parser? - case fieldLen of - 4 -> Just . fromIntegral <$> Parser.takeInt32BE - (-1) -> pure Nothing - 8 -> Just . fromIntegral <$> Parser.takeInt64BE - 2 -> Just . fromIntegral <$> Parser.takeInt16BE - _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" - binaryFloat4Decoder :: ByteString -> Float binaryFloat4Decoder = castWord32ToFloat . either error id . BinSer.decodeWord32BE 0 @@ -805,6 +799,19 @@ instance FromPgField () where allowedPgTypes = (== voidOid) . fieldTypeOid } +{-# INLINE intRowDecoder #-} +intRowDecoder = + inlinableRowDecoder haskellIntOids $ do + fieldLen <- Parser.takeInt32BE + -- TODO: We're assuming `Int` is always 64 bits, so 64bit CPUs? Is that ok? + -- TODO: Is there a way to optimistically assume <=4 bytes and use our custom new parser? + case fieldLen of + 4 -> fromIntegral <$> Parser.takeInt32BE + (-1) -> fail "Cannot decode SQL null as the Haskell Int type. Use a `Maybe Int`" + 8 -> fromIntegral <$> Parser.takeInt64BE + 2 -> fromIntegral <$> Parser.takeInt16BE + _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" + instance FromPgField Int where fieldDecoder = FieldDecoder @@ -816,11 +823,9 @@ instance FromPgField Int where allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid } {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = - let fromNullable = \case - Nothing -> fail "Cannot decode SQL null as the Haskell Int type. Use a `Maybe Int`" - Just i -> pure i - in inlinableRowDecoder haskellIntOids $ binaryIntSpecializedRowDecoder >>= fromNullable + singleFieldRowDecoder = intRowDecoder + {-# INLINE inlinedSingleFieldRowDecoder #-} + inlinedSingleFieldRowDecoder = intRowDecoder -- The instance below makes our Records benchmark faster and use less -- memory, but makes our Tuples benchmark slower. Worth investigating. @@ -909,6 +914,19 @@ instance FromPgField Float where Just bs -> Right $ binaryFloat4Decoder bs Nothing -> Left "Cannot decode SQL null as the Haskell Float type. Use a `Maybe Float`" +{-# INLINE doubleRowDecoder #-} +doubleRowDecoder = + let fromNullable = \case + Nothing -> fail "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`" + Just i -> pure i + float4OrDouble8Decoder = do + len <- Parser.takeInt32BE + case len of + 8 -> Just <$> Parser.takeDoubleBE + 4 -> Just . float2Double <$> Parser.takeFloatBE + _ -> fail "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`" + in inlinableRowDecoder [float8Oid, float4Oid] $ float4OrDouble8Decoder >>= fromNullable + instance FromPgField Double where fieldDecoder = FieldDecoder @@ -921,17 +939,10 @@ instance FromPgField Double where Nothing -> Left "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`", allowedPgTypes = (`elem` [float8Oid, float4Oid]) . fieldTypeOid } - singleFieldRowDecoder = - let fromNullable = \case - Nothing -> fail "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`" - Just i -> pure i - float4OrDouble8Decoder = do - len <- Parser.takeInt32BE - case len of - 8 -> Just <$> Parser.takeDoubleBE - 4 -> Just . float2Double <$> Parser.takeFloatBE - _ -> pure Nothing - in inlinableRowDecoder [float8Oid, float4Oid] $ float4OrDouble8Decoder >>= fromNullable + {-# NOINLINE singleFieldRowDecoder #-} + singleFieldRowDecoder = doubleRowDecoder + {-# INLINE inlinedSingleFieldRowDecoder #-} + inlinedSingleFieldRowDecoder = doubleRowDecoder -- | Allows you to specify a type (and other checks, possibly) for a `FieldDecoder`. -- This can be useful to ensure you're not accidentally decoding a different type. @@ -1038,11 +1049,28 @@ instance FromPgField LBS.ByteString where Just bs -> Right $ LBS.fromStrict bs Nothing -> Left "Cannot decode SQL null as the Haskell ByteString type. Use a `Maybe ByteString`" +{-# INLINE textDecoder #-} +textDecoder = + let fromNullable = \case + Nothing -> fail "Cannot decode SQL null as the Haskell Text type. Use a `Maybe Text`" + Just i -> pure i + rp = do + len <- Parser.takeInt32BE + if len >= 0 + -- TODO: Use some faster unsafeDecodeUtf8 function? + then Just . decodeUtf8 <$> Parser.take (fromIntegral len) + else pure Nothing + in inlinableRowDecoder [textOid, varcharOid, nameOid] $ rp >>= fromNullable + instance FromPgField Text where fieldDecoder = parsePgType [textOid, varcharOid, nameOid] $ \case Just bs -> Right $ decodeUtf8 bs -- TODO: Use some faster unsafeDecodeUtf8 function? Nothing -> Left "Cannot decode SQL null as the Haskell Text type. Use a `Maybe Text`" + {-# NOINLINE singleFieldRowDecoder #-} + singleFieldRowDecoder = textDecoder + {-# INLINE inlinedSingleFieldRowDecoder #-} + inlinedSingleFieldRowDecoder = textDecoder instance FromPgField LT.Text where fieldDecoder = parsePgType [textOid, varcharOid, nameOid] $ \case @@ -1072,6 +1100,22 @@ instance FromPgField (CI LT.Text) where instance FromPgField (CI String) where fieldDecoder = typeFieldDecoder (typeMustBeNamed "citext") $ CI.mk <$> fieldDecoder +{-# INLINE utcTimeRowDecoder #-} +utcTimeRowDecoder = + let fromNullable = \case + Nothing -> fail "Cannot decode SQL null as the Haskell UTCTime type. Use a `Maybe UTCTime`" + Just i -> pure i + utcTimeDecoder = do + len <- Parser.takeInt32BE + case len of + 8 -> do + totalusecs <- Parser.takeInt64BE + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + pure $ Just $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + _ -> pure Nothing + in inlinableRowDecoder [timestamptzOid] $ utcTimeDecoder >>= fromNullable + instance FromPgField UTCTime where fieldDecoder = parsePgType [timestamptzOid] $ \case Just bs -> do @@ -1081,20 +1125,13 @@ instance FromPgField UTCTime where parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 Right $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) Nothing -> Left "Cannot decode SQL null as the Haskell UTCTime type. Use a `Maybe UTCTime`" - singleFieldRowDecoder = - let fromNullable = \case - Nothing -> fail "Cannot decode SQL null as the Haskell UTCTime type. Use a `Maybe UTCTime`" - Just i -> pure i - utcTimeDecoder = do - len <- Parser.takeInt32BE - case len of - 8 -> do - totalusecs <- Parser.takeInt64BE - let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day - parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - pure $ Just $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - _ -> pure Nothing - in inlinableRowDecoder [timestamptzOid] $ utcTimeDecoder >>= fromNullable + {-# NOINLINE singleFieldRowDecoder #-} + singleFieldRowDecoder = utcTimeRowDecoder + {-# NOINLINE inlinedSingleFieldRowDecoder #-} + inlinedSingleFieldRowDecoder = utcTimeRowDecoder + +-- {-# INLINE inlinedSingleFieldRowDecoder #-} +-- inlinedSingleFieldRowDecoder = doubleRowDecoder instance FromPgField (Unbounded UTCTime) where fieldDecoder = parsePgType [timestamptzOid] $ \case @@ -1156,6 +1193,13 @@ instance FromPgField TimeOfDay where Right $ timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral usecs * 1_000_000 Nothing -> Left "Cannot decode SQL null as the Haskell TimeOfDay type. Use a `Maybe TimeOfDay`" +{-# INLINE dayRowDecoder #-} +dayRowDecoder = + let int32ToDay = \case + Nothing -> fail "Cannot decode SQL null as the Haskell Day type. Use a `Maybe Day`" + Just i32 -> let jd = fromIntegral i32 :: Integer in pure $ addJulianDurationClip (CalendarDiffDays 0 (jd - 13)) $ fromJulian 2000 01 01 + in inlinableRowDecoder [dateOid] $ Parser.takeInt32BEWithFieldLength >>= int32ToDay + instance FromPgField Day where fieldDecoder = parsePgType [dateOid] $ \case Just bs -> do @@ -1166,11 +1210,9 @@ instance FromPgField Day where Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 Nothing -> Left "Cannot decode SQL null as the Haskell Day type. Use a `Maybe Day`" {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = - let int32ToDay = \case - Nothing -> fail "Cannot decode SQL null as the Haskell Day type. Use a `Maybe Day`" - Just i32 -> let jd = fromIntegral i32 :: Integer in pure $ addJulianDurationClip (CalendarDiffDays 0 (jd - 13)) $ fromJulian 2000 01 01 - in inlinableRowDecoder [dateOid] $ Parser.takeInt32BEWithFieldLength >>= int32ToDay + singleFieldRowDecoder = dayRowDecoder + {-# INLINE inlinedSingleFieldRowDecoder #-} + inlinedSingleFieldRowDecoder = dayRowDecoder instance FromPgField (Unbounded Day) where fieldDecoder = parsePgType [dateOid] $ \case From 94a9ece7818749205f3143f0b2972e4ab4f30c9e Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Fri, 14 Aug 2026 12:05:34 -0300 Subject: [PATCH 16/35] More comprehensive coverage of types in benchmarks, more specialized row decoders --- hpgsql-benchmarks/hpgsql-benchmarks.cabal | 1 + hpgsql-benchmarks/src/Main.hs | 67 +++++++++---- hpgsql/src/Hpgsql/Encoding.hs | 116 ++++++++++++++++++---- hpgsql/src/Hpgsql/SimpleParser.hs | 12 ++- 4 files changed, 156 insertions(+), 40 deletions(-) diff --git a/hpgsql-benchmarks/hpgsql-benchmarks.cabal b/hpgsql-benchmarks/hpgsql-benchmarks.cabal index aa34959..d7269ae 100644 --- a/hpgsql-benchmarks/hpgsql-benchmarks.cabal +++ b/hpgsql-benchmarks/hpgsql-benchmarks.cabal @@ -72,6 +72,7 @@ executable hpgsql-benchmarks , hspec-expectations , postgresql-simple , resourcet + , scientific , statistics , stm , streaming diff --git a/hpgsql-benchmarks/src/Main.hs b/hpgsql-benchmarks/src/Main.hs index 41a7f0e..58420e4 100644 --- a/hpgsql-benchmarks/src/Main.hs +++ b/hpgsql-benchmarks/src/Main.hs @@ -24,6 +24,7 @@ import Criterion.Measurement.Types ) import qualified Data.ByteString.Char8 as BS8 import Data.Int (Int32, Int64) +import Data.Scientific (Scientific) import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as Text @@ -82,13 +83,18 @@ data BenchRow = BenchRow brMaybeInt :: !(Maybe Int), brMaybeText :: !(Maybe Text), brMaybeDouble :: !(Maybe Double), - brMaybeDay :: !(Maybe Day) + brMaybeDay :: !(Maybe Day), + brNumeric :: !Scientific, + brFloat :: !Float, + brBool1 :: Bool, + brBool2 :: Bool } deriving stock (Generic, Show, Eq) - deriving anyclass (NFData, PGSimple.FromRow) + deriving anyclass (NFData, Hpgsql.FromPgRow, PGSimple.FromRow) -instance Hpgsql.FromPgRow BenchRow where - rowDecoder = BenchRow <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder +fullyInlinedBenchRowDecoder :: Hpgsql.RowDecoder BenchRow +fullyInlinedBenchRowDecoder = + BenchRow <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder data HasqlBenchRow = HasqlBenchRow { hbrId :: !Int32, @@ -103,7 +109,11 @@ data HasqlBenchRow = HasqlBenchRow hbrMaybeInt :: !(Maybe Int32), hbrMaybeText :: !(Maybe Text), hbrMaybeDouble :: !(Maybe Double), - hbrMaybeDay :: !(Maybe Day) + hbrMaybeDay :: !(Maybe Day), + hbrNumeric :: !Scientific, + hbrFloat :: !Float, + hbrBool1 :: Bool, + hbrBool2 :: Bool } deriving stock (Generic, Show, Eq) deriving anyclass (NFData) @@ -169,12 +179,14 @@ main = do statsBefore <- getRTSStats hspecWith defaultConfig {configFormat = Just (formatterToFormat silent)} $ do + let sql17 = "SELECT g, ('2000-01-01'::date + g::int4), ('2000-06-15'::date + g::int4), ('2000-01-01T00:00:00Z'::timestamptz + g * interval '1 second'), ('2020-06-15T12:00:00Z'::timestamptz + g * interval '1 minute'), 'row-' || g::text, 'item-' || g::text, g::float8 * 1.5, g::float8 * 2.5, NULL::int4, NULL::text, NULL::float8, NULL::date, g::numeric, g::float4, g%2=0, g%2=1 FROM generate_series(1,$1) g" + sql17Simple = "SELECT g, ('2000-01-01'::date + g::int4), ('2000-06-15'::date + g::int4), ('2000-01-01T00:00:00Z'::timestamptz + g * interval '1 second'), ('2020-06-15T12:00:00Z'::timestamptz + g * interval '1 minute'), 'row-' || g::text, 'item-' || g::text, g::float8 * 1.5, g::float8 * 2.5, NULL::int4, NULL::text, NULL::float8, NULL::date, g::numeric, g::float4, g%2=0, g%2=1 FROM generate_series(1,?) g" + sql13 = "SELECT g, ('2000-01-01'::date + g::int4), ('2000-06-15'::date + g::int4), ('2000-01-01T00:00:00Z'::timestamptz + g * interval '1 second'), ('2020-06-15T12:00:00Z'::timestamptz + g * interval '1 minute'), 'row-' || g::text, 'item-' || g::text, g::float8 * 1.5, g::float8 * 2.5, NULL::int4, NULL::text, NULL::float8, NULL::date FROM generate_series(1,$1) g" + sql13Simple = "SELECT g, ('2000-01-01'::date + g::int4), ('2000-06-15'::date + g::int4), ('2000-01-01T00:00:00Z'::timestamptz + g * interval '1 second'), ('2020-06-15T12:00:00Z'::timestamptz + g * interval '1 minute'), 'row-' || g::text, 'item-' || g::text, g::float8 * 1.5, g::float8 * 2.5, NULL::int4, NULL::text, NULL::float8, NULL::date FROM generate_series(1,?) g" describe "Parsing 13-column rows into a List" $ do - let sql = "SELECT g, ('2000-01-01'::date + g::int4), ('2000-06-15'::date + g::int4), ('2000-01-01T00:00:00Z'::timestamptz + g * interval '1 second'), ('2020-06-15T12:00:00Z'::timestamptz + g * interval '1 minute'), 'row-' || g::text, 'item-' || g::text, g::float8 * 1.5, g::float8 * 2.5, NULL::int4, NULL::text, NULL::float8, NULL::date FROM generate_series(1,$1) g" - pgSimpleSql = "SELECT g, ('2000-01-01'::date + g::int4), ('2000-06-15'::date + g::int4), ('2000-01-01T00:00:00Z'::timestamptz + g * interval '1 second'), ('2020-06-15T12:00:00Z'::timestamptz + g * interval '1 minute'), 'row-' || g::text, 'item-' || g::text, g::float8 * 1.5, g::float8 * 2.5, NULL::int4, NULL::text, NULL::float8, NULL::date FROM generate_series(1,?) g" - hasqlListStmt = + let hasqlListStmt = HasqlStmt.Statement - sql + sql13 (HasqlEnc.param (HasqlEnc.nonNullable HasqlEnc.int4)) ( HasqlDec.rowList ( (,,,,,,,,,,,,) @@ -196,7 +208,7 @@ main = do True hasqlRecordListStmt = HasqlStmt.Statement - sql + sql17 (HasqlEnc.param (HasqlEnc.nonNullable HasqlEnc.int4)) ( HasqlDec.rowList ( HasqlBenchRow @@ -213,15 +225,19 @@ main = do <*> HasqlDec.column (HasqlDec.nullable HasqlDec.text) <*> HasqlDec.column (HasqlDec.nullable HasqlDec.float8) <*> HasqlDec.column (HasqlDec.nullable HasqlDec.date) + <*> HasqlDec.column (HasqlDec.nonNullable HasqlDec.numeric) + <*> HasqlDec.column (HasqlDec.nonNullable HasqlDec.float4) + <*> HasqlDec.column (HasqlDec.nonNullable HasqlDec.bool) + <*> HasqlDec.column (HasqlDec.nonNullable HasqlDec.bool) ) ) True - forM_ [10_000 :: Int, 100_000] $ \n -> do + forM_ [100_000 :: Int] $ \n -> do it ("hpgsql Tuple List (" ++ show n ++ " rows)") $ void $ bench ("hpgsql Tuple List (" ++ show n ++ " rows)") $ withMultipleConnections numConcurrentConnections hpgsqlConnect Hpgsql.Connection.closeGracefully $ \conn -> do - Hpgsql.queryWith (Hpgsql.rowDecoder @(Int, Day, Day, UTCTime, UTCTime, Text, Text, Double, Double, Maybe Int, Maybe Text, Maybe Double, Maybe Day)) conn (Hpgsql.mkQuery sql (Hpgsql.Only n)) + Hpgsql.queryWith (Hpgsql.rowDecoder @(Int, Day, Day, UTCTime, UTCTime, Text, Text, Double, Double, Maybe Int, Maybe Text, Maybe Double, Maybe Day)) conn (Hpgsql.mkQuery sql13 (Hpgsql.Only n)) it ("hasql Tuple List (" ++ show n ++ " rows)") $ void $ bench ("hasql Tuple List (" ++ show n ++ " rows)") $ @@ -232,12 +248,12 @@ main = do void $ bench ("postgresql-simple Tuple List (" ++ show n ++ " rows)") $ withMultipleConnections numConcurrentConnections pgSimpleConnect PGSimple.close $ \pgSimpleConn -> do - PGSimple.query @_ @(Int, Day, Day, UTCTime, UTCTime, Text, Text, Double, Double, Maybe Int, Maybe Text, Maybe Double, Maybe Day) pgSimpleConn pgSimpleSql (PGSimple.Only n) + PGSimple.query @_ @(Int, Day, Day, UTCTime, UTCTime, Text, Text, Double, Double, Maybe Int, Maybe Text, Maybe Double, Maybe Day) pgSimpleConn sql13Simple (PGSimple.Only n) it ("hpgsql Record List (" ++ show n ++ " rows)") $ void $ bench ("hpgsql Record List (" ++ show n ++ " rows)") $ withMultipleConnections numConcurrentConnections hpgsqlConnect Hpgsql.Connection.closeGracefully $ \conn -> do - Hpgsql.queryWith (Hpgsql.rowDecoder @BenchRow) conn (Hpgsql.mkQuery sql (Hpgsql.Only n)) + Hpgsql.queryWith (Hpgsql.rowDecoder @BenchRow) conn (Hpgsql.mkQuery sql17 (Hpgsql.Only n)) it ("hasql Record List (" ++ show n ++ " rows)") $ void $ bench ("hasql Record List (" ++ show n ++ " rows)") $ @@ -248,40 +264,47 @@ main = do void $ bench ("postgresql-simple Record List (" ++ show n ++ " rows)") $ withMultipleConnections numConcurrentConnections pgSimpleConnect PGSimple.close $ \pgSimpleConn -> do - PGSimple.query @_ @BenchRow pgSimpleConn pgSimpleSql (PGSimple.Only n) + PGSimple.query @_ @BenchRow pgSimpleConn sql17Simple (PGSimple.Only n) describe "Parsing 13-column rows in streaming fashion" $ do - let sql = "SELECT g, ('2000-01-01'::date + g::int4), ('2000-06-15'::date + g::int4), ('2000-01-01T00:00:00Z'::timestamptz + g * interval '1 second'), ('2020-06-15T12:00:00Z'::timestamptz + g * interval '1 minute'), 'row-' || g::text, 'item-' || g::text, g::float8 * 1.5, g::float8 * 2.5, NULL::int4, NULL::text, NULL::float8, NULL::date FROM generate_series(1,$1) g" - forM_ [10_000 :: Int, 100_000] $ \n -> do + forM_ [100_000 :: Int] $ \n -> do it ("hpgsql Tuple Stream (" ++ show n ++ " rows)") $ void $ bench ("hpgsql Tuple Stream (" ++ show n ++ " rows)") $ withMultipleConnections numConcurrentConnections hpgsqlConnect Hpgsql.Connection.closeGracefully $ \conn -> do - res <- Hpgsql.querySWith (Hpgsql.rowDecoder @(Int, Day, Day, UTCTime, UTCTime, Text, Text, Double, Double, Maybe Int, Maybe Text, Maybe Double, Maybe Day)) conn (Hpgsql.mkQuery sql (Hpgsql.Only n)) + res <- Hpgsql.querySWith (Hpgsql.rowDecoder @(Int, Day, Day, UTCTime, UTCTime, Text, Text, Double, Double, Maybe Int, Maybe Text, Maybe Double, Maybe Day)) conn (Hpgsql.mkQuery sql13 (Hpgsql.Only n)) S.effects res it ("streaming-postgresql-simple Tuple Stream (" ++ show n ++ " rows)") $ void $ bench ("streaming-postgresql-simple Tuple Stream (" ++ show n ++ " rows)") $ withMultipleConnections numConcurrentConnections pgSimpleConnect PGSimple.close $ \pgSimpleConn -> do runResourceT @IO $ do - let res :: Stream (Of (Int, Day, Day, UTCTime, UTCTime, Text, Text, Double, Double, Maybe Int, Maybe Text, Maybe Double, Maybe Day)) (ResourceT IO) () = StreamingPostgresSimple.query pgSimpleConn "SELECT g, ('2000-01-01'::date + g::int4), ('2000-06-15'::date + g::int4), ('2000-01-01T00:00:00Z'::timestamptz + g * interval '1 second'), ('2020-06-15T12:00:00Z'::timestamptz + g * interval '1 minute'), 'row-' || g::text, 'item-' || g::text, g::float8 * 1.5, g::float8 * 2.5, NULL::int4, NULL::text, NULL::float8, NULL::date FROM generate_series(1,?) g" (PGSimple.Only n) + let res :: Stream (Of (Int, Day, Day, UTCTime, UTCTime, Text, Text, Double, Double, Maybe Int, Maybe Text, Maybe Double, Maybe Day)) (ResourceT IO) () = StreamingPostgresSimple.query pgSimpleConn sql13Simple (PGSimple.Only n) S.effects res it ("postgresql-simple Tuple fold (" ++ show n ++ " rows)") $ void $ bench ("postgresql-simple Tuple fold (" ++ show n ++ " rows)") $ withMultipleConnections numConcurrentConnections pgSimpleConnect PGSimple.close $ \pgSimpleConn -> do - PGSimple.fold pgSimpleConn "SELECT g, ('2000-01-01'::date + g::int4), ('2000-06-15'::date + g::int4), ('2000-01-01T00:00:00Z'::timestamptz + g * interval '1 second'), ('2020-06-15T12:00:00Z'::timestamptz + g * interval '1 minute'), 'row-' || g::text, 'item-' || g::text, g::float8 * 1.5, g::float8 * 2.5, NULL::int4, NULL::text, NULL::float8, NULL::date FROM generate_series(1,?) g" (PGSimple.Only n) () (\() (!_ :: (Int, Day, Day, UTCTime, UTCTime, Text, Text, Double, Double, Maybe Int, Maybe Text, Maybe Double, Maybe Day)) -> pure ()) + PGSimple.fold pgSimpleConn sql13Simple (PGSimple.Only n) () (\() (!_ :: (Int, Day, Day, UTCTime, UTCTime, Text, Text, Double, Double, Maybe Int, Maybe Text, Maybe Double, Maybe Day)) -> pure ()) + describe "Parsing 17-column rows in streaming fashion" $ do + forM_ [100_000 :: Int] $ \n -> do it ("hpgsql Record Stream (" ++ show n ++ " rows)") $ void $ bench ("hpgsql Record Stream (" ++ show n ++ " rows)") $ do withMultipleConnections numConcurrentConnections hpgsqlConnect Hpgsql.Connection.closeGracefully $ \conn -> do - res <- Hpgsql.querySWith (Hpgsql.rowDecoder @BenchRow) conn (Hpgsql.mkQuery sql (Hpgsql.Only n)) + res <- Hpgsql.querySWith (Hpgsql.rowDecoder @BenchRow) conn (Hpgsql.mkQuery sql17 (Hpgsql.Only n)) + S.effects res + it ("hpgsql Record Stream (" ++ show n ++ " rows, fully inlined row decoder)") $ + void $ + bench ("hpgsql Record Stream (" ++ show n ++ " rows, fully inlined row decoder)") $ do + withMultipleConnections numConcurrentConnections hpgsqlConnect Hpgsql.Connection.closeGracefully $ \conn -> do + res <- Hpgsql.querySWith fullyInlinedBenchRowDecoder conn (Hpgsql.mkQuery sql17 (Hpgsql.Only n)) S.effects res it ("streaming-postgresql-simple Record Stream (" ++ show n ++ " rows)") $ void $ bench ("streaming-postgresql-simple Record Stream (" ++ show n ++ " rows)") $ withMultipleConnections numConcurrentConnections pgSimpleConnect PGSimple.close $ \pgSimpleConn -> do runResourceT @IO $ do - let res :: Stream (Of BenchRow) (ResourceT IO) () = StreamingPostgresSimple.query pgSimpleConn "SELECT g, ('2000-01-01'::date + g::int4), ('2000-06-15'::date + g::int4), ('2000-01-01T00:00:00Z'::timestamptz + g * interval '1 second'), ('2020-06-15T12:00:00Z'::timestamptz + g * interval '1 minute'), 'row-' || g::text, 'item-' || g::text, g::float8 * 1.5, g::float8 * 2.5, NULL::int4, NULL::text, NULL::float8, NULL::date FROM generate_series(1,?) g" (PGSimple.Only n) + let res :: Stream (Of BenchRow) (ResourceT IO) () = StreamingPostgresSimple.query pgSimpleConn sql17Simple (PGSimple.Only n) S.effects res it ("postgresql-simple Record fold (" ++ show n ++ " rows)") $ void $ diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index d767f62..276b473 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -800,6 +800,7 @@ instance FromPgField () where } {-# INLINE intRowDecoder #-} +intRowDecoder :: RowDecoder Int intRowDecoder = inlinableRowDecoder haskellIntOids $ do fieldLen <- Parser.takeInt32BE @@ -860,6 +861,17 @@ instance FromPgField Int16 where allowedPgTypes = (== int2Oid) . fieldTypeOid } +{-# INLINE int32RowDecoder #-} +int32RowDecoder :: RowDecoder Int32 +int32RowDecoder = + inlinableRowDecoder [int2Oid, int4Oid] $ do + fieldLen <- Parser.takeInt32BE + case fieldLen of + 4 -> Parser.takeInt32BE + (-1) -> fail "Cannot decode SQL null as the Haskell Int32 type. Use a `Maybe Int32`" + 2 -> fromIntegral <$> Parser.takeInt16BE + _ -> fail "Trying to decode PG int4 but it's not 2 or 4 bytes long" + instance FromPgField Int32 where fieldDecoder = FieldDecoder @@ -870,6 +882,22 @@ instance FromPgField Int32 where Nothing -> Left "Cannot decode SQL null as the Haskell Int32 type. Use a `Maybe Int32`", allowedPgTypes = (`elem` [int2Oid, int4Oid]) . fieldTypeOid } + {-# NOINLINE singleFieldRowDecoder #-} + singleFieldRowDecoder = int32RowDecoder + {-# INLINE inlinedSingleFieldRowDecoder #-} + inlinedSingleFieldRowDecoder = int32RowDecoder + +{-# INLINE int64RowDecoder #-} +int64RowDecoder :: RowDecoder Int64 +int64RowDecoder = + inlinableRowDecoder [int2Oid, int4Oid, int8Oid] $ do + fieldLen <- Parser.takeInt32BE + case fieldLen of + 8 -> Parser.takeInt64BE + 4 -> fromIntegral <$> Parser.takeInt32BE + (-1) -> fail "Cannot decode SQL null as the Haskell Int64 type. Use a `Maybe Int64`" + 2 -> fromIntegral <$> Parser.takeInt16BE + _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" instance FromPgField Int64 where fieldDecoder = @@ -881,6 +909,10 @@ instance FromPgField Int64 where Nothing -> Left "Cannot decode SQL null as the Haskell Int64 type. Use a `Maybe Int64`", allowedPgTypes = (`elem` [int2Oid, int4Oid, int8Oid]) . fieldTypeOid } + {-# NOINLINE singleFieldRowDecoder #-} + singleFieldRowDecoder = int64RowDecoder + {-# INLINE inlinedSingleFieldRowDecoder #-} + inlinedSingleFieldRowDecoder = int64RowDecoder instance FromPgField Integer where fieldDecoder = @@ -909,12 +941,25 @@ instance FromPgField Oid where allowedPgTypes = (== oidOid) . fieldTypeOid } +{-# INLINE floatRowDecoder #-} +floatRowDecoder :: RowDecoder Float +floatRowDecoder = + let fromNullable = \case + Nothing -> fail "Cannot decode SQL null as the Haskell Float type. Use a `Maybe Float`" + Just i -> pure i + in inlinableRowDecoder [float4Oid] $ Parser.takeFloatBEWithFieldLength >>= fromNullable + instance FromPgField Float where fieldDecoder = parsePgType [float4Oid] $ \case Just bs -> Right $ binaryFloat4Decoder bs Nothing -> Left "Cannot decode SQL null as the Haskell Float type. Use a `Maybe Float`" + {-# NOINLINE singleFieldRowDecoder #-} + singleFieldRowDecoder = floatRowDecoder + {-# INLINE inlinedSingleFieldRowDecoder #-} + inlinedSingleFieldRowDecoder = floatRowDecoder {-# INLINE doubleRowDecoder #-} +doubleRowDecoder :: RowDecoder Double doubleRowDecoder = let fromNullable = \case Nothing -> fail "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`" @@ -967,6 +1012,7 @@ typeMustBeNamed :: Text -> (FieldInfo -> Bool) typeMustBeNamed typName = \fieldInfo -> (typeName <$> lookupTypeByOid fieldInfo.fieldTypeOid fieldInfo.encodingContext.typeInfoCache) == Just typName +{-# INLINE scientificDecoder #-} scientificDecoder :: Bool -> Parser.Parser Scientific scientificDecoder mustBeInteger = do ndigits <- Parser.takeInt16BE @@ -984,24 +1030,50 @@ scientificDecoder mustBeInteger = do !digit <- fromIntegral <$> Parser.takeInt16BE parseAndMult (ndigitsLeft - 1) (currexpon - 4) (val + scientific digit currexpon) +{-# INLINE numericRowParser #-} +numericRowParser :: Parser.Parser Scientific +numericRowParser = do + fieldLen <- Parser.takeInt32BE + case fieldLen of + (-1) -> fail "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`" + _ -> scientificDecoder False + instance FromPgField Scientific where -- See https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/numeric.c#L1163 fieldDecoder = FieldDecoder - { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> - let !decodeInt = binaryIntDecoder @Int64 oid - in \case - Just bs -> - -- TODO: There is loss converting from Float/Double to Scientific, but it might be quite small, so should we accept - -- float4Oid and float8Oid here? - if oid == numericOid - then case Parser.parseOnly (scientificDecoder False <* Parser.endOfInput) bs of - Parser.ParseOk sci -> Right sci - Parser.ParseFail err -> Left err - else flip scientific 0 . fromIntegral <$> decodeInt bs - Nothing -> Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`", + { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> + if fieldTypeOid /= numericOid + then + let intdec = binaryIntDecoder @Int64 fieldTypeOid + in \case + Just bs -> flip scientific 0 . fromIntegral <$> intdec bs + Nothing -> Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`" + else \case + Just bs -> + -- TODO: There is loss converting from Float/Double to Scientific, but it might be quite small, so should we accept + -- float4Oid and float8Oid here? + case Parser.parseOnly (scientificDecoder False <* Parser.endOfInput) bs of + Parser.ParseOk sci -> Right sci + Parser.ParseFail err -> Left err + Nothing -> Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`", allowedPgTypes = (`elem` [numericOid, int2Oid, int4Oid, int8Oid]) . fieldTypeOid } + {-# NOINLINE singleFieldRowDecoder #-} + singleFieldRowDecoder = + RowDecoder + { fullRowDecoder = \case + [singleColInfo] -> + if singleColInfo.fieldTypeOid /= numericOid + then + flip scientific 0 . fromIntegral <$> (inlinedSingleFieldRowDecoder @Int64).fullRowDecoder [singleColInfo] + else numericRowParser + _ -> error "singleField expected a single column OID but got 0 or >1", + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid `elem` [numericOid, int2Oid, int4Oid, int8Oid])] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } instance FromPgField (Ratio Integer) where fieldDecoder = toRational <$> fieldDecoder @Scientific @@ -1009,15 +1081,22 @@ instance FromPgField (Ratio Integer) where binaryTrue :: ByteString binaryTrue = BinSer.encodePgBoolean True +{-# INLINE boolRowDecoder #-} +boolRowDecoder :: RowDecoder Bool +boolRowDecoder = + let word8ToBool = \case + Nothing -> fail "Cannot decode SQL null as the Haskell Bool type. Use a `Maybe Bool`" + Just w8 -> pure $ w8 == 1 + in inlinableRowDecoder [boolOid] $ Parser.parsePgFieldWithAtMost4Bytes BinSer.TypeSize1 >>= word8ToBool + instance FromPgField Bool where fieldDecoder = parsePgType [boolOid] $ \case Just bs -> Right $ bs == binaryTrue Nothing -> Left "Cannot decode SQL null as the Haskell Bool type. Use a `Maybe Bool`" - singleFieldRowDecoder = - let word8ToBool = \case - Nothing -> fail "Cannot decode SQL null as the Haskell Bool type. Use a `Maybe Bool`" - Just w8 -> pure $ w8 == 1 - in inlinableRowDecoder [boolOid] $ Parser.parsePgFieldWithAtMost4Bytes BinSer.TypeSize1 >>= word8ToBool + {-# NOINLINE singleFieldRowDecoder #-} + singleFieldRowDecoder = boolRowDecoder + {-# INLINE inlinedSingleFieldRowDecoder #-} + inlinedSingleFieldRowDecoder = boolRowDecoder instance FromPgField Char where fieldDecoder = @@ -1050,6 +1129,7 @@ instance FromPgField LBS.ByteString where Nothing -> Left "Cannot decode SQL null as the Haskell ByteString type. Use a `Maybe ByteString`" {-# INLINE textDecoder #-} +textDecoder :: RowDecoder Text textDecoder = let fromNullable = \case Nothing -> fail "Cannot decode SQL null as the Haskell Text type. Use a `Maybe Text`" @@ -1101,6 +1181,7 @@ instance FromPgField (CI String) where fieldDecoder = typeFieldDecoder (typeMustBeNamed "citext") $ CI.mk <$> fieldDecoder {-# INLINE utcTimeRowDecoder #-} +utcTimeRowDecoder :: RowDecoder UTCTime utcTimeRowDecoder = let fromNullable = \case Nothing -> fail "Cannot decode SQL null as the Haskell UTCTime type. Use a `Maybe UTCTime`" @@ -1194,6 +1275,7 @@ instance FromPgField TimeOfDay where Nothing -> Left "Cannot decode SQL null as the Haskell TimeOfDay type. Use a `Maybe TimeOfDay`" {-# INLINE dayRowDecoder #-} +dayRowDecoder :: RowDecoder Day dayRowDecoder = let int32ToDay = \case Nothing -> fail "Cannot decode SQL null as the Haskell Day type. Use a `Maybe Day`" diff --git a/hpgsql/src/Hpgsql/SimpleParser.hs b/hpgsql/src/Hpgsql/SimpleParser.hs index 23942e4..145c54d 100644 --- a/hpgsql/src/Hpgsql/SimpleParser.hs +++ b/hpgsql/src/Hpgsql/SimpleParser.hs @@ -30,6 +30,7 @@ module Hpgsql.SimpleParser takeInt16BEWithFieldLength, takeFloatBE, takeDoubleBE, + takeFloatBEWithFieldLength, ) where @@ -38,7 +39,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Int (Int16, Int32, Int64) import Foreign.Storable (Storable) -import GHC.Float (castWord32ToFloat, castWord64ToDouble) +import GHC.Float (castWord32ToFloat, castWord64ToDouble, word2Float) import Hpgsql.Encoding.BinarySerializer (ByteStringIdx (..)) import qualified Hpgsql.Encoding.BinarySerializer as BinSer import Prelude hiding (take) @@ -160,6 +161,15 @@ takeInt32BEWithFieldLength = do mi32 <- parsePgFieldWithAtMost4Bytes BinSer.TypeSize4 pure $ fromIntegral <$> mi32 +{-# INLINE takeFloatBEWithFieldLength #-} + +-- | Parses both a field length and the field itself, for +-- a Float in a row. +takeFloatBEWithFieldLength :: Parser (Maybe Float) +takeFloatBEWithFieldLength = do + mf <- parsePgFieldWithAtMost4Bytes BinSer.TypeSize4 + pure $ castWord32ToFloat <$> mf + {-# INLINE takeFloatBE #-} takeFloatBE :: Parser Float takeFloatBE = Parser $ \idx bs kf ks -> From 2eea650121fa28033e3294954269bf905a4a41c0 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Fri, 14 Aug 2026 14:19:48 -0300 Subject: [PATCH 17/35] Tests for non-specialized field decoders --- hpgsql-tests/EncodingDecodingSpec.hs | 518 ++++++++++++++++----------- 1 file changed, 306 insertions(+), 212 deletions(-) diff --git a/hpgsql-tests/EncodingDecodingSpec.hs b/hpgsql-tests/EncodingDecodingSpec.hs index efdbdfc..d49bc84 100644 --- a/hpgsql-tests/EncodingDecodingSpec.hs +++ b/hpgsql-tests/EncodingDecodingSpec.hs @@ -372,8 +372,18 @@ byteaTextDecoding conn = hedgehog $ do someBs :: ByteString <- Gen.forAll $ Gen.bytes (Gen.linear 0 50) let lazyBs :: LBS.ByteString = LBS.fromStrict someBs hexStr = concatMap (\w -> let s = showHex w "" in if length s < 2 then '0' : s else s) (BS.unpack someBs) - res <- liftIO $ queryMay conn (fromString $ "SELECT '\\x" <> hexStr <> "'::bytea, '\\x" <> hexStr <> "'::bytea") - res === Just (someBs, lazyBs) + qry = fromString $ "SELECT '\\x" <> hexStr <> "'::bytea, '\\x" <> hexStr <> "'::bytea" + (res1, res2) <- + liftIO $ + runPipeline conn $ + (,) + <$> pipeline1With rowDecoder qry + -- Specialized row parsers of each type are a different implementation from + -- the simpler fieldDecoders, so we need to test both + <*> pipeline1With ((,) <$> singleField fieldDecoder <*> singleField fieldDecoder) qry + let expectedResult = (someBs, lazyBs) + liftIO res1 >>= (=== expectedResult) + liftIO res2 >>= (=== expectedResult) dateAndTimestampTextDecoding :: HPgConnection -> PropertyT IO () dateAndTimestampTextDecoding conn = hedgehog $ do @@ -393,38 +403,43 @@ dateAndTimestampTextDecoding conn = hedgehog $ do someNominalDiffTime :: NominalDiffTime = realToFrac $ picosecondsToDiffTime (someNominalDiffTimeMicros * 1_000_000) (intervalSecs, intervalRemMicros) = someIntervalTimeMicros `quotRem` 1_000_000 (nomSecs, nomRemMicros) = someNominalDiffTimeMicros `quotRem` 1_000_000 - res <- + qry = + fromString $ + "SELECT '" + <> iso8601Show date + <> "'::date" + <> ", '" + <> iso8601Show timetz + <> "'::timestamptz" + <> ", '" + <> show someNumberOfMonths + <> " months " + <> show intervalSecs + <> " seconds " + <> show intervalRemMicros + <> " microseconds'::interval" + <> ", '" + <> iso8601Show timetz + <> "'::timestamptz" + <> ", '" + <> iso8601Show date + <> "'::date" + <> ", '" + <> show nomSecs + <> " seconds " + <> show nomRemMicros + <> " microseconds'::interval" + (res1, res2) <- liftIO $ - queryWith - rowDecoder - conn - ( fromString $ - "SELECT '" - <> iso8601Show date - <> "'::date" - <> ", '" - <> iso8601Show timetz - <> "'::timestamptz" - <> ", '" - <> show someNumberOfMonths - <> " months " - <> show intervalSecs - <> " seconds " - <> show intervalRemMicros - <> " microseconds'::interval" - <> ", '" - <> iso8601Show timetz - <> "'::timestamptz" - <> ", '" - <> iso8601Show date - <> "'::date" - <> ", '" - <> show nomSecs - <> " seconds " - <> show nomRemMicros - <> " microseconds'::interval" - ) - res === [(date, timetz, someCalendarDiffTime, Finite timetz, Finite date, CalendarDiffTime 0 someNominalDiffTime)] + runPipeline conn $ + (,) + <$> pipeline1With rowDecoder qry + -- Specialized row parsers of each type are a different implementation from + -- the simpler fieldDecoders, so we need to test both + <*> pipeline1With ((,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder) qry + let expectedResult = (date, timetz, someCalendarDiffTime, Finite timetz, Finite date, CalendarDiffTime 0 someNominalDiffTime) + liftIO res1 >>= (=== expectedResult) + liftIO res2 >>= (=== expectedResult) numericTextDecoding :: HPgConnection -> PropertyT IO () numericTextDecoding conn = hedgehog $ do @@ -433,30 +448,35 @@ numericTextDecoding conn = hedgehog $ do doubleVal :: Double <- Gen.forAll $ Gen.double $ Gen.exponentialFloatFrom 0 (-1e308) 1e308 doubleVal2 :: Double <- Gen.forAll $ Gen.double $ Gen.linearFracFrom 0 (-1e308) 1e308 integerVal :: Integer <- Gen.forAll $ (*) <$> (fromIntegral @Int64 <$> Gen.enumBounded) <*> (fromIntegral @Int64 <$> Gen.enumBounded) - res <- + let qry = + fromString $ + "SELECT '1.521'::numeric, '1.521'::numeric(4,1), '1.521'::numeric" + <> ", '" + <> show floatVal + <> "'::float4" + <> ", '" + <> show floatVal2 + <> "'::float4" + <> ", '" + <> show doubleVal + <> "'::float8" + <> ", '" + <> show doubleVal2 + <> "'::float8" + <> ", '" + <> show integerVal + <> "'::numeric" + (res1, res2) <- liftIO $ - queryWith - rowDecoder - conn - ( fromString $ - "SELECT '1.521'::numeric, '1.521'::numeric(4,1), '1.521'::numeric" - <> ", '" - <> show floatVal - <> "'::float4" - <> ", '" - <> show floatVal2 - <> "'::float4" - <> ", '" - <> show doubleVal - <> "'::float8" - <> ", '" - <> show doubleVal2 - <> "'::float8" - <> ", '" - <> show integerVal - <> "'::numeric" - ) - res === [(1.521 :: Scientific, 1.5 :: Scientific, 1.521 :: Scientific, floatVal, floatVal2, doubleVal, doubleVal2, integerVal)] + runPipeline conn $ + (,) + <$> pipeline1With rowDecoder qry + -- Specialized row parsers of each type are a different implementation from + -- the simpler fieldDecoders, so we need to test both + <*> pipeline1With ((,,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder) qry + let expectedResult = (1.521 :: Scientific, 1.5 :: Scientific, 1.521 :: Scientific, floatVal, floatVal2, doubleVal, doubleVal2, integerVal) + liftIO res1 >>= (=== expectedResult) + liftIO res2 >>= (=== expectedResult) numericTextDecodingLargerTypes :: HPgConnection -> PropertyT IO () numericTextDecodingLargerTypes conn = hedgehog $ do @@ -464,63 +484,107 @@ numericTextDecodingLargerTypes conn = hedgehog $ do int2Val :: Int16 <- Gen.forAll Gen.enumBounded int4Val :: Int32 <- Gen.forAll Gen.enumBounded int8Val :: Int64 <- Gen.forAll Gen.enumBounded - res <- + let qry = + fromString $ + "SELECT '" + <> show floatVal + <> "'::float4" + <> ", '" + <> show int2Val + <> "'::int2" + <> ", '" + <> show int2Val + <> "'::int2" + <> ", '" + <> show int2Val + <> "'::int2" + <> ", '" + <> show int2Val + <> "'::int2" + <> ", '" + <> show int4Val + <> "'::int4" + <> ", '" + <> show int4Val + <> "'::int4" + <> ", '" + <> show int4Val + <> "'::int4" + <> ", '" + <> show int8Val + <> "'::int8" + <> ", '" + <> show int8Val + <> "'::int8" + (res1, res2) <- liftIO $ - queryWith - rowDecoder - conn - ( fromString $ - "SELECT '" - <> show floatVal - <> "'::float4" - <> ", '" - <> show int2Val - <> "'::int2" - <> ", '" - <> show int2Val - <> "'::int2" - <> ", '" - <> show int2Val - <> "'::int2" - <> ", '" - <> show int2Val - <> "'::int2" - <> ", '" - <> show int4Val - <> "'::int4" - <> ", '" - <> show int4Val - <> "'::int4" - <> ", '" - <> show int4Val - <> "'::int4" - <> ", '" - <> show int8Val - <> "'::int8" - <> ", '" - <> show int8Val - <> "'::int8" - ) - let rowRes = (float2Double floatVal, fromIntegral int2Val :: Int32, fromIntegral int2Val :: Int64, fromIntegral int2Val :: Integer, fromIntegral int2Val :: Scientific, fromIntegral int4Val :: Int64, fromIntegral int4Val :: Integer, fromIntegral int4Val :: Scientific, fromIntegral int8Val :: Integer, fromIntegral int8Val :: Scientific) - res === [rowRes] + runPipeline conn $ + (,) + <$> pipeline1With rowDecoder qry + -- Specialized row parsers of each type are a different implementation from + -- the simpler fieldDecoders, so we need to test both + <*> pipeline1With ((,,,,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder) qry + let expectedResult = (float2Double floatVal, fromIntegral int2Val :: Int32, fromIntegral int2Val :: Int64, fromIntegral int2Val :: Integer, fromIntegral int2Val :: Scientific, fromIntegral int4Val :: Int64, fromIntegral int4Val :: Integer, fromIntegral int4Val :: Scientific, fromIntegral int8Val :: Integer, fromIntegral int8Val :: Scientific) + liftIO res1 >>= (=== expectedResult) + liftIO res2 >>= (=== expectedResult) numericExtremeTextDecoding :: HPgConnection -> IO () numericExtremeTextDecoding conn = do - queryWith rowDecoder conn (fromString $ "SELECT '" <> show (minBound :: Int16) <> "'::int2, '" <> show (maxBound :: Int16) <> "'::int2") - `shouldReturn` [(minBound :: Int16, maxBound :: Int16)] - queryWith rowDecoder conn (fromString $ "SELECT '" <> show (minBound :: Int32) <> "'::int4, '" <> show (maxBound :: Int32) <> "'::int4") - `shouldReturn` [(minBound :: Int32, maxBound :: Int32)] - queryWith rowDecoder conn (fromString $ "SELECT '" <> show (minBound :: Int64) <> "'::int8, '" <> show (maxBound :: Int64) <> "'::int8") - `shouldReturn` [(minBound :: Int64, maxBound :: Int64)] - [(f :: Float, d :: Double)] <- queryWith rowDecoder conn "SELECT 'NaN'::float4, 'NaN'::float8" - f `shouldSatisfy` isNaN - d `shouldSatisfy` isNaN - queryWith rowDecoder conn "SELECT 'Infinity'::float4, '-Infinity'::float4, 'Infinity'::float8, '-Infinity'::float8" - `shouldReturn` [((1 / 0) :: Float, ((-1) / 0) :: Float, (1 / 0) :: Double, ((-1) / 0) :: Double)] - [(d1 :: Double, d2 :: Double, d3 :: Double)] <- queryWith rowDecoder conn "SELECT 'NaN'::float4, 'Infinity'::float4, '-Infinity'::float4" + -- Specialized row parsers of each type are a different implementation from + -- the simpler fieldDecoders, so we need to test both + let int16Qry = fromString $ "SELECT '" <> show (minBound :: Int16) <> "'::int2, '" <> show (maxBound :: Int16) <> "'::int2" + int32Qry = fromString $ "SELECT '" <> show (minBound :: Int32) <> "'::int4, '" <> show (maxBound :: Int32) <> "'::int4" + int64Qry = fromString $ "SELECT '" <> show (minBound :: Int64) <> "'::int8, '" <> show (maxBound :: Int64) <> "'::int8" + nanQry = "SELECT 'NaN'::float4, 'NaN'::float8" + infQry = "SELECT 'Infinity'::float4, '-Infinity'::float4, 'Infinity'::float8, '-Infinity'::float8" + mixQry = "SELECT 'NaN'::float4, 'Infinity'::float4, '-Infinity'::float4" + (int16Res1, int16Res2, int32Res1, int32Res2, int64Res1, int64Res2, nanRes1, nanRes2, infRes1, infRes2, mixRes1, mixRes2) <- + runPipeline conn $ + (,,,,,,,,,,,) + <$> pipeline1With rowDecoder int16Qry + <*> pipeline1With ((,) <$> singleField fieldDecoder <*> singleField fieldDecoder) int16Qry + <*> pipeline1With rowDecoder int32Qry + <*> pipeline1With ((,) <$> singleField fieldDecoder <*> singleField fieldDecoder) int32Qry + <*> pipeline1With rowDecoder int64Qry + <*> pipeline1With ((,) <$> singleField fieldDecoder <*> singleField fieldDecoder) int64Qry + <*> pipeline1With rowDecoder nanQry + <*> pipeline1With ((,) <$> singleField fieldDecoder <*> singleField fieldDecoder) nanQry + <*> pipeline1With rowDecoder infQry + <*> pipeline1With ((,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder) infQry + <*> pipeline1With rowDecoder mixQry + <*> pipeline1With ((,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder) mixQry + -- Integer boundary values + int16Res1 `shouldReturn` (minBound :: Int16, maxBound :: Int16) + int16Res2 `shouldReturn` (minBound :: Int16, maxBound :: Int16) + int32Res1 `shouldReturn` (minBound :: Int32, maxBound :: Int32) + int32Res2 `shouldReturn` (minBound :: Int32, maxBound :: Int32) + int64Res1 `shouldReturn` (minBound :: Int64, maxBound :: Int64) + int64Res2 `shouldReturn` (minBound :: Int64, maxBound :: Int64) + -- NaN for Float and Double + (f1 :: Float, d1 :: Double) <- nanRes1 + f1 `shouldSatisfy` isNaN d1 `shouldSatisfy` isNaN - d2 `shouldBe` (1 / 0 :: Double) - d3 `shouldBe` ((-1) / 0 :: Double) + (f2 :: Float, d2 :: Double) <- nanRes2 + f2 `shouldSatisfy` isNaN + d2 `shouldSatisfy` isNaN + -- +-Infinity for Float and Double + let infRow = (posInfFloat, negInfFloat, posInfDouble, negInfDouble) + infRes1 `shouldReturn` infRow + infRes2 `shouldReturn` infRow + -- NaN and +-Infinity encoded as Float, decoded as Double + (md1 :: Double, md2 :: Double, md3 :: Double) <- mixRes1 + md1 `shouldSatisfy` isNaN + md2 `shouldBe` posInfDouble + md3 `shouldBe` negInfDouble + (md4 :: Double, md5 :: Double, md6 :: Double) <- mixRes2 + md4 `shouldSatisfy` isNaN + md5 `shouldBe` posInfDouble + md6 `shouldBe` negInfDouble + where + posInfFloat = (1 / 0) :: Float + negInfFloat = ((-1) / 0) :: Float + posInfDouble = (1 / 0) :: Double + negInfDouble = ((-1) / 0) :: Double jsonTextDecoding :: HPgConnection -> PropertyT IO () jsonTextDecoding conn = hedgehog $ do @@ -528,29 +592,38 @@ jsonTextDecoding conn = hedgehog $ do jsonVal2 :: Aeson.Value <- Gen.forAll genJsonValue jsonVal3 :: Aeson.Value <- Gen.forAll genJsonValue let encodeJson = pgEscape . Text.unpack . TE.decodeUtf8 . LBS.toStrict . Aeson.encode - [(v1, v2, v3, v4) :: (Aeson.Value, Aeson.Value, PgJson, PgJson)] <- + qry = + fromString $ + "SELECT '" + <> encodeJson jsonVal1 + <> "'::json" + <> ", '" + <> encodeJson jsonVal1 + <> "'::jsonb" + <> ", '" + <> encodeJson jsonVal2 + <> "'::json" + <> ", '" + <> encodeJson jsonVal3 + <> "'::jsonb" + -- Specialized row parsers of each type are a different implementation from + -- the simpler fieldDecoders, so we need to test both + (res1, res2) <- liftIO $ - queryWith - rowDecoder - conn - ( fromString $ - "SELECT '" - <> encodeJson jsonVal1 - <> "'::json" - <> ", '" - <> encodeJson jsonVal1 - <> "'::jsonb" - <> ", '" - <> encodeJson jsonVal2 - <> "'::json" - <> ", '" - <> encodeJson jsonVal3 - <> "'::jsonb" - ) + runPipeline conn $ + (,) + <$> pipeline1With rowDecoder qry + <*> pipeline1With ((,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder) qry + (v1, v2, v3, v4) :: (Aeson.Value, Aeson.Value, PgJson, PgJson) <- liftIO res1 v1 === jsonVal1 v2 === jsonVal1 Aeson.toJSON v3 === jsonVal2 Aeson.toJSON v4 === jsonVal3 + (v5, v6, v7, v8) :: (Aeson.Value, Aeson.Value, PgJson, PgJson) <- liftIO res2 + v5 === jsonVal1 + v6 === jsonVal1 + Aeson.toJSON v7 === jsonVal2 + Aeson.toJSON v8 === jsonVal3 where pgEscape = concatMap $ \case '\'' -> "''" @@ -570,13 +643,18 @@ uuidTextDecoding :: HPgConnection -> PropertyT IO () uuidTextDecoding conn = hedgehog $ do uuidBytes <- Gen.forAll $ Gen.bytes (Gen.singleton 16) let Just uuid = UUID.fromByteString (LBS.fromStrict uuidBytes) - res <- + qry = fromString $ "SELECT '" <> UUID.toString uuid <> "'::uuid" + (res1, res2) <- liftIO $ - queryWith - rowDecoder - conn - (fromString $ "SELECT '" <> UUID.toString uuid <> "'::uuid") - res === [Only uuid] + runPipeline conn $ + (,) + <$> pipeline1With rowDecoder qry + -- Specialized row parsers of each type are a different implementation from + -- the simpler fieldDecoders, so we need to test both + <*> pipeline1With (Only <$> singleField fieldDecoder) qry + let expectedResult = Only uuid + liftIO res1 >>= (=== expectedResult) + liftIO res2 >>= (=== expectedResult) ciTextRoundTrip :: HPgConnection -> PropertyT IO () ciTextRoundTrip conn = hedgehog $ do @@ -604,13 +682,18 @@ ciTextRoundTrip conn = hedgehog $ do ciTextTextDecoding :: HPgConnection -> PropertyT IO () ciTextTextDecoding conn = hedgehog $ do someText :: Text <- Gen.forAll $ Gen.text (Gen.linear 0 50) (Gen.filter (\c -> c /= '\0' && c /= '\'') Gen.unicode) - res <- - liftIO $ do - queryWith - rowDecoder - conn - (fromString $ "SELECT '" <> Text.unpack someText <> "'::citext, '" <> Text.unpack someText <> "'::citext, '" <> Text.unpack someText <> "'::citext") - res === [(CI.mk someText, CI.mk (LT.fromStrict someText), CI.mk (Text.unpack someText))] + let qry = fromString $ "SELECT '" <> Text.unpack someText <> "'::citext, '" <> Text.unpack someText <> "'::citext, '" <> Text.unpack someText <> "'::citext" + (res1, res2) <- + liftIO $ + runPipeline conn $ + (,) + <$> pipeline1With rowDecoder qry + -- Specialized row parsers of each type are a different implementation from + -- the simpler fieldDecoders, so we need to test both + <*> pipeline1With ((,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder) qry + let expectedResult = (CI.mk someText, CI.mk (LT.fromStrict someText), CI.mk (Text.unpack someText)) + liftIO res1 >>= (=== expectedResult) + liftIO res2 >>= (=== expectedResult) timeOfDayRoundTrip :: HPgConnection -> PropertyT IO () timeOfDayRoundTrip conn = hedgehog $ do @@ -642,43 +725,48 @@ timeOfDayTextDecoding conn = hedgehog $ do pure $ timeToTimeOfDay $ picosecondsToDiffTime (timeOfDayMicros * 1_000_000) row <- Gen.forAll $ (,,,,,,,,,) <$> genTimeOfDay <*> genTimeOfDay <*> genTimeOfDay <*> genTimeOfDay <*> genTimeOfDay <*> genTimeOfDay <*> genTimeOfDay <*> genTimeOfDay <*> genTimeOfDay <*> genTimeOfDay let (t1, t2, t3, t4, t5, t6, t7, t8, t9, t10) = row - res <- + qry = + fromString $ + "SELECT '" + <> iso8601Show t1 + <> "'::time" + <> ", '" + <> iso8601Show t2 + <> "'::time" + <> ", '" + <> iso8601Show t3 + <> "'::time" + <> ", '" + <> iso8601Show t4 + <> "'::time" + <> ", '" + <> iso8601Show t5 + <> "'::time" + <> ", '" + <> iso8601Show t6 + <> "'::time" + <> ", '" + <> iso8601Show t7 + <> "'::time" + <> ", '" + <> iso8601Show t8 + <> "'::time" + <> ", '" + <> iso8601Show t9 + <> "'::time" + <> ", '" + <> iso8601Show t10 + <> "'::time" + (res1, res2) <- liftIO $ - query - conn - ( fromString $ - "SELECT '" - <> iso8601Show t1 - <> "'::time" - <> ", '" - <> iso8601Show t2 - <> "'::time" - <> ", '" - <> iso8601Show t3 - <> "'::time" - <> ", '" - <> iso8601Show t4 - <> "'::time" - <> ", '" - <> iso8601Show t5 - <> "'::time" - <> ", '" - <> iso8601Show t6 - <> "'::time" - <> ", '" - <> iso8601Show t7 - <> "'::time" - <> ", '" - <> iso8601Show t8 - <> "'::time" - <> ", '" - <> iso8601Show t9 - <> "'::time" - <> ", '" - <> iso8601Show t10 - <> "'::time" - ) - res === [row] + runPipeline conn $ + (,) + <$> pipeline1With rowDecoder qry + -- Specialized row parsers of each type are a different implementation from + -- the simpler fieldDecoders, so we need to test both + <*> pipeline1With ((,,,,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder) qry + liftIO res1 >>= (=== row) + liftIO res2 >>= (=== row) localTimeTextDecoding :: HPgConnection -> PropertyT IO () localTimeTextDecoding conn = hedgehog $ do @@ -692,7 +780,39 @@ localTimeTextDecoding conn = hedgehog $ do pure $ LocalTime localDay localTimeOfDay row <- Gen.forAll $ (,,,,,,,,,) <$> genLocalTime <*> genLocalTime <*> genLocalTime <*> genLocalTime <*> genLocalTime <*> genLocalTime <*> genLocalTime <*> genLocalTime <*> genLocalTime <*> genLocalTime let (lt1, lt2, lt3, lt4, lt5, lt6, lt7, lt8, lt9, lt10) = row - res <- + qry = + fromString $ + "SELECT '" + <> iso8601Show lt1 + <> "'::timestamp" + <> ", '" + <> iso8601Show lt2 + <> "'::timestamp" + <> ", '" + <> iso8601Show lt3 + <> "'::timestamp" + <> ", '" + <> iso8601Show lt4 + <> "'::timestamp" + <> ", '" + <> iso8601Show lt5 + <> "'::timestamp" + <> ", '" + <> iso8601Show lt6 + <> "'::timestamp" + <> ", '" + <> iso8601Show lt7 + <> "'::timestamp" + <> ", '" + <> iso8601Show lt8 + <> "'::timestamp" + <> ", '" + <> iso8601Show lt9 + <> "'::timestamp" + <> ", '" + <> iso8601Show lt10 + <> "'::timestamp" + (res1Val, res2Val) <- liftIO $ withRollback conn $ do -- Doesn't seem like the timezone matters, but we set to -- UTC because this is a textual representation, and the @@ -701,42 +821,16 @@ localTimeTextDecoding conn = hedgehog $ do -- are the inverse of each other but produce bogus values -- nonetheless. execute conn "SET LOCAL timezone = 'UTC'" - queryWith - rowDecoder - conn - ( fromString $ - "SELECT '" - <> iso8601Show lt1 - <> "'::timestamp" - <> ", '" - <> iso8601Show lt2 - <> "'::timestamp" - <> ", '" - <> iso8601Show lt3 - <> "'::timestamp" - <> ", '" - <> iso8601Show lt4 - <> "'::timestamp" - <> ", '" - <> iso8601Show lt5 - <> "'::timestamp" - <> ", '" - <> iso8601Show lt6 - <> "'::timestamp" - <> ", '" - <> iso8601Show lt7 - <> "'::timestamp" - <> ", '" - <> iso8601Show lt8 - <> "'::timestamp" - <> ", '" - <> iso8601Show lt9 - <> "'::timestamp" - <> ", '" - <> iso8601Show lt10 - <> "'::timestamp" - ) - res === [row] + (res1, res2) <- + runPipeline conn $ + (,) + <$> pipeline1With rowDecoder qry + -- Specialized row parsers of each type are a different implementation from + -- the simpler fieldDecoders, so we need to test both + <*> pipeline1With ((,,,,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder) qry + (,) <$> res1 <*> res2 + res1Val === row + res2Val === row fieldDecoderSemigroup :: HPgConnection -> IO () fieldDecoderSemigroup conn = do From e07e93eaccc331cdebe7f7b3bb0f783e2cde21ad Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Fri, 14 Aug 2026 14:22:37 -0300 Subject: [PATCH 18/35] Tidy up GHC Core --- hpgsql-benchmarks/src/Main.hs | 2 +- hpgsql-tests/RowDecoderGhcCore.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/hpgsql-benchmarks/src/Main.hs b/hpgsql-benchmarks/src/Main.hs index 58420e4..b206ed1 100644 --- a/hpgsql-benchmarks/src/Main.hs +++ b/hpgsql-benchmarks/src/Main.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -ddump-simpl -ddump-to-file #-} +{-# OPTIONS_GHC -ddump-simpl -dno-typeable-binds -dsuppress-coercions -dsuppress-module-prefixes -dsuppress-type-applications -ddump-to-file #-} module Main where diff --git a/hpgsql-tests/RowDecoderGhcCore.hs b/hpgsql-tests/RowDecoderGhcCore.hs index 0e1fab9..244ec4d 100644 --- a/hpgsql-tests/RowDecoderGhcCore.hs +++ b/hpgsql-tests/RowDecoderGhcCore.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -ddump-simpl -ddump-to-file #-} +{-# OPTIONS_GHC -ddump-simpl -dno-typeable-binds -dsuppress-coercions -dsuppress-module-prefixes -dsuppress-type-applications -ddump-to-file #-} -- | -- This is not a real test module. It's just a type deriving `FromPgRow` From 3a44fb6cff8bfcfdd268b58a3c68b43a81c43fe6 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 15 Aug 2026 09:52:40 -0300 Subject: [PATCH 19/35] Overlapping Maybe instances do help with the inlined row decoder's performance --- hpgsql-benchmarks/src/Main.hs | 4 +- hpgsql/src/Hpgsql/Encoding.hs | 211 ++++++++++++++++++++-------------- 2 files changed, 129 insertions(+), 86 deletions(-) diff --git a/hpgsql-benchmarks/src/Main.hs b/hpgsql-benchmarks/src/Main.hs index b206ed1..25672a8 100644 --- a/hpgsql-benchmarks/src/Main.hs +++ b/hpgsql-benchmarks/src/Main.hs @@ -86,8 +86,8 @@ data BenchRow = BenchRow brMaybeDay :: !(Maybe Day), brNumeric :: !Scientific, brFloat :: !Float, - brBool1 :: Bool, - brBool2 :: Bool + brBool1 :: !Bool, + brBool2 :: !Bool } deriving stock (Generic, Show, Eq) deriving anyclass (NFData, Hpgsql.FromPgRow, PGSimple.FromRow) diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index 276b473..7f32c19 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -800,17 +800,17 @@ instance FromPgField () where } {-# INLINE intRowDecoder #-} -intRowDecoder :: RowDecoder Int +intRowDecoder :: RowDecoder (Maybe Int) intRowDecoder = inlinableRowDecoder haskellIntOids $ do fieldLen <- Parser.takeInt32BE -- TODO: We're assuming `Int` is always 64 bits, so 64bit CPUs? Is that ok? -- TODO: Is there a way to optimistically assume <=4 bytes and use our custom new parser? case fieldLen of - 4 -> fromIntegral <$> Parser.takeInt32BE - (-1) -> fail "Cannot decode SQL null as the Haskell Int type. Use a `Maybe Int`" - 8 -> fromIntegral <$> Parser.takeInt64BE - 2 -> fromIntegral <$> Parser.takeInt16BE + 4 -> Just . fromIntegral <$> Parser.takeInt32BE + (-1) -> pure Nothing + 8 -> Just . fromIntegral <$> Parser.takeInt64BE + 2 -> Just . fromIntegral <$> Parser.takeInt16BE _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" instance FromPgField Int where @@ -824,32 +824,28 @@ instance FromPgField Int where allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid } {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = intRowDecoder + singleFieldRowDecoder = inlinedSingleFieldRowDecoder + {-# INLINE inlinedSingleFieldRowDecoder #-} + inlinedSingleFieldRowDecoder = nonNullableRowDec "Int" intRowDecoder + +instance {-# OVERLAPPING #-} FromPgField (Maybe Int) where + -- This overlapping instance isn't pretty, but it reduces memory + -- usage and improves performance a bit + fieldDecoder = error "TODO Maybe Int" + + -- FieldDecoder + -- { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> + -- let !decode = binaryIntDecoder oid + -- in \case + -- Just bs -> Just <$> decode bs + -- Nothing -> Right Nothing, + -- allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid + -- } + {-# NOINLINE singleFieldRowDecoder #-} + singleFieldRowDecoder = inlinedSingleFieldRowDecoder {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = intRowDecoder --- The instance below makes our Records benchmark faster and use less --- memory, but makes our Tuples benchmark slower. Worth investigating. --- instance {-# OVERLAPPING #-} FromPgField (Maybe Int) where --- fieldDecoder = error "NOOO" - --- -- FieldDecoder --- -- { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> --- -- let !decode = binaryIntDecoder oid --- -- in \case --- -- Just bs -> Just <$> decode bs --- -- Nothing -> Right Nothing, --- -- allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid --- -- } --- singleFieldRowDecoder = --- RowDecoder --- { fullRowDecoder = const binaryIntSpecializedRowDecoder, --- rowColumnsTypeCheck = \case --- [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid `elem` haskellIntOids)] --- _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", --- numExpectedColumns = 1 --- } - instance FromPgField Int16 where fieldDecoder = FieldDecoder @@ -942,35 +938,38 @@ instance FromPgField Oid where } {-# INLINE floatRowDecoder #-} -floatRowDecoder :: RowDecoder Float +floatRowDecoder :: RowDecoder (Maybe Float) floatRowDecoder = - let fromNullable = \case - Nothing -> fail "Cannot decode SQL null as the Haskell Float type. Use a `Maybe Float`" - Just i -> pure i - in inlinableRowDecoder [float4Oid] $ Parser.takeFloatBEWithFieldLength >>= fromNullable + inlinableRowDecoder [float4Oid] Parser.takeFloatBEWithFieldLength instance FromPgField Float where fieldDecoder = parsePgType [float4Oid] $ \case Just bs -> Right $ binaryFloat4Decoder bs Nothing -> Left "Cannot decode SQL null as the Haskell Float type. Use a `Maybe Float`" {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = floatRowDecoder + singleFieldRowDecoder = inlinedSingleFieldRowDecoder + {-# INLINE inlinedSingleFieldRowDecoder #-} + inlinedSingleFieldRowDecoder = nonNullableRowDec "Float" floatRowDecoder + +instance {-# OVERLAPPING #-} FromPgField (Maybe Float) where + -- This overlapping instance isn't pretty, but it reduces memory + -- usage and improves performance a bit + fieldDecoder = error "TODO Maybe Float" + {-# NOINLINE singleFieldRowDecoder #-} + singleFieldRowDecoder = inlinedSingleFieldRowDecoder {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = floatRowDecoder {-# INLINE doubleRowDecoder #-} -doubleRowDecoder :: RowDecoder Double +doubleRowDecoder :: RowDecoder (Maybe Double) doubleRowDecoder = - let fromNullable = \case - Nothing -> fail "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`" - Just i -> pure i - float4OrDouble8Decoder = do + let float4OrDouble8Decoder = do len <- Parser.takeInt32BE case len of 8 -> Just <$> Parser.takeDoubleBE 4 -> Just . float2Double <$> Parser.takeFloatBE - _ -> fail "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`" - in inlinableRowDecoder [float8Oid, float4Oid] $ float4OrDouble8Decoder >>= fromNullable + _ -> pure Nothing + in inlinableRowDecoder [float8Oid, float4Oid] float4OrDouble8Decoder instance FromPgField Double where fieldDecoder = @@ -985,7 +984,16 @@ instance FromPgField Double where allowedPgTypes = (`elem` [float8Oid, float4Oid]) . fieldTypeOid } {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = doubleRowDecoder + singleFieldRowDecoder = inlinedSingleFieldRowDecoder + {-# INLINE inlinedSingleFieldRowDecoder #-} + inlinedSingleFieldRowDecoder = nonNullableRowDec "Double" doubleRowDecoder + +instance {-# OVERLAPPING #-} FromPgField (Maybe Double) where + -- This overlapping instance isn't pretty, but it reduces memory + -- usage and improves performance a bit + fieldDecoder = error "TODO Maybe Double" + {-# NOINLINE singleFieldRowDecoder #-} + singleFieldRowDecoder = inlinedSingleFieldRowDecoder {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = doubleRowDecoder @@ -1082,19 +1090,25 @@ binaryTrue :: ByteString binaryTrue = BinSer.encodePgBoolean True {-# INLINE boolRowDecoder #-} -boolRowDecoder :: RowDecoder Bool +boolRowDecoder :: RowDecoder (Maybe Bool) boolRowDecoder = - let word8ToBool = \case - Nothing -> fail "Cannot decode SQL null as the Haskell Bool type. Use a `Maybe Bool`" - Just w8 -> pure $ w8 == 1 - in inlinableRowDecoder [boolOid] $ Parser.parsePgFieldWithAtMost4Bytes BinSer.TypeSize1 >>= word8ToBool + inlinableRowDecoder [boolOid] $ fmap (== 1) <$> Parser.parsePgFieldWithAtMost4Bytes BinSer.TypeSize1 instance FromPgField Bool where fieldDecoder = parsePgType [boolOid] $ \case Just bs -> Right $ bs == binaryTrue Nothing -> Left "Cannot decode SQL null as the Haskell Bool type. Use a `Maybe Bool`" {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = boolRowDecoder + singleFieldRowDecoder = inlinedSingleFieldRowDecoder + {-# INLINE inlinedSingleFieldRowDecoder #-} + inlinedSingleFieldRowDecoder = nonNullableRowDec "Bool" boolRowDecoder + +instance {-# OVERLAPPING #-} FromPgField (Maybe Bool) where + -- This overlapping instance isn't pretty, but it reduces memory + -- usage and improves performance a bit + fieldDecoder = error "TODO Maybe Bool" + {-# NOINLINE singleFieldRowDecoder #-} + singleFieldRowDecoder = inlinedSingleFieldRowDecoder {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = boolRowDecoder @@ -1129,18 +1143,14 @@ instance FromPgField LBS.ByteString where Nothing -> Left "Cannot decode SQL null as the Haskell ByteString type. Use a `Maybe ByteString`" {-# INLINE textDecoder #-} -textDecoder :: RowDecoder Text +textDecoder :: RowDecoder (Maybe Text) textDecoder = - let fromNullable = \case - Nothing -> fail "Cannot decode SQL null as the Haskell Text type. Use a `Maybe Text`" - Just i -> pure i - rp = do - len <- Parser.takeInt32BE - if len >= 0 - -- TODO: Use some faster unsafeDecodeUtf8 function? - then Just . decodeUtf8 <$> Parser.take (fromIntegral len) - else pure Nothing - in inlinableRowDecoder [textOid, varcharOid, nameOid] $ rp >>= fromNullable + inlinableRowDecoder [textOid, varcharOid, nameOid] $ do + len <- Parser.takeInt32BE + if len >= 0 + -- TODO: Use some faster unsafeDecodeUtf8 function? + then Just . decodeUtf8 <$> Parser.take (fromIntegral len) + else pure Nothing instance FromPgField Text where fieldDecoder = parsePgType [textOid, varcharOid, nameOid] $ \case @@ -1148,7 +1158,16 @@ instance FromPgField Text where -- TODO: Use some faster unsafeDecodeUtf8 function? Nothing -> Left "Cannot decode SQL null as the Haskell Text type. Use a `Maybe Text`" {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = textDecoder + singleFieldRowDecoder = inlinedSingleFieldRowDecoder + {-# INLINE inlinedSingleFieldRowDecoder #-} + inlinedSingleFieldRowDecoder = nonNullableRowDec "Text" textDecoder + +instance {-# OVERLAPPING #-} FromPgField (Maybe Text) where + -- This overlapping instance isn't pretty, but it reduces memory + -- usage and improves performance a bit + fieldDecoder = error "TODO Maybe Text" + {-# NOINLINE singleFieldRowDecoder #-} + singleFieldRowDecoder = inlinedSingleFieldRowDecoder {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = textDecoder @@ -1181,21 +1200,17 @@ instance FromPgField (CI String) where fieldDecoder = typeFieldDecoder (typeMustBeNamed "citext") $ CI.mk <$> fieldDecoder {-# INLINE utcTimeRowDecoder #-} -utcTimeRowDecoder :: RowDecoder UTCTime +utcTimeRowDecoder :: RowDecoder (Maybe UTCTime) utcTimeRowDecoder = - let fromNullable = \case - Nothing -> fail "Cannot decode SQL null as the Haskell UTCTime type. Use a `Maybe UTCTime`" - Just i -> pure i - utcTimeDecoder = do - len <- Parser.takeInt32BE - case len of - 8 -> do - totalusecs <- Parser.takeInt64BE - let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day - parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - pure $ Just $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - _ -> pure Nothing - in inlinableRowDecoder [timestamptzOid] $ utcTimeDecoder >>= fromNullable + inlinableRowDecoder [timestamptzOid] $ do + len <- Parser.takeInt32BE + case len of + 8 -> do + totalusecs <- Parser.takeInt64BE + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + pure $ Just $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + _ -> pure Nothing instance FromPgField UTCTime where fieldDecoder = parsePgType [timestamptzOid] $ \case @@ -1207,12 +1222,18 @@ instance FromPgField UTCTime where Right $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) Nothing -> Left "Cannot decode SQL null as the Haskell UTCTime type. Use a `Maybe UTCTime`" {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = utcTimeRowDecoder + singleFieldRowDecoder = inlinedSingleFieldRowDecoder {-# NOINLINE inlinedSingleFieldRowDecoder #-} - inlinedSingleFieldRowDecoder = utcTimeRowDecoder + inlinedSingleFieldRowDecoder = nonNullableRowDec "UTCTime" utcTimeRowDecoder --- {-# INLINE inlinedSingleFieldRowDecoder #-} --- inlinedSingleFieldRowDecoder = doubleRowDecoder +instance {-# OVERLAPPING #-} FromPgField (Maybe UTCTime) where + -- This overlapping instance isn't pretty, but it reduces memory + -- usage and improves performance a bit + fieldDecoder = error "TODO Maybe UTCTime" + {-# NOINLINE singleFieldRowDecoder #-} + singleFieldRowDecoder = inlinedSingleFieldRowDecoder + {-# INLINE inlinedSingleFieldRowDecoder #-} + inlinedSingleFieldRowDecoder = utcTimeRowDecoder instance FromPgField (Unbounded UTCTime) where fieldDecoder = parsePgType [timestamptzOid] $ \case @@ -1275,12 +1296,10 @@ instance FromPgField TimeOfDay where Nothing -> Left "Cannot decode SQL null as the Haskell TimeOfDay type. Use a `Maybe TimeOfDay`" {-# INLINE dayRowDecoder #-} -dayRowDecoder :: RowDecoder Day +dayRowDecoder :: RowDecoder (Maybe Day) dayRowDecoder = - let int32ToDay = \case - Nothing -> fail "Cannot decode SQL null as the Haskell Day type. Use a `Maybe Day`" - Just i32 -> let jd = fromIntegral i32 :: Integer in pure $ addJulianDurationClip (CalendarDiffDays 0 (jd - 13)) $ fromJulian 2000 01 01 - in inlinableRowDecoder [dateOid] $ Parser.takeInt32BEWithFieldLength >>= int32ToDay + let int32ToDay (i32 :: Int32) = let jd = fromIntegral i32 :: Integer in addJulianDurationClip (CalendarDiffDays 0 (jd - 13)) $ fromJulian 2000 01 01 + in inlinableRowDecoder [dateOid] $ fmap int32ToDay <$> Parser.takeInt32BEWithFieldLength instance FromPgField Day where fieldDecoder = parsePgType [dateOid] $ \case @@ -1292,7 +1311,16 @@ instance FromPgField Day where Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 Nothing -> Left "Cannot decode SQL null as the Haskell Day type. Use a `Maybe Day`" {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = dayRowDecoder + singleFieldRowDecoder = inlinedSingleFieldRowDecoder + {-# INLINE inlinedSingleFieldRowDecoder #-} + inlinedSingleFieldRowDecoder = nonNullableRowDec "Day" dayRowDecoder + +instance {-# OVERLAPPING #-} FromPgField (Maybe Day) where + -- This overlapping instance isn't pretty, but it reduces memory + -- usage and improves performance a bit + fieldDecoder = error "TODO Maybe Day" + {-# NOINLINE singleFieldRowDecoder #-} + singleFieldRowDecoder = inlinedSingleFieldRowDecoder {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = dayRowDecoder @@ -1357,9 +1385,24 @@ nullableField FieldDecoder {..} = allowedPgTypes } +{-# INLINE nonNullableRowDec #-} +nonNullableRowDec :: String -> RowDecoder (Maybe a) -> RowDecoder a +nonNullableRowDec haskellTypeName rdec = + let fromNullable mVal = case mVal of + Nothing -> fail $ "Cannot decode SQL null as the Haskell " ++ haskellTypeName ++ " type. Use a `" ++ haskellTypeName ++ "` if you want SQL nulls" + Just v -> pure v + in RowDecoder + { fullRowDecoder = \finfos -> rdec.fullRowDecoder finfos >>= fromNullable, + rowColumnsTypeCheck = rdec.rowColumnsTypeCheck, + numExpectedColumns = rdec.numExpectedColumns + } + instance (FromPgField a) => FromPgField (Maybe a) where fieldDecoder = nullableField fieldDecoder +-- TODO specialized row decoders! But can we? +-- singleFieldRowDecoder = nullableRow inlinedSingleFieldRowDecoder + allowOnlyArrayTypes :: FieldInfo -> Bool allowOnlyArrayTypes fieldInfo = -- TODO: We could check the elemTypeOid too, but maybe later From 84b7265caad9183dfcc19328f229b1960889d7e6 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sun, 16 Aug 2026 10:10:10 -0300 Subject: [PATCH 20/35] Very experimental change with `Maybe a` instances --- Runfile | 2 +- hpgsql/src/Hpgsql/Encoding.hs | 286 +++++++++++++----------------- hpgsql/src/Hpgsql/Internal.hs | 2 +- hpgsql/src/Hpgsql/SimpleParser.hs | 16 +- hpgsql/src/Hpgsql/Types.hs | 28 ++- 5 files changed, 146 insertions(+), 188 deletions(-) diff --git a/Runfile b/Runfile index 406b180..1b85191 100644 --- a/Runfile +++ b/Runfile @@ -73,7 +73,7 @@ tests: if [ -n "$NIX" ]; then nix-build --no-out-link -A "testsPg${pg}" --argstr hspecArgs "$TARGS" else - cabal build hpgsql-tests hpgsql-simple-compat-tests + cabal build hpgsql-tests nix-shell -A "shellPg${pg}" ./default.nix --run "./scripts/run-tests-db-internal.sh $TARGS" fi done diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index 7f32c19..5d25248 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -121,7 +121,7 @@ data FieldInfo = FieldInfo -- | A decoder for a single field/column. data FieldDecoder a = FieldDecoder - { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String a, + { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String (Maybe a), allowedPgTypes :: FieldInfo -> Bool } deriving stock (Functor) @@ -157,7 +157,7 @@ instance Applicative RowDecoder where instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in Hpgsql because Hpgsql type-checks the result types of queries before having access to even the first data row. Use the Applicative class to write your instances or use the Monadic decoding variants.")) => Monad RowDecoder where (>>=) = error "inaccessible bind in Monad RowDecoder instance" -{-# INLINE singleField #-} -- 1.2% wall time perf. gain with this +{-# INLINE singleField #-} singleField :: FieldDecoder a -> RowDecoder a singleField (FieldDecoder {..}) = RowDecoder @@ -172,7 +172,8 @@ singleField (FieldDecoder {..}) = Just <$> Parser.take lenNextCol else pure Nothing case decode nextColBs of - Right v -> pure v + Right Nothing -> fail "Got SQL NULL but no nulls accepted" -- TODO: Please improve the failure message.. show field name and target Haskell type if we can + Right (Just v) -> pure v Left err -> fail err _ -> error "singleField expected a single column OID but got 0 or >1", rowColumnsTypeCheck = \case @@ -244,9 +245,9 @@ compositeTypeDecoder :: forall a. RowDecoder a -> FieldDecoder a compositeTypeDecoder (RowDecoder {..}) = FieldDecoder { fieldValueDecoder = \compositeTypeOid -> \case - Nothing -> Left "Got NULL in composite type but it was not allowed" - Just bs -> case Parser.parseOnly (parserForRecord compositeTypeOid.encodingContext <* Parser.endOfInput) bs of - Parser.ParseOk v -> Right v + Nothing -> Right Nothing -- Left "Got NULL in composite type but it was not allowed" + Just bs -> case Parser.parseOnly (parserForRecord compositeTypeOid.encodingContext <* Parser.endOfInput "compositeTypeDecoder") bs of + Parser.ParseOk v -> Right (Just v) Parser.ParseFail err -> Left err, allowedPgTypes = const True -- There's no way to enforce a custom type's OID. We only check if it's structurally the same in the parser (same subtypes in same order) } @@ -265,7 +266,7 @@ compositeTypeDecoder (RowDecoder {..}) = pure (oid, sizeBs <> bs) let typecheckedCols = rowColumnsTypeCheck (map (mkColInfo . fst) cols) unless (all snd typecheckedCols) $ fail $ "Parser for composite found type OIDs " ++ show (map fst cols) ++ " but expected different" - case Parser.parseOnly (fullRowDecoder (map (mkColInfo . fst) cols) <* Parser.endOfInput) (mconcat $ map snd cols) of + case Parser.parseOnly (fullRowDecoder (map (mkColInfo . fst) cols) <* Parser.endOfInput "parserForRecord") (mconcat $ map snd cols) of Parser.ParseOk v -> pure v Parser.ParseFail err -> error $ "Error decoding composite type: " ++ show err @@ -782,7 +783,7 @@ binaryFloat4Decoder = castWord32ToFloat . either error id . BinSer.decodeWord32B binaryFloat8Decoder :: ByteString -> Double binaryFloat8Decoder = castWord64ToDouble . either error id . BinSer.decodeWord64BE 0 -parsePgType :: [Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a +parsePgType :: [Oid] -> (Maybe ByteString -> Either String (Maybe a)) -> FieldDecoder a parsePgType !requiredTypeOids !fieldValueDecoder = FieldDecoder { fieldValueDecoder = \_oid -> fieldValueDecoder, @@ -793,9 +794,9 @@ instance FromPgField () where fieldDecoder = FieldDecoder { fieldValueDecoder = \_oid -> \case - Just "" -> Right () + Just "" -> Right (Just ()) Just bs -> Left $ "Invalid value '" ++ show bs ++ "' for postgres void type" - Nothing -> Left "Cannot decode SQL null as the Haskell () type. Use a `Maybe ()`", + Nothing -> pure Nothing, -- Left "Cannot decode SQL null as the Haskell () type. Use a `Maybe ()`", allowedPgTypes = (== voidOid) . fieldTypeOid } @@ -819,8 +820,8 @@ instance FromPgField Int where { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> let !decode = binaryIntDecoder oid in \case - Just bs -> decode bs - Nothing -> Left "Cannot decode SQL null as the Haskell Int type. Use a `Maybe Int`", + Just bs -> Just <$> decode bs + Nothing -> pure Nothing, -- Left "Cannot decode SQL null as the Haskell Int type. Use a `Maybe Int`", allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid } {-# NOINLINE singleFieldRowDecoder #-} @@ -828,32 +829,14 @@ instance FromPgField Int where {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = nonNullableRowDec "Int" intRowDecoder -instance {-# OVERLAPPING #-} FromPgField (Maybe Int) where - -- This overlapping instance isn't pretty, but it reduces memory - -- usage and improves performance a bit - fieldDecoder = error "TODO Maybe Int" - - -- FieldDecoder - -- { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> - -- let !decode = binaryIntDecoder oid - -- in \case - -- Just bs -> Just <$> decode bs - -- Nothing -> Right Nothing, - -- allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid - -- } - {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = inlinedSingleFieldRowDecoder - {-# INLINE inlinedSingleFieldRowDecoder #-} - inlinedSingleFieldRowDecoder = intRowDecoder - instance FromPgField Int16 where fieldDecoder = FieldDecoder { fieldValueDecoder = let !decode = binaryIntDecoder int2Oid in const $ \case - Just bs -> decode bs - Nothing -> Left "Cannot decode SQL null as the Haskell Int16 type. Use a `Maybe Int16`", + Just bs -> Just <$> decode bs + Nothing -> Right Nothing, -- Left "Cannot decode SQL null as the Haskell Int16 type. Use a `Maybe Int16`", allowedPgTypes = (== int2Oid) . fieldTypeOid } @@ -874,8 +857,8 @@ instance FromPgField Int32 where { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> let !decode = binaryIntDecoder oid in \case - Just bs -> decode bs - Nothing -> Left "Cannot decode SQL null as the Haskell Int32 type. Use a `Maybe Int32`", + Just bs -> Just <$> decode bs + Nothing -> Right Nothing, -- Left "Cannot decode SQL null as the Haskell Int32 type. Use a `Maybe Int32`", allowedPgTypes = (`elem` [int2Oid, int4Oid]) . fieldTypeOid } {-# NOINLINE singleFieldRowDecoder #-} @@ -901,8 +884,8 @@ instance FromPgField Int64 where { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> let !decode = binaryIntDecoder oid in \case - Just bs -> decode bs - Nothing -> Left "Cannot decode SQL null as the Haskell Int64 type. Use a `Maybe Int64`", + Just bs -> Just <$> decode bs + Nothing -> pure Nothing, -- Left "Cannot decode SQL null as the Haskell Int64 type. Use a `Maybe Int64`", allowedPgTypes = (`elem` [int2Oid, int4Oid, int8Oid]) . fieldTypeOid } {-# NOINLINE singleFieldRowDecoder #-} @@ -917,13 +900,13 @@ instance FromPgField Integer where let !decodeInt = binaryIntDecoder @Int64 oid in \case Just bs - | oid /= numericOid -> fromIntegral <$> decodeInt bs - | otherwise -> case Parser.parseOnly (scientificDecoder True <* Parser.endOfInput) bs of + | oid /= numericOid -> Just . fromIntegral <$> decodeInt bs + | otherwise -> case Parser.parseOnly (scientificDecoder True <* Parser.endOfInput "Integer") bs of Parser.ParseOk sci -> case floatingOrInteger @Double @Integer sci of - Right i -> Right i + Right i -> Right (Just i) Left _ -> Left "Internal error in Hpgsql. Scientific to Integer conversion failed" Parser.ParseFail err -> Left err - Nothing -> Left "Cannot decode SQL null as the Haskell Integer type. Use a `Maybe Integer`", + Nothing -> Right Nothing, -- Left "Cannot decode SQL null as the Haskell Integer type. Use a `Maybe Integer`", allowedPgTypes = (`elem` [int8Oid, numericOid, int4Oid, int2Oid]) . fieldTypeOid } @@ -932,8 +915,8 @@ instance FromPgField Oid where FieldDecoder { fieldValueDecoder = \_ -> \case -- Oids are just int4 - Just bs -> Oid <$> binaryIntDecoder int4Oid bs - Nothing -> Left "Cannot decode SQL null as the Haskell Oid type. Use a `Maybe Oid`", + Just bs -> Just . Oid <$> binaryIntDecoder int4Oid bs + Nothing -> pure Nothing, -- Left "Cannot decode SQL null as the Haskell Oid type. Use a `Maybe Oid`", allowedPgTypes = (== oidOid) . fieldTypeOid } @@ -944,22 +927,13 @@ floatRowDecoder = instance FromPgField Float where fieldDecoder = parsePgType [float4Oid] $ \case - Just bs -> Right $ binaryFloat4Decoder bs - Nothing -> Left "Cannot decode SQL null as the Haskell Float type. Use a `Maybe Float`" + Just bs -> Right $ Just $ binaryFloat4Decoder bs + Nothing -> pure Nothing -- Left "Cannot decode SQL null as the Haskell Float type. Use a `Maybe Float`" {-# NOINLINE singleFieldRowDecoder #-} singleFieldRowDecoder = inlinedSingleFieldRowDecoder {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = nonNullableRowDec "Float" floatRowDecoder -instance {-# OVERLAPPING #-} FromPgField (Maybe Float) where - -- This overlapping instance isn't pretty, but it reduces memory - -- usage and improves performance a bit - fieldDecoder = error "TODO Maybe Float" - {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = inlinedSingleFieldRowDecoder - {-# INLINE inlinedSingleFieldRowDecoder #-} - inlinedSingleFieldRowDecoder = floatRowDecoder - {-# INLINE doubleRowDecoder #-} doubleRowDecoder :: RowDecoder (Maybe Double) doubleRowDecoder = @@ -979,8 +953,8 @@ instance FromPgField Double where | oid == float8Oid = binaryFloat8Decoder | otherwise = float2Double . binaryFloat4Decoder in \case - Just bs -> Right $ decoder bs - Nothing -> Left "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`", + Just bs -> Right $ Just $ decoder bs + Nothing -> pure Nothing, -- Left "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`", allowedPgTypes = (`elem` [float8Oid, float4Oid]) . fieldTypeOid } {-# NOINLINE singleFieldRowDecoder #-} @@ -988,15 +962,6 @@ instance FromPgField Double where {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = nonNullableRowDec "Double" doubleRowDecoder -instance {-# OVERLAPPING #-} FromPgField (Maybe Double) where - -- This overlapping instance isn't pretty, but it reduces memory - -- usage and improves performance a bit - fieldDecoder = error "TODO Maybe Double" - {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = inlinedSingleFieldRowDecoder - {-# INLINE inlinedSingleFieldRowDecoder #-} - inlinedSingleFieldRowDecoder = doubleRowDecoder - -- | Allows you to specify a type (and other checks, possibly) for a `FieldDecoder`. -- This can be useful to ensure you're not accidentally decoding a different type. -- @@ -1055,16 +1020,16 @@ instance FromPgField Scientific where then let intdec = binaryIntDecoder @Int64 fieldTypeOid in \case - Just bs -> flip scientific 0 . fromIntegral <$> intdec bs - Nothing -> Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`" + Just bs -> Just . flip scientific 0 . fromIntegral <$> intdec bs + Nothing -> pure Nothing -- Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`" else \case Just bs -> -- TODO: There is loss converting from Float/Double to Scientific, but it might be quite small, so should we accept -- float4Oid and float8Oid here? - case Parser.parseOnly (scientificDecoder False <* Parser.endOfInput) bs of - Parser.ParseOk sci -> Right sci + case Parser.parseOnly (scientificDecoder False <* Parser.endOfInput "Scientific") bs of + Parser.ParseOk sci -> Right (Just sci) Parser.ParseFail err -> Left err - Nothing -> Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`", + Nothing -> pure Nothing, -- Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`", allowedPgTypes = (`elem` [numericOid, int2Oid, int4Oid, int8Oid]) . fieldTypeOid } {-# NOINLINE singleFieldRowDecoder #-} @@ -1096,22 +1061,13 @@ boolRowDecoder = instance FromPgField Bool where fieldDecoder = parsePgType [boolOid] $ \case - Just bs -> Right $ bs == binaryTrue - Nothing -> Left "Cannot decode SQL null as the Haskell Bool type. Use a `Maybe Bool`" + Just bs -> Right $ Just $ bs == binaryTrue + Nothing -> Right Nothing -- Left "Cannot decode SQL null as the Haskell Bool type. Use a `Maybe Bool`" {-# NOINLINE singleFieldRowDecoder #-} singleFieldRowDecoder = inlinedSingleFieldRowDecoder {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = nonNullableRowDec "Bool" boolRowDecoder -instance {-# OVERLAPPING #-} FromPgField (Maybe Bool) where - -- This overlapping instance isn't pretty, but it reduces memory - -- usage and improves performance a bit - fieldDecoder = error "TODO Maybe Bool" - {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = inlinedSingleFieldRowDecoder - {-# INLINE inlinedSingleFieldRowDecoder #-} - inlinedSingleFieldRowDecoder = boolRowDecoder - instance FromPgField Char where fieldDecoder = let textParser = fieldValueDecoder (fieldDecoder @Text) @@ -1123,24 +1079,21 @@ instance FromPgField Char where if oid == charOid -- TODO: Postgres has values of type "char" in the pg_type.typcategory table. -- We should test this instance works with those, and we haven't yet. - then Right $ BSC.head bs + then Right $ Just $ BSC.head bs else case decodeText mbs of Left err -> Left err - Right t -> if Text.length t > 1 then Left "Cannot parse text with more than one character into a Haskell Char type." else Right (Text.head t) - Nothing -> Left "Cannot decode SQL null as the Haskell Char type. Use a `Maybe Char`", - -- TODO: All the varchar types? + Right (Just t) -> if Text.length t > 1 then Left "Cannot parse text with more than one character into a Haskell Char type." else Right (Just $ Text.head t) + Right Nothing -> Right Nothing + Nothing -> Right Nothing, -- Left "Cannot decode SQL null as the Haskell Char type. Use a `Maybe Char`", + -- TODO: All the varchar types? allowedPgTypes = (`elem` [charOid, textOid]) . fieldTypeOid } instance FromPgField ByteString where - fieldDecoder = parsePgType [byteaOid] $ \case - Just bs -> Right bs - Nothing -> Left "Cannot decode SQL null as the Haskell ByteString type. Use a `Maybe ByteString`" + fieldDecoder = parsePgType [byteaOid] Right instance FromPgField LBS.ByteString where - fieldDecoder = parsePgType [byteaOid] $ \case - Just bs -> Right $ LBS.fromStrict bs - Nothing -> Left "Cannot decode SQL null as the Haskell ByteString type. Use a `Maybe ByteString`" + fieldDecoder = parsePgType [byteaOid] $ Right . fmap LBS.fromStrict {-# INLINE textDecoder #-} textDecoder :: RowDecoder (Maybe Text) @@ -1154,35 +1107,26 @@ textDecoder = instance FromPgField Text where fieldDecoder = parsePgType [textOid, varcharOid, nameOid] $ \case - Just bs -> Right $ decodeUtf8 bs + Just bs -> Right $ Just $ decodeUtf8 bs -- TODO: Use some faster unsafeDecodeUtf8 function? - Nothing -> Left "Cannot decode SQL null as the Haskell Text type. Use a `Maybe Text`" + Nothing -> Right Nothing -- Left "Cannot decode SQL null as the Haskell Text type. Use a `Maybe Text`" {-# NOINLINE singleFieldRowDecoder #-} singleFieldRowDecoder = inlinedSingleFieldRowDecoder {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = nonNullableRowDec "Text" textDecoder -instance {-# OVERLAPPING #-} FromPgField (Maybe Text) where - -- This overlapping instance isn't pretty, but it reduces memory - -- usage and improves performance a bit - fieldDecoder = error "TODO Maybe Text" - {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = inlinedSingleFieldRowDecoder - {-# INLINE inlinedSingleFieldRowDecoder #-} - inlinedSingleFieldRowDecoder = textDecoder - instance FromPgField LT.Text where fieldDecoder = parsePgType [textOid, varcharOid, nameOid] $ \case - Just bs -> Right $ LT.fromStrict $ decodeUtf8 bs + Just bs -> Right $ Just $ LT.fromStrict $ decodeUtf8 bs -- TODO: Use some faster unsafeDecodeUtf8 function? - Nothing -> Left "Cannot decode SQL null as the Haskell Text type. Use a `Maybe Text`" + Nothing -> Right Nothing -- Left "Cannot decode SQL null as the Haskell Text type. Use a `Maybe Text`" instance FromPgField String where fieldDecoder = parsePgType [textOid, varcharOid, nameOid] $ \case -- connection option). - Just bs -> Right $ Text.unpack $ decodeUtf8 bs + Just bs -> Right $ Just $ Text.unpack $ decodeUtf8 bs -- TODO: Use some faster unsafeDecodeUtf8 function? - Nothing -> Left "Cannot decode SQL null as the Haskell String type. Use a `Maybe String`" + Nothing -> Right Nothing -- Left "Cannot decode SQL null as the Haskell String type. Use a `Maybe String`" -- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default -- connection option). @@ -1219,22 +1163,13 @@ instance FromPgField UTCTime where totalusecs <- BinSer.decodeInt64BE 0 bs let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - Right $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - Nothing -> Left "Cannot decode SQL null as the Haskell UTCTime type. Use a `Maybe UTCTime`" + Right $ Just $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + Nothing -> pure Nothing -- Left "Cannot decode SQL null as the Haskell UTCTime type. Use a `Maybe UTCTime`" {-# NOINLINE singleFieldRowDecoder #-} singleFieldRowDecoder = inlinedSingleFieldRowDecoder {-# NOINLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = nonNullableRowDec "UTCTime" utcTimeRowDecoder -instance {-# OVERLAPPING #-} FromPgField (Maybe UTCTime) where - -- This overlapping instance isn't pretty, but it reduces memory - -- usage and improves performance a bit - fieldDecoder = error "TODO Maybe UTCTime" - {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = inlinedSingleFieldRowDecoder - {-# INLINE inlinedSingleFieldRowDecoder #-} - inlinedSingleFieldRowDecoder = utcTimeRowDecoder - instance FromPgField (Unbounded UTCTime) where fieldDecoder = parsePgType [timestamptzOid] $ \case Just bs -> do @@ -1242,15 +1177,15 @@ instance FromPgField (Unbounded UTCTime) where totalusecs <- BinSer.decodeInt64BE 0 bs Right $ if totalusecs == minBound - then NegInfinity + then Just NegInfinity else if totalusecs == maxBound - then PosInfinity + then Just PosInfinity else let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - in Finite $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - Nothing -> Left "Cannot decode SQL null as the Haskell (Unbounded UTCTime) type. Use a `Maybe (Unbounded UTCTime)`" + in Just $ Finite $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + Nothing -> Right Nothing -- Left "Cannot decode SQL null as the Haskell (Unbounded UTCTime) type. Use a `Maybe (Unbounded UTCTime)`" instance FromPgField ZonedTime where fieldDecoder = parsePgType [timestamptzOid] $ \case @@ -1259,8 +1194,8 @@ instance FromPgField ZonedTime where totalusecs <- BinSer.decodeInt64BE 0 bs let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - Right $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - Nothing -> Left "Cannot decode SQL null as the Haskell ZonedTime type. Use a `Maybe ZonedTime`" + Right $ Just $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + Nothing -> pure Nothing -- Left "Cannot decode SQL null as the Haskell ZonedTime type. Use a `Maybe ZonedTime`" instance FromPgField (Unbounded ZonedTime) where fieldDecoder = parsePgType [timestamptzOid] $ \case @@ -1269,15 +1204,15 @@ instance FromPgField (Unbounded ZonedTime) where totalusecs <- BinSer.decodeInt64BE 0 bs Right $ if totalusecs == minBound - then NegInfinity + then Just NegInfinity else if totalusecs == maxBound - then PosInfinity + then Just PosInfinity else let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - in Finite $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - Nothing -> Left "Cannot decode SQL null as the Haskell ZonedTime type. Use a `Maybe ZonedTime`" + in Just $ Finite $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + Nothing -> pure Nothing -- Left "Cannot decode SQL null as the Haskell ZonedTime type. Use a `Maybe ZonedTime`" instance FromPgField LocalTime where fieldDecoder = parsePgType [timestampOid] $ \case @@ -1285,15 +1220,15 @@ instance FromPgField LocalTime where totalusecs <- BinSer.decodeInt64BE 0 bs let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - Right $ LocalTime parsedDate (timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - Nothing -> Left "Cannot decode SQL null as the Haskell LocalTime type. Use a `Maybe LocalTime`" + Right $ Just $ LocalTime parsedDate (timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + Nothing -> pure Nothing -- Left "Cannot decode SQL null as the Haskell LocalTime type. Use a `Maybe LocalTime`" instance FromPgField TimeOfDay where fieldDecoder = parsePgType [timeOid] $ \case Just bs -> do usecs <- BinSer.decodeInt64BE 0 bs - Right $ timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral usecs * 1_000_000 - Nothing -> Left "Cannot decode SQL null as the Haskell TimeOfDay type. Use a `Maybe TimeOfDay`" + Right $ Just $ timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral usecs * 1_000_000 + Nothing -> Right Nothing -- Left "Cannot decode SQL null as the Haskell TimeOfDay type. Use a `Maybe TimeOfDay`" {-# INLINE dayRowDecoder #-} dayRowDecoder :: RowDecoder (Maybe Day) @@ -1308,22 +1243,13 @@ instance FromPgField Day where -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 -- But I found a simpler way to do this. Let's see if it works in our property based tests jd <- BinSer.decodeInt32BE 0 bs - Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 - Nothing -> Left "Cannot decode SQL null as the Haskell Day type. Use a `Maybe Day`" + Right $ Just $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 + Nothing -> pure Nothing -- Left "Cannot decode SQL null as the Haskell Day type. Use a `Maybe Day`" {-# NOINLINE singleFieldRowDecoder #-} singleFieldRowDecoder = inlinedSingleFieldRowDecoder {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = nonNullableRowDec "Day" dayRowDecoder -instance {-# OVERLAPPING #-} FromPgField (Maybe Day) where - -- This overlapping instance isn't pretty, but it reduces memory - -- usage and improves performance a bit - fieldDecoder = error "TODO Maybe Day" - {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = inlinedSingleFieldRowDecoder - {-# INLINE inlinedSingleFieldRowDecoder #-} - inlinedSingleFieldRowDecoder = dayRowDecoder - instance FromPgField (Unbounded Day) where fieldDecoder = parsePgType [dateOid] $ \case Just bs -> do @@ -1333,13 +1259,13 @@ instance FromPgField (Unbounded Day) where jd <- BinSer.decodeInt32BE 0 bs Right $ if jd == minBound - then NegInfinity + then Just NegInfinity else if jd == maxBound - then PosInfinity + then Just PosInfinity else - Finite $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 - Nothing -> Left "Cannot decode SQL null as the Haskell (Unbounded Day) type. Use a `Maybe (Unbounded Day)`" + Just $ Finite $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 + Nothing -> pure Nothing -- Left "Cannot decode SQL null as the Haskell (Unbounded Day) type. Use a `Maybe (Unbounded Day)`" instance FromPgField CalendarDiffTime where fieldDecoder = parsePgType [intervalOid] $ \case @@ -1347,15 +1273,15 @@ instance FromPgField CalendarDiffTime where nMicrosecs <- BinSer.decodeInt64BE 0 bs nDays <- BinSer.decodeInt32BE 8 bs nMonths <- BinSer.decodeInt32BE 12 bs - Right $ CalendarDiffTime {ctMonths = fromIntegral nMonths, ctTime = secondsToNominalDiffTime (fromIntegral nDays * 86400) + realToFrac (picosecondsToDiffTime (fromIntegral nMicrosecs * 1_000_000))} - Nothing -> Left "Cannot decode SQL null as the Haskell CalendarDiffTime type. Use a `Maybe CalendarDiffTime`" + Right $ Just $ CalendarDiffTime {ctMonths = fromIntegral nMonths, ctTime = secondsToNominalDiffTime (fromIntegral nDays * 86400) + realToFrac (picosecondsToDiffTime (fromIntegral nMicrosecs * 1_000_000))} + Nothing -> pure Nothing -- Left "Cannot decode SQL null as the Haskell CalendarDiffTime type. Use a `Maybe CalendarDiffTime`" instance FromPgField UUID where fieldDecoder = parsePgType [uuidOid] $ \case Just bs -> case UUID.fromByteString (LBS.fromStrict bs) of - Just uuid -> Right uuid + Just uuid -> Right (Just uuid) Nothing -> Left "Bug in Hpgsql: UUID field could not be decoded" - Nothing -> Left "Cannot decode SQL null as the Haskell UUID type. Use a `Maybe UUID`" + Nothing -> Right Nothing -- Left "Cannot decode SQL null as the Haskell UUID type. Use a `Maybe UUID`" instance FromPgField Aeson.Value where fieldDecoder = @@ -1363,12 +1289,14 @@ instance FromPgField Aeson.Value where { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> let -- jsonb has a byte prepended to the contents and json does not + -- TODO: Does `BS.drop 1` get inlined into `Aeson.decodeStrict` further down? + -- Might be an interesting case study !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id in \case - Just bs -> case Aeson.decodeStrict $ fixJsonb bs of - Just d -> Right d + Just bs -> case Aeson.decodeStrict @Aeson.Value $ fixJsonb bs of + Just d -> Right (Just d) Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid." - Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls", + Nothing -> pure Nothing, -- Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } @@ -1380,6 +1308,13 @@ nullableField FieldDecoder {..} = { fieldValueDecoder = \oid -> let !origFieldValueParser = fieldValueDecoder oid in \case + -- TODO: we have multiple layers of Maybe/NULL here. + -- What should we do? If the supplied decoder returns + -- Nothing, do we return `Just Nothing`? Or do we follow + -- SQL's viral NULL semantics? + -- Think about a custom user type that decodes NULL into a Just, + -- and test that with all decoding combinations we provide ( + -- singleField, nullableField, specialized inlined/not-inlined row decoders, etc.) Nothing -> Right Nothing justBs -> Just <$> origFieldValueParser justBs, allowedPgTypes @@ -1397,11 +1332,30 @@ nonNullableRowDec haskellTypeName rdec = numExpectedColumns = rdec.numExpectedColumns } +{-# INLINE nullableRowDec #-} +nullableRowDec :: RowDecoder a -> RowDecoder (Maybe a) +nullableRowDec rdec = + RowDecoder + { fullRowDecoder = \finfos -> do + -- Peek the field length, but only consume it + -- if we get a NULL. Urgh. + fieldLen <- Parser.peekInt32BE + if fieldLen == (-1) + then do + Parser.skip 4 + pure Nothing + else + Just <$> rdec.fullRowDecoder finfos, + rowColumnsTypeCheck = rdec.rowColumnsTypeCheck, + numExpectedColumns = rdec.numExpectedColumns + } + instance (FromPgField a) => FromPgField (Maybe a) where fieldDecoder = nullableField fieldDecoder - --- TODO specialized row decoders! But can we? --- singleFieldRowDecoder = nullableRow inlinedSingleFieldRowDecoder + {-# NOINLINE singleFieldRowDecoder #-} + singleFieldRowDecoder = nullableRowDec inlinedSingleFieldRowDecoder + {-# INLINE inlinedSingleFieldRowDecoder #-} + inlinedSingleFieldRowDecoder = nullableRowDec inlinedSingleFieldRowDecoder allowOnlyArrayTypes :: FieldInfo -> Bool allowOnlyArrayTypes fieldInfo = @@ -1419,11 +1373,11 @@ instance {-# OVERLAPPING #-} forall a. (FromPgField a) => FromPgField (Vector (V fieldDecoder = FieldDecoder { fieldValueDecoder = \colInfo -> - let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput + let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput "Vector (Vector a)" in \case - Nothing -> Left "Cannot decode SQL null as the Haskell (Vector (Vector a)) type. Use a `Maybe (Vector (Vector a))`" + Nothing -> Right Nothing -- Left "Cannot decode SQL null as the Haskell (Vector (Vector a)) type. Use a `Maybe (Vector (Vector a))`" Just bs -> case Parser.parseOnly arrayFieldDecoder bs of - Parser.ParseOk v -> Right v + Parser.ParseOk v -> Right (Just v) Parser.ParseFail err -> Left err, allowedPgTypes = allowOnlyArrayTypes } @@ -1453,7 +1407,8 @@ instance {-# OVERLAPPING #-} forall a. (FromPgField a) => FromPgField (Vector (V elementBs <- if size == (-1) then pure Nothing else Just <$> Parser.take size case elementParser.fieldValueDecoder elementColInfo elementBs of Left err -> fail $ "Error parsing array element: " ++ show err - Right el -> pure el + Right (Just el) -> pure el + Right Nothing -> fail "Found an array element that is NULL" -- TODO: I think this is a bug of ours, because what if a ~ Maybe b? {-# INLINE genericFromPgRow #-} @@ -1585,9 +1540,7 @@ untypedFieldEncoder enc = FieldEncoder {toTypeOid = \_ -> Nothing, toPgField = e rawBytesFieldDecoder :: FieldDecoder ByteString rawBytesFieldDecoder = FieldDecoder - { fieldValueDecoder = \_oid -> \case - Nothing -> Left "Cannot decode SQL null as the `rawBytesFieldDecoder`." - Just bs -> Right bs, + { fieldValueDecoder = const Right, allowedPgTypes = const True } @@ -1615,11 +1568,11 @@ arrayField !replicateFunction !elementParser = -- From https://github.com/postgres/postgres/blob/5941946d0934b9eccb0d5bfebd40b155249a0130/src/backend/utils/adt/arrayfuncs.c#L1548 FieldDecoder { fieldValueDecoder = \colInfo -> - let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput + let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput "arrayField" in \case - Nothing -> Left "Cannot decode SQL null as the Haskell Vector type. Use a `Maybe (Vector a)`" + Nothing -> Right Nothing -- Left "Cannot decode SQL null as the Haskell Vector type. Use a `Maybe (Vector a)`" Just bs -> case Parser.parseOnly arrayFieldDecoder bs of - Parser.ParseOk v -> Right v + Parser.ParseOk v -> Right (Just v) Parser.ParseFail err -> Left err, allowedPgTypes = allowOnlyArrayTypes } @@ -1642,4 +1595,5 @@ arrayField !replicateFunction !elementParser = elementBs <- if size == (-1) then pure Nothing else Just <$> Parser.take size case elementParser.fieldValueDecoder elementColInfo elementBs of Left err -> fail $ "Error parsing array element: " ++ show err - Right el -> pure el + Right (Just el) -> pure el + Right Nothing -> fail "Found an array element that is NULL" -- TODO: I think this is a bug of ours, because what if a ~ Maybe b? diff --git a/hpgsql/src/Hpgsql/Internal.hs b/hpgsql/src/Hpgsql/Internal.hs index 8c427fe..4cfa3c0 100644 --- a/hpgsql/src/Hpgsql/Internal.hs +++ b/hpgsql/src/Hpgsql/Internal.hs @@ -1418,7 +1418,7 @@ consumeStreamingResults rp conn qryId = S.effect $ do S.concat $ S.mapM ( \(DataRows rowColumnData) -> - case Parser.parseOnly (Parser.parseMany rowparser <* Parser.endOfInput) rowColumnData of + case Parser.parseOnly (Parser.parseMany rowparser <* Parser.endOfInput "DataRows") rowColumnData of Parser.ParseOk rows -> pure rows Parser.ParseFail err -> throwIrrecoverableErrorWithStatement qText $ "Failed parsing a row: " <> Text.pack (show err) ) diff --git a/hpgsql/src/Hpgsql/SimpleParser.hs b/hpgsql/src/Hpgsql/SimpleParser.hs index 145c54d..28fec4d 100644 --- a/hpgsql/src/Hpgsql/SimpleParser.hs +++ b/hpgsql/src/Hpgsql/SimpleParser.hs @@ -31,6 +31,7 @@ module Hpgsql.SimpleParser takeFloatBE, takeDoubleBE, takeFloatBEWithFieldLength, + peekInt32BE, ) where @@ -39,7 +40,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Int (Int16, Int32, Int64) import Foreign.Storable (Storable) -import GHC.Float (castWord32ToFloat, castWord64ToDouble, word2Float) +import GHC.Float (castWord32ToFloat, castWord64ToDouble) import Hpgsql.Encoding.BinarySerializer (ByteStringIdx (..)) import qualified Hpgsql.Encoding.BinarySerializer as BinSer import Prelude hiding (take) @@ -152,6 +153,13 @@ takeInt32BE = Parser $ \idx bs kf ks -> Right v -> ks v (idx + 4) bs Left err -> kf err +{-# INLINE peekInt32BE #-} +peekInt32BE :: Parser Int32 +peekInt32BE = Parser $ \idx bs kf ks -> + case BinSer.decodeInt32BE idx bs of + Right v -> ks v idx bs + Left err -> kf err + {-# INLINE takeInt32BEWithFieldLength #-} -- | Parses both a field length and the field itself, for @@ -241,9 +249,9 @@ parseManyRows = Parser $ \idx' bs' _kf ks -> let restIdx = go idx' bs' in ks res {-# INLINE parseManyRows #-} -- | Succeeds only when the input has been fully consumed. -endOfInput :: Parser () -endOfInput = Parser $ \idx bs kf ks -> - if BS.length bs <= idx.idx then ks () idx bs else kf "endOfInput: input remaining" +endOfInput :: String -> Parser () +endOfInput debugFail = Parser $ \idx bs kf ks -> + if BS.length bs <= idx.idx then ks () idx bs else kf $ "endOfInput: input remaining (" ++ debugFail ++ ")" {-# INLINE endOfInput #-} -- | Run a parser and additionally return the slice of input it consumed. diff --git a/hpgsql/src/Hpgsql/Types.hs b/hpgsql/src/Hpgsql/Types.hs index 21fb011..ad19e16 100644 --- a/hpgsql/src/Hpgsql/Types.hs +++ b/hpgsql/src/Hpgsql/Types.hs @@ -87,13 +87,11 @@ instance FromPgField PgJson where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let - -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in - \case - Just bs -> Right $ PgJson $ fixJsonb bs - Nothing -> Left "Cannot decode SQL null as the Haskell PgJson type. Use a `Maybe PgJson` if you want SQL nulls", + let -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in \case + Just bs -> Right $ Just $ PgJson $ fixJsonb bs + Nothing -> pure Nothing, -- Left "Cannot decode SQL null as the Haskell PgJson type. Use a `Maybe PgJson` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } @@ -109,15 +107,13 @@ instance (FromJSON a) => FromPgField (Aeson a) where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let - -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in - \case - Just bs -> case Aeson.decodeStrict $ fixJsonb bs of - Just v -> Right $ Aeson v - Nothing -> Left "Failed to decode postgres JSON value into your `Aeson a` type. Are you sure it's proper JSON?" - Nothing -> Left "Cannot decode SQL null as a Haskell (Aeson a) type. Use a `Maybe (Aeson a)` if you want SQL nulls", + let -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in \case + Just bs -> case Aeson.decodeStrict $ fixJsonb bs of + Just v -> Right $ Just $ Aeson v + Nothing -> Left "Failed to decode postgres JSON value into your `Aeson a` type. Are you sure it's proper JSON?" + Nothing -> Right Nothing, -- Left "Cannot decode SQL null as a Haskell (Aeson a) type. Use a `Maybe (Aeson a)` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } From e5fc6e6706e2d49ca822c9f04608c0666789240d Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Mon, 17 Aug 2026 15:34:12 -0300 Subject: [PATCH 21/35] A separate field in FieldDecoder for what to decode NULL to With this, I am able to write specialised `FromPgField (Maybe a)` instances that can inline more aggressively. The gotcha is --- Runfile | 6 +- hpgsql-tests/RowDecoderGhcCore.hs | 2 +- hpgsql/src/Hpgsql/Encoding.hs | 455 +++++++++++++++++------------- hpgsql/src/Hpgsql/Internal.hs | 2 +- hpgsql/src/Hpgsql/SimpleParser.hs | 6 +- hpgsql/src/Hpgsql/Types.hs | 14 +- 6 files changed, 267 insertions(+), 218 deletions(-) diff --git a/Runfile b/Runfile index 1b85191..0a791b9 100644 --- a/Runfile +++ b/Runfile @@ -73,13 +73,13 @@ tests: if [ -n "$NIX" ]; then nix-build --no-out-link -A "testsPg${pg}" --argstr hspecArgs "$TARGS" else - cabal build hpgsql-tests + cabal build hpgsql-tests # hpgsql-simple-compat-tests nix-shell -A "shellPg${pg}" ./default.nix --run "./scripts/run-tests-db-internal.sh $TARGS" fi done - echo "--- Running hlint" - hlint . + # echo "--- Running hlint" + # hlint . ## # Runs tests 100 times, reporting how many passed and how many failed. diff --git a/hpgsql-tests/RowDecoderGhcCore.hs b/hpgsql-tests/RowDecoderGhcCore.hs index 244ec4d..512efc8 100644 --- a/hpgsql-tests/RowDecoderGhcCore.hs +++ b/hpgsql-tests/RowDecoderGhcCore.hs @@ -27,7 +27,7 @@ import Hpgsql.Encoding (FromPgField (..), FromPgRow (..), genericFromPgRow, sing data BestCaseScenarioRecord = BestCaseScenarioRecord { bcsId :: !Int, bcsDate :: !Day, - bcsText :: !Int + bcsText :: !(Maybe Int) } instance FromPgRow BestCaseScenarioRecord where diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index 5d25248..fc9513e 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -121,7 +121,8 @@ data FieldInfo = FieldInfo -- | A decoder for a single field/column. data FieldDecoder a = FieldDecoder - { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String (Maybe a), + { fieldValueDecoder :: FieldInfo -> ByteString -> Either String a, -- TODO: Since this now takes a ByteString (not a Maybe), it could actually be typed `FieldInfo -> Parser a` + decodesSqlNullTo :: Either String a, allowedPgTypes :: FieldInfo -> Bool } deriving stock (Functor) @@ -137,6 +138,7 @@ instance Semigroup (FieldDecoder a) where let cand1 = if dec1.allowedPgTypes cInfo then f1 mbs else Left "Not first parser" cand2 = if dec2.allowedPgTypes cInfo then f2 mbs else Left "Not second parser" in cand1 <> cand2, + decodesSqlNullTo = dec1.decodesSqlNullTo <> dec2.decodesSqlNullTo, allowedPgTypes = \cInfo -> dec1.allowedPgTypes cInfo || dec2.allowedPgTypes cInfo } @@ -157,27 +159,27 @@ instance Applicative RowDecoder where instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in Hpgsql because Hpgsql type-checks the result types of queries before having access to even the first data row. Use the Applicative class to write your instances or use the Monadic decoding variants.")) => Monad RowDecoder where (>>=) = error "inaccessible bind in Monad RowDecoder instance" -{-# INLINE singleField #-} +{-# INLINE singleField #-} -- 1.2% wall time perf. gain with this singleField :: FieldDecoder a -> RowDecoder a -singleField (FieldDecoder {..}) = +singleField fdec = RowDecoder { fullRowDecoder = \case [singleColInfo] -> - let decode = fieldValueDecoder singleColInfo + let decode = fdec.fieldValueDecoder singleColInfo in do lenNextCol <- fromIntegral <$> Parser.takeInt32BE - nextColBs <- - if lenNextCol >= 0 - then - Just <$> Parser.take lenNextCol - else pure Nothing - case decode nextColBs of - Right Nothing -> fail "Got SQL NULL but no nulls accepted" -- TODO: Please improve the failure message.. show field name and target Haskell type if we can - Right (Just v) -> pure v - Left err -> fail err + if lenNextCol >= 0 + then do + nextColBs <- Parser.take lenNextCol + case decode nextColBs of + Right v -> pure v + Left err -> fail err + else case fdec.decodesSqlNullTo of + Right v -> pure v + Left err -> fail err _ -> error "singleField expected a single column OID but got 0 or >1", rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, allowedPgTypes singleColInfo)] + [singleColInfo] -> [(singleColInfo, fdec.allowedPgTypes singleColInfo)] _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", numExpectedColumns = 1 } @@ -244,11 +246,13 @@ class FromPgRow a where compositeTypeDecoder :: forall a. RowDecoder a -> FieldDecoder a compositeTypeDecoder (RowDecoder {..}) = FieldDecoder - { fieldValueDecoder = \compositeTypeOid -> \case - Nothing -> Right Nothing -- Left "Got NULL in composite type but it was not allowed" - Just bs -> case Parser.parseOnly (parserForRecord compositeTypeOid.encodingContext <* Parser.endOfInput "compositeTypeDecoder") bs of - Parser.ParseOk v -> Right (Just v) - Parser.ParseFail err -> Left err, + { fieldValueDecoder = \compositeTypeOid -> + let prs = parserForRecord compositeTypeOid.encodingContext <* Parser.endOfInput + in \bs -> + case Parser.parseOnly prs bs of + Parser.ParseOk v -> Right v + Parser.ParseFail err -> Left err, + decodesSqlNullTo = Left "TODO: composeTypeDecoder decodesSqlNullTo", allowedPgTypes = const True -- There's no way to enforce a custom type's OID. We only check if it's structurally the same in the parser (same subtypes in same order) } where @@ -266,7 +270,7 @@ compositeTypeDecoder (RowDecoder {..}) = pure (oid, sizeBs <> bs) let typecheckedCols = rowColumnsTypeCheck (map (mkColInfo . fst) cols) unless (all snd typecheckedCols) $ fail $ "Parser for composite found type OIDs " ++ show (map fst cols) ++ " but expected different" - case Parser.parseOnly (fullRowDecoder (map (mkColInfo . fst) cols) <* Parser.endOfInput "parserForRecord") (mconcat $ map snd cols) of + case Parser.parseOnly (fullRowDecoder (map (mkColInfo . fst) cols) <* Parser.endOfInput) (mconcat $ map snd cols) of Parser.ParseOk v -> pure v Parser.ParseFail err -> error $ "Error decoding composite type: " ++ show err @@ -783,10 +787,11 @@ binaryFloat4Decoder = castWord32ToFloat . either error id . BinSer.decodeWord32B binaryFloat8Decoder :: ByteString -> Double binaryFloat8Decoder = castWord64ToDouble . either error id . BinSer.decodeWord64BE 0 -parsePgType :: [Oid] -> (Maybe ByteString -> Either String (Maybe a)) -> FieldDecoder a -parsePgType !requiredTypeOids !fieldValueDecoder = +parsePgType :: String -> [Oid] -> (ByteString -> Either String a) -> FieldDecoder a +parsePgType !typeName !requiredTypeOids !fieldValueDecoder = FieldDecoder { fieldValueDecoder = \_oid -> fieldValueDecoder, + decodesSqlNullTo = Left $ "Cannot decode SQL null as the Haskell " ++ typeName ++ " type. Use a `Maybe " ++ show typeName ++ "`", allowedPgTypes = (`elem` requiredTypeOids) . fieldTypeOid } @@ -794,9 +799,9 @@ instance FromPgField () where fieldDecoder = FieldDecoder { fieldValueDecoder = \_oid -> \case - Just "" -> Right (Just ()) - Just bs -> Left $ "Invalid value '" ++ show bs ++ "' for postgres void type" - Nothing -> pure Nothing, -- Left "Cannot decode SQL null as the Haskell () type. Use a `Maybe ()`", + "" -> Right () + bs -> Left $ "Invalid value '" ++ show bs ++ "' for postgres void type", + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell () type. Use a `Maybe ()`", allowedPgTypes = (== voidOid) . fieldTypeOid } @@ -819,9 +824,8 @@ instance FromPgField Int where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> let !decode = binaryIntDecoder oid - in \case - Just bs -> Just <$> decode bs - Nothing -> pure Nothing, -- Left "Cannot decode SQL null as the Haskell Int type. Use a `Maybe Int`", + in \bs -> decode bs, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int type. Use a `Maybe Int`", allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid } {-# NOINLINE singleFieldRowDecoder #-} @@ -829,14 +833,31 @@ instance FromPgField Int where {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = nonNullableRowDec "Int" intRowDecoder +-- instance {-# OVERLAPPING #-} FromPgField (Maybe Int) where +-- -- This overlapping instance isn't pretty, but it reduces memory +-- -- usage and improves performance a bit +-- fieldDecoder = error "TODO Maybe Int" + +-- -- FieldDecoder +-- -- { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> +-- -- let !decode = binaryIntDecoder oid +-- -- in \case +-- -- Just bs -> Just <$> decode bs +-- -- Nothing -> Right Nothing, +-- -- allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid +-- -- } +-- {-# NOINLINE singleFieldRowDecoder #-} +-- singleFieldRowDecoder = inlinedSingleFieldRowDecoder +-- {-# INLINE inlinedSingleFieldRowDecoder #-} +-- inlinedSingleFieldRowDecoder = intRowDecoder + instance FromPgField Int16 where fieldDecoder = FieldDecoder { fieldValueDecoder = let !decode = binaryIntDecoder int2Oid - in const $ \case - Just bs -> Just <$> decode bs - Nothing -> Right Nothing, -- Left "Cannot decode SQL null as the Haskell Int16 type. Use a `Maybe Int16`", + in const decode, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int16 type. Use a `Maybe Int16`", allowedPgTypes = (== int2Oid) . fieldTypeOid } @@ -854,11 +875,8 @@ int32RowDecoder = instance FromPgField Int32 where fieldDecoder = FieldDecoder - { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> - let !decode = binaryIntDecoder oid - in \case - Just bs -> Just <$> decode bs - Nothing -> Right Nothing, -- Left "Cannot decode SQL null as the Haskell Int32 type. Use a `Maybe Int32`", + { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> binaryIntDecoder oid, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int32 type. Use a `Maybe Int32`", allowedPgTypes = (`elem` [int2Oid, int4Oid]) . fieldTypeOid } {-# NOINLINE singleFieldRowDecoder #-} @@ -881,11 +899,8 @@ int64RowDecoder = instance FromPgField Int64 where fieldDecoder = FieldDecoder - { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> - let !decode = binaryIntDecoder oid - in \case - Just bs -> Just <$> decode bs - Nothing -> pure Nothing, -- Left "Cannot decode SQL null as the Haskell Int64 type. Use a `Maybe Int64`", + { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> binaryIntDecoder oid, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int64 type. Use a `Maybe Int64`", allowedPgTypes = (`elem` [int2Oid, int4Oid, int8Oid]) . fieldTypeOid } {-# NOINLINE singleFieldRowDecoder #-} @@ -898,15 +913,14 @@ instance FromPgField Integer where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> let !decodeInt = binaryIntDecoder @Int64 oid - in \case - Just bs - | oid /= numericOid -> Just . fromIntegral <$> decodeInt bs - | otherwise -> case Parser.parseOnly (scientificDecoder True <* Parser.endOfInput "Integer") bs of - Parser.ParseOk sci -> case floatingOrInteger @Double @Integer sci of - Right i -> Right (Just i) - Left _ -> Left "Internal error in Hpgsql. Scientific to Integer conversion failed" - Parser.ParseFail err -> Left err - Nothing -> Right Nothing, -- Left "Cannot decode SQL null as the Haskell Integer type. Use a `Maybe Integer`", + in if oid /= numericOid + then fmap fromIntegral <$> decodeInt + else \bs -> case Parser.parseOnly (scientificDecoder True <* Parser.endOfInput) bs of + Parser.ParseOk sci -> case floatingOrInteger @Double @Integer sci of + Right i -> Right i + Left _ -> Left "Internal error in Hpgsql. Scientific to Integer conversion failed" + Parser.ParseFail err -> Left err, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Integer type. Use a `Maybe Integer`", allowedPgTypes = (`elem` [int8Oid, numericOid, int4Oid, int2Oid]) . fieldTypeOid } @@ -915,8 +929,8 @@ instance FromPgField Oid where FieldDecoder { fieldValueDecoder = \_ -> \case -- Oids are just int4 - Just bs -> Just . Oid <$> binaryIntDecoder int4Oid bs - Nothing -> pure Nothing, -- Left "Cannot decode SQL null as the Haskell Oid type. Use a `Maybe Oid`", + bs -> Oid <$> binaryIntDecoder int4Oid bs, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Oid type. Use a `Maybe Oid`", allowedPgTypes = (== oidOid) . fieldTypeOid } @@ -926,14 +940,21 @@ floatRowDecoder = inlinableRowDecoder [float4Oid] Parser.takeFloatBEWithFieldLength instance FromPgField Float where - fieldDecoder = parsePgType [float4Oid] $ \case - Just bs -> Right $ Just $ binaryFloat4Decoder bs - Nothing -> pure Nothing -- Left "Cannot decode SQL null as the Haskell Float type. Use a `Maybe Float`" + fieldDecoder = parsePgType "Float" [float4Oid] $ Right . binaryFloat4Decoder {-# NOINLINE singleFieldRowDecoder #-} singleFieldRowDecoder = inlinedSingleFieldRowDecoder {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = nonNullableRowDec "Float" floatRowDecoder +-- instance {-# OVERLAPPING #-} FromPgField (Maybe Float) where +-- -- This overlapping instance isn't pretty, but it reduces memory +-- -- usage and improves performance a bit +-- fieldDecoder = error "TODO Maybe Float" +-- {-# NOINLINE singleFieldRowDecoder #-} +-- singleFieldRowDecoder = inlinedSingleFieldRowDecoder +-- {-# INLINE inlinedSingleFieldRowDecoder #-} +-- inlinedSingleFieldRowDecoder = floatRowDecoder + {-# INLINE doubleRowDecoder #-} doubleRowDecoder :: RowDecoder (Maybe Double) doubleRowDecoder = @@ -949,12 +970,11 @@ instance FromPgField Double where fieldDecoder = FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> - let !decoder + let decoder | oid == float8Oid = binaryFloat8Decoder | otherwise = float2Double . binaryFloat4Decoder - in \case - Just bs -> Right $ Just $ decoder bs - Nothing -> pure Nothing, -- Left "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`", + in Right . decoder, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`", allowedPgTypes = (`elem` [float8Oid, float4Oid]) . fieldTypeOid } {-# NOINLINE singleFieldRowDecoder #-} @@ -962,6 +982,15 @@ instance FromPgField Double where {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = nonNullableRowDec "Double" doubleRowDecoder +-- instance {-# OVERLAPPING #-} FromPgField (Maybe Double) where +-- -- This overlapping instance isn't pretty, but it reduces memory +-- -- usage and improves performance a bit +-- fieldDecoder = error "TODO Maybe Double" +-- {-# NOINLINE singleFieldRowDecoder #-} +-- singleFieldRowDecoder = inlinedSingleFieldRowDecoder +-- {-# INLINE inlinedSingleFieldRowDecoder #-} +-- inlinedSingleFieldRowDecoder = doubleRowDecoder + -- | Allows you to specify a type (and other checks, possibly) for a `FieldDecoder`. -- This can be useful to ensure you're not accidentally decoding a different type. -- @@ -1019,17 +1048,15 @@ instance FromPgField Scientific where if fieldTypeOid /= numericOid then let intdec = binaryIntDecoder @Int64 fieldTypeOid - in \case - Just bs -> Just . flip scientific 0 . fromIntegral <$> intdec bs - Nothing -> pure Nothing -- Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`" + in \bs -> flip scientific 0 . fromIntegral <$> intdec bs else \case - Just bs -> + bs -> -- TODO: There is loss converting from Float/Double to Scientific, but it might be quite small, so should we accept -- float4Oid and float8Oid here? - case Parser.parseOnly (scientificDecoder False <* Parser.endOfInput "Scientific") bs of - Parser.ParseOk sci -> Right (Just sci) - Parser.ParseFail err -> Left err - Nothing -> pure Nothing, -- Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`", + case Parser.parseOnly (scientificDecoder False <* Parser.endOfInput) bs of + Parser.ParseOk sci -> Right sci + Parser.ParseFail err -> Left err, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`", allowedPgTypes = (`elem` [numericOid, int2Oid, int4Oid, int8Oid]) . fieldTypeOid } {-# NOINLINE singleFieldRowDecoder #-} @@ -1060,40 +1087,45 @@ boolRowDecoder = inlinableRowDecoder [boolOid] $ fmap (== 1) <$> Parser.parsePgFieldWithAtMost4Bytes BinSer.TypeSize1 instance FromPgField Bool where - fieldDecoder = parsePgType [boolOid] $ \case - Just bs -> Right $ Just $ bs == binaryTrue - Nothing -> Right Nothing -- Left "Cannot decode SQL null as the Haskell Bool type. Use a `Maybe Bool`" + fieldDecoder = parsePgType "Bool" [boolOid] $ \bs -> Right $ bs == binaryTrue {-# NOINLINE singleFieldRowDecoder #-} singleFieldRowDecoder = inlinedSingleFieldRowDecoder {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = nonNullableRowDec "Bool" boolRowDecoder +-- instance {-# OVERLAPPING #-} FromPgField (Maybe Bool) where +-- -- This overlapping instance isn't pretty, but it reduces memory +-- -- usage and improves performance a bit +-- fieldDecoder = error "TODO Maybe Bool" +-- {-# NOINLINE singleFieldRowDecoder #-} +-- singleFieldRowDecoder = inlinedSingleFieldRowDecoder +-- {-# INLINE inlinedSingleFieldRowDecoder #-} +-- inlinedSingleFieldRowDecoder = boolRowDecoder + instance FromPgField Char where fieldDecoder = let textParser = fieldValueDecoder (fieldDecoder @Text) in FieldDecoder { fieldValueDecoder = \colInfo@FieldInfo {fieldTypeOid = oid} -> let !decodeText = textParser colInfo - in \mbs -> case mbs of - Just bs -> - if oid == charOid - -- TODO: Postgres has values of type "char" in the pg_type.typcategory table. - -- We should test this instance works with those, and we haven't yet. - then Right $ Just $ BSC.head bs - else case decodeText mbs of - Left err -> Left err - Right (Just t) -> if Text.length t > 1 then Left "Cannot parse text with more than one character into a Haskell Char type." else Right (Just $ Text.head t) - Right Nothing -> Right Nothing - Nothing -> Right Nothing, -- Left "Cannot decode SQL null as the Haskell Char type. Use a `Maybe Char`", - -- TODO: All the varchar types? + in \bs -> + if oid == charOid + -- TODO: Postgres has values of type "char" in the pg_type.typcategory table. + -- We should test this instance works with those, and we haven't yet. + then Right $ BSC.head bs + else case decodeText bs of + Left err -> Left err + Right t -> if Text.length t > 1 then Left "Cannot parse text with more than one character into a Haskell Char type." else Right (Text.head t), + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Char type. Use a `Maybe Char`", + -- TODO: All the varchar types? allowedPgTypes = (`elem` [charOid, textOid]) . fieldTypeOid } instance FromPgField ByteString where - fieldDecoder = parsePgType [byteaOid] Right + fieldDecoder = parsePgType "byteString" [byteaOid] Right instance FromPgField LBS.ByteString where - fieldDecoder = parsePgType [byteaOid] $ Right . fmap LBS.fromStrict + fieldDecoder = parsePgType "ByteString" [byteaOid] $ Right . LBS.fromStrict {-# INLINE textDecoder #-} textDecoder :: RowDecoder (Maybe Text) @@ -1106,27 +1138,29 @@ textDecoder = else pure Nothing instance FromPgField Text where - fieldDecoder = parsePgType [textOid, varcharOid, nameOid] $ \case - Just bs -> Right $ Just $ decodeUtf8 bs - -- TODO: Use some faster unsafeDecodeUtf8 function? - Nothing -> Right Nothing -- Left "Cannot decode SQL null as the Haskell Text type. Use a `Maybe Text`" + -- TODO: Use some faster unsafeDecodeUtf8 function? + fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ decodeUtf8 bs {-# NOINLINE singleFieldRowDecoder #-} singleFieldRowDecoder = inlinedSingleFieldRowDecoder {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = nonNullableRowDec "Text" textDecoder +-- instance {-# OVERLAPPING #-} FromPgField (Maybe Text) where +-- -- This overlapping instance isn't pretty, but it reduces memory +-- -- usage and improves performance a bit +-- fieldDecoder = error "TODO Maybe Text" +-- {-# NOINLINE singleFieldRowDecoder #-} +-- singleFieldRowDecoder = inlinedSingleFieldRowDecoder +-- {-# INLINE inlinedSingleFieldRowDecoder #-} +-- inlinedSingleFieldRowDecoder = textDecoder + instance FromPgField LT.Text where - fieldDecoder = parsePgType [textOid, varcharOid, nameOid] $ \case - Just bs -> Right $ Just $ LT.fromStrict $ decodeUtf8 bs - -- TODO: Use some faster unsafeDecodeUtf8 function? - Nothing -> Right Nothing -- Left "Cannot decode SQL null as the Haskell Text type. Use a `Maybe Text`" + -- TODO: Use some faster unsafeDecodeUtf8 function? + fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ LT.fromStrict $ decodeUtf8 bs instance FromPgField String where - fieldDecoder = parsePgType [textOid, varcharOid, nameOid] $ \case - -- connection option). - Just bs -> Right $ Just $ Text.unpack $ decodeUtf8 bs - -- TODO: Use some faster unsafeDecodeUtf8 function? - Nothing -> Right Nothing -- Left "Cannot decode SQL null as the Haskell String type. Use a `Maybe String`" + -- TODO: Use some faster unsafeDecodeUtf8 function? + fieldDecoder = parsePgType "String" [textOid, varcharOid, nameOid] $ \bs -> Right $ Text.unpack $ decodeUtf8 bs -- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default -- connection option). @@ -1157,78 +1191,81 @@ utcTimeRowDecoder = _ -> pure Nothing instance FromPgField UTCTime where - fieldDecoder = parsePgType [timestamptzOid] $ \case - Just bs -> do + fieldDecoder = parsePgType "UTCTime" [timestamptzOid] $ \case + bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 totalusecs <- BinSer.decodeInt64BE 0 bs let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - Right $ Just $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - Nothing -> pure Nothing -- Left "Cannot decode SQL null as the Haskell UTCTime type. Use a `Maybe UTCTime`" + Right $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) {-# NOINLINE singleFieldRowDecoder #-} singleFieldRowDecoder = inlinedSingleFieldRowDecoder {-# NOINLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = nonNullableRowDec "UTCTime" utcTimeRowDecoder +-- instance {-# OVERLAPPING #-} FromPgField (Maybe UTCTime) where +-- -- This overlapping instance isn't pretty, but it reduces memory +-- -- usage and improves performance a bit +-- fieldDecoder = error "TODO Maybe UTCTime" +-- {-# NOINLINE singleFieldRowDecoder #-} +-- singleFieldRowDecoder = inlinedSingleFieldRowDecoder +-- {-# INLINE inlinedSingleFieldRowDecoder #-} +-- inlinedSingleFieldRowDecoder = utcTimeRowDecoder + instance FromPgField (Unbounded UTCTime) where - fieldDecoder = parsePgType [timestamptzOid] $ \case - Just bs -> do + fieldDecoder = parsePgType "Unbounded UTCTime" [timestamptzOid] $ \case + bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 totalusecs <- BinSer.decodeInt64BE 0 bs Right $ if totalusecs == minBound - then Just NegInfinity + then NegInfinity else if totalusecs == maxBound - then Just PosInfinity + then PosInfinity else let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - in Just $ Finite $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - Nothing -> Right Nothing -- Left "Cannot decode SQL null as the Haskell (Unbounded UTCTime) type. Use a `Maybe (Unbounded UTCTime)`" + in Finite $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) instance FromPgField ZonedTime where - fieldDecoder = parsePgType [timestamptzOid] $ \case - Just bs -> do + fieldDecoder = parsePgType "ZonedTime" [timestamptzOid] $ \case + bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 totalusecs <- BinSer.decodeInt64BE 0 bs let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - Right $ Just $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - Nothing -> pure Nothing -- Left "Cannot decode SQL null as the Haskell ZonedTime type. Use a `Maybe ZonedTime`" + Right $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) instance FromPgField (Unbounded ZonedTime) where - fieldDecoder = parsePgType [timestamptzOid] $ \case - Just bs -> do + fieldDecoder = parsePgType "Unbounded ZonedTime" [timestamptzOid] $ \case + bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 totalusecs <- BinSer.decodeInt64BE 0 bs Right $ if totalusecs == minBound - then Just NegInfinity + then NegInfinity else if totalusecs == maxBound - then Just PosInfinity + then PosInfinity else let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - in Just $ Finite $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - Nothing -> pure Nothing -- Left "Cannot decode SQL null as the Haskell ZonedTime type. Use a `Maybe ZonedTime`" + in Finite $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) instance FromPgField LocalTime where - fieldDecoder = parsePgType [timestampOid] $ \case - Just bs -> do + fieldDecoder = parsePgType "LocalTime" [timestampOid] $ \case + bs -> do totalusecs <- BinSer.decodeInt64BE 0 bs let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - Right $ Just $ LocalTime parsedDate (timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - Nothing -> pure Nothing -- Left "Cannot decode SQL null as the Haskell LocalTime type. Use a `Maybe LocalTime`" + Right $ LocalTime parsedDate (timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) instance FromPgField TimeOfDay where - fieldDecoder = parsePgType [timeOid] $ \case - Just bs -> do + fieldDecoder = parsePgType "TimeOfDay" [timeOid] $ \case + bs -> do usecs <- BinSer.decodeInt64BE 0 bs - Right $ Just $ timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral usecs * 1_000_000 - Nothing -> Right Nothing -- Left "Cannot decode SQL null as the Haskell TimeOfDay type. Use a `Maybe TimeOfDay`" + Right $ timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral usecs * 1_000_000 {-# INLINE dayRowDecoder #-} dayRowDecoder :: RowDecoder (Maybe Day) @@ -1237,51 +1274,55 @@ dayRowDecoder = in inlinableRowDecoder [dateOid] $ fmap int32ToDay <$> Parser.takeInt32BEWithFieldLength instance FromPgField Day where - fieldDecoder = parsePgType [dateOid] $ \case - Just bs -> do + fieldDecoder = parsePgType "Day" [dateOid] $ \case + bs -> do -- There is a very specific conversion function for these, which I poorly translated to Haskell -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 -- But I found a simpler way to do this. Let's see if it works in our property based tests jd <- BinSer.decodeInt32BE 0 bs - Right $ Just $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 - Nothing -> pure Nothing -- Left "Cannot decode SQL null as the Haskell Day type. Use a `Maybe Day`" + Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 {-# NOINLINE singleFieldRowDecoder #-} singleFieldRowDecoder = inlinedSingleFieldRowDecoder {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = nonNullableRowDec "Day" dayRowDecoder +-- instance {-# OVERLAPPING #-} FromPgField (Maybe Day) where +-- -- This overlapping instance isn't pretty, but it reduces memory +-- -- usage and improves performance a bit +-- fieldDecoder = error "TODO Maybe Day" +-- {-# NOINLINE singleFieldRowDecoder #-} +-- singleFieldRowDecoder = inlinedSingleFieldRowDecoder +-- {-# INLINE inlinedSingleFieldRowDecoder #-} +-- inlinedSingleFieldRowDecoder = dayRowDecoder + instance FromPgField (Unbounded Day) where - fieldDecoder = parsePgType [dateOid] $ \case - Just bs -> do + fieldDecoder = parsePgType "Unbounded Day" [dateOid] $ \case + bs -> do -- There is a very specific conversion function for these, which I poorly translated to Haskell -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 -- But I found a simpler way to do this. Let's see if it works in our property based tests jd <- BinSer.decodeInt32BE 0 bs Right $ if jd == minBound - then Just NegInfinity + then NegInfinity else if jd == maxBound - then Just PosInfinity + then PosInfinity else - Just $ Finite $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 - Nothing -> pure Nothing -- Left "Cannot decode SQL null as the Haskell (Unbounded Day) type. Use a `Maybe (Unbounded Day)`" + Finite $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 instance FromPgField CalendarDiffTime where - fieldDecoder = parsePgType [intervalOid] $ \case - Just bs -> do - nMicrosecs <- BinSer.decodeInt64BE 0 bs - nDays <- BinSer.decodeInt32BE 8 bs - nMonths <- BinSer.decodeInt32BE 12 bs - Right $ Just $ CalendarDiffTime {ctMonths = fromIntegral nMonths, ctTime = secondsToNominalDiffTime (fromIntegral nDays * 86400) + realToFrac (picosecondsToDiffTime (fromIntegral nMicrosecs * 1_000_000))} - Nothing -> pure Nothing -- Left "Cannot decode SQL null as the Haskell CalendarDiffTime type. Use a `Maybe CalendarDiffTime`" + fieldDecoder = parsePgType "CalendarDiffTime " [intervalOid] $ \bs -> do + nMicrosecs <- BinSer.decodeInt64BE 0 bs + nDays <- BinSer.decodeInt32BE 8 bs + nMonths <- BinSer.decodeInt32BE 12 bs + Right $ CalendarDiffTime {ctMonths = fromIntegral nMonths, ctTime = secondsToNominalDiffTime (fromIntegral nDays * 86400) + realToFrac (picosecondsToDiffTime (fromIntegral nMicrosecs * 1_000_000))} instance FromPgField UUID where - fieldDecoder = parsePgType [uuidOid] $ \case - Just bs -> case UUID.fromByteString (LBS.fromStrict bs) of - Just uuid -> Right (Just uuid) + fieldDecoder = parsePgType "UUID" [uuidOid] $ \case + bs -> case UUID.fromByteString (LBS.fromStrict bs) of + Just uuid -> Right uuid Nothing -> Left "Bug in Hpgsql: UUID field could not be decoded" - Nothing -> Right Nothing -- Left "Cannot decode SQL null as the Haskell UUID type. Use a `Maybe UUID`" instance FromPgField Aeson.Value where fieldDecoder = @@ -1289,14 +1330,12 @@ instance FromPgField Aeson.Value where { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> let -- jsonb has a byte prepended to the contents and json does not - -- TODO: Does `BS.drop 1` get inlined into `Aeson.decodeStrict` further down? - -- Might be an interesting case study !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id in \case - Just bs -> case Aeson.decodeStrict @Aeson.Value $ fixJsonb bs of - Just d -> Right (Just d) - Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid." - Nothing -> pure Nothing, -- Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls", + bs -> case Aeson.decodeStrict $ fixJsonb bs of + Just d -> Right d + Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } @@ -1306,17 +1345,9 @@ nullableField :: FieldDecoder a -> FieldDecoder (Maybe a) nullableField FieldDecoder {..} = FieldDecoder { fieldValueDecoder = \oid -> - let !origFieldValueParser = fieldValueDecoder oid - in \case - -- TODO: we have multiple layers of Maybe/NULL here. - -- What should we do? If the supplied decoder returns - -- Nothing, do we return `Just Nothing`? Or do we follow - -- SQL's viral NULL semantics? - -- Think about a custom user type that decodes NULL into a Just, - -- and test that with all decoding combinations we provide ( - -- singleField, nullableField, specialized inlined/not-inlined row decoders, etc.) - Nothing -> Right Nothing - justBs -> Just <$> origFieldValueParser justBs, + let origFieldValueParser = fieldValueDecoder oid + in \bs -> Just <$> origFieldValueParser bs, + decodesSqlNullTo = Right Nothing, allowedPgTypes } @@ -1332,30 +1363,40 @@ nonNullableRowDec haskellTypeName rdec = numExpectedColumns = rdec.numExpectedColumns } -{-# INLINE nullableRowDec #-} -nullableRowDec :: RowDecoder a -> RowDecoder (Maybe a) -nullableRowDec rdec = - RowDecoder - { fullRowDecoder = \finfos -> do - -- Peek the field length, but only consume it - -- if we get a NULL. Urgh. - fieldLen <- Parser.peekInt32BE - if fieldLen == (-1) - then do - Parser.skip 4 - pure Nothing - else - Just <$> rdec.fullRowDecoder finfos, - rowColumnsTypeCheck = rdec.rowColumnsTypeCheck, - numExpectedColumns = rdec.numExpectedColumns - } - instance (FromPgField a) => FromPgField (Maybe a) where fieldDecoder = nullableField fieldDecoder + {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = nullableRowDec inlinedSingleFieldRowDecoder + singleFieldRowDecoder = inlinedSingleFieldRowDecoder {-# INLINE inlinedSingleFieldRowDecoder #-} - inlinedSingleFieldRowDecoder = nullableRowDec inlinedSingleFieldRowDecoder + inlinedSingleFieldRowDecoder = + RowDecoder + { fullRowDecoder = \finfos -> + let frd = inlinedSingleFieldRowDecoder.fullRowDecoder finfos + in do + -- TODO: We're decoding the field length twice with + -- the peek call when the value isn't NULL. + -- Maybe we should make `FromPgField`'s new methods + -- be two `Parser` objects: one for both length and field + -- and another only for the field (but how would that work + -- without the length..? It wouldn't.) + -- Maybe we do the `Parser (Maybe a)` for `a` types, then. + -- We can build a `Parser a` from that with `decodesSqlNullTo` + -- and with inlining there's nothing to lose? + fieldLen <- Parser.peekInt32BE + if fieldLen == (-1) + then case fieldDecoder.decodesSqlNullTo of + Left err -> fail err + Right v -> Parser.skip 4 >> pure v + else do + Just <$> frd, + rowColumnsTypeCheck = + let fdec = fieldDecoder @a + in \case + [singleColInfo] -> [(singleColInfo, fdec.allowedPgTypes singleColInfo)] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } allowOnlyArrayTypes :: FieldInfo -> Bool allowOnlyArrayTypes fieldInfo = @@ -1373,12 +1414,12 @@ instance {-# OVERLAPPING #-} forall a. (FromPgField a) => FromPgField (Vector (V fieldDecoder = FieldDecoder { fieldValueDecoder = \colInfo -> - let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput "Vector (Vector a)" + let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput in \case - Nothing -> Right Nothing -- Left "Cannot decode SQL null as the Haskell (Vector (Vector a)) type. Use a `Maybe (Vector (Vector a))`" - Just bs -> case Parser.parseOnly arrayFieldDecoder bs of - Parser.ParseOk v -> Right (Just v) + bs -> case Parser.parseOnly arrayFieldDecoder bs of + Parser.ParseOk v -> Right v Parser.ParseFail err -> Left err, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell (Vector (Vector a)) type. Use a `Maybe (Vector (Vector a))`", allowedPgTypes = allowOnlyArrayTypes } where @@ -1404,11 +1445,15 @@ instance {-# OVERLAPPING #-} forall a. (FromPgField a) => FromPgField (Vector (V Vector.replicateM lengthEachRow $ do size :: Int <- fromIntegral <$> Parser.takeInt32BE - elementBs <- if size == (-1) then pure Nothing else Just <$> Parser.take size - case elementParser.fieldValueDecoder elementColInfo elementBs of - Left err -> fail $ "Error parsing array element: " ++ show err - Right (Just el) -> pure el - Right Nothing -> fail "Found an array element that is NULL" -- TODO: I think this is a bug of ours, because what if a ~ Maybe b? + if size == (-1) + then case elementParser.decodesSqlNullTo of + Left err -> fail err + Right v -> pure v + else do + elementBs <- Parser.take size + case elementParser.fieldValueDecoder elementColInfo elementBs of + Left err -> fail $ "Error parsing array element: " ++ show err + Right el -> pure el {-# INLINE genericFromPgRow #-} @@ -1540,7 +1585,9 @@ untypedFieldEncoder enc = FieldEncoder {toTypeOid = \_ -> Nothing, toPgField = e rawBytesFieldDecoder :: FieldDecoder ByteString rawBytesFieldDecoder = FieldDecoder - { fieldValueDecoder = const Right, + { fieldValueDecoder = \_oid -> \case + bs -> Right bs, + decodesSqlNullTo = Left "Cannot decode SQL null as the `rawBytesFieldDecoder`.", allowedPgTypes = const True } @@ -1568,12 +1615,12 @@ arrayField !replicateFunction !elementParser = -- From https://github.com/postgres/postgres/blob/5941946d0934b9eccb0d5bfebd40b155249a0130/src/backend/utils/adt/arrayfuncs.c#L1548 FieldDecoder { fieldValueDecoder = \colInfo -> - let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput "arrayField" + let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput in \case - Nothing -> Right Nothing -- Left "Cannot decode SQL null as the Haskell Vector type. Use a `Maybe (Vector a)`" - Just bs -> case Parser.parseOnly arrayFieldDecoder bs of - Parser.ParseOk v -> Right (Just v) + bs -> case Parser.parseOnly arrayFieldDecoder bs of + Parser.ParseOk v -> Right v Parser.ParseFail err -> Left err, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Vector type. Use a `Maybe (Vector a)`", allowedPgTypes = allowOnlyArrayTypes } where @@ -1592,8 +1639,12 @@ arrayField !replicateFunction !elementParser = unless (elementParser.allowedPgTypes elementColInfo) $ fail $ "Array contains elements of type OID " ++ show elementTypeOid ++ " but decoder does not handle that type" replicateFunction dim_i $ do size :: Int <- fromIntegral <$> Parser.takeInt32BE - elementBs <- if size == (-1) then pure Nothing else Just <$> Parser.take size - case elementParser.fieldValueDecoder elementColInfo elementBs of - Left err -> fail $ "Error parsing array element: " ++ show err - Right (Just el) -> pure el - Right Nothing -> fail "Found an array element that is NULL" -- TODO: I think this is a bug of ours, because what if a ~ Maybe b? + if size == (-1) + then case elementParser.decodesSqlNullTo of + Left err -> fail err + Right v -> pure v + else do + elementBs <- Parser.take size + case elementParser.fieldValueDecoder elementColInfo elementBs of + Left err -> fail $ "Error parsing array element: " ++ show err + Right el -> pure el diff --git a/hpgsql/src/Hpgsql/Internal.hs b/hpgsql/src/Hpgsql/Internal.hs index 4cfa3c0..8c427fe 100644 --- a/hpgsql/src/Hpgsql/Internal.hs +++ b/hpgsql/src/Hpgsql/Internal.hs @@ -1418,7 +1418,7 @@ consumeStreamingResults rp conn qryId = S.effect $ do S.concat $ S.mapM ( \(DataRows rowColumnData) -> - case Parser.parseOnly (Parser.parseMany rowparser <* Parser.endOfInput "DataRows") rowColumnData of + case Parser.parseOnly (Parser.parseMany rowparser <* Parser.endOfInput) rowColumnData of Parser.ParseOk rows -> pure rows Parser.ParseFail err -> throwIrrecoverableErrorWithStatement qText $ "Failed parsing a row: " <> Text.pack (show err) ) diff --git a/hpgsql/src/Hpgsql/SimpleParser.hs b/hpgsql/src/Hpgsql/SimpleParser.hs index 28fec4d..5c9e499 100644 --- a/hpgsql/src/Hpgsql/SimpleParser.hs +++ b/hpgsql/src/Hpgsql/SimpleParser.hs @@ -249,9 +249,9 @@ parseManyRows = Parser $ \idx' bs' _kf ks -> let restIdx = go idx' bs' in ks res {-# INLINE parseManyRows #-} -- | Succeeds only when the input has been fully consumed. -endOfInput :: String -> Parser () -endOfInput debugFail = Parser $ \idx bs kf ks -> - if BS.length bs <= idx.idx then ks () idx bs else kf $ "endOfInput: input remaining (" ++ debugFail ++ ")" +endOfInput :: Parser () +endOfInput = Parser $ \idx bs kf ks -> + if BS.length bs <= idx.idx then ks () idx bs else kf "endOfInput: input remaining" {-# INLINE endOfInput #-} -- | Run a parser and additionally return the slice of input it consumed. diff --git a/hpgsql/src/Hpgsql/Types.hs b/hpgsql/src/Hpgsql/Types.hs index ad19e16..8cc68ce 100644 --- a/hpgsql/src/Hpgsql/Types.hs +++ b/hpgsql/src/Hpgsql/Types.hs @@ -89,9 +89,8 @@ instance FromPgField PgJson where \FieldInfo {fieldTypeOid} -> let -- jsonb has a byte prepended to the contents and json does not !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in \case - Just bs -> Right $ Just $ PgJson $ fixJsonb bs - Nothing -> pure Nothing, -- Left "Cannot decode SQL null as the Haskell PgJson type. Use a `Maybe PgJson` if you want SQL nulls", + in \bs -> Right $ PgJson $ fixJsonb bs, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell PgJson type. Use a `Maybe PgJson` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } @@ -109,11 +108,10 @@ instance (FromJSON a) => FromPgField (Aeson a) where \FieldInfo {fieldTypeOid} -> let -- jsonb has a byte prepended to the contents and json does not !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in \case - Just bs -> case Aeson.decodeStrict $ fixJsonb bs of - Just v -> Right $ Just $ Aeson v - Nothing -> Left "Failed to decode postgres JSON value into your `Aeson a` type. Are you sure it's proper JSON?" - Nothing -> Right Nothing, -- Left "Cannot decode SQL null as a Haskell (Aeson a) type. Use a `Maybe (Aeson a)` if you want SQL nulls", + in \bs -> case Aeson.decodeStrict $ fixJsonb bs of + Just v -> Right $ Aeson v + Nothing -> Left "Failed to decode postgres JSON value into your `Aeson a` type. Are you sure it's proper JSON?", + decodesSqlNullTo = Left "Cannot decode SQL null as a Haskell (Aeson a) type. Use a `Maybe (Aeson a)` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } From 8a0684d89cf05c4c4136c2106056479844d83aa4 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Tue, 18 Aug 2026 18:18:30 -0300 Subject: [PATCH 22/35] Try to improve the code, but inlining got worse --- hpgsql-benchmarks/src/Main.hs | 2 +- hpgsql-tests/RowDecoderGhcCore.hs | 2 +- hpgsql/src/Hpgsql/Encoding.hs | 256 ++++++++++++++++-------------- 3 files changed, 140 insertions(+), 120 deletions(-) diff --git a/hpgsql-benchmarks/src/Main.hs b/hpgsql-benchmarks/src/Main.hs index 25672a8..9150240 100644 --- a/hpgsql-benchmarks/src/Main.hs +++ b/hpgsql-benchmarks/src/Main.hs @@ -47,7 +47,7 @@ import Hpgsql.Connection (renderLibpqConnectionString) import qualified Hpgsql.Connection import qualified Hpgsql.Connection as Hpgsql import qualified Hpgsql.Copy -import Hpgsql.Encoding (FromPgField (inlinedSingleFieldRowDecoder)) +import Hpgsql.Encoding (inlinedSingleFieldRowDecoder) import qualified Hpgsql.Encoding as Hpgsql import qualified Hpgsql.Query as Hpgsql import qualified Hpgsql.Types as Hpgsql diff --git a/hpgsql-tests/RowDecoderGhcCore.hs b/hpgsql-tests/RowDecoderGhcCore.hs index 512efc8..e10493c 100644 --- a/hpgsql-tests/RowDecoderGhcCore.hs +++ b/hpgsql-tests/RowDecoderGhcCore.hs @@ -10,7 +10,7 @@ import Data.Int (Int64) import Data.Text (Text) import Data.Time (Day, UTCTime) import GHC.Generics (Generic) -import Hpgsql.Encoding (FromPgField (..), FromPgRow (..), genericFromPgRow, singleField) +import Hpgsql.Encoding (FromPgField (..), FromPgRow (..), genericFromPgRow, inlinedSingleFieldRowDecoder, singleField) -- | BestCaseScenarioRecord's purpose is to have a very small row decoder in GHC Core -- for my own understanding/comprehension of what a RowDecoder gets compiled to diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index fc9513e..6592c42 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -27,6 +27,7 @@ module Hpgsql.Encoding FromPgRow (..), RowDecoder (..), -- TODO: Can we export ctor? singleField, + singleFieldRowDecoder, nullableField, genericFromPgRow, @@ -78,6 +79,7 @@ import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Data.Coerce (coerce) import Data.Fixed (divMod') +import Data.Functor ((<&>)) import Data.Functor.Contravariant (Contravariant (..)) import Data.Int (Int16, Int32, Int64) import qualified Data.List as List @@ -159,7 +161,7 @@ instance Applicative RowDecoder where instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in Hpgsql because Hpgsql type-checks the result types of queries before having access to even the first data row. Use the Applicative class to write your instances or use the Monadic decoding variants.")) => Monad RowDecoder where (>>=) = error "inaccessible bind in Monad RowDecoder instance" -{-# INLINE singleField #-} -- 1.2% wall time perf. gain with this +{-# INLINE singleField #-} singleField :: FieldDecoder a -> RowDecoder a singleField fdec = RowDecoder @@ -208,24 +210,63 @@ inlinableRowDecoder tyoids p = } class FromPgField a where - -- | A decoder that takes + {-# MINIMAL fieldDecoder #-} fieldDecoder :: FieldDecoder a - -- | This should be semantically equivalent to `singleField fieldDecoder`, and - -- it is automatically derived to be exactly that. - -- So as a user, you don't need to override this. - -- This field exists for a performance optimization within hpgsql, or for users - -- that really know what they're doing. - singleFieldRowDecoder :: RowDecoder a - singleFieldRowDecoder = singleField fieldDecoder - - -- | This is just like `singleFieldDecoder`, but it inlines into your - -- `FromPgRow` instances aggressively. This will increase code size and + -- | This should be semantically equivalent to `singleField fieldDecoder`, + -- but it can be overridden (and is for base types) to a much faster implementation. + -- Using this when deriving your `FromPgRow` instances will increase code size and -- possibly compilation times somewhat, but in some cases it can make row decoders -- compile down to a ByteString-peeking implementation with much fewer - -- allocations that can be ~10% faster than the other. + -- allocations and thus better performance. + -- Any implementation of this _must_ return a `Nothing` for a SQL NULL value, + -- regardless of what `FieldDecoder` would do with a SQL NULL. + -- TODO: Move this to inside the FieldDecoder type? + {-# INLINE fastFieldDecoder #-} + fastFieldDecoder :: RowDecoder (Maybe a) + fastFieldDecoder = + let fdec = fieldDecoder + in RowDecoder + { fullRowDecoder = \case + [singleColInfo] -> do + len <- Parser.takeInt32BE + if len == (-1) + then pure Nothing + else do + bs <- Parser.take (fromIntegral len) + case fdec.fieldValueDecoder singleColInfo bs of + Left err -> fail err + Right v -> pure v + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, fdec.allowedPgTypes singleColInfo)] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } + + {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder :: RowDecoder a - inlinedSingleFieldRowDecoder = singleFieldRowDecoder + inlinedSingleFieldRowDecoder = + let fastrdec = fastFieldDecoder @a + in do + RowDecoder + { fullRowDecoder = \finfos -> do + mv <- fastrdec.fullRowDecoder finfos + case mv of + -- This `case` is why we require `fastFieldDecoder` to decode + -- SQL NULL into `Nothing`: we do check decodesSqlNullTo. + Nothing -> case fieldDecoder.decodesSqlNullTo of + Left err -> fail err -- Type doesn't accept NULLs + Right v -> pure v + Just v -> pure v, + rowColumnsTypeCheck = fastrdec.rowColumnsTypeCheck, + numExpectedColumns = fastrdec.numExpectedColumns + } + +-- TODO: better name for `singleFieldRowDecoder`? +{-# NOINLINE singleFieldRowDecoder #-} +singleFieldRowDecoder :: forall a. (FromPgField a) => RowDecoder a +singleFieldRowDecoder = inlinedSingleFieldRowDecoder class FromPgRow a where rowDecoder :: RowDecoder a @@ -805,6 +846,7 @@ instance FromPgField () where allowedPgTypes = (== voidOid) . fieldTypeOid } +-- TODO: Inline intRowDecoder into FromPgField? And all others too? {-# INLINE intRowDecoder #-} intRowDecoder :: RowDecoder (Maybe Int) intRowDecoder = @@ -828,8 +870,8 @@ instance FromPgField Int where decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int type. Use a `Maybe Int`", allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid } - {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = inlinedSingleFieldRowDecoder + {-# INLINE fastFieldDecoder #-} + fastFieldDecoder = intRowDecoder {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = nonNullableRowDec "Int" intRowDecoder @@ -846,10 +888,8 @@ instance FromPgField Int where -- -- Nothing -> Right Nothing, -- -- allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid -- -- } --- {-# NOINLINE singleFieldRowDecoder #-} --- singleFieldRowDecoder = inlinedSingleFieldRowDecoder --- {-# INLINE inlinedSingleFieldRowDecoder #-} --- inlinedSingleFieldRowDecoder = intRowDecoder +-- {-# INLINE fastFieldDecoder #-} +-- fastFieldDecoder = intRowDecoder instance FromPgField Int16 where fieldDecoder = @@ -862,14 +902,14 @@ instance FromPgField Int16 where } {-# INLINE int32RowDecoder #-} -int32RowDecoder :: RowDecoder Int32 +int32RowDecoder :: RowDecoder (Maybe Int32) int32RowDecoder = inlinableRowDecoder [int2Oid, int4Oid] $ do fieldLen <- Parser.takeInt32BE case fieldLen of - 4 -> Parser.takeInt32BE - (-1) -> fail "Cannot decode SQL null as the Haskell Int32 type. Use a `Maybe Int32`" - 2 -> fromIntegral <$> Parser.takeInt16BE + 4 -> Just <$> Parser.takeInt32BE + (-1) -> pure Nothing + 2 -> Just . fromIntegral <$> Parser.takeInt16BE _ -> fail "Trying to decode PG int4 but it's not 2 or 4 bytes long" instance FromPgField Int32 where @@ -879,21 +919,19 @@ instance FromPgField Int32 where decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int32 type. Use a `Maybe Int32`", allowedPgTypes = (`elem` [int2Oid, int4Oid]) . fieldTypeOid } - {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = int32RowDecoder - {-# INLINE inlinedSingleFieldRowDecoder #-} - inlinedSingleFieldRowDecoder = int32RowDecoder + {-# INLINE fastFieldDecoder #-} + fastFieldDecoder = int32RowDecoder {-# INLINE int64RowDecoder #-} -int64RowDecoder :: RowDecoder Int64 +int64RowDecoder :: RowDecoder (Maybe Int64) int64RowDecoder = inlinableRowDecoder [int2Oid, int4Oid, int8Oid] $ do fieldLen <- Parser.takeInt32BE case fieldLen of - 8 -> Parser.takeInt64BE - 4 -> fromIntegral <$> Parser.takeInt32BE - (-1) -> fail "Cannot decode SQL null as the Haskell Int64 type. Use a `Maybe Int64`" - 2 -> fromIntegral <$> Parser.takeInt16BE + 8 -> Just <$> Parser.takeInt64BE + 4 -> Just . fromIntegral <$> Parser.takeInt32BE + (-1) -> pure Nothing + 2 -> Just . fromIntegral <$> Parser.takeInt16BE _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" instance FromPgField Int64 where @@ -903,10 +941,8 @@ instance FromPgField Int64 where decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int64 type. Use a `Maybe Int64`", allowedPgTypes = (`elem` [int2Oid, int4Oid, int8Oid]) . fieldTypeOid } - {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = int64RowDecoder - {-# INLINE inlinedSingleFieldRowDecoder #-} - inlinedSingleFieldRowDecoder = int64RowDecoder + {-# INLINE fastFieldDecoder #-} + fastFieldDecoder = int64RowDecoder instance FromPgField Integer where fieldDecoder = @@ -941,19 +977,15 @@ floatRowDecoder = instance FromPgField Float where fieldDecoder = parsePgType "Float" [float4Oid] $ Right . binaryFloat4Decoder - {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = inlinedSingleFieldRowDecoder - {-# INLINE inlinedSingleFieldRowDecoder #-} - inlinedSingleFieldRowDecoder = nonNullableRowDec "Float" floatRowDecoder + {-# INLINE fastFieldDecoder #-} + fastFieldDecoder = floatRowDecoder -- instance {-# OVERLAPPING #-} FromPgField (Maybe Float) where -- -- This overlapping instance isn't pretty, but it reduces memory -- -- usage and improves performance a bit -- fieldDecoder = error "TODO Maybe Float" --- {-# NOINLINE singleFieldRowDecoder #-} --- singleFieldRowDecoder = inlinedSingleFieldRowDecoder --- {-# INLINE inlinedSingleFieldRowDecoder #-} --- inlinedSingleFieldRowDecoder = floatRowDecoder +-- {-# INLINE fastFieldDecoder #-} +-- fastFieldDecoder = floatRowDecoder {-# INLINE doubleRowDecoder #-} doubleRowDecoder :: RowDecoder (Maybe Double) @@ -977,8 +1009,8 @@ instance FromPgField Double where decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`", allowedPgTypes = (`elem` [float8Oid, float4Oid]) . fieldTypeOid } - {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = inlinedSingleFieldRowDecoder + {-# INLINE fastFieldDecoder #-} + fastFieldDecoder = doubleRowDecoder {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = nonNullableRowDec "Double" doubleRowDecoder @@ -986,10 +1018,8 @@ instance FromPgField Double where -- -- This overlapping instance isn't pretty, but it reduces memory -- -- usage and improves performance a bit -- fieldDecoder = error "TODO Maybe Double" --- {-# NOINLINE singleFieldRowDecoder #-} --- singleFieldRowDecoder = inlinedSingleFieldRowDecoder --- {-# INLINE inlinedSingleFieldRowDecoder #-} --- inlinedSingleFieldRowDecoder = doubleRowDecoder +-- {-# INLINE fastFieldDecoder #-} +-- fastFieldDecoder = doubleRowDecoder -- | Allows you to specify a type (and other checks, possibly) for a `FieldDecoder`. -- This can be useful to ensure you're not accidentally decoding a different type. @@ -1033,12 +1063,12 @@ scientificDecoder mustBeInteger = do parseAndMult (ndigitsLeft - 1) (currexpon - 4) (val + scientific digit currexpon) {-# INLINE numericRowParser #-} -numericRowParser :: Parser.Parser Scientific +numericRowParser :: Parser.Parser (Maybe Scientific) numericRowParser = do fieldLen <- Parser.takeInt32BE case fieldLen of - (-1) -> fail "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`" - _ -> scientificDecoder False + (-1) -> pure Nothing + _ -> Just <$> scientificDecoder False instance FromPgField Scientific where -- See https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/numeric.c#L1163 @@ -1059,14 +1089,14 @@ instance FromPgField Scientific where decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`", allowedPgTypes = (`elem` [numericOid, int2Oid, int4Oid, int8Oid]) . fieldTypeOid } - {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = + {-# INLINE fastFieldDecoder #-} + fastFieldDecoder = RowDecoder { fullRowDecoder = \case [singleColInfo] -> if singleColInfo.fieldTypeOid /= numericOid then - flip scientific 0 . fromIntegral <$> (inlinedSingleFieldRowDecoder @Int64).fullRowDecoder [singleColInfo] + fmap (flip scientific 0 . fromIntegral) <$> (fastFieldDecoder @Int64).fullRowDecoder [singleColInfo] else numericRowParser _ -> error "singleField expected a single column OID but got 0 or >1", rowColumnsTypeCheck = \case @@ -1088,19 +1118,15 @@ boolRowDecoder = instance FromPgField Bool where fieldDecoder = parsePgType "Bool" [boolOid] $ \bs -> Right $ bs == binaryTrue - {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = inlinedSingleFieldRowDecoder - {-# INLINE inlinedSingleFieldRowDecoder #-} - inlinedSingleFieldRowDecoder = nonNullableRowDec "Bool" boolRowDecoder + {-# INLINE fastFieldDecoder #-} + fastFieldDecoder = boolRowDecoder -- instance {-# OVERLAPPING #-} FromPgField (Maybe Bool) where -- -- This overlapping instance isn't pretty, but it reduces memory -- -- usage and improves performance a bit -- fieldDecoder = error "TODO Maybe Bool" --- {-# NOINLINE singleFieldRowDecoder #-} --- singleFieldRowDecoder = inlinedSingleFieldRowDecoder --- {-# INLINE inlinedSingleFieldRowDecoder #-} --- inlinedSingleFieldRowDecoder = boolRowDecoder +-- {-# INLINE fastFieldDecoder #-} +-- fastFieldDecoder = boolRowDecoder instance FromPgField Char where fieldDecoder = @@ -1140,19 +1166,15 @@ textDecoder = instance FromPgField Text where -- TODO: Use some faster unsafeDecodeUtf8 function? fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ decodeUtf8 bs - {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = inlinedSingleFieldRowDecoder - {-# INLINE inlinedSingleFieldRowDecoder #-} - inlinedSingleFieldRowDecoder = nonNullableRowDec "Text" textDecoder + {-# INLINE fastFieldDecoder #-} + fastFieldDecoder = textDecoder -- instance {-# OVERLAPPING #-} FromPgField (Maybe Text) where -- -- This overlapping instance isn't pretty, but it reduces memory -- -- usage and improves performance a bit -- fieldDecoder = error "TODO Maybe Text" --- {-# NOINLINE singleFieldRowDecoder #-} --- singleFieldRowDecoder = inlinedSingleFieldRowDecoder --- {-# INLINE inlinedSingleFieldRowDecoder #-} --- inlinedSingleFieldRowDecoder = textDecoder +-- {-# INLINE fastFieldDecoder #-} +-- fastFieldDecoder = textDecoder instance FromPgField LT.Text where -- TODO: Use some faster unsafeDecodeUtf8 function? @@ -1198,19 +1220,15 @@ instance FromPgField UTCTime where let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 Right $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = inlinedSingleFieldRowDecoder - {-# NOINLINE inlinedSingleFieldRowDecoder #-} - inlinedSingleFieldRowDecoder = nonNullableRowDec "UTCTime" utcTimeRowDecoder + {-# NOINLINE fastFieldDecoder #-} + fastFieldDecoder = utcTimeRowDecoder -- instance {-# OVERLAPPING #-} FromPgField (Maybe UTCTime) where -- -- This overlapping instance isn't pretty, but it reduces memory -- -- usage and improves performance a bit -- fieldDecoder = error "TODO Maybe UTCTime" --- {-# NOINLINE singleFieldRowDecoder #-} --- singleFieldRowDecoder = inlinedSingleFieldRowDecoder --- {-# INLINE inlinedSingleFieldRowDecoder #-} --- inlinedSingleFieldRowDecoder = utcTimeRowDecoder +-- {-# INLINE fastFieldDecoder #-} +-- fastFieldDecoder = utcTimeRowDecoder instance FromPgField (Unbounded UTCTime) where fieldDecoder = parsePgType "Unbounded UTCTime" [timestamptzOid] $ \case @@ -1281,8 +1299,8 @@ instance FromPgField Day where -- But I found a simpler way to do this. Let's see if it works in our property based tests jd <- BinSer.decodeInt32BE 0 bs Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 - {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = inlinedSingleFieldRowDecoder + {-# INLINE fastFieldDecoder #-} + fastFieldDecoder = dayRowDecoder {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder = nonNullableRowDec "Day" dayRowDecoder @@ -1290,10 +1308,8 @@ instance FromPgField Day where -- -- This overlapping instance isn't pretty, but it reduces memory -- -- usage and improves performance a bit -- fieldDecoder = error "TODO Maybe Day" --- {-# NOINLINE singleFieldRowDecoder #-} --- singleFieldRowDecoder = inlinedSingleFieldRowDecoder --- {-# INLINE inlinedSingleFieldRowDecoder #-} --- inlinedSingleFieldRowDecoder = dayRowDecoder +-- {-# INLINE fastFieldDecoder #-} +-- fastFieldDecoder = dayRowDecoder instance FromPgField (Unbounded Day) where fieldDecoder = parsePgType "Unbounded Day" [dateOid] $ \case @@ -1366,37 +1382,41 @@ nonNullableRowDec haskellTypeName rdec = instance (FromPgField a) => FromPgField (Maybe a) where fieldDecoder = nullableField fieldDecoder - {-# NOINLINE singleFieldRowDecoder #-} - singleFieldRowDecoder = inlinedSingleFieldRowDecoder - {-# INLINE inlinedSingleFieldRowDecoder #-} - inlinedSingleFieldRowDecoder = - RowDecoder - { fullRowDecoder = \finfos -> - let frd = inlinedSingleFieldRowDecoder.fullRowDecoder finfos - in do - -- TODO: We're decoding the field length twice with - -- the peek call when the value isn't NULL. - -- Maybe we should make `FromPgField`'s new methods - -- be two `Parser` objects: one for both length and field - -- and another only for the field (but how would that work - -- without the length..? It wouldn't.) - -- Maybe we do the `Parser (Maybe a)` for `a` types, then. - -- We can build a `Parser a` from that with `decodesSqlNullTo` - -- and with inlining there's nothing to lose? - fieldLen <- Parser.peekInt32BE - if fieldLen == (-1) - then case fieldDecoder.decodesSqlNullTo of - Left err -> fail err - Right v -> Parser.skip 4 >> pure v - else do - Just <$> frd, - rowColumnsTypeCheck = - let fdec = fieldDecoder @a - in \case - [singleColInfo] -> [(singleColInfo, fdec.allowedPgTypes singleColInfo)] - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", - numExpectedColumns = 1 - } + {-# INLINE fastFieldDecoder #-} + fastFieldDecoder = + fastFieldDecoder <&> \case + Nothing -> Nothing + Just v -> Just (Just v) + +-- let ffdec = fastFieldDecoder @a +-- in +-- RowDecoder +-- { fullRowDecoder = \finfos -> +-- let frd = fastFieldDecoder.fullRowDecoder finfos +-- in do +-- -- TODO: We're decoding the field length twice with +-- -- the peek call when the value isn't NULL. +-- -- Maybe we should make `FromPgField`'s new methods +-- -- be two `Parser` objects: one for both length and field +-- -- and another only for the field (but how would that work +-- -- without the length..? It wouldn't.) +-- -- Maybe we do the `Parser (Maybe a)` for `a` types, then. +-- -- We can build a `Parser a` from that with `decodesSqlNullTo` +-- -- and with inlining there's nothing to lose? +-- fieldLen <- Parser.peekInt32BE +-- if fieldLen == (-1) +-- then case fieldDecoder.decodesSqlNullTo of +-- Left err -> fail err +-- Right v -> Parser.skip 4 >> pure v +-- else do +-- Just <$> frd, +-- rowColumnsTypeCheck = +-- let fdec = fieldDecoder @a +-- in \case +-- [singleColInfo] -> [(singleColInfo, fdec.allowedPgTypes singleColInfo)] +-- _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", +-- numExpectedColumns = 1 +-- } allowOnlyArrayTypes :: FieldInfo -> Bool allowOnlyArrayTypes fieldInfo = From 52d7670da3dba225d0db68e606238ca31fd6599c Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Wed, 19 Aug 2026 15:26:08 -0300 Subject: [PATCH 23/35] Some memory usage improvements Let's see if this is better than the OVERLAPPING instances --- hpgsql/src/Hpgsql/Encoding.hs | 275 +++++++++++++++++++--------------- 1 file changed, 155 insertions(+), 120 deletions(-) diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index 6592c42..c03253c 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -28,6 +28,7 @@ module Hpgsql.Encoding RowDecoder (..), -- TODO: Can we export ctor? singleField, singleFieldRowDecoder, + inlinedSingleFieldRowDecoder, nullableField, genericFromPgRow, @@ -79,7 +80,6 @@ import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Data.Coerce (coerce) import Data.Fixed (divMod') -import Data.Functor ((<&>)) import Data.Functor.Contravariant (Contravariant (..)) import Data.Int (Int16, Int32, Int64) import qualified Data.List as List @@ -176,6 +176,8 @@ singleField fdec = case decode nextColBs of Right v -> pure v Left err -> fail err + -- This `case` is why we require `fieldAndValueDecoder` to decode + -- SQL NULL into `Nothing`: we do check decodesSqlNullTo. else case fdec.decodesSqlNullTo of Right v -> pure v Left err -> fail err @@ -222,48 +224,67 @@ class FromPgField a where -- Any implementation of this _must_ return a `Nothing` for a SQL NULL value, -- regardless of what `FieldDecoder` would do with a SQL NULL. -- TODO: Move this to inside the FieldDecoder type? - {-# INLINE fastFieldDecoder #-} - fastFieldDecoder :: RowDecoder (Maybe a) - fastFieldDecoder = - let fdec = fieldDecoder - in RowDecoder - { fullRowDecoder = \case - [singleColInfo] -> do - len <- Parser.takeInt32BE - if len == (-1) - then pure Nothing - else do - bs <- Parser.take (fromIntegral len) - case fdec.fieldValueDecoder singleColInfo bs of - Left err -> fail err - Right v -> pure v - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", - rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, fdec.allowedPgTypes singleColInfo)] - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", - numExpectedColumns = 1 - } + {-# NOINLINE fieldAndValueDecoder #-} + fieldAndValueDecoder :: RowDecoder (Maybe a) + fieldAndValueDecoder = + RowDecoder + { fullRowDecoder = + case inlinedConstFieldDecoder of + Nothing -> slowerParser + Just fd -> const fd, + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, (fieldDecoder @a).allowedPgTypes singleColInfo)] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } + where + -- slowerParser takes a ByteString and passes it to the + -- field decoder. + slowerParser = \case + [singleColInfo] -> do + len <- Parser.takeInt32BE + if len == (-1) + then pure Nothing + else do + bs <- Parser.take (fromIntegral len) + case fieldDecoder.fieldValueDecoder singleColInfo bs of + Left err -> fail err + Right v -> pure v + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1" + + {-# INLINE inlinedConstFieldDecoder #-} + + -- | For types where there is a fast way to decode fields+values + -- without knowing the OID of the value in the query (of course, the + -- possible OIDs are still limited by the FieldDecoder's allowed types), + -- this can help provide a significant boost to inlined row decoders. + -- Define as `Nothing` if this isn't possible. + inlinedConstFieldDecoder :: Maybe (Parser.Parser (Maybe a)) + inlinedConstFieldDecoder = Nothing {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder :: RowDecoder a - inlinedSingleFieldRowDecoder = - let fastrdec = fastFieldDecoder @a - in do - RowDecoder - { fullRowDecoder = \finfos -> do - mv <- fastrdec.fullRowDecoder finfos + inlinedSingleFieldRowDecoder = case inlinedConstFieldDecoder @a of + Nothing -> singleField fieldDecoder + Just p -> + let fdec = fieldDecoder @a + in RowDecoder + { fullRowDecoder = const $ do + mv <- p case mv of - -- This `case` is why we require `fastFieldDecoder` to decode - -- SQL NULL into `Nothing`: we do check decodesSqlNullTo. - Nothing -> case fieldDecoder.decodesSqlNullTo of - Left err -> fail err -- Type doesn't accept NULLs + Nothing -> case fdec.decodesSqlNullTo of + Left err -> fail err Right v -> pure v Just v -> pure v, - rowColumnsTypeCheck = fastrdec.rowColumnsTypeCheck, - numExpectedColumns = fastrdec.numExpectedColumns + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, fdec.allowedPgTypes singleColInfo)] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 } --- TODO: better name for `singleFieldRowDecoder`? +-- TODO: better name for `singleFieldRowDecoder`? We have 3 methods now +-- to create a single field RowDecoder, what a mess! Figure out names +-- and code docs. {-# NOINLINE singleFieldRowDecoder #-} singleFieldRowDecoder :: forall a. (FromPgField a) => RowDecoder a singleFieldRowDecoder = inlinedSingleFieldRowDecoder @@ -848,20 +869,20 @@ instance FromPgField () where -- TODO: Inline intRowDecoder into FromPgField? And all others too? {-# INLINE intRowDecoder #-} -intRowDecoder :: RowDecoder (Maybe Int) -intRowDecoder = - inlinableRowDecoder haskellIntOids $ do - fieldLen <- Parser.takeInt32BE - -- TODO: We're assuming `Int` is always 64 bits, so 64bit CPUs? Is that ok? - -- TODO: Is there a way to optimistically assume <=4 bytes and use our custom new parser? - case fieldLen of - 4 -> Just . fromIntegral <$> Parser.takeInt32BE - (-1) -> pure Nothing - 8 -> Just . fromIntegral <$> Parser.takeInt64BE - 2 -> Just . fromIntegral <$> Parser.takeInt16BE - _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" +intRowDecoder :: Parser.Parser (Maybe Int) +intRowDecoder = do + fieldLen <- Parser.takeInt32BE + -- TODO: We're assuming `Int` is always 64 bits, so 64bit CPUs? Is that ok? + -- TODO: Is there a way to optimistically assume <=4 bytes and use our custom new parser? + case fieldLen of + 4 -> Just . fromIntegral <$> Parser.takeInt32BE + (-1) -> pure Nothing + 8 -> Just . fromIntegral <$> Parser.takeInt64BE + 2 -> Just . fromIntegral <$> Parser.takeInt16BE + _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" instance FromPgField Int where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> @@ -870,10 +891,11 @@ instance FromPgField Int where decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int type. Use a `Maybe Int`", allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid } - {-# INLINE fastFieldDecoder #-} - fastFieldDecoder = intRowDecoder - {-# INLINE inlinedSingleFieldRowDecoder #-} - inlinedSingleFieldRowDecoder = nonNullableRowDec "Int" intRowDecoder + + -- {-# INLINE fieldAndValueDecoder #-} + -- fieldAndValueDecoder = intRowDecoder + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just intRowDecoder -- instance {-# OVERLAPPING #-} FromPgField (Maybe Int) where -- -- This overlapping instance isn't pretty, but it reduces memory @@ -888,8 +910,8 @@ instance FromPgField Int where -- -- Nothing -> Right Nothing, -- -- allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid -- -- } --- {-# INLINE fastFieldDecoder #-} --- fastFieldDecoder = intRowDecoder +-- {-# INLINE fieldAndValueDecoder #-} +-- fieldAndValueDecoder = intRowDecoder instance FromPgField Int16 where fieldDecoder = @@ -919,8 +941,8 @@ instance FromPgField Int32 where decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int32 type. Use a `Maybe Int32`", allowedPgTypes = (`elem` [int2Oid, int4Oid]) . fieldTypeOid } - {-# INLINE fastFieldDecoder #-} - fastFieldDecoder = int32RowDecoder + {-# INLINE fieldAndValueDecoder #-} + fieldAndValueDecoder = int32RowDecoder {-# INLINE int64RowDecoder #-} int64RowDecoder :: RowDecoder (Maybe Int64) @@ -941,8 +963,8 @@ instance FromPgField Int64 where decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int64 type. Use a `Maybe Int64`", allowedPgTypes = (`elem` [int2Oid, int4Oid, int8Oid]) . fieldTypeOid } - {-# INLINE fastFieldDecoder #-} - fastFieldDecoder = int64RowDecoder + {-# INLINE fieldAndValueDecoder #-} + fieldAndValueDecoder = int64RowDecoder instance FromPgField Integer where fieldDecoder = @@ -970,33 +992,32 @@ instance FromPgField Oid where allowedPgTypes = (== oidOid) . fieldTypeOid } -{-# INLINE floatRowDecoder #-} -floatRowDecoder :: RowDecoder (Maybe Float) -floatRowDecoder = - inlinableRowDecoder [float4Oid] Parser.takeFloatBEWithFieldLength +-- {-# INLINE floatRowDecoder #-} +-- floatRowDecoder :: Parser.Parser (Maybe Float) +-- floatRowDecoder = Parser.takeFloatBEWithFieldLength instance FromPgField Float where fieldDecoder = parsePgType "Float" [float4Oid] $ Right . binaryFloat4Decoder - {-# INLINE fastFieldDecoder #-} - fastFieldDecoder = floatRowDecoder + -- {-# INLINE fieldAndValueDecoder #-} + -- fieldAndValueDecoder = floatRowDecoder + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just Parser.takeFloatBEWithFieldLength -- instance {-# OVERLAPPING #-} FromPgField (Maybe Float) where -- -- This overlapping instance isn't pretty, but it reduces memory -- -- usage and improves performance a bit -- fieldDecoder = error "TODO Maybe Float" --- {-# INLINE fastFieldDecoder #-} --- fastFieldDecoder = floatRowDecoder +-- {-# INLINE fieldAndValueDecoder #-} +-- fieldAndValueDecoder = floatRowDecoder {-# INLINE doubleRowDecoder #-} -doubleRowDecoder :: RowDecoder (Maybe Double) -doubleRowDecoder = - let float4OrDouble8Decoder = do - len <- Parser.takeInt32BE - case len of - 8 -> Just <$> Parser.takeDoubleBE - 4 -> Just . float2Double <$> Parser.takeFloatBE - _ -> pure Nothing - in inlinableRowDecoder [float8Oid, float4Oid] float4OrDouble8Decoder +doubleRowDecoder :: Parser.Parser (Maybe Double) +doubleRowDecoder = do + len <- Parser.takeInt32BE + case len of + 8 -> Just <$> Parser.takeDoubleBE + 4 -> Just . float2Double <$> Parser.takeFloatBE + _ -> pure Nothing instance FromPgField Double where fieldDecoder = @@ -1009,17 +1030,18 @@ instance FromPgField Double where decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`", allowedPgTypes = (`elem` [float8Oid, float4Oid]) . fieldTypeOid } - {-# INLINE fastFieldDecoder #-} - fastFieldDecoder = doubleRowDecoder - {-# INLINE inlinedSingleFieldRowDecoder #-} - inlinedSingleFieldRowDecoder = nonNullableRowDec "Double" doubleRowDecoder + + -- {-# INLINE fieldAndValueDecoder #-} + -- fieldAndValueDecoder = doubleRowDecoder + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just doubleRowDecoder -- instance {-# OVERLAPPING #-} FromPgField (Maybe Double) where -- -- This overlapping instance isn't pretty, but it reduces memory -- -- usage and improves performance a bit -- fieldDecoder = error "TODO Maybe Double" --- {-# INLINE fastFieldDecoder #-} --- fastFieldDecoder = doubleRowDecoder +-- {-# INLINE fieldAndValueDecoder #-} +-- fieldAndValueDecoder = doubleRowDecoder -- | Allows you to specify a type (and other checks, possibly) for a `FieldDecoder`. -- This can be useful to ensure you're not accidentally decoding a different type. @@ -1089,14 +1111,14 @@ instance FromPgField Scientific where decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`", allowedPgTypes = (`elem` [numericOid, int2Oid, int4Oid, int8Oid]) . fieldTypeOid } - {-# INLINE fastFieldDecoder #-} - fastFieldDecoder = + {-# INLINE fieldAndValueDecoder #-} + fieldAndValueDecoder = RowDecoder { fullRowDecoder = \case [singleColInfo] -> if singleColInfo.fieldTypeOid /= numericOid then - fmap (flip scientific 0 . fromIntegral) <$> (fastFieldDecoder @Int64).fullRowDecoder [singleColInfo] + fmap (flip scientific 0 . fromIntegral) <$> (fieldAndValueDecoder @Int64).fullRowDecoder [singleColInfo] else numericRowParser _ -> error "singleField expected a single column OID but got 0 or >1", rowColumnsTypeCheck = \case @@ -1112,21 +1134,22 @@ binaryTrue :: ByteString binaryTrue = BinSer.encodePgBoolean True {-# INLINE boolRowDecoder #-} -boolRowDecoder :: RowDecoder (Maybe Bool) -boolRowDecoder = - inlinableRowDecoder [boolOid] $ fmap (== 1) <$> Parser.parsePgFieldWithAtMost4Bytes BinSer.TypeSize1 +boolRowDecoder :: Parser.Parser (Maybe Bool) +boolRowDecoder = fmap (== 1) <$> Parser.parsePgFieldWithAtMost4Bytes BinSer.TypeSize1 instance FromPgField Bool where fieldDecoder = parsePgType "Bool" [boolOid] $ \bs -> Right $ bs == binaryTrue - {-# INLINE fastFieldDecoder #-} - fastFieldDecoder = boolRowDecoder + -- {-# INLINE fieldAndValueDecoder #-} + -- fieldAndValueDecoder = boolRowDecoder + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just boolRowDecoder -- instance {-# OVERLAPPING #-} FromPgField (Maybe Bool) where -- -- This overlapping instance isn't pretty, but it reduces memory -- -- usage and improves performance a bit -- fieldDecoder = error "TODO Maybe Bool" --- {-# INLINE fastFieldDecoder #-} --- fastFieldDecoder = boolRowDecoder +-- {-# INLINE fieldAndValueDecoder #-} +-- fieldAndValueDecoder = boolRowDecoder instance FromPgField Char where fieldDecoder = @@ -1154,9 +1177,8 @@ instance FromPgField LBS.ByteString where fieldDecoder = parsePgType "ByteString" [byteaOid] $ Right . LBS.fromStrict {-# INLINE textDecoder #-} -textDecoder :: RowDecoder (Maybe Text) -textDecoder = - inlinableRowDecoder [textOid, varcharOid, nameOid] $ do +textDecoder :: Parser.Parser (Maybe Text) +textDecoder = do len <- Parser.takeInt32BE if len >= 0 -- TODO: Use some faster unsafeDecodeUtf8 function? @@ -1166,15 +1188,17 @@ textDecoder = instance FromPgField Text where -- TODO: Use some faster unsafeDecodeUtf8 function? fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ decodeUtf8 bs - {-# INLINE fastFieldDecoder #-} - fastFieldDecoder = textDecoder + -- {-# INLINE fieldAndValueDecoder #-} + -- fieldAndValueDecoder = textDecoder + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just textDecoder -- instance {-# OVERLAPPING #-} FromPgField (Maybe Text) where -- -- This overlapping instance isn't pretty, but it reduces memory -- -- usage and improves performance a bit -- fieldDecoder = error "TODO Maybe Text" --- {-# INLINE fastFieldDecoder #-} --- fastFieldDecoder = textDecoder +-- {-# INLINE fieldAndValueDecoder #-} +-- fieldAndValueDecoder = textDecoder instance FromPgField LT.Text where -- TODO: Use some faster unsafeDecodeUtf8 function? @@ -1200,9 +1224,8 @@ instance FromPgField (CI String) where fieldDecoder = typeFieldDecoder (typeMustBeNamed "citext") $ CI.mk <$> fieldDecoder {-# INLINE utcTimeRowDecoder #-} -utcTimeRowDecoder :: RowDecoder (Maybe UTCTime) -utcTimeRowDecoder = - inlinableRowDecoder [timestamptzOid] $ do +utcTimeRowDecoder :: Parser.Parser (Maybe UTCTime) +utcTimeRowDecoder = do len <- Parser.takeInt32BE case len of 8 -> do @@ -1220,15 +1243,17 @@ instance FromPgField UTCTime where let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 Right $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - {-# NOINLINE fastFieldDecoder #-} - fastFieldDecoder = utcTimeRowDecoder + -- {-# NOINLINE fieldAndValueDecoder #-} + -- fieldAndValueDecoder = utcTimeRowDecoder + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just utcTimeRowDecoder -- instance {-# OVERLAPPING #-} FromPgField (Maybe UTCTime) where -- -- This overlapping instance isn't pretty, but it reduces memory -- -- usage and improves performance a bit -- fieldDecoder = error "TODO Maybe UTCTime" --- {-# INLINE fastFieldDecoder #-} --- fastFieldDecoder = utcTimeRowDecoder +-- {-# INLINE fieldAndValueDecoder #-} +-- fieldAndValueDecoder = utcTimeRowDecoder instance FromPgField (Unbounded UTCTime) where fieldDecoder = parsePgType "Unbounded UTCTime" [timestamptzOid] $ \case @@ -1286,10 +1311,10 @@ instance FromPgField TimeOfDay where Right $ timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral usecs * 1_000_000 {-# INLINE dayRowDecoder #-} -dayRowDecoder :: RowDecoder (Maybe Day) +dayRowDecoder :: Parser.Parser (Maybe Day) dayRowDecoder = let int32ToDay (i32 :: Int32) = let jd = fromIntegral i32 :: Integer in addJulianDurationClip (CalendarDiffDays 0 (jd - 13)) $ fromJulian 2000 01 01 - in inlinableRowDecoder [dateOid] $ fmap int32ToDay <$> Parser.takeInt32BEWithFieldLength + in fmap int32ToDay <$> Parser.takeInt32BEWithFieldLength instance FromPgField Day where fieldDecoder = parsePgType "Day" [dateOid] $ \case @@ -1299,17 +1324,18 @@ instance FromPgField Day where -- But I found a simpler way to do this. Let's see if it works in our property based tests jd <- BinSer.decodeInt32BE 0 bs Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 - {-# INLINE fastFieldDecoder #-} - fastFieldDecoder = dayRowDecoder - {-# INLINE inlinedSingleFieldRowDecoder #-} - inlinedSingleFieldRowDecoder = nonNullableRowDec "Day" dayRowDecoder + + -- {-# INLINE fieldAndValueDecoder #-} + -- fieldAndValueDecoder = dayRowDecoder + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just dayRowDecoder -- instance {-# OVERLAPPING #-} FromPgField (Maybe Day) where -- -- This overlapping instance isn't pretty, but it reduces memory -- -- usage and improves performance a bit -- fieldDecoder = error "TODO Maybe Day" --- {-# INLINE fastFieldDecoder #-} --- fastFieldDecoder = dayRowDecoder +-- {-# INLINE fieldAndValueDecoder #-} +-- fieldAndValueDecoder = dayRowDecoder instance FromPgField (Unbounded Day) where fieldDecoder = parsePgType "Unbounded Day" [dateOid] $ \case @@ -1382,17 +1408,26 @@ nonNullableRowDec haskellTypeName rdec = instance (FromPgField a) => FromPgField (Maybe a) where fieldDecoder = nullableField fieldDecoder - {-# INLINE fastFieldDecoder #-} - fastFieldDecoder = - fastFieldDecoder <&> \case - Nothing -> Nothing - Just v -> Just (Just v) - --- let ffdec = fastFieldDecoder @a + {-# INLINE inlinedConstFieldDecoder #-} + -- \| For types where there is a fast way to decode fields+values + -- without knowing the OID of the value in the query (of course, the + -- possible OIDs are still limited by the FieldDecoder's allowed types), + -- this can help provide a significant boost to inlined row decoders. + -- Define as `Nothing` if this isn't possible. + -- inlinedConstFieldDecoder :: Maybe (Parser.Parser (Maybe (Maybe a))) + inlinedConstFieldDecoder = case inlinedConstFieldDecoder @a of + Nothing -> Nothing + Just p -> Just $ do + mv <- p + case mv of + Nothing -> pure Nothing -- Must return Nothing for SQL Nulls + jv -> pure $ Just jv + +-- let ffdec = fieldAndValueDecoder @a -- in -- RowDecoder -- { fullRowDecoder = \finfos -> --- let frd = fastFieldDecoder.fullRowDecoder finfos +-- let frd = fieldAndValueDecoder.fullRowDecoder finfos -- in do -- -- TODO: We're decoding the field length twice with -- -- the peek call when the value isn't NULL. From 4d60b05284f95103f69508e4d4ad1ca05cc63871 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Wed, 19 Aug 2026 16:27:43 -0300 Subject: [PATCH 24/35] Float decodesSqlNullTo outside and add strictness for better inlining This is the prize I was looking for. Now the row decoders are built with the NULL handling parts a lot more inlined, which even means in a fully inlined row decoder we no longer box into a `Maybe a` to then case match on it and fail on `Nothing`, when the target record has a field typed as `a` (not a Maybe). --- hpgsql/src/Hpgsql/Encoding.hs | 76 +++++++++++++++++++++++++---------- 1 file changed, 55 insertions(+), 21 deletions(-) diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index c03253c..eedbaa4 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -267,17 +267,18 @@ class FromPgField a where inlinedSingleFieldRowDecoder = case inlinedConstFieldDecoder @a of Nothing -> singleField fieldDecoder Just p -> - let fdec = fieldDecoder @a + let !valueForNull = case (fieldDecoder @a).decodesSqlNullTo of + Left err -> fail err + Right v -> pure v + !typeCheck = (fieldDecoder @a).allowedPgTypes in RowDecoder { fullRowDecoder = const $ do mv <- p case mv of - Nothing -> case fdec.decodesSqlNullTo of - Left err -> fail err - Right v -> pure v + Nothing -> valueForNull Just v -> pure v, rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, fdec.allowedPgTypes singleColInfo)] + [singleColInfo] -> [(singleColInfo, typeCheck singleColInfo)] _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", numExpectedColumns = 1 } @@ -858,6 +859,7 @@ parsePgType !typeName !requiredTypeOids !fieldValueDecoder = } instance FromPgField () where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = \_oid -> \case @@ -914,6 +916,7 @@ instance FromPgField Int where -- fieldAndValueDecoder = intRowDecoder instance FromPgField Int16 where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = @@ -935,6 +938,7 @@ int32RowDecoder = _ -> fail "Trying to decode PG int4 but it's not 2 or 4 bytes long" instance FromPgField Int32 where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> binaryIntDecoder oid, @@ -957,6 +961,7 @@ int64RowDecoder = _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" instance FromPgField Int64 where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> binaryIntDecoder oid, @@ -967,6 +972,7 @@ instance FromPgField Int64 where fieldAndValueDecoder = int64RowDecoder instance FromPgField Integer where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> @@ -983,6 +989,7 @@ instance FromPgField Integer where } instance FromPgField Oid where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = \_ -> \case @@ -997,7 +1004,9 @@ instance FromPgField Oid where -- floatRowDecoder = Parser.takeFloatBEWithFieldLength instance FromPgField Float where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Float" [float4Oid] $ Right . binaryFloat4Decoder + -- {-# INLINE fieldAndValueDecoder #-} -- fieldAndValueDecoder = floatRowDecoder {-# INLINE inlinedConstFieldDecoder #-} @@ -1020,6 +1029,7 @@ doubleRowDecoder = do _ -> pure Nothing instance FromPgField Double where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> @@ -1094,6 +1104,7 @@ numericRowParser = do instance FromPgField Scientific where -- See https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/numeric.c#L1163 + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> @@ -1128,6 +1139,7 @@ instance FromPgField Scientific where } instance FromPgField (Ratio Integer) where + {-# INLINE fieldDecoder #-} fieldDecoder = toRational <$> fieldDecoder @Scientific binaryTrue :: ByteString @@ -1138,7 +1150,9 @@ boolRowDecoder :: Parser.Parser (Maybe Bool) boolRowDecoder = fmap (== 1) <$> Parser.parsePgFieldWithAtMost4Bytes BinSer.TypeSize1 instance FromPgField Bool where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Bool" [boolOid] $ \bs -> Right $ bs == binaryTrue + -- {-# INLINE fieldAndValueDecoder #-} -- fieldAndValueDecoder = boolRowDecoder {-# INLINE inlinedConstFieldDecoder #-} @@ -1152,6 +1166,7 @@ instance FromPgField Bool where -- fieldAndValueDecoder = boolRowDecoder instance FromPgField Char where + {-# INLINE fieldDecoder #-} fieldDecoder = let textParser = fieldValueDecoder (fieldDecoder @Text) in FieldDecoder @@ -1171,23 +1186,26 @@ instance FromPgField Char where } instance FromPgField ByteString where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "byteString" [byteaOid] Right instance FromPgField LBS.ByteString where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "ByteString" [byteaOid] $ Right . LBS.fromStrict {-# INLINE textDecoder #-} textDecoder :: Parser.Parser (Maybe Text) textDecoder = do - len <- Parser.takeInt32BE - if len >= 0 - -- TODO: Use some faster unsafeDecodeUtf8 function? - then Just . decodeUtf8 <$> Parser.take (fromIntegral len) - else pure Nothing + len <- Parser.takeInt32BE + if len >= 0 + -- TODO: Use some faster unsafeDecodeUtf8 function? + then Just . decodeUtf8 <$> Parser.take (fromIntegral len) + else pure Nothing instance FromPgField Text where - -- TODO: Use some faster unsafeDecodeUtf8 function? + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ decodeUtf8 bs + -- {-# INLINE fieldAndValueDecoder #-} -- fieldAndValueDecoder = textDecoder {-# INLINE inlinedConstFieldDecoder #-} @@ -1201,41 +1219,45 @@ instance FromPgField Text where -- fieldAndValueDecoder = textDecoder instance FromPgField LT.Text where - -- TODO: Use some faster unsafeDecodeUtf8 function? + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ LT.fromStrict $ decodeUtf8 bs instance FromPgField String where - -- TODO: Use some faster unsafeDecodeUtf8 function? + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "String" [textOid, varcharOid, nameOid] $ \bs -> Right $ Text.unpack $ decodeUtf8 bs -- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default -- connection option). instance FromPgField (CI Text) where + {-# INLINE fieldDecoder #-} fieldDecoder = typeFieldDecoder (typeMustBeNamed "citext") $ CI.mk <$> fieldDecoder -- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default -- connection option). instance FromPgField (CI LT.Text) where + {-# INLINE fieldDecoder #-} fieldDecoder = typeFieldDecoder (typeMustBeNamed "citext") $ CI.mk <$> fieldDecoder -- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default -- connection option). instance FromPgField (CI String) where + {-# INLINE fieldDecoder #-} fieldDecoder = typeFieldDecoder (typeMustBeNamed "citext") $ CI.mk <$> fieldDecoder {-# INLINE utcTimeRowDecoder #-} utcTimeRowDecoder :: Parser.Parser (Maybe UTCTime) utcTimeRowDecoder = do - len <- Parser.takeInt32BE - case len of - 8 -> do - totalusecs <- Parser.takeInt64BE - let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day - parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - pure $ Just $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - _ -> pure Nothing + len <- Parser.takeInt32BE + case len of + 8 -> do + totalusecs <- Parser.takeInt64BE + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + pure $ Just $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + _ -> pure Nothing instance FromPgField UTCTime where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "UTCTime" [timestamptzOid] $ \case bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 @@ -1243,6 +1265,7 @@ instance FromPgField UTCTime where let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 Right $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + -- {-# NOINLINE fieldAndValueDecoder #-} -- fieldAndValueDecoder = utcTimeRowDecoder {-# INLINE inlinedConstFieldDecoder #-} @@ -1256,6 +1279,7 @@ instance FromPgField UTCTime where -- fieldAndValueDecoder = utcTimeRowDecoder instance FromPgField (Unbounded UTCTime) where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Unbounded UTCTime" [timestamptzOid] $ \case bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 @@ -1272,6 +1296,7 @@ instance FromPgField (Unbounded UTCTime) where in Finite $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) instance FromPgField ZonedTime where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "ZonedTime" [timestamptzOid] $ \case bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 @@ -1281,6 +1306,7 @@ instance FromPgField ZonedTime where Right $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) instance FromPgField (Unbounded ZonedTime) where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Unbounded ZonedTime" [timestamptzOid] $ \case bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 @@ -1297,6 +1323,7 @@ instance FromPgField (Unbounded ZonedTime) where in Finite $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) instance FromPgField LocalTime where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "LocalTime" [timestampOid] $ \case bs -> do totalusecs <- BinSer.decodeInt64BE 0 bs @@ -1305,6 +1332,7 @@ instance FromPgField LocalTime where Right $ LocalTime parsedDate (timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) instance FromPgField TimeOfDay where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "TimeOfDay" [timeOid] $ \case bs -> do usecs <- BinSer.decodeInt64BE 0 bs @@ -1317,6 +1345,7 @@ dayRowDecoder = in fmap int32ToDay <$> Parser.takeInt32BEWithFieldLength instance FromPgField Day where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Day" [dateOid] $ \case bs -> do -- There is a very specific conversion function for these, which I poorly translated to Haskell @@ -1338,6 +1367,7 @@ instance FromPgField Day where -- fieldAndValueDecoder = dayRowDecoder instance FromPgField (Unbounded Day) where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Unbounded Day" [dateOid] $ \case bs -> do -- There is a very specific conversion function for these, which I poorly translated to Haskell @@ -1354,6 +1384,7 @@ instance FromPgField (Unbounded Day) where Finite $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 instance FromPgField CalendarDiffTime where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "CalendarDiffTime " [intervalOid] $ \bs -> do nMicrosecs <- BinSer.decodeInt64BE 0 bs nDays <- BinSer.decodeInt32BE 8 bs @@ -1361,12 +1392,14 @@ instance FromPgField CalendarDiffTime where Right $ CalendarDiffTime {ctMonths = fromIntegral nMonths, ctTime = secondsToNominalDiffTime (fromIntegral nDays * 86400) + realToFrac (picosecondsToDiffTime (fromIntegral nMicrosecs * 1_000_000))} instance FromPgField UUID where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "UUID" [uuidOid] $ \case bs -> case UUID.fromByteString (LBS.fromStrict bs) of Just uuid -> Right uuid Nothing -> Left "Bug in Hpgsql: UUID field could not be decoded" instance FromPgField Aeson.Value where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = @@ -1406,6 +1439,7 @@ nonNullableRowDec haskellTypeName rdec = } instance (FromPgField a) => FromPgField (Maybe a) where + {-# INLINE fieldDecoder #-} fieldDecoder = nullableField fieldDecoder {-# INLINE inlinedConstFieldDecoder #-} From eb4372d97ae489847ce1125765d3e6f25a618601 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Wed, 19 Aug 2026 16:54:59 -0300 Subject: [PATCH 25/35] Tidy up, a few more INLINE pragmas --- TODO.md | 5 +- hpgsql/src/Hpgsql/Encoding.hs | 182 ++++++---------------------------- hpgsql/src/Hpgsql/Types.hs | 23 +++-- 3 files changed, 49 insertions(+), 161 deletions(-) diff --git a/TODO.md b/TODO.md index e3e3aa8..6d50f38 100644 --- a/TODO.md +++ b/TODO.md @@ -1,5 +1,2 @@ - Test both `singleField fieldDecoder` and `singleFieldRowDecoder` for every type in our tests. -- Make every FromPgField instance have a dedicated singleFieldRowDecoder override, change our benchmarks to exercise other types we're not, like `numeric` and `Float` -- Investigate why overlapping (Maybe a) instance is better for record decoding but worse for Tuple decoding - - Revert things: derive the overlapping (Maybe a) instance, derive the `FromPgField a` using that under the hood. -- Try to achieve a 100% inlined row decoder for a small record type +- Some types (the Aeson ones, for example) still don't derive specialized row decoders diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index eedbaa4..60cd2e8 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -27,8 +27,6 @@ module Hpgsql.Encoding FromPgRow (..), RowDecoder (..), -- TODO: Can we export ctor? singleField, - singleFieldRowDecoder, - inlinedSingleFieldRowDecoder, nullableField, genericFromPgRow, @@ -252,21 +250,30 @@ class FromPgField a where Right v -> pure v _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1" - {-# INLINE inlinedConstFieldDecoder #-} - -- | For types where there is a fast way to decode fields+values -- without knowing the OID of the value in the query (of course, the -- possible OIDs are still limited by the FieldDecoder's allowed types), -- this can help provide a significant boost to inlined row decoders. -- Define as `Nothing` if this isn't possible. + {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder :: Maybe (Parser.Parser (Maybe a)) inlinedConstFieldDecoder = Nothing + -- | Semantically equivalent to `singleField fieldDecoder`, but for + -- some types it can provide a much faster `RowDecoder`. Beware that + -- this will produce more code in row decoders. {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder :: RowDecoder a inlinedSingleFieldRowDecoder = case inlinedConstFieldDecoder @a of + -- This is a class method instead of a top-level function + -- because the GHC inliner behaves differently when it's a top-level + -- function, and benchmarks show it gets worse. Nothing -> singleField fieldDecoder Just p -> + -- The strictness and floating out of fieldDecoder-derived + -- values allows GHC to inline a lot more. For example, `valueForNull` + -- gets inlined to a `fail "Cannot decode SQL NULL ..."` for basic types + -- like `Int`. let !valueForNull = case (fieldDecoder @a).decodesSqlNullTo of Left err -> fail err Right v -> pure v @@ -283,13 +290,6 @@ class FromPgField a where numExpectedColumns = 1 } --- TODO: better name for `singleFieldRowDecoder`? We have 3 methods now --- to create a single field RowDecoder, what a mess! Figure out names --- and code docs. -{-# NOINLINE singleFieldRowDecoder #-} -singleFieldRowDecoder :: forall a. (FromPgField a) => RowDecoder a -singleFieldRowDecoder = inlinedSingleFieldRowDecoder - class FromPgRow a where rowDecoder :: RowDecoder a default rowDecoder :: (Generic a, ProductTypeDecoder (Rep a)) => RowDecoder a @@ -363,43 +363,43 @@ compositeTypeEncoder rowEnc = } instance (FromPgField a) => FromPgRow (Only a) where - rowDecoder = Only <$> singleFieldRowDecoder + rowDecoder = Only <$> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b) => FromPgRow (a, b) where - rowDecoder = (,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c) => FromPgRow (a, b, c) where - rowDecoder = (,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d) => FromPgRow (a, b, c, d) where - rowDecoder = (,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e) => FromPgRow (a, b, c, d, e) where - rowDecoder = (,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f) => FromPgRow (a, b, c, d, e, f) where - rowDecoder = (,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g) => FromPgRow (a, b, c, d, e, f, g) where - rowDecoder = (,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h) => FromPgRow (a, b, c, d, e, f, g, h) where - rowDecoder = (,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i) => FromPgRow (a, b, c, d, e, f, g, h, i) where - rowDecoder = (,,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,,,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j) => FromPgRow (a, b, c, d, e, f, g, h, i, j) where - rowDecoder = (,,,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,,,,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k) where - rowDecoder = (,,,,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,,,,,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k, FromPgField l) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k, l) where - rowDecoder = (,,,,,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,,,,,,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k, FromPgField l, FromPgField m) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k, l, m) where - rowDecoder = (,,,,,,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,,,,,,,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder data FieldEncoder a = FieldEncoder { toTypeOid :: !(EncodingContext -> Maybe Oid), @@ -894,27 +894,9 @@ instance FromPgField Int where allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid } - -- {-# INLINE fieldAndValueDecoder #-} - -- fieldAndValueDecoder = intRowDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just intRowDecoder --- instance {-# OVERLAPPING #-} FromPgField (Maybe Int) where --- -- This overlapping instance isn't pretty, but it reduces memory --- -- usage and improves performance a bit --- fieldDecoder = error "TODO Maybe Int" - --- -- FieldDecoder --- -- { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> --- -- let !decode = binaryIntDecoder oid --- -- in \case --- -- Just bs -> Just <$> decode bs --- -- Nothing -> Right Nothing, --- -- allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid --- -- } --- {-# INLINE fieldAndValueDecoder #-} --- fieldAndValueDecoder = intRowDecoder - instance FromPgField Int16 where {-# INLINE fieldDecoder #-} fieldDecoder = @@ -999,26 +981,13 @@ instance FromPgField Oid where allowedPgTypes = (== oidOid) . fieldTypeOid } --- {-# INLINE floatRowDecoder #-} --- floatRowDecoder :: Parser.Parser (Maybe Float) --- floatRowDecoder = Parser.takeFloatBEWithFieldLength - instance FromPgField Float where {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Float" [float4Oid] $ Right . binaryFloat4Decoder - -- {-# INLINE fieldAndValueDecoder #-} - -- fieldAndValueDecoder = floatRowDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just Parser.takeFloatBEWithFieldLength --- instance {-# OVERLAPPING #-} FromPgField (Maybe Float) where --- -- This overlapping instance isn't pretty, but it reduces memory --- -- usage and improves performance a bit --- fieldDecoder = error "TODO Maybe Float" --- {-# INLINE fieldAndValueDecoder #-} --- fieldAndValueDecoder = floatRowDecoder - {-# INLINE doubleRowDecoder #-} doubleRowDecoder :: Parser.Parser (Maybe Double) doubleRowDecoder = do @@ -1041,18 +1010,9 @@ instance FromPgField Double where allowedPgTypes = (`elem` [float8Oid, float4Oid]) . fieldTypeOid } - -- {-# INLINE fieldAndValueDecoder #-} - -- fieldAndValueDecoder = doubleRowDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just doubleRowDecoder --- instance {-# OVERLAPPING #-} FromPgField (Maybe Double) where --- -- This overlapping instance isn't pretty, but it reduces memory --- -- usage and improves performance a bit --- fieldDecoder = error "TODO Maybe Double" --- {-# INLINE fieldAndValueDecoder #-} --- fieldAndValueDecoder = doubleRowDecoder - -- | Allows you to specify a type (and other checks, possibly) for a `FieldDecoder`. -- This can be useful to ensure you're not accidentally decoding a different type. -- @@ -1153,18 +1113,9 @@ instance FromPgField Bool where {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Bool" [boolOid] $ \bs -> Right $ bs == binaryTrue - -- {-# INLINE fieldAndValueDecoder #-} - -- fieldAndValueDecoder = boolRowDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just boolRowDecoder --- instance {-# OVERLAPPING #-} FromPgField (Maybe Bool) where --- -- This overlapping instance isn't pretty, but it reduces memory --- -- usage and improves performance a bit --- fieldDecoder = error "TODO Maybe Bool" --- {-# INLINE fieldAndValueDecoder #-} --- fieldAndValueDecoder = boolRowDecoder - instance FromPgField Char where {-# INLINE fieldDecoder #-} fieldDecoder = @@ -1206,18 +1157,9 @@ instance FromPgField Text where {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ decodeUtf8 bs - -- {-# INLINE fieldAndValueDecoder #-} - -- fieldAndValueDecoder = textDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just textDecoder --- instance {-# OVERLAPPING #-} FromPgField (Maybe Text) where --- -- This overlapping instance isn't pretty, but it reduces memory --- -- usage and improves performance a bit --- fieldDecoder = error "TODO Maybe Text" --- {-# INLINE fieldAndValueDecoder #-} --- fieldAndValueDecoder = textDecoder - instance FromPgField LT.Text where {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ LT.fromStrict $ decodeUtf8 bs @@ -1266,18 +1208,9 @@ instance FromPgField UTCTime where parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 Right $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - -- {-# NOINLINE fieldAndValueDecoder #-} - -- fieldAndValueDecoder = utcTimeRowDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just utcTimeRowDecoder --- instance {-# OVERLAPPING #-} FromPgField (Maybe UTCTime) where --- -- This overlapping instance isn't pretty, but it reduces memory --- -- usage and improves performance a bit --- fieldDecoder = error "TODO Maybe UTCTime" --- {-# INLINE fieldAndValueDecoder #-} --- fieldAndValueDecoder = utcTimeRowDecoder - instance FromPgField (Unbounded UTCTime) where {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Unbounded UTCTime" [timestamptzOid] $ \case @@ -1354,18 +1287,9 @@ instance FromPgField Day where jd <- BinSer.decodeInt32BE 0 bs Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 - -- {-# INLINE fieldAndValueDecoder #-} - -- fieldAndValueDecoder = dayRowDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just dayRowDecoder --- instance {-# OVERLAPPING #-} FromPgField (Maybe Day) where --- -- This overlapping instance isn't pretty, but it reduces memory --- -- usage and improves performance a bit --- fieldDecoder = error "TODO Maybe Day" --- {-# INLINE fieldAndValueDecoder #-} --- fieldAndValueDecoder = dayRowDecoder - instance FromPgField (Unbounded Day) where {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Unbounded Day" [dateOid] $ \case @@ -1404,12 +1328,14 @@ instance FromPgField Aeson.Value where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in \case - bs -> case Aeson.decodeStrict $ fixJsonb bs of - Just d -> Right d - Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", + let + -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in + \case + bs -> case Aeson.decodeStrict $ fixJsonb bs of + Just d -> Right d + Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } @@ -1426,18 +1352,6 @@ nullableField FieldDecoder {..} = allowedPgTypes } -{-# INLINE nonNullableRowDec #-} -nonNullableRowDec :: String -> RowDecoder (Maybe a) -> RowDecoder a -nonNullableRowDec haskellTypeName rdec = - let fromNullable mVal = case mVal of - Nothing -> fail $ "Cannot decode SQL null as the Haskell " ++ haskellTypeName ++ " type. Use a `" ++ haskellTypeName ++ "` if you want SQL nulls" - Just v -> pure v - in RowDecoder - { fullRowDecoder = \finfos -> rdec.fullRowDecoder finfos >>= fromNullable, - rowColumnsTypeCheck = rdec.rowColumnsTypeCheck, - numExpectedColumns = rdec.numExpectedColumns - } - instance (FromPgField a) => FromPgField (Maybe a) where {-# INLINE fieldDecoder #-} fieldDecoder = nullableField fieldDecoder @@ -1457,36 +1371,6 @@ instance (FromPgField a) => FromPgField (Maybe a) where Nothing -> pure Nothing -- Must return Nothing for SQL Nulls jv -> pure $ Just jv --- let ffdec = fieldAndValueDecoder @a --- in --- RowDecoder --- { fullRowDecoder = \finfos -> --- let frd = fieldAndValueDecoder.fullRowDecoder finfos --- in do --- -- TODO: We're decoding the field length twice with --- -- the peek call when the value isn't NULL. --- -- Maybe we should make `FromPgField`'s new methods --- -- be two `Parser` objects: one for both length and field --- -- and another only for the field (but how would that work --- -- without the length..? It wouldn't.) --- -- Maybe we do the `Parser (Maybe a)` for `a` types, then. --- -- We can build a `Parser a` from that with `decodesSqlNullTo` --- -- and with inlining there's nothing to lose? --- fieldLen <- Parser.peekInt32BE --- if fieldLen == (-1) --- then case fieldDecoder.decodesSqlNullTo of --- Left err -> fail err --- Right v -> Parser.skip 4 >> pure v --- else do --- Just <$> frd, --- rowColumnsTypeCheck = --- let fdec = fieldDecoder @a --- in \case --- [singleColInfo] -> [(singleColInfo, fdec.allowedPgTypes singleColInfo)] --- _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", --- numExpectedColumns = 1 --- } - allowOnlyArrayTypes :: FieldInfo -> Bool allowOnlyArrayTypes fieldInfo = -- TODO: We could check the elemTypeOid too, but maybe later @@ -1566,7 +1450,7 @@ instance (FromPgField a) => ProductTypeDecoder (K1 r a) where -- coercing instead of fmap reduces memory usage, apparently -- by reducing (unnecessary) closures in the final row decoder, -- as per looking at GHC Core - genRowDecoder = coerce $ singleFieldRowDecoder @a + genRowDecoder = coerce $ inlinedSingleFieldRowDecoder @a genericToPgRow :: forall a. (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a genericToPgRow = contramap from genRowEncoder diff --git a/hpgsql/src/Hpgsql/Types.hs b/hpgsql/src/Hpgsql/Types.hs index 8cc68ce..77c2dc1 100644 --- a/hpgsql/src/Hpgsql/Types.hs +++ b/hpgsql/src/Hpgsql/Types.hs @@ -40,6 +40,7 @@ instance forall a. (ToPgField a) => ToPgField (PGArray a) where } instance forall a. (FromPgField a) => FromPgField (PGArray a) where + {-# INLINE fieldDecoder #-} fieldDecoder = PGArray <$> arrayField replicateM fieldDecoder -- | A way to compose two rows. @@ -83,13 +84,16 @@ pgJsonByteString :: PgJson -> ByteString pgJsonByteString (PgJson bs) = bs instance FromPgField PgJson where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in \bs -> Right $ PgJson $ fixJsonb bs, + let + -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in + \bs -> Right $ PgJson $ fixJsonb bs, decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell PgJson type. Use a `Maybe PgJson` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } @@ -102,15 +106,18 @@ newtype Aeson a = Aeson {getAeson :: a} deriving newtype (Eq) instance (FromJSON a) => FromPgField (Aeson a) where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in \bs -> case Aeson.decodeStrict $ fixJsonb bs of - Just v -> Right $ Aeson v - Nothing -> Left "Failed to decode postgres JSON value into your `Aeson a` type. Are you sure it's proper JSON?", + let + -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in + \bs -> case Aeson.decodeStrict $ fixJsonb bs of + Just v -> Right $ Aeson v + Nothing -> Left "Failed to decode postgres JSON value into your `Aeson a` type. Are you sure it's proper JSON?", decodesSqlNullTo = Left "Cannot decode SQL null as a Haskell (Aeson a) type. Use a `Maybe (Aeson a)` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } From c5ee605be9f0b275b2b69a3f07da84589765f829 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Wed, 19 Aug 2026 17:09:11 -0300 Subject: [PATCH 26/35] TODOs in the code --- hpgsql/src/Hpgsql/Encoding.hs | 26 ++++++++++++++++---------- 1 file changed, 16 insertions(+), 10 deletions(-) diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index 60cd2e8..6c79e31 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -162,6 +162,7 @@ instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in {-# INLINE singleField #-} singleField :: FieldDecoder a -> RowDecoder a singleField fdec = + -- TODO: Float out decodesSqlNullTo to here. Does it make a difference? RowDecoder { fullRowDecoder = \case [singleColInfo] -> @@ -221,10 +222,16 @@ class FromPgField a where -- allocations and thus better performance. -- Any implementation of this _must_ return a `Nothing` for a SQL NULL value, -- regardless of what `FieldDecoder` would do with a SQL NULL. - -- TODO: Move this to inside the FieldDecoder type? {-# NOINLINE fieldAndValueDecoder #-} fieldAndValueDecoder :: RowDecoder (Maybe a) fieldAndValueDecoder = + -- TODO: Float out allowedPgTypes? Does it matter at all? + -- TODO: This method is.. only useful for the `Scientific` type, + -- which can provide a faster row decoder but still needs to know + -- the type's OID. Maybe it's useful for our Aeson types too? + -- In any case, this class has many methods, and their names should + -- better reflect when they're useful and what they do, and `fieldAndValueDecoder` + -- might not be doing the best job in the world at that. RowDecoder { fullRowDecoder = case inlinedConstFieldDecoder of @@ -261,7 +268,8 @@ class FromPgField a where -- | Semantically equivalent to `singleField fieldDecoder`, but for -- some types it can provide a much faster `RowDecoder`. Beware that - -- this will produce more code in row decoders. + -- using will produce more code in your row decoders, which can affect + -- compilation times and binary size. {-# INLINE inlinedSingleFieldRowDecoder #-} inlinedSingleFieldRowDecoder :: RowDecoder a inlinedSingleFieldRowDecoder = case inlinedConstFieldDecoder @a of @@ -1328,14 +1336,12 @@ instance FromPgField Aeson.Value where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let - -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in - \case - bs -> case Aeson.decodeStrict $ fixJsonb bs of - Just d -> Right d - Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", + let -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in \case + bs -> case Aeson.decodeStrict $ fixJsonb bs of + Just d -> Right d + Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } From cf938103877fee48ed8ff21bbc4c80db8336e199 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Wed, 19 Aug 2026 21:13:47 -0300 Subject: [PATCH 27/35] Trying a specialized notConst method Types like `Scientific` are not being decoded optimally otherwise, and they can do better than in the current state --- TODO.md | 2 +- hpgsql/src/Hpgsql/Encoding.hs | 274 +++++++++++++++------------------- hpgsql/src/Hpgsql/Types.hs | 22 ++- 3 files changed, 133 insertions(+), 165 deletions(-) diff --git a/TODO.md b/TODO.md index 6d50f38..7bb0ccb 100644 --- a/TODO.md +++ b/TODO.md @@ -1,2 +1,2 @@ - Test both `singleField fieldDecoder` and `singleFieldRowDecoder` for every type in our tests. -- Some types (the Aeson ones, for example) still don't derive specialized row decoders +- Some types (the Aeson ones, for example, but more) still don't derive specialized row decoders diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index 6c79e31..6d0fa9e 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -21,7 +21,7 @@ -- of fields), check "Hpgsql.Encoding.RowDecoderMonadic". module Hpgsql.Encoding ( -- * Decoding - FromPgField (..), + FromPgField (fieldDecoder, inlinedSingleFieldRowDecoder), -- Don't export the other internal perf-oriented methods yet FieldDecoder (..), -- TODO: Can we export ctor? FieldInfo (..), FromPgRow (..), @@ -121,7 +121,7 @@ data FieldInfo = FieldInfo -- | A decoder for a single field/column. data FieldDecoder a = FieldDecoder - { fieldValueDecoder :: FieldInfo -> ByteString -> Either String a, -- TODO: Since this now takes a ByteString (not a Maybe), it could actually be typed `FieldInfo -> Parser a` + { fieldValueDecoder :: FieldInfo -> ByteString -> Either String a, decodesSqlNullTo :: Either String a, allowedPgTypes :: FieldInfo -> Bool } @@ -162,110 +162,76 @@ instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in {-# INLINE singleField #-} singleField :: FieldDecoder a -> RowDecoder a singleField fdec = - -- TODO: Float out decodesSqlNullTo to here. Does it make a difference? - RowDecoder - { fullRowDecoder = \case - [singleColInfo] -> - let decode = fdec.fieldValueDecoder singleColInfo - in do - lenNextCol <- fromIntegral <$> Parser.takeInt32BE - if lenNextCol >= 0 - then do - nextColBs <- Parser.take lenNextCol - case decode nextColBs of - Right v -> pure v - Left err -> fail err - -- This `case` is why we require `fieldAndValueDecoder` to decode - -- SQL NULL into `Nothing`: we do check decodesSqlNullTo. - else case fdec.decodesSqlNullTo of - Right v -> pure v - Left err -> fail err - _ -> error "singleField expected a single column OID but got 0 or >1", - rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, fdec.allowedPgTypes singleColInfo)] - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", - numExpectedColumns = 1 - } - -{-# INLINE inlinableRowDecoder #-} -inlinableRowDecoder :: [Oid] -> Parser.Parser a -> RowDecoder a -inlinableRowDecoder tyoids p = - -- FromPgField instances whose decoders don't care about the OID of the PG type - -- being decoded are very dear to us because they allow a very important optimization: - -- their row decoders do not care about the `FieldInfo` argument, which - -- makes them inlinable by GHC at compile time (FieldInfo is only available - -- at run time when the RowDescription message arrives for a given query). - -- These are key to produce compiled to code that almost compiles down to - -- a bunch of `peek` calls to a single ByteString decoding bytes into - -- typed values, to then call the Parser continuation, and repeat. - -- The only allocations (I think) when everything is inlined by this are the - -- decoded values themselves being boxed and the CPS Parser's ByteStringIdx - -- also being passed boxed between continuations (though reading GHC Core - -- is something I'm still learning). - RowDecoder - { fullRowDecoder = const p, - rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid `elem` tyoids)] - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", - numExpectedColumns = 1 - } + -- This `case` is why we require `fieldAndValueDecoder` to decode + -- SQL NULL into `Nothing`: we do check decodesSqlNullTo. + let !valueForNull = case fdec.decodesSqlNullTo of + Left err -> fail err + Right v -> pure v + !typeCheck = fdec.allowedPgTypes + in RowDecoder + { fullRowDecoder = \case + [singleColInfo] -> + let decode = fdec.fieldValueDecoder singleColInfo + in do + lenNextCol <- fromIntegral <$> Parser.takeInt32BE + if lenNextCol >= 0 + then do + nextColBs <- Parser.take lenNextCol + case decode nextColBs of + Right v -> pure v + Left err -> fail err + else valueForNull + _ -> error "singleField expected a single column OID but got 0 or >1", + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, typeCheck singleColInfo)] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } class FromPgField a where {-# MINIMAL fieldDecoder #-} fieldDecoder :: FieldDecoder a - -- | This should be semantically equivalent to `singleField fieldDecoder`, - -- but it can be overridden (and is for base types) to a much faster implementation. - -- Using this when deriving your `FromPgRow` instances will increase code size and - -- possibly compilation times somewhat, but in some cases it can make row decoders - -- compile down to a ByteString-peeking implementation with much fewer - -- allocations and thus better performance. - -- Any implementation of this _must_ return a `Nothing` for a SQL NULL value, - -- regardless of what `FieldDecoder` would do with a SQL NULL. - {-# NOINLINE fieldAndValueDecoder #-} - fieldAndValueDecoder :: RowDecoder (Maybe a) - fieldAndValueDecoder = - -- TODO: Float out allowedPgTypes? Does it matter at all? - -- TODO: This method is.. only useful for the `Scientific` type, - -- which can provide a faster row decoder but still needs to know - -- the type's OID. Maybe it's useful for our Aeson types too? - -- In any case, this class has many methods, and their names should - -- better reflect when they're useful and what they do, and `fieldAndValueDecoder` - -- might not be doing the best job in the world at that. - RowDecoder - { fullRowDecoder = - case inlinedConstFieldDecoder of - Nothing -> slowerParser - Just fd -> const fd, - rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, (fieldDecoder @a).allowedPgTypes singleColInfo)] - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", - numExpectedColumns = 1 - } - where - -- slowerParser takes a ByteString and passes it to the - -- field decoder. - slowerParser = \case - [singleColInfo] -> do - len <- Parser.takeInt32BE - if len == (-1) - then pure Nothing - else do - bs <- Parser.take (fromIntegral len) - case fieldDecoder.fieldValueDecoder singleColInfo bs of - Left err -> fail err - Right v -> pure v - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1" - -- | For types where there is a fast way to decode fields+values -- without knowing the OID of the value in the query (of course, the -- possible OIDs are still limited by the FieldDecoder's allowed types), - -- this can help provide a significant boost to inlined row decoders. - -- Define as `Nothing` if this isn't possible. + -- defining this can help provide a significant performance boost to inlined row decoders. + -- + -- Any implementation of this _must_ return a `Nothing` for a SQL NULL value, + -- regardless of what `FieldDecoder` would do with a SQL NULL. + -- + -- Define this as `Nothing` if implementing it isn't possible. + -- This isn't exposed to users yet, but we should recommend they add an INLINE pragma, + -- as the method's name suggests. {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder :: Maybe (Parser.Parser (Maybe a)) inlinedConstFieldDecoder = Nothing + -- | For types that can't implement `inlinedConstFieldDecoder`, this is the next + -- best thing: also a specialized field+value decoder that can be faster than + -- one derived from `fieldDecoder`. + -- + -- Any implementation of this _must_ return a `Nothing` for a SQL NULL value, + -- regardless of what `FieldDecoder` would do with a SQL NULL. + {-# INLINE notConstFieldDecoder #-} + notConstFieldDecoder :: FieldInfo -> Parser.Parser (Maybe a) + notConstFieldDecoder = + case inlinedConstFieldDecoder of + Nothing -> slowerParser + Just fd -> const fd + where + -- slowerParser takes a ByteString and passes it to the + -- field decoder. + slowerParser singleColInfo = do + len <- Parser.takeInt32BE + if len == (-1) + then pure Nothing + else do + bs <- Parser.take (fromIntegral len) + case fieldDecoder.fieldValueDecoder singleColInfo bs of + Left err -> fail err + Right v -> pure v + -- | Semantically equivalent to `singleField fieldDecoder`, but for -- some types it can provide a much faster `RowDecoder`. Beware that -- using will produce more code in your row decoders, which can affect @@ -275,8 +241,25 @@ class FromPgField a where inlinedSingleFieldRowDecoder = case inlinedConstFieldDecoder @a of -- This is a class method instead of a top-level function -- because the GHC inliner behaves differently when it's a top-level - -- function, and benchmarks show it gets worse. - Nothing -> singleField fieldDecoder + -- function, and benchmarks show this is faster. + Nothing -> + let !valueForNull = case (fieldDecoder @a).decodesSqlNullTo of + Left err -> fail err + Right v -> pure v + !typeCheck = (fieldDecoder @a).allowedPgTypes + in RowDecoder + { fullRowDecoder = \case + [singleColInfo] -> do + mv <- notConstFieldDecoder singleColInfo + case mv of + Nothing -> valueForNull + Just v -> pure v + _ -> error "singleField expected a single column OID but got 0 or >1", + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, typeCheck singleColInfo)] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } Just p -> -- The strictness and floating out of fieldDecoder-derived -- values allows GHC to inline a lot more. For example, `valueForNull` @@ -318,12 +301,12 @@ compositeTypeDecoder :: forall a. RowDecoder a -> FieldDecoder a compositeTypeDecoder (RowDecoder {..}) = FieldDecoder { fieldValueDecoder = \compositeTypeOid -> - let prs = parserForRecord compositeTypeOid.encodingContext <* Parser.endOfInput + let !prs = parserForRecord compositeTypeOid.encodingContext <* Parser.endOfInput in \bs -> case Parser.parseOnly prs bs of Parser.ParseOk v -> Right v Parser.ParseFail err -> Left err, - decodesSqlNullTo = Left "TODO: composeTypeDecoder decodesSqlNullTo", + decodesSqlNullTo = Left "Got NULL in composite type but it was not allowed", allowedPgTypes = const True -- There's no way to enforce a custom type's OID. We only check if it's structurally the same in the parser (same subtypes in same order) } where @@ -877,20 +860,6 @@ instance FromPgField () where allowedPgTypes = (== voidOid) . fieldTypeOid } --- TODO: Inline intRowDecoder into FromPgField? And all others too? -{-# INLINE intRowDecoder #-} -intRowDecoder :: Parser.Parser (Maybe Int) -intRowDecoder = do - fieldLen <- Parser.takeInt32BE - -- TODO: We're assuming `Int` is always 64 bits, so 64bit CPUs? Is that ok? - -- TODO: Is there a way to optimistically assume <=4 bytes and use our custom new parser? - case fieldLen of - 4 -> Just . fromIntegral <$> Parser.takeInt32BE - (-1) -> pure Nothing - 8 -> Just . fromIntegral <$> Parser.takeInt64BE - 2 -> Just . fromIntegral <$> Parser.takeInt16BE - _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" - instance FromPgField Int where {-# INLINE fieldDecoder #-} fieldDecoder = @@ -903,7 +872,16 @@ instance FromPgField Int where } {-# INLINE inlinedConstFieldDecoder #-} - inlinedConstFieldDecoder = Just intRowDecoder + inlinedConstFieldDecoder = Just $ do + fieldLen <- Parser.takeInt32BE + -- TODO: We're assuming `Int` is always 64 bits, so 64bit CPUs? Is that ok? + -- TODO: Is there a way to optimistically assume <=4 bytes and use our custom new parser? + case fieldLen of + 4 -> Just . fromIntegral <$> Parser.takeInt32BE + (-1) -> pure Nothing + 8 -> Just . fromIntegral <$> Parser.takeInt64BE + 2 -> Just . fromIntegral <$> Parser.takeInt16BE + _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" instance FromPgField Int16 where {-# INLINE fieldDecoder #-} @@ -916,17 +894,6 @@ instance FromPgField Int16 where allowedPgTypes = (== int2Oid) . fieldTypeOid } -{-# INLINE int32RowDecoder #-} -int32RowDecoder :: RowDecoder (Maybe Int32) -int32RowDecoder = - inlinableRowDecoder [int2Oid, int4Oid] $ do - fieldLen <- Parser.takeInt32BE - case fieldLen of - 4 -> Just <$> Parser.takeInt32BE - (-1) -> pure Nothing - 2 -> Just . fromIntegral <$> Parser.takeInt16BE - _ -> fail "Trying to decode PG int4 but it's not 2 or 4 bytes long" - instance FromPgField Int32 where {-# INLINE fieldDecoder #-} fieldDecoder = @@ -935,20 +902,14 @@ instance FromPgField Int32 where decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int32 type. Use a `Maybe Int32`", allowedPgTypes = (`elem` [int2Oid, int4Oid]) . fieldTypeOid } - {-# INLINE fieldAndValueDecoder #-} - fieldAndValueDecoder = int32RowDecoder - -{-# INLINE int64RowDecoder #-} -int64RowDecoder :: RowDecoder (Maybe Int64) -int64RowDecoder = - inlinableRowDecoder [int2Oid, int4Oid, int8Oid] $ do + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just $ do fieldLen <- Parser.takeInt32BE case fieldLen of - 8 -> Just <$> Parser.takeInt64BE - 4 -> Just . fromIntegral <$> Parser.takeInt32BE + 4 -> Just <$> Parser.takeInt32BE (-1) -> pure Nothing 2 -> Just . fromIntegral <$> Parser.takeInt16BE - _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" + _ -> fail "Trying to decode PG int4 but it's not 2 or 4 bytes long" instance FromPgField Int64 where {-# INLINE fieldDecoder #-} @@ -958,8 +919,15 @@ instance FromPgField Int64 where decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int64 type. Use a `Maybe Int64`", allowedPgTypes = (`elem` [int2Oid, int4Oid, int8Oid]) . fieldTypeOid } - {-# INLINE fieldAndValueDecoder #-} - fieldAndValueDecoder = int64RowDecoder + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just $ do + fieldLen <- Parser.takeInt32BE + case fieldLen of + 8 -> Just <$> Parser.takeInt64BE + 4 -> Just . fromIntegral <$> Parser.takeInt32BE + (-1) -> pure Nothing + 2 -> Just . fromIntegral <$> Parser.takeInt16BE + _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" instance FromPgField Integer where {-# INLINE fieldDecoder #-} @@ -1090,21 +1058,25 @@ instance FromPgField Scientific where decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`", allowedPgTypes = (`elem` [numericOid, int2Oid, int4Oid, int8Oid]) . fieldTypeOid } - {-# INLINE fieldAndValueDecoder #-} - fieldAndValueDecoder = - RowDecoder - { fullRowDecoder = \case - [singleColInfo] -> - if singleColInfo.fieldTypeOid /= numericOid - then - fmap (flip scientific 0 . fromIntegral) <$> (fieldAndValueDecoder @Int64).fullRowDecoder [singleColInfo] - else numericRowParser - _ -> error "singleField expected a single column OID but got 0 or >1", - rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid `elem` [numericOid, int2Oid, int4Oid, int8Oid])] - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", - numExpectedColumns = 1 - } + {-# INLINE inlinedSingleFieldRowDecoder #-} + inlinedSingleFieldRowDecoder = + let !int64RowDec = fromMaybe (error "Bug in HPgsql: Int64 does not have an inlinedConstFieldDecoder") $ inlinedConstFieldDecoder @Int64 + in RowDecoder + { fullRowDecoder = \case + [singleColInfo] -> do + msci <- + if singleColInfo.fieldTypeOid /= numericOid + then fmap (flip scientific 0 . fromIntegral) <$> int64RowDec + else numericRowParser + case msci of + Nothing -> fail "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`" + Just sci -> pure sci + _ -> error "singleField expected a single column OID but got 0 or >1", + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid `elem` [numericOid, int2Oid, int4Oid, int8Oid])] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } instance FromPgField (Ratio Integer) where {-# INLINE fieldDecoder #-} diff --git a/hpgsql/src/Hpgsql/Types.hs b/hpgsql/src/Hpgsql/Types.hs index 77c2dc1..08a56b6 100644 --- a/hpgsql/src/Hpgsql/Types.hs +++ b/hpgsql/src/Hpgsql/Types.hs @@ -64,7 +64,7 @@ instance forall a b. (ToPgRow a, ToPgRow b) => ToPgRow (a :. b) where instance (FromPgRow a, FromPgRow b) => FromPgRow (a :. b) where rowDecoder = (:.) <$> rowDecoder <*> rowDecoder --- | A JSON type that does not incur the costs of deserializing +-- | A JSON type that does not incur the costs of JSON/aeson deserializing -- in its `FromPgField` instance because it assumes postgres only generates -- valid JSON. Useful for extra performance if its opaqueness is not a problem. -- Although it does have a `toJSON` method, using it will incur a @@ -89,11 +89,9 @@ instance FromPgField PgJson where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let - -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in - \bs -> Right $ PgJson $ fixJsonb bs, + let -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in \bs -> Right $ PgJson $ fixJsonb bs, decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell PgJson type. Use a `Maybe PgJson` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } @@ -111,13 +109,11 @@ instance (FromJSON a) => FromPgField (Aeson a) where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let - -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in - \bs -> case Aeson.decodeStrict $ fixJsonb bs of - Just v -> Right $ Aeson v - Nothing -> Left "Failed to decode postgres JSON value into your `Aeson a` type. Are you sure it's proper JSON?", + let -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in \bs -> case Aeson.decodeStrict $ fixJsonb bs of + Just v -> Right $ Aeson v + Nothing -> Left "Failed to decode postgres JSON value into your `Aeson a` type. Are you sure it's proper JSON?", decodesSqlNullTo = Left "Cannot decode SQL null as a Haskell (Aeson a) type. Use a `Maybe (Aeson a)` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } From 7eddecb7bfacc385d0bd57d927a08cfca7ce3ef7 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Thu, 20 Aug 2026 14:31:31 -0300 Subject: [PATCH 28/35] Do the JSON types, but hpgsql-simple-compat will break Becase we don't have a FieldInfo when decoding NULL anymore. Not sure what we can do. --- Runfile | 6 +-- TODO.md | 1 + .../Database/PostgreSQL/Simple/FromField.hs | 10 +++-- .../Database/PostgreSQL/Simple/HpgsqlUtils.hs | 21 +++++++--- hpgsql/src/Hpgsql/Encoding.hs | 38 +++++++++---------- hpgsql/src/Hpgsql/Types.hs | 21 +++++++++- 6 files changed, 64 insertions(+), 33 deletions(-) diff --git a/Runfile b/Runfile index 0a791b9..406b180 100644 --- a/Runfile +++ b/Runfile @@ -73,13 +73,13 @@ tests: if [ -n "$NIX" ]; then nix-build --no-out-link -A "testsPg${pg}" --argstr hspecArgs "$TARGS" else - cabal build hpgsql-tests # hpgsql-simple-compat-tests + cabal build hpgsql-tests hpgsql-simple-compat-tests nix-shell -A "shellPg${pg}" ./default.nix --run "./scripts/run-tests-db-internal.sh $TARGS" fi done - # echo "--- Running hlint" - # hlint . + echo "--- Running hlint" + hlint . ## # Runs tests 100 times, reporting how many passed and how many failed. diff --git a/TODO.md b/TODO.md index 7bb0ccb..95ea5db 100644 --- a/TODO.md +++ b/TODO.md @@ -1,2 +1,3 @@ - Test both `singleField fieldDecoder` and `singleFieldRowDecoder` for every type in our tests. - Some types (the Aeson ones, for example, but more) still don't derive specialized row decoders +- "Oh no! No colInfo here.. what do we do!?" in hpgsql-simple-compat. This might require a big rethinking of things.. diff --git a/hpgsql-simple-compat/src/Database/PostgreSQL/Simple/FromField.hs b/hpgsql-simple-compat/src/Database/PostgreSQL/Simple/FromField.hs index 3a2b83b..42e124e 100644 --- a/hpgsql-simple-compat/src/Database/PostgreSQL/Simple/FromField.hs +++ b/hpgsql-simple-compat/src/Database/PostgreSQL/Simple/FromField.hs @@ -177,9 +177,13 @@ class FromField a where let dec = Hpgsql.fieldDecoder in \f -> if Hpgsql.allowedPgTypes dec f - then \mbs -> Conversion $ \_encCtx -> case Hpgsql.fieldValueDecoder dec f mbs of - Right v -> Ok v - Left err -> Errors [toException $ userError err] + then \mbs -> Conversion $ \_encCtx -> case mbs of + Nothing -> case dec.decodesSqlNullTo of + Left err -> Errors [toException $ userError err] + Right v -> Ok v + Just bs -> case Hpgsql.fieldValueDecoder dec f bs of + Right v -> Ok v + Left err -> Errors [toException $ userError err] else \_ -> Conversion $ \_encCtx -> Errors [toException $ userError "Invalid type OID for FromField instance"] instance FromField () diff --git a/hpgsql-simple-compat/src/Database/PostgreSQL/Simple/HpgsqlUtils.hs b/hpgsql-simple-compat/src/Database/PostgreSQL/Simple/HpgsqlUtils.hs index 63a2898..cf42a1d 100644 --- a/hpgsql-simple-compat/src/Database/PostgreSQL/Simple/HpgsqlUtils.hs +++ b/hpgsql-simple-compat/src/Database/PostgreSQL/Simple/HpgsqlUtils.hs @@ -95,18 +95,29 @@ type FieldParser a = Field -> Maybe ByteString -> Conversion a toHpgsqlFieldDecoder :: FieldParser a -> FieldDecoder a toHpgsqlFieldDecoder fp = FieldDecoder - { fieldValueDecoder = \colInfo mbs -> - let valConv = fp colInfo mbs + { fieldValueDecoder = \colInfo bs -> + let valConv = fp colInfo (Just bs) in case runConversion valConv colInfo.encodingContext of Ok v -> Right v Errors errs -> Left (show errs), + decodesSqlNullTo = + let valConv = fp (error "Oh no! No colInfo here.. what do we do!?") Nothing + encCtx = error "We could fake an EncodingContext, at least. TODO." + in case runConversion valConv encCtx of + Ok v -> Right v + Errors errs -> Left (show errs), allowedPgTypes = const True -- No way to check if types are valid ahead of time } fromHpgsqlFieldDecoder :: FieldDecoder a -> FieldParser a -fromHpgsqlFieldDecoder dec = \f mbs -> Conversion $ \_encCtx -> case dec.fieldValueDecoder f mbs of - Right v -> Ok v - Left err -> Errors [toException $ userError $ show err] +fromHpgsqlFieldDecoder dec = \f mbs -> Conversion $ \_encCtx -> + case mbs of + Nothing -> case dec.decodesSqlNullTo of + Left err -> Errors [toException $ userError $ show err] + Right v -> Ok v + Just bs -> case dec.fieldValueDecoder f bs of + Right v -> Ok v + Left err -> Errors [toException $ userError $ show err] -- | Given a Hpgsql query, returns the text format with question marks -- for query arguments and a row object. With both, you can call diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index 6d0fa9e..919278e 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -21,7 +21,7 @@ -- of fields), check "Hpgsql.Encoding.RowDecoderMonadic". module Hpgsql.Encoding ( -- * Decoding - FromPgField (fieldDecoder, inlinedSingleFieldRowDecoder), -- Don't export the other internal perf-oriented methods yet + FromPgField (..), -- We export the other internal perf-oriented methods, which isn't great because we may want to change them FieldDecoder (..), -- TODO: Can we export ctor? FieldInfo (..), FromPgRow (..), @@ -207,8 +207,9 @@ class FromPgField a where inlinedConstFieldDecoder :: Maybe (Parser.Parser (Maybe a)) inlinedConstFieldDecoder = Nothing - -- | For types that can't implement `inlinedConstFieldDecoder`, this is the next - -- best thing: also a specialized field+value decoder that can be faster than + -- | For types that can't implement `inlinedConstFieldDecoder` because they + -- need to know the value's OID for decoding, this is the next best thing: + -- also a specialized field+value decoder that can be faster than the -- one derived from `fieldDecoder`. -- -- Any implementation of this _must_ return a `Nothing` for a SQL NULL value, @@ -1058,25 +1059,13 @@ instance FromPgField Scientific where decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`", allowedPgTypes = (`elem` [numericOid, int2Oid, int4Oid, int8Oid]) . fieldTypeOid } - {-# INLINE inlinedSingleFieldRowDecoder #-} - inlinedSingleFieldRowDecoder = + {-# INLINE notConstFieldDecoder #-} + notConstFieldDecoder = let !int64RowDec = fromMaybe (error "Bug in HPgsql: Int64 does not have an inlinedConstFieldDecoder") $ inlinedConstFieldDecoder @Int64 - in RowDecoder - { fullRowDecoder = \case - [singleColInfo] -> do - msci <- - if singleColInfo.fieldTypeOid /= numericOid - then fmap (flip scientific 0 . fromIntegral) <$> int64RowDec - else numericRowParser - case msci of - Nothing -> fail "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`" - Just sci -> pure sci - _ -> error "singleField expected a single column OID but got 0 or >1", - rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid `elem` [numericOid, int2Oid, int4Oid, int8Oid])] - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", - numExpectedColumns = 1 - } + in \singleColInfo -> + if singleColInfo.fieldTypeOid /= numericOid + then fmap (flip scientific 0 . fromIntegral) <$> int64RowDec + else numericRowParser instance FromPgField (Ratio Integer) where {-# INLINE fieldDecoder #-} @@ -1334,6 +1323,13 @@ instance (FromPgField a) => FromPgField (Maybe a) where {-# INLINE fieldDecoder #-} fieldDecoder = nullableField fieldDecoder + {-# INLINE notConstFieldDecoder #-} + notConstFieldDecoder finfo = do + mv <- notConstFieldDecoder @a finfo + case mv of + Nothing -> pure Nothing + jv -> pure $ Just jv + {-# INLINE inlinedConstFieldDecoder #-} -- \| For types where there is a fast way to decode fields+values -- without knowing the OID of the value in the query (of course, the diff --git a/hpgsql/src/Hpgsql/Types.hs b/hpgsql/src/Hpgsql/Types.hs index 08a56b6..2fc1dbe 100644 --- a/hpgsql/src/Hpgsql/Types.hs +++ b/hpgsql/src/Hpgsql/Types.hs @@ -20,6 +20,7 @@ import Data.Tuple.Only (Only (..)) import Data.Typeable (Proxy (..)) import Hpgsql.Builder (BinaryField (..)) import Hpgsql.Encoding (FieldDecoder (..), FieldEncoder (..), FieldInfo (..), FromPgField (..), FromPgRow (..), RowEncoder (..), ToPgField (..), ToPgRow (..), arrayField, toPgVectorField) +import qualified Hpgsql.SimpleParser as Parser import Hpgsql.TypeInfo (EncodingContext (..), TypeInfo (..), jsonOid, jsonbOid, lookupTypeByOid) -- | Encodes a Haskell list as a postgres array. You can also use `Vector` if you prefer. @@ -95,6 +96,16 @@ instance FromPgField PgJson where decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell PgJson type. Use a `Maybe PgJson` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } + {-# INLINE notConstFieldDecoder #-} + notConstFieldDecoder finfo = do + len <- fromIntegral <$> Parser.takeInt32BE + if len == (-1) + then pure Nothing + else + fmap (Just . PgJson) $ + if finfo.fieldTypeOid == jsonbOid + then Parser.skip 1 >> Parser.take (len - 1) + else Parser.take len -- | A newtype wrapper to decode a JSON value with Aeson -- into your type (from either json or jsonb), and to encode @@ -113,10 +124,18 @@ instance (FromJSON a) => FromPgField (Aeson a) where !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id in \bs -> case Aeson.decodeStrict $ fixJsonb bs of Just v -> Right $ Aeson v - Nothing -> Left "Failed to decode postgres JSON value into your `Aeson a` type. Are you sure it's proper JSON?", + Nothing -> Left "Failed to decode the postgres JSON value into your `Aeson a` type with aeson", decodesSqlNullTo = Left "Cannot decode SQL null as a Haskell (Aeson a) type. Use a `Maybe (Aeson a)` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } + {-# INLINE notConstFieldDecoder #-} + notConstFieldDecoder finfo = + notConstFieldDecoder finfo >>= \case + Nothing -> pure Nothing + Just (PgJson jsonBs) -> + case Aeson.decodeStrict jsonBs of + Just v -> pure $ Just $ Aeson v + Nothing -> fail "Failed to decode the postgres JSON value into your `Aeson a` type with aeson" instance (ToJSON a) => ToPgField (Aeson a) where fieldEncoder = From 63c1e9736d2387812635a4937425c7f557c6e063 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Fri, 14 Aug 2026 16:24:49 -0300 Subject: [PATCH 29/35] Create new strict and lazy ByteString-like PinnedByteArray types And use them almost everywhere. --- Runfile | 2 +- TODO.md | 4 +- hpgsql-tests/EncodingDecodingSpec.hs | 21 - hpgsql/hpgsql.cabal | 2 +- hpgsql/src/Hpgsql/Encoding.hs | 163 ++++---- .../src/Hpgsql/Encoding/BinarySerializer.hs | 225 ----------- hpgsql/src/Hpgsql/Internal.hs | 52 +-- hpgsql/src/Hpgsql/InternalTypes.hs | 5 +- hpgsql/src/Hpgsql/Msgs.hs | 14 +- hpgsql/src/Hpgsql/Networking.hs | 17 +- hpgsql/src/Hpgsql/PinnedByteArray.hs | 376 ++++++++++++++++++ hpgsql/src/Hpgsql/SimpleParser.hs | 65 ++- hpgsql/src/Hpgsql/Types.hs | 7 +- 13 files changed, 542 insertions(+), 411 deletions(-) delete mode 100644 hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs create mode 100644 hpgsql/src/Hpgsql/PinnedByteArray.hs diff --git a/Runfile b/Runfile index 406b180..6f66d84 100644 --- a/Runfile +++ b/Runfile @@ -73,7 +73,7 @@ tests: if [ -n "$NIX" ]; then nix-build --no-out-link -A "testsPg${pg}" --argstr hspecArgs "$TARGS" else - cabal build hpgsql-tests hpgsql-simple-compat-tests + cabal build hpgsql-tests # hpgsql-simple-compat-tests nix-shell -A "shellPg${pg}" ./default.nix --run "./scripts/run-tests-db-internal.sh $TARGS" fi done diff --git a/TODO.md b/TODO.md index 95ea5db..73f8067 100644 --- a/TODO.md +++ b/TODO.md @@ -1,3 +1 @@ -- Test both `singleField fieldDecoder` and `singleFieldRowDecoder` for every type in our tests. -- Some types (the Aeson ones, for example, but more) still don't derive specialized row decoders -- "Oh no! No colInfo here.. what do we do!?" in hpgsql-simple-compat. This might require a big rethinking of things.. +- If ShortByteStrings are really beneficial, consider breaking API change to take a ShortByteString instead in FromPgField to avoid so much converting between ByteString and ShortByteString diff --git a/hpgsql-tests/EncodingDecodingSpec.hs b/hpgsql-tests/EncodingDecodingSpec.hs index d49bc84..0b960a0 100644 --- a/hpgsql-tests/EncodingDecodingSpec.hs +++ b/hpgsql-tests/EncodingDecodingSpec.hs @@ -166,9 +166,6 @@ spec = parallel $ do it "0-columns results can be decoded" zeroColumnsResults - it - "Specialized DataRow decoding consistency" - specializedDataRowDecodingConsistency zeroColumnsResults :: IO () zeroColumnsResults = do @@ -1026,24 +1023,6 @@ data Person = Person {name :: Text, born :: Day, heightMeters :: Double} deriving stock (Generic) deriving anyclass (FromPgRow) -specializedDataRowDecodingConsistency :: PropertyT IO () -specializedDataRowDecodingConsistency = hedgehog $ do - dataRows <- Gen.forAll $ Gen.list (Gen.linear 0 20) genDataRowBS - mapM_ - ( \drBS -> do - let restOfMsg = LBS.fromStrict (BS.drop 5 drBS) - parsed = parseDataRowFromPgMsg 'D' restOfMsg - fmap fullDataRow parsed === Just drBS - ) - dataRows - --- | Copy of the FromPgMessage DataRow instance's parsing logic from Hpgsql.Msgs. --- Keep in sync with that module's @instance FromPgMessage DataRow@. -parseDataRowFromPgMsg :: Char -> LBS.ByteString -> Maybe DataRow -parseDataRowFromPgMsg c !restOfMsg = case c of - 'D' -> Just $ DataRow $ BS.singleton 68 <> testEncodeInt32BE (fromIntegral $ LBS.length restOfMsg + 4) <> LBS.toStrict restOfMsg - _ -> Nothing - genDataRowBS :: Gen.Gen ByteString genDataRowBS = do numFields <- Gen.int (Gen.linear 0 10) diff --git a/hpgsql/hpgsql.cabal b/hpgsql/hpgsql.cabal index d20fb9c..7a4d495 100644 --- a/hpgsql/hpgsql.cabal +++ b/hpgsql/hpgsql.cabal @@ -43,7 +43,6 @@ library Hpgsql.Types other-modules: Hpgsql.Base - Hpgsql.Encoding.BinarySerializer Hpgsql.Internal Hpgsql.LanguageHaskell.FromThExtension Hpgsql.LanguageHaskell.GhcParserOpts @@ -51,6 +50,7 @@ library Hpgsql.Locking Hpgsql.Msgs Hpgsql.Networking + Hpgsql.PinnedByteArray Hpgsql.QueryInternal Hpgsql.ScramSHA256 Hpgsql.SimpleParser diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index 919278e..eb9e63b 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -106,7 +106,8 @@ import GHC.TypeLits (KnownSymbol, TypeError, symbolVal) import qualified GHC.TypeLits as TypeLits import Hpgsql.Builder (BinaryField (..)) import qualified Hpgsql.Builder as Builder -import qualified Hpgsql.Encoding.BinarySerializer as BinSer +import Hpgsql.PinnedByteArray (PinnedByteArray) +import qualified Hpgsql.PinnedByteArray as PBA import qualified Hpgsql.SimpleParser as Parser import Hpgsql.Time (Unbounded (..)) import Hpgsql.TypeInfo (EncodingContext (..), Oid (..), TypeDetails (..), TypeInfo (..), boolOid, byteaOid, charOid, dateOid, float4Oid, float8Oid, int2Oid, int4Oid, int8Oid, intervalOid, jsonOid, jsonbOid, lookupTypeByName, lookupTypeByOid, nameOid, numericOid, oidOid, textOid, timeOid, timestampOid, timestamptzOid, uuidOid, varcharOid, voidOid) @@ -121,7 +122,7 @@ data FieldInfo = FieldInfo -- | A decoder for a single field/column. data FieldDecoder a = FieldDecoder - { fieldValueDecoder :: FieldInfo -> ByteString -> Either String a, + { fieldValueDecoder :: FieldInfo -> PinnedByteArray -> Either String a, decodesSqlNullTo :: Either String a, allowedPgTypes :: FieldInfo -> Bool } @@ -322,10 +323,10 @@ compositeTypeDecoder (RowDecoder {..}) = !oid <- Oid . fromIntegral <$> Parser.takeInt32BE (sizeBs, !size) <- Parser.match $ fromIntegral <$> Parser.takeInt32BE !bs <- Parser.take (max 0 size) - pure (oid, sizeBs <> bs) + pure (oid, PBA.fromStrict sizeBs <> PBA.fromStrict bs) let typecheckedCols = rowColumnsTypeCheck (map (mkColInfo . fst) cols) unless (all snd typecheckedCols) $ fail $ "Parser for composite found type OIDs " ++ show (map fst cols) ++ " but expected different" - case Parser.parseOnly (fullRowDecoder (map (mkColInfo . fst) cols) <* Parser.endOfInput) (mconcat $ map snd cols) of + case Parser.parseOnly (fullRowDecoder (map (mkColInfo . fst) cols) <* Parser.endOfInput) (PBA.toStrict $ mconcat $ map snd cols) of Parser.ParseOk v -> pure v Parser.ParseFail err -> error $ "Error decoding composite type: " ++ show err @@ -436,21 +437,21 @@ instance ToPgField Int16 where fieldEncoder = FieldEncoder { toTypeOid = \_ -> Just int2Oid, - toPgField = \_ -> \n -> NotNull $ BinSer.encodeInt16BE n + toPgField = \_ -> \n -> NotNull $ PBA.encodeInt16BE n } instance ToPgField Int32 where fieldEncoder = FieldEncoder { toTypeOid = \_ -> Just int4Oid, - toPgField = \_ -> \n -> NotNull $ BinSer.encodeInt32BE n + toPgField = \_ -> \n -> NotNull $ PBA.encodeInt32BE n } instance ToPgField Int64 where fieldEncoder = FieldEncoder { toTypeOid = \_ -> Just int8Oid, - toPgField = \_ -> \n -> NotNull $ BinSer.encodeInt64BE n + toPgField = \_ -> \n -> NotNull $ PBA.encodeInt64BE n } instance ToPgField Integer where @@ -473,7 +474,7 @@ instance ToPgField Oid where fieldEncoder = FieldEncoder { toTypeOid = \_ -> Just oidOid, - toPgField = \_ -> \n -> NotNull $ BinSer.encodeInt32BE $ fromIntegral n + toPgField = \_ -> \n -> NotNull $ PBA.encodeInt32BE $ fromIntegral n } instance ToPgField Scientific where @@ -481,7 +482,7 @@ instance ToPgField Scientific where FieldEncoder { toTypeOid = \_ -> Just numericOid, toPgField = \_ -> \n -> - let sign = BinSer.encodeInt16BE $ if n >= 0 then 0 else 0x4000 + let sign = PBA.encodeInt16BE $ if n >= 0 then 0 else 0x4000 -- The number is coeff * 10^exp, but we want it in base-10000 so we convert it to -- new_coeff * 10^new_exp with new_exp a multiple of 4 base10000Expon = 4 * (base10Exponent n `div` 4) @@ -489,8 +490,8 @@ instance ToPgField Scientific where ndigits, weight :: Int16 digits :: ByteString (ndigits, weight, digits) = calculateDigits 0 0 (abs base10000Coeff) "" - dscale = BinSer.encodeInt16BE (abs $ fromIntegral base10000Expon) -- More than necessary, but safe? - in NotNull $ BinSer.encodeInt16BE ndigits <> BinSer.encodeInt16BE (weight - 1 + fromIntegral (base10000Expon `div` 4)) <> sign <> dscale <> digits + dscale = PBA.encodeInt16BE (abs $ fromIntegral base10000Expon) -- More than necessary, but safe? + in NotNull $ PBA.encodeInt16BE ndigits <> PBA.encodeInt16BE (weight - 1 + fromIntegral (base10000Expon `div` 4)) <> sign <> dscale <> digits } where calculateDigits :: Int16 -> Int16 -> Integer -> BS.ByteString -> (Int16, Int16, BS.ByteString) @@ -501,27 +502,27 @@ instance ToPgField Scientific where (ndigitsSoFar + 1) (weightSoFar + 1) quotient - (BinSer.encodeInt16BE rest <> encodedDigits) + (PBA.encodeInt16BE rest <> encodedDigits) instance ToPgField Float where fieldEncoder = FieldEncoder { toTypeOid = \_ -> Just float4Oid, - toPgField = \_ -> \n -> NotNull $ BinSer.encodeFloat n + toPgField = \_ -> \n -> NotNull $ PBA.encodeFloat n } instance ToPgField Double where fieldEncoder = FieldEncoder { toTypeOid = \_ -> Just float8Oid, - toPgField = \_ -> \n -> NotNull $ BinSer.encodeDouble n + toPgField = \_ -> \n -> NotNull $ PBA.encodeDouble n } instance ToPgField Bool where fieldEncoder = FieldEncoder { toTypeOid = \_ -> Just boolOid, - toPgField = \_ n -> NotNull $ BinSer.encodePgBoolean n + toPgField = \_ n -> NotNull $ PBA.encodePgBoolean n } instance ToPgField Day where @@ -531,7 +532,7 @@ instance ToPgField Day where FieldEncoder { toTypeOid = \_ -> Just dateOid, -- TODO: Catch integer overflow and do what? - toPgField = \_ d -> NotNull $ BinSer.encodeInt32BE $ fromIntegral $ diffDays d (fromGregorian 2000 1 1) + toPgField = \_ d -> NotNull $ PBA.encodeInt32BE $ fromIntegral $ diffDays d (fromGregorian 2000 1 1) } instance ToPgField (Unbounded Day) where @@ -540,9 +541,9 @@ instance ToPgField (Unbounded Day) where in FieldEncoder { toTypeOid = fe.toTypeOid, toPgField = \encCtx -> \case - NegInfinity -> NotNull $ BinSer.encodeInt32BE minBound + NegInfinity -> NotNull $ PBA.encodeInt32BE minBound Finite v -> fe.toPgField encCtx v - PosInfinity -> NotNull $ BinSer.encodeInt32BE maxBound + PosInfinity -> NotNull $ PBA.encodeInt32BE maxBound } instance ToPgField CalendarDiffTime where @@ -551,7 +552,7 @@ instance ToPgField CalendarDiffTime where { toTypeOid = \_ -> Just intervalOid, toPgField = \_ CalendarDiffTime {..} -> let (days :: Int32, timeUnderOneDay) = ctTime `divMod'` 86_400 - in NotNull $ BinSer.encodeInt64BE (round $ timeUnderOneDay * 1_000_000) <> BinSer.encodeInt32BE days <> BinSer.encodeInt32BE (fromIntegral ctMonths) + in NotNull $ PBA.encodeInt64BE (round $ timeUnderOneDay * 1_000_000) <> PBA.encodeInt32BE days <> PBA.encodeInt32BE (fromIntegral ctMonths) } instance ToPgField NominalDiffTime where @@ -559,7 +560,7 @@ instance ToPgField NominalDiffTime where FieldEncoder { toTypeOid = \_ -> Just intervalOid, toPgField = \_ ndt -> - NotNull $ BinSer.encodeInt64BE (round $ ndt * 1_000_000) <> BinSer.encodeInt32BE 0 <> BinSer.encodeInt32BE 0 + NotNull $ PBA.encodeInt64BE (round $ ndt * 1_000_000) <> PBA.encodeInt32BE 0 <> PBA.encodeInt32BE 0 } instance ToPgField UTCTime where @@ -570,7 +571,7 @@ instance ToPgField UTCTime where toPgField = \_ (UTCTime parsedDate timeinday) -> let day :: Int64 = fromInteger $ parsedDate `diffDays` fromJulian 1999 12 19 totalusecs :: Int64 = 86_400_000_000 * day + fromInteger (diffTimeToPicoseconds timeinday `div` 1_000_000) - in NotNull $ BinSer.encodeInt64BE totalusecs + in NotNull $ PBA.encodeInt64BE totalusecs } instance ToPgField (Unbounded UTCTime) where @@ -579,9 +580,9 @@ instance ToPgField (Unbounded UTCTime) where in FieldEncoder { toTypeOid = fe.toTypeOid, toPgField = \encCtx -> \case - NegInfinity -> NotNull $ BinSer.encodeInt64BE minBound + NegInfinity -> NotNull $ PBA.encodeInt64BE minBound Finite v -> fe.toPgField encCtx v - PosInfinity -> NotNull $ BinSer.encodeInt64BE maxBound + PosInfinity -> NotNull $ PBA.encodeInt64BE maxBound } instance ToPgField ZonedTime where @@ -598,9 +599,9 @@ instance ToPgField (Unbounded ZonedTime) where in FieldEncoder { toTypeOid = fe.toTypeOid, toPgField = \encCtx -> \case - NegInfinity -> NotNull $ BinSer.encodeInt64BE minBound + NegInfinity -> NotNull $ PBA.encodeInt64BE minBound Finite v -> fe.toPgField encCtx v - PosInfinity -> NotNull $ BinSer.encodeInt64BE maxBound + PosInfinity -> NotNull $ PBA.encodeInt64BE maxBound } instance ToPgField LocalTime where @@ -610,7 +611,7 @@ instance ToPgField LocalTime where toPgField = \_ (LocalTime localDay localTimeOfDay) -> let day :: Int64 = fromInteger $ localDay `diffDays` fromJulian 1999 12 19 totalusecs :: Int64 = 86_400_000_000 * day + fromInteger (diffTimeToPicoseconds (timeOfDayToTime localTimeOfDay) `div` 1_000_000) - in NotNull $ BinSer.encodeInt64BE totalusecs + in NotNull $ PBA.encodeInt64BE totalusecs } instance ToPgField TimeOfDay where @@ -619,7 +620,7 @@ instance ToPgField TimeOfDay where { toTypeOid = \_ -> Just timeOid, toPgField = \_ tod -> let usecs :: Int64 = fromInteger $ diffTimeToPicoseconds (timeOfDayToTime tod) `div` 1_000_000 - in NotNull $ BinSer.encodeInt64BE usecs + in NotNull $ PBA.encodeInt64BE usecs } instance ToPgField Char where @@ -816,33 +817,33 @@ haskellIntOids :: [Oid] -- | Big-Endian binary encoder for Haskell's `Data.Int`, which is machine-dependent. binaryIntEncoder :: Int -> BinaryField binaryIntEncoder - | haskellIntOid == int8Oid = NotNull . BinSer.encodeInt64BE . fromIntegral - | haskellIntOid == int4Oid = NotNull . BinSer.encodeInt32BE . fromIntegral - | otherwise = NotNull . BinSer.encodeInt16BE . fromIntegral + | haskellIntOid == int8Oid = NotNull . PBA.encodeInt64BE . fromIntegral + | haskellIntOid == int4Oid = NotNull . PBA.encodeInt32BE . fromIntegral + | otherwise = NotNull . PBA.encodeInt16BE . fromIntegral -- | Big-Endian binary decoder for Haskell's various IntXX types. -binaryIntDecoder :: forall a. (Integral a, Bounded a) => Oid -> ByteString -> Either String a +binaryIntDecoder :: forall a. (Integral a, Bounded a) => Oid -> PinnedByteArray -> Either String a binaryIntDecoder typOid = \bs -> if doesFit then intDecoder bs else Left $ "Chosen integral type does not fit every value for PG type with OID " ++ show typOid where maxBoundPgType :: Integer - intDecoder :: ByteString -> Either String a + intDecoder :: PinnedByteArray -> Either String a (maxBoundPgType, intDecoder) - | typOid == int8Oid = (fromIntegral $ maxBound @Int64, fmap fromIntegral . BinSer.decodeInt64BE 0) - | typOid == int4Oid = (fromIntegral $ maxBound @Int32, fmap fromIntegral . BinSer.decodeInt32BE 0) - | typOid == int2Oid = (fromIntegral $ maxBound @Int16, fmap fromIntegral . BinSer.decodeInt16BE 0) + | typOid == int8Oid = (fromIntegral $ maxBound @Int64, fmap fromIntegral . PBA.decodeInt64BE 0) + | typOid == int4Oid = (fromIntegral $ maxBound @Int32, fmap fromIntegral . PBA.decodeInt32BE 0) + | typOid == int2Oid = (fromIntegral $ maxBound @Int16, fmap fromIntegral . PBA.decodeInt16BE 0) | otherwise = error "Bug in Hpgsql. Decoding binary integral type not an int2, int4 or int8" doesFit = maxBoundPgType <= fromIntegral (maxBound @a) -binaryFloat4Decoder :: ByteString -> Float -binaryFloat4Decoder = castWord32ToFloat . either error id . BinSer.decodeWord32BE 0 +binaryFloat4Decoder :: PinnedByteArray -> Float +binaryFloat4Decoder = castWord32ToFloat . either error id . PBA.decodeWord32BE 0 -binaryFloat8Decoder :: ByteString -> Double -binaryFloat8Decoder = castWord64ToDouble . either error id . BinSer.decodeWord64BE 0 +binaryFloat8Decoder :: PinnedByteArray -> Double +binaryFloat8Decoder = castWord64ToDouble . either error id . PBA.decodeWord64BE 0 -parsePgType :: String -> [Oid] -> (ByteString -> Either String a) -> FieldDecoder a +parsePgType :: String -> [Oid] -> (PinnedByteArray -> Either String a) -> FieldDecoder a parsePgType !typeName !requiredTypeOids !fieldValueDecoder = FieldDecoder { fieldValueDecoder = \_oid -> fieldValueDecoder, @@ -854,9 +855,11 @@ instance FromPgField () where {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder - { fieldValueDecoder = \_oid -> \case - "" -> Right () - bs -> Left $ "Invalid value '" ++ show bs ++ "' for postgres void type", + { fieldValueDecoder = \_oid -> \bs -> + if PBA.length bs == 0 + then Right () + else + Left $ "Invalid value for postgres void type", decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell () type. Use a `Maybe ()`", allowedPgTypes = (== voidOid) . fieldTypeOid } @@ -1071,12 +1074,12 @@ instance FromPgField (Ratio Integer) where {-# INLINE fieldDecoder #-} fieldDecoder = toRational <$> fieldDecoder @Scientific -binaryTrue :: ByteString -binaryTrue = BinSer.encodePgBoolean True +binaryTrue :: PinnedByteArray +binaryTrue = PBA.fromByteString $ PBA.encodePgBoolean True {-# INLINE boolRowDecoder #-} boolRowDecoder :: Parser.Parser (Maybe Bool) -boolRowDecoder = fmap (== 1) <$> Parser.parsePgFieldWithAtMost4Bytes BinSer.TypeSize1 +boolRowDecoder = fmap (== 1) <$> Parser.parsePgFieldWithAtMost4Bytes PBA.TypeSize1 instance FromPgField Bool where {-# INLINE fieldDecoder #-} @@ -1094,9 +1097,7 @@ instance FromPgField Char where let !decodeText = textParser colInfo in \bs -> if oid == charOid - -- TODO: Postgres has values of type "char" in the pg_type.typcategory table. - -- We should test this instance works with those, and we haven't yet. - then Right $ BSC.head bs + then Right $ BSC.head $ PBA.toByteString bs else case decodeText bs of Left err -> Left err Right t -> if Text.length t > 1 then Left "Cannot parse text with more than one character into a Haskell Char type." else Right (Text.head t), @@ -1107,11 +1108,11 @@ instance FromPgField Char where instance FromPgField ByteString where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "byteString" [byteaOid] Right + fieldDecoder = parsePgType "byteString" [byteaOid] (Right . PBA.toByteString) instance FromPgField LBS.ByteString where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "ByteString" [byteaOid] $ Right . LBS.fromStrict + fieldDecoder = parsePgType "ByteString" [byteaOid] $ (Right . LBS.fromStrict . PBA.toByteString) {-# INLINE textDecoder #-} textDecoder :: Parser.Parser (Maybe Text) @@ -1119,23 +1120,23 @@ textDecoder = do len <- Parser.takeInt32BE if len >= 0 -- TODO: Use some faster unsafeDecodeUtf8 function? - then Just . decodeUtf8 <$> Parser.take (fromIntegral len) + then Just . decodeUtf8 . PBA.toByteString <$> Parser.take (fromIntegral len) else pure Nothing instance FromPgField Text where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ decodeUtf8 bs + fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ decodeUtf8 $ PBA.toByteString bs {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just textDecoder instance FromPgField LT.Text where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ LT.fromStrict $ decodeUtf8 bs + fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ LT.fromStrict $ decodeUtf8 $ PBA.toByteString bs instance FromPgField String where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "String" [textOid, varcharOid, nameOid] $ \bs -> Right $ Text.unpack $ decodeUtf8 bs + fieldDecoder = parsePgType "String" [textOid, varcharOid, nameOid] $ \bs -> Right $ Text.unpack $ decodeUtf8 $ PBA.toByteString bs -- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default -- connection option). @@ -1172,7 +1173,7 @@ instance FromPgField UTCTime where fieldDecoder = parsePgType "UTCTime" [timestamptzOid] $ \case bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- BinSer.decodeInt64BE 0 bs + totalusecs <- PBA.decodeInt64BE 0 bs let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 Right $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) @@ -1185,7 +1186,7 @@ instance FromPgField (Unbounded UTCTime) where fieldDecoder = parsePgType "Unbounded UTCTime" [timestamptzOid] $ \case bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- BinSer.decodeInt64BE 0 bs + totalusecs <- PBA.decodeInt64BE 0 bs Right $ if totalusecs == minBound then NegInfinity @@ -1202,7 +1203,7 @@ instance FromPgField ZonedTime where fieldDecoder = parsePgType "ZonedTime" [timestamptzOid] $ \case bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- BinSer.decodeInt64BE 0 bs + totalusecs <- PBA.decodeInt64BE 0 bs let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 Right $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) @@ -1212,7 +1213,7 @@ instance FromPgField (Unbounded ZonedTime) where fieldDecoder = parsePgType "Unbounded ZonedTime" [timestamptzOid] $ \case bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- BinSer.decodeInt64BE 0 bs + totalusecs <- PBA.decodeInt64BE 0 bs Right $ if totalusecs == minBound then NegInfinity @@ -1228,7 +1229,7 @@ instance FromPgField LocalTime where {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "LocalTime" [timestampOid] $ \case bs -> do - totalusecs <- BinSer.decodeInt64BE 0 bs + totalusecs <- PBA.decodeInt64BE 0 bs let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 Right $ LocalTime parsedDate (timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) @@ -1237,7 +1238,7 @@ instance FromPgField TimeOfDay where {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "TimeOfDay" [timeOid] $ \case bs -> do - usecs <- BinSer.decodeInt64BE 0 bs + usecs <- PBA.decodeInt64BE 0 bs Right $ timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral usecs * 1_000_000 {-# INLINE dayRowDecoder #-} @@ -1253,7 +1254,7 @@ instance FromPgField Day where -- There is a very specific conversion function for these, which I poorly translated to Haskell -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 -- But I found a simpler way to do this. Let's see if it works in our property based tests - jd <- BinSer.decodeInt32BE 0 bs + jd <- PBA.decodeInt32BE 0 bs Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 {-# INLINE inlinedConstFieldDecoder #-} @@ -1266,7 +1267,7 @@ instance FromPgField (Unbounded Day) where -- There is a very specific conversion function for these, which I poorly translated to Haskell -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 -- But I found a simpler way to do this. Let's see if it works in our property based tests - jd <- BinSer.decodeInt32BE 0 bs + jd <- PBA.decodeInt32BE 0 bs Right $ if jd == minBound then NegInfinity @@ -1279,15 +1280,15 @@ instance FromPgField (Unbounded Day) where instance FromPgField CalendarDiffTime where {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "CalendarDiffTime " [intervalOid] $ \bs -> do - nMicrosecs <- BinSer.decodeInt64BE 0 bs - nDays <- BinSer.decodeInt32BE 8 bs - nMonths <- BinSer.decodeInt32BE 12 bs + nMicrosecs <- PBA.decodeInt64BE 0 bs + nDays <- PBA.decodeInt32BE 8 bs + nMonths <- PBA.decodeInt32BE 12 bs Right $ CalendarDiffTime {ctMonths = fromIntegral nMonths, ctTime = secondsToNominalDiffTime (fromIntegral nDays * 86400) + realToFrac (picosecondsToDiffTime (fromIntegral nMicrosecs * 1_000_000))} instance FromPgField UUID where {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "UUID" [uuidOid] $ \case - bs -> case UUID.fromByteString (LBS.fromStrict bs) of + bs -> case UUID.fromByteString (LBS.fromStrict $ PBA.toByteString bs) of Just uuid -> Right uuid Nothing -> Left "Bug in Hpgsql: UUID field could not be decoded" @@ -1300,7 +1301,7 @@ instance FromPgField Aeson.Value where let -- jsonb has a byte prepended to the contents and json does not !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id in \case - bs -> case Aeson.decodeStrict $ fixJsonb bs of + bs -> case Aeson.decodeStrict $ fixJsonb (PBA.toByteString bs) of Just d -> Right d Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls", @@ -1362,10 +1363,9 @@ instance {-# OVERLAPPING #-} forall a. (FromPgField a) => FromPgField (Vector (V FieldDecoder { fieldValueDecoder = \colInfo -> let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput - in \case - bs -> case Parser.parseOnly arrayFieldDecoder bs of - Parser.ParseOk v -> Right v - Parser.ParseFail err -> Left err, + in \bs -> case Parser.parseOnly arrayFieldDecoder bs of + Parser.ParseOk v -> Right v + Parser.ParseFail err -> Left err, decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell (Vector (Vector a)) type. Use a `Maybe (Vector (Vector a))`", allowedPgTypes = allowOnlyArrayTypes } @@ -1533,7 +1533,7 @@ rawBytesFieldDecoder :: FieldDecoder ByteString rawBytesFieldDecoder = FieldDecoder { fieldValueDecoder = \_oid -> \case - bs -> Right bs, + bs -> Right $ PBA.toByteString bs, decodesSqlNullTo = Left "Cannot decode SQL null as the `rawBytesFieldDecoder`.", allowedPgTypes = const True } @@ -1547,12 +1547,12 @@ toPgVectorField encCtx = in \vec -> let ndim = Builder.int32BE 1 -- Postgres seems to build the "has_nulls" flag itself in the ReadArrayBinary function at https://github.com/postgres/postgres/blob/aa7f9493a02f5981c09b924323f0e7a58a32f2ed/src/backend/utils/adt/arrayfuncs.c#L1429, so we can just set it to 0 - hasNull = Builder.byteString $ BinSer.encodeInt32BE 0 - -- hasNull = Builder.byteString $ BinSer.encodeInt32BE (if Vector.any (\e -> toPgField e == Nothing) vec then 1 else 0) - elemOidBs = Builder.byteString $ BinSer.encodeInt32BE elemOid - lb1 = Builder.byteString $ BinSer.encodeInt32BE 1 + hasNull = Builder.byteString $ PBA.encodeInt32BE 0 + -- hasNull = Builder.byteString $ PBA.encodeInt32BE (if Vector.any (\e -> toPgField e == Nothing) vec then 1 else 0) + elemOidBs = Builder.byteString $ PBA.encodeInt32BE elemOid + lb1 = Builder.byteString $ PBA.encodeInt32BE 1 (Sum len, encodedElements) = foldMap (\el -> (Sum 1, encodeElement el)) vec - dim1 = Builder.byteString $ BinSer.encodeInt32BE len + dim1 = Builder.byteString $ PBA.encodeInt32BE len fullBs = ndim <> hasNull <> elemOidBs <> dim1 <> lb1 <> encodedElements in NotNull (Builder.toStrictByteString fullBs) @@ -1563,10 +1563,9 @@ arrayField !replicateFunction !elementParser = FieldDecoder { fieldValueDecoder = \colInfo -> let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput - in \case - bs -> case Parser.parseOnly arrayFieldDecoder bs of - Parser.ParseOk v -> Right v - Parser.ParseFail err -> Left err, + in \bs -> case Parser.parseOnly arrayFieldDecoder bs of + Parser.ParseOk v -> Right v + Parser.ParseFail err -> Left err, decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Vector type. Use a `Maybe (Vector a)`", allowedPgTypes = allowOnlyArrayTypes } diff --git a/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs b/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs deleted file mode 100644 index a72fc8c..0000000 --- a/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs +++ /dev/null @@ -1,225 +0,0 @@ -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE CPP #-} - --- | --- A replacement for libraries like cereal or binary. --- In our tests, this is ~6.0% faster than cereal, and it also --- (or by virtue of) allocates ~13% less memory in some of our benchmarks. --- And it also means one fewer dependency. --- The caveat is that this module makes unaligned memory access. For the target --- CPU architectures of this library, this should be fine. -module Hpgsql.Encoding.BinarySerializer - ( ByteStringIdx (..), - decodeInt16BE, - decodeInt32BE, - decodeInt64BE, - decodeWord32BE, - decodeWord64BE, - encodeInt32BE, - encodeDouble, - encodeFloat, - encodeInt64BE, - encodeInt16BE, - encodePgBoolean, - decodeDataRow, - decodePgFieldWithAtMost4Bytes, - WordDecoding (..), - ) -where - -import Data.ByteString (ByteString) -import qualified Data.ByteString.Internal as InternalBS -import Data.Int (Int16, Int32, Int64) -import Prelude hiding (encodeFloat) -#if WORDS_BIGENDIAN -import Data.Word (Word16, Word32, Word64) -#else -import Data.Word (Word16, Word32, Word64, byteSwap16, byteSwap32, byteSwap64, Word8) -#endif -import Data.Bits (Bits (unsafeShiftR)) -import Data.Coerce (coerce) -import Foreign (Storable (..), (.&.)) -import Foreign.ForeignPtr (withForeignPtr) -import GHC.Float (castDoubleToWord64, castFloatToWord32) -import System.IO.Unsafe (unsafeDupablePerformIO) - -fromBigEndian32 :: Word32 -> Word32 -#if WORDS_BIGENDIAN -fromBigEndian32 = Prelude.id -#else -fromBigEndian32 = byteSwap32 -#endif - -fromBigEndian64 :: Word64 -> Word64 -#if WORDS_BIGENDIAN -fromBigEndian64 = Prelude.id -#else -fromBigEndian64 = byteSwap64 -#endif - -fromBigEndian16 :: Word16 -> Word16 -#if WORDS_BIGENDIAN -fromBigEndian16 = Prelude.id -#else -fromBigEndian16 = byteSwap16 -#endif - -{-# INLINE unsafeDecodeWord #-} -unsafeDecodeWord :: (Storable a) => ByteStringIdx -> ByteString -> Int -> (a -> a) -> Either String a -unsafeDecodeWord idx (InternalBS.BS bytesPtr len) minLen endianConvert = - if len >= minLen + idx.idx - then - -- A bang (strictness) in `decodedWord` makes our benchmarks allocate more memory and run slower! - let decodedWord = endianConvert $ unsafeDupablePerformIO $ withForeignPtr bytesPtr $ \ptr -> peekByteOff (coerce ptr) idx.idx - in Right decodedWord - else Left "Less than enough bytes to decode" - -{-# INLINE unsafeEncodeWord #-} -unsafeEncodeWord :: (Storable a) => a -> (a -> a) -> Int -> ByteString -unsafeEncodeWord n endianConvert len = - InternalBS.unsafeCreate len $ \bufferPtr -> - poke (coerce bufferPtr) $ endianConvert n - -newtype ByteStringIdx = ByteStringIdx {idx :: Int} - deriving newtype (Num) - -{-# INLINE decodeInt16BE #-} -decodeInt16BE :: ByteStringIdx -> ByteString -> Either String Int16 -decodeInt16BE idx bs = fromIntegral <$> unsafeDecodeWord idx bs 2 fromBigEndian16 - -{-# INLINE encodeInt16BE #-} -encodeInt16BE :: Int16 -> ByteString -encodeInt16BE n = unsafeEncodeWord (fromIntegral n) fromBigEndian16 2 - -{-# INLINE decodeWord8 #-} -decodeWord8 :: ByteStringIdx -> ByteString -> Either String Word8 -decodeWord8 idx bs = unsafeDecodeWord idx bs 1 Prelude.id - -{-# INLINE decodeWord32BE #-} -decodeWord32BE :: ByteStringIdx -> ByteString -> Either String Word32 -decodeWord32BE idx bs = unsafeDecodeWord idx bs 4 fromBigEndian32 - -{-# INLINE decodeWord64BE #-} -decodeWord64BE :: ByteStringIdx -> ByteString -> Either String Word64 -decodeWord64BE idx bs = unsafeDecodeWord idx bs 8 fromBigEndian64 - -{-# INLINE decodeInt32BE #-} -decodeInt32BE :: ByteStringIdx -> ByteString -> Either String Int32 -decodeInt32BE idx bs = fromIntegral <$> unsafeDecodeWord idx bs 4 fromBigEndian32 - -{-# INLINE encodeInt32BE #-} -encodeInt32BE :: Int32 -> ByteString -encodeInt32BE n = unsafeEncodeWord (fromIntegral n) fromBigEndian32 4 - -{-# INLINE decodeInt64BE #-} -decodeInt64BE :: ByteStringIdx -> ByteString -> Either String Int64 -decodeInt64BE idx bs = fromIntegral <$> unsafeDecodeWord idx bs 8 fromBigEndian64 - -{-# INLINE encodeInt64BE #-} -encodeInt64BE :: Int64 -> ByteString -encodeInt64BE n = unsafeEncodeWord (fromIntegral n) fromBigEndian64 8 - -{-# INLINE encodeFloat #-} -encodeFloat :: Float -> ByteString -encodeFloat n = unsafeEncodeWord (castFloatToWord32 n) fromBigEndian32 4 - -{-# INLINE encodeDouble #-} -encodeDouble :: Double -> ByteString -encodeDouble n = unsafeEncodeWord (castDoubleToWord64 n) fromBigEndian64 8 - --- TODO: Encode field length together with value for small types. --- This can also be a performance boost by having fewer bytestrings? -{-# INLINE encodePgBoolean #-} -encodePgBoolean :: Bool -> ByteString -encodePgBoolean v = if v then "\SOH" else "\NUL" - -{-# INLINE decodeDataRow #-} - --- | A super specialized decoder to decode a postgres DataRow message --- more quickly than a naive implementation. --- Returns the index into the left-unparsed contents of the supplied bytestring. -decodeDataRow :: ByteStringIdx -> ByteString -> Either String ByteStringIdx -decodeDataRow idx bs@(InternalBS.BS _bytesPtr len) = - -- We have a fast path when rows are at least 8 bytes long (should be the case - -- for all but 0-column query results or bytestring chunks "cut in the middle of the message") - -- by playing with bitwise operations. - -- Whether this is worth keeping is sort of questionable. It's complex - -- (even if I think it's safe and well tested) and reduces runtime of one of - -- our benchmarks by 2% compared to not having it. - case unsafeDecodeWord idx bs 8 fromBigEndian64 of - Right (w64 :: Word64) -> - -- After fromBigEndian64, the Word64 has bytes in big-endian order: - -- byte 0 (msg type) in MSB, bytes 1-4 (length) next, bytes 5-6 (col count), byte 7 in LSB. - let msgIdentByte64 = w64 .&. 0b11111111_00000000_00000000_00000000_00000000_00000000_00000000_00000000 - lenFullMsg = flip unsafeShiftR 24 $ w64 .&. 0b00000000_11111111_11111111_11111111_11111111_00000000_00000000_00000000 - letterD :: Word64 = 0b01000100_00000000_00000000_00000000_00000000_00000000_00000000_00000000 - in if msgIdentByte64 == letterD - then - toResult (fromIntegral lenFullMsg) - else Left "Not a DataRow (Word64 bits decoding path)" - Left _ -> - -- It is possible the DataRow has length less than 8 bytes, so - -- we still have to try to parse that. - if len >= 5 + idx.idx - then do - msgIdentChar <- decodeWord8 idx bs - lenFullMsg <- decodeInt32BE (1 + idx) bs - if msgIdentChar == 68 -- Letter 'D' - then toResult (fromIntegral lenFullMsg) - else Left "Not a DataRow" - else Left "Less than enough bytes to decode a DataRow" - where - toResult lenFullMsg - | len >= 1 + lenFullMsg + idx.idx = Right $ ByteStringIdx $ 1 + lenFullMsg + idx.idx - | otherwise = Left "Less than enough bytes to decode a full DataRow" - -data WordDecoding a where - TypeSize1 :: WordDecoding Word8 - TypeSize2 :: WordDecoding Word16 - TypeSize4 :: WordDecoding Word32 - -{-# INLINE decodePgFieldWithAtMost4Bytes #-} - --- | A specialized decoder that decoders a query result's --- field's contents, but only for PG fields at most 4 bytes long and --- at least 1 byte long (so no text or void types, for example). --- This includes essentially int32, int16, and booleans. --- Pass in as type argument a Word8, Word16 or Word32 to indicate --- the size of the PG type you're decoding. --- Returns the index into the first yet-unparsed byte. -decodePgFieldWithAtMost4Bytes :: forall a. (Storable a, Integral a) => WordDecoding a -> ByteStringIdx -> ByteString -> Either String (Maybe a, ByteStringIdx) -decodePgFieldWithAtMost4Bytes wdec = - let (pgTypeSize, endianSwap, valueMask :: Word64) = case wdec of - TypeSize1 -> (1, Prelude.id, 0b00000000_00000000_00000000_00000000_11111111_00000000_00000000_00000000) - TypeSize2 -> (2, fromBigEndian16, 0b00000000_00000000_00000000_00000000_11111111_11111111_00000000_00000000) - TypeSize4 -> (4, fromBigEndian32, 0b00000000_00000000_00000000_00000000_11111111_11111111_11111111_11111111) - valueShift :: Int = 8 * (4 - pgTypeSize) - in \idx bs -> - -- We try the most optimistic case first: - -- - Non-null 4 byte long types (like int32) - -- - Null int32 followed by at least one other field (not the last field in the row) - -- - Shorter types (int16, bool) followed by at least one other field (not the last field in the row) - -- In all the cases above, there are at least 8 bytes in the row, so our decoding into a Word64 will succeed. - case unsafeDecodeWord idx bs 8 fromBigEndian64 of - Right (w64 :: Word64) -> - let fieldLenW64 :: Word64 = flip unsafeShiftR 32 $ w64 .&. 0b11111111_11111111_11111111_11111111_00000000_00000000_00000000_00000000 - fieldIfNotNull :: a = fromIntegral $ unsafeShiftR (w64 .&. valueMask) valueShift - in if fieldLenW64 == 0xFFFFFFFF -- (-1) in two's-complement - then - Right (Nothing, idx + 4) - else - if fieldLenW64 <= 4 - then - Right (Just fieldIfNotNull, idx + 4 + fromIntegral fieldLenW64) - else Left "You cannot use decodePgFieldWithAtMost4Bytes to decode fields of types potentially more than 4 bytes long" - Left _ -> do - -- This is the not-as-optimistic case, which includes: - -- - A NULL int32 as the last field in the row - -- - A bool/int8/int16 that is the last field in the row - lenField <- decodeInt32BE idx bs - if lenField >= 0 - then do - -- peek after the next 4 bytes for @a - fieldValue <- unsafeDecodeWord (idx + 4) bs (fromIntegral pgTypeSize) endianSwap - Right (Just fieldValue, idx + 4 + fromIntegral lenField) - else Right (Nothing, idx + 4) diff --git a/hpgsql/src/Hpgsql/Internal.hs b/hpgsql/src/Hpgsql/Internal.hs index 8c427fe..ae9a747 100644 --- a/hpgsql/src/Hpgsql/Internal.hs +++ b/hpgsql/src/Hpgsql/Internal.hs @@ -115,8 +115,6 @@ import qualified Control.Concurrent.STM as STM import Control.Exception.Safe (Exception (..), MonadThrow, SomeException, bracket, bracketOnError, finally, handleJust, mask, mask_, onException, throw, toException, tryJust) import Control.Monad (forM, forM_, join, unless, void, when) import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.ByteString.Internal (w2c) import qualified Data.ByteString.Lazy as LBS import Data.Data (Proxy (..)) import Data.Either (isLeft, isRight) @@ -137,13 +135,14 @@ import GHC.Conc (ThreadStatus (..), threadStatus) import Hpgsql.Base import qualified Hpgsql.Builder as Builder import Hpgsql.Encoding (FieldInfo (..), FromPgRow (..), RowDecoder (..), RowEncoder (..), ToPgRow (..)) -import qualified Hpgsql.Encoding.BinarySerializer as BinSer import Hpgsql.Encoding.RowDecoderMonadic (ConversionState (..), RowDecoderMonadic (..)) import Hpgsql.InternalTypes (BindComplete (..), CommandComplete (..), ConnectOpts (..), ConnectionString (..), CopyInResponse (..), CopyQueryState (..), DataRow (..), Either3 (..), EncodingContext (..), ErrorDetail (..), ErrorResponse (..), HPgConnection (..), InternalConnectionState (..), IrrecoverableHpgsqlError (..), NoData (..), NotificationResponse (..), ParseComplete (..), Pipeline (..), PostgresError (..), Query (..), QueryId (..), QueryProtocol (..), QueryState (..), ReadyForQuery (..), ResetConnectionOpts (..), ResponseMsg (..), ResponseMsgsReceived (..), RowDescription (..), SingleQuery (..), TransactionStatus (..), WeakThreadId (..), mkMutex, queryToByteString, throwIrrecoverableError) import Hpgsql.Locking (getMyWeakThreadId, withMutex) import Hpgsql.Msgs (AuthenticationMethod (..), AuthenticationResponse (..), BackendKeyData (..), Bind (..), CancelRequest (..), CopyData (..), CopyDone (..), Describe (..), Execute (..), FromPgMessage (..), NoticeResponse (..), ParameterStatus (..), Parse (..), PasswordMessage (..), PgMsgParser (..), SASLInitialResponse (..), SASLResponse (..), StartupMessage (..), Sync (..), Terminate (..), ToPgMessage (..), parsePgMessage) import qualified Hpgsql.Msgs as Msgs import Hpgsql.Networking (recvNonBlocking, sendNonBlocking, socketWaitRead, socketWaitWrite) +import Hpgsql.PinnedByteArray (LazyPinnedByteArray, PinnedByteArray, takeMessageWithoutLength, takePgMessageIdentAndLen) +import qualified Hpgsql.PinnedByteArray as PBA import Hpgsql.Query (breakQueryIntoStatements) import qualified Hpgsql.ScramSHA256 as ScramSHA256 import qualified Hpgsql.SimpleParser as Parser @@ -507,7 +506,7 @@ receiveNextMsgWithMaskedContinuation conn parser f = Left (msgIdentChar, mPgError) -> throw IrrecoverableHpgsqlError {hpgsqlDetails = "Could not parse postgres message with ident char " <> Text.pack (show msgIdentChar) <> ". This is an internal error in Hpgsql. Please report it.", innerException = toException <$> mPgError, relatedStatement = Nothing} data ReceiveWhat a b where - ReceiveDataRows :: ReceiveWhat DataRow ByteString + ReceiveDataRows :: ReceiveWhat DataRow PinnedByteArray ReceiveArbitraryMsg :: PgMsgParser a -> (Either (Char, Maybe PostgresError) a -> STM b) -> ReceiveWhat a b -- | Masks asynchronous exceptions in between the moment the message is extracted from @@ -533,13 +532,14 @@ receiveNextMsgGeneric conn@HPgConnection {socket, recvBuffer} receiveWhat = do -- So we append to the buffer up until it has been fully fetched, -- and then extract it from the buffer in one piece. (initialBuf, initialBufLen) <- receiveUntilBufferHasAtLeast 5 - let charAndLength = LBS.take 5 initialBuf - let (w2c -> msgIdentChar, lenbs) = fromMaybe (error "impossible") $ LBS.uncons charAndLength - lenLeftToFetch :: Int64 = fromIntegral $ either error id (BinSer.decodeInt32BE 0 $ LBS.toStrict lenbs) - 4 + let (msgIdentChar, lenPlus4) = fromMaybe (error "impossible") $ takePgMessageIdentAndLen initialBuf + let lenLeftToFetch :: Int = fromIntegral $ lenPlus4 - 4 fullMessageLen = 5 + lenLeftToFetch (nowBuf, _nowBufLen) <- if initialBufLen >= fullMessageLen then pure (initialBuf, initialBufLen) else receiveUntilBufferHasAtLeast fullMessageLen - let restOfMsg = LBS.drop 5 $ LBS.take fullMessageLen nowBuf - receivedNoticeOrParameterSoTryAgain <- go msgIdentChar restOfMsg fullMessageLen nowBuf + let restOfMsg = takeMessageWithoutLength lenLeftToFetch nowBuf + -- TODO: `toStrict` on the entire buffer might be overkill unless we know we're receiving + -- DataRows, already. Best to do this later on inside the critical section. + receivedNoticeOrParameterSoTryAgain <- go msgIdentChar restOfMsg fullMessageLen (PBA.toStrict nowBuf) case receivedNoticeOrParameterSoTryAgain of Nothing -> receiveNextMsgGeneric conn receiveWhat Just res -> pure res @@ -553,11 +553,12 @@ receiveNextMsgGeneric conn@HPgConnection {socket, recvBuffer} receiveWhat = do -- Ideally we'd have non-retriable STM at the type-level here. Maybe later. -- Make sure to do very little work inside `go`! go msgIdentChar restOfMsg fullMessageLen nowBuf = mask_ $ modifyIORefIO recvBuffer $ do - let bufferWithoutMsg = LBS.drop fullMessageLen nowBuf + let bufferWithoutMsg = PBA.fromStrict $ PBA.drop fullMessageLen nowBuf + restOfMsgBs = LBS.fromStrict $ PBA.toByteString restOfMsg handleUnexpectedMsg onNotAnyReasonableMsg = -- This could be a Notification, NOTICE or a ParameterStatus message, since these -- can be received _at any time_ according to the docs. - case parsePgMessage msgIdentChar restOfMsg (Left3 <$> msgParser @NotificationResponse <|> Middle3 <$> msgParser @NoticeResponse <|> Right3 <$> msgParser @ParameterStatus) of + case parsePgMessage msgIdentChar restOfMsgBs (Left3 <$> msgParser @NotificationResponse <|> Middle3 <$> msgParser @NoticeResponse <|> Right3 <$> msgParser @ParameterStatus) of Just (Left3 notifResponse) -> do debugPrint "Received notification. Will add it to internal queue." STM.atomically $ do @@ -579,20 +580,19 @@ receiveNextMsgGeneric conn@HPgConnection {socket, recvBuffer} receiveWhat = do Nothing -> do -- Just in case this is a postgres error, it might include useful information, -- so we spit that out - let mPgError = mkPostgresError "" <$> parsePgMessage msgIdentChar restOfMsg (msgParser @ErrorResponse) - fmap (nowBuf,) $ Just <$> STM.atomically (onNotAnyReasonableMsg (msgIdentChar, mPgError)) + let mPgError = mkPostgresError "" <$> parsePgMessage msgIdentChar restOfMsgBs (msgParser @ErrorResponse) + fmap (PBA.fromStrict nowBuf,) $ Just <$> STM.atomically (onNotAnyReasonableMsg (msgIdentChar, mPgError)) case receiveWhat of ReceiveDataRows -> -- Parse as many DataRows as we can to do as much work as we can per buffer "churn" - let fullBuf = LBS.toStrict nowBuf - in case Parser.parseOnly Parser.parseManyRows fullBuf of - Parser.ParseOk unconsumedBufferBegin | unconsumedBufferBegin.idx > 0 -> do - let (msgs, unconsumedBuffer) = BS.splitAt unconsumedBufferBegin.idx fullBuf - debugPrint $ "Received one or more messages with total length " ++ show (BS.length msgs) - pure (LBS.fromStrict unconsumedBuffer, Just msgs) - _ -> handleUnexpectedMsg $ const $ pure "" -- No error when we stop receiving DataRows, only emptiness + case Parser.parseOnly Parser.parseManyRows nowBuf of + Parser.ParseOk unconsumedBufferBegin | unconsumedBufferBegin.idx > 0 -> do + let (msgs, unconsumedBuffer) = PBA.splitAt unconsumedBufferBegin.idx nowBuf + debugPrint $ "Received one or more messages with total length " ++ show (PBA.length msgs) + pure (PBA.fromStrict unconsumedBuffer, Just msgs) + _ -> handleUnexpectedMsg $ const $ pure PBA.emptyPBA -- No error when we stop receiving DataRows, only emptiness ReceiveArbitraryMsg parser f -> - case parsePgMessage msgIdentChar restOfMsg parser of + case parsePgMessage msgIdentChar restOfMsgBs parser of Just msg -> do debugPrint $ "Received " ++ show msg fmap (bufferWithoutMsg,) $ Just <$> STM.atomically (f (Right msg)) @@ -601,10 +601,10 @@ receiveNextMsgGeneric conn@HPgConnection {socket, recvBuffer} receiveWhat = do -- \| Appends into the internal buffer by reading from the socket -- until the buffer has at least N bytes. -- Returns the current buffer and its length. - receiveUntilBufferHasAtLeast :: Int64 -> IO (LBS.ByteString, Int64) + receiveUntilBufferHasAtLeast :: Int -> IO (LazyPinnedByteArray, Int) receiveUntilBufferHasAtLeast minBytesNecessary = do currentBuffer <- readIORef recvBuffer - let nBytesInBuffer = LBS.length currentBuffer + let nBytesInBuffer = PBA.lazyLength currentBuffer if nBytesInBuffer >= minBytesNecessary then pure (currentBuffer, nBytesInBuffer) else do @@ -613,7 +613,7 @@ receiveNextMsgGeneric conn@HPgConnection {socket, recvBuffer} receiveWhat = do mask $ \restore -> rethrowAsIrrecoverable $ do restore $ socketWaitRead socket someBytes <- timeDebugNonBlockingOperation "recv" $ recvNonBlocking socket (max conn.connOpts.recvChunkSize $ fromIntegral $ minBytesNecessary - nBytesInBuffer) - atomicWriteIORef recvBuffer (currentBuffer <> LBS.fromStrict someBytes) + atomicWriteIORef recvBuffer (currentBuffer <> PBA.fromStrict someBytes) receiveUntilBufferHasAtLeast minBytesNecessary sendCancellationRequest :: HPgConnection -> IO () @@ -844,7 +844,7 @@ receiveOutstandingResponseMsgsAtomically thisThreadId conn qryId = do } pure (Just respMsg, newState) -newtype DataRows = DataRows ByteString +newtype DataRows = DataRows PinnedByteArray -- | After sending one or more queries to the backend, run this function for each query to fetch that query's results. -- You must call the returned IO function and consume the returned Stream completely until you get to the @@ -893,7 +893,7 @@ consumeResults conn qryId = do ( \() -> do mRow <- receiveNextMsgGeneric conn ReceiveDataRows case mRow of - rows | not (BS.null rows) -> pure $ Right (DataRows rows :> ()) + rows | not (PBA.null rows) -> pure $ Right (DataRows rows :> ()) _ -> do stateAfterNextMsg <- snd <$> receiveOutstandingResponseMsgsAtomically thisThreadId conn qryId case stateAfterNextMsg of diff --git a/hpgsql/src/Hpgsql/InternalTypes.hs b/hpgsql/src/Hpgsql/InternalTypes.hs index af81141..9381db6 100644 --- a/hpgsql/src/Hpgsql/InternalTypes.hs +++ b/hpgsql/src/Hpgsql/InternalTypes.hs @@ -77,6 +77,7 @@ import Data.Set (Set) import Hpgsql.Base (lastTwoAndInit, maximumOnOrDef, minimumOnOrDef) import Hpgsql.Builder (BinaryField) import Hpgsql.ParsingInternal (BlockOrNotBlock (..), ParsingOpts (..), parseSql) +import Hpgsql.PinnedByteArray (LazyPinnedByteArray, PinnedByteArray) import Hpgsql.TransactionStatusInternal (TransactionStatus (..)) import Hpgsql.TypeInfo (EncodingContext (..), Oid (..)) import Network.Socket (AddrInfo, Socket) @@ -370,7 +371,7 @@ newtype CommandComplete = CommandComplete {numRows :: Int64} -- | A DataRow with its leading identifying character ('D'), the 32bits self-length, -- the 2 bytes for the number of fields and the fields' lengths and values themselves. -newtype DataRow = DataRow {fullDataRow :: ByteString} +newtype DataRow = DataRow {fullDataRow :: PinnedByteArray} instance Show DataRow where show _ = "DataRow" @@ -464,7 +465,7 @@ data InternalConnectionState = InternalConnectionState data HPgConnection = HPgConnection { socket :: !Socket, socketClosed :: !(MVar Bool), - recvBuffer :: !(IORef LBS.ByteString), + recvBuffer :: !(IORef LazyPinnedByteArray), sendBuffer :: !(MVar [(LBS.ByteString, STM ())]), socketMutex :: !Mutex, originalConnStr :: !ConnectionString, diff --git a/hpgsql/src/Hpgsql/Msgs.hs b/hpgsql/src/Hpgsql/Msgs.hs index 3171079..721d684 100644 --- a/hpgsql/src/Hpgsql/Msgs.hs +++ b/hpgsql/src/Hpgsql/Msgs.hs @@ -23,8 +23,8 @@ import Data.Text.Encoding (decodeASCII, decodeUtf8, encodeUtf8) import Data.Word (Word8) import Hpgsql.Builder (BinaryField, Builder, builderLength) import qualified Hpgsql.Builder as Builder -import qualified Hpgsql.Encoding.BinarySerializer as BinSer import Hpgsql.InternalTypes (BindComplete (..), CommandComplete (..), CopyInResponse (..), DataRow (..), ErrorDetail (..), ErrorResponse (..), NoData (..), NotificationResponse (..), ParseComplete (..), ReadyForQuery (..), RowDescription (..), TransactionStatus (..)) +import qualified Hpgsql.PinnedByteArray as PBA import Hpgsql.ScramSHA256 (ScramClientFinalMessage (..), ScramServerFirstMessage (..)) import Hpgsql.TypeInfo (Oid (..)) @@ -54,7 +54,7 @@ colParser = do colName <- nulTerminatedCStringParser -- Column name as C string void $ Parsec.take (4 + 2) -- TODO: OIDs are unsigned integers! Try `select (-1)::oid` to see. Change to UInt32 somehow - typOid <- either fail pure . BinSer.decodeInt32BE 0 =<< Parsec.take 4 + typOid <- either fail pure . PBA.decodeInt32BE 0 . PBA.fromByteString =<< Parsec.take 4 void $ Parsec.take (2 + 4 + 2) pure (colName, Oid (fromIntegral typOid)) @@ -138,7 +138,7 @@ data Terminate = Terminate instance FromPgMessage AuthenticationResponse where msgParser = PgMsgParser $ \c restOfMsg -> case c of - 'R' -> case first (BinSer.decodeInt32BE 0 . LBS.toStrict) $ LBS.splitAt 4 restOfMsg of + 'R' -> case first (PBA.decodeInt32BE 0 . PBA.fromByteString . LBS.toStrict) $ LBS.splitAt 4 restOfMsg of (Right 0, _) -> Just $ AuthenticationResponse AuthOk (Right 2, _) -> Just $ AuthenticationResponse AuthKerberosV5 (Right 3, _) -> Just $ AuthenticationResponse AuthCleartextPassword @@ -155,7 +155,7 @@ instance FromPgMessage AuthenticationResponse where instance FromPgMessage BackendKeyData where msgParser = PgMsgParser $ \c (LBS.splitAt 4 -> (pidBS, backendSecretKey)) -> case c of - 'K' -> case BinSer.decodeInt32BE 0 $ LBS.toStrict pidBS of + 'K' -> case PBA.decodeInt32BE 0 $ PBA.fromByteString $ LBS.toStrict pidBS of Right pid -> Just $ BackendKeyData {backendPid = pid, backendSecretKey = LBS.toStrict backendSecretKey} Left _ -> Nothing _ -> Nothing @@ -226,7 +226,7 @@ instance FromPgMessage CopyInResponse where instance FromPgMessage DataRow where msgParser = PgMsgParser $ \c !restOfMsg -> case c of -- TODO: Double-check the re-encoding here is correct! - 'D' -> Just $ DataRow {fullDataRow = BS.singleton 68 <> BinSer.encodeInt32BE (fromIntegral $ LBS.length restOfMsg + 4) <> LBS.toStrict restOfMsg} + 'D' -> Just $ DataRow {fullDataRow = PBA.fromByteString $ BS.singleton 68 <> PBA.encodeInt32BE (fromIntegral $ LBS.length restOfMsg + 4) <> LBS.toStrict restOfMsg} _ -> Nothing instance FromPgMessage NoData where @@ -360,7 +360,7 @@ instance FromPgMessage RowDescription where if c == 'T' then let (numColsBS, colContents) = LBS.splitAt 2 restOfMsg - numCols = either error id $ BinSer.decodeInt16BE 0 $ LBS.toStrict numColsBS + numCols = either error id $ PBA.decodeInt16BE 0 $ PBA.fromByteString $ LBS.toStrict numColsBS allColOidsParser :: Parsec.Parser [(Text, Oid)] allColOidsParser = replicateM (fromIntegral numCols) colParser in case LazyParsec.parseOnly (allColOidsParser <* Parsec.endOfInput) colContents of @@ -407,7 +407,7 @@ instance FromPgMessage NotificationResponse where then Nothing else let (notifierPidBs, channelNameAndPayload) = LBS.splitAt 4 restOfMsg - notifierPid = either error id $ BinSer.decodeInt32BE 0 $ LBS.toStrict notifierPidBs + notifierPid = either error id $ PBA.decodeInt32BE 0 $ PBA.fromByteString $ LBS.toStrict notifierPidBs in case LazyParsec.parseOnly ((NotificationResponse notifierPid <$> nulTerminatedCStringParser <*> nulTerminatedCStringParser) <* Parsec.endOfInput) channelNameAndPayload of diff --git a/hpgsql/src/Hpgsql/Networking.hs b/hpgsql/src/Hpgsql/Networking.hs index 29232c2..4ef48c0 100644 --- a/hpgsql/src/Hpgsql/Networking.hs +++ b/hpgsql/src/Hpgsql/Networking.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} + -- | -- This module contains code largely copied from the @network@ library -- (BSD-3-Clause), with modifications to remove blocking calls @@ -18,13 +21,13 @@ where import Control.Concurrent (threadWaitRead, threadWaitWrite) import Control.Exception.Safe (throw) -import Data.ByteString (ByteString) -import Data.ByteString.Internal (createAndTrim) import qualified Data.ByteString.Lazy as L import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import Data.Int (Int64) import Foreign (Ptr, Storable (..), Word8, allocaArray, castPtr, nullPtr, plusPtr) -import Foreign.C (CChar (..), CInt (..), CSize (..), eAGAIN, eWOULDBLOCK, getErrno) +import Foreign.C (CInt (..), CSize (..), eAGAIN, eWOULDBLOCK, getErrno) +import GHC.Base (Addr#) +import Hpgsql.PinnedByteArray (PinnedByteArray, createPinnedByteArray) import Network.Socket (Socket, withFdSocket) import System.Posix.Types (CSsize (..)) @@ -34,11 +37,11 @@ socketWaitRead socket = withFdSocket socket (threadWaitRead . fromIntegral) socketWaitWrite :: Socket -> IO () socketWaitWrite socket = withFdSocket socket (threadWaitWrite . fromIntegral) -recvNonBlocking :: Socket -> Int -> IO ByteString -recvNonBlocking s nbytes = withFdSocket s $ \fd -> createAndTrim nbytes $ \buffer -> do +recvNonBlocking :: Socket -> Int -> IO PinnedByteArray +recvNonBlocking s nbytes = withFdSocket s $ \fd -> createPinnedByteArray nbytes $ \buffer -> do -- Largely copied from https://hackage-content.haskell.org/package/network-3.2.8.0/docs/src/Network.Socket.Buffer.html#recvBufNoWait and other functions from the network library, -- but then modified to our needs. - r <- c_recv fd (castPtr buffer) (fromIntegral nbytes) 0 {-flags-} + r <- c_recv fd buffer (fromIntegral nbytes) 0 {-flags-} if r >= 0 then do -- putStrLn $ "Asked for " ++ show nbytes ++ ", got " ++ show r @@ -115,7 +118,7 @@ instance Storable IOVec where -- pokeIov ptr (sPtr, sLen) = poke ptr $ IOVec sPtr (fromIntegral sLen) foreign import ccall unsafe "recv" - c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt + c_recv :: CInt -> Addr# -> CSize -> CInt -> IO CInt foreign import ccall unsafe "writev" c_writev :: CInt -> Ptr IOVec -> CInt -> IO CSsize diff --git a/hpgsql/src/Hpgsql/PinnedByteArray.hs b/hpgsql/src/Hpgsql/PinnedByteArray.hs new file mode 100644 index 0000000..ca1c3b2 --- /dev/null +++ b/hpgsql/src/Hpgsql/PinnedByteArray.hs @@ -0,0 +1,376 @@ +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module Hpgsql.PinnedByteArray + ( PinnedByteArray (..), + LazyPinnedByteArray, + createPinnedByteArray, + takePgMessageIdentAndLen, + takeMessageWithoutLength, + drop, + fromStrict, + toStrict, + splitAt, + length, + take, + lazyLength, + null, + emptyPBA, + fromByteString, + toByteString, + toStrictN, + + -- * Binary (de)serializer + ByteStringIdx (..), + decodeInt16BE, + decodeInt32BE, + decodeInt64BE, + decodeWord32BE, + decodeWord64BE, + encodeInt32BE, + encodeDouble, + encodeFloat, + encodeInt64BE, + encodeInt16BE, + encodePgBoolean, + decodeDataRow, + decodePgFieldWithAtMost4Bytes, + WordDecoding (..), + ) +where + +import Control.Monad (when) +import Data.ByteString (ByteString) +import Data.ByteString.Internal (ByteString (..)) +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Internal as InternalBS +import Data.Int (Int16, Int32, Int64) +import Foreign (withForeignPtr) +import Foreign.C (CInt (..)) +import Foreign.Marshal.Utils (copyBytes) +import Foreign.Ptr (plusPtr) +import GHC.Base (Addr#, ByteArray#, Char (..), IO (..), Int (..), MutableByteArray#, RealWorld, byteArrayContents#, compareByteArrays#, indexWord8ArrayAsChar#, indexWord8ArrayAsWord32#, mutableByteArrayContents#, newPinnedByteArray#, unIO, unsafeFreezeByteArray#, (+#)) +import GHC.Exts (indexWord8Array#, indexWord8ArrayAsWord16#, indexWord8ArrayAsWord64#) +import GHC.Ptr (Ptr (..)) +import GHC.Word (Word32 (..)) +import System.IO.Unsafe (unsafeDupablePerformIO) +import Prelude hiding (drop, encodeFloat, length, null, splitAt, take) +#if WORDS_BIGENDIAN +import Data.Word (Word16, Word32, Word64) +#else +import Data.Word (Word16, Word64, byteSwap16, byteSwap64, Word8, byteSwap32) +#endif +import Data.Bits (Bits (unsafeShiftR)) +import Data.Coerce (coerce) +import Foreign (Storable (..), (.&.)) +import GHC.Float (castDoubleToWord64, castFloatToWord32) +import GHC.Word (Word16 (..), Word64 (..), Word8 (..)) + +data PinnedByteArray = PinnedByteArray + { start :: !Int, + len :: !Int, + array :: !ByteArray# + } + +instance Eq PinnedByteArray where + PinnedByteArray (I# s1) l1@(I# len) arr1# == PinnedByteArray (I# s2) l2 arr2# = + l1 == l2 && case compareByteArrays# arr1# s1 arr2# s2 len of + 0# -> True + _ -> False + +-- TODO: dlist for efficient snoc, because buffers can grow very large when fetching binaries/json/text blobs +data LazyPinnedByteArray = LazyPinnedByteArray !Int ![PinnedByteArray] + +instance Semigroup LazyPinnedByteArray where + LazyPinnedByteArray l1 pbs1 <> LazyPinnedByteArray l2 pbs2 = LazyPinnedByteArray (l1 + l2) (pbs1 ++ pbs2) + +instance Monoid LazyPinnedByteArray where + mempty = LazyPinnedByteArray 0 [] + +{-# NOINLINE emptyPBA #-} +emptyPBA :: PinnedByteArray +emptyPBA = unsafeDupablePerformIO $ createPinnedByteArray 0 (\_ -> pure 0) + +-- TODO: write property-based tests for these functions. This is tricky to get right. + +createPinnedByteArray :: Int -> (Addr# -> IO CInt) -> IO PinnedByteArray +createPinnedByteArray (I# size#) f = IO $ \s0 -> + let !(# newRW, (mutArr# :: MutableByteArray# RealWorld) #) = newPinnedByteArray# size# s0 + !(# newRW', lenCopied #) = unIO (f (mutableByteArrayContents# mutArr#)) newRW + !(# finalRW, frozenArr# #) = unsafeFreezeByteArray# mutArr# newRW' + in (# finalRW, PinnedByteArray 0 (fromIntegral lenCopied) frozenArr# #) + +fromByteString :: ByteString -> PinnedByteArray +fromByteString (BS fptr len) = unsafeDupablePerformIO $ createPinnedByteArray len $ \dst -> withForeignPtr fptr $ \src -> do + copyBytes (Ptr dst) src len + pure $ fromIntegral len + +toByteString :: PinnedByteArray -> ByteString +toByteString (PinnedByteArray start len src) = unsafeDupablePerformIO $ BS.create len $ \dst -> + copyBytes dst (Ptr (byteArrayContents# src) `plusPtr` start) len + +takePgMessageIdentAndLen :: LazyPinnedByteArray -> Maybe (Char, Int32) +takePgMessageIdentAndLen lpba@(LazyPinnedByteArray len _) = + if len >= 5 + then + let !(PinnedByteArray (I# start) _ arr#) = toStrictN 0 5 lpba + in Just (C# (indexWord8ArrayAsChar# arr# start), fromIntegral $ fromBigEndian32 $ W32# (indexWord8ArrayAsWord32# arr# (start +# 1#))) + else Nothing + +-- | Skips 5 bytes for a message's header and takes the next `n` bytes. +takeMessageWithoutLength :: Int -> LazyPinnedByteArray -> PinnedByteArray +takeMessageWithoutLength n = toStrictN 5 n + +-- | Drops the next `n` bytes. +drop :: Int -> PinnedByteArray -> PinnedByteArray +drop n (PinnedByteArray start len arr#) = + if n >= len + then emptyPBA + else + PinnedByteArray (start + n) (len - n) arr# + +-- | Takes the first `n` bytes. +take :: Int -> PinnedByteArray -> PinnedByteArray +take n (PinnedByteArray start len arr#) = + PinnedByteArray start (min n len) arr# + +fromStrict :: PinnedByteArray -> LazyPinnedByteArray +fromStrict pba@(PinnedByteArray _ len _) = LazyPinnedByteArray len [pba] + +-- | Copies chunks into a single contiguous 'PinnedByteArray'. Avoids the copy +-- when there's already just a single chunk. +toStrict :: LazyPinnedByteArray -> PinnedByteArray +toStrict (LazyPinnedByteArray _ [pba]) = pba +toStrict lpba@(LazyPinnedByteArray totalLen _) = toStrictN 0 totalLen lpba + +-- | Creates strict PBA from a Lazy one, but just with the first @n@ +-- bytes after the first @skip@ (or less if they're not all there). +toStrictN :: Int -> Int -> LazyPinnedByteArray -> PinnedByteArray +toStrictN skip n' (LazyPinnedByteArray totalLen' chunks) = + let n = min n' totalLen' + in unsafeDupablePerformIO $ createPinnedByteArray n $ \dst -> do + let go copied _ _ [] = pure copied + go copied _ 0 _ = pure copied + go offset skipLeft nLeft (PinnedByteArray start l arr# : rest) = do + let toSkipSrc = min l skipLeft + toCopy = min nLeft (l - toSkipSrc) + when (toCopy > 0 && toSkipSrc < l) $ copyBytes (Ptr dst `plusPtr` offset) (Ptr (byteArrayContents# arr#) `plusPtr` (start + toSkipSrc)) toCopy + when (toCopy < 0) $ error "toCopy < 0 should be impossible" + go (offset + toCopy) (skipLeft - toSkipSrc) (nLeft - toCopy) rest + fromIntegral <$> go 0 skip n chunks + +splitAt :: Int -> PinnedByteArray -> (PinnedByteArray, PinnedByteArray) +splitAt n pba = (take n pba, drop n pba) + +length :: PinnedByteArray -> Int +length (PinnedByteArray _ len _) = len + +null :: PinnedByteArray -> Bool +null = (== 0) . length + +lazyLength :: LazyPinnedByteArray -> Int +lazyLength (LazyPinnedByteArray len _) = len + +-- * Binary (de)serializer + +-- A replacement for libraries like cereal or binary. +-- In our tests, this is ~6.0% faster than cereal, and it also +-- (or by virtue of) allocates ~13% less memory in some of our benchmarks. +-- And it also means one fewer dependency. +-- The caveat is that this module makes unaligned memory access. For the target +-- CPU architectures of this library, this should be fine. + +fromBigEndian32 :: Word32 -> Word32 +#if WORDS_BIGENDIAN +fromBigEndian32 = Prelude.id +#else +fromBigEndian32 = byteSwap32 +#endif + +fromBigEndian64 :: Word64 -> Word64 +#if WORDS_BIGENDIAN +fromBigEndian64 = Prelude.id +#else +fromBigEndian64 = byteSwap64 +#endif + +fromBigEndian16 :: Word16 -> Word16 +#if WORDS_BIGENDIAN +fromBigEndian16 = Prelude.id +#else +fromBigEndian16 = byteSwap16 +#endif + +data CoolWordDec a where + CWord8 :: CoolWordDec Word8 + CWord16 :: CoolWordDec Word16 + CWord32 :: CoolWordDec Word32 + CWord64 :: CoolWordDec Word64 + +{-# INLINE unsafeDecodeWord #-} +unsafeDecodeWord :: CoolWordDec a -> ByteStringIdx -> PinnedByteArray -> (a -> a) -> Either String a +unsafeDecodeWord wdec (ByteStringIdx boxedIdx@(I# idx)) (PinnedByteArray (I# start) len byArrSharp) endianConvert = + case wdec of + CWord8 -> if len < 1 + boxedIdx then Left "Less than enough bytes to decode" else Right $ endianConvert $ W8# $ indexWord8Array# byArrSharp (idx +# start) + CWord16 -> if len < 2 + boxedIdx then Left "Less than enough bytes to decode" else Right $ endianConvert $ W16# $ indexWord8ArrayAsWord16# byArrSharp (idx +# start) + CWord32 -> if len < 4 + boxedIdx then Left "Less than enough bytes to decode" else Right $ endianConvert $ W32# $ indexWord8ArrayAsWord32# byArrSharp (idx +# start) + CWord64 -> if len < 8 + boxedIdx then Left "Less than enough bytes to decode" else Right $ endianConvert $ W64# $ indexWord8ArrayAsWord64# byArrSharp (idx +# start) + +{-# INLINE unsafeEncodeWord #-} +unsafeEncodeWord :: (Storable a) => a -> (a -> a) -> Int -> ByteString +unsafeEncodeWord n endianConvert len = + InternalBS.unsafeCreate len $ \bufferPtr -> + poke (coerce bufferPtr) $ endianConvert n + +newtype ByteStringIdx = ByteStringIdx {idx :: Int} + deriving newtype (Num) + +{-# INLINE decodeInt16BE #-} +decodeInt16BE :: ByteStringIdx -> PinnedByteArray -> Either String Int16 +decodeInt16BE idx bs = fromIntegral <$> unsafeDecodeWord CWord16 idx bs fromBigEndian16 + +{-# INLINE encodeInt16BE #-} +encodeInt16BE :: Int16 -> ByteString +encodeInt16BE n = unsafeEncodeWord (fromIntegral n) fromBigEndian16 2 + +{-# INLINE decodeWord8 #-} +decodeWord8 :: ByteStringIdx -> PinnedByteArray -> Either String Word8 +decodeWord8 idx bs = unsafeDecodeWord CWord8 idx bs Prelude.id + +{-# INLINE decodeWord32BE #-} +decodeWord32BE :: ByteStringIdx -> PinnedByteArray -> Either String Word32 +decodeWord32BE idx bs = unsafeDecodeWord CWord32 idx bs fromBigEndian32 + +{-# INLINE decodeWord64BE #-} +decodeWord64BE :: ByteStringIdx -> PinnedByteArray -> Either String Word64 +decodeWord64BE idx bs = unsafeDecodeWord CWord64 idx bs fromBigEndian64 + +{-# INLINE decodeInt32BE #-} +decodeInt32BE :: ByteStringIdx -> PinnedByteArray -> Either String Int32 +decodeInt32BE idx bs = fromIntegral <$> unsafeDecodeWord CWord32 idx bs fromBigEndian32 + +{-# INLINE encodeInt32BE #-} +encodeInt32BE :: Int32 -> ByteString +encodeInt32BE n = unsafeEncodeWord (fromIntegral n) fromBigEndian32 4 + +{-# INLINE decodeInt64BE #-} +decodeInt64BE :: ByteStringIdx -> PinnedByteArray -> Either String Int64 +decodeInt64BE idx bs = fromIntegral <$> unsafeDecodeWord CWord64 idx bs fromBigEndian64 + +{-# INLINE encodeInt64BE #-} +encodeInt64BE :: Int64 -> ByteString +encodeInt64BE n = unsafeEncodeWord (fromIntegral n) fromBigEndian64 8 + +{-# INLINE encodeFloat #-} +encodeFloat :: Float -> ByteString +encodeFloat n = unsafeEncodeWord (castFloatToWord32 n) fromBigEndian32 4 + +{-# INLINE encodeDouble #-} +encodeDouble :: Double -> ByteString +encodeDouble n = unsafeEncodeWord (castDoubleToWord64 n) fromBigEndian64 8 + +-- TODO: Encode field length together with value for small types. +-- This can also be a performance boost by having fewer bytestrings? +{-# INLINE encodePgBoolean #-} +encodePgBoolean :: Bool -> ByteString +encodePgBoolean v = if v then "\SOH" else "\NUL" + +{-# INLINE decodeDataRow #-} + +-- | A super specialized decoder to decode a postgres DataRow message +-- more quickly than a naive implementation. +-- Returns the index into the left-unparsed contents of the supplied bytestring. +decodeDataRow :: ByteStringIdx -> PinnedByteArray -> Either String ByteStringIdx +decodeDataRow idx sbs@(PinnedByteArray _ len _) = + -- We have a fast path when rows are at least 8 bytes long (should be the case + -- for all but 0-column query results or bytestring chunks "cut in the middle of the message") + -- by playing with bitwise operations. + -- Whether this is worth keeping is sort of questionable. It's complex + -- (even if I think it's safe and well tested) and reduces runtime of one of + -- our benchmarks by 2% compared to not having it. + case unsafeDecodeWord CWord64 idx sbs fromBigEndian64 of + Right (w64 :: Word64) -> + -- After fromBigEndian64, the Word64 has bytes in big-endian order: + -- byte 0 (msg type) in MSB, bytes 1-4 (length) next, bytes 5-6 (col count), byte 7 in LSB. + let msgIdentByte64 = w64 .&. 0b11111111_00000000_00000000_00000000_00000000_00000000_00000000_00000000 + lenFullMsg = flip unsafeShiftR 24 $ w64 .&. 0b00000000_11111111_11111111_11111111_11111111_00000000_00000000_00000000 + letterD :: Word64 = 0b01000100_00000000_00000000_00000000_00000000_00000000_00000000_00000000 + in if msgIdentByte64 == letterD + then + toResult (fromIntegral lenFullMsg) + else Left "Not a DataRow (Word64 bits decoding path)" + Left _ -> + -- It is possible the DataRow has length less than 8 bytes, so + -- we still have to try to parse that. + if len >= 5 + idx.idx + then do + msgIdentChar <- decodeWord8 idx sbs + lenFullMsg <- decodeInt32BE (1 + idx) sbs + if msgIdentChar == 68 -- Letter 'D' + then toResult (fromIntegral lenFullMsg) + else Left "Not a DataRow" + else Left "Less than enough bytes to decode a DataRow" + where + toResult lenFullMsg + | len >= 1 + lenFullMsg + idx.idx = Right $ ByteStringIdx $ 1 + lenFullMsg + idx.idx + | otherwise = Left "Less than enough bytes to decode a full DataRow" + +data WordDecoding a where + TypeSize1 :: WordDecoding Word8 + TypeSize2 :: WordDecoding Word16 + TypeSize4 :: WordDecoding Word32 + +fromWordDec :: WordDecoding a -> CoolWordDec a +fromWordDec = \case + TypeSize1 -> CWord8 + TypeSize2 -> CWord16 + TypeSize4 -> CWord32 + +{-# INLINE decodePgFieldWithAtMost4Bytes #-} + +-- | A specialized decoder that decoders a query result's +-- field's contents, but only for PG fields at most 4 bytes long and +-- at least 1 byte long (so no text or void types, for example). +-- This includes essentially int32, int16, and booleans. +-- Pass in as type argument a Word8, Word16 or Word32 to indicate +-- the size of the PG type you're decoding. +-- Returns the index into the first yet-unparsed byte. +decodePgFieldWithAtMost4Bytes :: forall a. (Storable a, Integral a) => WordDecoding a -> ByteStringIdx -> PinnedByteArray -> Either String (Maybe a, ByteStringIdx) +decodePgFieldWithAtMost4Bytes wdec = + let (pgTypeSize, endianSwap, valueMask :: Word64) = case wdec of + TypeSize1 -> (1, Prelude.id, 0b00000000_00000000_00000000_00000000_11111111_00000000_00000000_00000000) + TypeSize2 -> (2, fromBigEndian16, 0b00000000_00000000_00000000_00000000_11111111_11111111_00000000_00000000) + TypeSize4 -> (4, fromBigEndian32, 0b00000000_00000000_00000000_00000000_11111111_11111111_11111111_11111111) + valueShift :: Int = 8 * (4 - pgTypeSize) + in \idx bs -> + -- We try the most optimistic case first: + -- - Non-null 4 byte long types (like int32) + -- - Null int32 followed by at least one other field (not the last field in the row) + -- - Shorter types (int16, bool) followed by at least one other field (not the last field in the row) + -- In all the cases above, there are at least 8 bytes in the row, so our decoding into a Word64 will succeed. + case unsafeDecodeWord CWord64 idx bs fromBigEndian64 of + Right (w64 :: Word64) -> + let fieldLenW64 :: Word64 = flip unsafeShiftR 32 $ w64 .&. 0b11111111_11111111_11111111_11111111_00000000_00000000_00000000_00000000 + fieldIfNotNull :: a = fromIntegral $ unsafeShiftR (w64 .&. valueMask) valueShift + in if fieldLenW64 == 0xFFFFFFFF -- (-1) in two's-complement + then + Right (Nothing, idx + 4) + else + if fieldLenW64 <= 4 + then + Right (Just fieldIfNotNull, idx + 4 + fromIntegral fieldLenW64) + else Left "You cannot use decodePgFieldWithAtMost4Bytes to decode fields of types potentially more than 4 bytes long" + Left _ -> do + -- This is the not-as-optimistic case, which includes: + -- - A NULL int32 as the last field in the row + -- - A bool/int8/int16 that is the last field in the row + lenField <- decodeInt32BE idx bs + if lenField >= 0 + then do + -- peek after the next 4 bytes for @a + fieldValue <- unsafeDecodeWord (fromWordDec wdec) (idx + 4) bs endianSwap + Right (Just fieldValue, idx + 4 + fromIntegral lenField) + else Right (Nothing, idx + 4) diff --git a/hpgsql/src/Hpgsql/SimpleParser.hs b/hpgsql/src/Hpgsql/SimpleParser.hs index 5c9e499..e6fccf8 100644 --- a/hpgsql/src/Hpgsql/SimpleParser.hs +++ b/hpgsql/src/Hpgsql/SimpleParser.hs @@ -36,13 +36,11 @@ module Hpgsql.SimpleParser where import Control.Applicative (Alternative (..)) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS import Data.Int (Int16, Int32, Int64) import Foreign.Storable (Storable) import GHC.Float (castWord32ToFloat, castWord64ToDouble) -import Hpgsql.Encoding.BinarySerializer (ByteStringIdx (..)) -import qualified Hpgsql.Encoding.BinarySerializer as BinSer +import Hpgsql.PinnedByteArray (ByteStringIdx (..), PinnedByteArray) +import qualified Hpgsql.PinnedByteArray as PBA import Prelude hiding (take) data ParseResult a @@ -50,16 +48,16 @@ data ParseResult a | ParseOk !a deriving stock (Show) --- | A parser that consumes a strict 'ByteString'. +-- | A parser that consumes a strict 'PinnedByteArray'. newtype Parser a = Parser { unParser :: forall r. ByteStringIdx -> - ByteString -> + PinnedByteArray -> (String -> r) -> -- \^ failure continuation - (a -> ByteStringIdx -> ByteString -> r) -> - -- \^ success continuation, taking original or new ByteString, the index into the original/new bytestring of the first yet-unparsed byte, and parsed value + (a -> ByteStringIdx -> PinnedByteArray -> r) -> + -- \^ success continuation, taking original or new PinnedByteArray, the index into the original/new bytestring of the first yet-unparsed byte, and parsed value r } @@ -98,29 +96,29 @@ instance MonadFail Parser where -- | Run a parser and return either an error message or the parsed value, -- using the strict 'ParseResult' type. Any unconsumed trailing input is -- discarded. -parseOnly :: Parser a -> ByteString -> ParseResult a +parseOnly :: Parser a -> PinnedByteArray -> ParseResult a parseOnly p = parseOnlyOffset p 0 {-# INLINE parseOnly #-} -- | Run a parser and return either an error message or the parsed value, -- using the strict 'ParseResult' type. Any unconsumed trailing input is -- discarded. -parseOnlyOffset :: Parser a -> ByteStringIdx -> ByteString -> ParseResult a +parseOnlyOffset :: Parser a -> ByteStringIdx -> PinnedByteArray -> ParseResult a parseOnlyOffset (Parser p) idx bs = p idx bs ParseFail (\a _ _ -> ParseOk a) {-# INLINE parseOnlyOffset #-} --- | Consume exactly @n@ bytes of input, failing if fewer than @n@ bytes +-- | Consume exactly `n` bytes of input, failing if fewer than `n` bytes -- remain. -take :: Int -> Parser ByteString -take n = Parser $ \idx bs kf ks -> +take :: Int -> Parser PinnedByteArray +take n = Parser $ \idx sbs kf ks -> let skip' = n + idx.idx - in if BS.length bs >= skip' - then case BS.take n $ BS.drop idx.idx bs of + in if PBA.length sbs >= skip' + then case PBA.take n $ PBA.drop idx.idx sbs of -- Strict on the bytestring because we're pretty sure -- the field decoder will need to evaluate this anyway, -- so no need for an extra thunk - !h -> ks h (ByteStringIdx skip') bs - else kf ("take: wanted " <> show skip' <> " bytes but only " <> show (BS.length bs) <> " remain") + !h -> ks h (ByteStringIdx skip') sbs + else kf ("take: wanted " <> show skip' <> " bytes but only " <> show (PBA.length sbs) <> " remain") {-# INLINE take #-} -- | Consume exactly @n@ bytes of input, failing if fewer than @n@ bytes @@ -133,7 +131,7 @@ skip n = Parser $ \idx bs _ ks -> {-# INLINE takeInt16BE #-} takeInt16BE :: Parser Int16 takeInt16BE = Parser $ \idx bs kf ks -> - case BinSer.decodeInt16BE idx bs of + case PBA.decodeInt16BE idx bs of Right v -> ks v (idx + 2) bs Left err -> kf err @@ -143,20 +141,20 @@ takeInt16BE = Parser $ \idx bs kf ks -> -- an Int16 in a row. takeInt16BEWithFieldLength :: Parser (Maybe Int16) takeInt16BEWithFieldLength = do - mi16 <- parsePgFieldWithAtMost4Bytes BinSer.TypeSize2 + mi16 <- parsePgFieldWithAtMost4Bytes PBA.TypeSize2 pure $ fromIntegral <$> mi16 {-# INLINE takeInt32BE #-} takeInt32BE :: Parser Int32 takeInt32BE = Parser $ \idx bs kf ks -> - case BinSer.decodeInt32BE idx bs of + case PBA.decodeInt32BE idx bs of Right v -> ks v (idx + 4) bs Left err -> kf err {-# INLINE peekInt32BE #-} peekInt32BE :: Parser Int32 peekInt32BE = Parser $ \idx bs kf ks -> - case BinSer.decodeInt32BE idx bs of + case PBA.decodeInt32BE idx bs of Right v -> ks v idx bs Left err -> kf err @@ -166,7 +164,7 @@ peekInt32BE = Parser $ \idx bs kf ks -> -- an Int32 in a row. takeInt32BEWithFieldLength :: Parser (Maybe Int32) takeInt32BEWithFieldLength = do - mi32 <- parsePgFieldWithAtMost4Bytes BinSer.TypeSize4 + mi32 <- parsePgFieldWithAtMost4Bytes PBA.TypeSize4 pure $ fromIntegral <$> mi32 {-# INLINE takeFloatBEWithFieldLength #-} @@ -175,20 +173,20 @@ takeInt32BEWithFieldLength = do -- a Float in a row. takeFloatBEWithFieldLength :: Parser (Maybe Float) takeFloatBEWithFieldLength = do - mf <- parsePgFieldWithAtMost4Bytes BinSer.TypeSize4 + mf <- parsePgFieldWithAtMost4Bytes PBA.TypeSize4 pure $ castWord32ToFloat <$> mf {-# INLINE takeFloatBE #-} takeFloatBE :: Parser Float takeFloatBE = Parser $ \idx bs kf ks -> - case BinSer.decodeWord32BE idx bs of + case PBA.decodeWord32BE idx bs of Right v -> ks (castWord32ToFloat v) (idx + 4) bs Left err -> kf err {-# INLINE takeDoubleBE #-} takeDoubleBE :: Parser Double takeDoubleBE = Parser $ \idx bs kf ks -> - case BinSer.decodeWord64BE idx bs of + case PBA.decodeWord64BE idx bs of Right v -> ks (castWord64ToDouble v) (idx + 8) bs Left err -> kf err @@ -206,7 +204,7 @@ takeInt64BEWithFieldLength = do {-# INLINE takeInt64BE #-} takeInt64BE :: Parser Int64 takeInt64BE = Parser $ \idx bs kf ks -> - case BinSer.decodeInt64BE idx bs of + case PBA.decodeInt64BE idx bs of Right v -> ks v (idx + 8) bs Left err -> kf err @@ -216,7 +214,7 @@ takeInt64BE = Parser $ \idx bs kf ks -> -- returning the index of the byte after this DataRow's last. takeDataRow :: Parser ByteStringIdx takeDataRow = Parser $ \idx bs kf ks -> - case BinSer.decodeDataRow idx bs of + case PBA.decodeDataRow idx bs of Left err -> kf err Right idxRest -> ks idxRest idxRest bs @@ -224,9 +222,9 @@ takeDataRow = Parser $ \idx bs kf ks -> -- | A specialized parser that reads a query result's -- field's contents. -parsePgFieldWithAtMost4Bytes :: forall a. (Storable a, Integral a) => BinSer.WordDecoding a -> Parser (Maybe a) +parsePgFieldWithAtMost4Bytes :: forall a. (Storable a, Integral a) => PBA.WordDecoding a -> Parser (Maybe a) parsePgFieldWithAtMost4Bytes wdec = - let dec = BinSer.decodePgFieldWithAtMost4Bytes wdec + let dec = PBA.decodePgFieldWithAtMost4Bytes wdec in Parser $ \idx bs kf ks -> case dec idx bs of Right (v, restIdx) -> ks v restIdx bs @@ -251,20 +249,21 @@ parseManyRows = Parser $ \idx' bs' _kf ks -> let restIdx = go idx' bs' in ks res -- | Succeeds only when the input has been fully consumed. endOfInput :: Parser () endOfInput = Parser $ \idx bs kf ks -> - if BS.length bs <= idx.idx then ks () idx bs else kf "endOfInput: input remaining" + if PBA.length bs <= idx.idx then ks () idx bs else kf "endOfInput: input remaining" {-# INLINE endOfInput #-} -- | Run a parser and additionally return the slice of input it consumed. --- Because the input is a strict 'ByteString', the returned slice is a view +-- Because the input is a strict 'PinnedByteArray', the returned slice is a view -- over the original buffer and allocates no extra memory. -match :: Parser a -> Parser (ByteString, a) +match :: Parser a -> Parser (PinnedByteArray, a) match (Parser p) = Parser $ \idx bs kf ks -> p idx bs kf ( \a idx' bs' -> - let !consumed = BS.take (idx'.idx - idx.idx) $ BS.drop idx.idx bs + -- TODO: Is take . drop this being inlined or rewritten? + let !consumed = PBA.take (idx'.idx - idx.idx) $ PBA.drop idx.idx bs in ks (consumed, a) idx' bs' ) {-# INLINE match #-} diff --git a/hpgsql/src/Hpgsql/Types.hs b/hpgsql/src/Hpgsql/Types.hs index 2fc1dbe..62536bf 100644 --- a/hpgsql/src/Hpgsql/Types.hs +++ b/hpgsql/src/Hpgsql/Types.hs @@ -20,6 +20,7 @@ import Data.Tuple.Only (Only (..)) import Data.Typeable (Proxy (..)) import Hpgsql.Builder (BinaryField (..)) import Hpgsql.Encoding (FieldDecoder (..), FieldEncoder (..), FieldInfo (..), FromPgField (..), FromPgRow (..), RowEncoder (..), ToPgField (..), ToPgRow (..), arrayField, toPgVectorField) +import qualified Hpgsql.PinnedByteArray as PBA import qualified Hpgsql.SimpleParser as Parser import Hpgsql.TypeInfo (EncodingContext (..), TypeInfo (..), jsonOid, jsonbOid, lookupTypeByOid) @@ -92,7 +93,7 @@ instance FromPgField PgJson where \FieldInfo {fieldTypeOid} -> let -- jsonb has a byte prepended to the contents and json does not !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in \bs -> Right $ PgJson $ fixJsonb bs, + in \bs -> Right $ PgJson $ fixJsonb (PBA.toByteString bs), decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell PgJson type. Use a `Maybe PgJson` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } @@ -102,7 +103,7 @@ instance FromPgField PgJson where if len == (-1) then pure Nothing else - fmap (Just . PgJson) $ + fmap (Just . PgJson . PBA.toByteString) $ if finfo.fieldTypeOid == jsonbOid then Parser.skip 1 >> Parser.take (len - 1) else Parser.take len @@ -122,7 +123,7 @@ instance (FromJSON a) => FromPgField (Aeson a) where \FieldInfo {fieldTypeOid} -> let -- jsonb has a byte prepended to the contents and json does not !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in \bs -> case Aeson.decodeStrict $ fixJsonb bs of + in \bs -> case Aeson.decodeStrict $ fixJsonb (PBA.toByteString bs) of Just v -> Right $ Aeson v Nothing -> Left "Failed to decode the postgres JSON value into your `Aeson a` type with aeson", decodesSqlNullTo = Left "Cannot decode SQL null as a Haskell (Aeson a) type. Use a `Maybe (Aeson a)` if you want SQL nulls", From 3e8a092177d7bd857eaa73b561becfb61cec2d02 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sun, 23 Aug 2026 11:56:59 -0300 Subject: [PATCH 30/35] Stop inlining aggressively in Generically derived row decoders, add another benchmark --- hpgsql-benchmarks/src/Main.hs | 12 +++++++++++- hpgsql-tests/RowDecoderGhcCore.hs | 4 ++-- hpgsql/src/Hpgsql/Encoding.hs | 12 ++++++++++-- 3 files changed, 23 insertions(+), 5 deletions(-) diff --git a/hpgsql-benchmarks/src/Main.hs b/hpgsql-benchmarks/src/Main.hs index 9150240..08dc633 100644 --- a/hpgsql-benchmarks/src/Main.hs +++ b/hpgsql-benchmarks/src/Main.hs @@ -47,7 +47,7 @@ import Hpgsql.Connection (renderLibpqConnectionString) import qualified Hpgsql.Connection import qualified Hpgsql.Connection as Hpgsql import qualified Hpgsql.Copy -import Hpgsql.Encoding (inlinedSingleFieldRowDecoder) +import Hpgsql.Encoding (inlinedSingleFieldRowDecoder, notInlinedSingleFieldRowDecoder) import qualified Hpgsql.Encoding as Hpgsql import qualified Hpgsql.Query as Hpgsql import qualified Hpgsql.Types as Hpgsql @@ -92,6 +92,10 @@ data BenchRow = BenchRow deriving stock (Generic, Show, Eq) deriving anyclass (NFData, Hpgsql.FromPgRow, PGSimple.FromRow) +notInlinedHandWrittenBenchRowDecoder :: Hpgsql.RowDecoder BenchRow +notInlinedHandWrittenBenchRowDecoder = + BenchRow <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + fullyInlinedBenchRowDecoder :: Hpgsql.RowDecoder BenchRow fullyInlinedBenchRowDecoder = BenchRow <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder @@ -293,6 +297,12 @@ main = do withMultipleConnections numConcurrentConnections hpgsqlConnect Hpgsql.Connection.closeGracefully $ \conn -> do res <- Hpgsql.querySWith (Hpgsql.rowDecoder @BenchRow) conn (Hpgsql.mkQuery sql17 (Hpgsql.Only n)) S.effects res + it ("hpgsql Record Stream (" ++ show n ++ " rows, hand-written row decoder)") $ + void $ + bench ("hpgsql Record Stream (" ++ show n ++ " rows, hand-written row decoder)") $ do + withMultipleConnections numConcurrentConnections hpgsqlConnect Hpgsql.Connection.closeGracefully $ \conn -> do + res <- Hpgsql.querySWith notInlinedHandWrittenBenchRowDecoder conn (Hpgsql.mkQuery sql17 (Hpgsql.Only n)) + S.effects res it ("hpgsql Record Stream (" ++ show n ++ " rows, fully inlined row decoder)") $ void $ bench ("hpgsql Record Stream (" ++ show n ++ " rows, fully inlined row decoder)") $ do diff --git a/hpgsql-tests/RowDecoderGhcCore.hs b/hpgsql-tests/RowDecoderGhcCore.hs index e10493c..0f8ceb4 100644 --- a/hpgsql-tests/RowDecoderGhcCore.hs +++ b/hpgsql-tests/RowDecoderGhcCore.hs @@ -21,8 +21,8 @@ import Hpgsql.Encoding (FromPgField (..), FromPgRow (..), genericFromPgRow, inli -- - Look for the Record constructor and grep for it to find where the RowDecoder -- invokes it, only to find where the RowDecoder is. -- - Grep for numbers that exist in the decoders' implementation, such as 8#, 13#, 4#. --- These are a strong indicator that each decoder was inlined into the RowDecoder. --- There is still unnecessary allocations/boxing even with full inlining, but maybe +-- These are strong indicators that each decoder was inlined into the RowDecoder. +-- There still are unnecessary allocations/boxing even with full inlining, but maybe -- one day we'll find a way to get rid of all of them. data BestCaseScenarioRecord = BestCaseScenarioRecord { bcsId :: !Int, diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index eb9e63b..338d541 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -235,7 +235,15 @@ class FromPgField a where Right v -> pure v -- | Semantically equivalent to `singleField fieldDecoder`, but for - -- some types it can provide a much faster `RowDecoder`. Beware that + -- most types it can provide a much faster `RowDecoder`. This doesn't + -- cause the same amount of size blowup that `inlinedSingleFieldRowDecoder` + -- does, but is also not as fast as that. + {-# NOINLINE notInlinedSingleFieldRowDecoder #-} + notInlinedSingleFieldRowDecoder :: RowDecoder a + notInlinedSingleFieldRowDecoder = inlinedSingleFieldRowDecoder + + -- | Semantically equivalent to `singleField fieldDecoder`, but for + -- most types it can provide a much faster `RowDecoder`. Beware that -- using will produce more code in your row decoders, which can affect -- compilation times and binary size. {-# INLINE inlinedSingleFieldRowDecoder #-} @@ -1424,7 +1432,7 @@ instance (FromPgField a) => ProductTypeDecoder (K1 r a) where -- coercing instead of fmap reduces memory usage, apparently -- by reducing (unnecessary) closures in the final row decoder, -- as per looking at GHC Core - genRowDecoder = coerce $ inlinedSingleFieldRowDecoder @a + genRowDecoder = coerce $ notInlinedSingleFieldRowDecoder @a genericToPgRow :: forall a. (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a genericToPgRow = contramap from genRowEncoder From 784d5cfbed255cc590680e2524f64810b12bce85 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sun, 23 Aug 2026 12:19:02 -0300 Subject: [PATCH 31/35] Don't use inlined row decoders for Tuples Barely any difference in performance --- hpgsql/src/Hpgsql/Encoding.hs | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index 338d541..9fd92d1 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -364,43 +364,43 @@ compositeTypeEncoder rowEnc = } instance (FromPgField a) => FromPgRow (Only a) where - rowDecoder = Only <$> inlinedSingleFieldRowDecoder + rowDecoder = Only <$> notInlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b) => FromPgRow (a, b) where - rowDecoder = (,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder + rowDecoder = (,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c) => FromPgRow (a, b, c) where - rowDecoder = (,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder + rowDecoder = (,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d) => FromPgRow (a, b, c, d) where - rowDecoder = (,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder + rowDecoder = (,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e) => FromPgRow (a, b, c, d, e) where - rowDecoder = (,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder + rowDecoder = (,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f) => FromPgRow (a, b, c, d, e, f) where - rowDecoder = (,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder + rowDecoder = (,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g) => FromPgRow (a, b, c, d, e, f, g) where - rowDecoder = (,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder + rowDecoder = (,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h) => FromPgRow (a, b, c, d, e, f, g, h) where - rowDecoder = (,,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder + rowDecoder = (,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i) => FromPgRow (a, b, c, d, e, f, g, h, i) where - rowDecoder = (,,,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder + rowDecoder = (,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j) => FromPgRow (a, b, c, d, e, f, g, h, i, j) where - rowDecoder = (,,,,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder + rowDecoder = (,,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k) where - rowDecoder = (,,,,,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder + rowDecoder = (,,,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k, FromPgField l) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k, l) where - rowDecoder = (,,,,,,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder + rowDecoder = (,,,,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k, FromPgField l, FromPgField m) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k, l, m) where - rowDecoder = (,,,,,,,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder + rowDecoder = (,,,,,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder data FieldEncoder a = FieldEncoder { toTypeOid :: !(EncodingContext -> Maybe Oid), From b4f37ab84190627f625fac972facf7b16be874be Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sun, 23 Aug 2026 12:44:15 -0300 Subject: [PATCH 32/35] Update TODO --- TODO.md | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/TODO.md b/TODO.md index 73f8067..18d9cb5 100644 --- a/TODO.md +++ b/TODO.md @@ -1 +1,9 @@ -- If ShortByteStrings are really beneficial, consider breaking API change to take a ShortByteString instead in FromPgField to avoid so much converting between ByteString and ShortByteString +- Test both `singleField fieldDecoder` and `singleFieldRowDecoder` for every type in our tests. +- Do _not_ expose new FromPgField methods. Add new EncodingInternal module, instead. + - Check that the non-exposed methods are safe wrt bytearray bounds access by construction, and users can't break that. If that's true, we can omit bounds checks in our row decoding, making row decoders smaller and maybe faster. +- Some types might still not derive specialized row decoders +- "Oh no! No colInfo here.. what do we do!?" in hpgsql-simple-compat. This might require a big rethinking of things.. +- Double-check which row encoders we want to use the inlined versions for and which we don't. Tuples? +- Text internals might be easier to use now? +- Expose in the FromPgField class two new methods.. inlined and non inlined row decoders with/without bounds checks. Use with-bounds-checks for MonadicRowDecoder, and without-bounds-checks for regular row decoder, because the latter checks type oids +- Is `notInlinedSingleFieldRowDecoder` worth keeping? The Generically derived decoder is almost as fast. Maybe for types that aren't records it's a different story, though? From 19acd1dff4039f5188fb8d58bdf22bd4d938cbe8 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sun, 23 Aug 2026 20:04:43 -0300 Subject: [PATCH 33/35] Stop exposing performance-oriented FromPgField methods So we can change them --- hpgsql/hpgsql.cabal | 1 + hpgsql/src/Hpgsql/Encoding.hs | 1541 +---------------------- hpgsql/src/Hpgsql/Encoding/Internal.hs | 1578 ++++++++++++++++++++++++ hpgsql/src/Hpgsql/Types.hs | 2 +- 4 files changed, 1583 insertions(+), 1539 deletions(-) create mode 100644 hpgsql/src/Hpgsql/Encoding/Internal.hs diff --git a/hpgsql/hpgsql.cabal b/hpgsql/hpgsql.cabal index 7a4d495..0ba7fc9 100644 --- a/hpgsql/hpgsql.cabal +++ b/hpgsql/hpgsql.cabal @@ -43,6 +43,7 @@ library Hpgsql.Types other-modules: Hpgsql.Base + Hpgsql.Encoding.Internal Hpgsql.Internal Hpgsql.LanguageHaskell.FromThExtension Hpgsql.LanguageHaskell.GhcParserOpts diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index 9fd92d1..1692724 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE UndecidableInstances #-} - -- | -- -- = Encoding and decoding fields and rows @@ -21,8 +19,8 @@ -- of fields), check "Hpgsql.Encoding.RowDecoderMonadic". module Hpgsql.Encoding ( -- * Decoding - FromPgField (..), -- We export the other internal perf-oriented methods, which isn't great because we may want to change them - FieldDecoder (..), -- TODO: Can we export ctor? + FromPgField (fieldDecoder, notInlinedSingleFieldRowDecoder, inlinedSingleFieldRowDecoder), -- Do not export other methods so we can change them + FieldDecoder (..), FieldInfo (..), FromPgRow (..), RowDecoder (..), -- TODO: Can we export ctor? @@ -68,1537 +66,4 @@ module Hpgsql.Encoding ) where -import Control.Monad (replicateM, unless, when) -import qualified Data.Aeson as Aeson -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC -import qualified Data.ByteString.Lazy as LBS -import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI -import Data.Coerce (coerce) -import Data.Fixed (divMod') -import Data.Functor.Contravariant (Contravariant (..)) -import Data.Int (Int16, Int32, Int64) -import qualified Data.List as List -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe) -import Data.Monoid (Sum (..)) -import Data.Proxy (Proxy (..)) -import Data.Ratio (Ratio) -import Data.Scientific (Scientific (..), floatingOrInteger, scientific) -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT -import Data.Time (CalendarDiffDays (..), CalendarDiffTime (..), Day, LocalTime (..), NominalDiffTime, TimeOfDay, UTCTime (..), ZonedTime, diffDays, diffTimeToPicoseconds, fromGregorian, picosecondsToDiffTime, secondsToNominalDiffTime, timeOfDayToTime, timeToTimeOfDay, utc, utcToZonedTime, zonedTimeToUTC) -import Data.Time.Calendar.Julian (addJulianDurationClip, fromJulian) -import Data.Tuple.Only (Only (..)) -import Data.UUID.Types (UUID) -import qualified Data.UUID.Types as UUID -import Data.Vector (Vector) -import qualified Data.Vector as Vector -import GHC.Float (castWord32ToFloat, castWord64ToDouble, expt, float2Double) -import GHC.Generics (C, D, Generic (..), K1 (..), M1 (..), Meta (MetaCons), U1 (..), (:*:) (..), (:+:) (..)) -import GHC.TypeLits (KnownSymbol, TypeError, symbolVal) -import qualified GHC.TypeLits as TypeLits -import Hpgsql.Builder (BinaryField (..)) -import qualified Hpgsql.Builder as Builder -import Hpgsql.PinnedByteArray (PinnedByteArray) -import qualified Hpgsql.PinnedByteArray as PBA -import qualified Hpgsql.SimpleParser as Parser -import Hpgsql.Time (Unbounded (..)) -import Hpgsql.TypeInfo (EncodingContext (..), Oid (..), TypeDetails (..), TypeInfo (..), boolOid, byteaOid, charOid, dateOid, float4Oid, float8Oid, int2Oid, int4Oid, int8Oid, intervalOid, jsonOid, jsonbOid, lookupTypeByName, lookupTypeByOid, nameOid, numericOid, oidOid, textOid, timeOid, timestampOid, timestamptzOid, uuidOid, varcharOid, voidOid) - -data FieldInfo = FieldInfo - { fieldTypeOid :: !Oid, - -- | The column name from the query's result, if available. - fieldName :: !(Maybe Text), - -- | The EncodingContext as of the moment the query ran. - encodingContext :: !EncodingContext - } - --- | A decoder for a single field/column. -data FieldDecoder a = FieldDecoder - { fieldValueDecoder :: FieldInfo -> PinnedByteArray -> Either String a, - decodesSqlNullTo :: Either String a, - allowedPgTypes :: FieldInfo -> Bool - } - deriving stock (Functor) - --- | `f1 <> f2` produces a `FieldDecoder` that tries `f1` first, and if that fails it tries `f2`. -instance Semigroup (FieldDecoder a) where - dec1 <> dec2 = - FieldDecoder - { fieldValueDecoder = \cInfo -> - let f1 = dec1.fieldValueDecoder cInfo - f2 = dec2.fieldValueDecoder cInfo - in \mbs -> - let cand1 = if dec1.allowedPgTypes cInfo then f1 mbs else Left "Not first parser" - cand2 = if dec2.allowedPgTypes cInfo then f2 mbs else Left "Not second parser" - in cand1 <> cand2, - decodesSqlNullTo = dec1.decodesSqlNullTo <> dec2.decodesSqlNullTo, - allowedPgTypes = \cInfo -> dec1.allowedPgTypes cInfo || dec2.allowedPgTypes cInfo - } - -data RowDecoder a = RowDecoder - { fullRowDecoder :: [FieldInfo] -> Parser.Parser a, - -- | Returns the same colInfos with a boolean indicating if - -- the expected types match for each colInfo. - rowColumnsTypeCheck :: [FieldInfo] -> [(FieldInfo, Bool)], - numExpectedColumns :: !Int - } - deriving stock (Functor, Generic) - -instance Applicative RowDecoder where - pure v = RowDecoder (const $ pure v) (map (,True)) 0 - {-# INLINE (<*>) #-} -- This is crucial for performance. It makes our CPS Parser truly compile to CPS row decoders. - RowDecoder p1 tc1 nc1 <*> RowDecoder p2 tc2 nc2 = RowDecoder (\colTypes -> let (cols1, cols2) = List.splitAt nc1 colTypes in p1 cols1 <*> p2 cols2) (\colTypes -> let (cols1, cols2) = List.splitAt nc1 colTypes in tc1 cols1 ++ tc2 cols2) (nc1 + nc2) - -instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in Hpgsql because Hpgsql type-checks the result types of queries before having access to even the first data row. Use the Applicative class to write your instances or use the Monadic decoding variants.")) => Monad RowDecoder where - (>>=) = error "inaccessible bind in Monad RowDecoder instance" - -{-# INLINE singleField #-} -singleField :: FieldDecoder a -> RowDecoder a -singleField fdec = - -- This `case` is why we require `fieldAndValueDecoder` to decode - -- SQL NULL into `Nothing`: we do check decodesSqlNullTo. - let !valueForNull = case fdec.decodesSqlNullTo of - Left err -> fail err - Right v -> pure v - !typeCheck = fdec.allowedPgTypes - in RowDecoder - { fullRowDecoder = \case - [singleColInfo] -> - let decode = fdec.fieldValueDecoder singleColInfo - in do - lenNextCol <- fromIntegral <$> Parser.takeInt32BE - if lenNextCol >= 0 - then do - nextColBs <- Parser.take lenNextCol - case decode nextColBs of - Right v -> pure v - Left err -> fail err - else valueForNull - _ -> error "singleField expected a single column OID but got 0 or >1", - rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, typeCheck singleColInfo)] - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", - numExpectedColumns = 1 - } - -class FromPgField a where - {-# MINIMAL fieldDecoder #-} - fieldDecoder :: FieldDecoder a - - -- | For types where there is a fast way to decode fields+values - -- without knowing the OID of the value in the query (of course, the - -- possible OIDs are still limited by the FieldDecoder's allowed types), - -- defining this can help provide a significant performance boost to inlined row decoders. - -- - -- Any implementation of this _must_ return a `Nothing` for a SQL NULL value, - -- regardless of what `FieldDecoder` would do with a SQL NULL. - -- - -- Define this as `Nothing` if implementing it isn't possible. - -- This isn't exposed to users yet, but we should recommend they add an INLINE pragma, - -- as the method's name suggests. - {-# INLINE inlinedConstFieldDecoder #-} - inlinedConstFieldDecoder :: Maybe (Parser.Parser (Maybe a)) - inlinedConstFieldDecoder = Nothing - - -- | For types that can't implement `inlinedConstFieldDecoder` because they - -- need to know the value's OID for decoding, this is the next best thing: - -- also a specialized field+value decoder that can be faster than the - -- one derived from `fieldDecoder`. - -- - -- Any implementation of this _must_ return a `Nothing` for a SQL NULL value, - -- regardless of what `FieldDecoder` would do with a SQL NULL. - {-# INLINE notConstFieldDecoder #-} - notConstFieldDecoder :: FieldInfo -> Parser.Parser (Maybe a) - notConstFieldDecoder = - case inlinedConstFieldDecoder of - Nothing -> slowerParser - Just fd -> const fd - where - -- slowerParser takes a ByteString and passes it to the - -- field decoder. - slowerParser singleColInfo = do - len <- Parser.takeInt32BE - if len == (-1) - then pure Nothing - else do - bs <- Parser.take (fromIntegral len) - case fieldDecoder.fieldValueDecoder singleColInfo bs of - Left err -> fail err - Right v -> pure v - - -- | Semantically equivalent to `singleField fieldDecoder`, but for - -- most types it can provide a much faster `RowDecoder`. This doesn't - -- cause the same amount of size blowup that `inlinedSingleFieldRowDecoder` - -- does, but is also not as fast as that. - {-# NOINLINE notInlinedSingleFieldRowDecoder #-} - notInlinedSingleFieldRowDecoder :: RowDecoder a - notInlinedSingleFieldRowDecoder = inlinedSingleFieldRowDecoder - - -- | Semantically equivalent to `singleField fieldDecoder`, but for - -- most types it can provide a much faster `RowDecoder`. Beware that - -- using will produce more code in your row decoders, which can affect - -- compilation times and binary size. - {-# INLINE inlinedSingleFieldRowDecoder #-} - inlinedSingleFieldRowDecoder :: RowDecoder a - inlinedSingleFieldRowDecoder = case inlinedConstFieldDecoder @a of - -- This is a class method instead of a top-level function - -- because the GHC inliner behaves differently when it's a top-level - -- function, and benchmarks show this is faster. - Nothing -> - let !valueForNull = case (fieldDecoder @a).decodesSqlNullTo of - Left err -> fail err - Right v -> pure v - !typeCheck = (fieldDecoder @a).allowedPgTypes - in RowDecoder - { fullRowDecoder = \case - [singleColInfo] -> do - mv <- notConstFieldDecoder singleColInfo - case mv of - Nothing -> valueForNull - Just v -> pure v - _ -> error "singleField expected a single column OID but got 0 or >1", - rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, typeCheck singleColInfo)] - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", - numExpectedColumns = 1 - } - Just p -> - -- The strictness and floating out of fieldDecoder-derived - -- values allows GHC to inline a lot more. For example, `valueForNull` - -- gets inlined to a `fail "Cannot decode SQL NULL ..."` for basic types - -- like `Int`. - let !valueForNull = case (fieldDecoder @a).decodesSqlNullTo of - Left err -> fail err - Right v -> pure v - !typeCheck = (fieldDecoder @a).allowedPgTypes - in RowDecoder - { fullRowDecoder = const $ do - mv <- p - case mv of - Nothing -> valueForNull - Just v -> pure v, - rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, typeCheck singleColInfo)] - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", - numExpectedColumns = 1 - } - -class FromPgRow a where - rowDecoder :: RowDecoder a - default rowDecoder :: (Generic a, ProductTypeDecoder (Rep a)) => RowDecoder a - rowDecoder = genericFromPgRow - --- | Allows you to create a @FieldDecoder@ for composite types. --- For a type such as: --- --- > CREATE TYPE int_and_bool AS (numfield INT, boolfield BOOL); --- --- You can define a Haskell type as such: --- --- > data IntAndBool = IntAndBool Int Bool --- > --- > instance FromPgField IntAndBool where --- > fieldDecoder = compositeTypeDecoder rowDecoder <&> \(i, b) -> IntAndBool i b -compositeTypeDecoder :: forall a. RowDecoder a -> FieldDecoder a -compositeTypeDecoder (RowDecoder {..}) = - FieldDecoder - { fieldValueDecoder = \compositeTypeOid -> - let !prs = parserForRecord compositeTypeOid.encodingContext <* Parser.endOfInput - in \bs -> - case Parser.parseOnly prs bs of - Parser.ParseOk v -> Right v - Parser.ParseFail err -> Left err, - decodesSqlNullTo = Left "Got NULL in composite type but it was not allowed", - allowedPgTypes = const True -- There's no way to enforce a custom type's OID. We only check if it's structurally the same in the parser (same subtypes in same order) - } - where - parserForRecord :: EncodingContext -> Parser.Parser a - parserForRecord encodingContext = do - -- From https://github.com/postgres/postgres/blob/50ba65e73325cf55fedb3e1f14673d816726923b/src/backend/utils/adt/rowtypes.c#L687 - -- we can see a composite type's binary representation consists of: number of columns (Int32) + for_each_column { OID (Int32) + size_or_minus_1 (Int32) + Bytes } - numCols <- fromIntegral <$> Parser.takeInt32BE - unless (numCols == numExpectedColumns) $ fail $ "Composite type has " ++ show numCols ++ " attributes but parser expected " ++ show numExpectedColumns - let mkColInfo oid = FieldInfo oid Nothing encodingContext - cols <- replicateM numCols $ do - !oid <- Oid . fromIntegral <$> Parser.takeInt32BE - (sizeBs, !size) <- Parser.match $ fromIntegral <$> Parser.takeInt32BE - !bs <- Parser.take (max 0 size) - pure (oid, PBA.fromStrict sizeBs <> PBA.fromStrict bs) - let typecheckedCols = rowColumnsTypeCheck (map (mkColInfo . fst) cols) - unless (all snd typecheckedCols) $ fail $ "Parser for composite found type OIDs " ++ show (map fst cols) ++ " but expected different" - case Parser.parseOnly (fullRowDecoder (map (mkColInfo . fst) cols) <* Parser.endOfInput) (PBA.toStrict $ mconcat $ map snd cols) of - Parser.ParseOk v -> pure v - Parser.ParseFail err -> error $ "Error decoding composite type: " ++ show err - --- | Allows you to create a @FieldEncoder@ for composite types. --- For a type such as: --- --- > CREATE TYPE int_and_bool AS (numfield INT, boolfield BOOL); --- --- You can define a Haskell type as such: --- --- > data IntAndBool = IntAndBool Int Bool --- > --- > instance ToPgField IntAndBool where --- > fieldEncoder = typeFieldEncoder (typeOidWithName "int_and_bool") --- > $ compositeTypeEncoder $ contramap (\(IntAndBool i b) -> (fromIntegral i :: Int32, b)) rowEncoder -compositeTypeEncoder :: forall a. RowEncoder a -> FieldEncoder a -compositeTypeEncoder rowEnc = - FieldEncoder - { toTypeOid = \_ -> Nothing, - toPgField = \encCtx -> \a -> - let fields = map (\f -> f encCtx) (rowEnc.toPgParams a) - numCols = Builder.int32BE (fromIntegral $ length fields) - encodeField (mOid, bf) = - let Oid oid = fromMaybe (Oid 0) mOid - in Builder.int32BE oid <> Builder.binaryField bf - in NotNull (Builder.toStrictByteString (numCols <> foldMap encodeField fields)) - } - -instance (FromPgField a) => FromPgRow (Only a) where - rowDecoder = Only <$> notInlinedSingleFieldRowDecoder - -instance (FromPgField a, FromPgField b) => FromPgRow (a, b) where - rowDecoder = (,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder - -instance (FromPgField a, FromPgField b, FromPgField c) => FromPgRow (a, b, c) where - rowDecoder = (,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder - -instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d) => FromPgRow (a, b, c, d) where - rowDecoder = (,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder - -instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e) => FromPgRow (a, b, c, d, e) where - rowDecoder = (,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder - -instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f) => FromPgRow (a, b, c, d, e, f) where - rowDecoder = (,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder - -instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g) => FromPgRow (a, b, c, d, e, f, g) where - rowDecoder = (,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder - -instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h) => FromPgRow (a, b, c, d, e, f, g, h) where - rowDecoder = (,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder - -instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i) => FromPgRow (a, b, c, d, e, f, g, h, i) where - rowDecoder = (,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder - -instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j) => FromPgRow (a, b, c, d, e, f, g, h, i, j) where - rowDecoder = (,,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder - -instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k) where - rowDecoder = (,,,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder - -instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k, FromPgField l) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k, l) where - rowDecoder = (,,,,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder - -instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k, FromPgField l, FromPgField m) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k, l, m) where - rowDecoder = (,,,,,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder - -data FieldEncoder a = FieldEncoder - { toTypeOid :: !(EncodingContext -> Maybe Oid), - toPgField :: !(EncodingContext -> a -> BinaryField) - } - -instance Contravariant FieldEncoder where - contramap f fEnc = FieldEncoder {toTypeOid = fEnc.toTypeOid, toPgField = \encCtx -> let toF = fEnc.toPgField encCtx in \v -> toF (f v)} - -class ToPgField a where - fieldEncoder :: FieldEncoder a - --- | Allows you to specify a type for a FieldEncoder. This can be useful to avoid --- letting postgres infer types itself, which can cause errors. For example: --- --- > data MyEnum = Val1 | Val2 | Val3 --- > myEnumFieldDecoderWithTypeInfoCheck :: FieldEncoder MyEnum --- > myEnumFieldDecoderWithTypeInfoCheck = --- > let convert = \case --- > Val1 -> "val1" :: Text --- > Val2 -> "val2" --- > Val3 -> "val3" --- > in typeFieldEncoder --- > (typeOidWithName "my_enum") --- > $ contramap convert fieldEncoder --- --- This will work unless you use non-default flags in your connection options. -typeFieldEncoder :: (EncodingContext -> Maybe Oid) -> FieldEncoder a -> FieldEncoder a -typeFieldEncoder ttoid enc = enc {toTypeOid = ttoid} - -typeOidWithName :: Text -> (EncodingContext -> Maybe Oid) -typeOidWithName typName = \encCtx -> typeOid <$> lookupTypeByName typName encCtx.typeInfoCache - -instance ToPgField Int where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just haskellIntOid, - toPgField = \_ -> binaryIntEncoder - } - -instance ToPgField Int16 where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just int2Oid, - toPgField = \_ -> \n -> NotNull $ PBA.encodeInt16BE n - } - -instance ToPgField Int32 where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just int4Oid, - toPgField = \_ -> \n -> NotNull $ PBA.encodeInt32BE n - } - -instance ToPgField Int64 where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just int8Oid, - toPgField = \_ -> \n -> NotNull $ PBA.encodeInt64BE n - } - -instance ToPgField Integer where - fieldEncoder = - let fe = fieldEncoder @Scientific - in FieldEncoder - { toTypeOid = \_ -> Just numericOid, - toPgField = \encCtx -> \n -> fe.toPgField encCtx (fromIntegral n) - } - -instance ToPgField (Ratio Integer) where - fieldEncoder = - let fe = fieldEncoder @Scientific - in FieldEncoder - { toTypeOid = \_ -> Just numericOid, - toPgField = \encCtx -> \r -> fe.toPgField encCtx (fromRational r) - } - -instance ToPgField Oid where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just oidOid, - toPgField = \_ -> \n -> NotNull $ PBA.encodeInt32BE $ fromIntegral n - } - -instance ToPgField Scientific where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just numericOid, - toPgField = \_ -> \n -> - let sign = PBA.encodeInt16BE $ if n >= 0 then 0 else 0x4000 - -- The number is coeff * 10^exp, but we want it in base-10000 so we convert it to - -- new_coeff * 10^new_exp with new_exp a multiple of 4 - base10000Expon = 4 * (base10Exponent n `div` 4) - base10000Coeff = coefficient n * expt 10 (base10Exponent n - base10000Expon) - ndigits, weight :: Int16 - digits :: ByteString - (ndigits, weight, digits) = calculateDigits 0 0 (abs base10000Coeff) "" - dscale = PBA.encodeInt16BE (abs $ fromIntegral base10000Expon) -- More than necessary, but safe? - in NotNull $ PBA.encodeInt16BE ndigits <> PBA.encodeInt16BE (weight - 1 + fromIntegral (base10000Expon `div` 4)) <> sign <> dscale <> digits - } - where - calculateDigits :: Int16 -> Int16 -> Integer -> BS.ByteString -> (Int16, Int16, BS.ByteString) - calculateDigits !ndigitsSoFar !weightSoFar 0 !encodedDigits = (ndigitsSoFar, weightSoFar, encodedDigits) - calculateDigits !ndigitsSoFar !weightSoFar !val !encodedDigits = - let (quotient, fromIntegral -> (rest :: Int16)) = val `divMod` 10000 - in calculateDigits - (ndigitsSoFar + 1) - (weightSoFar + 1) - quotient - (PBA.encodeInt16BE rest <> encodedDigits) - -instance ToPgField Float where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just float4Oid, - toPgField = \_ -> \n -> NotNull $ PBA.encodeFloat n - } - -instance ToPgField Double where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just float8Oid, - toPgField = \_ -> \n -> NotNull $ PBA.encodeDouble n - } - -instance ToPgField Bool where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just boolOid, - toPgField = \_ n -> NotNull $ PBA.encodePgBoolean n - } - -instance ToPgField Day where - -- PG Dates are Int32 number of days relative to 2000-01-01 - -- https://github.com/postgres/postgres/blob/master/src/include/datatype/timestamp.h#L235 - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just dateOid, - -- TODO: Catch integer overflow and do what? - toPgField = \_ d -> NotNull $ PBA.encodeInt32BE $ fromIntegral $ diffDays d (fromGregorian 2000 1 1) - } - -instance ToPgField (Unbounded Day) where - fieldEncoder = - let fe = fieldEncoder @Day - in FieldEncoder - { toTypeOid = fe.toTypeOid, - toPgField = \encCtx -> \case - NegInfinity -> NotNull $ PBA.encodeInt32BE minBound - Finite v -> fe.toPgField encCtx v - PosInfinity -> NotNull $ PBA.encodeInt32BE maxBound - } - -instance ToPgField CalendarDiffTime where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just intervalOid, - toPgField = \_ CalendarDiffTime {..} -> - let (days :: Int32, timeUnderOneDay) = ctTime `divMod'` 86_400 - in NotNull $ PBA.encodeInt64BE (round $ timeUnderOneDay * 1_000_000) <> PBA.encodeInt32BE days <> PBA.encodeInt32BE (fromIntegral ctMonths) - } - -instance ToPgField NominalDiffTime where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just intervalOid, - toPgField = \_ ndt -> - NotNull $ PBA.encodeInt64BE (round $ ndt * 1_000_000) <> PBA.encodeInt32BE 0 <> PBA.encodeInt32BE 0 - } - -instance ToPgField UTCTime where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just timestamptzOid, - -- TODO: Catch integer overflow and do what? - toPgField = \_ (UTCTime parsedDate timeinday) -> - let day :: Int64 = fromInteger $ parsedDate `diffDays` fromJulian 1999 12 19 - totalusecs :: Int64 = 86_400_000_000 * day + fromInteger (diffTimeToPicoseconds timeinday `div` 1_000_000) - in NotNull $ PBA.encodeInt64BE totalusecs - } - -instance ToPgField (Unbounded UTCTime) where - fieldEncoder = - let fe = fieldEncoder @UTCTime - in FieldEncoder - { toTypeOid = fe.toTypeOid, - toPgField = \encCtx -> \case - NegInfinity -> NotNull $ PBA.encodeInt64BE minBound - Finite v -> fe.toPgField encCtx v - PosInfinity -> NotNull $ PBA.encodeInt64BE maxBound - } - -instance ToPgField ZonedTime where - fieldEncoder = - let fe = fieldEncoder @UTCTime - in FieldEncoder - { toTypeOid = \_ -> Just timestamptzOid, - toPgField = \encCtx -> fe.toPgField encCtx . zonedTimeToUTC - } - -instance ToPgField (Unbounded ZonedTime) where - fieldEncoder = - let fe = fieldEncoder @ZonedTime - in FieldEncoder - { toTypeOid = fe.toTypeOid, - toPgField = \encCtx -> \case - NegInfinity -> NotNull $ PBA.encodeInt64BE minBound - Finite v -> fe.toPgField encCtx v - PosInfinity -> NotNull $ PBA.encodeInt64BE maxBound - } - -instance ToPgField LocalTime where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just timestampOid, - toPgField = \_ (LocalTime localDay localTimeOfDay) -> - let day :: Int64 = fromInteger $ localDay `diffDays` fromJulian 1999 12 19 - totalusecs :: Int64 = 86_400_000_000 * day + fromInteger (diffTimeToPicoseconds (timeOfDayToTime localTimeOfDay) `div` 1_000_000) - in NotNull $ PBA.encodeInt64BE totalusecs - } - -instance ToPgField TimeOfDay where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just timeOid, - toPgField = \_ tod -> - let usecs :: Int64 = fromInteger $ diffTimeToPicoseconds (timeOfDayToTime tod) `div` 1_000_000 - in NotNull $ PBA.encodeInt64BE usecs - } - -instance ToPgField Char where - fieldEncoder = - let fe = fieldEncoder @Text - in FieldEncoder - { toTypeOid = \_ -> Just textOid, - toPgField = \encCtx -> let !toTextField = fe.toPgField encCtx in \t -> toTextField $ Text.singleton t - } - -instance ToPgField ByteString where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just byteaOid, - toPgField = \_ -> \bs -> NotNull bs - } - -instance ToPgField LBS.ByteString where - fieldEncoder = - let fe = fieldEncoder @ByteString - in FieldEncoder - { toTypeOid = \_ -> Just byteaOid, - toPgField = \encCtx -> fe.toPgField encCtx . LBS.toStrict - } - -instance ToPgField Text where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just textOid, - toPgField = \_ -> \t -> - let bs = encodeUtf8 t - in NotNull bs - } - -instance ToPgField LT.Text where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just textOid, - toPgField = \_ -> \t -> - let bs = LBS.toStrict $ LT.encodeUtf8 t - in NotNull bs - } - -instance ToPgField String where - fieldEncoder = - let fe = fieldEncoder @Text - in FieldEncoder - { toTypeOid = \_ -> Just textOid, - toPgField = \encCtx -> fe.toPgField encCtx . Text.pack - } - --- From https://hackage.haskell.org/package/case-insensitive-1.2.1.0/docs/Data-CaseInsensitive.html, --- "Note that the FoldCase instance for ByteStrings is only guaranteed to be correct for ISO-8859-1 encoded strings!". --- So we don't have those instances. - --- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default --- connection option). -instance ToPgField (CI Text) where - fieldEncoder = typeFieldEncoder (typeOidWithName "citext") $ contramap CI.original fieldEncoder - --- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default --- connection option). -instance ToPgField (CI LT.Text) where - fieldEncoder = typeFieldEncoder (typeOidWithName "citext") $ contramap CI.original fieldEncoder - --- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default --- connection option). -instance ToPgField (CI String) where - fieldEncoder = typeFieldEncoder (typeOidWithName "citext") $ contramap CI.original fieldEncoder - -instance ToPgField UUID where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just uuidOid, - toPgField = \_ -> NotNull . LBS.toStrict . UUID.toByteString - } - -instance ToPgField Aeson.Value where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just jsonbOid, - toPgField = \_ -> \v -> - let bs = BS.cons 1 (LBS.toStrict $ Aeson.encode v) - in NotNull bs - } - -instance (ToPgField a) => ToPgField (Maybe a) where - fieldEncoder = - let fe = fieldEncoder @a - in FieldEncoder - { toTypeOid = fe.toTypeOid, - toPgField = \encCtx -> \case - Nothing -> SqlNull - Just n -> fe.toPgField encCtx n - } - -instance (ToPgField a) => ToPgField (Vector a) where - fieldEncoder = - let fe = fieldEncoder @a - in FieldEncoder - { toTypeOid = \encodingContext -> do - -- Maybe monad - elOid <- fe.toTypeOid encodingContext - arrayTypInfo <- lookupTypeByOid elOid encodingContext.typeInfoCache - arrayTypInfo.oidOfArrayType, - toPgField = toPgVectorField - } - -data RowEncoder a = RowEncoder - { toPgParams :: !(a -> [EncodingContext -> (Maybe Oid, BinaryField)]), - toTypeOids :: !(Proxy a -> [EncodingContext -> Maybe Oid]), - -- | This produces bytes for Binary COPY FROM STDIN rows, which can increase performance - -- and reduce memory usage comparing to deriving these bytes from `toPgParams`. - -- The produced bytes should not contain the total number of fields in the - -- beginning. - toBinaryCopyBytes :: !(EncodingContext -> a -> Builder.Builder) - } - -instance Contravariant RowEncoder where - contramap f rec = RowEncoder (\v -> rec.toPgParams (f v)) (\_ -> rec.toTypeOids Proxy) (\encCtx -> let !toBytes = rec.toBinaryCopyBytes encCtx in \v -> toBytes (f v)) - --- | These are from `Divisible`, but we don't currently pull in the extra dependency that has that. -divide :: (a -> (b, c)) -> RowEncoder b -> RowEncoder c -> RowEncoder a -divide d re1 re2 = - RowEncoder - { toPgParams = \a -> let (b, c) = d a in re1.toPgParams b ++ re2.toPgParams c, - toTypeOids = \_ -> re1.toTypeOids Proxy ++ re2.toTypeOids Proxy, - toBinaryCopyBytes = \encCtx -> - let !toBytes1 = re1.toBinaryCopyBytes encCtx - !toBytes2 = re2.toBinaryCopyBytes encCtx - in \a -> let (b, c) = d a in toBytes1 b <> toBytes2 c - } - -class ToPgRow a where - rowEncoder :: RowEncoder a - default rowEncoder :: (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a - rowEncoder = genericToPgRow - -instance ToPgRow () where - rowEncoder = RowEncoder (\_ -> []) (\_ -> []) (\_ -> \_ -> mempty) - -singleFieldRowEncoder :: forall a. (ToPgField a) => RowEncoder a -singleFieldRowEncoder = - let fe = fieldEncoder @a - in RowEncoder - { toPgParams = \a -> [\encodingContext -> (fe.toTypeOid encodingContext, fe.toPgField encodingContext a)], - toTypeOids = \_ -> [fe.toTypeOid], - toBinaryCopyBytes = \encCtx -> let !enc = fe.toPgField encCtx in \a -> Builder.binaryField $ enc a - } - -instance (ToPgField a) => ToPgRow (Only a) where - rowEncoder = contramap fromOnly singleFieldRowEncoder - -instance (ToPgField a, ToPgField b) => ToPgRow (a, b) where - rowEncoder = divide id singleFieldRowEncoder singleFieldRowEncoder - -instance (ToPgField a, ToPgField b, ToPgField c) => ToPgRow (a, b, c) where - rowEncoder = divide (\(a, b, c) -> ((a, b), c)) rowEncoder singleFieldRowEncoder - -instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d) => ToPgRow (a, b, c, d) where - rowEncoder = divide (\(a, b, c, d) -> ((a, b), (c, d))) rowEncoder rowEncoder - -instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e) => ToPgRow (a, b, c, d, e) where - rowEncoder = divide (\(a, b, c, d, e) -> ((a, b, c), (d, e))) rowEncoder rowEncoder - -instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f) => ToPgRow (a, b, c, d, e, f) where - rowEncoder = divide (\(a, b, c, d, e, f) -> ((a, b, c), (d, e, f))) rowEncoder rowEncoder - -instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g) => ToPgRow (a, b, c, d, e, f, g) where - rowEncoder = divide (\(a, b, c, d, e, f, g) -> ((a, b, c), (d, e, f, g))) rowEncoder rowEncoder - -instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g, ToPgField h) => ToPgRow (a, b, c, d, e, f, g, h) where - rowEncoder = divide (\(a, b, c, d, e, f, g, h) -> ((a, b, c, d), (e, f, g, h))) rowEncoder rowEncoder - -instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g, ToPgField h, ToPgField i) => ToPgRow (a, b, c, d, e, f, g, h, i) where - rowEncoder = divide (\(a, b, c, d, e, f, g, h, i) -> ((a, b, c, d), (e, f, g, h, i))) rowEncoder rowEncoder - -instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g, ToPgField h, ToPgField i, ToPgField j) => ToPgRow (a, b, c, d, e, f, g, h, i, j) where - rowEncoder = divide (\(a, b, c, d, e, f, g, h, i, j) -> ((a, b, c, d, e), (f, g, h, i, j))) rowEncoder rowEncoder - -instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g, ToPgField h, ToPgField i, ToPgField j, ToPgField k) => ToPgRow (a, b, c, d, e, f, g, h, i, j, k) where - rowEncoder = divide (\(a, b, c, d, e, f, g, h, i, j, k) -> ((a, b, c, d, e, f), (g, h, i, j, k))) rowEncoder rowEncoder - --- | The OID for `Data.Int`, which is machine dependent. -haskellIntOid :: Oid - --- | All pg type OIDs that fit into Haskell's `Data.Int`, whose size is machine dependent. -haskellIntOids :: [Oid] -(haskellIntOid, haskellIntOids) - | (fromIntegral (maxBound @Int) :: Integer) > fromIntegral (maxBound @Int32) = (int8Oid, [int2Oid, int4Oid, int8Oid]) - | (fromIntegral (maxBound @Int) :: Integer) > fromIntegral (maxBound @Int16) = (int4Oid, [int2Oid, int4Oid]) - | otherwise = (int2Oid, [int2Oid]) - --- | Big-Endian binary encoder for Haskell's `Data.Int`, which is machine-dependent. -binaryIntEncoder :: Int -> BinaryField -binaryIntEncoder - | haskellIntOid == int8Oid = NotNull . PBA.encodeInt64BE . fromIntegral - | haskellIntOid == int4Oid = NotNull . PBA.encodeInt32BE . fromIntegral - | otherwise = NotNull . PBA.encodeInt16BE . fromIntegral - --- | Big-Endian binary decoder for Haskell's various IntXX types. -binaryIntDecoder :: forall a. (Integral a, Bounded a) => Oid -> PinnedByteArray -> Either String a -binaryIntDecoder typOid = \bs -> - if doesFit - then intDecoder bs - else Left $ "Chosen integral type does not fit every value for PG type with OID " ++ show typOid - where - maxBoundPgType :: Integer - intDecoder :: PinnedByteArray -> Either String a - (maxBoundPgType, intDecoder) - | typOid == int8Oid = (fromIntegral $ maxBound @Int64, fmap fromIntegral . PBA.decodeInt64BE 0) - | typOid == int4Oid = (fromIntegral $ maxBound @Int32, fmap fromIntegral . PBA.decodeInt32BE 0) - | typOid == int2Oid = (fromIntegral $ maxBound @Int16, fmap fromIntegral . PBA.decodeInt16BE 0) - | otherwise = error "Bug in Hpgsql. Decoding binary integral type not an int2, int4 or int8" - doesFit = maxBoundPgType <= fromIntegral (maxBound @a) - -binaryFloat4Decoder :: PinnedByteArray -> Float -binaryFloat4Decoder = castWord32ToFloat . either error id . PBA.decodeWord32BE 0 - -binaryFloat8Decoder :: PinnedByteArray -> Double -binaryFloat8Decoder = castWord64ToDouble . either error id . PBA.decodeWord64BE 0 - -parsePgType :: String -> [Oid] -> (PinnedByteArray -> Either String a) -> FieldDecoder a -parsePgType !typeName !requiredTypeOids !fieldValueDecoder = - FieldDecoder - { fieldValueDecoder = \_oid -> fieldValueDecoder, - decodesSqlNullTo = Left $ "Cannot decode SQL null as the Haskell " ++ typeName ++ " type. Use a `Maybe " ++ show typeName ++ "`", - allowedPgTypes = (`elem` requiredTypeOids) . fieldTypeOid - } - -instance FromPgField () where - {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = \_oid -> \bs -> - if PBA.length bs == 0 - then Right () - else - Left $ "Invalid value for postgres void type", - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell () type. Use a `Maybe ()`", - allowedPgTypes = (== voidOid) . fieldTypeOid - } - -instance FromPgField Int where - {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> - let !decode = binaryIntDecoder oid - in \bs -> decode bs, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int type. Use a `Maybe Int`", - allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid - } - - {-# INLINE inlinedConstFieldDecoder #-} - inlinedConstFieldDecoder = Just $ do - fieldLen <- Parser.takeInt32BE - -- TODO: We're assuming `Int` is always 64 bits, so 64bit CPUs? Is that ok? - -- TODO: Is there a way to optimistically assume <=4 bytes and use our custom new parser? - case fieldLen of - 4 -> Just . fromIntegral <$> Parser.takeInt32BE - (-1) -> pure Nothing - 8 -> Just . fromIntegral <$> Parser.takeInt64BE - 2 -> Just . fromIntegral <$> Parser.takeInt16BE - _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" - -instance FromPgField Int16 where - {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = - let !decode = binaryIntDecoder int2Oid - in const decode, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int16 type. Use a `Maybe Int16`", - allowedPgTypes = (== int2Oid) . fieldTypeOid - } - -instance FromPgField Int32 where - {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> binaryIntDecoder oid, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int32 type. Use a `Maybe Int32`", - allowedPgTypes = (`elem` [int2Oid, int4Oid]) . fieldTypeOid - } - {-# INLINE inlinedConstFieldDecoder #-} - inlinedConstFieldDecoder = Just $ do - fieldLen <- Parser.takeInt32BE - case fieldLen of - 4 -> Just <$> Parser.takeInt32BE - (-1) -> pure Nothing - 2 -> Just . fromIntegral <$> Parser.takeInt16BE - _ -> fail "Trying to decode PG int4 but it's not 2 or 4 bytes long" - -instance FromPgField Int64 where - {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> binaryIntDecoder oid, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int64 type. Use a `Maybe Int64`", - allowedPgTypes = (`elem` [int2Oid, int4Oid, int8Oid]) . fieldTypeOid - } - {-# INLINE inlinedConstFieldDecoder #-} - inlinedConstFieldDecoder = Just $ do - fieldLen <- Parser.takeInt32BE - case fieldLen of - 8 -> Just <$> Parser.takeInt64BE - 4 -> Just . fromIntegral <$> Parser.takeInt32BE - (-1) -> pure Nothing - 2 -> Just . fromIntegral <$> Parser.takeInt16BE - _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" - -instance FromPgField Integer where - {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> - let !decodeInt = binaryIntDecoder @Int64 oid - in if oid /= numericOid - then fmap fromIntegral <$> decodeInt - else \bs -> case Parser.parseOnly (scientificDecoder True <* Parser.endOfInput) bs of - Parser.ParseOk sci -> case floatingOrInteger @Double @Integer sci of - Right i -> Right i - Left _ -> Left "Internal error in Hpgsql. Scientific to Integer conversion failed" - Parser.ParseFail err -> Left err, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Integer type. Use a `Maybe Integer`", - allowedPgTypes = (`elem` [int8Oid, numericOid, int4Oid, int2Oid]) . fieldTypeOid - } - -instance FromPgField Oid where - {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = \_ -> \case - -- Oids are just int4 - bs -> Oid <$> binaryIntDecoder int4Oid bs, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Oid type. Use a `Maybe Oid`", - allowedPgTypes = (== oidOid) . fieldTypeOid - } - -instance FromPgField Float where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Float" [float4Oid] $ Right . binaryFloat4Decoder - - {-# INLINE inlinedConstFieldDecoder #-} - inlinedConstFieldDecoder = Just Parser.takeFloatBEWithFieldLength - -{-# INLINE doubleRowDecoder #-} -doubleRowDecoder :: Parser.Parser (Maybe Double) -doubleRowDecoder = do - len <- Parser.takeInt32BE - case len of - 8 -> Just <$> Parser.takeDoubleBE - 4 -> Just . float2Double <$> Parser.takeFloatBE - _ -> pure Nothing - -instance FromPgField Double where - {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> - let decoder - | oid == float8Oid = binaryFloat8Decoder - | otherwise = float2Double . binaryFloat4Decoder - in Right . decoder, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`", - allowedPgTypes = (`elem` [float8Oid, float4Oid]) . fieldTypeOid - } - - {-# INLINE inlinedConstFieldDecoder #-} - inlinedConstFieldDecoder = Just doubleRowDecoder - --- | Allows you to specify a type (and other checks, possibly) for a `FieldDecoder`. --- This can be useful to ensure you're not accidentally decoding a different type. --- --- > data MyEnum = Val1 | Val2 | Val3 --- > myEnumFieldDecoderWithTypeInfoCheck :: FieldDecoder MyEnum --- > myEnumFieldDecoderWithTypeInfoCheck = --- > let convert = \case --- > "val1" -> Val1 --- > "val2" -> Val2 --- > "val3" -> Val3 --- > _ -> error "Invalid value for MyEnum" --- > in typeFieldDecoder --- > (typeMustBeNamed "my_enum") --- > $ convert <$> rawBytesFieldDecoder --- --- This will work unless you use non-default flags in your connection options. -typeFieldDecoder :: (FieldInfo -> Bool) -> FieldDecoder a -> FieldDecoder a -typeFieldDecoder fieldCheck dec = dec {allowedPgTypes = fieldCheck} - -typeMustBeNamed :: Text -> (FieldInfo -> Bool) -typeMustBeNamed typName = \fieldInfo -> - (typeName <$> lookupTypeByOid fieldInfo.fieldTypeOid fieldInfo.encodingContext.typeInfoCache) == Just typName - -{-# INLINE scientificDecoder #-} -scientificDecoder :: Bool -> Parser.Parser Scientific -scientificDecoder mustBeInteger = do - ndigits <- Parser.takeInt16BE - weight <- Parser.takeInt16BE - sign <- Parser.takeInt16BE -- 0x0000 is positive, 0x4000 is negative, 0xC000 is NAN, 0xD000 is Positive Infinity, 0xF000 is Negative Infinity - unless (sign == 0x0000 || sign == 0x4000) $ fail "NaN, positive or negative infinities cannot be decoded into Integer or Scientific" - !dscale <- Parser.takeInt16BE - when (mustBeInteger && dscale /= 0) $ fail "Decoding into `Integer` requires explicit casting with `numeric(X,0)` to force integral values" - valueAbs <- parseAndMult ndigits (fromIntegral weight * 4) 0 - pure $ (if sign == 0x0000 then 1 else (-1)) * valueAbs - where - parseAndMult :: Int16 -> Int -> Scientific -> Parser.Parser Scientific - parseAndMult 0 _ !val = pure val - parseAndMult !ndigitsLeft !currexpon !val = do - !digit <- fromIntegral <$> Parser.takeInt16BE - parseAndMult (ndigitsLeft - 1) (currexpon - 4) (val + scientific digit currexpon) - -{-# INLINE numericRowParser #-} -numericRowParser :: Parser.Parser (Maybe Scientific) -numericRowParser = do - fieldLen <- Parser.takeInt32BE - case fieldLen of - (-1) -> pure Nothing - _ -> Just <$> scientificDecoder False - -instance FromPgField Scientific where - -- See https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/numeric.c#L1163 - {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - if fieldTypeOid /= numericOid - then - let intdec = binaryIntDecoder @Int64 fieldTypeOid - in \bs -> flip scientific 0 . fromIntegral <$> intdec bs - else \case - bs -> - -- TODO: There is loss converting from Float/Double to Scientific, but it might be quite small, so should we accept - -- float4Oid and float8Oid here? - case Parser.parseOnly (scientificDecoder False <* Parser.endOfInput) bs of - Parser.ParseOk sci -> Right sci - Parser.ParseFail err -> Left err, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`", - allowedPgTypes = (`elem` [numericOid, int2Oid, int4Oid, int8Oid]) . fieldTypeOid - } - {-# INLINE notConstFieldDecoder #-} - notConstFieldDecoder = - let !int64RowDec = fromMaybe (error "Bug in HPgsql: Int64 does not have an inlinedConstFieldDecoder") $ inlinedConstFieldDecoder @Int64 - in \singleColInfo -> - if singleColInfo.fieldTypeOid /= numericOid - then fmap (flip scientific 0 . fromIntegral) <$> int64RowDec - else numericRowParser - -instance FromPgField (Ratio Integer) where - {-# INLINE fieldDecoder #-} - fieldDecoder = toRational <$> fieldDecoder @Scientific - -binaryTrue :: PinnedByteArray -binaryTrue = PBA.fromByteString $ PBA.encodePgBoolean True - -{-# INLINE boolRowDecoder #-} -boolRowDecoder :: Parser.Parser (Maybe Bool) -boolRowDecoder = fmap (== 1) <$> Parser.parsePgFieldWithAtMost4Bytes PBA.TypeSize1 - -instance FromPgField Bool where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Bool" [boolOid] $ \bs -> Right $ bs == binaryTrue - - {-# INLINE inlinedConstFieldDecoder #-} - inlinedConstFieldDecoder = Just boolRowDecoder - -instance FromPgField Char where - {-# INLINE fieldDecoder #-} - fieldDecoder = - let textParser = fieldValueDecoder (fieldDecoder @Text) - in FieldDecoder - { fieldValueDecoder = \colInfo@FieldInfo {fieldTypeOid = oid} -> - let !decodeText = textParser colInfo - in \bs -> - if oid == charOid - then Right $ BSC.head $ PBA.toByteString bs - else case decodeText bs of - Left err -> Left err - Right t -> if Text.length t > 1 then Left "Cannot parse text with more than one character into a Haskell Char type." else Right (Text.head t), - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Char type. Use a `Maybe Char`", - -- TODO: All the varchar types? - allowedPgTypes = (`elem` [charOid, textOid]) . fieldTypeOid - } - -instance FromPgField ByteString where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "byteString" [byteaOid] (Right . PBA.toByteString) - -instance FromPgField LBS.ByteString where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "ByteString" [byteaOid] $ (Right . LBS.fromStrict . PBA.toByteString) - -{-# INLINE textDecoder #-} -textDecoder :: Parser.Parser (Maybe Text) -textDecoder = do - len <- Parser.takeInt32BE - if len >= 0 - -- TODO: Use some faster unsafeDecodeUtf8 function? - then Just . decodeUtf8 . PBA.toByteString <$> Parser.take (fromIntegral len) - else pure Nothing - -instance FromPgField Text where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ decodeUtf8 $ PBA.toByteString bs - - {-# INLINE inlinedConstFieldDecoder #-} - inlinedConstFieldDecoder = Just textDecoder - -instance FromPgField LT.Text where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ LT.fromStrict $ decodeUtf8 $ PBA.toByteString bs - -instance FromPgField String where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "String" [textOid, varcharOid, nameOid] $ \bs -> Right $ Text.unpack $ decodeUtf8 $ PBA.toByteString bs - --- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default --- connection option). -instance FromPgField (CI Text) where - {-# INLINE fieldDecoder #-} - fieldDecoder = typeFieldDecoder (typeMustBeNamed "citext") $ CI.mk <$> fieldDecoder - --- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default --- connection option). -instance FromPgField (CI LT.Text) where - {-# INLINE fieldDecoder #-} - fieldDecoder = typeFieldDecoder (typeMustBeNamed "citext") $ CI.mk <$> fieldDecoder - --- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default --- connection option). -instance FromPgField (CI String) where - {-# INLINE fieldDecoder #-} - fieldDecoder = typeFieldDecoder (typeMustBeNamed "citext") $ CI.mk <$> fieldDecoder - -{-# INLINE utcTimeRowDecoder #-} -utcTimeRowDecoder :: Parser.Parser (Maybe UTCTime) -utcTimeRowDecoder = do - len <- Parser.takeInt32BE - case len of - 8 -> do - totalusecs <- Parser.takeInt64BE - let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day - parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - pure $ Just $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - _ -> pure Nothing - -instance FromPgField UTCTime where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "UTCTime" [timestamptzOid] $ \case - bs -> do - -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- PBA.decodeInt64BE 0 bs - let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day - parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - Right $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - - {-# INLINE inlinedConstFieldDecoder #-} - inlinedConstFieldDecoder = Just utcTimeRowDecoder - -instance FromPgField (Unbounded UTCTime) where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Unbounded UTCTime" [timestamptzOid] $ \case - bs -> do - -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- PBA.decodeInt64BE 0 bs - Right $ - if totalusecs == minBound - then NegInfinity - else - if totalusecs == maxBound - then PosInfinity - else - let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day - parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - in Finite $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - -instance FromPgField ZonedTime where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "ZonedTime" [timestamptzOid] $ \case - bs -> do - -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- PBA.decodeInt64BE 0 bs - let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day - parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - Right $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - -instance FromPgField (Unbounded ZonedTime) where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Unbounded ZonedTime" [timestamptzOid] $ \case - bs -> do - -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- PBA.decodeInt64BE 0 bs - Right $ - if totalusecs == minBound - then NegInfinity - else - if totalusecs == maxBound - then PosInfinity - else - let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day - parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - in Finite $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - -instance FromPgField LocalTime where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "LocalTime" [timestampOid] $ \case - bs -> do - totalusecs <- PBA.decodeInt64BE 0 bs - let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day - parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - Right $ LocalTime parsedDate (timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - -instance FromPgField TimeOfDay where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "TimeOfDay" [timeOid] $ \case - bs -> do - usecs <- PBA.decodeInt64BE 0 bs - Right $ timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral usecs * 1_000_000 - -{-# INLINE dayRowDecoder #-} -dayRowDecoder :: Parser.Parser (Maybe Day) -dayRowDecoder = - let int32ToDay (i32 :: Int32) = let jd = fromIntegral i32 :: Integer in addJulianDurationClip (CalendarDiffDays 0 (jd - 13)) $ fromJulian 2000 01 01 - in fmap int32ToDay <$> Parser.takeInt32BEWithFieldLength - -instance FromPgField Day where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Day" [dateOid] $ \case - bs -> do - -- There is a very specific conversion function for these, which I poorly translated to Haskell - -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 - -- But I found a simpler way to do this. Let's see if it works in our property based tests - jd <- PBA.decodeInt32BE 0 bs - Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 - - {-# INLINE inlinedConstFieldDecoder #-} - inlinedConstFieldDecoder = Just dayRowDecoder - -instance FromPgField (Unbounded Day) where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Unbounded Day" [dateOid] $ \case - bs -> do - -- There is a very specific conversion function for these, which I poorly translated to Haskell - -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 - -- But I found a simpler way to do this. Let's see if it works in our property based tests - jd <- PBA.decodeInt32BE 0 bs - Right $ - if jd == minBound - then NegInfinity - else - if jd == maxBound - then PosInfinity - else - Finite $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 - -instance FromPgField CalendarDiffTime where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "CalendarDiffTime " [intervalOid] $ \bs -> do - nMicrosecs <- PBA.decodeInt64BE 0 bs - nDays <- PBA.decodeInt32BE 8 bs - nMonths <- PBA.decodeInt32BE 12 bs - Right $ CalendarDiffTime {ctMonths = fromIntegral nMonths, ctTime = secondsToNominalDiffTime (fromIntegral nDays * 86400) + realToFrac (picosecondsToDiffTime (fromIntegral nMicrosecs * 1_000_000))} - -instance FromPgField UUID where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "UUID" [uuidOid] $ \case - bs -> case UUID.fromByteString (LBS.fromStrict $ PBA.toByteString bs) of - Just uuid -> Right uuid - Nothing -> Left "Bug in Hpgsql: UUID field could not be decoded" - -instance FromPgField Aeson.Value where - {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = - \FieldInfo {fieldTypeOid} -> - let -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in \case - bs -> case Aeson.decodeStrict $ fixJsonb (PBA.toByteString bs) of - Just d -> Right d - Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls", - allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid - } - --- | A FieldDecoder that accepts and decodes SQL NULLs into `Nothing` values --- for a given decoder. -nullableField :: FieldDecoder a -> FieldDecoder (Maybe a) -nullableField FieldDecoder {..} = - FieldDecoder - { fieldValueDecoder = \oid -> - let origFieldValueParser = fieldValueDecoder oid - in \bs -> Just <$> origFieldValueParser bs, - decodesSqlNullTo = Right Nothing, - allowedPgTypes - } - -instance (FromPgField a) => FromPgField (Maybe a) where - {-# INLINE fieldDecoder #-} - fieldDecoder = nullableField fieldDecoder - - {-# INLINE notConstFieldDecoder #-} - notConstFieldDecoder finfo = do - mv <- notConstFieldDecoder @a finfo - case mv of - Nothing -> pure Nothing - jv -> pure $ Just jv - - {-# INLINE inlinedConstFieldDecoder #-} - -- \| For types where there is a fast way to decode fields+values - -- without knowing the OID of the value in the query (of course, the - -- possible OIDs are still limited by the FieldDecoder's allowed types), - -- this can help provide a significant boost to inlined row decoders. - -- Define as `Nothing` if this isn't possible. - -- inlinedConstFieldDecoder :: Maybe (Parser.Parser (Maybe (Maybe a))) - inlinedConstFieldDecoder = case inlinedConstFieldDecoder @a of - Nothing -> Nothing - Just p -> Just $ do - mv <- p - case mv of - Nothing -> pure Nothing -- Must return Nothing for SQL Nulls - jv -> pure $ Just jv - -allowOnlyArrayTypes :: FieldInfo -> Bool -allowOnlyArrayTypes fieldInfo = - -- TODO: We could check the elemTypeOid too, but maybe later - case lookupTypeByOid fieldInfo.fieldTypeOid fieldInfo.encodingContext.typeInfoCache of - Just (TypeInfo {typeDetails = ArrayType _}) -> True - Nothing -> True -- Assume user knows what they're doing - Just _ -> False -- Definitely not an array - -instance forall a. (FromPgField a) => FromPgField (Vector a) where - fieldDecoder = arrayField Vector.replicateM fieldDecoder - -instance {-# OVERLAPPING #-} forall a. (FromPgField a) => FromPgField (Vector (Vector a)) where - -- From https://github.com/postgres/postgres/blob/5941946d0934b9eccb0d5bfebd40b155249a0130/src/backend/utils/adt/arrayfuncs.c#L1548 - fieldDecoder = - FieldDecoder - { fieldValueDecoder = \colInfo -> - let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput - in \bs -> case Parser.parseOnly arrayFieldDecoder bs of - Parser.ParseOk v -> Right v - Parser.ParseFail err -> Left err, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell (Vector (Vector a)) type. Use a `Maybe (Vector (Vector a))`", - allowedPgTypes = allowOnlyArrayTypes - } - where - !elementParser = fieldDecoder @a - arrayParser :: EncodingContext -> Parser.Parser (Vector (Vector a)) - arrayParser encodingContext = do - !ndim <- Parser.takeInt32BE - !_hasNull <- Parser.takeInt32BE - !elementTypeOid :: Oid <- Oid . fromIntegral <$> Parser.takeInt32BE - let !elementColInfo = FieldInfo elementTypeOid Nothing encodingContext - when (ndim /= 2) $ fail $ "TODO: No support for " ++ show ndim ++ "-dimensional arrays in Hpgsql. Got array with ndim=" ++ show ndim - unless (elementParser.allowedPgTypes elementColInfo) $ fail $ "Array contains elements of type OID " ++ show elementTypeOid ++ " but decoder does not handle that type" - numRows <- do - !dim_i :: Int <- fromIntegral <$> Parser.takeInt32BE - !_lb_i <- Parser.takeInt32BE - pure dim_i - lengthEachRow <- do - !dim_i :: Int <- fromIntegral <$> Parser.takeInt32BE - !_lb_i <- Parser.takeInt32BE - pure dim_i - - Vector.replicateM numRows $ do - Vector.replicateM lengthEachRow $ - do - size :: Int <- fromIntegral <$> Parser.takeInt32BE - if size == (-1) - then case elementParser.decodesSqlNullTo of - Left err -> fail err - Right v -> pure v - else do - elementBs <- Parser.take size - case elementParser.fieldValueDecoder elementColInfo elementBs of - Left err -> fail $ "Error parsing array element: " ++ show err - Right el -> pure el - -{-# INLINE genericFromPgRow #-} - --- | Derives `FromPgRow` generically. -genericFromPgRow :: forall a. (Generic a, ProductTypeDecoder (Rep a)) => RowDecoder a -genericFromPgRow = to <$> genRowDecoder @(Rep a) - -class ProductTypeDecoder f where - genRowDecoder :: RowDecoder (f a) - -instance (ProductTypeDecoder a, ProductTypeDecoder b) => ProductTypeDecoder (a :*: b) where - {-# INLINE genRowDecoder #-} - genRowDecoder = (:*:) <$> genRowDecoder <*> genRowDecoder - -instance (ProductTypeDecoder f) => ProductTypeDecoder (M1 a c f) where - {-# INLINE genRowDecoder #-} - genRowDecoder = M1 <$> genRowDecoder - -instance (FromPgField a) => ProductTypeDecoder (K1 r a) where - {-# INLINE genRowDecoder #-} - -- coercing instead of fmap reduces memory usage, apparently - -- by reducing (unnecessary) closures in the final row decoder, - -- as per looking at GHC Core - genRowDecoder = coerce $ notInlinedSingleFieldRowDecoder @a - -genericToPgRow :: forall a. (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a -genericToPgRow = contramap from genRowEncoder - -class ProductTypeEncoder f where - genRowEncoder :: RowEncoder (f a) - -instance (ProductTypeEncoder a, ProductTypeEncoder b) => ProductTypeEncoder (a :*: b) where - genRowEncoder = divide (\(a :*: b) -> (a, b)) genRowEncoder genRowEncoder - -instance (ProductTypeEncoder f) => ProductTypeEncoder (M1 i c f) where - genRowEncoder = contramap unM1 genRowEncoder - -instance (ToPgField a) => ProductTypeEncoder (K1 r a) where - genRowEncoder = contramap unK1 singleFieldRowEncoder - --- | For the very common case of a Haskell enum matching a custom postgres enum type --- that has its values all as lower case strings, this newtype can help you derive --- instances as such: --- --- > data Mood = Sad | Ok | Happy --- > deriving stock (Generic) --- > deriving (FromPgField, ToPgField) via (LowerCasedPgEnum Mood) --- --- And this would match the Postgres equivalent: --- --- > CREATE TYPE mood AS ENUM ('sad', 'ok', 'happy'); --- --- If you run into PostgreSQL type inference problems with this, you can --- write instances manually with 'genericEnumFieldDecoder', 'genericEnumFieldEncoder', --- 'typeFieldEncoder', and 'typeFieldDecoder'. -newtype LowerCasedPgEnum a = LowerCasedPgEnum a - -instance (Generic a, EnumDecoder (Rep a)) => FromPgField (LowerCasedPgEnum a) where - fieldDecoder = LowerCasedPgEnum <$> genericEnumFieldDecoder LT.toLower - -instance (Generic a, EnumEncoder (Rep a)) => ToPgField (LowerCasedPgEnum a) where - fieldEncoder = untypedFieldEncoder $ \_encCtx -> \(LowerCasedPgEnum v) -> NotNull $ genericEnumFieldEncoder Text.toLower v - --- | One of the functions behind 'LowerCasedPgEnum', but you can decide --- how to map your type's constructor names arbitrarily, which can be --- useful if you're not using lowercase values in your postgres enums. -genericEnumFieldDecoder :: - forall a. - (Generic a, EnumDecoder (Rep a)) => - -- | A function that takes in the Haskell constructor name and returns the textual representation of the enum in postgres - (LT.Text -> LT.Text) -> - FieldDecoder a -genericEnumFieldDecoder nameTransform = fromMaybe (error $ "Invalid enum value. Not one of " ++ show (Map.keys allValuesMap)) . flip Map.lookup allValuesMap <$> rawBytesFieldDecoder - where - -- TODO: Vector of pointers to ByteStrings for a bit more memory locality? Does it make a perf difference? - allValuesMap = Map.mapKeys (LBS.toStrict . LT.encodeUtf8 . nameTransform) $ fmap to genEnumDecoder - -class EnumDecoder f where - -- | Returns the textual representation and constructed object for every possible - -- value of the enum. - genEnumDecoder :: Map LT.Text (f a) - -instance (EnumDecoder a, EnumDecoder b) => EnumDecoder (a :+: b) where - genEnumDecoder = (L1 <$> genEnumDecoder) `Map.union` (R1 <$> genEnumDecoder) - -instance (EnumDecoder f) => EnumDecoder (M1 D c f) where - genEnumDecoder = M1 <$> genEnumDecoder - --- U1 is "Unit"-type, that is: no value in the constructor, AKA "pure enum". -instance (KnownSymbol ctorName) => EnumDecoder (M1 C ('MetaCons ctorName ctorFixity 'False) U1) where - genEnumDecoder = Map.singleton (LT.pack $ symbolVal (Proxy @ctorName)) (M1 U1) - --- | One of the functions behind 'LowerCasedPgEnum', but you can decide --- how to map your type's constructor names arbitrarily, which can be --- useful if you're not using lowercase values in your postgres enums. -genericEnumFieldEncoder :: - forall a. - (Generic a, EnumEncoder (Rep a)) => - -- | A function that takes in the Haskell constructor name and returns the textual representation of the enum in postgres - (Text -> Text) -> - a -> - ByteString -genericEnumFieldEncoder nameTransform = encodeUtf8 . nameTransform . genEnumEncoder . from - -class EnumEncoder f where - -- | Returns the textual representation of an enum value's constructor. - genEnumEncoder :: f a -> Text - -instance (EnumEncoder a, EnumEncoder b) => EnumEncoder (a :+: b) where - genEnumEncoder (L1 x) = genEnumEncoder x - genEnumEncoder (R1 x) = genEnumEncoder x - -instance (EnumEncoder f) => EnumEncoder (M1 D c f) where - genEnumEncoder (M1 x) = genEnumEncoder x - --- U1 is "Unit"-type, that is: no value in the constructor, AKA "pure enum". -instance (KnownSymbol ctorName) => EnumEncoder (M1 C ('MetaCons ctorName ctorFixity 'False) U1) where - genEnumEncoder _ = Text.pack $ symbolVal (Proxy @ctorName) - --- | Returns a `FieldEncoder` that is sent without a type OID in queries. --- This means postgres will try to infer the type of these arguments. --- Check `typedFieldEncoder` if you're interested in encoding your custom types, --- you probably don't need this. -untypedFieldEncoder :: (EncodingContext -> a -> BinaryField) -> FieldEncoder a -untypedFieldEncoder enc = FieldEncoder {toTypeOid = \_ -> Nothing, toPgField = enc} - --- | A decoder that accepts any PG type and returns the object's --- postgres' binary representation as a ByteString. -rawBytesFieldDecoder :: FieldDecoder ByteString -rawBytesFieldDecoder = - FieldDecoder - { fieldValueDecoder = \_oid -> \case - bs -> Right $ PBA.toByteString bs, - decodesSqlNullTo = Left "Cannot decode SQL null as the `rawBytesFieldDecoder`.", - allowedPgTypes = const True - } - --- | Returns a field-encoding function for a vector-like Foldable (e.g. Lists and Vector itself). -toPgVectorField :: forall f a. (Foldable f, ToPgField a) => EncodingContext -> f a -> BinaryField -toPgVectorField encCtx = - let fe = fieldEncoder @a - encodeElement el = Builder.binaryField $ fe.toPgField encCtx el - Oid elemOid = fromMaybe (Oid 0) (fe.toTypeOid encCtx) - in \vec -> - let ndim = Builder.int32BE 1 - -- Postgres seems to build the "has_nulls" flag itself in the ReadArrayBinary function at https://github.com/postgres/postgres/blob/aa7f9493a02f5981c09b924323f0e7a58a32f2ed/src/backend/utils/adt/arrayfuncs.c#L1429, so we can just set it to 0 - hasNull = Builder.byteString $ PBA.encodeInt32BE 0 - -- hasNull = Builder.byteString $ PBA.encodeInt32BE (if Vector.any (\e -> toPgField e == Nothing) vec then 1 else 0) - elemOidBs = Builder.byteString $ PBA.encodeInt32BE elemOid - lb1 = Builder.byteString $ PBA.encodeInt32BE 1 - (Sum len, encodedElements) = foldMap (\el -> (Sum 1, encodeElement el)) vec - dim1 = Builder.byteString $ PBA.encodeInt32BE len - fullBs = ndim <> hasNull <> elemOidBs <> dim1 <> lb1 <> encodedElements - in NotNull (Builder.toStrictByteString fullBs) - --- | A FieldDecoder that accepts and decodes Postgres arrays. -arrayField :: forall a f. (Monoid (f a)) => (forall m. (Monad m) => Int -> m a -> m (f a)) -> FieldDecoder a -> FieldDecoder (f a) -arrayField !replicateFunction !elementParser = - -- From https://github.com/postgres/postgres/blob/5941946d0934b9eccb0d5bfebd40b155249a0130/src/backend/utils/adt/arrayfuncs.c#L1548 - FieldDecoder - { fieldValueDecoder = \colInfo -> - let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput - in \bs -> case Parser.parseOnly arrayFieldDecoder bs of - Parser.ParseOk v -> Right v - Parser.ParseFail err -> Left err, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Vector type. Use a `Maybe (Vector a)`", - allowedPgTypes = allowOnlyArrayTypes - } - where - arrayParser :: EncodingContext -> Parser.Parser (f a) - arrayParser encodingContext = do - !ndim <- Parser.takeInt32BE - !_hasNull <- Parser.takeInt32BE - !elementTypeOid :: Oid <- Oid . fromIntegral <$> Parser.takeInt32BE - let !elementColInfo = FieldInfo elementTypeOid Nothing encodingContext - when (ndim > 1) $ fail $ "TODO: No support for multi-dimensional arrays in Hpgsql. Got array with ndim=" ++ show ndim - if ndim == 0 - then pure mempty - else do - !dim_i :: Int <- fromIntegral <$> Parser.takeInt32BE - !_lb_i <- Parser.takeInt32BE - unless (elementParser.allowedPgTypes elementColInfo) $ fail $ "Array contains elements of type OID " ++ show elementTypeOid ++ " but decoder does not handle that type" - replicateFunction dim_i $ do - size :: Int <- fromIntegral <$> Parser.takeInt32BE - if size == (-1) - then case elementParser.decodesSqlNullTo of - Left err -> fail err - Right v -> pure v - else do - elementBs <- Parser.take size - case elementParser.fieldValueDecoder elementColInfo elementBs of - Left err -> fail $ "Error parsing array element: " ++ show err - Right el -> pure el +import Hpgsql.Encoding.Internal diff --git a/hpgsql/src/Hpgsql/Encoding/Internal.hs b/hpgsql/src/Hpgsql/Encoding/Internal.hs new file mode 100644 index 0000000..82537c5 --- /dev/null +++ b/hpgsql/src/Hpgsql/Encoding/Internal.hs @@ -0,0 +1,1578 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Hpgsql.Encoding.Internal + ( -- * Decoding + FromPgField (..), + FieldDecoder (..), + FieldInfo (..), + FromPgRow (..), + RowDecoder (..), + singleField, + nullableField, + genericFromPgRow, + + -- * Encoding + ToPgField (..), + FieldEncoder (..), + ToPgRow (..), + RowEncoder (..), + EncodingContext (..), + genericToPgRow, + + -- * PostgreSQL enums + LowerCasedPgEnum (..), + genericEnumFieldDecoder, + genericEnumFieldEncoder, + + -- * PostgreSQL composite types + compositeTypeDecoder, + compositeTypeEncoder, + + -- * Driving PostgreSQL type inference + typeFieldDecoder, + typeFieldEncoder, + typeOidWithName, + typeMustBeNamed, + + -- * Others + rawBytesFieldDecoder, + untypedFieldEncoder, + toPgVectorField, + arrayField, + ) +where + +import Control.Monad (replicateM, unless, when) +import qualified Data.Aeson as Aeson +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as LBS +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.Coerce (coerce) +import Data.Fixed (divMod') +import Data.Functor.Contravariant (Contravariant (..)) +import Data.Int (Int16, Int32, Int64) +import qualified Data.List as List +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Monoid (Sum (..)) +import Data.Proxy (Proxy (..)) +import Data.Ratio (Ratio) +import Data.Scientific (Scientific (..), floatingOrInteger, scientific) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT +import Data.Time (CalendarDiffDays (..), CalendarDiffTime (..), Day, LocalTime (..), NominalDiffTime, TimeOfDay, UTCTime (..), ZonedTime, diffDays, diffTimeToPicoseconds, fromGregorian, picosecondsToDiffTime, secondsToNominalDiffTime, timeOfDayToTime, timeToTimeOfDay, utc, utcToZonedTime, zonedTimeToUTC) +import Data.Time.Calendar.Julian (addJulianDurationClip, fromJulian) +import Data.Tuple.Only (Only (..)) +import Data.UUID.Types (UUID) +import qualified Data.UUID.Types as UUID +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import GHC.Float (castWord32ToFloat, castWord64ToDouble, expt, float2Double) +import GHC.Generics (C, D, Generic (..), K1 (..), M1 (..), Meta (MetaCons), U1 (..), (:*:) (..), (:+:) (..)) +import GHC.TypeLits (KnownSymbol, TypeError, symbolVal) +import qualified GHC.TypeLits as TypeLits +import Hpgsql.Builder (BinaryField (..)) +import qualified Hpgsql.Builder as Builder +import Hpgsql.PinnedByteArray (PinnedByteArray) +import qualified Hpgsql.PinnedByteArray as PBA +import qualified Hpgsql.SimpleParser as Parser +import Hpgsql.Time (Unbounded (..)) +import Hpgsql.TypeInfo (EncodingContext (..), Oid (..), TypeDetails (..), TypeInfo (..), boolOid, byteaOid, charOid, dateOid, float4Oid, float8Oid, int2Oid, int4Oid, int8Oid, intervalOid, jsonOid, jsonbOid, lookupTypeByName, lookupTypeByOid, nameOid, numericOid, oidOid, textOid, timeOid, timestampOid, timestamptzOid, uuidOid, varcharOid, voidOid) + +data FieldInfo = FieldInfo + { fieldTypeOid :: !Oid, + -- | The column name from the query's result, if available. + fieldName :: !(Maybe Text), + -- | The EncodingContext as of the moment the query ran. + encodingContext :: !EncodingContext + } + +-- | A decoder for a single field/column. +data FieldDecoder a = FieldDecoder + { fieldValueDecoder :: FieldInfo -> PinnedByteArray -> Either String a, + decodesSqlNullTo :: Either String a, + allowedPgTypes :: FieldInfo -> Bool + } + deriving stock (Functor) + +-- | `f1 <> f2` produces a `FieldDecoder` that tries `f1` first, and if that fails it tries `f2`. +instance Semigroup (FieldDecoder a) where + dec1 <> dec2 = + FieldDecoder + { fieldValueDecoder = \cInfo -> + let f1 = dec1.fieldValueDecoder cInfo + f2 = dec2.fieldValueDecoder cInfo + in \mbs -> + let cand1 = if dec1.allowedPgTypes cInfo then f1 mbs else Left "Not first parser" + cand2 = if dec2.allowedPgTypes cInfo then f2 mbs else Left "Not second parser" + in cand1 <> cand2, + decodesSqlNullTo = dec1.decodesSqlNullTo <> dec2.decodesSqlNullTo, + allowedPgTypes = \cInfo -> dec1.allowedPgTypes cInfo || dec2.allowedPgTypes cInfo + } + +data RowDecoder a = RowDecoder + { fullRowDecoder :: [FieldInfo] -> Parser.Parser a, + -- | Returns the same colInfos with a boolean indicating if + -- the expected types match for each colInfo. + rowColumnsTypeCheck :: [FieldInfo] -> [(FieldInfo, Bool)], + numExpectedColumns :: !Int + } + deriving stock (Functor, Generic) + +instance Applicative RowDecoder where + pure v = RowDecoder (const $ pure v) (map (,True)) 0 + {-# INLINE (<*>) #-} -- This is crucial for performance. It makes our CPS Parser truly compile to CPS row decoders. + RowDecoder p1 tc1 nc1 <*> RowDecoder p2 tc2 nc2 = RowDecoder (\colTypes -> let (cols1, cols2) = List.splitAt nc1 colTypes in p1 cols1 <*> p2 cols2) (\colTypes -> let (cols1, cols2) = List.splitAt nc1 colTypes in tc1 cols1 ++ tc2 cols2) (nc1 + nc2) + +instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in Hpgsql because Hpgsql type-checks the result types of queries before having access to even the first data row. Use the Applicative class to write your instances or use the Monadic decoding variants.")) => Monad RowDecoder where + (>>=) = error "inaccessible bind in Monad RowDecoder instance" + +{-# INLINE singleField #-} +singleField :: FieldDecoder a -> RowDecoder a +singleField fdec = + -- This `case` is why we require `fieldAndValueDecoder` to decode + -- SQL NULL into `Nothing`: we do check decodesSqlNullTo. + let !valueForNull = case fdec.decodesSqlNullTo of + Left err -> fail err + Right v -> pure v + !typeCheck = fdec.allowedPgTypes + in RowDecoder + { fullRowDecoder = \case + [singleColInfo] -> + let decode = fdec.fieldValueDecoder singleColInfo + in do + lenNextCol <- fromIntegral <$> Parser.takeInt32BE + if lenNextCol >= 0 + then do + nextColBs <- Parser.take lenNextCol + case decode nextColBs of + Right v -> pure v + Left err -> fail err + else valueForNull + _ -> error "singleField expected a single column OID but got 0 or >1", + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, typeCheck singleColInfo)] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } + +class FromPgField a where + {-# MINIMAL fieldDecoder #-} + fieldDecoder :: FieldDecoder a + + -- | For types where there is a fast way to decode fields+values + -- without knowing the OID of the value in the query (of course, the + -- possible OIDs are still limited by the FieldDecoder's allowed types), + -- defining this can help provide a significant performance boost to inlined row decoders. + -- + -- Any implementation of this _must_ return a `Nothing` for a SQL NULL value, + -- regardless of what `FieldDecoder` would do with a SQL NULL. + -- + -- Define this as `Nothing` if implementing it isn't possible. + -- This isn't exposed to users yet, but we should recommend they add an INLINE pragma, + -- as the method's name suggests. + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder :: Maybe (Parser.Parser (Maybe a)) + inlinedConstFieldDecoder = Nothing + + -- | For types that can't implement `inlinedConstFieldDecoder` because they + -- need to know the value's OID for decoding, this is the next best thing: + -- also a specialized field+value decoder that can be faster than the + -- one derived from `fieldDecoder`. + -- + -- Any implementation of this _must_ return a `Nothing` for a SQL NULL value, + -- regardless of what `FieldDecoder` would do with a SQL NULL. + {-# INLINE notConstFieldDecoder #-} + notConstFieldDecoder :: FieldInfo -> Parser.Parser (Maybe a) + notConstFieldDecoder = + case inlinedConstFieldDecoder of + Nothing -> slowerParser + Just fd -> const fd + where + -- slowerParser takes a ByteString and passes it to the + -- field decoder. + slowerParser singleColInfo = do + len <- Parser.takeInt32BE + if len == (-1) + then pure Nothing + else do + bs <- Parser.take (fromIntegral len) + case fieldDecoder.fieldValueDecoder singleColInfo bs of + Left err -> fail err + Right v -> pure v + + -- | Semantically equivalent to `singleField fieldDecoder`, but for + -- most types it can provide a much faster `RowDecoder`. This doesn't + -- cause the same amount of size blowup that `inlinedSingleFieldRowDecoder` + -- does, but is also not as fast as that. + {-# NOINLINE notInlinedSingleFieldRowDecoder #-} + notInlinedSingleFieldRowDecoder :: RowDecoder a + notInlinedSingleFieldRowDecoder = inlinedSingleFieldRowDecoder + + -- | Semantically equivalent to `singleField fieldDecoder`, but for + -- most types it can provide a much faster `RowDecoder`. Beware that + -- using will produce more code in your row decoders, which can affect + -- compilation times and binary size. + {-# INLINE inlinedSingleFieldRowDecoder #-} + inlinedSingleFieldRowDecoder :: RowDecoder a + inlinedSingleFieldRowDecoder = case inlinedConstFieldDecoder @a of + -- This is a class method instead of a top-level function + -- because the GHC inliner behaves differently when it's a top-level + -- function, and benchmarks show this is faster. + Nothing -> + let !valueForNull = case (fieldDecoder @a).decodesSqlNullTo of + Left err -> fail err + Right v -> pure v + !typeCheck = (fieldDecoder @a).allowedPgTypes + in RowDecoder + { fullRowDecoder = \case + [singleColInfo] -> do + mv <- notConstFieldDecoder singleColInfo + case mv of + Nothing -> valueForNull + Just v -> pure v + _ -> error "singleField expected a single column OID but got 0 or >1", + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, typeCheck singleColInfo)] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } + Just p -> + -- The strictness and floating out of fieldDecoder-derived + -- values allows GHC to inline a lot more. For example, `valueForNull` + -- gets inlined to a `fail "Cannot decode SQL NULL ..."` for basic types + -- like `Int`. + let !valueForNull = case (fieldDecoder @a).decodesSqlNullTo of + Left err -> fail err + Right v -> pure v + !typeCheck = (fieldDecoder @a).allowedPgTypes + in RowDecoder + { fullRowDecoder = const $ do + mv <- p + case mv of + Nothing -> valueForNull + Just v -> pure v, + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, typeCheck singleColInfo)] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } + +class FromPgRow a where + rowDecoder :: RowDecoder a + default rowDecoder :: (Generic a, ProductTypeDecoder (Rep a)) => RowDecoder a + rowDecoder = genericFromPgRow + +-- | Allows you to create a @FieldDecoder@ for composite types. +-- For a type such as: +-- +-- > CREATE TYPE int_and_bool AS (numfield INT, boolfield BOOL); +-- +-- You can define a Haskell type as such: +-- +-- > data IntAndBool = IntAndBool Int Bool +-- > +-- > instance FromPgField IntAndBool where +-- > fieldDecoder = compositeTypeDecoder rowDecoder <&> \(i, b) -> IntAndBool i b +compositeTypeDecoder :: forall a. RowDecoder a -> FieldDecoder a +compositeTypeDecoder (RowDecoder {..}) = + FieldDecoder + { fieldValueDecoder = \compositeTypeOid -> + let !prs = parserForRecord compositeTypeOid.encodingContext <* Parser.endOfInput + in \bs -> + case Parser.parseOnly prs bs of + Parser.ParseOk v -> Right v + Parser.ParseFail err -> Left err, + decodesSqlNullTo = Left "Got NULL in composite type but it was not allowed", + allowedPgTypes = const True -- There's no way to enforce a custom type's OID. We only check if it's structurally the same in the parser (same subtypes in same order) + } + where + parserForRecord :: EncodingContext -> Parser.Parser a + parserForRecord encodingContext = do + -- From https://github.com/postgres/postgres/blob/50ba65e73325cf55fedb3e1f14673d816726923b/src/backend/utils/adt/rowtypes.c#L687 + -- we can see a composite type's binary representation consists of: number of columns (Int32) + for_each_column { OID (Int32) + size_or_minus_1 (Int32) + Bytes } + numCols <- fromIntegral <$> Parser.takeInt32BE + unless (numCols == numExpectedColumns) $ fail $ "Composite type has " ++ show numCols ++ " attributes but parser expected " ++ show numExpectedColumns + let mkColInfo oid = FieldInfo oid Nothing encodingContext + cols <- replicateM numCols $ do + !oid <- Oid . fromIntegral <$> Parser.takeInt32BE + (sizeBs, !size) <- Parser.match $ fromIntegral <$> Parser.takeInt32BE + !bs <- Parser.take (max 0 size) + pure (oid, PBA.fromStrict sizeBs <> PBA.fromStrict bs) + let typecheckedCols = rowColumnsTypeCheck (map (mkColInfo . fst) cols) + unless (all snd typecheckedCols) $ fail $ "Parser for composite found type OIDs " ++ show (map fst cols) ++ " but expected different" + case Parser.parseOnly (fullRowDecoder (map (mkColInfo . fst) cols) <* Parser.endOfInput) (PBA.toStrict $ mconcat $ map snd cols) of + Parser.ParseOk v -> pure v + Parser.ParseFail err -> error $ "Error decoding composite type: " ++ show err + +-- | Allows you to create a @FieldEncoder@ for composite types. +-- For a type such as: +-- +-- > CREATE TYPE int_and_bool AS (numfield INT, boolfield BOOL); +-- +-- You can define a Haskell type as such: +-- +-- > data IntAndBool = IntAndBool Int Bool +-- > +-- > instance ToPgField IntAndBool where +-- > fieldEncoder = typeFieldEncoder (typeOidWithName "int_and_bool") +-- > $ compositeTypeEncoder $ contramap (\(IntAndBool i b) -> (fromIntegral i :: Int32, b)) rowEncoder +compositeTypeEncoder :: forall a. RowEncoder a -> FieldEncoder a +compositeTypeEncoder rowEnc = + FieldEncoder + { toTypeOid = \_ -> Nothing, + toPgField = \encCtx -> \a -> + let fields = map (\f -> f encCtx) (rowEnc.toPgParams a) + numCols = Builder.int32BE (fromIntegral $ length fields) + encodeField (mOid, bf) = + let Oid oid = fromMaybe (Oid 0) mOid + in Builder.int32BE oid <> Builder.binaryField bf + in NotNull (Builder.toStrictByteString (numCols <> foldMap encodeField fields)) + } + +instance (FromPgField a) => FromPgRow (Only a) where + rowDecoder = Only <$> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b) => FromPgRow (a, b) where + rowDecoder = (,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b, FromPgField c) => FromPgRow (a, b, c) where + rowDecoder = (,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d) => FromPgRow (a, b, c, d) where + rowDecoder = (,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e) => FromPgRow (a, b, c, d, e) where + rowDecoder = (,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f) => FromPgRow (a, b, c, d, e, f) where + rowDecoder = (,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g) => FromPgRow (a, b, c, d, e, f, g) where + rowDecoder = (,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h) => FromPgRow (a, b, c, d, e, f, g, h) where + rowDecoder = (,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i) => FromPgRow (a, b, c, d, e, f, g, h, i) where + rowDecoder = (,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j) => FromPgRow (a, b, c, d, e, f, g, h, i, j) where + rowDecoder = (,,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k) where + rowDecoder = (,,,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k, FromPgField l) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k, l) where + rowDecoder = (,,,,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k, FromPgField l, FromPgField m) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k, l, m) where + rowDecoder = (,,,,,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +data FieldEncoder a = FieldEncoder + { toTypeOid :: !(EncodingContext -> Maybe Oid), + toPgField :: !(EncodingContext -> a -> BinaryField) + } + +instance Contravariant FieldEncoder where + contramap f fEnc = FieldEncoder {toTypeOid = fEnc.toTypeOid, toPgField = \encCtx -> let toF = fEnc.toPgField encCtx in \v -> toF (f v)} + +class ToPgField a where + fieldEncoder :: FieldEncoder a + +-- | Allows you to specify a type for a FieldEncoder. This can be useful to avoid +-- letting postgres infer types itself, which can cause errors. For example: +-- +-- > data MyEnum = Val1 | Val2 | Val3 +-- > myEnumFieldDecoderWithTypeInfoCheck :: FieldEncoder MyEnum +-- > myEnumFieldDecoderWithTypeInfoCheck = +-- > let convert = \case +-- > Val1 -> "val1" :: Text +-- > Val2 -> "val2" +-- > Val3 -> "val3" +-- > in typeFieldEncoder +-- > (typeOidWithName "my_enum") +-- > $ contramap convert fieldEncoder +-- +-- This will work unless you use non-default flags in your connection options. +typeFieldEncoder :: (EncodingContext -> Maybe Oid) -> FieldEncoder a -> FieldEncoder a +typeFieldEncoder ttoid enc = enc {toTypeOid = ttoid} + +typeOidWithName :: Text -> (EncodingContext -> Maybe Oid) +typeOidWithName typName = \encCtx -> typeOid <$> lookupTypeByName typName encCtx.typeInfoCache + +instance ToPgField Int where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just haskellIntOid, + toPgField = \_ -> binaryIntEncoder + } + +instance ToPgField Int16 where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just int2Oid, + toPgField = \_ -> \n -> NotNull $ PBA.encodeInt16BE n + } + +instance ToPgField Int32 where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just int4Oid, + toPgField = \_ -> \n -> NotNull $ PBA.encodeInt32BE n + } + +instance ToPgField Int64 where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just int8Oid, + toPgField = \_ -> \n -> NotNull $ PBA.encodeInt64BE n + } + +instance ToPgField Integer where + fieldEncoder = + let fe = fieldEncoder @Scientific + in FieldEncoder + { toTypeOid = \_ -> Just numericOid, + toPgField = \encCtx -> \n -> fe.toPgField encCtx (fromIntegral n) + } + +instance ToPgField (Ratio Integer) where + fieldEncoder = + let fe = fieldEncoder @Scientific + in FieldEncoder + { toTypeOid = \_ -> Just numericOid, + toPgField = \encCtx -> \r -> fe.toPgField encCtx (fromRational r) + } + +instance ToPgField Oid where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just oidOid, + toPgField = \_ -> \n -> NotNull $ PBA.encodeInt32BE $ fromIntegral n + } + +instance ToPgField Scientific where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just numericOid, + toPgField = \_ -> \n -> + let sign = PBA.encodeInt16BE $ if n >= 0 then 0 else 0x4000 + -- The number is coeff * 10^exp, but we want it in base-10000 so we convert it to + -- new_coeff * 10^new_exp with new_exp a multiple of 4 + base10000Expon = 4 * (base10Exponent n `div` 4) + base10000Coeff = coefficient n * expt 10 (base10Exponent n - base10000Expon) + ndigits, weight :: Int16 + digits :: ByteString + (ndigits, weight, digits) = calculateDigits 0 0 (abs base10000Coeff) "" + dscale = PBA.encodeInt16BE (abs $ fromIntegral base10000Expon) -- More than necessary, but safe? + in NotNull $ PBA.encodeInt16BE ndigits <> PBA.encodeInt16BE (weight - 1 + fromIntegral (base10000Expon `div` 4)) <> sign <> dscale <> digits + } + where + calculateDigits :: Int16 -> Int16 -> Integer -> BS.ByteString -> (Int16, Int16, BS.ByteString) + calculateDigits !ndigitsSoFar !weightSoFar 0 !encodedDigits = (ndigitsSoFar, weightSoFar, encodedDigits) + calculateDigits !ndigitsSoFar !weightSoFar !val !encodedDigits = + let (quotient, fromIntegral -> (rest :: Int16)) = val `divMod` 10000 + in calculateDigits + (ndigitsSoFar + 1) + (weightSoFar + 1) + quotient + (PBA.encodeInt16BE rest <> encodedDigits) + +instance ToPgField Float where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just float4Oid, + toPgField = \_ -> \n -> NotNull $ PBA.encodeFloat n + } + +instance ToPgField Double where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just float8Oid, + toPgField = \_ -> \n -> NotNull $ PBA.encodeDouble n + } + +instance ToPgField Bool where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just boolOid, + toPgField = \_ n -> NotNull $ PBA.encodePgBoolean n + } + +instance ToPgField Day where + -- PG Dates are Int32 number of days relative to 2000-01-01 + -- https://github.com/postgres/postgres/blob/master/src/include/datatype/timestamp.h#L235 + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just dateOid, + -- TODO: Catch integer overflow and do what? + toPgField = \_ d -> NotNull $ PBA.encodeInt32BE $ fromIntegral $ diffDays d (fromGregorian 2000 1 1) + } + +instance ToPgField (Unbounded Day) where + fieldEncoder = + let fe = fieldEncoder @Day + in FieldEncoder + { toTypeOid = fe.toTypeOid, + toPgField = \encCtx -> \case + NegInfinity -> NotNull $ PBA.encodeInt32BE minBound + Finite v -> fe.toPgField encCtx v + PosInfinity -> NotNull $ PBA.encodeInt32BE maxBound + } + +instance ToPgField CalendarDiffTime where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just intervalOid, + toPgField = \_ CalendarDiffTime {..} -> + let (days :: Int32, timeUnderOneDay) = ctTime `divMod'` 86_400 + in NotNull $ PBA.encodeInt64BE (round $ timeUnderOneDay * 1_000_000) <> PBA.encodeInt32BE days <> PBA.encodeInt32BE (fromIntegral ctMonths) + } + +instance ToPgField NominalDiffTime where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just intervalOid, + toPgField = \_ ndt -> + NotNull $ PBA.encodeInt64BE (round $ ndt * 1_000_000) <> PBA.encodeInt32BE 0 <> PBA.encodeInt32BE 0 + } + +instance ToPgField UTCTime where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just timestamptzOid, + -- TODO: Catch integer overflow and do what? + toPgField = \_ (UTCTime parsedDate timeinday) -> + let day :: Int64 = fromInteger $ parsedDate `diffDays` fromJulian 1999 12 19 + totalusecs :: Int64 = 86_400_000_000 * day + fromInteger (diffTimeToPicoseconds timeinday `div` 1_000_000) + in NotNull $ PBA.encodeInt64BE totalusecs + } + +instance ToPgField (Unbounded UTCTime) where + fieldEncoder = + let fe = fieldEncoder @UTCTime + in FieldEncoder + { toTypeOid = fe.toTypeOid, + toPgField = \encCtx -> \case + NegInfinity -> NotNull $ PBA.encodeInt64BE minBound + Finite v -> fe.toPgField encCtx v + PosInfinity -> NotNull $ PBA.encodeInt64BE maxBound + } + +instance ToPgField ZonedTime where + fieldEncoder = + let fe = fieldEncoder @UTCTime + in FieldEncoder + { toTypeOid = \_ -> Just timestamptzOid, + toPgField = \encCtx -> fe.toPgField encCtx . zonedTimeToUTC + } + +instance ToPgField (Unbounded ZonedTime) where + fieldEncoder = + let fe = fieldEncoder @ZonedTime + in FieldEncoder + { toTypeOid = fe.toTypeOid, + toPgField = \encCtx -> \case + NegInfinity -> NotNull $ PBA.encodeInt64BE minBound + Finite v -> fe.toPgField encCtx v + PosInfinity -> NotNull $ PBA.encodeInt64BE maxBound + } + +instance ToPgField LocalTime where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just timestampOid, + toPgField = \_ (LocalTime localDay localTimeOfDay) -> + let day :: Int64 = fromInteger $ localDay `diffDays` fromJulian 1999 12 19 + totalusecs :: Int64 = 86_400_000_000 * day + fromInteger (diffTimeToPicoseconds (timeOfDayToTime localTimeOfDay) `div` 1_000_000) + in NotNull $ PBA.encodeInt64BE totalusecs + } + +instance ToPgField TimeOfDay where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just timeOid, + toPgField = \_ tod -> + let usecs :: Int64 = fromInteger $ diffTimeToPicoseconds (timeOfDayToTime tod) `div` 1_000_000 + in NotNull $ PBA.encodeInt64BE usecs + } + +instance ToPgField Char where + fieldEncoder = + let fe = fieldEncoder @Text + in FieldEncoder + { toTypeOid = \_ -> Just textOid, + toPgField = \encCtx -> let !toTextField = fe.toPgField encCtx in \t -> toTextField $ Text.singleton t + } + +instance ToPgField ByteString where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just byteaOid, + toPgField = \_ -> \bs -> NotNull bs + } + +instance ToPgField LBS.ByteString where + fieldEncoder = + let fe = fieldEncoder @ByteString + in FieldEncoder + { toTypeOid = \_ -> Just byteaOid, + toPgField = \encCtx -> fe.toPgField encCtx . LBS.toStrict + } + +instance ToPgField Text where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just textOid, + toPgField = \_ -> \t -> + let bs = encodeUtf8 t + in NotNull bs + } + +instance ToPgField LT.Text where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just textOid, + toPgField = \_ -> \t -> + let bs = LBS.toStrict $ LT.encodeUtf8 t + in NotNull bs + } + +instance ToPgField String where + fieldEncoder = + let fe = fieldEncoder @Text + in FieldEncoder + { toTypeOid = \_ -> Just textOid, + toPgField = \encCtx -> fe.toPgField encCtx . Text.pack + } + +-- From https://hackage.haskell.org/package/case-insensitive-1.2.1.0/docs/Data-CaseInsensitive.html, +-- "Note that the FoldCase instance for ByteStrings is only guaranteed to be correct for ISO-8859-1 encoded strings!". +-- So we don't have those instances. + +-- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default +-- connection option). +instance ToPgField (CI Text) where + fieldEncoder = typeFieldEncoder (typeOidWithName "citext") $ contramap CI.original fieldEncoder + +-- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default +-- connection option). +instance ToPgField (CI LT.Text) where + fieldEncoder = typeFieldEncoder (typeOidWithName "citext") $ contramap CI.original fieldEncoder + +-- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default +-- connection option). +instance ToPgField (CI String) where + fieldEncoder = typeFieldEncoder (typeOidWithName "citext") $ contramap CI.original fieldEncoder + +instance ToPgField UUID where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just uuidOid, + toPgField = \_ -> NotNull . LBS.toStrict . UUID.toByteString + } + +instance ToPgField Aeson.Value where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just jsonbOid, + toPgField = \_ -> \v -> + let bs = BS.cons 1 (LBS.toStrict $ Aeson.encode v) + in NotNull bs + } + +instance (ToPgField a) => ToPgField (Maybe a) where + fieldEncoder = + let fe = fieldEncoder @a + in FieldEncoder + { toTypeOid = fe.toTypeOid, + toPgField = \encCtx -> \case + Nothing -> SqlNull + Just n -> fe.toPgField encCtx n + } + +instance (ToPgField a) => ToPgField (Vector a) where + fieldEncoder = + let fe = fieldEncoder @a + in FieldEncoder + { toTypeOid = \encodingContext -> do + -- Maybe monad + elOid <- fe.toTypeOid encodingContext + arrayTypInfo <- lookupTypeByOid elOid encodingContext.typeInfoCache + arrayTypInfo.oidOfArrayType, + toPgField = toPgVectorField + } + +data RowEncoder a = RowEncoder + { toPgParams :: !(a -> [EncodingContext -> (Maybe Oid, BinaryField)]), + toTypeOids :: !(Proxy a -> [EncodingContext -> Maybe Oid]), + -- | This produces bytes for Binary COPY FROM STDIN rows, which can increase performance + -- and reduce memory usage comparing to deriving these bytes from `toPgParams`. + -- The produced bytes should not contain the total number of fields in the + -- beginning. + toBinaryCopyBytes :: !(EncodingContext -> a -> Builder.Builder) + } + +instance Contravariant RowEncoder where + contramap f rec = RowEncoder (\v -> rec.toPgParams (f v)) (\_ -> rec.toTypeOids Proxy) (\encCtx -> let !toBytes = rec.toBinaryCopyBytes encCtx in \v -> toBytes (f v)) + +-- | These are from `Divisible`, but we don't currently pull in the extra dependency that has that. +divide :: (a -> (b, c)) -> RowEncoder b -> RowEncoder c -> RowEncoder a +divide d re1 re2 = + RowEncoder + { toPgParams = \a -> let (b, c) = d a in re1.toPgParams b ++ re2.toPgParams c, + toTypeOids = \_ -> re1.toTypeOids Proxy ++ re2.toTypeOids Proxy, + toBinaryCopyBytes = \encCtx -> + let !toBytes1 = re1.toBinaryCopyBytes encCtx + !toBytes2 = re2.toBinaryCopyBytes encCtx + in \a -> let (b, c) = d a in toBytes1 b <> toBytes2 c + } + +class ToPgRow a where + rowEncoder :: RowEncoder a + default rowEncoder :: (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a + rowEncoder = genericToPgRow + +instance ToPgRow () where + rowEncoder = RowEncoder (\_ -> []) (\_ -> []) (\_ -> \_ -> mempty) + +singleFieldRowEncoder :: forall a. (ToPgField a) => RowEncoder a +singleFieldRowEncoder = + let fe = fieldEncoder @a + in RowEncoder + { toPgParams = \a -> [\encodingContext -> (fe.toTypeOid encodingContext, fe.toPgField encodingContext a)], + toTypeOids = \_ -> [fe.toTypeOid], + toBinaryCopyBytes = \encCtx -> let !enc = fe.toPgField encCtx in \a -> Builder.binaryField $ enc a + } + +instance (ToPgField a) => ToPgRow (Only a) where + rowEncoder = contramap fromOnly singleFieldRowEncoder + +instance (ToPgField a, ToPgField b) => ToPgRow (a, b) where + rowEncoder = divide id singleFieldRowEncoder singleFieldRowEncoder + +instance (ToPgField a, ToPgField b, ToPgField c) => ToPgRow (a, b, c) where + rowEncoder = divide (\(a, b, c) -> ((a, b), c)) rowEncoder singleFieldRowEncoder + +instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d) => ToPgRow (a, b, c, d) where + rowEncoder = divide (\(a, b, c, d) -> ((a, b), (c, d))) rowEncoder rowEncoder + +instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e) => ToPgRow (a, b, c, d, e) where + rowEncoder = divide (\(a, b, c, d, e) -> ((a, b, c), (d, e))) rowEncoder rowEncoder + +instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f) => ToPgRow (a, b, c, d, e, f) where + rowEncoder = divide (\(a, b, c, d, e, f) -> ((a, b, c), (d, e, f))) rowEncoder rowEncoder + +instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g) => ToPgRow (a, b, c, d, e, f, g) where + rowEncoder = divide (\(a, b, c, d, e, f, g) -> ((a, b, c), (d, e, f, g))) rowEncoder rowEncoder + +instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g, ToPgField h) => ToPgRow (a, b, c, d, e, f, g, h) where + rowEncoder = divide (\(a, b, c, d, e, f, g, h) -> ((a, b, c, d), (e, f, g, h))) rowEncoder rowEncoder + +instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g, ToPgField h, ToPgField i) => ToPgRow (a, b, c, d, e, f, g, h, i) where + rowEncoder = divide (\(a, b, c, d, e, f, g, h, i) -> ((a, b, c, d), (e, f, g, h, i))) rowEncoder rowEncoder + +instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g, ToPgField h, ToPgField i, ToPgField j) => ToPgRow (a, b, c, d, e, f, g, h, i, j) where + rowEncoder = divide (\(a, b, c, d, e, f, g, h, i, j) -> ((a, b, c, d, e), (f, g, h, i, j))) rowEncoder rowEncoder + +instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g, ToPgField h, ToPgField i, ToPgField j, ToPgField k) => ToPgRow (a, b, c, d, e, f, g, h, i, j, k) where + rowEncoder = divide (\(a, b, c, d, e, f, g, h, i, j, k) -> ((a, b, c, d, e, f), (g, h, i, j, k))) rowEncoder rowEncoder + +-- | The OID for `Data.Int`, which is machine dependent. +haskellIntOid :: Oid + +-- | All pg type OIDs that fit into Haskell's `Data.Int`, whose size is machine dependent. +haskellIntOids :: [Oid] +(haskellIntOid, haskellIntOids) + | (fromIntegral (maxBound @Int) :: Integer) > fromIntegral (maxBound @Int32) = (int8Oid, [int2Oid, int4Oid, int8Oid]) + | (fromIntegral (maxBound @Int) :: Integer) > fromIntegral (maxBound @Int16) = (int4Oid, [int2Oid, int4Oid]) + | otherwise = (int2Oid, [int2Oid]) + +-- | Big-Endian binary encoder for Haskell's `Data.Int`, which is machine-dependent. +binaryIntEncoder :: Int -> BinaryField +binaryIntEncoder + | haskellIntOid == int8Oid = NotNull . PBA.encodeInt64BE . fromIntegral + | haskellIntOid == int4Oid = NotNull . PBA.encodeInt32BE . fromIntegral + | otherwise = NotNull . PBA.encodeInt16BE . fromIntegral + +-- | Big-Endian binary decoder for Haskell's various IntXX types. +binaryIntDecoder :: forall a. (Integral a, Bounded a) => Oid -> PinnedByteArray -> Either String a +binaryIntDecoder typOid = \bs -> + if doesFit + then intDecoder bs + else Left $ "Chosen integral type does not fit every value for PG type with OID " ++ show typOid + where + maxBoundPgType :: Integer + intDecoder :: PinnedByteArray -> Either String a + (maxBoundPgType, intDecoder) + | typOid == int8Oid = (fromIntegral $ maxBound @Int64, fmap fromIntegral . PBA.decodeInt64BE 0) + | typOid == int4Oid = (fromIntegral $ maxBound @Int32, fmap fromIntegral . PBA.decodeInt32BE 0) + | typOid == int2Oid = (fromIntegral $ maxBound @Int16, fmap fromIntegral . PBA.decodeInt16BE 0) + | otherwise = error "Bug in Hpgsql. Decoding binary integral type not an int2, int4 or int8" + doesFit = maxBoundPgType <= fromIntegral (maxBound @a) + +binaryFloat4Decoder :: PinnedByteArray -> Float +binaryFloat4Decoder = castWord32ToFloat . either error id . PBA.decodeWord32BE 0 + +binaryFloat8Decoder :: PinnedByteArray -> Double +binaryFloat8Decoder = castWord64ToDouble . either error id . PBA.decodeWord64BE 0 + +parsePgType :: String -> [Oid] -> (PinnedByteArray -> Either String a) -> FieldDecoder a +parsePgType !typeName !requiredTypeOids !fieldValueDecoder = + FieldDecoder + { fieldValueDecoder = \_oid -> fieldValueDecoder, + decodesSqlNullTo = Left $ "Cannot decode SQL null as the Haskell " ++ typeName ++ " type. Use a `Maybe " ++ show typeName ++ "`", + allowedPgTypes = (`elem` requiredTypeOids) . fieldTypeOid + } + +instance FromPgField () where + {-# INLINE fieldDecoder #-} + fieldDecoder = + FieldDecoder + { fieldValueDecoder = \_oid -> \bs -> + if PBA.length bs == 0 + then Right () + else + Left $ "Invalid value for postgres void type", + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell () type. Use a `Maybe ()`", + allowedPgTypes = (== voidOid) . fieldTypeOid + } + +instance FromPgField Int where + {-# INLINE fieldDecoder #-} + fieldDecoder = + FieldDecoder + { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> + let !decode = binaryIntDecoder oid + in \bs -> decode bs, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int type. Use a `Maybe Int`", + allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid + } + + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just $ do + fieldLen <- Parser.takeInt32BE + -- TODO: We're assuming `Int` is always 64 bits, so 64bit CPUs? Is that ok? + -- TODO: Is there a way to optimistically assume <=4 bytes and use our custom new parser? + case fieldLen of + 4 -> Just . fromIntegral <$> Parser.takeInt32BE + (-1) -> pure Nothing + 8 -> Just . fromIntegral <$> Parser.takeInt64BE + 2 -> Just . fromIntegral <$> Parser.takeInt16BE + _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" + +instance FromPgField Int16 where + {-# INLINE fieldDecoder #-} + fieldDecoder = + FieldDecoder + { fieldValueDecoder = + let !decode = binaryIntDecoder int2Oid + in const decode, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int16 type. Use a `Maybe Int16`", + allowedPgTypes = (== int2Oid) . fieldTypeOid + } + +instance FromPgField Int32 where + {-# INLINE fieldDecoder #-} + fieldDecoder = + FieldDecoder + { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> binaryIntDecoder oid, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int32 type. Use a `Maybe Int32`", + allowedPgTypes = (`elem` [int2Oid, int4Oid]) . fieldTypeOid + } + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just $ do + fieldLen <- Parser.takeInt32BE + case fieldLen of + 4 -> Just <$> Parser.takeInt32BE + (-1) -> pure Nothing + 2 -> Just . fromIntegral <$> Parser.takeInt16BE + _ -> fail "Trying to decode PG int4 but it's not 2 or 4 bytes long" + +instance FromPgField Int64 where + {-# INLINE fieldDecoder #-} + fieldDecoder = + FieldDecoder + { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> binaryIntDecoder oid, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int64 type. Use a `Maybe Int64`", + allowedPgTypes = (`elem` [int2Oid, int4Oid, int8Oid]) . fieldTypeOid + } + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just $ do + fieldLen <- Parser.takeInt32BE + case fieldLen of + 8 -> Just <$> Parser.takeInt64BE + 4 -> Just . fromIntegral <$> Parser.takeInt32BE + (-1) -> pure Nothing + 2 -> Just . fromIntegral <$> Parser.takeInt16BE + _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" + +instance FromPgField Integer where + {-# INLINE fieldDecoder #-} + fieldDecoder = + FieldDecoder + { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> + let !decodeInt = binaryIntDecoder @Int64 oid + in if oid /= numericOid + then fmap fromIntegral <$> decodeInt + else \bs -> case Parser.parseOnly (scientificDecoder True <* Parser.endOfInput) bs of + Parser.ParseOk sci -> case floatingOrInteger @Double @Integer sci of + Right i -> Right i + Left _ -> Left "Internal error in Hpgsql. Scientific to Integer conversion failed" + Parser.ParseFail err -> Left err, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Integer type. Use a `Maybe Integer`", + allowedPgTypes = (`elem` [int8Oid, numericOid, int4Oid, int2Oid]) . fieldTypeOid + } + +instance FromPgField Oid where + {-# INLINE fieldDecoder #-} + fieldDecoder = + FieldDecoder + { fieldValueDecoder = \_ -> \case + -- Oids are just int4 + bs -> Oid <$> binaryIntDecoder int4Oid bs, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Oid type. Use a `Maybe Oid`", + allowedPgTypes = (== oidOid) . fieldTypeOid + } + +instance FromPgField Float where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "Float" [float4Oid] $ Right . binaryFloat4Decoder + + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just Parser.takeFloatBEWithFieldLength + +{-# INLINE doubleRowDecoder #-} +doubleRowDecoder :: Parser.Parser (Maybe Double) +doubleRowDecoder = do + len <- Parser.takeInt32BE + case len of + 8 -> Just <$> Parser.takeDoubleBE + 4 -> Just . float2Double <$> Parser.takeFloatBE + _ -> pure Nothing + +instance FromPgField Double where + {-# INLINE fieldDecoder #-} + fieldDecoder = + FieldDecoder + { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> + let decoder + | oid == float8Oid = binaryFloat8Decoder + | otherwise = float2Double . binaryFloat4Decoder + in Right . decoder, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`", + allowedPgTypes = (`elem` [float8Oid, float4Oid]) . fieldTypeOid + } + + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just doubleRowDecoder + +-- | Allows you to specify a type (and other checks, possibly) for a `FieldDecoder`. +-- This can be useful to ensure you're not accidentally decoding a different type. +-- +-- > data MyEnum = Val1 | Val2 | Val3 +-- > myEnumFieldDecoderWithTypeInfoCheck :: FieldDecoder MyEnum +-- > myEnumFieldDecoderWithTypeInfoCheck = +-- > let convert = \case +-- > "val1" -> Val1 +-- > "val2" -> Val2 +-- > "val3" -> Val3 +-- > _ -> error "Invalid value for MyEnum" +-- > in typeFieldDecoder +-- > (typeMustBeNamed "my_enum") +-- > $ convert <$> rawBytesFieldDecoder +-- +-- This will work unless you use non-default flags in your connection options. +typeFieldDecoder :: (FieldInfo -> Bool) -> FieldDecoder a -> FieldDecoder a +typeFieldDecoder fieldCheck dec = dec {allowedPgTypes = fieldCheck} + +typeMustBeNamed :: Text -> (FieldInfo -> Bool) +typeMustBeNamed typName = \fieldInfo -> + (typeName <$> lookupTypeByOid fieldInfo.fieldTypeOid fieldInfo.encodingContext.typeInfoCache) == Just typName + +{-# INLINE scientificDecoder #-} +scientificDecoder :: Bool -> Parser.Parser Scientific +scientificDecoder mustBeInteger = do + ndigits <- Parser.takeInt16BE + weight <- Parser.takeInt16BE + sign <- Parser.takeInt16BE -- 0x0000 is positive, 0x4000 is negative, 0xC000 is NAN, 0xD000 is Positive Infinity, 0xF000 is Negative Infinity + unless (sign == 0x0000 || sign == 0x4000) $ fail "NaN, positive or negative infinities cannot be decoded into Integer or Scientific" + !dscale <- Parser.takeInt16BE + when (mustBeInteger && dscale /= 0) $ fail "Decoding into `Integer` requires explicit casting with `numeric(X,0)` to force integral values" + valueAbs <- parseAndMult ndigits (fromIntegral weight * 4) 0 + pure $ (if sign == 0x0000 then 1 else (-1)) * valueAbs + where + parseAndMult :: Int16 -> Int -> Scientific -> Parser.Parser Scientific + parseAndMult 0 _ !val = pure val + parseAndMult !ndigitsLeft !currexpon !val = do + !digit <- fromIntegral <$> Parser.takeInt16BE + parseAndMult (ndigitsLeft - 1) (currexpon - 4) (val + scientific digit currexpon) + +{-# INLINE numericRowParser #-} +numericRowParser :: Parser.Parser (Maybe Scientific) +numericRowParser = do + fieldLen <- Parser.takeInt32BE + case fieldLen of + (-1) -> pure Nothing + _ -> Just <$> scientificDecoder False + +instance FromPgField Scientific where + -- See https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/numeric.c#L1163 + {-# INLINE fieldDecoder #-} + fieldDecoder = + FieldDecoder + { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> + if fieldTypeOid /= numericOid + then + let intdec = binaryIntDecoder @Int64 fieldTypeOid + in \bs -> flip scientific 0 . fromIntegral <$> intdec bs + else \case + bs -> + -- TODO: There is loss converting from Float/Double to Scientific, but it might be quite small, so should we accept + -- float4Oid and float8Oid here? + case Parser.parseOnly (scientificDecoder False <* Parser.endOfInput) bs of + Parser.ParseOk sci -> Right sci + Parser.ParseFail err -> Left err, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`", + allowedPgTypes = (`elem` [numericOid, int2Oid, int4Oid, int8Oid]) . fieldTypeOid + } + {-# INLINE notConstFieldDecoder #-} + notConstFieldDecoder = + let !int64RowDec = fromMaybe (error "Bug in HPgsql: Int64 does not have an inlinedConstFieldDecoder") $ inlinedConstFieldDecoder @Int64 + in \singleColInfo -> + if singleColInfo.fieldTypeOid /= numericOid + then fmap (flip scientific 0 . fromIntegral) <$> int64RowDec + else numericRowParser + +instance FromPgField (Ratio Integer) where + {-# INLINE fieldDecoder #-} + fieldDecoder = toRational <$> fieldDecoder @Scientific + +binaryTrue :: PinnedByteArray +binaryTrue = PBA.fromByteString $ PBA.encodePgBoolean True + +{-# INLINE boolRowDecoder #-} +boolRowDecoder :: Parser.Parser (Maybe Bool) +boolRowDecoder = fmap (== 1) <$> Parser.parsePgFieldWithAtMost4Bytes PBA.TypeSize1 + +instance FromPgField Bool where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "Bool" [boolOid] $ \bs -> Right $ bs == binaryTrue + + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just boolRowDecoder + +instance FromPgField Char where + {-# INLINE fieldDecoder #-} + fieldDecoder = + let textParser = fieldValueDecoder (fieldDecoder @Text) + in FieldDecoder + { fieldValueDecoder = \colInfo@FieldInfo {fieldTypeOid = oid} -> + let !decodeText = textParser colInfo + in \bs -> + if oid == charOid + then Right $ BSC.head $ PBA.toByteString bs + else case decodeText bs of + Left err -> Left err + Right t -> if Text.length t > 1 then Left "Cannot parse text with more than one character into a Haskell Char type." else Right (Text.head t), + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Char type. Use a `Maybe Char`", + -- TODO: All the varchar types? + allowedPgTypes = (`elem` [charOid, textOid]) . fieldTypeOid + } + +instance FromPgField ByteString where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "byteString" [byteaOid] (Right . PBA.toByteString) + +instance FromPgField LBS.ByteString where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "ByteString" [byteaOid] $ (Right . LBS.fromStrict . PBA.toByteString) + +{-# INLINE textDecoder #-} +textDecoder :: Parser.Parser (Maybe Text) +textDecoder = do + len <- Parser.takeInt32BE + if len >= 0 + -- TODO: Use some faster unsafeDecodeUtf8 function? + then Just . decodeUtf8 . PBA.toByteString <$> Parser.take (fromIntegral len) + else pure Nothing + +instance FromPgField Text where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ decodeUtf8 $ PBA.toByteString bs + + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just textDecoder + +instance FromPgField LT.Text where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ LT.fromStrict $ decodeUtf8 $ PBA.toByteString bs + +instance FromPgField String where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "String" [textOid, varcharOid, nameOid] $ \bs -> Right $ Text.unpack $ decodeUtf8 $ PBA.toByteString bs + +-- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default +-- connection option). +instance FromPgField (CI Text) where + {-# INLINE fieldDecoder #-} + fieldDecoder = typeFieldDecoder (typeMustBeNamed "citext") $ CI.mk <$> fieldDecoder + +-- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default +-- connection option). +instance FromPgField (CI LT.Text) where + {-# INLINE fieldDecoder #-} + fieldDecoder = typeFieldDecoder (typeMustBeNamed "citext") $ CI.mk <$> fieldDecoder + +-- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default +-- connection option). +instance FromPgField (CI String) where + {-# INLINE fieldDecoder #-} + fieldDecoder = typeFieldDecoder (typeMustBeNamed "citext") $ CI.mk <$> fieldDecoder + +{-# INLINE utcTimeRowDecoder #-} +utcTimeRowDecoder :: Parser.Parser (Maybe UTCTime) +utcTimeRowDecoder = do + len <- Parser.takeInt32BE + case len of + 8 -> do + totalusecs <- Parser.takeInt64BE + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + pure $ Just $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + _ -> pure Nothing + +instance FromPgField UTCTime where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "UTCTime" [timestamptzOid] $ \case + bs -> do + -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 + totalusecs <- PBA.decodeInt64BE 0 bs + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + Right $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just utcTimeRowDecoder + +instance FromPgField (Unbounded UTCTime) where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "Unbounded UTCTime" [timestamptzOid] $ \case + bs -> do + -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 + totalusecs <- PBA.decodeInt64BE 0 bs + Right $ + if totalusecs == minBound + then NegInfinity + else + if totalusecs == maxBound + then PosInfinity + else + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + in Finite $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + +instance FromPgField ZonedTime where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "ZonedTime" [timestamptzOid] $ \case + bs -> do + -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 + totalusecs <- PBA.decodeInt64BE 0 bs + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + Right $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + +instance FromPgField (Unbounded ZonedTime) where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "Unbounded ZonedTime" [timestamptzOid] $ \case + bs -> do + -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 + totalusecs <- PBA.decodeInt64BE 0 bs + Right $ + if totalusecs == minBound + then NegInfinity + else + if totalusecs == maxBound + then PosInfinity + else + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + in Finite $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + +instance FromPgField LocalTime where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "LocalTime" [timestampOid] $ \case + bs -> do + totalusecs <- PBA.decodeInt64BE 0 bs + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + Right $ LocalTime parsedDate (timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + +instance FromPgField TimeOfDay where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "TimeOfDay" [timeOid] $ \case + bs -> do + usecs <- PBA.decodeInt64BE 0 bs + Right $ timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral usecs * 1_000_000 + +{-# INLINE dayRowDecoder #-} +dayRowDecoder :: Parser.Parser (Maybe Day) +dayRowDecoder = + let int32ToDay (i32 :: Int32) = let jd = fromIntegral i32 :: Integer in addJulianDurationClip (CalendarDiffDays 0 (jd - 13)) $ fromJulian 2000 01 01 + in fmap int32ToDay <$> Parser.takeInt32BEWithFieldLength + +instance FromPgField Day where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "Day" [dateOid] $ \case + bs -> do + -- There is a very specific conversion function for these, which I poorly translated to Haskell + -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 + -- But I found a simpler way to do this. Let's see if it works in our property based tests + jd <- PBA.decodeInt32BE 0 bs + Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 + + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just dayRowDecoder + +instance FromPgField (Unbounded Day) where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "Unbounded Day" [dateOid] $ \case + bs -> do + -- There is a very specific conversion function for these, which I poorly translated to Haskell + -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 + -- But I found a simpler way to do this. Let's see if it works in our property based tests + jd <- PBA.decodeInt32BE 0 bs + Right $ + if jd == minBound + then NegInfinity + else + if jd == maxBound + then PosInfinity + else + Finite $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 + +instance FromPgField CalendarDiffTime where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "CalendarDiffTime " [intervalOid] $ \bs -> do + nMicrosecs <- PBA.decodeInt64BE 0 bs + nDays <- PBA.decodeInt32BE 8 bs + nMonths <- PBA.decodeInt32BE 12 bs + Right $ CalendarDiffTime {ctMonths = fromIntegral nMonths, ctTime = secondsToNominalDiffTime (fromIntegral nDays * 86400) + realToFrac (picosecondsToDiffTime (fromIntegral nMicrosecs * 1_000_000))} + +instance FromPgField UUID where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "UUID" [uuidOid] $ \case + bs -> case UUID.fromByteString (LBS.fromStrict $ PBA.toByteString bs) of + Just uuid -> Right uuid + Nothing -> Left "Bug in Hpgsql: UUID field could not be decoded" + +instance FromPgField Aeson.Value where + {-# INLINE fieldDecoder #-} + fieldDecoder = + FieldDecoder + { fieldValueDecoder = + \FieldInfo {fieldTypeOid} -> + let -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in \case + bs -> case Aeson.decodeStrict $ fixJsonb (PBA.toByteString bs) of + Just d -> Right d + Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls", + allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid + } + +-- | A FieldDecoder that accepts and decodes SQL NULLs into `Nothing` values +-- for a given decoder. +nullableField :: FieldDecoder a -> FieldDecoder (Maybe a) +nullableField FieldDecoder {..} = + FieldDecoder + { fieldValueDecoder = \oid -> + let origFieldValueParser = fieldValueDecoder oid + in \bs -> Just <$> origFieldValueParser bs, + decodesSqlNullTo = Right Nothing, + allowedPgTypes + } + +instance (FromPgField a) => FromPgField (Maybe a) where + {-# INLINE fieldDecoder #-} + fieldDecoder = nullableField fieldDecoder + + {-# INLINE notConstFieldDecoder #-} + notConstFieldDecoder finfo = do + mv <- notConstFieldDecoder @a finfo + case mv of + Nothing -> pure Nothing + jv -> pure $ Just jv + + {-# INLINE inlinedConstFieldDecoder #-} + -- \| For types where there is a fast way to decode fields+values + -- without knowing the OID of the value in the query (of course, the + -- possible OIDs are still limited by the FieldDecoder's allowed types), + -- this can help provide a significant boost to inlined row decoders. + -- Define as `Nothing` if this isn't possible. + -- inlinedConstFieldDecoder :: Maybe (Parser.Parser (Maybe (Maybe a))) + inlinedConstFieldDecoder = case inlinedConstFieldDecoder @a of + Nothing -> Nothing + Just p -> Just $ do + mv <- p + case mv of + Nothing -> pure Nothing -- Must return Nothing for SQL Nulls + jv -> pure $ Just jv + +allowOnlyArrayTypes :: FieldInfo -> Bool +allowOnlyArrayTypes fieldInfo = + -- TODO: We could check the elemTypeOid too, but maybe later + case lookupTypeByOid fieldInfo.fieldTypeOid fieldInfo.encodingContext.typeInfoCache of + Just (TypeInfo {typeDetails = ArrayType _}) -> True + Nothing -> True -- Assume user knows what they're doing + Just _ -> False -- Definitely not an array + +instance forall a. (FromPgField a) => FromPgField (Vector a) where + fieldDecoder = arrayField Vector.replicateM fieldDecoder + +instance {-# OVERLAPPING #-} forall a. (FromPgField a) => FromPgField (Vector (Vector a)) where + -- From https://github.com/postgres/postgres/blob/5941946d0934b9eccb0d5bfebd40b155249a0130/src/backend/utils/adt/arrayfuncs.c#L1548 + fieldDecoder = + FieldDecoder + { fieldValueDecoder = \colInfo -> + let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput + in \bs -> case Parser.parseOnly arrayFieldDecoder bs of + Parser.ParseOk v -> Right v + Parser.ParseFail err -> Left err, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell (Vector (Vector a)) type. Use a `Maybe (Vector (Vector a))`", + allowedPgTypes = allowOnlyArrayTypes + } + where + !elementParser = fieldDecoder @a + arrayParser :: EncodingContext -> Parser.Parser (Vector (Vector a)) + arrayParser encodingContext = do + !ndim <- Parser.takeInt32BE + !_hasNull <- Parser.takeInt32BE + !elementTypeOid :: Oid <- Oid . fromIntegral <$> Parser.takeInt32BE + let !elementColInfo = FieldInfo elementTypeOid Nothing encodingContext + when (ndim /= 2) $ fail $ "TODO: No support for " ++ show ndim ++ "-dimensional arrays in Hpgsql. Got array with ndim=" ++ show ndim + unless (elementParser.allowedPgTypes elementColInfo) $ fail $ "Array contains elements of type OID " ++ show elementTypeOid ++ " but decoder does not handle that type" + numRows <- do + !dim_i :: Int <- fromIntegral <$> Parser.takeInt32BE + !_lb_i <- Parser.takeInt32BE + pure dim_i + lengthEachRow <- do + !dim_i :: Int <- fromIntegral <$> Parser.takeInt32BE + !_lb_i <- Parser.takeInt32BE + pure dim_i + + Vector.replicateM numRows $ do + Vector.replicateM lengthEachRow $ + do + size :: Int <- fromIntegral <$> Parser.takeInt32BE + if size == (-1) + then case elementParser.decodesSqlNullTo of + Left err -> fail err + Right v -> pure v + else do + elementBs <- Parser.take size + case elementParser.fieldValueDecoder elementColInfo elementBs of + Left err -> fail $ "Error parsing array element: " ++ show err + Right el -> pure el + +{-# INLINE genericFromPgRow #-} + +-- | Derives `FromPgRow` generically. +genericFromPgRow :: forall a. (Generic a, ProductTypeDecoder (Rep a)) => RowDecoder a +genericFromPgRow = to <$> genRowDecoder @(Rep a) + +class ProductTypeDecoder f where + genRowDecoder :: RowDecoder (f a) + +instance (ProductTypeDecoder a, ProductTypeDecoder b) => ProductTypeDecoder (a :*: b) where + {-# INLINE genRowDecoder #-} + genRowDecoder = (:*:) <$> genRowDecoder <*> genRowDecoder + +instance (ProductTypeDecoder f) => ProductTypeDecoder (M1 a c f) where + {-# INLINE genRowDecoder #-} + genRowDecoder = M1 <$> genRowDecoder + +instance (FromPgField a) => ProductTypeDecoder (K1 r a) where + {-# INLINE genRowDecoder #-} + -- coercing instead of fmap reduces memory usage, apparently + -- by reducing (unnecessary) closures in the final row decoder, + -- as per looking at GHC Core + genRowDecoder = coerce $ notInlinedSingleFieldRowDecoder @a + +genericToPgRow :: forall a. (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a +genericToPgRow = contramap from genRowEncoder + +class ProductTypeEncoder f where + genRowEncoder :: RowEncoder (f a) + +instance (ProductTypeEncoder a, ProductTypeEncoder b) => ProductTypeEncoder (a :*: b) where + genRowEncoder = divide (\(a :*: b) -> (a, b)) genRowEncoder genRowEncoder + +instance (ProductTypeEncoder f) => ProductTypeEncoder (M1 i c f) where + genRowEncoder = contramap unM1 genRowEncoder + +instance (ToPgField a) => ProductTypeEncoder (K1 r a) where + genRowEncoder = contramap unK1 singleFieldRowEncoder + +-- | For the very common case of a Haskell enum matching a custom postgres enum type +-- that has its values all as lower case strings, this newtype can help you derive +-- instances as such: +-- +-- > data Mood = Sad | Ok | Happy +-- > deriving stock (Generic) +-- > deriving (FromPgField, ToPgField) via (LowerCasedPgEnum Mood) +-- +-- And this would match the Postgres equivalent: +-- +-- > CREATE TYPE mood AS ENUM ('sad', 'ok', 'happy'); +-- +-- If you run into PostgreSQL type inference problems with this, you can +-- write instances manually with 'genericEnumFieldDecoder', 'genericEnumFieldEncoder', +-- 'typeFieldEncoder', and 'typeFieldDecoder'. +newtype LowerCasedPgEnum a = LowerCasedPgEnum a + +instance (Generic a, EnumDecoder (Rep a)) => FromPgField (LowerCasedPgEnum a) where + fieldDecoder = LowerCasedPgEnum <$> genericEnumFieldDecoder LT.toLower + +instance (Generic a, EnumEncoder (Rep a)) => ToPgField (LowerCasedPgEnum a) where + fieldEncoder = untypedFieldEncoder $ \_encCtx -> \(LowerCasedPgEnum v) -> NotNull $ genericEnumFieldEncoder Text.toLower v + +-- | One of the functions behind 'LowerCasedPgEnum', but you can decide +-- how to map your type's constructor names arbitrarily, which can be +-- useful if you're not using lowercase values in your postgres enums. +genericEnumFieldDecoder :: + forall a. + (Generic a, EnumDecoder (Rep a)) => + -- | A function that takes in the Haskell constructor name and returns the textual representation of the enum in postgres + (LT.Text -> LT.Text) -> + FieldDecoder a +genericEnumFieldDecoder nameTransform = fromMaybe (error $ "Invalid enum value. Not one of " ++ show (Map.keys allValuesMap)) . flip Map.lookup allValuesMap <$> rawBytesFieldDecoder + where + -- TODO: Vector of pointers to ByteStrings for a bit more memory locality? Does it make a perf difference? + allValuesMap = Map.mapKeys (LBS.toStrict . LT.encodeUtf8 . nameTransform) $ fmap to genEnumDecoder + +class EnumDecoder f where + -- | Returns the textual representation and constructed object for every possible + -- value of the enum. + genEnumDecoder :: Map LT.Text (f a) + +instance (EnumDecoder a, EnumDecoder b) => EnumDecoder (a :+: b) where + genEnumDecoder = (L1 <$> genEnumDecoder) `Map.union` (R1 <$> genEnumDecoder) + +instance (EnumDecoder f) => EnumDecoder (M1 D c f) where + genEnumDecoder = M1 <$> genEnumDecoder + +-- U1 is "Unit"-type, that is: no value in the constructor, AKA "pure enum". +instance (KnownSymbol ctorName) => EnumDecoder (M1 C ('MetaCons ctorName ctorFixity 'False) U1) where + genEnumDecoder = Map.singleton (LT.pack $ symbolVal (Proxy @ctorName)) (M1 U1) + +-- | One of the functions behind 'LowerCasedPgEnum', but you can decide +-- how to map your type's constructor names arbitrarily, which can be +-- useful if you're not using lowercase values in your postgres enums. +genericEnumFieldEncoder :: + forall a. + (Generic a, EnumEncoder (Rep a)) => + -- | A function that takes in the Haskell constructor name and returns the textual representation of the enum in postgres + (Text -> Text) -> + a -> + ByteString +genericEnumFieldEncoder nameTransform = encodeUtf8 . nameTransform . genEnumEncoder . from + +class EnumEncoder f where + -- | Returns the textual representation of an enum value's constructor. + genEnumEncoder :: f a -> Text + +instance (EnumEncoder a, EnumEncoder b) => EnumEncoder (a :+: b) where + genEnumEncoder (L1 x) = genEnumEncoder x + genEnumEncoder (R1 x) = genEnumEncoder x + +instance (EnumEncoder f) => EnumEncoder (M1 D c f) where + genEnumEncoder (M1 x) = genEnumEncoder x + +-- U1 is "Unit"-type, that is: no value in the constructor, AKA "pure enum". +instance (KnownSymbol ctorName) => EnumEncoder (M1 C ('MetaCons ctorName ctorFixity 'False) U1) where + genEnumEncoder _ = Text.pack $ symbolVal (Proxy @ctorName) + +-- | Returns a `FieldEncoder` that is sent without a type OID in queries. +-- This means postgres will try to infer the type of these arguments. +-- Check `typedFieldEncoder` if you're interested in encoding your custom types, +-- you probably don't need this. +untypedFieldEncoder :: (EncodingContext -> a -> BinaryField) -> FieldEncoder a +untypedFieldEncoder enc = FieldEncoder {toTypeOid = \_ -> Nothing, toPgField = enc} + +-- | A decoder that accepts any PG type and returns the object's +-- postgres' binary representation as a ByteString. +rawBytesFieldDecoder :: FieldDecoder ByteString +rawBytesFieldDecoder = + FieldDecoder + { fieldValueDecoder = \_oid -> \case + bs -> Right $ PBA.toByteString bs, + decodesSqlNullTo = Left "Cannot decode SQL null as the `rawBytesFieldDecoder`.", + allowedPgTypes = const True + } + +-- | Returns a field-encoding function for a vector-like Foldable (e.g. Lists and Vector itself). +toPgVectorField :: forall f a. (Foldable f, ToPgField a) => EncodingContext -> f a -> BinaryField +toPgVectorField encCtx = + let fe = fieldEncoder @a + encodeElement el = Builder.binaryField $ fe.toPgField encCtx el + Oid elemOid = fromMaybe (Oid 0) (fe.toTypeOid encCtx) + in \vec -> + let ndim = Builder.int32BE 1 + -- Postgres seems to build the "has_nulls" flag itself in the ReadArrayBinary function at https://github.com/postgres/postgres/blob/aa7f9493a02f5981c09b924323f0e7a58a32f2ed/src/backend/utils/adt/arrayfuncs.c#L1429, so we can just set it to 0 + hasNull = Builder.byteString $ PBA.encodeInt32BE 0 + -- hasNull = Builder.byteString $ PBA.encodeInt32BE (if Vector.any (\e -> toPgField e == Nothing) vec then 1 else 0) + elemOidBs = Builder.byteString $ PBA.encodeInt32BE elemOid + lb1 = Builder.byteString $ PBA.encodeInt32BE 1 + (Sum len, encodedElements) = foldMap (\el -> (Sum 1, encodeElement el)) vec + dim1 = Builder.byteString $ PBA.encodeInt32BE len + fullBs = ndim <> hasNull <> elemOidBs <> dim1 <> lb1 <> encodedElements + in NotNull (Builder.toStrictByteString fullBs) + +-- | A FieldDecoder that accepts and decodes Postgres arrays. +arrayField :: forall a f. (Monoid (f a)) => (forall m. (Monad m) => Int -> m a -> m (f a)) -> FieldDecoder a -> FieldDecoder (f a) +arrayField !replicateFunction !elementParser = + -- From https://github.com/postgres/postgres/blob/5941946d0934b9eccb0d5bfebd40b155249a0130/src/backend/utils/adt/arrayfuncs.c#L1548 + FieldDecoder + { fieldValueDecoder = \colInfo -> + let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput + in \bs -> case Parser.parseOnly arrayFieldDecoder bs of + Parser.ParseOk v -> Right v + Parser.ParseFail err -> Left err, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Vector type. Use a `Maybe (Vector a)`", + allowedPgTypes = allowOnlyArrayTypes + } + where + arrayParser :: EncodingContext -> Parser.Parser (f a) + arrayParser encodingContext = do + !ndim <- Parser.takeInt32BE + !_hasNull <- Parser.takeInt32BE + !elementTypeOid :: Oid <- Oid . fromIntegral <$> Parser.takeInt32BE + let !elementColInfo = FieldInfo elementTypeOid Nothing encodingContext + when (ndim > 1) $ fail $ "TODO: No support for multi-dimensional arrays in Hpgsql. Got array with ndim=" ++ show ndim + if ndim == 0 + then pure mempty + else do + !dim_i :: Int <- fromIntegral <$> Parser.takeInt32BE + !_lb_i <- Parser.takeInt32BE + unless (elementParser.allowedPgTypes elementColInfo) $ fail $ "Array contains elements of type OID " ++ show elementTypeOid ++ " but decoder does not handle that type" + replicateFunction dim_i $ do + size :: Int <- fromIntegral <$> Parser.takeInt32BE + if size == (-1) + then case elementParser.decodesSqlNullTo of + Left err -> fail err + Right v -> pure v + else do + elementBs <- Parser.take size + case elementParser.fieldValueDecoder elementColInfo elementBs of + Left err -> fail $ "Error parsing array element: " ++ show err + Right el -> pure el diff --git a/hpgsql/src/Hpgsql/Types.hs b/hpgsql/src/Hpgsql/Types.hs index 62536bf..cbaa9fe 100644 --- a/hpgsql/src/Hpgsql/Types.hs +++ b/hpgsql/src/Hpgsql/Types.hs @@ -19,7 +19,7 @@ import qualified Data.ByteString.Lazy as LBS import Data.Tuple.Only (Only (..)) import Data.Typeable (Proxy (..)) import Hpgsql.Builder (BinaryField (..)) -import Hpgsql.Encoding (FieldDecoder (..), FieldEncoder (..), FieldInfo (..), FromPgField (..), FromPgRow (..), RowEncoder (..), ToPgField (..), ToPgRow (..), arrayField, toPgVectorField) +import Hpgsql.Encoding.Internal (FieldDecoder (..), FieldEncoder (..), FieldInfo (..), FromPgField (..), FromPgRow (..), RowEncoder (..), ToPgField (..), ToPgRow (..), arrayField, toPgVectorField) import qualified Hpgsql.PinnedByteArray as PBA import qualified Hpgsql.SimpleParser as Parser import Hpgsql.TypeInfo (EncodingContext (..), TypeInfo (..), jsonOid, jsonbOid, lookupTypeByOid) From e6efc73a7f405912e48060d2e0cb107f2accc75e Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sun, 23 Aug 2026 20:04:48 -0300 Subject: [PATCH 34/35] Document why PinnedByteArray --- hpgsql/src/Hpgsql/PinnedByteArray.hs | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/hpgsql/src/Hpgsql/PinnedByteArray.hs b/hpgsql/src/Hpgsql/PinnedByteArray.hs index ca1c3b2..9362b60 100644 --- a/hpgsql/src/Hpgsql/PinnedByteArray.hs +++ b/hpgsql/src/Hpgsql/PinnedByteArray.hs @@ -4,6 +4,29 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UnliftedFFITypes #-} +-- | +-- Why our own `PinnedByteArray` type instead of just using `ByteString`? +-- It all started when upon inspecting our row decoder's GHC Core, I saw +-- `lazy`, `keepAlive` and boxing+unboxing of Word32s that seemed completely +-- unnecessary. Claude suggested `lazy` - which appeared in GHC Core - acted +-- like an optimization fence, and I don't remember the details now, but +-- basically a `ByteString` uses a `ForeignPtr` under the hood, which requires +-- `withForeignPtr`, which uses `keepAlive#`, adding a lot of code to peek a +-- Word from a pointer. +-- Whether Claude's assumption that that code acts as an optimization fence +-- is correct is inconsequential, what matters is that we can remove all that +-- code by using pinned `ByteArray`s, and that the extra Word boxing+unboxing +-- indeed goes away with that. +-- +-- After I wrote this, I realized _maybe_ I could've moved `withForeignPtr` +-- higher up in the call stack and in a single location, then pass down the +-- `Ptr Word8` in a newtype instead of doing this. But it wasn't only late, +-- `PinnedByteArray` has the advantage that I can push it down even to user +-- facing methods without being concerned with everything happening inside +-- the context of `withForeignPtr` (though I don't think it would've been a +-- problem). Also, we only use pinned byte arrays for our receive buffer, +-- which has such a short life span (it gets decoded into user rows immediately) +-- that heap fragmentation doesn't sound too concerning. module Hpgsql.PinnedByteArray ( PinnedByteArray (..), LazyPinnedByteArray, From c9316c1d63057fd2426082ac70398572926dc0a8 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sun, 23 Aug 2026 20:44:40 -0300 Subject: [PATCH 35/35] Custom conversion from PinnedByteArray to Text Very little gained, but why not? --- hpgsql-tests/EncodingDecodingSpec.hs | 45 ++++++++++++++++++++++++++ hpgsql/src/Hpgsql/Encoding/Internal.hs | 25 +++++++------- hpgsql/src/Hpgsql/PinnedByteArray.hs | 9 ++++++ hpgsql/src/Hpgsql/SimpleParser.hs | 16 +++++++++ hpgsql/src/Hpgsql/Types.hs | 20 +++++++----- 5 files changed, 95 insertions(+), 20 deletions(-) diff --git a/hpgsql-tests/EncodingDecodingSpec.hs b/hpgsql-tests/EncodingDecodingSpec.hs index 0b960a0..0ea9f79 100644 --- a/hpgsql-tests/EncodingDecodingSpec.hs +++ b/hpgsql-tests/EncodingDecodingSpec.hs @@ -125,6 +125,12 @@ spec = parallel $ do it "CI Text text decoding" ciTextTextDecoding + it + "Text values round-trip" + textRoundTrip + it + "Text text decoding" + textTextDecoding it "TimeOfDay values round-trip" timeOfDayRoundTrip @@ -692,6 +698,45 @@ ciTextTextDecoding conn = hedgehog $ do liftIO res1 >>= (=== expectedResult) liftIO res2 >>= (=== expectedResult) +textRoundTrip :: HPgConnection -> PropertyT IO () +textRoundTrip conn = hedgehog $ do + let genText = Gen.maybe $ Gen.text (Gen.linear 0 300) (Gen.filter (/= '\0') Gen.unicode) + genLazyText = Gen.maybe $ LT.fromStrict <$> Gen.text (Gen.linear 0 300) (Gen.filter (/= '\0') Gen.unicode) + genString = Gen.maybe $ Gen.string (Gen.linear 0 300) (Gen.filter (/= '\0') Gen.unicode) + row <- + Gen.forAll $ + (,,,,,,,,,) + <$> genText + <*> genText + <*> genText + <*> genText + <*> genLazyText + <*> genLazyText + <*> genLazyText + <*> genString + <*> genString + <*> genString + res <- + liftIO $ + query conn (mkQuery "SELECT $1, $2, $3, $4, $5, $6, $7, $8, $9, $10" row) + res === [row] + +textTextDecoding :: HPgConnection -> PropertyT IO () +textTextDecoding conn = hedgehog $ do + someText :: Text <- Gen.forAll $ Gen.text (Gen.linear 0 300) (Gen.filter (\c -> c /= '\0' && c /= '\'') Gen.unicode) + let qry = fromString $ "SELECT '" <> Text.unpack someText <> "'::text, '" <> Text.unpack someText <> "'::text, '" <> Text.unpack someText <> "'::text" + (res1, res2) <- + liftIO $ + runPipeline conn $ + (,) + <$> pipeline1With rowDecoder qry + -- Specialized row parsers of each type are a different implementation from + -- the simpler fieldDecoders, so we need to test both + <*> pipeline1With ((,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder) qry + let expectedResult = (someText, LT.fromStrict someText, Text.unpack someText) + liftIO res1 >>= (=== expectedResult) + liftIO res2 >>= (=== expectedResult) + timeOfDayRoundTrip :: HPgConnection -> PropertyT IO () timeOfDayRoundTrip conn = hedgehog $ do let genTimeOfDay = do diff --git a/hpgsql/src/Hpgsql/Encoding/Internal.hs b/hpgsql/src/Hpgsql/Encoding/Internal.hs index 82537c5..05637cf 100644 --- a/hpgsql/src/Hpgsql/Encoding/Internal.hs +++ b/hpgsql/src/Hpgsql/Encoding/Internal.hs @@ -64,7 +64,7 @@ import Data.Ratio (Ratio) import Data.Scientific (Scientific (..), floatingOrInteger, scientific) import Data.Text (Text) import qualified Data.Text as Text -import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT import Data.Time (CalendarDiffDays (..), CalendarDiffTime (..), Day, LocalTime (..), NominalDiffTime, TimeOfDay, UTCTime (..), ZonedTime, diffDays, diffTimeToPicoseconds, fromGregorian, picosecondsToDiffTime, secondsToNominalDiffTime, timeOfDayToTime, timeToTimeOfDay, utc, utcToZonedTime, zonedTimeToUTC) @@ -1101,24 +1101,23 @@ textDecoder :: Parser.Parser (Maybe Text) textDecoder = do len <- Parser.takeInt32BE if len >= 0 - -- TODO: Use some faster unsafeDecodeUtf8 function? - then Just . decodeUtf8 . PBA.toByteString <$> Parser.take (fromIntegral len) + then Just <$> Parser.takeUtf8Text (fromIntegral len) else pure Nothing instance FromPgField Text where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ decodeUtf8 $ PBA.toByteString bs + fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> PBA.unsafeToUtf8Text 0 (PBA.length bs) bs {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just textDecoder instance FromPgField LT.Text where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ LT.fromStrict $ decodeUtf8 $ PBA.toByteString bs + fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> LT.fromStrict <$> PBA.unsafeToUtf8Text 0 (PBA.length bs) bs instance FromPgField String where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "String" [textOid, varcharOid, nameOid] $ \bs -> Right $ Text.unpack $ decodeUtf8 $ PBA.toByteString bs + fieldDecoder = parsePgType "String" [textOid, varcharOid, nameOid] $ \bs -> Text.unpack <$> PBA.unsafeToUtf8Text 0 (PBA.length bs) bs -- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default -- connection option). @@ -1280,12 +1279,14 @@ instance FromPgField Aeson.Value where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in \case - bs -> case Aeson.decodeStrict $ fixJsonb (PBA.toByteString bs) of - Just d -> Right d - Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", + let + -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in + \case + bs -> case Aeson.decodeStrict $ fixJsonb (PBA.toByteString bs) of + Just d -> Right d + Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } diff --git a/hpgsql/src/Hpgsql/PinnedByteArray.hs b/hpgsql/src/Hpgsql/PinnedByteArray.hs index 9362b60..a1c8350 100644 --- a/hpgsql/src/Hpgsql/PinnedByteArray.hs +++ b/hpgsql/src/Hpgsql/PinnedByteArray.hs @@ -62,6 +62,7 @@ module Hpgsql.PinnedByteArray decodeDataRow, decodePgFieldWithAtMost4Bytes, WordDecoding (..), + unsafeToUtf8Text, ) where @@ -86,8 +87,10 @@ import Data.Word (Word16, Word32, Word64) #else import Data.Word (Word16, Word64, byteSwap16, byteSwap64, Word8, byteSwap32) #endif +import Data.Array.Byte (ByteArray (..)) import Data.Bits (Bits (unsafeShiftR)) import Data.Coerce (coerce) +import Data.Text.Internal (Text (..)) import Foreign (Storable (..), (.&.)) import GHC.Float (castDoubleToWord64, castFloatToWord32) import GHC.Word (Word16 (..), Word64 (..), Word8 (..)) @@ -135,6 +138,12 @@ toByteString :: PinnedByteArray -> ByteString toByteString (PinnedByteArray start len src) = unsafeDupablePerformIO $ BS.create len $ \dst -> copyBytes dst (Ptr (byteArrayContents# src) `plusPtr` start) len +{-# INLINE unsafeToUtf8Text #-} +-- Assuming the pinned byte array contains valid UTF8 text, creates +-- returns an instance of `Text` with the same contents (but does make a copy). +unsafeToUtf8Text :: ByteStringIdx -> Int -> PinnedByteArray -> Either String Text +unsafeToUtf8Text idx desiredLen pba@(PinnedByteArray _ actualLen _) = if actualLen < desiredLen then Left "Not enough bytes to convert to Text" else let !(PinnedByteArray start arrLen arr#) = toStrictN idx.idx desiredLen (fromStrict pba) in Right $ Text (ByteArray arr#) start arrLen + takePgMessageIdentAndLen :: LazyPinnedByteArray -> Maybe (Char, Int32) takePgMessageIdentAndLen lpba@(LazyPinnedByteArray len _) = if len >= 5 diff --git a/hpgsql/src/Hpgsql/SimpleParser.hs b/hpgsql/src/Hpgsql/SimpleParser.hs index e6fccf8..5841787 100644 --- a/hpgsql/src/Hpgsql/SimpleParser.hs +++ b/hpgsql/src/Hpgsql/SimpleParser.hs @@ -32,11 +32,13 @@ module Hpgsql.SimpleParser takeDoubleBE, takeFloatBEWithFieldLength, peekInt32BE, + takeUtf8Text, ) where import Control.Applicative (Alternative (..)) import Data.Int (Int16, Int32, Int64) +import Data.Text (Text) import Foreign.Storable (Storable) import GHC.Float (castWord32ToFloat, castWord64ToDouble) import Hpgsql.PinnedByteArray (ByteStringIdx (..), PinnedByteArray) @@ -113,6 +115,7 @@ take :: Int -> Parser PinnedByteArray take n = Parser $ \idx sbs kf ks -> let skip' = n + idx.idx in if PBA.length sbs >= skip' + -- TODO: dropAndTake in a single call then case PBA.take n $ PBA.drop idx.idx sbs of -- Strict on the bytestring because we're pretty sure -- the field decoder will need to evaluate this anyway, @@ -121,6 +124,19 @@ take n = Parser $ \idx sbs kf ks -> else kf ("take: wanted " <> show skip' <> " bytes but only " <> show (PBA.length sbs) <> " remain") {-# INLINE take #-} +-- | Consume exactly `n` bytes of input, failing if fewer than `n` bytes +-- remain, and assumes those next `n` bytes are UTF8 text, so returns them +-- as `Text`. +takeUtf8Text :: Int -> Parser Text +takeUtf8Text n = Parser $ \idx sbs kf ks -> + let skip' = n + idx.idx + in if PBA.length sbs >= skip' + then case PBA.unsafeToUtf8Text idx n sbs of + Left err -> kf err + Right t -> ks t (ByteStringIdx skip') sbs + else kf ("take: wanted " <> show skip' <> " bytes but only " <> show (PBA.length sbs) <> " remain") +{-# INLINE takeUtf8Text #-} + -- | Consume exactly @n@ bytes of input, failing if fewer than @n@ bytes -- remain. skip :: Int -> Parser () diff --git a/hpgsql/src/Hpgsql/Types.hs b/hpgsql/src/Hpgsql/Types.hs index cbaa9fe..728f24b 100644 --- a/hpgsql/src/Hpgsql/Types.hs +++ b/hpgsql/src/Hpgsql/Types.hs @@ -91,9 +91,11 @@ instance FromPgField PgJson where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in \bs -> Right $ PgJson $ fixJsonb (PBA.toByteString bs), + let + -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in + \bs -> Right $ PgJson $ fixJsonb (PBA.toByteString bs), decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell PgJson type. Use a `Maybe PgJson` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } @@ -121,11 +123,13 @@ instance (FromJSON a) => FromPgField (Aeson a) where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in \bs -> case Aeson.decodeStrict $ fixJsonb (PBA.toByteString bs) of - Just v -> Right $ Aeson v - Nothing -> Left "Failed to decode the postgres JSON value into your `Aeson a` type with aeson", + let + -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in + \bs -> case Aeson.decodeStrict $ fixJsonb (PBA.toByteString bs) of + Just v -> Right $ Aeson v + Nothing -> Left "Failed to decode the postgres JSON value into your `Aeson a` type with aeson", decodesSqlNullTo = Left "Cannot decode SQL null as a Haskell (Aeson a) type. Use a `Maybe (Aeson a)` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid }