diff --git a/TODO.md b/TODO.md new file mode 100644 index 0000000..82fd6ab --- /dev/null +++ b/TODO.md @@ -0,0 +1,4 @@ +- 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.. +- Double-check which row encoders we want to use the inlined versions for and which we don't. Tuples? 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 139bd82..9150240 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 @@ -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 @@ -46,6 +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 qualified Hpgsql.Encoding as Hpgsql import qualified Hpgsql.Query as Hpgsql import qualified Hpgsql.Types as Hpgsql @@ -81,11 +83,19 @@ 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, Hpgsql.FromPgRow, PGSimple.FromRow) +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, hbrDate1 :: !Day, @@ -99,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) @@ -165,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 ( (,,,,,,,,,,,,) @@ -192,7 +208,7 @@ main = do True hasqlRecordListStmt = HasqlStmt.Statement - sql + sql17 (HasqlEnc.param (HasqlEnc.nonNullable HasqlEnc.int4)) ( HasqlDec.rowList ( HasqlBenchRow @@ -209,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)") $ @@ -228,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)") $ @@ -244,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-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-tests/EncodingDecodingSpec.hs b/hpgsql-tests/EncodingDecodingSpec.hs index 33450cb..d49bc84 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.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, 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) @@ -318,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 @@ -339,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 @@ -379,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 @@ -410,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 @@ -474,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 '\'' -> "''" @@ -516,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 @@ -550,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 @@ -588,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 @@ -638,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 @@ -647,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 diff --git a/hpgsql-tests/RowDecoderGhcCore.hs b/hpgsql-tests/RowDecoderGhcCore.hs index e53d8a5..e10493c 100644 --- a/hpgsql-tests/RowDecoderGhcCore.hs +++ b/hpgsql-tests/RowDecoderGhcCore.hs @@ -1,38 +1,60 @@ -{-# 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` --- 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 (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 +-- 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 `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 :: !(Maybe Int) } +instance FromPgRow BestCaseScenarioRecord where + rowDecoder = BestCaseScenarioRecord <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder + +-- 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 dd5378f..194d76f 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 (..), -- 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 (..), @@ -121,7 +121,8 @@ data FieldInfo = FieldInfo -- | A decoder for a single field/column. data FieldDecoder a = FieldDecoder - { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String a, + { fieldValueDecoder :: FieldInfo -> ByteString -> Either String 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,32 +159,129 @@ 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 #-} singleField :: FieldDecoder a -> RowDecoder a -singleField (FieldDecoder {..}) = - RowDecoder - { fullRowDecoder = \case - [singleColInfo] -> - let decode = 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 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)] - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", - numExpectedColumns = 1 - } +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 + -- some 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 @@ -202,11 +301,13 @@ class FromPgRow a where 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 - 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 "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 @@ -254,43 +355,43 @@ compositeTypeEncoder rowEnc = } instance (FromPgField a) => FromPgRow (Only a) where - rowDecoder = Only <$> singleField fieldDecoder + rowDecoder = Only <$> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b) => FromPgRow (a, b) where - rowDecoder = (,) <$> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c) => FromPgRow (a, b, c) where - rowDecoder = (,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder 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 = (,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder 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 = (,,,,) <$> 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 = (,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + 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 = (,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + 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 = (,,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + 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 = (,,,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + 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 = (,,,,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + 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 = (,,,,,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + 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 = (,,,,,,,,,,,) <$> 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 = (,,,,,,,,,,,) <$> 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 = (,,,,,,,,,,,,) <$> 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 = (,,,,,,,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder data FieldEncoder a = FieldEncoder { toTypeOid :: !(EncodingContext -> Maybe Oid), @@ -702,12 +803,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 @@ -742,117 +837,159 @@ binaryIntDecoder typOid = \bs -> doesFit = maxBoundPgType <= fromIntegral (maxBound @a) 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 = +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 } instance FromPgField () where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = \_oid -> \case - Just "" -> Right () - Just bs -> Left $ "Invalid value '" ++ show bs ++ "' for postgres void type" - 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 } instance FromPgField Int where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { 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`", + 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 = \FieldInfo {fieldTypeOid = oid} -> - let !decode = binaryIntDecoder oid - in \case - Just bs -> decode bs - Nothing -> Left "Cannot decode SQL null as the Haskell Int16 type. Use a `Maybe Int16`", + { 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} -> - 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`", + { 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} -> - 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`", + { 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 \case - Just bs - | oid /= numericOid -> fromIntegral <$> decodeInt bs - | otherwise -> 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 - 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 } instance FromPgField Oid where + {-# INLINE fieldDecoder #-} fieldDecoder = 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`", + 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 - fieldDecoder = parsePgType [float4Oid] $ \case - Just bs -> Right $ binaryFloat4Decoder bs - Nothing -> Left "Cannot decode SQL null as the Haskell Float type. Use a `Maybe Float`" + {-# 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 + let decoder | 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`", + 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. -- @@ -876,6 +1013,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 @@ -893,113 +1031,159 @@ scientificDecoder mustBeInteger = 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 = 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 \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 :: ByteString binaryTrue = BinSer.encodePgBoolean True +{-# INLINE boolRowDecoder #-} +boolRowDecoder :: Parser.Parser (Maybe Bool) +boolRowDecoder = fmap (== 1) <$> Parser.parsePgFieldWithAtMost4Bytes BinSer.CWord8 + 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`" + {-# 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 \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 $ 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`", + 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] $ \case - Just bs -> Right bs - Nothing -> Left "Cannot decode SQL null as the Haskell ByteString type. Use a `Maybe ByteString`" + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "byteString" [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`" + {-# 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 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`" + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ decodeUtf8 bs + + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just textDecoder instance FromPgField LT.Text where - fieldDecoder = parsePgType [textOid, varcharOid, nameOid] $ \case - Just bs -> Right $ 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`" + {-# INLINE fieldDecoder #-} + 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 $ 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`" + {-# 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 + instance FromPgField UTCTime where - fieldDecoder = parsePgType [timestamptzOid] $ \case - Just bs -> do + {-# 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 <- 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`" + + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just utcTimeRowDecoder instance FromPgField (Unbounded UTCTime) where - fieldDecoder = parsePgType [timestamptzOid] $ \case - Just bs -> do + {-# 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 <- BinSer.decodeInt64BE 0 bs Right $ @@ -1012,21 +1196,21 @@ instance FromPgField (Unbounded UTCTime) where 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)`" instance FromPgField ZonedTime where - fieldDecoder = parsePgType [timestamptzOid] $ \case - Just bs -> do + {-# 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 <- 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`" instance FromPgField (Unbounded ZonedTime) where - fieldDecoder = parsePgType [timestamptzOid] $ \case - Just bs -> do + {-# 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 <- BinSer.decodeInt64BE 0 bs Right $ @@ -1039,37 +1223,46 @@ instance FromPgField (Unbounded ZonedTime) where 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`" instance FromPgField LocalTime where - fieldDecoder = parsePgType [timestampOid] $ \case - Just bs -> do + {-# INLINE fieldDecoder #-} + 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 $ LocalTime parsedDate (timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - 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 + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "TimeOfDay" [timeOid] $ \case + 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`" + +{-# 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 - fieldDecoder = parsePgType [dateOid] $ \case - Just bs -> do + {-# 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 <- 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`" + + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just dayRowDecoder instance FromPgField (Unbounded Day) where - fieldDecoder = parsePgType [dateOid] $ \case - Just bs -> do + {-# 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 @@ -1082,25 +1275,24 @@ instance FromPgField (Unbounded Day) where then 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)`" 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 $ 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`" + {-# INLINE fieldDecoder #-} + 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 + {-# 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" - Nothing -> Left "Cannot decode SQL null as the Haskell UUID type. Use a `Maybe UUID`" instance FromPgField Aeson.Value where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = @@ -1110,10 +1302,10 @@ instance FromPgField Aeson.Value where !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id in \case - Just bs -> case Aeson.decodeStrict $ fixJsonb bs of + 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", + 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 } @@ -1123,16 +1315,38 @@ nullableField :: FieldDecoder a -> FieldDecoder (Maybe a) nullableField FieldDecoder {..} = FieldDecoder { fieldValueDecoder = \oid -> - let !origFieldValueParser = fieldValueDecoder oid - in \case - Nothing -> Right Nothing - justBs -> Just <$> origFieldValueParser justBs, + 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 @@ -1151,10 +1365,10 @@ 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))`" - Just bs -> case Parser.parseOnly arrayFieldDecoder bs of + 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 @@ -1180,10 +1394,17 @@ 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 el -> pure el + 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 @@ -1205,7 +1426,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 $ inlinedSingleFieldRowDecoder @a genericToPgRow :: forall a. (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a genericToPgRow = contramap from genRowEncoder @@ -1314,8 +1535,8 @@ rawBytesFieldDecoder :: FieldDecoder ByteString rawBytesFieldDecoder = FieldDecoder { fieldValueDecoder = \_oid -> \case - Nothing -> Left "Cannot decode SQL null as the `rawBytesFieldDecoder`." - Just bs -> Right bs, + bs -> Right bs, + decodesSqlNullTo = Left "Cannot decode SQL null as the `rawBytesFieldDecoder`.", allowedPgTypes = const True } @@ -1345,10 +1566,10 @@ arrayField !replicateFunction !elementParser = { 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 a)`" - Just bs -> case Parser.parseOnly arrayFieldDecoder bs of + 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 @@ -1367,7 +1588,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 el -> pure el + 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/Encoding/BinarySerializer.hs b/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs index cfaa2c8..a213084 100644 --- a/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs +++ b/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs @@ -22,6 +22,8 @@ module Hpgsql.Encoding.BinarySerializer encodeInt16BE, encodePgBoolean, decodeDataRow, + decodePgFieldWithAtMost4Bytes, + WordDecoding (..), ) where @@ -62,14 +64,14 @@ fromBigEndian16 = Prelude.id fromBigEndian16 = byteSwap16 #endif -data CoolWordDec a where - CWord8 :: CoolWordDec Word8 - CWord16 :: CoolWordDec Word16 - CWord32 :: CoolWordDec Word32 - CWord64 :: CoolWordDec Word64 +data WordDecoding a where + CWord8 :: WordDecoding Word8 + CWord16 :: WordDecoding Word16 + CWord32 :: WordDecoding Word32 + CWord64 :: WordDecoding Word64 {-# INLINE decodeWord #-} -decodeWord :: CoolWordDec a -> ByteStringIdx -> ByteString -> (a -> a) -> Either String a +decodeWord :: WordDecoding a -> ByteStringIdx -> ByteString -> (a -> a) -> Either String a decodeWord wdec idx (InternalBS.BS bytesPtr len) endianConvert = case wdec of CWord8 -> if len < 1 + idx.idx then Left "Less than enough bytes to decode" else Right $ endianConvert $ unsafeDupablePerformIO $ withForeignPtr bytesPtr $ \ptr -> peekByteOff (coerce ptr) idx.idx @@ -99,12 +101,12 @@ decodeWord8 :: ByteStringIdx -> ByteString -> Either String Word8 decodeWord8 idx bs = decodeWord CWord8 idx bs Prelude.id {-# INLINE decodeWord32BE #-} -decodeWord32BE :: ByteString -> Either String Word32 -decodeWord32BE bs = decodeWord CWord32 0 bs fromBigEndian32 +decodeWord32BE :: ByteStringIdx -> ByteString -> Either String Word32 +decodeWord32BE idx bs = decodeWord CWord32 idx bs fromBigEndian32 {-# INLINE decodeWord64BE #-} -decodeWord64BE :: ByteString -> Either String Word64 -decodeWord64BE bs = decodeWord CWord64 0 bs fromBigEndian64 +decodeWord64BE :: ByteStringIdx -> ByteString -> Either String Word64 +decodeWord64BE idx bs = decodeWord CWord64 idx bs fromBigEndian64 {-# INLINE decodeInt32BE #-} decodeInt32BE :: ByteStringIdx -> ByteString -> Either String Int32 @@ -130,6 +132,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" @@ -173,3 +177,50 @@ 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 #-} + +-- | 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 + CWord8 -> (1, Prelude.id, 0b00000000_00000000_00000000_00000000_11111111_00000000_00000000_00000000) + CWord16 -> (2, fromBigEndian16, 0b00000000_00000000_00000000_00000000_11111111_11111111_00000000_00000000) + CWord32 -> (4, fromBigEndian32, 0b00000000_00000000_00000000_00000000_11111111_11111111_11111111_11111111) + CWord64 -> error "Cannot try to decode 64bit words with this function" + 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 decodeWord 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 <- decodeWord 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 abac6d4..d0bc4ae 100644 --- a/hpgsql/src/Hpgsql/SimpleParser.hs +++ b/hpgsql/src/Hpgsql/SimpleParser.hs @@ -24,12 +24,23 @@ module Hpgsql.SimpleParser takeDataRow, parseManyRows, skip, + parsePgFieldWithAtMost4Bytes, + takeInt64BEWithFieldLength, + takeInt32BEWithFieldLength, + takeInt16BEWithFieldLength, + takeFloatBE, + takeDoubleBE, + takeFloatBEWithFieldLength, + peekInt32BE, ) 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 Prelude hiding (take) @@ -65,6 +76,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 #-} @@ -116,22 +134,81 @@ 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 #-} + +-- | Parses both a field length and the field itself, for +-- an Int16 in a row. +takeInt16BEWithFieldLength :: Parser (Maybe Int16) +takeInt16BEWithFieldLength = do + mi16 <- parsePgFieldWithAtMost4Bytes BinSer.CWord16 + pure $ fromIntegral <$> mi16 {-# INLINE takeInt32BE #-} 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 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 +-- an Int32 in a row. +takeInt32BEWithFieldLength :: Parser (Maybe Int32) +takeInt32BEWithFieldLength = do + mi32 <- parsePgFieldWithAtMost4Bytes BinSer.CWord32 + 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.CWord32 + pure $ castWord32ToFloat <$> mf + +{-# 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 +-- 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 -> case BinSer.decodeInt64BE idx bs of - Left err -> kf err Right v -> ks v (idx + 8) bs + Left err -> kf err {-# INLINE takeDataRow #-} @@ -143,6 +220,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 $ \idx bs kf ks -> + case dec idx bs of + 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' where diff --git a/hpgsql/src/Hpgsql/Types.hs b/hpgsql/src/Hpgsql/Types.hs index 21fb011..7a67b51 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. @@ -40,6 +41,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. @@ -63,7 +65,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 @@ -83,6 +85,7 @@ pgJsonByteString :: PgJson -> ByteString pgJsonByteString (PgJson bs) = bs instance FromPgField PgJson where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = @@ -91,11 +94,20 @@ instance FromPgField PgJson where -- 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", + \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 } + {-# 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 @@ -105,6 +117,7 @@ newtype Aeson a = Aeson {getAeson :: a} deriving newtype (Eq) instance (FromJSON a) => FromPgField (Aeson a) where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = @@ -113,13 +126,20 @@ instance (FromJSON a) => FromPgField (Aeson a) where -- 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", + \bs -> case Aeson.decodeStrict $ fixJsonb 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 } + {-# 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 =