From 941926fd0fc7cba830eace847ba3cd7e14ec2340 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 8 Aug 2026 18:39:01 -0300 Subject: [PATCH 01/38] Claude-written rust benchmarks using tokio-postgres --- hpgsql-benchmarks/src/Main.hs | 4 + rust-bench/src/main.rs | 137 ++++++++++++++++++++++++++++++++++ shell.nix | 2 + 3 files changed, 143 insertions(+) create mode 100644 rust-bench/src/main.rs diff --git a/hpgsql-benchmarks/src/Main.hs b/hpgsql-benchmarks/src/Main.hs index 6301649..c28406b 100644 --- a/hpgsql-benchmarks/src/Main.hs +++ b/hpgsql-benchmarks/src/Main.hs @@ -91,6 +91,10 @@ data BenchRow = BenchRow deriving stock (Generic, Show, Eq) deriving anyclass (NFData, Hpgsql.FromPgRow, PGSimple.FromRow) +singleFieldFieldDecoderBenchRowDecoder :: Hpgsql.RowDecoder BenchRow +singleFieldFieldDecoderBenchRowDecoder = + BenchRow <$> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder + data HasqlBenchRow = HasqlBenchRow { hbrId :: !Int32, hbrDate1 :: !Day, diff --git a/rust-bench/src/main.rs b/rust-bench/src/main.rs new file mode 100644 index 0000000..2b7fb9b --- /dev/null +++ b/rust-bench/src/main.rs @@ -0,0 +1,137 @@ +use chrono::{DateTime, NaiveDate, Utc}; +use futures_util::{pin_mut, TryStreamExt}; +use rust_decimal::Decimal; +use std::env; +use std::hint::black_box; +use std::time::Instant; +use tokio_postgres::types::ToSql; +use tokio_postgres::NoTls; + +// Mirrors hpgsql-benchmarks/src/Main.hs's BenchRow / sql17 query, and its +// benchmark methodology: 2 concurrent connections, each running the query +// once per round, repeated for 10 rounds, with total wall-clock time +// reported across all 10 rounds (see `bench`/`withMultipleConnections` in +// that file). +#[derive(Debug)] +#[allow(dead_code)] +struct BenchRow { + id: i32, + date1: NaiveDate, + date2: NaiveDate, + timestamp1: DateTime, + timestamp2: DateTime, + text1: String, + text2: String, + double1: f64, + double2: f64, + maybe_int: Option, + maybe_text: Option, + maybe_double: Option, + maybe_date: Option, + numeric: Decimal, + float: f32, + bool1: bool, + bool2: bool, +} + +const SQL17: &str = "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"; + +const N: i32 = 100_000; +const NUM_CONCURRENT_CONNECTIONS: usize = 2; +const NUM_ROUNDS: usize = 10; + +fn conn_string() -> Result> { + let host = env::var("PGHOST")?; + let port: u16 = env::var("PGPORT")?.parse()?; + let dbname = env::var("PGDATABASE")?; + let user = env::var("PGUSER")?; + Ok(format!("host={host} port={port} dbname={dbname} user={user}")) +} + +// Connects fresh, prepares and streams SQL17's results once (decoding each +// row as it arrives, never collecting them into a Vec), then drops the +// connection -- mirroring `acquireConn` + one `querySWith`/`S.effects` call + +// `closeConn` in `withMultipleConnections`. +async fn run_once(conn_string: String) -> Result> { + let (client, connection) = tokio_postgres::connect(&conn_string, NoTls).await?; + + let connection_task = tokio::spawn(connection); + + let stmt = client.prepare(SQL17).await?; + let params: [&(dyn ToSql + Sync); 1] = [&N]; + let stream = client.query_raw(&stmt, params).await?; + pin_mut!(stream); + + let mut count = 0usize; + while let Some(row) = stream.try_next().await? { + // Decode every field, same as materializing a BenchRow would, but + // discard it immediately instead of collecting into a Vec. + black_box(BenchRow { + id: row.get(0), + date1: row.get(1), + date2: row.get(2), + timestamp1: row.get(3), + timestamp2: row.get(4), + text1: row.get(5), + text2: row.get(6), + double1: row.get(7), + double2: row.get(8), + maybe_int: row.get(9), + maybe_text: row.get(10), + maybe_double: row.get(11), + maybe_date: row.get(12), + numeric: row.get(13), + float: row.get(14), + bool1: row.get(15), + bool2: row.get(16), + }); + count += 1; + } + + drop(client); + let _ = connection_task.await; + + Ok(count) +} + +#[tokio::main] +async fn main() -> Result<(), Box> { + let conn_string = conn_string()?; + + // Warm up postgres before any timed measurement, mirroring the Haskell + // benchmark's warm-up connection. + { + let (client, connection) = tokio_postgres::connect(&conn_string, NoTls).await?; + let connection_task = tokio::spawn(connection); + client.execute("SELECT * FROM generate_series(1,100000)", &[]).await?; + drop(client); + let _ = connection_task.await; + } + + println!( + "Running {NUM_ROUNDS} rounds of {NUM_CONCURRENT_CONNECTIONS} concurrent connections each running the query once..." + ); + + let start = Instant::now(); + let mut total_rows = 0usize; + for _round in 0..NUM_ROUNDS { + let tasks: Vec<_> = (0..NUM_CONCURRENT_CONNECTIONS) + .map(|_| tokio::spawn(run_once(conn_string.clone()))) + .collect(); + for task in tasks { + total_rows += task.await??; + } + } + let elapsed = start.elapsed(); + + println!("Decoded {total_rows} rows total across {NUM_ROUNDS} rounds"); + println!("Wall clock time (total across {NUM_ROUNDS} rounds): {elapsed:?}"); + + Ok(()) +} diff --git a/shell.nix b/shell.nix index 06fb82b..d82efc9 100644 --- a/shell.nix +++ b/shell.nix @@ -13,6 +13,8 @@ in packages = p: with p; [ hpgsql hpgsql-tests hpgsql-benchmarks hpgsql-simple-compat hpgsql-simple-compat-tests ]; withHoogle = true; buildInputs = with pkgs; [ + cargo + rustc concurrently haskellPackages.cabal-install haskellPackages.ghcid From 7ff38f0e16d949d8928a4be383042ef54e9a5f37 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 5 Sep 2026 11:20:06 -0300 Subject: [PATCH 02/38] Improve benchmarks and peak memory measurement methodology --- BENCHMARKS.md | 13 +++ scripts/run-benchmarks-db-internal.sh | 140 ++++++++++++++++++++++++++ 2 files changed, 153 insertions(+) create mode 100755 scripts/run-benchmarks-db-internal.sh diff --git a/BENCHMARKS.md b/BENCHMARKS.md index feff5bb..a82c381 100644 --- a/BENCHMARKS.md +++ b/BENCHMARKS.md @@ -14,6 +14,19 @@ This is unfair towards libpq-based libraries in the comparison because hpgsql ha The Rust (tokio-postgres) benchmark's `peak_memory_upper_bound` is measured only by heaptrack, making it a precise peak, not an upper bound. +# Methodology for measuring peak memory usage + +Wall clock time shown in these benchmarks should be reliable as we force garbage collection inside each benchmark. + +Peak memory usage, however, is far trickier to measure. We use heaptrack to intercept and account for libc's allocation primitives, but the GHC runtime does not use `malloc` for its regular allocations, but does use it for ~72MB of allocations at application startup. Some of the libraries we compare to also use libpq, which uses `malloc` under the hood. +So we use `peak_live_rts_memory + heaptrack_peak_memory - heaptrack_peak_memory_after_app_init` as the measure of peak memory for a given benchmark. This discards the initial memory allocated by the RTS regardless of what the app does, ignores extra memory used by the GC during copying (which I consider just a byproduct of memory allocation) but still accounts for memory allocated by the RTS and by libpq. + +The downside of this approach is that peak memories as measured by both the GHC runtime and heaptrack may be collected at different points in time, so we're effectively measuring an upper bound on peak memory allocated. + +This is unfair towards libpq-based libraries in the comparison because hpgsql has no libc allocations at all, so it's precise for hpgsql, but an upper bound for the others. To somewhat counter that, we also measure peak live Haskell allocated memory independently, and total Haskell allocated memory as an even more distant proxy. Together, these can help us debug whether the upper bounds might be too far off. + +The Rust (tokio-postgres) benchmark's `peak_memory_upper_bound` is measured only by heaptrack, making it a precise peak, not an upper bound. + > [!WARNING] > I'm no expert using some of these libraries, so be careful interpreting results. I also welcome scrutiny and contributions. > Noteworthy: diff --git a/scripts/run-benchmarks-db-internal.sh b/scripts/run-benchmarks-db-internal.sh new file mode 100755 index 0000000..eed7c7b --- /dev/null +++ b/scripts/run-benchmarks-db-internal.sh @@ -0,0 +1,140 @@ +#!/usr/bin/env bash + +TABLE_HEADER="| name | wall_clock_time | peak_live_rts_memory | peak_memory_upper_bound | total_haskell_memory_allocated |" +TABLE_SEPARATOR="|---|---|---|---|---|" + +# Creates the markdown table file with a header if it doesn't already exist, +# so that calling this for a file shared by multiple run_bench/run_rust_bench +# calls (e.g. record_stream_bench.md) doesn't duplicate the header. +init_table() { + local table_file="$1" + local path="benchmark-results/$table_file" + if [ ! -f "$path" ]; then + echo "$TABLE_HEADER" > "$path" + echo "$TABLE_SEPARATOR" >> "$path" + fi +} + +# Converts a heaptrack-formatted size string (e.g. "72.07M", "1.2G", "512K", +# "0B") to a plain number of megabytes, so it can be combined arithmetically +# with peak_live_rts_memory (already reported in MB by the benchmark +# executable itself). +to_mb() { + local val="$1" + awk -v v="$val" 'BEGIN { + unit = substr(v, length(v), 1) + if (unit ~ /[A-Za-z]/) { + num = substr(v, 1, length(v) - 1) + 0 + } else { + unit = "B" + num = v + 0 + } + if (unit == "G") printf "%.4f", num * 1024 + else if (unit == "K") printf "%.4f", num / 1024 + else if (unit == "B") printf "%.4f", num / 1024 / 1024 + else printf "%.4f", num + }' +} + +run_bench() { + local table_file="$1" + init_table "$table_file" + shift + local bench_names=("$@") + for b in "${bench_names[@]}"; do + echo "$b" + # Measure wall-clock time without heaptrack to avoid interference + # Capture stdout to extract RTS peak live data + BENCH_OUTPUT=$("$benchexe" --match "$b" 2>&1) + # criterion's `secs` picks whichever unit fits (s/ms/μs/...), with a space + # between the number and the unit -- keep the unit, drop the space. + WALLCLOCK_TIME=$(echo "$BENCH_OUTPUT" | grep -oP '(?<=Wall time=)[0-9.]+ \S+(?=,)' | tr -d ' ') + PEAK_LIVE_MB=$(echo "$BENCH_OUTPUT" | grep -oP '(?<=--- Peak live data \(max_live_bytes\): )\S+') + # Sanity-check signal alongside peak_memory_upper_bound_mb (see + # BENCHMARKS.md): cumulative bytes allocated over the whole run, as + # opposed to a peak. Only available on the Haskell side (GHC.Stats), since + # heaptrack has no comparable "total ever allocated" figure to report. + TOTAL_ALLOCATED_MB=$(echo "$BENCH_OUTPUT" | grep -oP '(?<=memory allocated=)\S+(?= MB\.)') + + # Now run with heaptrack to track peak heap memory usage + heaptrack --record-only -o "benchmark-results/heaptrack.outdat" "$benchexe" --match "$b" 2>/dev/null + PEAKHEAP=$(heaptrack_print -f "benchmark-results/heaptrack.outdat.zst" | grep "peak heap memory consumption:" | awk -F': ' '{print $2}') + mv "benchmark-results/heaptrack.outdat.zst" "benchmark-results/$b.outdat.zst" + + # See "Methodology for measuring peak memory usage" in BENCHMARKS.md: this + # discards the app-init floor (mostly GHC's per-capability eventlog + # buffers, which heaptrack does see since they're malloc'd) from + # heaptrack's peak, then adds back the RTS's own peak live Haskell heap + # (which heaptrack can't see, since it's mmap'd megablocks, not malloc). + # It's an upper bound, not an exact simultaneous peak, since the two peaks + # may occur at different times. + ESTIMATED_PEAK_MB=$(awk -v live="$PEAK_LIVE_MB" -v heap="$(to_mb "$PEAKHEAP")" -v floor="$APP_INIT_PEAK_MB" 'BEGIN{printf "%.1f", live + heap - floor}') + + echo "| $b | $WALLCLOCK_TIME | ${PEAK_LIVE_MB}MB | ${ESTIMATED_PEAK_MB}MB | ${TOTAL_ALLOCATED_MB}MB |" >> "benchmark-results/$table_file" + done +} + +# Like run_bench, but for the Rust (tokio-postgres) benchmark executable, which +# has no --match flag (it only runs the one benchmark it was built with) and, +# having no GHC runtime, cannot report peak_live_rts_memory or +# total_haskell_memory_allocated_mb -- those are left as "-" for its row. +run_rust_bench() { + local table_file="$1" + local bench_name="$2" + init_table "$table_file" + echo "$bench_name" + + BENCH_OUTPUT=$("$rust_benchexe" 2>&1) + # Rust's Duration Debug format has no space between the number and whichever + # unit fits (ns/µs/ms/s), so a plain non-whitespace token captures both. + WALLCLOCK_TIME=$(echo "$BENCH_OUTPUT" | sed -n 's/^Wall clock time[^:]*: \(\S\+\).*/\1/p') + + # Still record with heaptrack so the profile is available for manual + # analysis, in addition to the peak reported below. + heaptrack --record-only -o "benchmark-results/heaptrack.outdat" "$rust_benchexe" 2>/dev/null + PEAKHEAP=$(heaptrack_print -f "benchmark-results/heaptrack.outdat.zst" | grep "peak heap memory consumption:" | awk -F': ' '{print $2}') + mv "benchmark-results/heaptrack.outdat.zst" "benchmark-results/$bench_name.outdat.zst" + + # Unlike GHC, Rust's default allocator routes through malloc, so heaptrack + # sees essentially all of its heap -- there's no GC-managed chunk hidden + # from it the way there is for the Haskell benchmarks. So this is a precise + # peak, not one term of an upper-bound estimate, and no floor subtraction + # applies (that floor is specific to the Haskell binary's own GHC RTS and + # linked C libraries, and has no meaning for this unrelated executable). + ESTIMATED_PEAK_MB=$(awk -v v="$(to_mb "$PEAKHEAP")" 'BEGIN{printf "%.1f", v}') + + echo "| $bench_name | $WALLCLOCK_TIME | - | ${ESTIMATED_PEAK_MB}MB | - |" >> "benchmark-results/$table_file" +} + +record_list_bench=("postgresql-simple Record List (100000 rows, Generically derived row decoder)" "hasql Record List (100000 rows)" "hpgsql Record List (100000 rows, Generically derived row decoder)") +tuple_list_bench=("postgresql-simple Tuple List (100000 rows)" "hasql Tuple List (100000 rows)" "hpgsql Tuple List (100000 rows)") +record_stream_bench=("streaming-postgresql-simple Record Stream (100000 rows, Generically derived row decoder)" "postgresql-simple Record fold (100000 rows, Generically derived row decoder)" "hpgsql Record Stream (100000 rows, Generically derived row decoder)") +tuple_stream_bench=("streaming-postgresql-simple Tuple Stream (100000 rows)" "postgresql-simple Tuple fold (100000 rows)" "hpgsql Tuple Stream (100000 rows)") +copy_bench=("postgresql-simple text COPY (100000 rows)" "hpgsql copyFromS binary COPY (100000 rows)") + +# Wipe the folder, recreate it and run the benchmarks +rm benchmark-results -rf +mkdir benchmark-results +benchexe=$(cabal list-bin hpgsql-benchmarks) +rust_benchexe="./rust-bench/target/release/rust-bench" + +# Measure the app-init memory floor once for the whole run: this matches no +# benchmark name, so hspec starts up the GHC RTS and immediately exits without +# running any benchmark's DB connections/queries. This floor is workload- +# independent (see BENCHMARKS.md), so collecting it once and reusing it for +# every benchmark below is both cheaper and more correct than remeasuring it +# per benchmark. +heaptrack --record-only -o "benchmark-results/heaptrack.outdat" "$benchexe" --match "no benchmark name matches this" 2>/dev/null +APP_INIT_PEAK_MB=$(to_mb "$(heaptrack_print -f "benchmark-results/heaptrack.outdat.zst" | grep "peak heap memory consumption:" | awk -F': ' '{print $2}')") +mv "benchmark-results/heaptrack.outdat.zst" "benchmark-results/app-init-baseline.outdat.zst" +echo "App-init heap memory floor (subtracted from every benchmark's heaptrack peak below): ${APP_INIT_PEAK_MB} M" + +run_bench record_list_bench.md "${record_list_bench[@]}" +run_bench tuple_list_bench.md "${tuple_list_bench[@]}" +run_bench record_stream_bench.md "${record_stream_bench[@]}" +run_bench tuple_stream_bench.md "${tuple_stream_bench[@]}" +run_bench copy_bench.md "${copy_bench[@]}" + +# rust-bench mirrors hpgsql's Record Stream benchmark (streamed, generically +# decoded rows, discarded as they arrive), so its result is recorded alongside it. +run_rust_bench record_stream_bench.md "rust-tokio-postgres Record Stream (100000 rows)" From fb638727bd408cdfcf0030b53ba9b076539338fa Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 5 Sep 2026 11:31:55 -0300 Subject: [PATCH 03/38] Tidy up --- hpgsql-benchmarks/src/Main.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/hpgsql-benchmarks/src/Main.hs b/hpgsql-benchmarks/src/Main.hs index c28406b..6301649 100644 --- a/hpgsql-benchmarks/src/Main.hs +++ b/hpgsql-benchmarks/src/Main.hs @@ -91,10 +91,6 @@ data BenchRow = BenchRow deriving stock (Generic, Show, Eq) deriving anyclass (NFData, Hpgsql.FromPgRow, PGSimple.FromRow) -singleFieldFieldDecoderBenchRowDecoder :: Hpgsql.RowDecoder BenchRow -singleFieldFieldDecoderBenchRowDecoder = - BenchRow <$> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder - data HasqlBenchRow = HasqlBenchRow { hbrId :: !Int32, hbrDate1 :: !Day, From d5b6943a6d971de87a575a6895a655703250949c Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 5 Sep 2026 20:10:50 -0300 Subject: [PATCH 04/38] A special Nix shell for benchmarks So cargo and rustc aren't necessary for the development shell --- scripts/run-benchmarks-db-internal.sh | 4 ++++ shell.nix | 2 -- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/scripts/run-benchmarks-db-internal.sh b/scripts/run-benchmarks-db-internal.sh index eed7c7b..9ef454b 100755 --- a/scripts/run-benchmarks-db-internal.sh +++ b/scripts/run-benchmarks-db-internal.sh @@ -112,6 +112,10 @@ record_stream_bench=("streaming-postgresql-simple Record Stream (100000 rows, Ge tuple_stream_bench=("streaming-postgresql-simple Tuple Stream (100000 rows)" "postgresql-simple Tuple fold (100000 rows)" "hpgsql Tuple Stream (100000 rows)") copy_bench=("postgresql-simple text COPY (100000 rows)" "hpgsql copyFromS binary COPY (100000 rows)") +# Compile executables +cabal build hpgsql-benchmarks +cargo build --release --manifest-path rust-bench/Cargo.toml + # Wipe the folder, recreate it and run the benchmarks rm benchmark-results -rf mkdir benchmark-results diff --git a/shell.nix b/shell.nix index d82efc9..06fb82b 100644 --- a/shell.nix +++ b/shell.nix @@ -13,8 +13,6 @@ in packages = p: with p; [ hpgsql hpgsql-tests hpgsql-benchmarks hpgsql-simple-compat hpgsql-simple-compat-tests ]; withHoogle = true; buildInputs = with pkgs; [ - cargo - rustc concurrently haskellPackages.cabal-install haskellPackages.ghcid From 706635670aff7ef422fbaf49f3c34c873b30d490 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 5 Sep 2026 22:20:37 -0300 Subject: [PATCH 05/38] Add a C# benchmark --- BENCHMARKS.md | 13 --------- scripts/run-benchmarks-db-internal.sh | 42 +++++++++++++++++++++++++-- 2 files changed, 40 insertions(+), 15 deletions(-) diff --git a/BENCHMARKS.md b/BENCHMARKS.md index a82c381..feff5bb 100644 --- a/BENCHMARKS.md +++ b/BENCHMARKS.md @@ -14,19 +14,6 @@ This is unfair towards libpq-based libraries in the comparison because hpgsql ha The Rust (tokio-postgres) benchmark's `peak_memory_upper_bound` is measured only by heaptrack, making it a precise peak, not an upper bound. -# Methodology for measuring peak memory usage - -Wall clock time shown in these benchmarks should be reliable as we force garbage collection inside each benchmark. - -Peak memory usage, however, is far trickier to measure. We use heaptrack to intercept and account for libc's allocation primitives, but the GHC runtime does not use `malloc` for its regular allocations, but does use it for ~72MB of allocations at application startup. Some of the libraries we compare to also use libpq, which uses `malloc` under the hood. -So we use `peak_live_rts_memory + heaptrack_peak_memory - heaptrack_peak_memory_after_app_init` as the measure of peak memory for a given benchmark. This discards the initial memory allocated by the RTS regardless of what the app does, ignores extra memory used by the GC during copying (which I consider just a byproduct of memory allocation) but still accounts for memory allocated by the RTS and by libpq. - -The downside of this approach is that peak memories as measured by both the GHC runtime and heaptrack may be collected at different points in time, so we're effectively measuring an upper bound on peak memory allocated. - -This is unfair towards libpq-based libraries in the comparison because hpgsql has no libc allocations at all, so it's precise for hpgsql, but an upper bound for the others. To somewhat counter that, we also measure peak live Haskell allocated memory independently, and total Haskell allocated memory as an even more distant proxy. Together, these can help us debug whether the upper bounds might be too far off. - -The Rust (tokio-postgres) benchmark's `peak_memory_upper_bound` is measured only by heaptrack, making it a precise peak, not an upper bound. - > [!WARNING] > I'm no expert using some of these libraries, so be careful interpreting results. I also welcome scrutiny and contributions. > Noteworthy: diff --git a/scripts/run-benchmarks-db-internal.sh b/scripts/run-benchmarks-db-internal.sh index 9ef454b..9c3f4d8 100755 --- a/scripts/run-benchmarks-db-internal.sh +++ b/scripts/run-benchmarks-db-internal.sh @@ -1,6 +1,6 @@ #!/usr/bin/env bash -TABLE_HEADER="| name | wall_clock_time | peak_live_rts_memory | peak_memory_upper_bound | total_haskell_memory_allocated |" +TABLE_HEADER="| name | wall_clock_time | peak_live_rts_memory | peak_memory_upper_bound | total_managed_memory_allocated |" TABLE_SEPARATOR="|---|---|---|---|---|" # Creates the markdown table file with a header if it doesn't already exist, @@ -74,10 +74,30 @@ run_bench() { done } +# Like run_bench, but for the C# (Npgsql) benchmark executable, which has no +# --match flag (it only runs the one benchmark it was built with). Its two +# peak-memory columns are left as "-": .NET's GC.GetTotalMemory is a snapshot, +# not a tracked running maximum like GHC's max_live_bytes, so it can't be +# relied on the same way, and there's no floor-subtracted heaptrack estimate +# to fall back on either. Only wall-clock time and total allocated bytes are +# reported. +run_csharp_bench() { + local table_file="$1" + local bench_name="$2" + init_table "$table_file" + echo "$bench_name" + + BENCH_OUTPUT=$("${csharp_benchexe[@]}" 2>&1) + WALLCLOCK_TIME=$(echo "$BENCH_OUTPUT" | grep -oP '(?<=Wall time=)[0-9.]+ \S+(?=,)' | tr -d ' ') + TOTAL_ALLOCATED_MB=$(echo "$BENCH_OUTPUT" | grep -oP '(?<=memory allocated=)\S+(?= MB\.)') + + echo "| $bench_name | $WALLCLOCK_TIME | - | - | ${TOTAL_ALLOCATED_MB}MB |" >> "benchmark-results/$table_file" +} + # Like run_bench, but for the Rust (tokio-postgres) benchmark executable, which # has no --match flag (it only runs the one benchmark it was built with) and, # having no GHC runtime, cannot report peak_live_rts_memory or -# total_haskell_memory_allocated_mb -- those are left as "-" for its row. +# total_managed_memory_allocated -- those are left as "-" for its row. run_rust_bench() { local table_file="$1" local bench_name="$2" @@ -115,12 +135,19 @@ copy_bench=("postgresql-simple text COPY (100000 rows)" "hpgsql copyFromS binary # Compile executables cabal build hpgsql-benchmarks cargo build --release --manifest-path rust-bench/Cargo.toml +dotnet build -c Release csharp-benchmarks/CsharpBenchmarks.csproj # Wipe the folder, recreate it and run the benchmarks rm benchmark-results -rf mkdir benchmark-results benchexe=$(cabal list-bin hpgsql-benchmarks) rust_benchexe="./rust-bench/target/release/rust-bench" +# Invoked via `dotnet ` rather than the native apphost binary directly: +# the apphost can't locate libhostfxr.so outside of a `dotnet run`/`dotnet +# exec` context (e.g. under nix-shell), and fails silently as far as this +# script is concerned (its stdout carries only an error message, so +# BENCH_OUTPUT's greps below all come up empty instead of erroring loudly). +csharp_benchexe=(dotnet "./csharp-benchmarks/bin/Release/net8.0/CsharpBenchmarks.dll") # Measure the app-init memory floor once for the whole run: this matches no # benchmark name, so hspec starts up the GHC RTS and immediately exits without @@ -133,6 +160,13 @@ APP_INIT_PEAK_MB=$(to_mb "$(heaptrack_print -f "benchmark-results/heaptrack.outd mv "benchmark-results/heaptrack.outdat.zst" "benchmark-results/app-init-baseline.outdat.zst" echo "App-init heap memory floor (subtracted from every benchmark's heaptrack peak below): ${APP_INIT_PEAK_MB} M" +# Same idea as above, but for the C# binary's own CLR + Npgsql startup +# floor, which is unrelated to (and measured separately from) GHC's floor. +CSHARP_BENCH_FLOOR_ONLY=1 heaptrack --record-only -o "benchmark-results/heaptrack.outdat" "${csharp_benchexe[@]}" 2>/dev/null +CSHARP_APP_INIT_PEAK_MB=$(to_mb "$(heaptrack_print -f "benchmark-results/heaptrack.outdat.zst" | grep "peak heap memory consumption:" | awk -F': ' '{print $2}')") +mv "benchmark-results/heaptrack.outdat.zst" "benchmark-results/csharp-app-init-baseline.outdat.zst" +echo "C# app-init heap memory floor (subtracted from the C# benchmark's heaptrack peak below): ${CSHARP_APP_INIT_PEAK_MB} M" + run_bench record_list_bench.md "${record_list_bench[@]}" run_bench tuple_list_bench.md "${tuple_list_bench[@]}" run_bench record_stream_bench.md "${record_stream_bench[@]}" @@ -142,3 +176,7 @@ run_bench copy_bench.md "${copy_bench[@]}" # rust-bench mirrors hpgsql's Record Stream benchmark (streamed, generically # decoded rows, discarded as they arrive), so its result is recorded alongside it. run_rust_bench record_stream_bench.md "rust-tokio-postgres Record Stream (100000 rows)" + +# The Npgsql benchmark also mirrors hpgsql's Record Stream benchmark (same 17 +# columns, streamed and discarded as they arrive), so it joins the same table. +run_csharp_bench record_stream_bench.md "Npgsql Record Stream (100000 rows)" From 2fd85dcb93ce17943f0c022626a1b0923eec9c78 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 5 Sep 2026 22:44:12 -0300 Subject: [PATCH 06/38] Tidy up a bit more --- rust-bench/src/main.rs | 19 ++- scripts/run-benchmarks-db-internal.sh | 213 +++++++++++++------------- 2 files changed, 127 insertions(+), 105 deletions(-) diff --git a/rust-bench/src/main.rs b/rust-bench/src/main.rs index 2b7fb9b..671febe 100644 --- a/rust-bench/src/main.rs +++ b/rust-bench/src/main.rs @@ -46,6 +46,19 @@ const N: i32 = 100_000; const NUM_CONCURRENT_CONNECTIONS: usize = 2; const NUM_ROUNDS: usize = 10; +// Matches Main.hs's/Program.cs's "Wall time= ," convention (a +// space before the unit, unlike Duration's Debug format) so the benchmark +// runner script can grep all three languages' output with the same pattern. +fn format_secs(s: f64) -> String { + if s < 0.001 { + format!("{:.1} μs", s * 1_000_000.0) + } else if s < 1.0 { + format!("{:.1} ms", s * 1000.0) + } else { + format!("{:.3} s", s) + } +} + fn conn_string() -> Result> { let host = env::var("PGHOST")?; let port: u16 = env::var("PGPORT")?.parse()?; @@ -130,8 +143,10 @@ async fn main() -> Result<(), Box> { } let elapsed = start.elapsed(); - println!("Decoded {total_rows} rows total across {NUM_ROUNDS} rounds"); - println!("Wall clock time (total across {NUM_ROUNDS} rounds): {elapsed:?}"); + println!( + "--- Benchmark rust-tokio-postgres Record Stream: Wall time={}, decoded {total_rows} rows total across {NUM_ROUNDS} rounds.", + format_secs(elapsed.as_secs_f64()) + ); Ok(()) } diff --git a/scripts/run-benchmarks-db-internal.sh b/scripts/run-benchmarks-db-internal.sh index 9c3f4d8..aaffe1d 100755 --- a/scripts/run-benchmarks-db-internal.sh +++ b/scripts/run-benchmarks-db-internal.sh @@ -3,16 +3,19 @@ TABLE_HEADER="| name | wall_clock_time | peak_live_rts_memory | peak_memory_upper_bound | total_managed_memory_allocated |" TABLE_SEPARATOR="|---|---|---|---|---|" -# Creates the markdown table file with a header if it doesn't already exist, -# so that calling this for a file shared by multiple run_bench/run_rust_bench -# calls (e.g. record_stream_bench.md) doesn't duplicate the header. -init_table() { - local table_file="$1" - local path="benchmark-results/$table_file" - if [ ! -f "$path" ]; then - echo "$TABLE_HEADER" > "$path" - echo "$TABLE_SEPARATOR" >> "$path" - fi +# Converts a fused "" wall-clock string (e.g. "14.69s", +# "895.5ms", "0.2μs") into milliseconds, so rows can be sorted slowest-to- +# fastest regardless of which unit each language picked for that row. +time_to_ms() { + local val="$1" + awk -v v="$val" 'BEGIN { + n = v + 0 + if (v ~ /ms$/) printf "%.6f", n + else if (v ~ /(μs|us)$/) printf "%.6f", n / 1000 + else if (v ~ /ns$/) printf "%.6f", n / 1000000 + else if (v ~ /s$/) printf "%.6f", n * 1000 + else printf "%.6f", 0 + }' } # Converts a heaptrack-formatted size string (e.g. "72.07M", "1.2G", "512K", @@ -36,94 +39,98 @@ to_mb() { }' } -run_bench() { - local table_file="$1" - init_table "$table_file" - shift - local bench_names=("$@") - for b in "${bench_names[@]}"; do - echo "$b" - # Measure wall-clock time without heaptrack to avoid interference - # Capture stdout to extract RTS peak live data - BENCH_OUTPUT=$("$benchexe" --match "$b" 2>&1) - # criterion's `secs` picks whichever unit fits (s/ms/μs/...), with a space - # between the number and the unit -- keep the unit, drop the space. - WALLCLOCK_TIME=$(echo "$BENCH_OUTPUT" | grep -oP '(?<=Wall time=)[0-9.]+ \S+(?=,)' | tr -d ' ') - PEAK_LIVE_MB=$(echo "$BENCH_OUTPUT" | grep -oP '(?<=--- Peak live data \(max_live_bytes\): )\S+') - # Sanity-check signal alongside peak_memory_upper_bound_mb (see - # BENCHMARKS.md): cumulative bytes allocated over the whole run, as - # opposed to a peak. Only available on the Haskell side (GHC.Stats), since - # heaptrack has no comparable "total ever allocated" figure to report. - TOTAL_ALLOCATED_MB=$(echo "$BENCH_OUTPUT" | grep -oP '(?<=memory allocated=)\S+(?= MB\.)') - - # Now run with heaptrack to track peak heap memory usage - heaptrack --record-only -o "benchmark-results/heaptrack.outdat" "$benchexe" --match "$b" 2>/dev/null - PEAKHEAP=$(heaptrack_print -f "benchmark-results/heaptrack.outdat.zst" | grep "peak heap memory consumption:" | awk -F': ' '{print $2}') - mv "benchmark-results/heaptrack.outdat.zst" "benchmark-results/$b.outdat.zst" - - # See "Methodology for measuring peak memory usage" in BENCHMARKS.md: this - # discards the app-init floor (mostly GHC's per-capability eventlog - # buffers, which heaptrack does see since they're malloc'd) from - # heaptrack's peak, then adds back the RTS's own peak live Haskell heap - # (which heaptrack can't see, since it's mmap'd megablocks, not malloc). - # It's an upper bound, not an exact simultaneous peak, since the two peaks - # may occur at different times. - ESTIMATED_PEAK_MB=$(awk -v live="$PEAK_LIVE_MB" -v heap="$(to_mb "$PEAKHEAP")" -v floor="$APP_INIT_PEAK_MB" 'BEGIN{printf "%.1f", live + heap - floor}') - - echo "| $b | $WALLCLOCK_TIME | ${PEAK_LIVE_MB}MB | ${ESTIMATED_PEAK_MB}MB | ${TOTAL_ALLOCATED_MB}MB |" >> "benchmark-results/$table_file" - done +# Renders an MB value for a table cell, or "-" when the value is absent (the +# benchmark's own stdout didn't report that metric at all, or its heaptrack +# peak was skipped -- see run_bench below). +fmt_mb() { + if [ -n "$1" ]; then echo "${1}MB"; else echo "-"; fi } -# Like run_bench, but for the C# (Npgsql) benchmark executable, which has no -# --match flag (it only runs the one benchmark it was built with). Its two -# peak-memory columns are left as "-": .NET's GC.GetTotalMemory is a snapshot, -# not a tracked running maximum like GHC's max_live_bytes, so it can't be -# relied on the same way, and there's no floor-subtracted heaptrack estimate -# to fall back on either. Only wall-clock time and total allocated bytes are -# reported. -run_csharp_bench() { +# Runs one benchmark and appends a row to a markdown table. All three +# languages' benchmark executables print output in a shared shape -- +# "Wall time= ," and (Haskell only) "memory allocated= +# MB." -- so the same greps work across all of them, and a metric a given +# language doesn't report simply comes up empty (rendered as "-"). +# +# `floor` controls whether/how a heaptrack-based peak_memory_upper_bound is +# computed (see "Methodology for measuring peak memory usage" in +# BENCHMARKS.md): +# - a number: subtract this app-init floor from heaptrack's peak, then add +# back peak_live_rts_memory (Haskell's upper-bound estimate, since its GC +# heap is invisible to heaptrack). +# - "0": no floor to subtract, just report heaptrack's raw peak (Rust, +# whose default allocator is malloc-backed so heaptrack sees ~all of it). +# - "" (empty): skip heaptrack entirely, leave peak_memory_upper_bound as +# "-" (C#, whose GC.GetTotalMemory can't be trusted as a true peak the +# way GHC's max_live_bytes can -- see BENCHMARKS.md). +run_bench() { local table_file="$1" local bench_name="$2" - init_table "$table_file" + local floor="$3" + shift 3 + local cmd=("$@") echo "$bench_name" - BENCH_OUTPUT=$("${csharp_benchexe[@]}" 2>&1) + BENCH_OUTPUT=$("${cmd[@]}" 2>&1) + # Each language picks whichever time unit fits (s/ms/μs/...), with a space + # between the number and the unit -- keep the unit, drop the space. WALLCLOCK_TIME=$(echo "$BENCH_OUTPUT" | grep -oP '(?<=Wall time=)[0-9.]+ \S+(?=,)' | tr -d ' ') + PEAK_LIVE_MB=$(echo "$BENCH_OUTPUT" | grep -oP '(?<=--- Peak live data \(max_live_bytes\): )\S+') TOTAL_ALLOCATED_MB=$(echo "$BENCH_OUTPUT" | grep -oP '(?<=memory allocated=)\S+(?= MB\.)') - echo "| $bench_name | $WALLCLOCK_TIME | - | - | ${TOTAL_ALLOCATED_MB}MB |" >> "benchmark-results/$table_file" + local peak_upper_mb="" + if [ -n "$floor" ]; then + heaptrack --record-only -o "benchmark-results/heaptrack.outdat" "${cmd[@]}" 2>/dev/null + local peakheap + peakheap=$(heaptrack_print -f "benchmark-results/heaptrack.outdat.zst" | grep "peak heap memory consumption:" | awk -F': ' '{print $2}') + mv "benchmark-results/heaptrack.outdat.zst" "benchmark-results/$bench_name.outdat.zst" + peak_upper_mb=$(awk -v live="${PEAK_LIVE_MB:-0}" -v heap="$(to_mb "$peakheap")" -v floor="$floor" 'BEGIN{printf "%.1f", live + heap - floor}') + fi + + # Italicize hpgsql's own row so it stands out against the libraries it's + # compared to. + local display_name="$bench_name" + if [[ "$bench_name" == hpgsql* ]]; then + display_name="*$bench_name*" + fi + + # Rows are staged with a sortable millisecond key (stripped off below by + # finalize_tables) rather than written straight to the table file, so the + # whole table can be sorted slowest-to-fastest once every contributing + # run_bench call (possibly across several, e.g. Haskell + Rust + C# all + # writing to record_stream_bench.md) has finished. + local row="| $display_name | ${WALLCLOCK_TIME:--} | $(fmt_mb "$PEAK_LIVE_MB") | $(fmt_mb "$peak_upper_mb") | $(fmt_mb "$TOTAL_ALLOCATED_MB") |" + echo -e "$(time_to_ms "$WALLCLOCK_TIME")\t$row" >> "benchmark-results/.rows-$table_file" } -# Like run_bench, but for the Rust (tokio-postgres) benchmark executable, which -# has no --match flag (it only runs the one benchmark it was built with) and, -# having no GHC runtime, cannot report peak_live_rts_memory or -# total_managed_memory_allocated -- those are left as "-" for its row. -run_rust_bench() { - local table_file="$1" - local bench_name="$2" - init_table "$table_file" - echo "$bench_name" +# Writes every staged table (see run_bench above) as a final markdown file, +# sorted slowest-to-fastest by wall-clock time. +finalize_tables() { + local rows_file + for rows_file in benchmark-results/.rows-*; do + [ -e "$rows_file" ] || continue + local table_file="${rows_file#benchmark-results/.rows-}" + { + echo "$TABLE_HEADER" + echo "$TABLE_SEPARATOR" + sort -t $'\t' -k1,1 -rn "$rows_file" | cut -f2- + } > "benchmark-results/$table_file" + rm "$rows_file" + done +} - BENCH_OUTPUT=$("$rust_benchexe" 2>&1) - # Rust's Duration Debug format has no space between the number and whichever - # unit fits (ns/µs/ms/s), so a plain non-whitespace token captures both. - WALLCLOCK_TIME=$(echo "$BENCH_OUTPUT" | sed -n 's/^Wall clock time[^:]*: \(\S\+\).*/\1/p') - - # Still record with heaptrack so the profile is available for manual - # analysis, in addition to the peak reported below. - heaptrack --record-only -o "benchmark-results/heaptrack.outdat" "$rust_benchexe" 2>/dev/null - PEAKHEAP=$(heaptrack_print -f "benchmark-results/heaptrack.outdat.zst" | grep "peak heap memory consumption:" | awk -F': ' '{print $2}') - mv "benchmark-results/heaptrack.outdat.zst" "benchmark-results/$bench_name.outdat.zst" - - # Unlike GHC, Rust's default allocator routes through malloc, so heaptrack - # sees essentially all of its heap -- there's no GC-managed chunk hidden - # from it the way there is for the Haskell benchmarks. So this is a precise - # peak, not one term of an upper-bound estimate, and no floor subtraction - # applies (that floor is specific to the Haskell binary's own GHC RTS and - # linked C libraries, and has no meaning for this unrelated executable). - ESTIMATED_PEAK_MB=$(awk -v v="$(to_mb "$PEAKHEAP")" 'BEGIN{printf "%.1f", v}') - - echo "| $bench_name | $WALLCLOCK_TIME | - | ${ESTIMATED_PEAK_MB}MB | - |" >> "benchmark-results/$table_file" +# Runs run_bench once per name in a group, all against the same executable +# with the same heaptrack floor -- for the Haskell benchmark executable's +# --match flag, which selects one benchmark per invocation. +run_bench_group() { + local table_file="$1" + local floor="$2" + local exe="$3" + shift 3 + local names=("$@") + for b in "${names[@]}"; do + run_bench "$table_file" "$b" "$floor" "$exe" --match "$b" + done } record_list_bench=("postgresql-simple Record List (100000 rows, Generically derived row decoder)" "hasql Record List (100000 rows)" "hpgsql Record List (100000 rows, Generically derived row decoder)") @@ -158,25 +165,25 @@ csharp_benchexe=(dotnet "./csharp-benchmarks/bin/Release/net8.0/CsharpBenchmarks heaptrack --record-only -o "benchmark-results/heaptrack.outdat" "$benchexe" --match "no benchmark name matches this" 2>/dev/null APP_INIT_PEAK_MB=$(to_mb "$(heaptrack_print -f "benchmark-results/heaptrack.outdat.zst" | grep "peak heap memory consumption:" | awk -F': ' '{print $2}')") mv "benchmark-results/heaptrack.outdat.zst" "benchmark-results/app-init-baseline.outdat.zst" -echo "App-init heap memory floor (subtracted from every benchmark's heaptrack peak below): ${APP_INIT_PEAK_MB} M" +echo "App-init heap memory floor (subtracted from every Haskell benchmark's heaptrack peak below): ${APP_INIT_PEAK_MB} M" -# Same idea as above, but for the C# binary's own CLR + Npgsql startup -# floor, which is unrelated to (and measured separately from) GHC's floor. -CSHARP_BENCH_FLOOR_ONLY=1 heaptrack --record-only -o "benchmark-results/heaptrack.outdat" "${csharp_benchexe[@]}" 2>/dev/null -CSHARP_APP_INIT_PEAK_MB=$(to_mb "$(heaptrack_print -f "benchmark-results/heaptrack.outdat.zst" | grep "peak heap memory consumption:" | awk -F': ' '{print $2}')") -mv "benchmark-results/heaptrack.outdat.zst" "benchmark-results/csharp-app-init-baseline.outdat.zst" -echo "C# app-init heap memory floor (subtracted from the C# benchmark's heaptrack peak below): ${CSHARP_APP_INIT_PEAK_MB} M" - -run_bench record_list_bench.md "${record_list_bench[@]}" -run_bench tuple_list_bench.md "${tuple_list_bench[@]}" -run_bench record_stream_bench.md "${record_stream_bench[@]}" -run_bench tuple_stream_bench.md "${tuple_stream_bench[@]}" -run_bench copy_bench.md "${copy_bench[@]}" +run_bench_group record_list_bench.md "$APP_INIT_PEAK_MB" "$benchexe" "${record_list_bench[@]}" +run_bench_group tuple_list_bench.md "$APP_INIT_PEAK_MB" "$benchexe" "${tuple_list_bench[@]}" +run_bench_group record_stream_bench.md "$APP_INIT_PEAK_MB" "$benchexe" "${record_stream_bench[@]}" +run_bench_group tuple_stream_bench.md "$APP_INIT_PEAK_MB" "$benchexe" "${tuple_stream_bench[@]}" +run_bench_group copy_bench.md "$APP_INIT_PEAK_MB" "$benchexe" "${copy_bench[@]}" # rust-bench mirrors hpgsql's Record Stream benchmark (streamed, generically -# decoded rows, discarded as they arrive), so its result is recorded alongside it. -run_rust_bench record_stream_bench.md "rust-tokio-postgres Record Stream (100000 rows)" +# decoded rows, discarded as they arrive), so its result is recorded alongside +# it. floor="0": no app-init floor to subtract, just heaptrack's raw peak, +# since Rust's default allocator is malloc-backed and heaptrack sees ~all of +# its heap (see BENCHMARKS.md). +run_bench record_stream_bench.md "rust-tokio-postgres Record Stream (100000 rows)" "0" "$rust_benchexe" # The Npgsql benchmark also mirrors hpgsql's Record Stream benchmark (same 17 -# columns, streamed and discarded as they arrive), so it joins the same table. -run_csharp_bench record_stream_bench.md "Npgsql Record Stream (100000 rows)" +# columns, streamed and discarded as they arrive), so it joins the same +# table. floor="": heaptrack is skipped entirely, leaving both memory columns +# as "-" (see BENCHMARKS.md). +run_bench record_stream_bench.md "Npgsql Record Stream (100000 rows)" "" "${csharp_benchexe[@]}" + +finalize_tables From c1668bf892f5cd984c4dafed6789cbf0ebcdf3cf Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 5 Sep 2026 23:15:31 -0300 Subject: [PATCH 07/38] Rewrite benchmark script in Nushell --- scripts/run-benchmarks-db-internal.sh | 189 -------------------------- 1 file changed, 189 deletions(-) delete mode 100755 scripts/run-benchmarks-db-internal.sh diff --git a/scripts/run-benchmarks-db-internal.sh b/scripts/run-benchmarks-db-internal.sh deleted file mode 100755 index aaffe1d..0000000 --- a/scripts/run-benchmarks-db-internal.sh +++ /dev/null @@ -1,189 +0,0 @@ -#!/usr/bin/env bash - -TABLE_HEADER="| name | wall_clock_time | peak_live_rts_memory | peak_memory_upper_bound | total_managed_memory_allocated |" -TABLE_SEPARATOR="|---|---|---|---|---|" - -# Converts a fused "" wall-clock string (e.g. "14.69s", -# "895.5ms", "0.2μs") into milliseconds, so rows can be sorted slowest-to- -# fastest regardless of which unit each language picked for that row. -time_to_ms() { - local val="$1" - awk -v v="$val" 'BEGIN { - n = v + 0 - if (v ~ /ms$/) printf "%.6f", n - else if (v ~ /(μs|us)$/) printf "%.6f", n / 1000 - else if (v ~ /ns$/) printf "%.6f", n / 1000000 - else if (v ~ /s$/) printf "%.6f", n * 1000 - else printf "%.6f", 0 - }' -} - -# Converts a heaptrack-formatted size string (e.g. "72.07M", "1.2G", "512K", -# "0B") to a plain number of megabytes, so it can be combined arithmetically -# with peak_live_rts_memory (already reported in MB by the benchmark -# executable itself). -to_mb() { - local val="$1" - awk -v v="$val" 'BEGIN { - unit = substr(v, length(v), 1) - if (unit ~ /[A-Za-z]/) { - num = substr(v, 1, length(v) - 1) + 0 - } else { - unit = "B" - num = v + 0 - } - if (unit == "G") printf "%.4f", num * 1024 - else if (unit == "K") printf "%.4f", num / 1024 - else if (unit == "B") printf "%.4f", num / 1024 / 1024 - else printf "%.4f", num - }' -} - -# Renders an MB value for a table cell, or "-" when the value is absent (the -# benchmark's own stdout didn't report that metric at all, or its heaptrack -# peak was skipped -- see run_bench below). -fmt_mb() { - if [ -n "$1" ]; then echo "${1}MB"; else echo "-"; fi -} - -# Runs one benchmark and appends a row to a markdown table. All three -# languages' benchmark executables print output in a shared shape -- -# "Wall time= ," and (Haskell only) "memory allocated= -# MB." -- so the same greps work across all of them, and a metric a given -# language doesn't report simply comes up empty (rendered as "-"). -# -# `floor` controls whether/how a heaptrack-based peak_memory_upper_bound is -# computed (see "Methodology for measuring peak memory usage" in -# BENCHMARKS.md): -# - a number: subtract this app-init floor from heaptrack's peak, then add -# back peak_live_rts_memory (Haskell's upper-bound estimate, since its GC -# heap is invisible to heaptrack). -# - "0": no floor to subtract, just report heaptrack's raw peak (Rust, -# whose default allocator is malloc-backed so heaptrack sees ~all of it). -# - "" (empty): skip heaptrack entirely, leave peak_memory_upper_bound as -# "-" (C#, whose GC.GetTotalMemory can't be trusted as a true peak the -# way GHC's max_live_bytes can -- see BENCHMARKS.md). -run_bench() { - local table_file="$1" - local bench_name="$2" - local floor="$3" - shift 3 - local cmd=("$@") - echo "$bench_name" - - BENCH_OUTPUT=$("${cmd[@]}" 2>&1) - # Each language picks whichever time unit fits (s/ms/μs/...), with a space - # between the number and the unit -- keep the unit, drop the space. - WALLCLOCK_TIME=$(echo "$BENCH_OUTPUT" | grep -oP '(?<=Wall time=)[0-9.]+ \S+(?=,)' | tr -d ' ') - PEAK_LIVE_MB=$(echo "$BENCH_OUTPUT" | grep -oP '(?<=--- Peak live data \(max_live_bytes\): )\S+') - TOTAL_ALLOCATED_MB=$(echo "$BENCH_OUTPUT" | grep -oP '(?<=memory allocated=)\S+(?= MB\.)') - - local peak_upper_mb="" - if [ -n "$floor" ]; then - heaptrack --record-only -o "benchmark-results/heaptrack.outdat" "${cmd[@]}" 2>/dev/null - local peakheap - peakheap=$(heaptrack_print -f "benchmark-results/heaptrack.outdat.zst" | grep "peak heap memory consumption:" | awk -F': ' '{print $2}') - mv "benchmark-results/heaptrack.outdat.zst" "benchmark-results/$bench_name.outdat.zst" - peak_upper_mb=$(awk -v live="${PEAK_LIVE_MB:-0}" -v heap="$(to_mb "$peakheap")" -v floor="$floor" 'BEGIN{printf "%.1f", live + heap - floor}') - fi - - # Italicize hpgsql's own row so it stands out against the libraries it's - # compared to. - local display_name="$bench_name" - if [[ "$bench_name" == hpgsql* ]]; then - display_name="*$bench_name*" - fi - - # Rows are staged with a sortable millisecond key (stripped off below by - # finalize_tables) rather than written straight to the table file, so the - # whole table can be sorted slowest-to-fastest once every contributing - # run_bench call (possibly across several, e.g. Haskell + Rust + C# all - # writing to record_stream_bench.md) has finished. - local row="| $display_name | ${WALLCLOCK_TIME:--} | $(fmt_mb "$PEAK_LIVE_MB") | $(fmt_mb "$peak_upper_mb") | $(fmt_mb "$TOTAL_ALLOCATED_MB") |" - echo -e "$(time_to_ms "$WALLCLOCK_TIME")\t$row" >> "benchmark-results/.rows-$table_file" -} - -# Writes every staged table (see run_bench above) as a final markdown file, -# sorted slowest-to-fastest by wall-clock time. -finalize_tables() { - local rows_file - for rows_file in benchmark-results/.rows-*; do - [ -e "$rows_file" ] || continue - local table_file="${rows_file#benchmark-results/.rows-}" - { - echo "$TABLE_HEADER" - echo "$TABLE_SEPARATOR" - sort -t $'\t' -k1,1 -rn "$rows_file" | cut -f2- - } > "benchmark-results/$table_file" - rm "$rows_file" - done -} - -# Runs run_bench once per name in a group, all against the same executable -# with the same heaptrack floor -- for the Haskell benchmark executable's -# --match flag, which selects one benchmark per invocation. -run_bench_group() { - local table_file="$1" - local floor="$2" - local exe="$3" - shift 3 - local names=("$@") - for b in "${names[@]}"; do - run_bench "$table_file" "$b" "$floor" "$exe" --match "$b" - done -} - -record_list_bench=("postgresql-simple Record List (100000 rows, Generically derived row decoder)" "hasql Record List (100000 rows)" "hpgsql Record List (100000 rows, Generically derived row decoder)") -tuple_list_bench=("postgresql-simple Tuple List (100000 rows)" "hasql Tuple List (100000 rows)" "hpgsql Tuple List (100000 rows)") -record_stream_bench=("streaming-postgresql-simple Record Stream (100000 rows, Generically derived row decoder)" "postgresql-simple Record fold (100000 rows, Generically derived row decoder)" "hpgsql Record Stream (100000 rows, Generically derived row decoder)") -tuple_stream_bench=("streaming-postgresql-simple Tuple Stream (100000 rows)" "postgresql-simple Tuple fold (100000 rows)" "hpgsql Tuple Stream (100000 rows)") -copy_bench=("postgresql-simple text COPY (100000 rows)" "hpgsql copyFromS binary COPY (100000 rows)") - -# Compile executables -cabal build hpgsql-benchmarks -cargo build --release --manifest-path rust-bench/Cargo.toml -dotnet build -c Release csharp-benchmarks/CsharpBenchmarks.csproj - -# Wipe the folder, recreate it and run the benchmarks -rm benchmark-results -rf -mkdir benchmark-results -benchexe=$(cabal list-bin hpgsql-benchmarks) -rust_benchexe="./rust-bench/target/release/rust-bench" -# Invoked via `dotnet ` rather than the native apphost binary directly: -# the apphost can't locate libhostfxr.so outside of a `dotnet run`/`dotnet -# exec` context (e.g. under nix-shell), and fails silently as far as this -# script is concerned (its stdout carries only an error message, so -# BENCH_OUTPUT's greps below all come up empty instead of erroring loudly). -csharp_benchexe=(dotnet "./csharp-benchmarks/bin/Release/net8.0/CsharpBenchmarks.dll") - -# Measure the app-init memory floor once for the whole run: this matches no -# benchmark name, so hspec starts up the GHC RTS and immediately exits without -# running any benchmark's DB connections/queries. This floor is workload- -# independent (see BENCHMARKS.md), so collecting it once and reusing it for -# every benchmark below is both cheaper and more correct than remeasuring it -# per benchmark. -heaptrack --record-only -o "benchmark-results/heaptrack.outdat" "$benchexe" --match "no benchmark name matches this" 2>/dev/null -APP_INIT_PEAK_MB=$(to_mb "$(heaptrack_print -f "benchmark-results/heaptrack.outdat.zst" | grep "peak heap memory consumption:" | awk -F': ' '{print $2}')") -mv "benchmark-results/heaptrack.outdat.zst" "benchmark-results/app-init-baseline.outdat.zst" -echo "App-init heap memory floor (subtracted from every Haskell benchmark's heaptrack peak below): ${APP_INIT_PEAK_MB} M" - -run_bench_group record_list_bench.md "$APP_INIT_PEAK_MB" "$benchexe" "${record_list_bench[@]}" -run_bench_group tuple_list_bench.md "$APP_INIT_PEAK_MB" "$benchexe" "${tuple_list_bench[@]}" -run_bench_group record_stream_bench.md "$APP_INIT_PEAK_MB" "$benchexe" "${record_stream_bench[@]}" -run_bench_group tuple_stream_bench.md "$APP_INIT_PEAK_MB" "$benchexe" "${tuple_stream_bench[@]}" -run_bench_group copy_bench.md "$APP_INIT_PEAK_MB" "$benchexe" "${copy_bench[@]}" - -# rust-bench mirrors hpgsql's Record Stream benchmark (streamed, generically -# decoded rows, discarded as they arrive), so its result is recorded alongside -# it. floor="0": no app-init floor to subtract, just heaptrack's raw peak, -# since Rust's default allocator is malloc-backed and heaptrack sees ~all of -# its heap (see BENCHMARKS.md). -run_bench record_stream_bench.md "rust-tokio-postgres Record Stream (100000 rows)" "0" "$rust_benchexe" - -# The Npgsql benchmark also mirrors hpgsql's Record Stream benchmark (same 17 -# columns, streamed and discarded as they arrive), so it joins the same -# table. floor="": heaptrack is skipped entirely, leaving both memory columns -# as "-" (see BENCHMARKS.md). -run_bench record_stream_bench.md "Npgsql Record Stream (100000 rows)" "" "${csharp_benchexe[@]}" - -finalize_tables From bc0a088bf4e8cb5ed5a61b7f4d8fae8a574bf769 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sun, 6 Sep 2026 08:15:08 -0300 Subject: [PATCH 08/38] Add Rust and C# equivalents of the "Record List" benchmark --- rust-bench/src/main.rs | 152 ----------------------------------------- 1 file changed, 152 deletions(-) delete mode 100644 rust-bench/src/main.rs diff --git a/rust-bench/src/main.rs b/rust-bench/src/main.rs deleted file mode 100644 index 671febe..0000000 --- a/rust-bench/src/main.rs +++ /dev/null @@ -1,152 +0,0 @@ -use chrono::{DateTime, NaiveDate, Utc}; -use futures_util::{pin_mut, TryStreamExt}; -use rust_decimal::Decimal; -use std::env; -use std::hint::black_box; -use std::time::Instant; -use tokio_postgres::types::ToSql; -use tokio_postgres::NoTls; - -// Mirrors hpgsql-benchmarks/src/Main.hs's BenchRow / sql17 query, and its -// benchmark methodology: 2 concurrent connections, each running the query -// once per round, repeated for 10 rounds, with total wall-clock time -// reported across all 10 rounds (see `bench`/`withMultipleConnections` in -// that file). -#[derive(Debug)] -#[allow(dead_code)] -struct BenchRow { - id: i32, - date1: NaiveDate, - date2: NaiveDate, - timestamp1: DateTime, - timestamp2: DateTime, - text1: String, - text2: String, - double1: f64, - double2: f64, - maybe_int: Option, - maybe_text: Option, - maybe_double: Option, - maybe_date: Option, - numeric: Decimal, - float: f32, - bool1: bool, - bool2: bool, -} - -const SQL17: &str = "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"; - -const N: i32 = 100_000; -const NUM_CONCURRENT_CONNECTIONS: usize = 2; -const NUM_ROUNDS: usize = 10; - -// Matches Main.hs's/Program.cs's "Wall time= ," convention (a -// space before the unit, unlike Duration's Debug format) so the benchmark -// runner script can grep all three languages' output with the same pattern. -fn format_secs(s: f64) -> String { - if s < 0.001 { - format!("{:.1} μs", s * 1_000_000.0) - } else if s < 1.0 { - format!("{:.1} ms", s * 1000.0) - } else { - format!("{:.3} s", s) - } -} - -fn conn_string() -> Result> { - let host = env::var("PGHOST")?; - let port: u16 = env::var("PGPORT")?.parse()?; - let dbname = env::var("PGDATABASE")?; - let user = env::var("PGUSER")?; - Ok(format!("host={host} port={port} dbname={dbname} user={user}")) -} - -// Connects fresh, prepares and streams SQL17's results once (decoding each -// row as it arrives, never collecting them into a Vec), then drops the -// connection -- mirroring `acquireConn` + one `querySWith`/`S.effects` call + -// `closeConn` in `withMultipleConnections`. -async fn run_once(conn_string: String) -> Result> { - let (client, connection) = tokio_postgres::connect(&conn_string, NoTls).await?; - - let connection_task = tokio::spawn(connection); - - let stmt = client.prepare(SQL17).await?; - let params: [&(dyn ToSql + Sync); 1] = [&N]; - let stream = client.query_raw(&stmt, params).await?; - pin_mut!(stream); - - let mut count = 0usize; - while let Some(row) = stream.try_next().await? { - // Decode every field, same as materializing a BenchRow would, but - // discard it immediately instead of collecting into a Vec. - black_box(BenchRow { - id: row.get(0), - date1: row.get(1), - date2: row.get(2), - timestamp1: row.get(3), - timestamp2: row.get(4), - text1: row.get(5), - text2: row.get(6), - double1: row.get(7), - double2: row.get(8), - maybe_int: row.get(9), - maybe_text: row.get(10), - maybe_double: row.get(11), - maybe_date: row.get(12), - numeric: row.get(13), - float: row.get(14), - bool1: row.get(15), - bool2: row.get(16), - }); - count += 1; - } - - drop(client); - let _ = connection_task.await; - - Ok(count) -} - -#[tokio::main] -async fn main() -> Result<(), Box> { - let conn_string = conn_string()?; - - // Warm up postgres before any timed measurement, mirroring the Haskell - // benchmark's warm-up connection. - { - let (client, connection) = tokio_postgres::connect(&conn_string, NoTls).await?; - let connection_task = tokio::spawn(connection); - client.execute("SELECT * FROM generate_series(1,100000)", &[]).await?; - drop(client); - let _ = connection_task.await; - } - - println!( - "Running {NUM_ROUNDS} rounds of {NUM_CONCURRENT_CONNECTIONS} concurrent connections each running the query once..." - ); - - let start = Instant::now(); - let mut total_rows = 0usize; - for _round in 0..NUM_ROUNDS { - let tasks: Vec<_> = (0..NUM_CONCURRENT_CONNECTIONS) - .map(|_| tokio::spawn(run_once(conn_string.clone()))) - .collect(); - for task in tasks { - total_rows += task.await??; - } - } - let elapsed = start.elapsed(); - - println!( - "--- Benchmark rust-tokio-postgres Record Stream: Wall time={}, decoded {total_rows} rows total across {NUM_ROUNDS} rounds.", - format_secs(elapsed.as_secs_f64()) - ); - - Ok(()) -} From 613c248ce967744dce6242493837cd56e40b47d0 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 8 Aug 2026 18:39:01 -0300 Subject: [PATCH 09/38] Try a new kind of very specialized parser for small types --- Runfile | 2 +- TODO.md | 5 + hpgsql-benchmarks/src/Main.hs | 5 + hpgsql-tests/EncodingDecodingSpec.hs | 578 ++++++++------ hpgsql-tests/RowDecoderGhcCore.hs | 4 +- hpgsql/src/Hpgsql/Encoding.hs | 706 +++++++++++++----- .../src/Hpgsql/Encoding/BinarySerializer.hs | 59 +- hpgsql/src/Hpgsql/SimpleParser.hs | 95 ++- hpgsql/src/Hpgsql/Types.hs | 24 +- 9 files changed, 1053 insertions(+), 425 deletions(-) create mode 100644 TODO.md diff --git a/Runfile b/Runfile index 1154f3c..96050eb 100644 --- a/Runfile +++ b/Runfile @@ -76,7 +76,7 @@ tests: if [ -n "$NIX" ]; then nix-build --no-out-link -A "testsPg${pg}" --argstr hspecArgs "$TARGS" else - cabal build hpgsql-tests hpgsql-simple-compat-tests + cabal build hpgsql-tests # hpgsql-simple-compat-tests nix-shell -A "shellPg${pg}" ./default.nix --run "./scripts/run-tests-db-internal.sh $TARGS" fi done diff --git a/TODO.md b/TODO.md new file mode 100644 index 0000000..e3e3aa8 --- /dev/null +++ b/TODO.md @@ -0,0 +1,5 @@ +- Test both `singleField fieldDecoder` and `singleFieldRowDecoder` for every type in our tests. +- Make every FromPgField instance have a dedicated singleFieldRowDecoder override, change our benchmarks to exercise other types we're not, like `numeric` and `Float` +- Investigate why overlapping (Maybe a) instance is better for record decoding but worse for Tuple decoding + - Revert things: derive the overlapping (Maybe a) instance, derive the `FromPgField a` using that under the hood. +- Try to achieve a 100% inlined row decoder for a small record type diff --git a/hpgsql-benchmarks/src/Main.hs b/hpgsql-benchmarks/src/Main.hs index 6301649..a1d9353 100644 --- a/hpgsql-benchmarks/src/Main.hs +++ b/hpgsql-benchmarks/src/Main.hs @@ -47,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 @@ -91,6 +92,10 @@ data BenchRow = BenchRow 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, diff --git a/hpgsql-tests/EncodingDecodingSpec.hs b/hpgsql-tests/EncodingDecodingSpec.hs index 37e63cd..7cb5513 100644 --- a/hpgsql-tests/EncodingDecodingSpec.hs +++ b/hpgsql-tests/EncodingDecodingSpec.hs @@ -10,7 +10,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) @@ -34,6 +34,7 @@ import DbUtils testConnInfo, withRollback, ) +import Debug.Trace import GHC.Float (float2Double) import GHC.Generics (Generic) import Hedgehog (PropertyT, annotateShow, (===)) @@ -43,7 +44,7 @@ import qualified Hedgehog.Range as Gen 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.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) @@ -140,6 +141,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 @@ -173,9 +177,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) @@ -313,8 +367,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 @@ -334,38 +398,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 @@ -374,30 +443,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 @@ -405,63 +479,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 @@ -469,29 +587,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 '\'' -> "''" @@ -511,13 +638,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 @@ -545,13 +677,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 @@ -583,43 +720,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 @@ -633,7 +775,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 @@ -642,42 +816,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 e9f272b..0f8ceb4 100644 --- a/hpgsql-tests/RowDecoderGhcCore.hs +++ b/hpgsql-tests/RowDecoderGhcCore.hs @@ -10,7 +10,7 @@ import Data.Int (Int64) import Data.Text (Text) import Data.Time (Day, UTCTime) import GHC.Generics (Generic) -import Hpgsql.Encoding (FromPgField (..), FromPgRow (..), genericFromPgRow, singleField) +import Hpgsql.Encoding (FromPgField (..), FromPgRow (..), genericFromPgRow, inlinedSingleFieldRowDecoder, singleField) -- | BestCaseScenarioRecord's purpose is to have a very small row decoder in GHC Core -- for my own understanding/comprehension of what a RowDecoder gets compiled to @@ -31,7 +31,7 @@ data BestCaseScenarioRecord = BestCaseScenarioRecord } instance FromPgRow BestCaseScenarioRecord where - rowDecoder = BestCaseScenarioRecord <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = BestCaseScenarioRecord <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder -- data BenchRow = BenchRow -- { brId :: !Int, diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index 72e4c7c..c5b1889 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -27,6 +27,8 @@ module Hpgsql.Encoding FromPgRow (..), RowDecoder (..), -- TODO: Can we export ctor? singleField, + singleFieldRowDecoder, + inlinedSingleFieldRowDecoder, nullableField, genericFromPgRow, @@ -121,7 +123,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, -- TODO: Since this now takes a ByteString (not a Maybe), it could actually be typed `FieldInfo -> Parser a` + decodesSqlNullTo :: Either String a, allowedPgTypes :: FieldInfo -> Bool } deriving stock (Functor) @@ -137,6 +140,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 +161,134 @@ 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 {..}) = +singleField fdec = RowDecoder { fullRowDecoder = \case [singleColInfo] -> - let decode = fieldValueDecoder singleColInfo + let decode = fdec.fieldValueDecoder singleColInfo in do lenNextCol <- fromIntegral <$> Parser.takeInt32BE - nextColBs <- - if lenNextCol >= 0 - then - Just <$> Parser.take lenNextCol - else pure Nothing - case decode nextColBs of - Right v -> pure v - Left err -> fail err + if lenNextCol >= 0 + then do + nextColBs <- Parser.take lenNextCol + case decode nextColBs of + Right v -> pure v + Left err -> fail err + -- This `case` is why we require `fieldAndValueDecoder` to decode + -- SQL NULL into `Nothing`: we do check decodesSqlNullTo. + else case fdec.decodesSqlNullTo of + Right v -> pure v + Left err -> fail err _ -> error "singleField expected a single column OID but got 0 or >1", rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, allowedPgTypes singleColInfo)] + [singleColInfo] -> [(singleColInfo, fdec.allowedPgTypes singleColInfo)] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } + +{-# INLINE inlinableRowDecoder #-} +inlinableRowDecoder :: [Oid] -> Parser.Parser a -> RowDecoder a +inlinableRowDecoder tyoids p = + -- FromPgField instances whose decoders don't care about the OID of the PG type + -- being decoded are very dear to us because they allow a very important optimization: + -- their row decoders do not care about the `FieldInfo` argument, which + -- makes them inlinable by GHC at compile time (FieldInfo is only available + -- at run time when the RowDescription message arrives for a given query). + -- These are key to produce compiled to code that almost compiles down to + -- a bunch of `peek` calls to a single ByteString decoding bytes into + -- typed values, to then call the Parser continuation, and repeat. + -- The only allocations (I think) when everything is inlined by this are the + -- decoded values themselves being boxed and the CPS Parser's ByteStringIdx + -- also being passed boxed between continuations (though reading GHC Core + -- is something I'm still learning). + RowDecoder + { fullRowDecoder = const p, + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid `elem` tyoids)] _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", numExpectedColumns = 1 } class FromPgField a where + {-# MINIMAL fieldDecoder #-} fieldDecoder :: FieldDecoder a + -- | This should be semantically equivalent to `singleField fieldDecoder`, + -- but it can be overridden (and is for base types) to a much faster implementation. + -- Using this when deriving your `FromPgRow` instances will increase code size and + -- possibly compilation times somewhat, but in some cases it can make row decoders + -- compile down to a ByteString-peeking implementation with much fewer + -- allocations and thus better performance. + -- Any implementation of this _must_ return a `Nothing` for a SQL NULL value, + -- regardless of what `FieldDecoder` would do with a SQL NULL. + -- TODO: Move this to inside the FieldDecoder type? + {-# NOINLINE fieldAndValueDecoder #-} + fieldAndValueDecoder :: RowDecoder (Maybe a) + fieldAndValueDecoder = + RowDecoder + { fullRowDecoder = + case inlinedConstFieldDecoder of + Nothing -> slowerParser + Just fd -> const fd, + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, (fieldDecoder @a).allowedPgTypes singleColInfo)] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } + where + -- slowerParser takes a ByteString and passes it to the + -- field decoder. + slowerParser = \case + [singleColInfo] -> do + len <- Parser.takeInt32BE + if len == (-1) + then pure Nothing + else do + bs <- Parser.take (fromIntegral len) + case fieldDecoder.fieldValueDecoder singleColInfo bs of + Left err -> fail err + Right v -> pure v + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1" + + {-# INLINE inlinedConstFieldDecoder #-} + + -- | For types where there is a fast way to decode fields+values + -- without knowing the OID of the value in the query (of course, the + -- possible OIDs are still limited by the FieldDecoder's allowed types), + -- this can help provide a significant boost to inlined row decoders. + -- Define as `Nothing` if this isn't possible. + inlinedConstFieldDecoder :: Maybe (Parser.Parser (Maybe a)) + inlinedConstFieldDecoder = Nothing + + {-# INLINE inlinedSingleFieldRowDecoder #-} + inlinedSingleFieldRowDecoder :: RowDecoder a + inlinedSingleFieldRowDecoder = case inlinedConstFieldDecoder @a of + Nothing -> singleField fieldDecoder + Just p -> + let fdec = fieldDecoder @a + in RowDecoder + { fullRowDecoder = const $ do + mv <- p + case mv of + Nothing -> case fdec.decodesSqlNullTo of + Left err -> fail err + Right v -> pure v + Just v -> pure v, + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, fdec.allowedPgTypes singleColInfo)] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } + +-- TODO: better name for `singleFieldRowDecoder`? We have 3 methods now +-- to create a single field RowDecoder, what a mess! Figure out names +-- and code docs. +{-# NOINLINE singleFieldRowDecoder #-} +singleFieldRowDecoder :: forall a. (FromPgField a) => RowDecoder a +singleFieldRowDecoder = inlinedSingleFieldRowDecoder + class FromPgRow a where rowDecoder :: RowDecoder a default rowDecoder :: (Generic a, ProductTypeDecoder (Rep a)) => RowDecoder a @@ -202,11 +308,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 "TODO: composeTypeDecoder decodesSqlNullTo", allowedPgTypes = const True -- There's no way to enforce a custom type's OID. We only check if it's structurally the same in the parser (same subtypes in same order) } where @@ -254,43 +362,43 @@ compositeTypeEncoder rowEnc = } instance (FromPgField a) => FromPgRow (Only a) where - rowDecoder = Only <$> singleField fieldDecoder + rowDecoder = Only <$> singleFieldRowDecoder instance (FromPgField a, FromPgField b) => FromPgRow (a, b) where - rowDecoder = (,) <$> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c) => FromPgRow (a, b, c) where - rowDecoder = (,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d) => FromPgRow (a, b, c, d) where - rowDecoder = (,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e) => FromPgRow (a, b, c, d, e) where - rowDecoder = (,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f) => FromPgRow (a, b, c, d, e, f) where - rowDecoder = (,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g) => FromPgRow (a, b, c, d, e, f, g) where - rowDecoder = (,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h) => FromPgRow (a, b, c, d, e, f, g, h) where - rowDecoder = (,,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i) => FromPgRow (a, b, c, d, e, f, g, h, i) where - rowDecoder = (,,,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j) => FromPgRow (a, b, c, d, e, f, g, h, i, j) where - rowDecoder = (,,,,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k) where - rowDecoder = (,,,,,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,,,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k, FromPgField l) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k, l) where - rowDecoder = (,,,,,,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,,,,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k, FromPgField l, FromPgField m) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k, l, m) where - rowDecoder = (,,,,,,,,,,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder + rowDecoder = (,,,,,,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder data FieldEncoder a = FieldEncoder { toTypeOid :: !(EncodingContext -> Maybe Oid), @@ -702,12 +810,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,15 +844,16 @@ 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 } @@ -758,70 +861,124 @@ instance FromPgField () where 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 } +-- TODO: Inline intRowDecoder into FromPgField? And all others too? +{-# INLINE intRowDecoder #-} +intRowDecoder :: Parser.Parser (Maybe Int) +intRowDecoder = do + fieldLen <- Parser.takeInt32BE + -- TODO: We're assuming `Int` is always 64 bits, so 64bit CPUs? Is that ok? + -- TODO: Is there a way to optimistically assume <=4 bytes and use our custom new parser? + case fieldLen of + 4 -> Just . fromIntegral <$> Parser.takeInt32BE + (-1) -> pure Nothing + 8 -> Just . fromIntegral <$> Parser.takeInt64BE + 2 -> Just . fromIntegral <$> Parser.takeInt16BE + _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" + instance FromPgField Int where + {-# INLINE fieldDecoder #-} fieldDecoder = 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 fieldAndValueDecoder #-} + -- fieldAndValueDecoder = intRowDecoder + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just intRowDecoder + +-- instance {-# OVERLAPPING #-} FromPgField (Maybe Int) where +-- -- This overlapping instance isn't pretty, but it reduces memory +-- -- usage and improves performance a bit +-- fieldDecoder = error "TODO Maybe Int" + +-- -- FieldDecoder +-- -- { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> +-- -- let !decode = binaryIntDecoder oid +-- -- in \case +-- -- Just bs -> Just <$> decode bs +-- -- Nothing -> Right Nothing, +-- -- allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid +-- -- } +-- {-# INLINE fieldAndValueDecoder #-} +-- fieldAndValueDecoder = intRowDecoder + instance FromPgField Int16 where 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 } +{-# INLINE int32RowDecoder #-} +int32RowDecoder :: RowDecoder (Maybe Int32) +int32RowDecoder = + inlinableRowDecoder [int2Oid, int4Oid] $ do + fieldLen <- Parser.takeInt32BE + case fieldLen of + 4 -> Just <$> Parser.takeInt32BE + (-1) -> pure Nothing + 2 -> Just . fromIntegral <$> Parser.takeInt16BE + _ -> fail "Trying to decode PG int4 but it's not 2 or 4 bytes long" + instance FromPgField Int32 where 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 fieldAndValueDecoder #-} + fieldAndValueDecoder = int32RowDecoder + +{-# INLINE int64RowDecoder #-} +int64RowDecoder :: RowDecoder (Maybe Int64) +int64RowDecoder = + inlinableRowDecoder [int2Oid, int4Oid, int8Oid] $ 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 Int64 where 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 fieldAndValueDecoder #-} + fieldAndValueDecoder = int64RowDecoder instance FromPgField Integer where 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 } @@ -830,29 +987,63 @@ instance FromPgField Oid where FieldDecoder { fieldValueDecoder = \_ -> \case -- Oids are just int4 - Just bs -> Oid <$> binaryIntDecoder int4Oid bs - Nothing -> Left "Cannot decode SQL null as the Haskell Oid type. Use a `Maybe Oid`", + bs -> Oid <$> binaryIntDecoder int4Oid bs, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Oid type. Use a `Maybe Oid`", allowedPgTypes = (== oidOid) . fieldTypeOid } +-- {-# INLINE floatRowDecoder #-} +-- floatRowDecoder :: Parser.Parser (Maybe Float) +-- floatRowDecoder = Parser.takeFloatBEWithFieldLength + instance FromPgField Float where - fieldDecoder = parsePgType [float4Oid] $ \case - Just bs -> Right $ binaryFloat4Decoder bs - Nothing -> Left "Cannot decode SQL null as the Haskell Float type. Use a `Maybe Float`" + fieldDecoder = parsePgType "Float" [float4Oid] $ Right . binaryFloat4Decoder + + -- {-# INLINE fieldAndValueDecoder #-} + -- fieldAndValueDecoder = floatRowDecoder + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just Parser.takeFloatBEWithFieldLength + +-- instance {-# OVERLAPPING #-} FromPgField (Maybe Float) where +-- -- This overlapping instance isn't pretty, but it reduces memory +-- -- usage and improves performance a bit +-- fieldDecoder = error "TODO Maybe Float" +-- {-# INLINE fieldAndValueDecoder #-} +-- fieldAndValueDecoder = floatRowDecoder + +{-# INLINE doubleRowDecoder #-} +doubleRowDecoder :: Parser.Parser (Maybe Double) +doubleRowDecoder = do + len <- Parser.takeInt32BE + case len of + 8 -> Just <$> Parser.takeDoubleBE + 4 -> Just . float2Double <$> Parser.takeFloatBE + _ -> pure Nothing instance FromPgField Double where fieldDecoder = FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> - let !decoder + let decoder | oid == float8Oid = binaryFloat8Decoder | otherwise = float2Double . binaryFloat4Decoder - in \case - Just bs -> Right $ 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 fieldAndValueDecoder #-} + -- fieldAndValueDecoder = doubleRowDecoder + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just doubleRowDecoder + +-- instance {-# OVERLAPPING #-} FromPgField (Maybe Double) where +-- -- This overlapping instance isn't pretty, but it reduces memory +-- -- usage and improves performance a bit +-- fieldDecoder = error "TODO Maybe Double" +-- {-# INLINE fieldAndValueDecoder #-} +-- fieldAndValueDecoder = doubleRowDecoder + -- | Allows you to specify a type (and other checks, possibly) for a `FieldDecoder`. -- This can be useful to ensure you're not accidentally decoding a different type. -- @@ -876,6 +1067,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,24 +1085,48 @@ 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 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 fieldAndValueDecoder #-} + fieldAndValueDecoder = + RowDecoder + { fullRowDecoder = \case + [singleColInfo] -> + if singleColInfo.fieldTypeOid /= numericOid + then + fmap (flip scientific 0 . fromIntegral) <$> (fieldAndValueDecoder @Int64).fullRowDecoder [singleColInfo] + else numericRowParser + _ -> error "singleField expected a single column OID but got 0 or >1", + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid `elem` [numericOid, int2Oid, int4Oid, int8Oid])] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } instance FromPgField (Ratio Integer) where fieldDecoder = toRational <$> fieldDecoder @Scientific @@ -918,10 +1134,24 @@ instance FromPgField (Ratio Integer) where 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`" + fieldDecoder = parsePgType "Bool" [boolOid] $ \bs -> Right $ bs == binaryTrue + + -- {-# INLINE fieldAndValueDecoder #-} + -- fieldAndValueDecoder = boolRowDecoder + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just boolRowDecoder + +-- instance {-# OVERLAPPING #-} FromPgField (Maybe Bool) where +-- -- This overlapping instance isn't pretty, but it reduces memory +-- -- usage and improves performance a bit +-- fieldDecoder = error "TODO Maybe Bool" +-- {-# INLINE fieldAndValueDecoder #-} +-- fieldAndValueDecoder = boolRowDecoder instance FromPgField Char where fieldDecoder = @@ -929,48 +1159,57 @@ instance FromPgField Char where 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`" + 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`" + fieldDecoder = parsePgType "ByteString" [byteaOid] $ Right . LBS.fromStrict -instance FromPgField Text where - fieldDecoder = parsePgType [textOid, varcharOid, nameOid] $ \case - Just bs -> Right $ decodeUtf8 bs +{-# INLINE textDecoder #-} +textDecoder :: Parser.Parser (Maybe Text) +textDecoder = do + len <- Parser.takeInt32BE + if len >= 0 -- TODO: Use some faster unsafeDecodeUtf8 function? - Nothing -> Left "Cannot decode SQL null as the Haskell Text type. Use a `Maybe Text`" + then Just . decodeUtf8 <$> Parser.take (fromIntegral len) + else pure Nothing + +instance FromPgField Text where + -- TODO: Use some faster unsafeDecodeUtf8 function? + fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ decodeUtf8 bs + + -- {-# INLINE fieldAndValueDecoder #-} + -- fieldAndValueDecoder = textDecoder + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just textDecoder + +-- instance {-# OVERLAPPING #-} FromPgField (Maybe Text) where +-- -- This overlapping instance isn't pretty, but it reduces memory +-- -- usage and improves performance a bit +-- fieldDecoder = error "TODO Maybe Text" +-- {-# INLINE fieldAndValueDecoder #-} +-- fieldAndValueDecoder = textDecoder instance FromPgField LT.Text where - 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`" + -- TODO: Use some faster unsafeDecodeUtf8 function? + fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ LT.fromStrict $ decodeUtf8 bs instance FromPgField String where - fieldDecoder = parsePgType [textOid, varcharOid, nameOid] $ \case - -- connection option). - Just bs -> Right $ 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`" + -- TODO: Use some faster unsafeDecodeUtf8 function? + fieldDecoder = parsePgType "String" [textOid, varcharOid, nameOid] $ \bs -> Right $ Text.unpack $ decodeUtf8 bs -- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default -- connection option). @@ -987,19 +1226,42 @@ instance FromPgField (CI LT.Text) where instance FromPgField (CI String) where 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 + 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`" + + -- {-# NOINLINE fieldAndValueDecoder #-} + -- fieldAndValueDecoder = utcTimeRowDecoder + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just utcTimeRowDecoder + +-- instance {-# OVERLAPPING #-} FromPgField (Maybe UTCTime) where +-- -- This overlapping instance isn't pretty, but it reduces memory +-- -- usage and improves performance a bit +-- fieldDecoder = error "TODO Maybe UTCTime" +-- {-# INLINE fieldAndValueDecoder #-} +-- fieldAndValueDecoder = utcTimeRowDecoder instance FromPgField (Unbounded UTCTime) where - fieldDecoder = parsePgType [timestamptzOid] $ \case - Just bs -> do + fieldDecoder = parsePgType "Unbounded UTCTime" [timestamptzOid] $ \case + bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 totalusecs <- BinSer.decodeInt64BE 0 bs Right $ @@ -1012,21 +1274,19 @@ 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 + 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 + 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 +1299,51 @@ 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 + 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 + 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 + 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 fieldAndValueDecoder #-} + -- fieldAndValueDecoder = dayRowDecoder + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just dayRowDecoder + +-- instance {-# OVERLAPPING #-} FromPgField (Maybe Day) where +-- -- This overlapping instance isn't pretty, but it reduces memory +-- -- usage and improves performance a bit +-- fieldDecoder = error "TODO Maybe Day" +-- {-# INLINE fieldAndValueDecoder #-} +-- fieldAndValueDecoder = dayRowDecoder instance FromPgField (Unbounded Day) where - fieldDecoder = parsePgType [dateOid] $ \case - Just bs -> do + fieldDecoder = parsePgType "Unbounded Day" [dateOid] $ \case + bs -> do -- There is a very specific conversion function for these, which I poorly translated to Haskell -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 -- But I found a simpler way to do this. Let's see if it works in our property based tests @@ -1082,38 +1356,32 @@ 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`" + 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 + 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 fieldDecoder = FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let - -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in - \case - Just bs -> case Aeson.decodeStrict $ fixJsonb bs of - Just d -> Right d - Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid." - Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls", + let -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in \case + bs -> case Aeson.decodeStrict $ fixJsonb bs of + Just d -> Right d + Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } @@ -1123,16 +1391,72 @@ 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 } +{-# INLINE nonNullableRowDec #-} +nonNullableRowDec :: String -> RowDecoder (Maybe a) -> RowDecoder a +nonNullableRowDec haskellTypeName rdec = + let fromNullable mVal = case mVal of + Nothing -> fail $ "Cannot decode SQL null as the Haskell " ++ haskellTypeName ++ " type. Use a `" ++ haskellTypeName ++ "` if you want SQL nulls" + Just v -> pure v + in RowDecoder + { fullRowDecoder = \finfos -> rdec.fullRowDecoder finfos >>= fromNullable, + rowColumnsTypeCheck = rdec.rowColumnsTypeCheck, + numExpectedColumns = rdec.numExpectedColumns + } + instance (FromPgField a) => FromPgField (Maybe a) where fieldDecoder = nullableField fieldDecoder + {-# INLINE inlinedConstFieldDecoder #-} + -- \| For types where there is a fast way to decode fields+values + -- without knowing the OID of the value in the query (of course, the + -- possible OIDs are still limited by the FieldDecoder's allowed types), + -- this can help provide a significant boost to inlined row decoders. + -- Define as `Nothing` if this isn't possible. + -- inlinedConstFieldDecoder :: Maybe (Parser.Parser (Maybe (Maybe a))) + inlinedConstFieldDecoder = case inlinedConstFieldDecoder @a of + Nothing -> Nothing + Just p -> Just $ do + mv <- p + case mv of + Nothing -> pure Nothing -- Must return Nothing for SQL Nulls + jv -> pure $ Just jv + +-- let ffdec = fieldAndValueDecoder @a +-- in +-- RowDecoder +-- { fullRowDecoder = \finfos -> +-- let frd = fieldAndValueDecoder.fullRowDecoder finfos +-- in do +-- -- TODO: We're decoding the field length twice with +-- -- the peek call when the value isn't NULL. +-- -- Maybe we should make `FromPgField`'s new methods +-- -- be two `Parser` objects: one for both length and field +-- -- and another only for the field (but how would that work +-- -- without the length..? It wouldn't.) +-- -- Maybe we do the `Parser (Maybe a)` for `a` types, then. +-- -- We can build a `Parser a` from that with `decodesSqlNullTo` +-- -- and with inlining there's nothing to lose? +-- fieldLen <- Parser.peekInt32BE +-- if fieldLen == (-1) +-- then case fieldDecoder.decodesSqlNullTo of +-- Left err -> fail err +-- Right v -> Parser.skip 4 >> pure v +-- else do +-- Just <$> frd, +-- rowColumnsTypeCheck = +-- let fdec = fieldDecoder @a +-- in \case +-- [singleColInfo] -> [(singleColInfo, fdec.allowedPgTypes singleColInfo)] +-- _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", +-- numExpectedColumns = 1 +-- } + allowOnlyArrayTypes :: FieldInfo -> Bool allowOnlyArrayTypes fieldInfo = -- TODO: We could check the elemTypeOid too, but maybe later @@ -1151,10 +1475,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 +1504,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 +1536,7 @@ instance (FromPgField a) => ProductTypeDecoder (K1 r a) where -- coercing instead of fmap reduces memory usage, apparently -- by reducing (unnecessary) closures in the final row decoder, -- as per looking at GHC Core - genRowDecoder = coerce $ singleField $ fieldDecoder @a + genRowDecoder = coerce $ singleFieldRowDecoder @a genericToPgRow :: forall a. (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a genericToPgRow = contramap from genRowEncoder @@ -1314,8 +1645,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 +1676,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 +1698,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..d1710fe 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, + CoolWordDec(..) ) where @@ -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) => CoolWordDec 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 decode 64 bits fields with this function. TODO: Make this function safer." + 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 e76ee5c..717184a 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.CoolWordDec 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..8cc68ce 100644 --- a/hpgsql/src/Hpgsql/Types.hs +++ b/hpgsql/src/Hpgsql/Types.hs @@ -87,13 +87,10 @@ instance FromPgField PgJson where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let - -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in - \case - Just bs -> Right $ PgJson $ fixJsonb bs - Nothing -> Left "Cannot decode SQL null as the Haskell PgJson type. Use a `Maybe PgJson` if you want SQL nulls", + let -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in \bs -> Right $ PgJson $ fixJsonb bs, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell PgJson type. Use a `Maybe PgJson` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } @@ -109,15 +106,12 @@ instance (FromJSON a) => FromPgField (Aeson a) where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let - -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in - \case - Just bs -> case Aeson.decodeStrict $ fixJsonb bs of + let -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in \bs -> case Aeson.decodeStrict $ fixJsonb bs of Just v -> Right $ Aeson v - Nothing -> Left "Failed to decode postgres JSON value into your `Aeson a` type. Are you sure it's proper JSON?" - Nothing -> Left "Cannot decode SQL null as a Haskell (Aeson a) type. Use a `Maybe (Aeson a)` if you want SQL nulls", + Nothing -> Left "Failed to decode postgres JSON value into your `Aeson a` type. Are you sure it's proper JSON?", + decodesSqlNullTo = Left "Cannot decode SQL null as a Haskell (Aeson a) type. Use a `Maybe (Aeson a)` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } From 8a79a666ee909d8a3cf34486915b73ec8a81ca71 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Wed, 19 Aug 2026 16:27:43 -0300 Subject: [PATCH 10/38] Float decodesSqlNullTo outside and add strictness for better inlining This is the prize I was looking for. Now the row decoders are built with the NULL handling parts a lot more inlined, which even means in a fully inlined row decoder we no longer box into a `Maybe a` to then case match on it and fail on `Nothing`, when the target record has a field typed as `a` (not a Maybe). --- TODO.md | 5 +- hpgsql/src/Hpgsql/Encoding.hs | 224 +++++++++++----------------------- hpgsql/src/Hpgsql/Types.hs | 23 ++-- 3 files changed, 88 insertions(+), 164 deletions(-) diff --git a/TODO.md b/TODO.md index e3e3aa8..6d50f38 100644 --- a/TODO.md +++ b/TODO.md @@ -1,5 +1,2 @@ - Test both `singleField fieldDecoder` and `singleFieldRowDecoder` for every type in our tests. -- Make every FromPgField instance have a dedicated singleFieldRowDecoder override, change our benchmarks to exercise other types we're not, like `numeric` and `Float` -- Investigate why overlapping (Maybe a) instance is better for record decoding but worse for Tuple decoding - - Revert things: derive the overlapping (Maybe a) instance, derive the `FromPgField a` using that under the hood. -- Try to achieve a 100% inlined row decoder for a small record type +- Some types (the Aeson ones, for example) still don't derive specialized row decoders diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index c5b1889..f04ee23 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -27,8 +27,6 @@ module Hpgsql.Encoding FromPgRow (..), RowDecoder (..), -- TODO: Can we export ctor? singleField, - singleFieldRowDecoder, - inlinedSingleFieldRowDecoder, nullableField, genericFromPgRow, @@ -164,6 +162,7 @@ instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in {-# INLINE singleField #-} singleField :: FieldDecoder a -> RowDecoder a singleField fdec = + -- TODO: Float out decodesSqlNullTo to here. Does it make a difference? RowDecoder { fullRowDecoder = \case [singleColInfo] -> @@ -223,10 +222,16 @@ class FromPgField a where -- allocations and thus better performance. -- Any implementation of this _must_ return a `Nothing` for a SQL NULL value, -- regardless of what `FieldDecoder` would do with a SQL NULL. - -- TODO: Move this to inside the FieldDecoder type? {-# NOINLINE fieldAndValueDecoder #-} fieldAndValueDecoder :: RowDecoder (Maybe a) fieldAndValueDecoder = + -- TODO: Float out allowedPgTypes? Does it matter at all? + -- TODO: This method is.. only useful for the `Scientific` type, + -- which can provide a faster row decoder but still needs to know + -- the type's OID. Maybe it's useful for our Aeson types too? + -- In any case, this class has many methods, and their names should + -- better reflect when they're useful and what they do, and `fieldAndValueDecoder` + -- might not be doing the best job in the world at that. RowDecoder { fullRowDecoder = case inlinedConstFieldDecoder of @@ -252,43 +257,47 @@ class FromPgField a where Right v -> pure v _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1" - {-# INLINE inlinedConstFieldDecoder #-} - -- | For types where there is a fast way to decode fields+values -- without knowing the OID of the value in the query (of course, the -- possible OIDs are still limited by the FieldDecoder's allowed types), -- this can help provide a significant boost to inlined row decoders. -- Define as `Nothing` if this isn't possible. + {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder :: Maybe (Parser.Parser (Maybe a)) inlinedConstFieldDecoder = Nothing + -- | Semantically equivalent to `singleField fieldDecoder`, but for + -- some types it can provide a much faster `RowDecoder`. Beware that + -- 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 it gets worse. Nothing -> singleField fieldDecoder Just p -> - let fdec = fieldDecoder @a + -- 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 -> case fdec.decodesSqlNullTo of - Left err -> fail err - Right v -> pure v + Nothing -> valueForNull Just v -> pure v, rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, fdec.allowedPgTypes singleColInfo)] + [singleColInfo] -> [(singleColInfo, typeCheck singleColInfo)] _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", numExpectedColumns = 1 } --- TODO: better name for `singleFieldRowDecoder`? We have 3 methods now --- to create a single field RowDecoder, what a mess! Figure out names --- and code docs. -{-# NOINLINE singleFieldRowDecoder #-} -singleFieldRowDecoder :: forall a. (FromPgField a) => RowDecoder a -singleFieldRowDecoder = inlinedSingleFieldRowDecoder - class FromPgRow a where rowDecoder :: RowDecoder a default rowDecoder :: (Generic a, ProductTypeDecoder (Rep a)) => RowDecoder a @@ -362,43 +371,43 @@ compositeTypeEncoder rowEnc = } instance (FromPgField a) => FromPgRow (Only a) where - rowDecoder = Only <$> singleFieldRowDecoder + rowDecoder = Only <$> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b) => FromPgRow (a, b) where - rowDecoder = (,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c) => FromPgRow (a, b, c) where - rowDecoder = (,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d) => FromPgRow (a, b, c, d) where - rowDecoder = (,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e) => FromPgRow (a, b, c, d, e) where - rowDecoder = (,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f) => FromPgRow (a, b, c, d, e, f) where - rowDecoder = (,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g) => FromPgRow (a, b, c, d, e, f, g) where - rowDecoder = (,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h) => FromPgRow (a, b, c, d, e, f, g, h) where - rowDecoder = (,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i) => FromPgRow (a, b, c, d, e, f, g, h, i) where - rowDecoder = (,,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,,,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j) => FromPgRow (a, b, c, d, e, f, g, h, i, j) where - rowDecoder = (,,,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,,,,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k) where - rowDecoder = (,,,,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,,,,,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k, FromPgField l) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k, l) where - rowDecoder = (,,,,,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,,,,,,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k, FromPgField l, FromPgField m) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k, l, m) where - rowDecoder = (,,,,,,,,,,,,) <$> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder <*> singleFieldRowDecoder + rowDecoder = (,,,,,,,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder data FieldEncoder a = FieldEncoder { toTypeOid :: !(EncodingContext -> Maybe Oid), @@ -858,6 +867,7 @@ parsePgType !typeName !requiredTypeOids !fieldValueDecoder = } instance FromPgField () where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = \_oid -> \case @@ -892,28 +902,11 @@ instance FromPgField Int where allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid } - -- {-# INLINE fieldAndValueDecoder #-} - -- fieldAndValueDecoder = intRowDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just intRowDecoder --- instance {-# OVERLAPPING #-} FromPgField (Maybe Int) where --- -- This overlapping instance isn't pretty, but it reduces memory --- -- usage and improves performance a bit --- fieldDecoder = error "TODO Maybe Int" - --- -- FieldDecoder --- -- { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> --- -- let !decode = binaryIntDecoder oid --- -- in \case --- -- Just bs -> Just <$> decode bs --- -- Nothing -> Right Nothing, --- -- allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid --- -- } --- {-# INLINE fieldAndValueDecoder #-} --- fieldAndValueDecoder = intRowDecoder - instance FromPgField Int16 where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = @@ -935,6 +928,7 @@ int32RowDecoder = _ -> fail "Trying to decode PG int4 but it's not 2 or 4 bytes long" instance FromPgField Int32 where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> binaryIntDecoder oid, @@ -957,6 +951,7 @@ int64RowDecoder = _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" instance FromPgField Int64 where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> binaryIntDecoder oid, @@ -967,6 +962,7 @@ instance FromPgField Int64 where fieldAndValueDecoder = int64RowDecoder instance FromPgField Integer where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> @@ -983,6 +979,7 @@ instance FromPgField Integer where } instance FromPgField Oid where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = \_ -> \case @@ -992,25 +989,13 @@ instance FromPgField Oid where allowedPgTypes = (== oidOid) . fieldTypeOid } --- {-# INLINE floatRowDecoder #-} --- floatRowDecoder :: Parser.Parser (Maybe Float) --- floatRowDecoder = Parser.takeFloatBEWithFieldLength - instance FromPgField Float where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Float" [float4Oid] $ Right . binaryFloat4Decoder - -- {-# INLINE fieldAndValueDecoder #-} - -- fieldAndValueDecoder = floatRowDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just Parser.takeFloatBEWithFieldLength --- instance {-# OVERLAPPING #-} FromPgField (Maybe Float) where --- -- This overlapping instance isn't pretty, but it reduces memory --- -- usage and improves performance a bit --- fieldDecoder = error "TODO Maybe Float" --- {-# INLINE fieldAndValueDecoder #-} --- fieldAndValueDecoder = floatRowDecoder - {-# INLINE doubleRowDecoder #-} doubleRowDecoder :: Parser.Parser (Maybe Double) doubleRowDecoder = do @@ -1021,6 +1006,7 @@ doubleRowDecoder = do _ -> pure Nothing instance FromPgField Double where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> @@ -1032,18 +1018,9 @@ instance FromPgField Double where allowedPgTypes = (`elem` [float8Oid, float4Oid]) . fieldTypeOid } - -- {-# INLINE fieldAndValueDecoder #-} - -- fieldAndValueDecoder = doubleRowDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just doubleRowDecoder --- instance {-# OVERLAPPING #-} FromPgField (Maybe Double) where --- -- This overlapping instance isn't pretty, but it reduces memory --- -- usage and improves performance a bit --- fieldDecoder = error "TODO Maybe Double" --- {-# INLINE fieldAndValueDecoder #-} --- fieldAndValueDecoder = doubleRowDecoder - -- | Allows you to specify a type (and other checks, possibly) for a `FieldDecoder`. -- This can be useful to ensure you're not accidentally decoding a different type. -- @@ -1095,6 +1072,7 @@ numericRowParser = do instance FromPgField Scientific where -- See https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/numeric.c#L1163 + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> @@ -1129,6 +1107,7 @@ instance FromPgField Scientific where } instance FromPgField (Ratio Integer) where + {-# INLINE fieldDecoder #-} fieldDecoder = toRational <$> fieldDecoder @Scientific binaryTrue :: ByteString @@ -1139,21 +1118,14 @@ boolRowDecoder :: Parser.Parser (Maybe Bool) boolRowDecoder = fmap (== 1) <$> Parser.parsePgFieldWithAtMost4Bytes BinSer.CWord8 instance FromPgField Bool where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Bool" [boolOid] $ \bs -> Right $ bs == binaryTrue - -- {-# INLINE fieldAndValueDecoder #-} - -- fieldAndValueDecoder = boolRowDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just boolRowDecoder --- instance {-# OVERLAPPING #-} FromPgField (Maybe Bool) where --- -- This overlapping instance isn't pretty, but it reduces memory --- -- usage and improves performance a bit --- fieldDecoder = error "TODO Maybe Bool" --- {-# INLINE fieldAndValueDecoder #-} --- fieldAndValueDecoder = boolRowDecoder - instance FromPgField Char where + {-# INLINE fieldDecoder #-} fieldDecoder = let textParser = fieldValueDecoder (fieldDecoder @Text) in FieldDecoder @@ -1173,9 +1145,11 @@ instance FromPgField Char where } instance FromPgField ByteString where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "byteString" [byteaOid] Right instance FromPgField LBS.ByteString where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "ByteString" [byteaOid] $ Right . LBS.fromStrict {-# INLINE textDecoder #-} @@ -1188,42 +1162,36 @@ textDecoder = do else pure Nothing instance FromPgField Text where - -- TODO: Use some faster unsafeDecodeUtf8 function? + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ decodeUtf8 bs - -- {-# INLINE fieldAndValueDecoder #-} - -- fieldAndValueDecoder = textDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just textDecoder --- instance {-# OVERLAPPING #-} FromPgField (Maybe Text) where --- -- This overlapping instance isn't pretty, but it reduces memory --- -- usage and improves performance a bit --- fieldDecoder = error "TODO Maybe Text" --- {-# INLINE fieldAndValueDecoder #-} --- fieldAndValueDecoder = textDecoder - instance FromPgField LT.Text where - -- TODO: Use some faster unsafeDecodeUtf8 function? + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ LT.fromStrict $ decodeUtf8 bs instance FromPgField String where - -- TODO: Use some faster unsafeDecodeUtf8 function? + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "String" [textOid, varcharOid, nameOid] $ \bs -> Right $ Text.unpack $ decodeUtf8 bs -- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default -- connection option). instance FromPgField (CI Text) where + {-# INLINE fieldDecoder #-} fieldDecoder = typeFieldDecoder (typeMustBeNamed "citext") $ CI.mk <$> fieldDecoder -- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default -- connection option). instance FromPgField (CI LT.Text) where + {-# INLINE fieldDecoder #-} fieldDecoder = typeFieldDecoder (typeMustBeNamed "citext") $ CI.mk <$> fieldDecoder -- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default -- connection option). instance FromPgField (CI String) where + {-# INLINE fieldDecoder #-} fieldDecoder = typeFieldDecoder (typeMustBeNamed "citext") $ CI.mk <$> fieldDecoder {-# INLINE utcTimeRowDecoder #-} @@ -1239,6 +1207,7 @@ utcTimeRowDecoder = do _ -> pure Nothing instance FromPgField UTCTime where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "UTCTime" [timestamptzOid] $ \case bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 @@ -1247,19 +1216,11 @@ instance FromPgField UTCTime where parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 Right $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - -- {-# NOINLINE fieldAndValueDecoder #-} - -- fieldAndValueDecoder = utcTimeRowDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just utcTimeRowDecoder --- instance {-# OVERLAPPING #-} FromPgField (Maybe UTCTime) where --- -- This overlapping instance isn't pretty, but it reduces memory --- -- usage and improves performance a bit --- fieldDecoder = error "TODO Maybe UTCTime" --- {-# INLINE fieldAndValueDecoder #-} --- fieldAndValueDecoder = utcTimeRowDecoder - instance FromPgField (Unbounded UTCTime) where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Unbounded UTCTime" [timestamptzOid] $ \case bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 @@ -1276,6 +1237,7 @@ instance FromPgField (Unbounded UTCTime) where in Finite $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) instance FromPgField ZonedTime where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "ZonedTime" [timestamptzOid] $ \case bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 @@ -1285,6 +1247,7 @@ instance FromPgField ZonedTime where Right $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) instance FromPgField (Unbounded ZonedTime) where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Unbounded ZonedTime" [timestamptzOid] $ \case bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 @@ -1301,6 +1264,7 @@ instance FromPgField (Unbounded ZonedTime) where in Finite $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) instance FromPgField LocalTime where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "LocalTime" [timestampOid] $ \case bs -> do totalusecs <- BinSer.decodeInt64BE 0 bs @@ -1309,6 +1273,7 @@ instance FromPgField LocalTime where Right $ LocalTime parsedDate (timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) instance FromPgField TimeOfDay where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "TimeOfDay" [timeOid] $ \case bs -> do usecs <- BinSer.decodeInt64BE 0 bs @@ -1321,6 +1286,7 @@ dayRowDecoder = in fmap int32ToDay <$> Parser.takeInt32BEWithFieldLength instance FromPgField Day where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Day" [dateOid] $ \case bs -> do -- There is a very specific conversion function for these, which I poorly translated to Haskell @@ -1329,19 +1295,11 @@ instance FromPgField Day where jd <- BinSer.decodeInt32BE 0 bs Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 - -- {-# INLINE fieldAndValueDecoder #-} - -- fieldAndValueDecoder = dayRowDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just dayRowDecoder --- instance {-# OVERLAPPING #-} FromPgField (Maybe Day) where --- -- This overlapping instance isn't pretty, but it reduces memory --- -- usage and improves performance a bit --- fieldDecoder = error "TODO Maybe Day" --- {-# INLINE fieldAndValueDecoder #-} --- fieldAndValueDecoder = dayRowDecoder - instance FromPgField (Unbounded Day) where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Unbounded Day" [dateOid] $ \case bs -> do -- There is a very specific conversion function for these, which I poorly translated to Haskell @@ -1358,6 +1316,7 @@ instance FromPgField (Unbounded Day) where Finite $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 instance FromPgField CalendarDiffTime where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "CalendarDiffTime " [intervalOid] $ \bs -> do nMicrosecs <- BinSer.decodeInt64BE 0 bs nDays <- BinSer.decodeInt32BE 8 bs @@ -1365,12 +1324,14 @@ instance FromPgField CalendarDiffTime where Right $ CalendarDiffTime {ctMonths = fromIntegral nMonths, ctTime = secondsToNominalDiffTime (fromIntegral nDays * 86400) + realToFrac (picosecondsToDiffTime (fromIntegral nMicrosecs * 1_000_000))} instance FromPgField UUID where + {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "UUID" [uuidOid] $ \case bs -> case UUID.fromByteString (LBS.fromStrict bs) of Just uuid -> Right uuid Nothing -> Left "Bug in Hpgsql: UUID field could not be decoded" instance FromPgField Aeson.Value where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = @@ -1397,19 +1358,8 @@ nullableField FieldDecoder {..} = allowedPgTypes } -{-# INLINE nonNullableRowDec #-} -nonNullableRowDec :: String -> RowDecoder (Maybe a) -> RowDecoder a -nonNullableRowDec haskellTypeName rdec = - let fromNullable mVal = case mVal of - Nothing -> fail $ "Cannot decode SQL null as the Haskell " ++ haskellTypeName ++ " type. Use a `" ++ haskellTypeName ++ "` if you want SQL nulls" - Just v -> pure v - in RowDecoder - { fullRowDecoder = \finfos -> rdec.fullRowDecoder finfos >>= fromNullable, - rowColumnsTypeCheck = rdec.rowColumnsTypeCheck, - numExpectedColumns = rdec.numExpectedColumns - } - instance (FromPgField a) => FromPgField (Maybe a) where + {-# INLINE fieldDecoder #-} fieldDecoder = nullableField fieldDecoder {-# INLINE inlinedConstFieldDecoder #-} @@ -1427,36 +1377,6 @@ instance (FromPgField a) => FromPgField (Maybe a) where Nothing -> pure Nothing -- Must return Nothing for SQL Nulls jv -> pure $ Just jv --- let ffdec = fieldAndValueDecoder @a --- in --- RowDecoder --- { fullRowDecoder = \finfos -> --- let frd = fieldAndValueDecoder.fullRowDecoder finfos --- in do --- -- TODO: We're decoding the field length twice with --- -- the peek call when the value isn't NULL. --- -- Maybe we should make `FromPgField`'s new methods --- -- be two `Parser` objects: one for both length and field --- -- and another only for the field (but how would that work --- -- without the length..? It wouldn't.) --- -- Maybe we do the `Parser (Maybe a)` for `a` types, then. --- -- We can build a `Parser a` from that with `decodesSqlNullTo` --- -- and with inlining there's nothing to lose? --- fieldLen <- Parser.peekInt32BE --- if fieldLen == (-1) --- then case fieldDecoder.decodesSqlNullTo of --- Left err -> fail err --- Right v -> Parser.skip 4 >> pure v --- else do --- Just <$> frd, --- rowColumnsTypeCheck = --- let fdec = fieldDecoder @a --- in \case --- [singleColInfo] -> [(singleColInfo, fdec.allowedPgTypes singleColInfo)] --- _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", --- numExpectedColumns = 1 --- } - allowOnlyArrayTypes :: FieldInfo -> Bool allowOnlyArrayTypes fieldInfo = -- TODO: We could check the elemTypeOid too, but maybe later @@ -1536,7 +1456,7 @@ instance (FromPgField a) => ProductTypeDecoder (K1 r a) where -- coercing instead of fmap reduces memory usage, apparently -- by reducing (unnecessary) closures in the final row decoder, -- as per looking at GHC Core - genRowDecoder = coerce $ singleFieldRowDecoder @a + genRowDecoder = coerce $ inlinedSingleFieldRowDecoder @a genericToPgRow :: forall a. (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a genericToPgRow = contramap from genRowEncoder diff --git a/hpgsql/src/Hpgsql/Types.hs b/hpgsql/src/Hpgsql/Types.hs index 8cc68ce..77c2dc1 100644 --- a/hpgsql/src/Hpgsql/Types.hs +++ b/hpgsql/src/Hpgsql/Types.hs @@ -40,6 +40,7 @@ instance forall a. (ToPgField a) => ToPgField (PGArray a) where } instance forall a. (FromPgField a) => FromPgField (PGArray a) where + {-# INLINE fieldDecoder #-} fieldDecoder = PGArray <$> arrayField replicateM fieldDecoder -- | A way to compose two rows. @@ -83,13 +84,16 @@ pgJsonByteString :: PgJson -> ByteString pgJsonByteString (PgJson bs) = bs instance FromPgField PgJson where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in \bs -> Right $ PgJson $ fixJsonb bs, + let + -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in + \bs -> Right $ PgJson $ fixJsonb bs, decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell PgJson type. Use a `Maybe PgJson` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } @@ -102,15 +106,18 @@ newtype Aeson a = Aeson {getAeson :: a} deriving newtype (Eq) instance (FromJSON a) => FromPgField (Aeson a) where + {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in \bs -> case Aeson.decodeStrict $ fixJsonb bs of - Just v -> Right $ Aeson v - Nothing -> Left "Failed to decode postgres JSON value into your `Aeson a` type. Are you sure it's proper JSON?", + let + -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in + \bs -> case Aeson.decodeStrict $ fixJsonb bs of + Just v -> Right $ Aeson v + Nothing -> Left "Failed to decode postgres JSON value into your `Aeson a` type. Are you sure it's proper JSON?", decodesSqlNullTo = Left "Cannot decode SQL null as a Haskell (Aeson a) type. Use a `Maybe (Aeson a)` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } From 3f3a6300e472d51a99a36d64d15bf1d43976d85f Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Wed, 19 Aug 2026 21:13:47 -0300 Subject: [PATCH 11/38] Trying a specialized notConst method Types like `Scientific` are not being decoded optimally otherwise, and they can do better than in the current state --- Runfile | 2 +- TODO.md | 3 +- .../Database/PostgreSQL/Simple/FromField.hs | 10 +- .../Database/PostgreSQL/Simple/HpgsqlUtils.hs | 21 +- hpgsql/src/Hpgsql/Encoding.hs | 270 ++++++++---------- hpgsql/src/Hpgsql/Types.hs | 41 ++- 6 files changed, 173 insertions(+), 174 deletions(-) diff --git a/Runfile b/Runfile index 96050eb..1154f3c 100644 --- a/Runfile +++ b/Runfile @@ -76,7 +76,7 @@ tests: if [ -n "$NIX" ]; then nix-build --no-out-link -A "testsPg${pg}" --argstr hspecArgs "$TARGS" else - cabal build hpgsql-tests # hpgsql-simple-compat-tests + cabal build hpgsql-tests hpgsql-simple-compat-tests nix-shell -A "shellPg${pg}" ./default.nix --run "./scripts/run-tests-db-internal.sh $TARGS" fi done diff --git a/TODO.md b/TODO.md index 6d50f38..95ea5db 100644 --- a/TODO.md +++ b/TODO.md @@ -1,2 +1,3 @@ - Test both `singleField fieldDecoder` and `singleFieldRowDecoder` for every type in our tests. -- Some types (the Aeson ones, for example) still don't derive specialized row decoders +- Some types (the Aeson ones, for example, but more) still don't derive specialized row decoders +- "Oh no! No colInfo here.. what do we do!?" in hpgsql-simple-compat. This might require a big rethinking of things.. diff --git a/hpgsql-simple-compat/src/Database/PostgreSQL/Simple/FromField.hs b/hpgsql-simple-compat/src/Database/PostgreSQL/Simple/FromField.hs index 3a2b83b..42e124e 100644 --- a/hpgsql-simple-compat/src/Database/PostgreSQL/Simple/FromField.hs +++ b/hpgsql-simple-compat/src/Database/PostgreSQL/Simple/FromField.hs @@ -177,9 +177,13 @@ class FromField a where let dec = Hpgsql.fieldDecoder in \f -> if Hpgsql.allowedPgTypes dec f - then \mbs -> Conversion $ \_encCtx -> case Hpgsql.fieldValueDecoder dec f mbs of - Right v -> Ok v - Left err -> Errors [toException $ userError err] + then \mbs -> Conversion $ \_encCtx -> case mbs of + Nothing -> case dec.decodesSqlNullTo of + Left err -> Errors [toException $ userError err] + Right v -> Ok v + Just bs -> case Hpgsql.fieldValueDecoder dec f bs of + Right v -> Ok v + Left err -> Errors [toException $ userError err] else \_ -> Conversion $ \_encCtx -> Errors [toException $ userError "Invalid type OID for FromField instance"] instance FromField () diff --git a/hpgsql-simple-compat/src/Database/PostgreSQL/Simple/HpgsqlUtils.hs b/hpgsql-simple-compat/src/Database/PostgreSQL/Simple/HpgsqlUtils.hs index 63a2898..cf42a1d 100644 --- a/hpgsql-simple-compat/src/Database/PostgreSQL/Simple/HpgsqlUtils.hs +++ b/hpgsql-simple-compat/src/Database/PostgreSQL/Simple/HpgsqlUtils.hs @@ -95,18 +95,29 @@ type FieldParser a = Field -> Maybe ByteString -> Conversion a toHpgsqlFieldDecoder :: FieldParser a -> FieldDecoder a toHpgsqlFieldDecoder fp = FieldDecoder - { fieldValueDecoder = \colInfo mbs -> - let valConv = fp colInfo mbs + { fieldValueDecoder = \colInfo bs -> + let valConv = fp colInfo (Just bs) in case runConversion valConv colInfo.encodingContext of Ok v -> Right v Errors errs -> Left (show errs), + decodesSqlNullTo = + let valConv = fp (error "Oh no! No colInfo here.. what do we do!?") Nothing + encCtx = error "We could fake an EncodingContext, at least. TODO." + in case runConversion valConv encCtx of + Ok v -> Right v + Errors errs -> Left (show errs), allowedPgTypes = const True -- No way to check if types are valid ahead of time } fromHpgsqlFieldDecoder :: FieldDecoder a -> FieldParser a -fromHpgsqlFieldDecoder dec = \f mbs -> Conversion $ \_encCtx -> case dec.fieldValueDecoder f mbs of - Right v -> Ok v - Left err -> Errors [toException $ userError $ show err] +fromHpgsqlFieldDecoder dec = \f mbs -> Conversion $ \_encCtx -> + case mbs of + Nothing -> case dec.decodesSqlNullTo of + Left err -> Errors [toException $ userError $ show err] + Right v -> Ok v + Just bs -> case dec.fieldValueDecoder f bs of + Right v -> Ok v + Left err -> Errors [toException $ userError $ show err] -- | Given a Hpgsql query, returns the text format with question marks -- for query arguments and a row object. With both, you can call diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index f04ee23..91f35ab 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,7 @@ data FieldInfo = FieldInfo -- | A decoder for a single field/column. data FieldDecoder a = FieldDecoder - { fieldValueDecoder :: FieldInfo -> ByteString -> Either String a, -- TODO: Since this now takes a ByteString (not a Maybe), it could actually be typed `FieldInfo -> Parser a` + { fieldValueDecoder :: FieldInfo -> ByteString -> Either String a, decodesSqlNullTo :: Either String a, allowedPgTypes :: FieldInfo -> Bool } @@ -162,110 +162,77 @@ instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in {-# INLINE singleField #-} singleField :: FieldDecoder a -> RowDecoder a singleField fdec = - -- TODO: Float out decodesSqlNullTo to here. Does it make a difference? - RowDecoder - { fullRowDecoder = \case - [singleColInfo] -> - let decode = fdec.fieldValueDecoder singleColInfo - in do - lenNextCol <- fromIntegral <$> Parser.takeInt32BE - if lenNextCol >= 0 - then do - nextColBs <- Parser.take lenNextCol - case decode nextColBs of - Right v -> pure v - Left err -> fail err - -- This `case` is why we require `fieldAndValueDecoder` to decode - -- SQL NULL into `Nothing`: we do check decodesSqlNullTo. - else case fdec.decodesSqlNullTo of - Right v -> pure v - Left err -> fail err - _ -> error "singleField expected a single column OID but got 0 or >1", - rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, fdec.allowedPgTypes singleColInfo)] - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", - numExpectedColumns = 1 - } - -{-# INLINE inlinableRowDecoder #-} -inlinableRowDecoder :: [Oid] -> Parser.Parser a -> RowDecoder a -inlinableRowDecoder tyoids p = - -- FromPgField instances whose decoders don't care about the OID of the PG type - -- being decoded are very dear to us because they allow a very important optimization: - -- their row decoders do not care about the `FieldInfo` argument, which - -- makes them inlinable by GHC at compile time (FieldInfo is only available - -- at run time when the RowDescription message arrives for a given query). - -- These are key to produce compiled to code that almost compiles down to - -- a bunch of `peek` calls to a single ByteString decoding bytes into - -- typed values, to then call the Parser continuation, and repeat. - -- The only allocations (I think) when everything is inlined by this are the - -- decoded values themselves being boxed and the CPS Parser's ByteStringIdx - -- also being passed boxed between continuations (though reading GHC Core - -- is something I'm still learning). - RowDecoder - { fullRowDecoder = const p, - rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid `elem` tyoids)] - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", - numExpectedColumns = 1 - } + -- This `case` is why we require `fieldAndValueDecoder` to decode + -- SQL NULL into `Nothing`: we do check decodesSqlNullTo. + let !valueForNull = case fdec.decodesSqlNullTo of + Left err -> fail err + Right v -> pure v + !typeCheck = fdec.allowedPgTypes + in RowDecoder + { fullRowDecoder = \case + [singleColInfo] -> + let decode = fdec.fieldValueDecoder singleColInfo + in do + lenNextCol <- fromIntegral <$> Parser.takeInt32BE + if lenNextCol >= 0 + then do + nextColBs <- Parser.take lenNextCol + case decode nextColBs of + Right v -> pure v + Left err -> fail err + else valueForNull + _ -> error "singleField expected a single column OID but got 0 or >1", + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, typeCheck singleColInfo)] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } class FromPgField a where {-# MINIMAL fieldDecoder #-} fieldDecoder :: FieldDecoder a - -- | This should be semantically equivalent to `singleField fieldDecoder`, - -- but it can be overridden (and is for base types) to a much faster implementation. - -- Using this when deriving your `FromPgRow` instances will increase code size and - -- possibly compilation times somewhat, but in some cases it can make row decoders - -- compile down to a ByteString-peeking implementation with much fewer - -- allocations and thus better performance. - -- Any implementation of this _must_ return a `Nothing` for a SQL NULL value, - -- regardless of what `FieldDecoder` would do with a SQL NULL. - {-# NOINLINE fieldAndValueDecoder #-} - fieldAndValueDecoder :: RowDecoder (Maybe a) - fieldAndValueDecoder = - -- TODO: Float out allowedPgTypes? Does it matter at all? - -- TODO: This method is.. only useful for the `Scientific` type, - -- which can provide a faster row decoder but still needs to know - -- the type's OID. Maybe it's useful for our Aeson types too? - -- In any case, this class has many methods, and their names should - -- better reflect when they're useful and what they do, and `fieldAndValueDecoder` - -- might not be doing the best job in the world at that. - RowDecoder - { fullRowDecoder = - case inlinedConstFieldDecoder of - Nothing -> slowerParser - Just fd -> const fd, - rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, (fieldDecoder @a).allowedPgTypes singleColInfo)] - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", - numExpectedColumns = 1 - } - where - -- slowerParser takes a ByteString and passes it to the - -- field decoder. - slowerParser = \case - [singleColInfo] -> do - len <- Parser.takeInt32BE - if len == (-1) - then pure Nothing - else do - bs <- Parser.take (fromIntegral len) - case fieldDecoder.fieldValueDecoder singleColInfo bs of - Left err -> fail err - Right v -> pure v - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1" - -- | For types where there is a fast way to decode fields+values -- without knowing the OID of the value in the query (of course, the -- possible OIDs are still limited by the FieldDecoder's allowed types), - -- this can help provide a significant boost to inlined row decoders. - -- Define as `Nothing` if this isn't possible. + -- defining this can help provide a significant performance boost to inlined row decoders. + -- + -- Any implementation of this _must_ return a `Nothing` for a SQL NULL value, + -- regardless of what `FieldDecoder` would do with a SQL NULL. + -- + -- Define this as `Nothing` if implementing it isn't possible. + -- This isn't exposed to users yet, but we should recommend they add an INLINE pragma, + -- as the method's name suggests. {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder :: Maybe (Parser.Parser (Maybe a)) inlinedConstFieldDecoder = Nothing + -- | For types that can't implement `inlinedConstFieldDecoder` 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 @@ -275,8 +242,25 @@ class FromPgField a where inlinedSingleFieldRowDecoder = case inlinedConstFieldDecoder @a of -- This is a class method instead of a top-level function -- because the GHC inliner behaves differently when it's a top-level - -- function, and benchmarks show it gets worse. - Nothing -> singleField fieldDecoder + -- function, and benchmarks show this is faster. + Nothing -> + let !valueForNull = case (fieldDecoder @a).decodesSqlNullTo of + Left err -> fail err + Right v -> pure v + !typeCheck = (fieldDecoder @a).allowedPgTypes + in RowDecoder + { fullRowDecoder = \case + [singleColInfo] -> do + mv <- notConstFieldDecoder singleColInfo + case mv of + Nothing -> valueForNull + Just v -> pure v + _ -> error "singleField expected a single column OID but got 0 or >1", + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, typeCheck singleColInfo)] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } Just p -> -- The strictness and floating out of fieldDecoder-derived -- values allows GHC to inline a lot more. For example, `valueForNull` @@ -318,12 +302,12 @@ compositeTypeDecoder :: forall a. RowDecoder a -> FieldDecoder a compositeTypeDecoder (RowDecoder {..}) = FieldDecoder { fieldValueDecoder = \compositeTypeOid -> - let prs = parserForRecord compositeTypeOid.encodingContext <* Parser.endOfInput + let !prs = parserForRecord compositeTypeOid.encodingContext <* Parser.endOfInput in \bs -> case Parser.parseOnly prs bs of Parser.ParseOk v -> Right v Parser.ParseFail err -> Left err, - decodesSqlNullTo = Left "TODO: composeTypeDecoder decodesSqlNullTo", + decodesSqlNullTo = Left "Got NULL in composite type but it was not allowed", allowedPgTypes = const True -- There's no way to enforce a custom type's OID. We only check if it's structurally the same in the parser (same subtypes in same order) } where @@ -877,20 +861,6 @@ instance FromPgField () where allowedPgTypes = (== voidOid) . fieldTypeOid } --- TODO: Inline intRowDecoder into FromPgField? And all others too? -{-# INLINE intRowDecoder #-} -intRowDecoder :: Parser.Parser (Maybe Int) -intRowDecoder = do - fieldLen <- Parser.takeInt32BE - -- TODO: We're assuming `Int` is always 64 bits, so 64bit CPUs? Is that ok? - -- TODO: Is there a way to optimistically assume <=4 bytes and use our custom new parser? - case fieldLen of - 4 -> Just . fromIntegral <$> Parser.takeInt32BE - (-1) -> pure Nothing - 8 -> Just . fromIntegral <$> Parser.takeInt64BE - 2 -> Just . fromIntegral <$> Parser.takeInt16BE - _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" - instance FromPgField Int where {-# INLINE fieldDecoder #-} fieldDecoder = @@ -903,7 +873,16 @@ instance FromPgField Int where } {-# INLINE inlinedConstFieldDecoder #-} - inlinedConstFieldDecoder = Just intRowDecoder + inlinedConstFieldDecoder = Just $ do + fieldLen <- Parser.takeInt32BE + -- TODO: We're assuming `Int` is always 64 bits, so 64bit CPUs? Is that ok? + -- TODO: Is there a way to optimistically assume <=4 bytes and use our custom new parser? + case fieldLen of + 4 -> Just . fromIntegral <$> Parser.takeInt32BE + (-1) -> pure Nothing + 8 -> Just . fromIntegral <$> Parser.takeInt64BE + 2 -> Just . fromIntegral <$> Parser.takeInt16BE + _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" instance FromPgField Int16 where {-# INLINE fieldDecoder #-} @@ -916,17 +895,6 @@ instance FromPgField Int16 where allowedPgTypes = (== int2Oid) . fieldTypeOid } -{-# INLINE int32RowDecoder #-} -int32RowDecoder :: RowDecoder (Maybe Int32) -int32RowDecoder = - inlinableRowDecoder [int2Oid, int4Oid] $ do - fieldLen <- Parser.takeInt32BE - case fieldLen of - 4 -> Just <$> Parser.takeInt32BE - (-1) -> pure Nothing - 2 -> Just . fromIntegral <$> Parser.takeInt16BE - _ -> fail "Trying to decode PG int4 but it's not 2 or 4 bytes long" - instance FromPgField Int32 where {-# INLINE fieldDecoder #-} fieldDecoder = @@ -935,20 +903,14 @@ instance FromPgField Int32 where decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int32 type. Use a `Maybe Int32`", allowedPgTypes = (`elem` [int2Oid, int4Oid]) . fieldTypeOid } - {-# INLINE fieldAndValueDecoder #-} - fieldAndValueDecoder = int32RowDecoder - -{-# INLINE int64RowDecoder #-} -int64RowDecoder :: RowDecoder (Maybe Int64) -int64RowDecoder = - inlinableRowDecoder [int2Oid, int4Oid, int8Oid] $ do + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just $ do fieldLen <- Parser.takeInt32BE case fieldLen of - 8 -> Just <$> Parser.takeInt64BE - 4 -> Just . fromIntegral <$> Parser.takeInt32BE + 4 -> Just <$> Parser.takeInt32BE (-1) -> pure Nothing 2 -> Just . fromIntegral <$> Parser.takeInt16BE - _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" + _ -> fail "Trying to decode PG int4 but it's not 2 or 4 bytes long" instance FromPgField Int64 where {-# INLINE fieldDecoder #-} @@ -958,8 +920,15 @@ instance FromPgField Int64 where decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int64 type. Use a `Maybe Int64`", allowedPgTypes = (`elem` [int2Oid, int4Oid, int8Oid]) . fieldTypeOid } - {-# INLINE fieldAndValueDecoder #-} - fieldAndValueDecoder = int64RowDecoder + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just $ do + fieldLen <- Parser.takeInt32BE + case fieldLen of + 8 -> Just <$> Parser.takeInt64BE + 4 -> Just . fromIntegral <$> Parser.takeInt32BE + (-1) -> pure Nothing + 2 -> Just . fromIntegral <$> Parser.takeInt16BE + _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" instance FromPgField Integer where {-# INLINE fieldDecoder #-} @@ -1090,21 +1059,13 @@ instance FromPgField Scientific where decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`", allowedPgTypes = (`elem` [numericOid, int2Oid, int4Oid, int8Oid]) . fieldTypeOid } - {-# INLINE fieldAndValueDecoder #-} - fieldAndValueDecoder = - RowDecoder - { fullRowDecoder = \case - [singleColInfo] -> - if singleColInfo.fieldTypeOid /= numericOid - then - fmap (flip scientific 0 . fromIntegral) <$> (fieldAndValueDecoder @Int64).fullRowDecoder [singleColInfo] - else numericRowParser - _ -> error "singleField expected a single column OID but got 0 or >1", - rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, singleColInfo.fieldTypeOid `elem` [numericOid, int2Oid, int4Oid, int8Oid])] - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", - numExpectedColumns = 1 - } + {-# INLINE 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 #-} @@ -1362,6 +1323,13 @@ instance (FromPgField a) => FromPgField (Maybe a) where {-# INLINE fieldDecoder #-} fieldDecoder = nullableField fieldDecoder + {-# INLINE notConstFieldDecoder #-} + notConstFieldDecoder finfo = do + mv <- notConstFieldDecoder @a finfo + case mv of + Nothing -> pure Nothing + jv -> pure $ Just jv + {-# INLINE inlinedConstFieldDecoder #-} -- \| For types where there is a fast way to decode fields+values -- without knowing the OID of the value in the query (of course, the diff --git a/hpgsql/src/Hpgsql/Types.hs b/hpgsql/src/Hpgsql/Types.hs index 77c2dc1..2fc1dbe 100644 --- a/hpgsql/src/Hpgsql/Types.hs +++ b/hpgsql/src/Hpgsql/Types.hs @@ -20,6 +20,7 @@ import Data.Tuple.Only (Only (..)) import Data.Typeable (Proxy (..)) import Hpgsql.Builder (BinaryField (..)) import Hpgsql.Encoding (FieldDecoder (..), FieldEncoder (..), FieldInfo (..), FromPgField (..), FromPgRow (..), RowEncoder (..), ToPgField (..), ToPgRow (..), arrayField, toPgVectorField) +import qualified Hpgsql.SimpleParser as Parser import Hpgsql.TypeInfo (EncodingContext (..), TypeInfo (..), jsonOid, jsonbOid, lookupTypeByOid) -- | Encodes a Haskell list as a postgres array. You can also use `Vector` if you prefer. @@ -64,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 @@ -89,14 +90,22 @@ instance FromPgField PgJson where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let - -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in - \bs -> Right $ PgJson $ fixJsonb bs, + let -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in \bs -> Right $ PgJson $ fixJsonb bs, decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell PgJson type. Use a `Maybe PgJson` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } + {-# 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 @@ -111,16 +120,22 @@ instance (FromJSON a) => FromPgField (Aeson a) where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let - -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in - \bs -> case Aeson.decodeStrict $ fixJsonb bs of - Just v -> Right $ Aeson v - Nothing -> Left "Failed to decode postgres JSON value into your `Aeson a` type. Are you sure it's proper JSON?", + let -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in \bs -> case Aeson.decodeStrict $ fixJsonb bs of + Just v -> Right $ Aeson v + Nothing -> Left "Failed to decode the postgres JSON value into your `Aeson a` type with aeson", decodesSqlNullTo = Left "Cannot decode SQL null as a Haskell (Aeson a) type. Use a `Maybe (Aeson a)` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } + {-# INLINE notConstFieldDecoder #-} + notConstFieldDecoder finfo = + notConstFieldDecoder finfo >>= \case + Nothing -> pure Nothing + Just (PgJson jsonBs) -> + case Aeson.decodeStrict jsonBs of + Just v -> pure $ Just $ Aeson v + Nothing -> fail "Failed to decode the postgres JSON value into your `Aeson a` type with aeson" instance (ToJSON a) => ToPgField (Aeson a) where fieldEncoder = From 7d0d7445f255cb7bfa6315467a6b9815109319fb Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Fri, 14 Aug 2026 16:24:49 -0300 Subject: [PATCH 12/38] Create new strict and lazy ByteString-like PinnedByteArray types And use them almost everywhere. --- Runfile | 2 +- TODO.md | 14 +- hpgsql-benchmarks/src/Main.hs | 41 +- hpgsql-tests/EncodingDecodingSpec.hs | 45 + hpgsql/hpgsql.cabal | 3 +- hpgsql/src/Hpgsql/Encoding.hs | 1559 +--------------- .../src/Hpgsql/Encoding/BinarySerializer.hs | 226 --- hpgsql/src/Hpgsql/Encoding/Internal.hs | 1579 +++++++++++++++++ hpgsql/src/Hpgsql/Internal.hs | 43 +- hpgsql/src/Hpgsql/InternalTypes.hs | 5 +- hpgsql/src/Hpgsql/Msgs.hs | 14 +- hpgsql/src/Hpgsql/Networking.hs | 17 +- hpgsql/src/Hpgsql/PinnedByteArray.hs | 409 +++++ hpgsql/src/Hpgsql/SimpleParser.hs | 79 +- hpgsql/src/Hpgsql/Types.hs | 25 +- 15 files changed, 2217 insertions(+), 1844 deletions(-) delete mode 100644 hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs create mode 100644 hpgsql/src/Hpgsql/Encoding/Internal.hs create mode 100644 hpgsql/src/Hpgsql/PinnedByteArray.hs diff --git a/Runfile b/Runfile index 1154f3c..96050eb 100644 --- a/Runfile +++ b/Runfile @@ -76,7 +76,7 @@ tests: if [ -n "$NIX" ]; then nix-build --no-out-link -A "testsPg${pg}" --argstr hspecArgs "$TARGS" else - cabal build hpgsql-tests hpgsql-simple-compat-tests + cabal build hpgsql-tests # hpgsql-simple-compat-tests nix-shell -A "shellPg${pg}" ./default.nix --run "./scripts/run-tests-db-internal.sh $TARGS" fi done diff --git a/TODO.md b/TODO.md index 95ea5db..68027de 100644 --- a/TODO.md +++ b/TODO.md @@ -1,3 +1,15 @@ +- Check that users can define their own types and create FromPgField instances that derive performant instances. Do they override the specialized methods? How do they do that? + - newtype-derived and simple `fmap`'d instances can, but instances that want to fail on some values cannot (no Monad instance for RowDecoder) and have to override the FieldDecoder. +- Expose a `PinnedByteArray` with `toByteString` to users, move current module to PinnedByteArray.Internal - 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 +- Do _not_ expose new FromPgField methods. Add new EncodingInternal module, instead. + - Check that the non-exposed methods are safe wrt bytearray bounds access by construction, and users can't break that. If that's true, we can omit bounds checks in our row decoding, making row decoders smaller and maybe faster. +- Some types might still not derive specialized row decoders - "Oh no! No colInfo here.. what do we do!?" in hpgsql-simple-compat. This might require a big rethinking of things.. +- Double-check which row encoders we want to use the inlined versions for and which we don't. Tuples? +- Text internals usage.. is it safe? Double-check. +- Expose in the FromPgField class two new methods.. inlined and non inlined row decoders with/without bounds checks. Use with-bounds-checks for MonadicRowDecoder, and without-bounds-checks for regular row decoder, because the latter checks type oids + - The specialized row decoders are already a problem here! They don't check type OIDs and can read bytes partially. We should ensure this mismatch is not possible. +- Is `notInlinedSingleFieldRowDecoder` worth keeping? The Generically derived decoder is almost as fast. Maybe for types that aren't records it's a different story, though? +- Check that we're not holding on to internal buffers when Record fields being materialized into aren't strict +- Write property-based tests for PinnedByteArray functions diff --git a/hpgsql-benchmarks/src/Main.hs b/hpgsql-benchmarks/src/Main.hs index a1d9353..81543a2 100644 --- a/hpgsql-benchmarks/src/Main.hs +++ b/hpgsql-benchmarks/src/Main.hs @@ -47,7 +47,7 @@ import Hpgsql.Connection (renderLibpqConnectionString) import qualified Hpgsql.Connection import qualified Hpgsql.Connection as Hpgsql import qualified Hpgsql.Copy -import Hpgsql.Encoding (inlinedSingleFieldRowDecoder) +import Hpgsql.Encoding (inlinedSingleFieldRowDecoder, notInlinedSingleFieldRowDecoder) import qualified Hpgsql.Encoding as Hpgsql import qualified Hpgsql.Query as Hpgsql import qualified Hpgsql.Types as Hpgsql @@ -92,6 +92,14 @@ data BenchRow = BenchRow deriving stock (Generic, Show, Eq) deriving anyclass (NFData, Hpgsql.FromPgRow, PGSimple.FromRow) +singleFieldFieldDecoderBenchRowDecoder :: Hpgsql.RowDecoder BenchRow +singleFieldFieldDecoderBenchRowDecoder = + BenchRow <$> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder + +notInlinedHandWrittenBenchRowDecoder :: Hpgsql.RowDecoder BenchRow +notInlinedHandWrittenBenchRowDecoder = + BenchRow <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + fullyInlinedBenchRowDecoder :: Hpgsql.RowDecoder BenchRow fullyInlinedBenchRowDecoder = BenchRow <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder @@ -306,11 +314,36 @@ main = do runResourceT @IO $ do 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, Generically derived row decoder)") $ + it ("hpgsql Record Stream (" ++ show n ++ " rows, `singleField fieldDecoder` row decoder)") $ + void $ + bench ("hpgsql Record Stream (" ++ show n ++ " rows, `singleField fieldDecoder` row decoder)") $ do + withMultipleConnections numConcurrentConnections hpgsqlConnect Hpgsql.Connection.closeGracefully $ \conn -> do + res <- Hpgsql.querySWith singleFieldFieldDecoderBenchRowDecoder conn (Hpgsql.mkQuery sql17 (Hpgsql.Only n)) + S.effects res + it ("hpgsql Record Stream (" ++ show n ++ " rows, hand-written row decoder)") $ + void $ + bench ("hpgsql Record Stream (" ++ show n ++ " rows, hand-written row decoder)") $ do + withMultipleConnections numConcurrentConnections hpgsqlConnect Hpgsql.Connection.closeGracefully $ \conn -> do + res <- Hpgsql.querySWith notInlinedHandWrittenBenchRowDecoder conn (Hpgsql.mkQuery sql17 (Hpgsql.Only n)) + S.effects res + it ("hpgsql Record Stream (" ++ show n ++ " rows, fully inlined row decoder)") $ + void $ + bench ("hpgsql Record Stream (" ++ show n ++ " rows, fully inlined row decoder)") $ do + 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 sql17Simple (PGSimple.Only n) + S.effects res + it ("postgresql-simple Record fold (" ++ show n ++ " rows)") $ void $ - bench ("postgresql-simple Record fold (" ++ show n ++ " rows, Generically derived row decoder)") $ + bench ("postgresql-simple Record fold (" ++ show n ++ " rows)") $ withMultipleConnections numConcurrentConnections pgSimpleConnect PGSimple.close $ \pgSimpleConn -> do - PGSimple.fold pgSimpleConn sql17Simple (PGSimple.Only n) () (\() (!_ :: BenchRow) -> pure ()) + 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) () (\() (!_ :: BenchRow) -> pure ()) describe "COPY FROM STDIN" $ do (conn, pgSimpleConn) <- runIO $ do hpgsqlConnInfo <- testConnInfo diff --git a/hpgsql-tests/EncodingDecodingSpec.hs b/hpgsql-tests/EncodingDecodingSpec.hs index 7cb5513..af7d8ee 100644 --- a/hpgsql-tests/EncodingDecodingSpec.hs +++ b/hpgsql-tests/EncodingDecodingSpec.hs @@ -123,6 +123,12 @@ spec = parallel $ do it "CI Text text decoding" ciTextTextDecoding + it + "Text values round-trip" + textRoundTrip + it + "Text text decoding" + textTextDecoding it "TimeOfDay values round-trip" timeOfDayRoundTrip @@ -690,6 +696,45 @@ ciTextTextDecoding conn = hedgehog $ do liftIO res1 >>= (=== expectedResult) liftIO res2 >>= (=== expectedResult) +textRoundTrip :: HPgConnection -> PropertyT IO () +textRoundTrip conn = hedgehog $ do + let genText = Gen.maybe $ Gen.text (Gen.linear 0 300) (Gen.filter (/= '\0') Gen.unicode) + genLazyText = Gen.maybe $ LT.fromStrict <$> Gen.text (Gen.linear 0 300) (Gen.filter (/= '\0') Gen.unicode) + genString = Gen.maybe $ Gen.string (Gen.linear 0 300) (Gen.filter (/= '\0') Gen.unicode) + row <- + Gen.forAll $ + (,,,,,,,,,) + <$> genText + <*> genText + <*> genText + <*> genText + <*> genLazyText + <*> genLazyText + <*> genLazyText + <*> genString + <*> genString + <*> genString + res <- + liftIO $ + query conn (mkQuery "SELECT $1, $2, $3, $4, $5, $6, $7, $8, $9, $10" row) + res === [row] + +textTextDecoding :: HPgConnection -> PropertyT IO () +textTextDecoding conn = hedgehog $ do + someText :: Text <- Gen.forAll $ Gen.text (Gen.linear 0 300) (Gen.filter (\c -> c /= '\0' && c /= '\'') Gen.unicode) + let qry = fromString $ "SELECT '" <> Text.unpack someText <> "'::text, '" <> Text.unpack someText <> "'::text, '" <> Text.unpack someText <> "'::text" + (res1, res2) <- + liftIO $ + runPipeline conn $ + (,) + <$> pipeline1With rowDecoder qry + -- Specialized row parsers of each type are a different implementation from + -- the simpler fieldDecoders, so we need to test both + <*> pipeline1With ((,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder) qry + let expectedResult = (someText, LT.fromStrict someText, Text.unpack someText) + liftIO res1 >>= (=== expectedResult) + liftIO res2 >>= (=== expectedResult) + timeOfDayRoundTrip :: HPgConnection -> PropertyT IO () timeOfDayRoundTrip conn = hedgehog $ do let genTimeOfDay = do diff --git a/hpgsql/hpgsql.cabal b/hpgsql/hpgsql.cabal index ae973a5..af82524 100644 --- a/hpgsql/hpgsql.cabal +++ b/hpgsql/hpgsql.cabal @@ -44,7 +44,7 @@ library Hpgsql.Types other-modules: Hpgsql.Base - Hpgsql.Encoding.BinarySerializer + Hpgsql.Encoding.Internal Hpgsql.Internal Hpgsql.LanguageHaskell.FromThExtension Hpgsql.LanguageHaskell.GhcParserOpts @@ -52,6 +52,7 @@ library Hpgsql.Locking Hpgsql.Msgs Hpgsql.Networking + Hpgsql.PinnedByteArray Hpgsql.QueryInternal Hpgsql.ScramSHA256 Hpgsql.SimpleParser diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index 91f35ab..cf4b978 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE UndecidableInstances #-} - -- | -- -- = Encoding and decoding fields and rows @@ -19,10 +17,35 @@ -- type check query results and field counts only once per query. If you need -- to write a row decoder that is monadic (because decoding can change depending on the values -- of fields), check "Hpgsql.Encoding.RowDecoderMonadic". +-- +-- = Performant row decoders +-- +-- Hpgsql provides roughly two* ways to derive row decoders from your types. +-- You can use `notInlinedSingleFieldRowDecoder` or `inlinedSingleFieldRowDecoder` for each field. +-- For example you can define: +-- +-- > data Car = Car { model :: Text, year :: Maybe Int, inGoodCondition :: Bool } +-- > +-- > instance FromPgRow Car where +-- > rowDecoder = Car <$> inlinedSingleFieldRowDecoder +-- > <*> inlinedSingleFieldRowDecoder +-- > <*> inlinedSingleFieldRowDecoder +-- +-- And hpgsql will derive a row decoder that is extremely fast because almost all the +-- decoding code is inlined. Fully inlined row decoders can be ~15% faster than not fully +-- inlined row decoders. +-- +-- However, bear in mind that fully inlined row decoders will generate more code and can possibly slow down compilation, +-- and that often the bottleneck is in query processing, not row decoding. +-- +-- Some notes: +-- +-- * Generically derived row decoders are not fully inlined, and perform as well as hand-written row decoders built with `notInlinedSingleFieldRowDecoder`. +-- * Another derivation method is to use `singleField fieldDecoder`. That is the least performant way of deriving row decoders, and is only useful if you need the ability to compose `FieldDecoder`s in ways that you can't otherwise. If you can, use `notInlinedSingleFieldRowDecoder` instead. module Hpgsql.Encoding ( -- * Decoding - FromPgField (..), -- We export the other internal perf-oriented methods, which isn't great because we may want to change them - FieldDecoder (..), -- TODO: Can we export ctor? + FromPgField (fieldDecoder, notInlinedSingleFieldRowDecoder, inlinedSingleFieldRowDecoder), -- Do not export other methods so we can change them + FieldDecoder (..), FieldInfo (..), FromPgRow (..), RowDecoder (..), -- TODO: Can we export ctor? @@ -68,1530 +91,4 @@ module Hpgsql.Encoding ) where -import Control.Monad (replicateM, unless, when) -import qualified Data.Aeson as Aeson -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC -import qualified Data.ByteString.Lazy as LBS -import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI -import Data.Coerce (coerce) -import Data.Fixed (divMod') -import Data.Functor.Contravariant (Contravariant (..)) -import Data.Int (Int16, Int32, Int64) -import qualified Data.List as List -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe) -import Data.Monoid (Sum (..)) -import Data.Proxy (Proxy (..)) -import Data.Ratio (Ratio) -import Data.Scientific (Scientific (..), floatingOrInteger, scientific) -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT -import Data.Time (CalendarDiffDays (..), CalendarDiffTime (..), Day, LocalTime (..), NominalDiffTime, TimeOfDay, UTCTime (..), ZonedTime, diffDays, diffTimeToPicoseconds, fromGregorian, picosecondsToDiffTime, secondsToNominalDiffTime, timeOfDayToTime, timeToTimeOfDay, utc, utcToZonedTime, zonedTimeToUTC) -import Data.Time.Calendar.Julian (addJulianDurationClip, fromJulian) -import Data.Tuple.Only (Only (..)) -import Data.UUID.Types (UUID) -import qualified Data.UUID.Types as UUID -import Data.Vector (Vector) -import qualified Data.Vector as Vector -import GHC.Float (castWord32ToFloat, castWord64ToDouble, expt, float2Double) -import GHC.Generics (C, D, Generic (..), K1 (..), M1 (..), Meta (MetaCons), U1 (..), (:*:) (..), (:+:) (..)) -import GHC.TypeLits (KnownSymbol, TypeError, symbolVal) -import qualified GHC.TypeLits as TypeLits -import Hpgsql.Builder (BinaryField (..)) -import qualified Hpgsql.Builder as Builder -import qualified Hpgsql.Encoding.BinarySerializer as BinSer -import qualified Hpgsql.SimpleParser as Parser -import Hpgsql.Time (Unbounded (..)) -import Hpgsql.TypeInfo (EncodingContext (..), Oid (..), TypeDetails (..), TypeInfo (..), boolOid, byteaOid, charOid, dateOid, float4Oid, float8Oid, int2Oid, int4Oid, int8Oid, intervalOid, jsonOid, jsonbOid, lookupTypeByName, lookupTypeByOid, nameOid, numericOid, oidOid, textOid, timeOid, timestampOid, timestamptzOid, uuidOid, varcharOid, voidOid) - -data FieldInfo = FieldInfo - { fieldTypeOid :: !Oid, - -- | The column name from the query's result, if available. - fieldName :: !(Maybe Text), - -- | The EncodingContext as of the moment the query ran. - encodingContext :: !EncodingContext - } - --- | A decoder for a single field/column. -data FieldDecoder a = FieldDecoder - { fieldValueDecoder :: FieldInfo -> ByteString -> Either String a, - decodesSqlNullTo :: Either String a, - allowedPgTypes :: FieldInfo -> Bool - } - deriving stock (Functor) - --- | `f1 <> f2` produces a `FieldDecoder` that tries `f1` first, and if that fails it tries `f2`. -instance Semigroup (FieldDecoder a) where - dec1 <> dec2 = - FieldDecoder - { fieldValueDecoder = \cInfo -> - let f1 = dec1.fieldValueDecoder cInfo - f2 = dec2.fieldValueDecoder cInfo - in \mbs -> - let cand1 = if dec1.allowedPgTypes cInfo then f1 mbs else Left "Not first parser" - cand2 = if dec2.allowedPgTypes cInfo then f2 mbs else Left "Not second parser" - in cand1 <> cand2, - decodesSqlNullTo = dec1.decodesSqlNullTo <> dec2.decodesSqlNullTo, - allowedPgTypes = \cInfo -> dec1.allowedPgTypes cInfo || dec2.allowedPgTypes cInfo - } - -data RowDecoder a = RowDecoder - { fullRowDecoder :: [FieldInfo] -> Parser.Parser a, - -- | Returns the same colInfos with a boolean indicating if - -- the expected types match for each colInfo. - rowColumnsTypeCheck :: [FieldInfo] -> [(FieldInfo, Bool)], - numExpectedColumns :: !Int - } - deriving stock (Functor, Generic) - -instance Applicative RowDecoder where - pure v = RowDecoder (const $ pure v) (map (,True)) 0 - {-# INLINE (<*>) #-} -- This is crucial for performance. It makes our CPS Parser truly compile to CPS row decoders. - RowDecoder p1 tc1 nc1 <*> RowDecoder p2 tc2 nc2 = RowDecoder (\colTypes -> let (cols1, cols2) = List.splitAt nc1 colTypes in p1 cols1 <*> p2 cols2) (\colTypes -> let (cols1, cols2) = List.splitAt nc1 colTypes in tc1 cols1 ++ tc2 cols2) (nc1 + nc2) - -instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in Hpgsql because Hpgsql type-checks the result types of queries before having access to even the first data row. Use the Applicative class to write your instances or use the Monadic decoding variants.")) => Monad RowDecoder where - (>>=) = error "inaccessible bind in Monad RowDecoder instance" - -{-# INLINE singleField #-} -singleField :: FieldDecoder a -> RowDecoder a -singleField fdec = - -- This `case` is why we require `fieldAndValueDecoder` to decode - -- SQL NULL into `Nothing`: we do check decodesSqlNullTo. - let !valueForNull = case fdec.decodesSqlNullTo of - Left err -> fail err - Right v -> pure v - !typeCheck = fdec.allowedPgTypes - in RowDecoder - { fullRowDecoder = \case - [singleColInfo] -> - let decode = fdec.fieldValueDecoder singleColInfo - in do - lenNextCol <- fromIntegral <$> Parser.takeInt32BE - if lenNextCol >= 0 - then do - nextColBs <- Parser.take lenNextCol - case decode nextColBs of - Right v -> pure v - Left err -> fail err - else valueForNull - _ -> error "singleField expected a single column OID but got 0 or >1", - rowColumnsTypeCheck = \case - [singleColInfo] -> [(singleColInfo, typeCheck singleColInfo)] - _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", - numExpectedColumns = 1 - } - -class FromPgField a where - {-# MINIMAL fieldDecoder #-} - fieldDecoder :: FieldDecoder a - - -- | For types where there is a fast way to decode fields+values - -- without knowing the OID of the value in the query (of course, the - -- possible OIDs are still limited by the FieldDecoder's allowed types), - -- defining this can help provide a significant performance boost to inlined row decoders. - -- - -- Any implementation of this _must_ return a `Nothing` for a SQL NULL value, - -- regardless of what `FieldDecoder` would do with a SQL NULL. - -- - -- Define this as `Nothing` if implementing it isn't possible. - -- This isn't exposed to users yet, but we should recommend they add an INLINE pragma, - -- as the method's name suggests. - {-# INLINE inlinedConstFieldDecoder #-} - inlinedConstFieldDecoder :: Maybe (Parser.Parser (Maybe a)) - inlinedConstFieldDecoder = Nothing - - -- | For types that can't implement `inlinedConstFieldDecoder` because they - -- need to know the value's OID for decoding, this is the next best thing: - -- also a specialized field+value decoder that can be faster than the - -- one derived from `fieldDecoder`. - -- - -- Any implementation of this _must_ return a `Nothing` for a SQL NULL value, - -- regardless of what `FieldDecoder` would do with a SQL NULL. - {-# INLINE notConstFieldDecoder #-} - notConstFieldDecoder :: FieldInfo -> Parser.Parser (Maybe a) - notConstFieldDecoder = - case inlinedConstFieldDecoder of - Nothing -> slowerParser - Just fd -> const fd - where - -- slowerParser takes a ByteString and passes it to the - -- field decoder. - slowerParser singleColInfo = do - len <- Parser.takeInt32BE - if len == (-1) - then pure Nothing - else do - bs <- Parser.take (fromIntegral len) - case fieldDecoder.fieldValueDecoder singleColInfo bs of - Left err -> fail err - Right v -> pure v - - -- | Semantically equivalent to `singleField fieldDecoder`, but for - -- 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 - rowDecoder = genericFromPgRow - --- | Allows you to create a @FieldDecoder@ for composite types. --- For a type such as: --- --- > CREATE TYPE int_and_bool AS (numfield INT, boolfield BOOL); --- --- You can define a Haskell type as such: --- --- > data IntAndBool = IntAndBool Int Bool --- > --- > instance FromPgField IntAndBool where --- > fieldDecoder = compositeTypeDecoder rowDecoder <&> \(i, b) -> IntAndBool i b -compositeTypeDecoder :: forall a. RowDecoder a -> FieldDecoder a -compositeTypeDecoder (RowDecoder {..}) = - FieldDecoder - { fieldValueDecoder = \compositeTypeOid -> - let !prs = parserForRecord compositeTypeOid.encodingContext <* Parser.endOfInput - in \bs -> - case Parser.parseOnly prs bs of - Parser.ParseOk v -> Right v - Parser.ParseFail err -> Left err, - decodesSqlNullTo = Left "Got NULL in composite type but it was not allowed", - allowedPgTypes = const True -- There's no way to enforce a custom type's OID. We only check if it's structurally the same in the parser (same subtypes in same order) - } - where - parserForRecord :: EncodingContext -> Parser.Parser a - parserForRecord encodingContext = do - -- From https://github.com/postgres/postgres/blob/50ba65e73325cf55fedb3e1f14673d816726923b/src/backend/utils/adt/rowtypes.c#L687 - -- we can see a composite type's binary representation consists of: number of columns (Int32) + for_each_column { OID (Int32) + size_or_minus_1 (Int32) + Bytes } - numCols <- fromIntegral <$> Parser.takeInt32BE - unless (numCols == numExpectedColumns) $ fail $ "Composite type has " ++ show numCols ++ " attributes but parser expected " ++ show numExpectedColumns - let mkColInfo oid = FieldInfo oid Nothing encodingContext - cols <- replicateM numCols $ do - !oid <- Oid . fromIntegral <$> Parser.takeInt32BE - (sizeBs, !size) <- Parser.match $ fromIntegral <$> Parser.takeInt32BE - !bs <- Parser.take (max 0 size) - pure (oid, sizeBs <> bs) - let typecheckedCols = rowColumnsTypeCheck (map (mkColInfo . fst) cols) - unless (all snd typecheckedCols) $ fail $ "Parser for composite found type OIDs " ++ show (map fst cols) ++ " but expected different" - case Parser.parseOnly (fullRowDecoder (map (mkColInfo . fst) cols) <* Parser.endOfInput) (mconcat $ map snd cols) of - Parser.ParseOk v -> pure v - Parser.ParseFail err -> error $ "Error decoding composite type: " ++ show err - --- | Allows you to create a @FieldEncoder@ for composite types. --- For a type such as: --- --- > CREATE TYPE int_and_bool AS (numfield INT, boolfield BOOL); --- --- You can define a Haskell type as such: --- --- > data IntAndBool = IntAndBool Int Bool --- > --- > instance ToPgField IntAndBool where --- > fieldEncoder = typeFieldEncoder (typeOidWithName "int_and_bool") --- > $ compositeTypeEncoder $ contramap (\(IntAndBool i b) -> (fromIntegral i :: Int32, b)) rowEncoder -compositeTypeEncoder :: forall a. RowEncoder a -> FieldEncoder a -compositeTypeEncoder rowEnc = - FieldEncoder - { toTypeOid = \_ -> Nothing, - toPgField = \encCtx -> \a -> - let fields = map (\f -> f encCtx) (rowEnc.toPgParams a) - numCols = Builder.int32BE (fromIntegral $ length fields) - encodeField (mOid, bf) = - let Oid oid = fromMaybe (Oid 0) mOid - in Builder.int32BE oid <> Builder.binaryField bf - in NotNull (Builder.toStrictByteString (numCols <> foldMap encodeField fields)) - } - -instance (FromPgField a) => FromPgRow (Only a) where - rowDecoder = Only <$> inlinedSingleFieldRowDecoder - -instance (FromPgField a, FromPgField b) => FromPgRow (a, b) where - rowDecoder = (,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder - -instance (FromPgField a, FromPgField b, FromPgField c) => FromPgRow (a, b, c) where - rowDecoder = (,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder - -instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d) => FromPgRow (a, b, c, d) where - rowDecoder = (,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder - -instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e) => FromPgRow (a, b, c, d, e) where - 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 = (,,,,,) <$> 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 = (,,,,,,) <$> 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 = (,,,,,,,) <$> 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 = (,,,,,,,,) <$> 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 = (,,,,,,,,,) <$> 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 = (,,,,,,,,,,) <$> 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 = (,,,,,,,,,,,) <$> 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 = (,,,,,,,,,,,,) <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder - -data FieldEncoder a = FieldEncoder - { toTypeOid :: !(EncodingContext -> Maybe Oid), - toPgField :: !(EncodingContext -> a -> BinaryField) - } - -instance Contravariant FieldEncoder where - contramap f fEnc = FieldEncoder {toTypeOid = fEnc.toTypeOid, toPgField = \encCtx -> let toF = fEnc.toPgField encCtx in \v -> toF (f v)} - -class ToPgField a where - fieldEncoder :: FieldEncoder a - --- | Allows you to specify a type for a FieldEncoder. This can be useful to avoid --- letting postgres infer types itself, which can cause errors. For example: --- --- > data MyEnum = Val1 | Val2 | Val3 --- > myEnumFieldDecoderWithTypeInfoCheck :: FieldEncoder MyEnum --- > myEnumFieldDecoderWithTypeInfoCheck = --- > let convert = \case --- > Val1 -> "val1" :: Text --- > Val2 -> "val2" --- > Val3 -> "val3" --- > in typeFieldEncoder --- > (typeOidWithName "my_enum") --- > $ contramap convert fieldEncoder --- --- This will work unless you use non-default flags in your connection options. -typeFieldEncoder :: (EncodingContext -> Maybe Oid) -> FieldEncoder a -> FieldEncoder a -typeFieldEncoder ttoid enc = enc {toTypeOid = ttoid} - -typeOidWithName :: Text -> (EncodingContext -> Maybe Oid) -typeOidWithName typName = \encCtx -> typeOid <$> lookupTypeByName typName encCtx.typeInfoCache - -instance ToPgField Int where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just haskellIntOid, - toPgField = \_ -> binaryIntEncoder - } - -instance ToPgField Int16 where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just int2Oid, - toPgField = \_ -> \n -> NotNull $ BinSer.encodeInt16BE n - } - -instance ToPgField Int32 where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just int4Oid, - toPgField = \_ -> \n -> NotNull $ BinSer.encodeInt32BE n - } - -instance ToPgField Int64 where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just int8Oid, - toPgField = \_ -> \n -> NotNull $ BinSer.encodeInt64BE n - } - -instance ToPgField Integer where - fieldEncoder = - let fe = fieldEncoder @Scientific - in FieldEncoder - { toTypeOid = \_ -> Just numericOid, - toPgField = \encCtx -> \n -> fe.toPgField encCtx (fromIntegral n) - } - -instance ToPgField (Ratio Integer) where - fieldEncoder = - let fe = fieldEncoder @Scientific - in FieldEncoder - { toTypeOid = \_ -> Just numericOid, - toPgField = \encCtx -> \r -> fe.toPgField encCtx (fromRational r) - } - -instance ToPgField Oid where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just oidOid, - toPgField = \_ -> \n -> NotNull $ BinSer.encodeInt32BE $ fromIntegral n - } - -instance ToPgField Scientific where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just numericOid, - toPgField = \_ -> \n -> - let sign = BinSer.encodeInt16BE $ if n >= 0 then 0 else 0x4000 - -- The number is coeff * 10^exp, but we want it in base-10000 so we convert it to - -- new_coeff * 10^new_exp with new_exp a multiple of 4 - base10000Expon = 4 * (base10Exponent n `div` 4) - base10000Coeff = coefficient n * expt 10 (base10Exponent n - base10000Expon) - ndigits, weight :: Int16 - digits :: ByteString - (ndigits, weight, digits) = calculateDigits 0 0 (abs base10000Coeff) "" - dscale = BinSer.encodeInt16BE (abs $ fromIntegral base10000Expon) -- More than necessary, but safe? - in NotNull $ BinSer.encodeInt16BE ndigits <> BinSer.encodeInt16BE (weight - 1 + fromIntegral (base10000Expon `div` 4)) <> sign <> dscale <> digits - } - where - calculateDigits :: Int16 -> Int16 -> Integer -> BS.ByteString -> (Int16, Int16, BS.ByteString) - calculateDigits !ndigitsSoFar !weightSoFar 0 !encodedDigits = (ndigitsSoFar, weightSoFar, encodedDigits) - calculateDigits !ndigitsSoFar !weightSoFar !val !encodedDigits = - let (quotient, fromIntegral -> (rest :: Int16)) = val `divMod` 10000 - in calculateDigits - (ndigitsSoFar + 1) - (weightSoFar + 1) - quotient - (BinSer.encodeInt16BE rest <> encodedDigits) - -instance ToPgField Float where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just float4Oid, - toPgField = \_ -> \n -> NotNull $ BinSer.encodeFloat n - } - -instance ToPgField Double where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just float8Oid, - toPgField = \_ -> \n -> NotNull $ BinSer.encodeDouble n - } - -instance ToPgField Bool where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just boolOid, - toPgField = \_ n -> NotNull $ BinSer.encodePgBoolean n - } - -instance ToPgField Day where - -- PG Dates are Int32 number of days relative to 2000-01-01 - -- https://github.com/postgres/postgres/blob/master/src/include/datatype/timestamp.h#L235 - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just dateOid, - -- TODO: Catch integer overflow and do what? - toPgField = \_ d -> NotNull $ BinSer.encodeInt32BE $ fromIntegral $ diffDays d (fromGregorian 2000 1 1) - } - -instance ToPgField (Unbounded Day) where - fieldEncoder = - let fe = fieldEncoder @Day - in FieldEncoder - { toTypeOid = fe.toTypeOid, - toPgField = \encCtx -> \case - NegInfinity -> NotNull $ BinSer.encodeInt32BE minBound - Finite v -> fe.toPgField encCtx v - PosInfinity -> NotNull $ BinSer.encodeInt32BE maxBound - } - -instance ToPgField CalendarDiffTime where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just intervalOid, - toPgField = \_ CalendarDiffTime {..} -> - let (days :: Int32, timeUnderOneDay) = ctTime `divMod'` 86_400 - in NotNull $ BinSer.encodeInt64BE (round $ timeUnderOneDay * 1_000_000) <> BinSer.encodeInt32BE days <> BinSer.encodeInt32BE (fromIntegral ctMonths) - } - -instance ToPgField NominalDiffTime where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just intervalOid, - toPgField = \_ ndt -> - NotNull $ BinSer.encodeInt64BE (round $ ndt * 1_000_000) <> BinSer.encodeInt32BE 0 <> BinSer.encodeInt32BE 0 - } - -instance ToPgField UTCTime where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just timestamptzOid, - -- TODO: Catch integer overflow and do what? - toPgField = \_ (UTCTime parsedDate timeinday) -> - let day :: Int64 = fromInteger $ parsedDate `diffDays` fromJulian 1999 12 19 - totalusecs :: Int64 = 86_400_000_000 * day + fromInteger (diffTimeToPicoseconds timeinday `div` 1_000_000) - in NotNull $ BinSer.encodeInt64BE totalusecs - } - -instance ToPgField (Unbounded UTCTime) where - fieldEncoder = - let fe = fieldEncoder @UTCTime - in FieldEncoder - { toTypeOid = fe.toTypeOid, - toPgField = \encCtx -> \case - NegInfinity -> NotNull $ BinSer.encodeInt64BE minBound - Finite v -> fe.toPgField encCtx v - PosInfinity -> NotNull $ BinSer.encodeInt64BE maxBound - } - -instance ToPgField ZonedTime where - fieldEncoder = - let fe = fieldEncoder @UTCTime - in FieldEncoder - { toTypeOid = \_ -> Just timestamptzOid, - toPgField = \encCtx -> fe.toPgField encCtx . zonedTimeToUTC - } - -instance ToPgField (Unbounded ZonedTime) where - fieldEncoder = - let fe = fieldEncoder @ZonedTime - in FieldEncoder - { toTypeOid = fe.toTypeOid, - toPgField = \encCtx -> \case - NegInfinity -> NotNull $ BinSer.encodeInt64BE minBound - Finite v -> fe.toPgField encCtx v - PosInfinity -> NotNull $ BinSer.encodeInt64BE maxBound - } - -instance ToPgField LocalTime where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just timestampOid, - toPgField = \_ (LocalTime localDay localTimeOfDay) -> - let day :: Int64 = fromInteger $ localDay `diffDays` fromJulian 1999 12 19 - totalusecs :: Int64 = 86_400_000_000 * day + fromInteger (diffTimeToPicoseconds (timeOfDayToTime localTimeOfDay) `div` 1_000_000) - in NotNull $ BinSer.encodeInt64BE totalusecs - } - -instance ToPgField TimeOfDay where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just timeOid, - toPgField = \_ tod -> - let usecs :: Int64 = fromInteger $ diffTimeToPicoseconds (timeOfDayToTime tod) `div` 1_000_000 - in NotNull $ BinSer.encodeInt64BE usecs - } - -instance ToPgField Char where - fieldEncoder = - let fe = fieldEncoder @Text - in FieldEncoder - { toTypeOid = \_ -> Just textOid, - toPgField = \encCtx -> let !toTextField = fe.toPgField encCtx in \t -> toTextField $ Text.singleton t - } - -instance ToPgField ByteString where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just byteaOid, - toPgField = \_ -> \bs -> NotNull bs - } - -instance ToPgField LBS.ByteString where - fieldEncoder = - let fe = fieldEncoder @ByteString - in FieldEncoder - { toTypeOid = \_ -> Just byteaOid, - toPgField = \encCtx -> fe.toPgField encCtx . LBS.toStrict - } - -instance ToPgField Text where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just textOid, - toPgField = \_ -> \t -> - let bs = encodeUtf8 t - in NotNull bs - } - -instance ToPgField LT.Text where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just textOid, - toPgField = \_ -> \t -> - let bs = LBS.toStrict $ LT.encodeUtf8 t - in NotNull bs - } - -instance ToPgField String where - fieldEncoder = - let fe = fieldEncoder @Text - in FieldEncoder - { toTypeOid = \_ -> Just textOid, - toPgField = \encCtx -> fe.toPgField encCtx . Text.pack - } - --- From https://hackage.haskell.org/package/case-insensitive-1.2.1.0/docs/Data-CaseInsensitive.html, --- "Note that the FoldCase instance for ByteStrings is only guaranteed to be correct for ISO-8859-1 encoded strings!". --- So we don't have those instances. - --- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default --- connection option). -instance ToPgField (CI Text) where - fieldEncoder = typeFieldEncoder (typeOidWithName "citext") $ contramap CI.original fieldEncoder - --- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default --- connection option). -instance ToPgField (CI LT.Text) where - fieldEncoder = typeFieldEncoder (typeOidWithName "citext") $ contramap CI.original fieldEncoder - --- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default --- connection option). -instance ToPgField (CI String) where - fieldEncoder = typeFieldEncoder (typeOidWithName "citext") $ contramap CI.original fieldEncoder - -instance ToPgField UUID where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just uuidOid, - toPgField = \_ -> NotNull . LBS.toStrict . UUID.toByteString - } - -instance ToPgField Aeson.Value where - fieldEncoder = - FieldEncoder - { toTypeOid = \_ -> Just jsonbOid, - toPgField = \_ -> \v -> - let bs = BS.cons 1 (LBS.toStrict $ Aeson.encode v) - in NotNull bs - } - -instance (ToPgField a) => ToPgField (Maybe a) where - fieldEncoder = - let fe = fieldEncoder @a - in FieldEncoder - { toTypeOid = fe.toTypeOid, - toPgField = \encCtx -> \case - Nothing -> SqlNull - Just n -> fe.toPgField encCtx n - } - -instance (ToPgField a) => ToPgField (Vector a) where - fieldEncoder = - let fe = fieldEncoder @a - in FieldEncoder - { toTypeOid = \encodingContext -> do - -- Maybe monad - elOid <- fe.toTypeOid encodingContext - arrayTypInfo <- lookupTypeByOid elOid encodingContext.typeInfoCache - arrayTypInfo.oidOfArrayType, - toPgField = toPgVectorField - } - -data RowEncoder a = RowEncoder - { toPgParams :: !(a -> [EncodingContext -> (Maybe Oid, BinaryField)]), - toTypeOids :: !(Proxy a -> [EncodingContext -> Maybe Oid]), - -- | This produces bytes for Binary COPY FROM STDIN rows, which can increase performance - -- and reduce memory usage comparing to deriving these bytes from `toPgParams`. - -- The produced bytes should not contain the total number of fields in the - -- beginning. - toBinaryCopyBytes :: !(EncodingContext -> a -> Builder.Builder) - } - -instance Contravariant RowEncoder where - contramap f rec = RowEncoder (\v -> rec.toPgParams (f v)) (\_ -> rec.toTypeOids Proxy) (\encCtx -> let !toBytes = rec.toBinaryCopyBytes encCtx in \v -> toBytes (f v)) - --- | These are from `Divisible`, but we don't currently pull in the extra dependency that has that. -divide :: (a -> (b, c)) -> RowEncoder b -> RowEncoder c -> RowEncoder a -divide d re1 re2 = - RowEncoder - { toPgParams = \a -> let (b, c) = d a in re1.toPgParams b ++ re2.toPgParams c, - toTypeOids = \_ -> re1.toTypeOids Proxy ++ re2.toTypeOids Proxy, - toBinaryCopyBytes = \encCtx -> - let !toBytes1 = re1.toBinaryCopyBytes encCtx - !toBytes2 = re2.toBinaryCopyBytes encCtx - in \a -> let (b, c) = d a in toBytes1 b <> toBytes2 c - } - -class ToPgRow a where - rowEncoder :: RowEncoder a - default rowEncoder :: (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a - rowEncoder = genericToPgRow - -instance ToPgRow () where - rowEncoder = RowEncoder (\_ -> []) (\_ -> []) (\_ -> \_ -> mempty) - -singleFieldRowEncoder :: forall a. (ToPgField a) => RowEncoder a -singleFieldRowEncoder = - let fe = fieldEncoder @a - in RowEncoder - { toPgParams = \a -> [\encodingContext -> (fe.toTypeOid encodingContext, fe.toPgField encodingContext a)], - toTypeOids = \_ -> [fe.toTypeOid], - toBinaryCopyBytes = \encCtx -> let !enc = fe.toPgField encCtx in \a -> Builder.binaryField $ enc a - } - -instance (ToPgField a) => ToPgRow (Only a) where - rowEncoder = contramap fromOnly singleFieldRowEncoder - -instance (ToPgField a, ToPgField b) => ToPgRow (a, b) where - rowEncoder = divide id singleFieldRowEncoder singleFieldRowEncoder - -instance (ToPgField a, ToPgField b, ToPgField c) => ToPgRow (a, b, c) where - rowEncoder = divide (\(a, b, c) -> ((a, b), c)) rowEncoder singleFieldRowEncoder - -instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d) => ToPgRow (a, b, c, d) where - rowEncoder = divide (\(a, b, c, d) -> ((a, b), (c, d))) rowEncoder rowEncoder - -instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e) => ToPgRow (a, b, c, d, e) where - rowEncoder = divide (\(a, b, c, d, e) -> ((a, b, c), (d, e))) rowEncoder rowEncoder - -instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f) => ToPgRow (a, b, c, d, e, f) where - rowEncoder = divide (\(a, b, c, d, e, f) -> ((a, b, c), (d, e, f))) rowEncoder rowEncoder - -instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g) => ToPgRow (a, b, c, d, e, f, g) where - rowEncoder = divide (\(a, b, c, d, e, f, g) -> ((a, b, c), (d, e, f, g))) rowEncoder rowEncoder - -instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g, ToPgField h) => ToPgRow (a, b, c, d, e, f, g, h) where - rowEncoder = divide (\(a, b, c, d, e, f, g, h) -> ((a, b, c, d), (e, f, g, h))) rowEncoder rowEncoder - -instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g, ToPgField h, ToPgField i) => ToPgRow (a, b, c, d, e, f, g, h, i) where - rowEncoder = divide (\(a, b, c, d, e, f, g, h, i) -> ((a, b, c, d), (e, f, g, h, i))) rowEncoder rowEncoder - -instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g, ToPgField h, ToPgField i, ToPgField j) => ToPgRow (a, b, c, d, e, f, g, h, i, j) where - rowEncoder = divide (\(a, b, c, d, e, f, g, h, i, j) -> ((a, b, c, d, e), (f, g, h, i, j))) rowEncoder rowEncoder - -instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g, ToPgField h, ToPgField i, ToPgField j, ToPgField k) => ToPgRow (a, b, c, d, e, f, g, h, i, j, k) where - rowEncoder = divide (\(a, b, c, d, e, f, g, h, i, j, k) -> ((a, b, c, d, e, f), (g, h, i, j, k))) rowEncoder rowEncoder - --- | The OID for `Data.Int`, which is machine dependent. -haskellIntOid :: Oid - --- | All pg type OIDs that fit into Haskell's `Data.Int`, whose size is machine dependent. -haskellIntOids :: [Oid] -(haskellIntOid, haskellIntOids) - | (fromIntegral (maxBound @Int) :: Integer) > fromIntegral (maxBound @Int32) = (int8Oid, [int2Oid, int4Oid, int8Oid]) - | (fromIntegral (maxBound @Int) :: Integer) > fromIntegral (maxBound @Int16) = (int4Oid, [int2Oid, int4Oid]) - | otherwise = (int2Oid, [int2Oid]) - --- | Big-Endian binary encoder for Haskell's `Data.Int`, which is machine-dependent. -binaryIntEncoder :: Int -> BinaryField -binaryIntEncoder - | haskellIntOid == int8Oid = NotNull . BinSer.encodeInt64BE . fromIntegral - | haskellIntOid == int4Oid = NotNull . BinSer.encodeInt32BE . fromIntegral - | otherwise = NotNull . BinSer.encodeInt16BE . fromIntegral - --- | Big-Endian binary decoder for Haskell's various IntXX types. -binaryIntDecoder :: forall a. (Integral a, Bounded a) => Oid -> ByteString -> Either String a -binaryIntDecoder typOid = \bs -> - if doesFit - then intDecoder bs - else Left $ "Chosen integral type does not fit every value for PG type with OID " ++ show typOid - where - maxBoundPgType :: Integer - intDecoder :: ByteString -> Either String a - (maxBoundPgType, intDecoder) - | typOid == int8Oid = (fromIntegral $ maxBound @Int64, fmap fromIntegral . BinSer.decodeInt64BE 0) - | typOid == int4Oid = (fromIntegral $ maxBound @Int32, fmap fromIntegral . BinSer.decodeInt32BE 0) - | typOid == int2Oid = (fromIntegral $ maxBound @Int16, fmap fromIntegral . BinSer.decodeInt16BE 0) - | otherwise = error "Bug in Hpgsql. Decoding binary integral type not an int2, int4 or int8" - doesFit = maxBoundPgType <= fromIntegral (maxBound @a) - -binaryFloat4Decoder :: ByteString -> Float -binaryFloat4Decoder = castWord32ToFloat . either error id . BinSer.decodeWord32BE 0 - -binaryFloat8Decoder :: ByteString -> Double -binaryFloat8Decoder = castWord64ToDouble . either error id . BinSer.decodeWord64BE 0 - -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 - "" -> 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 \bs -> decode bs, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int type. Use a `Maybe Int`", - allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid - } - - {-# INLINE inlinedConstFieldDecoder #-} - inlinedConstFieldDecoder = Just $ do - fieldLen <- Parser.takeInt32BE - -- TODO: We're assuming `Int` is always 64 bits, so 64bit CPUs? Is that ok? - -- TODO: Is there a way to optimistically assume <=4 bytes and use our custom new parser? - case fieldLen of - 4 -> Just . fromIntegral <$> Parser.takeInt32BE - (-1) -> pure Nothing - 8 -> Just . fromIntegral <$> Parser.takeInt64BE - 2 -> Just . fromIntegral <$> Parser.takeInt16BE - _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" - -instance FromPgField Int16 where - {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = - let !decode = binaryIntDecoder int2Oid - in const decode, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int16 type. Use a `Maybe Int16`", - allowedPgTypes = (== int2Oid) . fieldTypeOid - } - -instance FromPgField Int32 where - {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> binaryIntDecoder oid, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int32 type. Use a `Maybe Int32`", - allowedPgTypes = (`elem` [int2Oid, int4Oid]) . fieldTypeOid - } - {-# INLINE inlinedConstFieldDecoder #-} - inlinedConstFieldDecoder = Just $ do - fieldLen <- Parser.takeInt32BE - case fieldLen of - 4 -> Just <$> Parser.takeInt32BE - (-1) -> pure Nothing - 2 -> Just . fromIntegral <$> Parser.takeInt16BE - _ -> fail "Trying to decode PG int4 but it's not 2 or 4 bytes long" - -instance FromPgField Int64 where - {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> binaryIntDecoder oid, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int64 type. Use a `Maybe Int64`", - allowedPgTypes = (`elem` [int2Oid, int4Oid, int8Oid]) . fieldTypeOid - } - {-# INLINE inlinedConstFieldDecoder #-} - inlinedConstFieldDecoder = Just $ do - fieldLen <- Parser.takeInt32BE - case fieldLen of - 8 -> Just <$> Parser.takeInt64BE - 4 -> Just . fromIntegral <$> Parser.takeInt32BE - (-1) -> pure Nothing - 2 -> Just . fromIntegral <$> Parser.takeInt16BE - _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" - -instance FromPgField Integer where - {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> - let !decodeInt = binaryIntDecoder @Int64 oid - in if oid /= numericOid - then fmap fromIntegral <$> decodeInt - else \bs -> case Parser.parseOnly (scientificDecoder True <* Parser.endOfInput) bs of - Parser.ParseOk sci -> case floatingOrInteger @Double @Integer sci of - Right i -> Right i - Left _ -> Left "Internal error in Hpgsql. Scientific to Integer conversion failed" - Parser.ParseFail err -> Left err, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Integer type. Use a `Maybe Integer`", - allowedPgTypes = (`elem` [int8Oid, numericOid, int4Oid, int2Oid]) . fieldTypeOid - } - -instance FromPgField Oid where - {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = \_ -> \case - -- Oids are just int4 - bs -> Oid <$> binaryIntDecoder int4Oid bs, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Oid type. Use a `Maybe Oid`", - allowedPgTypes = (== oidOid) . fieldTypeOid - } - -instance FromPgField Float where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Float" [float4Oid] $ Right . binaryFloat4Decoder - - {-# INLINE inlinedConstFieldDecoder #-} - inlinedConstFieldDecoder = Just Parser.takeFloatBEWithFieldLength - -{-# INLINE doubleRowDecoder #-} -doubleRowDecoder :: Parser.Parser (Maybe Double) -doubleRowDecoder = do - len <- Parser.takeInt32BE - case len of - 8 -> Just <$> Parser.takeDoubleBE - 4 -> Just . float2Double <$> Parser.takeFloatBE - _ -> pure Nothing - -instance FromPgField Double where - {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> - let decoder - | oid == float8Oid = binaryFloat8Decoder - | otherwise = float2Double . binaryFloat4Decoder - in Right . decoder, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`", - allowedPgTypes = (`elem` [float8Oid, float4Oid]) . fieldTypeOid - } - - {-# INLINE inlinedConstFieldDecoder #-} - inlinedConstFieldDecoder = Just doubleRowDecoder - --- | Allows you to specify a type (and other checks, possibly) for a `FieldDecoder`. --- This can be useful to ensure you're not accidentally decoding a different type. --- --- > data MyEnum = Val1 | Val2 | Val3 --- > myEnumFieldDecoderWithTypeInfoCheck :: FieldDecoder MyEnum --- > myEnumFieldDecoderWithTypeInfoCheck = --- > let convert = \case --- > "val1" -> Val1 --- > "val2" -> Val2 --- > "val3" -> Val3 --- > _ -> error "Invalid value for MyEnum" --- > in typeFieldDecoder --- > (typeMustBeNamed "my_enum") --- > $ convert <$> rawBytesFieldDecoder --- --- This will work unless you use non-default flags in your connection options. -typeFieldDecoder :: (FieldInfo -> Bool) -> FieldDecoder a -> FieldDecoder a -typeFieldDecoder fieldCheck dec = dec {allowedPgTypes = fieldCheck} - -typeMustBeNamed :: Text -> (FieldInfo -> Bool) -typeMustBeNamed typName = \fieldInfo -> - (typeName <$> lookupTypeByOid fieldInfo.fieldTypeOid fieldInfo.encodingContext.typeInfoCache) == Just typName - -{-# INLINE scientificDecoder #-} -scientificDecoder :: Bool -> Parser.Parser Scientific -scientificDecoder mustBeInteger = do - ndigits <- Parser.takeInt16BE - weight <- Parser.takeInt16BE - sign <- Parser.takeInt16BE -- 0x0000 is positive, 0x4000 is negative, 0xC000 is NAN, 0xD000 is Positive Infinity, 0xF000 is Negative Infinity - unless (sign == 0x0000 || sign == 0x4000) $ fail "NaN, positive or negative infinities cannot be decoded into Integer or Scientific" - !dscale <- Parser.takeInt16BE - when (mustBeInteger && dscale /= 0) $ fail "Decoding into `Integer` requires explicit casting with `numeric(X,0)` to force integral values" - valueAbs <- parseAndMult ndigits (fromIntegral weight * 4) 0 - pure $ (if sign == 0x0000 then 1 else (-1)) * valueAbs - where - parseAndMult :: Int16 -> Int -> Scientific -> Parser.Parser Scientific - parseAndMult 0 _ !val = pure val - parseAndMult !ndigitsLeft !currexpon !val = do - !digit <- fromIntegral <$> Parser.takeInt16BE - parseAndMult (ndigitsLeft - 1) (currexpon - 4) (val + scientific digit currexpon) - -{-# INLINE numericRowParser #-} -numericRowParser :: Parser.Parser (Maybe Scientific) -numericRowParser = do - fieldLen <- Parser.takeInt32BE - case fieldLen of - (-1) -> pure Nothing - _ -> Just <$> scientificDecoder False - -instance FromPgField Scientific where - -- See https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/numeric.c#L1163 - {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - if fieldTypeOid /= numericOid - then - let intdec = binaryIntDecoder @Int64 fieldTypeOid - in \bs -> flip scientific 0 . fromIntegral <$> intdec bs - else \case - bs -> - -- TODO: There is loss converting from Float/Double to Scientific, but it might be quite small, so should we accept - -- float4Oid and float8Oid here? - case Parser.parseOnly (scientificDecoder False <* Parser.endOfInput) bs of - Parser.ParseOk sci -> Right sci - Parser.ParseFail err -> Left err, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`", - allowedPgTypes = (`elem` [numericOid, int2Oid, int4Oid, int8Oid]) . fieldTypeOid - } - {-# INLINE notConstFieldDecoder #-} - notConstFieldDecoder = - let !int64RowDec = fromMaybe (error "Bug in HPgsql: Int64 does not have an inlinedConstFieldDecoder") $ inlinedConstFieldDecoder @Int64 - in \singleColInfo -> - if singleColInfo.fieldTypeOid /= numericOid - then fmap (flip scientific 0 . fromIntegral) <$> int64RowDec - else numericRowParser - -instance FromPgField (Ratio Integer) where - {-# INLINE fieldDecoder #-} - fieldDecoder = toRational <$> fieldDecoder @Scientific - -binaryTrue :: ByteString -binaryTrue = BinSer.encodePgBoolean True - -{-# INLINE boolRowDecoder #-} -boolRowDecoder :: Parser.Parser (Maybe Bool) -boolRowDecoder = fmap (== 1) <$> Parser.parsePgFieldWithAtMost4Bytes BinSer.CWord8 - -instance FromPgField Bool where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Bool" [boolOid] $ \bs -> Right $ bs == binaryTrue - - {-# INLINE inlinedConstFieldDecoder #-} - inlinedConstFieldDecoder = Just boolRowDecoder - -instance FromPgField Char where - {-# INLINE fieldDecoder #-} - fieldDecoder = - let textParser = fieldValueDecoder (fieldDecoder @Text) - in FieldDecoder - { fieldValueDecoder = \colInfo@FieldInfo {fieldTypeOid = oid} -> - let !decodeText = textParser colInfo - in \bs -> - if oid == charOid - -- 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 - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "byteString" [byteaOid] Right - -instance FromPgField LBS.ByteString where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "ByteString" [byteaOid] $ Right . LBS.fromStrict - -{-# INLINE textDecoder #-} -textDecoder :: Parser.Parser (Maybe Text) -textDecoder = do - len <- Parser.takeInt32BE - if len >= 0 - -- TODO: Use some faster unsafeDecodeUtf8 function? - then Just . decodeUtf8 <$> Parser.take (fromIntegral len) - else pure Nothing - -instance FromPgField Text where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ decodeUtf8 bs - - {-# INLINE inlinedConstFieldDecoder #-} - inlinedConstFieldDecoder = Just textDecoder - -instance FromPgField LT.Text where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> Right $ LT.fromStrict $ decodeUtf8 bs - -instance FromPgField String where - {-# 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 - {-# 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) - - {-# INLINE inlinedConstFieldDecoder #-} - inlinedConstFieldDecoder = Just utcTimeRowDecoder - -instance FromPgField (Unbounded UTCTime) where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Unbounded UTCTime" [timestamptzOid] $ \case - bs -> do - -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- BinSer.decodeInt64BE 0 bs - Right $ - if totalusecs == minBound - then NegInfinity - else - if totalusecs == maxBound - then PosInfinity - else - let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day - parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - in Finite $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - -instance FromPgField ZonedTime where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "ZonedTime" [timestamptzOid] $ \case - bs -> do - -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- 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) - -instance FromPgField (Unbounded ZonedTime) where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Unbounded ZonedTime" [timestamptzOid] $ \case - bs -> do - -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- BinSer.decodeInt64BE 0 bs - Right $ - if totalusecs == minBound - then NegInfinity - else - if totalusecs == maxBound - then PosInfinity - else - let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day - parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - in Finite $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - -instance FromPgField LocalTime where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "LocalTime" [timestampOid] $ \case - bs -> do - totalusecs <- 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) - -instance FromPgField TimeOfDay where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "TimeOfDay" [timeOid] $ \case - bs -> do - usecs <- BinSer.decodeInt64BE 0 bs - Right $ timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral usecs * 1_000_000 - -{-# INLINE dayRowDecoder #-} -dayRowDecoder :: Parser.Parser (Maybe Day) -dayRowDecoder = - let int32ToDay (i32 :: Int32) = let jd = fromIntegral i32 :: Integer in addJulianDurationClip (CalendarDiffDays 0 (jd - 13)) $ fromJulian 2000 01 01 - in fmap int32ToDay <$> Parser.takeInt32BEWithFieldLength - -instance FromPgField Day where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Day" [dateOid] $ \case - bs -> do - -- There is a very specific conversion function for these, which I poorly translated to Haskell - -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 - -- But I found a simpler way to do this. Let's see if it works in our property based tests - jd <- BinSer.decodeInt32BE 0 bs - Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 - - {-# INLINE inlinedConstFieldDecoder #-} - inlinedConstFieldDecoder = Just dayRowDecoder - -instance FromPgField (Unbounded Day) where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Unbounded Day" [dateOid] $ \case - bs -> do - -- There is a very specific conversion function for these, which I poorly translated to Haskell - -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 - -- But I found a simpler way to do this. Let's see if it works in our property based tests - jd <- BinSer.decodeInt32BE 0 bs - Right $ - if jd == minBound - then NegInfinity - else - if jd == maxBound - then PosInfinity - else - Finite $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 - -instance FromPgField CalendarDiffTime where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "CalendarDiffTime " [intervalOid] $ \bs -> do - nMicrosecs <- 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 - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "UUID" [uuidOid] $ \case - bs -> case UUID.fromByteString (LBS.fromStrict bs) of - Just uuid -> Right uuid - Nothing -> Left "Bug in Hpgsql: UUID field could not be decoded" - -instance FromPgField Aeson.Value where - {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = - \FieldInfo {fieldTypeOid} -> - let -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in \case - bs -> case Aeson.decodeStrict $ fixJsonb bs of - Just d -> Right d - Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls", - allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid - } - --- | A FieldDecoder that accepts and decodes SQL NULLs into `Nothing` values --- for a given decoder. -nullableField :: FieldDecoder a -> FieldDecoder (Maybe a) -nullableField FieldDecoder {..} = - FieldDecoder - { fieldValueDecoder = \oid -> - let origFieldValueParser = fieldValueDecoder oid - in \bs -> Just <$> origFieldValueParser bs, - decodesSqlNullTo = Right Nothing, - allowedPgTypes - } - -instance (FromPgField a) => FromPgField (Maybe a) where - {-# INLINE fieldDecoder #-} - fieldDecoder = nullableField fieldDecoder - - {-# INLINE notConstFieldDecoder #-} - notConstFieldDecoder finfo = do - mv <- notConstFieldDecoder @a finfo - case mv of - Nothing -> pure Nothing - jv -> pure $ Just jv - - {-# INLINE inlinedConstFieldDecoder #-} - -- \| For types where there is a fast way to decode fields+values - -- without knowing the OID of the value in the query (of course, the - -- possible OIDs are still limited by the FieldDecoder's allowed types), - -- this can help provide a significant boost to inlined row decoders. - -- Define as `Nothing` if this isn't possible. - -- inlinedConstFieldDecoder :: Maybe (Parser.Parser (Maybe (Maybe a))) - inlinedConstFieldDecoder = case inlinedConstFieldDecoder @a of - Nothing -> Nothing - Just p -> Just $ do - mv <- p - case mv of - Nothing -> pure Nothing -- Must return Nothing for SQL Nulls - jv -> pure $ Just jv - -allowOnlyArrayTypes :: FieldInfo -> Bool -allowOnlyArrayTypes fieldInfo = - -- TODO: We could check the elemTypeOid too, but maybe later - case lookupTypeByOid fieldInfo.fieldTypeOid fieldInfo.encodingContext.typeInfoCache of - Just (TypeInfo {typeDetails = ArrayType _}) -> True - Nothing -> True -- Assume user knows what they're doing - Just _ -> False -- Definitely not an array - -instance forall a. (FromPgField a) => FromPgField (Vector a) where - fieldDecoder = arrayField Vector.replicateM fieldDecoder - -instance {-# OVERLAPPING #-} forall a. (FromPgField a) => FromPgField (Vector (Vector a)) where - -- From https://github.com/postgres/postgres/blob/5941946d0934b9eccb0d5bfebd40b155249a0130/src/backend/utils/adt/arrayfuncs.c#L1548 - fieldDecoder = - FieldDecoder - { fieldValueDecoder = \colInfo -> - let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput - in \case - bs -> case Parser.parseOnly arrayFieldDecoder bs of - Parser.ParseOk v -> Right v - Parser.ParseFail err -> Left err, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell (Vector (Vector a)) type. Use a `Maybe (Vector (Vector a))`", - allowedPgTypes = allowOnlyArrayTypes - } - where - !elementParser = fieldDecoder @a - arrayParser :: EncodingContext -> Parser.Parser (Vector (Vector a)) - arrayParser encodingContext = do - !ndim <- Parser.takeInt32BE - !_hasNull <- Parser.takeInt32BE - !elementTypeOid :: Oid <- Oid . fromIntegral <$> Parser.takeInt32BE - let !elementColInfo = FieldInfo elementTypeOid Nothing encodingContext - when (ndim /= 2) $ fail $ "TODO: No support for " ++ show ndim ++ "-dimensional arrays in Hpgsql. Got array with ndim=" ++ show ndim - unless (elementParser.allowedPgTypes elementColInfo) $ fail $ "Array contains elements of type OID " ++ show elementTypeOid ++ " but decoder does not handle that type" - numRows <- do - !dim_i :: Int <- fromIntegral <$> Parser.takeInt32BE - !_lb_i <- Parser.takeInt32BE - pure dim_i - lengthEachRow <- do - !dim_i :: Int <- fromIntegral <$> Parser.takeInt32BE - !_lb_i <- Parser.takeInt32BE - pure dim_i - - Vector.replicateM numRows $ do - Vector.replicateM lengthEachRow $ - do - size :: Int <- fromIntegral <$> Parser.takeInt32BE - if size == (-1) - then case elementParser.decodesSqlNullTo of - Left err -> fail err - Right v -> pure v - else do - elementBs <- Parser.take size - case elementParser.fieldValueDecoder elementColInfo elementBs of - Left err -> fail $ "Error parsing array element: " ++ show err - Right el -> pure el - -{-# INLINE genericFromPgRow #-} - --- | Derives `FromPgRow` generically. -genericFromPgRow :: forall a. (Generic a, ProductTypeDecoder (Rep a)) => RowDecoder a -genericFromPgRow = to <$> genRowDecoder @(Rep a) - -class ProductTypeDecoder f where - genRowDecoder :: RowDecoder (f a) - -instance (ProductTypeDecoder a, ProductTypeDecoder b) => ProductTypeDecoder (a :*: b) where - {-# INLINE genRowDecoder #-} - genRowDecoder = (:*:) <$> genRowDecoder <*> genRowDecoder - -instance (ProductTypeDecoder f) => ProductTypeDecoder (M1 a c f) where - {-# INLINE genRowDecoder #-} - genRowDecoder = M1 <$> genRowDecoder - -instance (FromPgField a) => ProductTypeDecoder (K1 r a) where - {-# INLINE genRowDecoder #-} - -- coercing instead of fmap reduces memory usage, apparently - -- by reducing (unnecessary) closures in the final row decoder, - -- as per looking at GHC Core - genRowDecoder = coerce $ inlinedSingleFieldRowDecoder @a - -genericToPgRow :: forall a. (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a -genericToPgRow = contramap from genRowEncoder - -class ProductTypeEncoder f where - genRowEncoder :: RowEncoder (f a) - -instance (ProductTypeEncoder a, ProductTypeEncoder b) => ProductTypeEncoder (a :*: b) where - genRowEncoder = divide (\(a :*: b) -> (a, b)) genRowEncoder genRowEncoder - -instance (ProductTypeEncoder f) => ProductTypeEncoder (M1 i c f) where - genRowEncoder = contramap unM1 genRowEncoder - -instance (ToPgField a) => ProductTypeEncoder (K1 r a) where - genRowEncoder = contramap unK1 singleFieldRowEncoder - --- | For the very common case of a Haskell enum matching a custom postgres enum type --- that has its values all as lower case strings, this newtype can help you derive --- instances as such: --- --- > data Mood = Sad | Ok | Happy --- > deriving stock (Generic) --- > deriving (FromPgField, ToPgField) via (LowerCasedPgEnum Mood) --- --- And this would match the Postgres equivalent: --- --- > CREATE TYPE mood AS ENUM ('sad', 'ok', 'happy'); --- --- If you run into PostgreSQL type inference problems with this, you can --- write instances manually with 'genericEnumFieldDecoder', 'genericEnumFieldEncoder', --- 'typeFieldEncoder', and 'typeFieldDecoder'. -newtype LowerCasedPgEnum a = LowerCasedPgEnum a - -instance (Generic a, EnumDecoder (Rep a)) => FromPgField (LowerCasedPgEnum a) where - fieldDecoder = LowerCasedPgEnum <$> genericEnumFieldDecoder LT.toLower - -instance (Generic a, EnumEncoder (Rep a)) => ToPgField (LowerCasedPgEnum a) where - fieldEncoder = untypedFieldEncoder $ \_encCtx -> \(LowerCasedPgEnum v) -> NotNull $ genericEnumFieldEncoder Text.toLower v - --- | One of the functions behind 'LowerCasedPgEnum', but you can decide --- how to map your type's constructor names arbitrarily, which can be --- useful if you're not using lowercase values in your postgres enums. -genericEnumFieldDecoder :: - forall a. - (Generic a, EnumDecoder (Rep a)) => - -- | A function that takes in the Haskell constructor name and returns the textual representation of the enum in postgres - (LT.Text -> LT.Text) -> - FieldDecoder a -genericEnumFieldDecoder nameTransform = fromMaybe (error $ "Invalid enum value. Not one of " ++ show (Map.keys allValuesMap)) . flip Map.lookup allValuesMap <$> rawBytesFieldDecoder - where - -- TODO: Vector of pointers to ByteStrings for a bit more memory locality? Does it make a perf difference? - allValuesMap = Map.mapKeys (LBS.toStrict . LT.encodeUtf8 . nameTransform) $ fmap to genEnumDecoder - -class EnumDecoder f where - -- | Returns the textual representation and constructed object for every possible - -- value of the enum. - genEnumDecoder :: Map LT.Text (f a) - -instance (EnumDecoder a, EnumDecoder b) => EnumDecoder (a :+: b) where - genEnumDecoder = (L1 <$> genEnumDecoder) `Map.union` (R1 <$> genEnumDecoder) - -instance (EnumDecoder f) => EnumDecoder (M1 D c f) where - genEnumDecoder = M1 <$> genEnumDecoder - --- U1 is "Unit"-type, that is: no value in the constructor, AKA "pure enum". -instance (KnownSymbol ctorName) => EnumDecoder (M1 C ('MetaCons ctorName ctorFixity 'False) U1) where - genEnumDecoder = Map.singleton (LT.pack $ symbolVal (Proxy @ctorName)) (M1 U1) - --- | One of the functions behind 'LowerCasedPgEnum', but you can decide --- how to map your type's constructor names arbitrarily, which can be --- useful if you're not using lowercase values in your postgres enums. -genericEnumFieldEncoder :: - forall a. - (Generic a, EnumEncoder (Rep a)) => - -- | A function that takes in the Haskell constructor name and returns the textual representation of the enum in postgres - (Text -> Text) -> - a -> - ByteString -genericEnumFieldEncoder nameTransform = encodeUtf8 . nameTransform . genEnumEncoder . from - -class EnumEncoder f where - -- | Returns the textual representation of an enum value's constructor. - genEnumEncoder :: f a -> Text - -instance (EnumEncoder a, EnumEncoder b) => EnumEncoder (a :+: b) where - genEnumEncoder (L1 x) = genEnumEncoder x - genEnumEncoder (R1 x) = genEnumEncoder x - -instance (EnumEncoder f) => EnumEncoder (M1 D c f) where - genEnumEncoder (M1 x) = genEnumEncoder x - --- U1 is "Unit"-type, that is: no value in the constructor, AKA "pure enum". -instance (KnownSymbol ctorName) => EnumEncoder (M1 C ('MetaCons ctorName ctorFixity 'False) U1) where - genEnumEncoder _ = Text.pack $ symbolVal (Proxy @ctorName) - --- | Returns a `FieldEncoder` that is sent without a type OID in queries. --- This means postgres will try to infer the type of these arguments. --- Check `typedFieldEncoder` if you're interested in encoding your custom types, --- you probably don't need this. -untypedFieldEncoder :: (EncodingContext -> a -> BinaryField) -> FieldEncoder a -untypedFieldEncoder enc = FieldEncoder {toTypeOid = \_ -> Nothing, toPgField = enc} - --- | A decoder that accepts any PG type and returns the object's --- postgres' binary representation as a ByteString. -rawBytesFieldDecoder :: FieldDecoder ByteString -rawBytesFieldDecoder = - FieldDecoder - { fieldValueDecoder = \_oid -> \case - bs -> Right bs, - decodesSqlNullTo = Left "Cannot decode SQL null as the `rawBytesFieldDecoder`.", - allowedPgTypes = const True - } - --- | Returns a field-encoding function for a vector-like Foldable (e.g. Lists and Vector itself). -toPgVectorField :: forall f a. (Foldable f, ToPgField a) => EncodingContext -> f a -> BinaryField -toPgVectorField encCtx = - let fe = fieldEncoder @a - encodeElement el = Builder.binaryField $ fe.toPgField encCtx el - Oid elemOid = fromMaybe (Oid 0) (fe.toTypeOid encCtx) - in \vec -> - let ndim = Builder.int32BE 1 - -- Postgres seems to build the "has_nulls" flag itself in the ReadArrayBinary function at https://github.com/postgres/postgres/blob/aa7f9493a02f5981c09b924323f0e7a58a32f2ed/src/backend/utils/adt/arrayfuncs.c#L1429, so we can just set it to 0 - hasNull = Builder.byteString $ BinSer.encodeInt32BE 0 - -- hasNull = Builder.byteString $ BinSer.encodeInt32BE (if Vector.any (\e -> toPgField e == Nothing) vec then 1 else 0) - elemOidBs = Builder.byteString $ BinSer.encodeInt32BE elemOid - lb1 = Builder.byteString $ BinSer.encodeInt32BE 1 - (Sum len, encodedElements) = foldMap (\el -> (Sum 1, encodeElement el)) vec - dim1 = Builder.byteString $ BinSer.encodeInt32BE len - fullBs = ndim <> hasNull <> elemOidBs <> dim1 <> lb1 <> encodedElements - in NotNull (Builder.toStrictByteString fullBs) - --- | A FieldDecoder that accepts and decodes Postgres arrays. -arrayField :: forall a f. (Monoid (f a)) => (forall m. (Monad m) => Int -> m a -> m (f a)) -> FieldDecoder a -> FieldDecoder (f a) -arrayField !replicateFunction !elementParser = - -- From https://github.com/postgres/postgres/blob/5941946d0934b9eccb0d5bfebd40b155249a0130/src/backend/utils/adt/arrayfuncs.c#L1548 - FieldDecoder - { fieldValueDecoder = \colInfo -> - let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput - in \case - bs -> case Parser.parseOnly arrayFieldDecoder bs of - Parser.ParseOk v -> Right v - Parser.ParseFail err -> Left err, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Vector type. Use a `Maybe (Vector a)`", - allowedPgTypes = allowOnlyArrayTypes - } - where - arrayParser :: EncodingContext -> Parser.Parser (f a) - arrayParser encodingContext = do - !ndim <- Parser.takeInt32BE - !_hasNull <- Parser.takeInt32BE - !elementTypeOid :: Oid <- Oid . fromIntegral <$> Parser.takeInt32BE - let !elementColInfo = FieldInfo elementTypeOid Nothing encodingContext - when (ndim > 1) $ fail $ "TODO: No support for multi-dimensional arrays in Hpgsql. Got array with ndim=" ++ show ndim - if ndim == 0 - then pure mempty - else do - !dim_i :: Int <- fromIntegral <$> Parser.takeInt32BE - !_lb_i <- Parser.takeInt32BE - unless (elementParser.allowedPgTypes elementColInfo) $ fail $ "Array contains elements of type OID " ++ show elementTypeOid ++ " but decoder does not handle that type" - replicateFunction dim_i $ do - size :: Int <- fromIntegral <$> Parser.takeInt32BE - if size == (-1) - then case elementParser.decodesSqlNullTo of - Left err -> fail err - Right v -> pure v - else do - elementBs <- Parser.take size - case elementParser.fieldValueDecoder elementColInfo elementBs of - Left err -> fail $ "Error parsing array element: " ++ show err - Right el -> pure el +import Hpgsql.Encoding.Internal diff --git a/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs b/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs deleted file mode 100644 index d1710fe..0000000 --- a/hpgsql/src/Hpgsql/Encoding/BinarySerializer.hs +++ /dev/null @@ -1,226 +0,0 @@ -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE CPP #-} - --- | --- A replacement for libraries like cereal or binary. --- In our tests, this is ~6.0% faster than cereal, and it also --- (or by virtue of) allocates ~13% less memory in some of our benchmarks. --- And it also means one fewer dependency. --- The caveat is that this module makes unaligned memory access. For the target --- CPU architectures of this library, this should be fine. -module Hpgsql.Encoding.BinarySerializer - ( ByteStringIdx (..), - decodeInt16BE, - decodeInt32BE, - decodeInt64BE, - decodeWord32BE, - decodeWord64BE, - encodeInt32BE, - encodeDouble, - encodeFloat, - encodeInt64BE, - encodeInt16BE, - encodePgBoolean, - decodeDataRow, - decodePgFieldWithAtMost4Bytes, - CoolWordDec(..) - ) -where - -import Data.ByteString (ByteString) -import qualified Data.ByteString.Internal as InternalBS -import Data.Int (Int16, Int32, Int64) -import Prelude hiding (encodeFloat) -#if WORDS_BIGENDIAN -import Data.Word (Word16, Word32, Word64) -#else -import Data.Word (Word16, Word32, Word64, byteSwap16, byteSwap32, byteSwap64, Word8) -#endif -import Data.Bits (Bits (unsafeShiftR)) -import Data.Coerce (coerce) -import Foreign (Storable (..), (.&.)) -import Foreign.ForeignPtr (withForeignPtr) -import GHC.Float (castDoubleToWord64, castFloatToWord32) -import System.IO.Unsafe (unsafeDupablePerformIO) - -fromBigEndian32 :: Word32 -> Word32 -#if WORDS_BIGENDIAN -fromBigEndian32 = Prelude.id -#else -fromBigEndian32 = byteSwap32 -#endif - -fromBigEndian64 :: Word64 -> Word64 -#if WORDS_BIGENDIAN -fromBigEndian64 = Prelude.id -#else -fromBigEndian64 = byteSwap64 -#endif - -fromBigEndian16 :: Word16 -> Word16 -#if WORDS_BIGENDIAN -fromBigEndian16 = Prelude.id -#else -fromBigEndian16 = byteSwap16 -#endif - -data CoolWordDec a where - CWord8 :: CoolWordDec Word8 - CWord16 :: CoolWordDec Word16 - CWord32 :: CoolWordDec Word32 - CWord64 :: CoolWordDec Word64 - -{-# INLINE decodeWord #-} -decodeWord :: CoolWordDec 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 - CWord16 -> if len < 2 + idx.idx then Left "Less than enough bytes to decode" else Right $ endianConvert $ unsafeDupablePerformIO $ withForeignPtr bytesPtr $ \ptr -> peekByteOff (coerce ptr) idx.idx - CWord32 -> if len < 4 + idx.idx then Left "Less than enough bytes to decode" else Right $ endianConvert $ unsafeDupablePerformIO $ withForeignPtr bytesPtr $ \ptr -> peekByteOff (coerce ptr) idx.idx - CWord64 -> if len < 8 + idx.idx then Left "Less than enough bytes to decode" else Right $ endianConvert $ unsafeDupablePerformIO $ withForeignPtr bytesPtr $ \ptr -> peekByteOff (coerce ptr) idx.idx - -{-# INLINE unsafeEncodeWord #-} -unsafeEncodeWord :: (Storable a) => a -> (a -> a) -> Int -> ByteString -unsafeEncodeWord n endianConvert len = - InternalBS.unsafeCreate len $ \bufferPtr -> - poke (coerce bufferPtr) $ endianConvert n - -newtype ByteStringIdx = ByteStringIdx {idx :: Int} - deriving newtype (Num) - -{-# INLINE decodeInt16BE #-} -decodeInt16BE :: ByteStringIdx -> ByteString -> Either String Int16 -decodeInt16BE idx bs = fromIntegral <$> decodeWord CWord16 idx bs fromBigEndian16 - -{-# INLINE encodeInt16BE #-} -encodeInt16BE :: Int16 -> ByteString -encodeInt16BE n = unsafeEncodeWord (fromIntegral n) fromBigEndian16 2 - -{-# INLINE decodeWord8 #-} -decodeWord8 :: ByteStringIdx -> ByteString -> Either String Word8 -decodeWord8 idx bs = decodeWord CWord8 idx bs Prelude.id - -{-# INLINE decodeWord32BE #-} -decodeWord32BE :: ByteStringIdx -> ByteString -> Either String Word32 -decodeWord32BE idx bs = decodeWord CWord32 idx bs fromBigEndian32 - -{-# INLINE decodeWord64BE #-} -decodeWord64BE :: ByteStringIdx -> ByteString -> Either String Word64 -decodeWord64BE idx bs = decodeWord CWord64 idx bs fromBigEndian64 - -{-# INLINE decodeInt32BE #-} -decodeInt32BE :: ByteStringIdx -> ByteString -> Either String Int32 -decodeInt32BE idx bs = fromIntegral <$> decodeWord CWord32 idx bs fromBigEndian32 - -{-# INLINE encodeInt32BE #-} -encodeInt32BE :: Int32 -> ByteString -encodeInt32BE n = unsafeEncodeWord (fromIntegral n) fromBigEndian32 4 - -{-# INLINE decodeInt64BE #-} -decodeInt64BE :: ByteStringIdx -> ByteString -> Either String Int64 -decodeInt64BE idx bs = fromIntegral <$> decodeWord CWord64 idx bs fromBigEndian64 - -{-# INLINE encodeInt64BE #-} -encodeInt64BE :: Int64 -> ByteString -encodeInt64BE n = unsafeEncodeWord (fromIntegral n) fromBigEndian64 8 - -{-# INLINE encodeFloat #-} -encodeFloat :: Float -> ByteString -encodeFloat n = unsafeEncodeWord (castFloatToWord32 n) fromBigEndian32 4 - -{-# INLINE encodeDouble #-} -encodeDouble :: Double -> ByteString -encodeDouble n = unsafeEncodeWord (castDoubleToWord64 n) fromBigEndian64 8 - --- TODO: Encode field length together with value for small types. --- This can also be a performance boost by having fewer bytestrings? -{-# INLINE encodePgBoolean #-} -encodePgBoolean :: Bool -> ByteString -encodePgBoolean v = if v then "\SOH" else "\NUL" - -{-# INLINE decodeDataRow #-} - --- | A super specialized decoder to decode a postgres DataRow message --- more quickly than a naive implementation. --- Returns the index into the left-unparsed contents of the supplied bytestring. -decodeDataRow :: ByteStringIdx -> ByteString -> Either String ByteStringIdx -decodeDataRow idx bs@(InternalBS.BS _bytesPtr len) = - -- We have a fast path when rows are at least 8 bytes long (should be the case - -- for all but 0-column query results or bytestring chunks "cut in the middle of the message") - -- by playing with bitwise operations. - -- Whether this is worth keeping is sort of questionable. It's complex - -- (even if I think it's safe and well tested) and reduces runtime of one of - -- our benchmarks by 2% compared to not having it. - case decodeWord CWord64 idx bs fromBigEndian64 of - Right (w64 :: Word64) -> - -- After fromBigEndian64, the Word64 has bytes in big-endian order: - -- byte 0 (msg type) in MSB, bytes 1-4 (length) next, bytes 5-6 (col count), byte 7 in LSB. - let msgIdentByte64 = w64 .&. 0b11111111_00000000_00000000_00000000_00000000_00000000_00000000_00000000 - lenFullMsg = flip unsafeShiftR 24 $ w64 .&. 0b00000000_11111111_11111111_11111111_11111111_00000000_00000000_00000000 - letterD :: Word64 = 0b01000100_00000000_00000000_00000000_00000000_00000000_00000000_00000000 - in if msgIdentByte64 == letterD - then - toResult (fromIntegral lenFullMsg) - else Left "Not a DataRow (Word64 bits decoding path)" - Left _ -> - -- It is possible the DataRow has length less than 8 bytes, so - -- we still have to try to parse that. - if len >= 5 + idx.idx - then do - msgIdentChar <- decodeWord8 idx bs - lenFullMsg <- decodeInt32BE (1 + idx) bs - if msgIdentChar == 68 -- Letter 'D' - then toResult (fromIntegral lenFullMsg) - else Left "Not a DataRow" - else Left "Less than enough bytes to decode a DataRow" - where - toResult lenFullMsg - | len >= 1 + lenFullMsg + idx.idx = Right $ ByteStringIdx $ 1 + lenFullMsg + idx.idx - | otherwise = Left "Less than enough bytes to decode a full DataRow" - -{-# 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) => CoolWordDec 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 decode 64 bits fields with this function. TODO: Make this function safer." - 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/Encoding/Internal.hs b/hpgsql/src/Hpgsql/Encoding/Internal.hs new file mode 100644 index 0000000..05637cf --- /dev/null +++ b/hpgsql/src/Hpgsql/Encoding/Internal.hs @@ -0,0 +1,1579 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Hpgsql.Encoding.Internal + ( -- * Decoding + FromPgField (..), + FieldDecoder (..), + FieldInfo (..), + FromPgRow (..), + RowDecoder (..), + singleField, + nullableField, + genericFromPgRow, + + -- * Encoding + ToPgField (..), + FieldEncoder (..), + ToPgRow (..), + RowEncoder (..), + EncodingContext (..), + genericToPgRow, + + -- * PostgreSQL enums + LowerCasedPgEnum (..), + genericEnumFieldDecoder, + genericEnumFieldEncoder, + + -- * PostgreSQL composite types + compositeTypeDecoder, + compositeTypeEncoder, + + -- * Driving PostgreSQL type inference + typeFieldDecoder, + typeFieldEncoder, + typeOidWithName, + typeMustBeNamed, + + -- * Others + rawBytesFieldDecoder, + untypedFieldEncoder, + toPgVectorField, + arrayField, + ) +where + +import Control.Monad (replicateM, unless, when) +import qualified Data.Aeson as Aeson +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as LBS +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.Coerce (coerce) +import Data.Fixed (divMod') +import Data.Functor.Contravariant (Contravariant (..)) +import Data.Int (Int16, Int32, Int64) +import qualified Data.List as List +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Monoid (Sum (..)) +import Data.Proxy (Proxy (..)) +import Data.Ratio (Ratio) +import Data.Scientific (Scientific (..), floatingOrInteger, scientific) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT +import Data.Time (CalendarDiffDays (..), CalendarDiffTime (..), Day, LocalTime (..), NominalDiffTime, TimeOfDay, UTCTime (..), ZonedTime, diffDays, diffTimeToPicoseconds, fromGregorian, picosecondsToDiffTime, secondsToNominalDiffTime, timeOfDayToTime, timeToTimeOfDay, utc, utcToZonedTime, zonedTimeToUTC) +import Data.Time.Calendar.Julian (addJulianDurationClip, fromJulian) +import Data.Tuple.Only (Only (..)) +import Data.UUID.Types (UUID) +import qualified Data.UUID.Types as UUID +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import GHC.Float (castWord32ToFloat, castWord64ToDouble, expt, float2Double) +import GHC.Generics (C, D, Generic (..), K1 (..), M1 (..), Meta (MetaCons), U1 (..), (:*:) (..), (:+:) (..)) +import GHC.TypeLits (KnownSymbol, TypeError, symbolVal) +import qualified GHC.TypeLits as TypeLits +import Hpgsql.Builder (BinaryField (..)) +import qualified Hpgsql.Builder as Builder +import Hpgsql.PinnedByteArray (PinnedByteArray) +import qualified Hpgsql.PinnedByteArray as PBA +import qualified Hpgsql.SimpleParser as Parser +import Hpgsql.Time (Unbounded (..)) +import Hpgsql.TypeInfo (EncodingContext (..), Oid (..), TypeDetails (..), TypeInfo (..), boolOid, byteaOid, charOid, dateOid, float4Oid, float8Oid, int2Oid, int4Oid, int8Oid, intervalOid, jsonOid, jsonbOid, lookupTypeByName, lookupTypeByOid, nameOid, numericOid, oidOid, textOid, timeOid, timestampOid, timestamptzOid, uuidOid, varcharOid, voidOid) + +data FieldInfo = FieldInfo + { fieldTypeOid :: !Oid, + -- | The column name from the query's result, if available. + fieldName :: !(Maybe Text), + -- | The EncodingContext as of the moment the query ran. + encodingContext :: !EncodingContext + } + +-- | A decoder for a single field/column. +data FieldDecoder a = FieldDecoder + { fieldValueDecoder :: FieldInfo -> PinnedByteArray -> Either String a, + decodesSqlNullTo :: Either String a, + allowedPgTypes :: FieldInfo -> Bool + } + deriving stock (Functor) + +-- | `f1 <> f2` produces a `FieldDecoder` that tries `f1` first, and if that fails it tries `f2`. +instance Semigroup (FieldDecoder a) where + dec1 <> dec2 = + FieldDecoder + { fieldValueDecoder = \cInfo -> + let f1 = dec1.fieldValueDecoder cInfo + f2 = dec2.fieldValueDecoder cInfo + in \mbs -> + let cand1 = if dec1.allowedPgTypes cInfo then f1 mbs else Left "Not first parser" + cand2 = if dec2.allowedPgTypes cInfo then f2 mbs else Left "Not second parser" + in cand1 <> cand2, + decodesSqlNullTo = dec1.decodesSqlNullTo <> dec2.decodesSqlNullTo, + allowedPgTypes = \cInfo -> dec1.allowedPgTypes cInfo || dec2.allowedPgTypes cInfo + } + +data RowDecoder a = RowDecoder + { fullRowDecoder :: [FieldInfo] -> Parser.Parser a, + -- | Returns the same colInfos with a boolean indicating if + -- the expected types match for each colInfo. + rowColumnsTypeCheck :: [FieldInfo] -> [(FieldInfo, Bool)], + numExpectedColumns :: !Int + } + deriving stock (Functor, Generic) + +instance Applicative RowDecoder where + pure v = RowDecoder (const $ pure v) (map (,True)) 0 + {-# INLINE (<*>) #-} -- This is crucial for performance. It makes our CPS Parser truly compile to CPS row decoders. + RowDecoder p1 tc1 nc1 <*> RowDecoder p2 tc2 nc2 = RowDecoder (\colTypes -> let (cols1, cols2) = List.splitAt nc1 colTypes in p1 cols1 <*> p2 cols2) (\colTypes -> let (cols1, cols2) = List.splitAt nc1 colTypes in tc1 cols1 ++ tc2 cols2) (nc1 + nc2) + +instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in Hpgsql because Hpgsql type-checks the result types of queries before having access to even the first data row. Use the Applicative class to write your instances or use the Monadic decoding variants.")) => Monad RowDecoder where + (>>=) = error "inaccessible bind in Monad RowDecoder instance" + +{-# INLINE singleField #-} +singleField :: FieldDecoder a -> RowDecoder a +singleField fdec = + -- This `case` is why we require `fieldAndValueDecoder` to decode + -- SQL NULL into `Nothing`: we do check decodesSqlNullTo. + let !valueForNull = case fdec.decodesSqlNullTo of + Left err -> fail err + Right v -> pure v + !typeCheck = fdec.allowedPgTypes + in RowDecoder + { fullRowDecoder = \case + [singleColInfo] -> + let decode = fdec.fieldValueDecoder singleColInfo + in do + lenNextCol <- fromIntegral <$> Parser.takeInt32BE + if lenNextCol >= 0 + then do + nextColBs <- Parser.take lenNextCol + case decode nextColBs of + Right v -> pure v + Left err -> fail err + else valueForNull + _ -> error "singleField expected a single column OID but got 0 or >1", + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, typeCheck singleColInfo)] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } + +class FromPgField a where + {-# MINIMAL fieldDecoder #-} + fieldDecoder :: FieldDecoder a + + -- | For types where there is a fast way to decode fields+values + -- without knowing the OID of the value in the query (of course, the + -- possible OIDs are still limited by the FieldDecoder's allowed types), + -- defining this can help provide a significant performance boost to inlined row decoders. + -- + -- Any implementation of this _must_ return a `Nothing` for a SQL NULL value, + -- regardless of what `FieldDecoder` would do with a SQL NULL. + -- + -- Define this as `Nothing` if implementing it isn't possible. + -- This isn't exposed to users yet, but we should recommend they add an INLINE pragma, + -- as the method's name suggests. + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder :: Maybe (Parser.Parser (Maybe a)) + inlinedConstFieldDecoder = Nothing + + -- | For types that can't implement `inlinedConstFieldDecoder` because they + -- need to know the value's OID for decoding, this is the next best thing: + -- also a specialized field+value decoder that can be faster than the + -- one derived from `fieldDecoder`. + -- + -- Any implementation of this _must_ return a `Nothing` for a SQL NULL value, + -- regardless of what `FieldDecoder` would do with a SQL NULL. + {-# INLINE notConstFieldDecoder #-} + notConstFieldDecoder :: FieldInfo -> Parser.Parser (Maybe a) + notConstFieldDecoder = + case inlinedConstFieldDecoder of + Nothing -> slowerParser + Just fd -> const fd + where + -- slowerParser takes a ByteString and passes it to the + -- field decoder. + slowerParser singleColInfo = do + len <- Parser.takeInt32BE + if len == (-1) + then pure Nothing + else do + bs <- Parser.take (fromIntegral len) + case fieldDecoder.fieldValueDecoder singleColInfo bs of + Left err -> fail err + Right v -> pure v + + -- | Semantically equivalent to `singleField fieldDecoder`, but for + -- most types it can provide a much faster `RowDecoder`. This doesn't + -- cause the same amount of size blowup that `inlinedSingleFieldRowDecoder` + -- does, but is also not as fast as that. + {-# NOINLINE notInlinedSingleFieldRowDecoder #-} + notInlinedSingleFieldRowDecoder :: RowDecoder a + notInlinedSingleFieldRowDecoder = inlinedSingleFieldRowDecoder + + -- | Semantically equivalent to `singleField fieldDecoder`, but for + -- most types it can provide a much faster `RowDecoder`. Beware that + -- using will produce more code in your row decoders, which can affect + -- compilation times and binary size. + {-# INLINE inlinedSingleFieldRowDecoder #-} + inlinedSingleFieldRowDecoder :: RowDecoder a + inlinedSingleFieldRowDecoder = case inlinedConstFieldDecoder @a of + -- This is a class method instead of a top-level function + -- because the GHC inliner behaves differently when it's a top-level + -- function, and benchmarks show this is faster. + Nothing -> + let !valueForNull = case (fieldDecoder @a).decodesSqlNullTo of + Left err -> fail err + Right v -> pure v + !typeCheck = (fieldDecoder @a).allowedPgTypes + in RowDecoder + { fullRowDecoder = \case + [singleColInfo] -> do + mv <- notConstFieldDecoder singleColInfo + case mv of + Nothing -> valueForNull + Just v -> pure v + _ -> error "singleField expected a single column OID but got 0 or >1", + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, typeCheck singleColInfo)] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } + Just p -> + -- The strictness and floating out of fieldDecoder-derived + -- values allows GHC to inline a lot more. For example, `valueForNull` + -- gets inlined to a `fail "Cannot decode SQL NULL ..."` for basic types + -- like `Int`. + let !valueForNull = case (fieldDecoder @a).decodesSqlNullTo of + Left err -> fail err + Right v -> pure v + !typeCheck = (fieldDecoder @a).allowedPgTypes + in RowDecoder + { fullRowDecoder = const $ do + mv <- p + case mv of + Nothing -> valueForNull + Just v -> pure v, + rowColumnsTypeCheck = \case + [singleColInfo] -> [(singleColInfo, typeCheck singleColInfo)] + _ -> error "singleField's rowColumnsTypeCheck expected a single column OID but got 0 or >1", + numExpectedColumns = 1 + } + +class FromPgRow a where + rowDecoder :: RowDecoder a + default rowDecoder :: (Generic a, ProductTypeDecoder (Rep a)) => RowDecoder a + rowDecoder = genericFromPgRow + +-- | Allows you to create a @FieldDecoder@ for composite types. +-- For a type such as: +-- +-- > CREATE TYPE int_and_bool AS (numfield INT, boolfield BOOL); +-- +-- You can define a Haskell type as such: +-- +-- > data IntAndBool = IntAndBool Int Bool +-- > +-- > instance FromPgField IntAndBool where +-- > fieldDecoder = compositeTypeDecoder rowDecoder <&> \(i, b) -> IntAndBool i b +compositeTypeDecoder :: forall a. RowDecoder a -> FieldDecoder a +compositeTypeDecoder (RowDecoder {..}) = + FieldDecoder + { fieldValueDecoder = \compositeTypeOid -> + let !prs = parserForRecord compositeTypeOid.encodingContext <* Parser.endOfInput + in \bs -> + case Parser.parseOnly prs bs of + Parser.ParseOk v -> Right v + Parser.ParseFail err -> Left err, + decodesSqlNullTo = Left "Got NULL in composite type but it was not allowed", + allowedPgTypes = const True -- There's no way to enforce a custom type's OID. We only check if it's structurally the same in the parser (same subtypes in same order) + } + where + parserForRecord :: EncodingContext -> Parser.Parser a + parserForRecord encodingContext = do + -- From https://github.com/postgres/postgres/blob/50ba65e73325cf55fedb3e1f14673d816726923b/src/backend/utils/adt/rowtypes.c#L687 + -- we can see a composite type's binary representation consists of: number of columns (Int32) + for_each_column { OID (Int32) + size_or_minus_1 (Int32) + Bytes } + numCols <- fromIntegral <$> Parser.takeInt32BE + unless (numCols == numExpectedColumns) $ fail $ "Composite type has " ++ show numCols ++ " attributes but parser expected " ++ show numExpectedColumns + let mkColInfo oid = FieldInfo oid Nothing encodingContext + cols <- replicateM numCols $ do + !oid <- Oid . fromIntegral <$> Parser.takeInt32BE + (sizeBs, !size) <- Parser.match $ fromIntegral <$> Parser.takeInt32BE + !bs <- Parser.take (max 0 size) + pure (oid, PBA.fromStrict sizeBs <> PBA.fromStrict bs) + let typecheckedCols = rowColumnsTypeCheck (map (mkColInfo . fst) cols) + unless (all snd typecheckedCols) $ fail $ "Parser for composite found type OIDs " ++ show (map fst cols) ++ " but expected different" + case Parser.parseOnly (fullRowDecoder (map (mkColInfo . fst) cols) <* Parser.endOfInput) (PBA.toStrict $ mconcat $ map snd cols) of + Parser.ParseOk v -> pure v + Parser.ParseFail err -> error $ "Error decoding composite type: " ++ show err + +-- | Allows you to create a @FieldEncoder@ for composite types. +-- For a type such as: +-- +-- > CREATE TYPE int_and_bool AS (numfield INT, boolfield BOOL); +-- +-- You can define a Haskell type as such: +-- +-- > data IntAndBool = IntAndBool Int Bool +-- > +-- > instance ToPgField IntAndBool where +-- > fieldEncoder = typeFieldEncoder (typeOidWithName "int_and_bool") +-- > $ compositeTypeEncoder $ contramap (\(IntAndBool i b) -> (fromIntegral i :: Int32, b)) rowEncoder +compositeTypeEncoder :: forall a. RowEncoder a -> FieldEncoder a +compositeTypeEncoder rowEnc = + FieldEncoder + { toTypeOid = \_ -> Nothing, + toPgField = \encCtx -> \a -> + let fields = map (\f -> f encCtx) (rowEnc.toPgParams a) + numCols = Builder.int32BE (fromIntegral $ length fields) + encodeField (mOid, bf) = + let Oid oid = fromMaybe (Oid 0) mOid + in Builder.int32BE oid <> Builder.binaryField bf + in NotNull (Builder.toStrictByteString (numCols <> foldMap encodeField fields)) + } + +instance (FromPgField a) => FromPgRow (Only a) where + rowDecoder = Only <$> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b) => FromPgRow (a, b) where + rowDecoder = (,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b, FromPgField c) => FromPgRow (a, b, c) where + rowDecoder = (,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d) => FromPgRow (a, b, c, d) where + rowDecoder = (,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e) => FromPgRow (a, b, c, d, e) where + rowDecoder = (,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f) => FromPgRow (a, b, c, d, e, f) where + rowDecoder = (,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g) => FromPgRow (a, b, c, d, e, f, g) where + rowDecoder = (,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h) => FromPgRow (a, b, c, d, e, f, g, h) where + rowDecoder = (,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i) => FromPgRow (a, b, c, d, e, f, g, h, i) where + rowDecoder = (,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j) => FromPgRow (a, b, c, d, e, f, g, h, i, j) where + rowDecoder = (,,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k) where + rowDecoder = (,,,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k, FromPgField l) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k, l) where + rowDecoder = (,,,,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k, FromPgField l, FromPgField m) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k, l, m) where + rowDecoder = (,,,,,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + +data FieldEncoder a = FieldEncoder + { toTypeOid :: !(EncodingContext -> Maybe Oid), + toPgField :: !(EncodingContext -> a -> BinaryField) + } + +instance Contravariant FieldEncoder where + contramap f fEnc = FieldEncoder {toTypeOid = fEnc.toTypeOid, toPgField = \encCtx -> let toF = fEnc.toPgField encCtx in \v -> toF (f v)} + +class ToPgField a where + fieldEncoder :: FieldEncoder a + +-- | Allows you to specify a type for a FieldEncoder. This can be useful to avoid +-- letting postgres infer types itself, which can cause errors. For example: +-- +-- > data MyEnum = Val1 | Val2 | Val3 +-- > myEnumFieldDecoderWithTypeInfoCheck :: FieldEncoder MyEnum +-- > myEnumFieldDecoderWithTypeInfoCheck = +-- > let convert = \case +-- > Val1 -> "val1" :: Text +-- > Val2 -> "val2" +-- > Val3 -> "val3" +-- > in typeFieldEncoder +-- > (typeOidWithName "my_enum") +-- > $ contramap convert fieldEncoder +-- +-- This will work unless you use non-default flags in your connection options. +typeFieldEncoder :: (EncodingContext -> Maybe Oid) -> FieldEncoder a -> FieldEncoder a +typeFieldEncoder ttoid enc = enc {toTypeOid = ttoid} + +typeOidWithName :: Text -> (EncodingContext -> Maybe Oid) +typeOidWithName typName = \encCtx -> typeOid <$> lookupTypeByName typName encCtx.typeInfoCache + +instance ToPgField Int where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just haskellIntOid, + toPgField = \_ -> binaryIntEncoder + } + +instance ToPgField Int16 where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just int2Oid, + toPgField = \_ -> \n -> NotNull $ PBA.encodeInt16BE n + } + +instance ToPgField Int32 where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just int4Oid, + toPgField = \_ -> \n -> NotNull $ PBA.encodeInt32BE n + } + +instance ToPgField Int64 where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just int8Oid, + toPgField = \_ -> \n -> NotNull $ PBA.encodeInt64BE n + } + +instance ToPgField Integer where + fieldEncoder = + let fe = fieldEncoder @Scientific + in FieldEncoder + { toTypeOid = \_ -> Just numericOid, + toPgField = \encCtx -> \n -> fe.toPgField encCtx (fromIntegral n) + } + +instance ToPgField (Ratio Integer) where + fieldEncoder = + let fe = fieldEncoder @Scientific + in FieldEncoder + { toTypeOid = \_ -> Just numericOid, + toPgField = \encCtx -> \r -> fe.toPgField encCtx (fromRational r) + } + +instance ToPgField Oid where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just oidOid, + toPgField = \_ -> \n -> NotNull $ PBA.encodeInt32BE $ fromIntegral n + } + +instance ToPgField Scientific where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just numericOid, + toPgField = \_ -> \n -> + let sign = PBA.encodeInt16BE $ if n >= 0 then 0 else 0x4000 + -- The number is coeff * 10^exp, but we want it in base-10000 so we convert it to + -- new_coeff * 10^new_exp with new_exp a multiple of 4 + base10000Expon = 4 * (base10Exponent n `div` 4) + base10000Coeff = coefficient n * expt 10 (base10Exponent n - base10000Expon) + ndigits, weight :: Int16 + digits :: ByteString + (ndigits, weight, digits) = calculateDigits 0 0 (abs base10000Coeff) "" + dscale = PBA.encodeInt16BE (abs $ fromIntegral base10000Expon) -- More than necessary, but safe? + in NotNull $ PBA.encodeInt16BE ndigits <> PBA.encodeInt16BE (weight - 1 + fromIntegral (base10000Expon `div` 4)) <> sign <> dscale <> digits + } + where + calculateDigits :: Int16 -> Int16 -> Integer -> BS.ByteString -> (Int16, Int16, BS.ByteString) + calculateDigits !ndigitsSoFar !weightSoFar 0 !encodedDigits = (ndigitsSoFar, weightSoFar, encodedDigits) + calculateDigits !ndigitsSoFar !weightSoFar !val !encodedDigits = + let (quotient, fromIntegral -> (rest :: Int16)) = val `divMod` 10000 + in calculateDigits + (ndigitsSoFar + 1) + (weightSoFar + 1) + quotient + (PBA.encodeInt16BE rest <> encodedDigits) + +instance ToPgField Float where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just float4Oid, + toPgField = \_ -> \n -> NotNull $ PBA.encodeFloat n + } + +instance ToPgField Double where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just float8Oid, + toPgField = \_ -> \n -> NotNull $ PBA.encodeDouble n + } + +instance ToPgField Bool where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just boolOid, + toPgField = \_ n -> NotNull $ PBA.encodePgBoolean n + } + +instance ToPgField Day where + -- PG Dates are Int32 number of days relative to 2000-01-01 + -- https://github.com/postgres/postgres/blob/master/src/include/datatype/timestamp.h#L235 + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just dateOid, + -- TODO: Catch integer overflow and do what? + toPgField = \_ d -> NotNull $ PBA.encodeInt32BE $ fromIntegral $ diffDays d (fromGregorian 2000 1 1) + } + +instance ToPgField (Unbounded Day) where + fieldEncoder = + let fe = fieldEncoder @Day + in FieldEncoder + { toTypeOid = fe.toTypeOid, + toPgField = \encCtx -> \case + NegInfinity -> NotNull $ PBA.encodeInt32BE minBound + Finite v -> fe.toPgField encCtx v + PosInfinity -> NotNull $ PBA.encodeInt32BE maxBound + } + +instance ToPgField CalendarDiffTime where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just intervalOid, + toPgField = \_ CalendarDiffTime {..} -> + let (days :: Int32, timeUnderOneDay) = ctTime `divMod'` 86_400 + in NotNull $ PBA.encodeInt64BE (round $ timeUnderOneDay * 1_000_000) <> PBA.encodeInt32BE days <> PBA.encodeInt32BE (fromIntegral ctMonths) + } + +instance ToPgField NominalDiffTime where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just intervalOid, + toPgField = \_ ndt -> + NotNull $ PBA.encodeInt64BE (round $ ndt * 1_000_000) <> PBA.encodeInt32BE 0 <> PBA.encodeInt32BE 0 + } + +instance ToPgField UTCTime where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just timestamptzOid, + -- TODO: Catch integer overflow and do what? + toPgField = \_ (UTCTime parsedDate timeinday) -> + let day :: Int64 = fromInteger $ parsedDate `diffDays` fromJulian 1999 12 19 + totalusecs :: Int64 = 86_400_000_000 * day + fromInteger (diffTimeToPicoseconds timeinday `div` 1_000_000) + in NotNull $ PBA.encodeInt64BE totalusecs + } + +instance ToPgField (Unbounded UTCTime) where + fieldEncoder = + let fe = fieldEncoder @UTCTime + in FieldEncoder + { toTypeOid = fe.toTypeOid, + toPgField = \encCtx -> \case + NegInfinity -> NotNull $ PBA.encodeInt64BE minBound + Finite v -> fe.toPgField encCtx v + PosInfinity -> NotNull $ PBA.encodeInt64BE maxBound + } + +instance ToPgField ZonedTime where + fieldEncoder = + let fe = fieldEncoder @UTCTime + in FieldEncoder + { toTypeOid = \_ -> Just timestamptzOid, + toPgField = \encCtx -> fe.toPgField encCtx . zonedTimeToUTC + } + +instance ToPgField (Unbounded ZonedTime) where + fieldEncoder = + let fe = fieldEncoder @ZonedTime + in FieldEncoder + { toTypeOid = fe.toTypeOid, + toPgField = \encCtx -> \case + NegInfinity -> NotNull $ PBA.encodeInt64BE minBound + Finite v -> fe.toPgField encCtx v + PosInfinity -> NotNull $ PBA.encodeInt64BE maxBound + } + +instance ToPgField LocalTime where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just timestampOid, + toPgField = \_ (LocalTime localDay localTimeOfDay) -> + let day :: Int64 = fromInteger $ localDay `diffDays` fromJulian 1999 12 19 + totalusecs :: Int64 = 86_400_000_000 * day + fromInteger (diffTimeToPicoseconds (timeOfDayToTime localTimeOfDay) `div` 1_000_000) + in NotNull $ PBA.encodeInt64BE totalusecs + } + +instance ToPgField TimeOfDay where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just timeOid, + toPgField = \_ tod -> + let usecs :: Int64 = fromInteger $ diffTimeToPicoseconds (timeOfDayToTime tod) `div` 1_000_000 + in NotNull $ PBA.encodeInt64BE usecs + } + +instance ToPgField Char where + fieldEncoder = + let fe = fieldEncoder @Text + in FieldEncoder + { toTypeOid = \_ -> Just textOid, + toPgField = \encCtx -> let !toTextField = fe.toPgField encCtx in \t -> toTextField $ Text.singleton t + } + +instance ToPgField ByteString where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just byteaOid, + toPgField = \_ -> \bs -> NotNull bs + } + +instance ToPgField LBS.ByteString where + fieldEncoder = + let fe = fieldEncoder @ByteString + in FieldEncoder + { toTypeOid = \_ -> Just byteaOid, + toPgField = \encCtx -> fe.toPgField encCtx . LBS.toStrict + } + +instance ToPgField Text where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just textOid, + toPgField = \_ -> \t -> + let bs = encodeUtf8 t + in NotNull bs + } + +instance ToPgField LT.Text where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just textOid, + toPgField = \_ -> \t -> + let bs = LBS.toStrict $ LT.encodeUtf8 t + in NotNull bs + } + +instance ToPgField String where + fieldEncoder = + let fe = fieldEncoder @Text + in FieldEncoder + { toTypeOid = \_ -> Just textOid, + toPgField = \encCtx -> fe.toPgField encCtx . Text.pack + } + +-- From https://hackage.haskell.org/package/case-insensitive-1.2.1.0/docs/Data-CaseInsensitive.html, +-- "Note that the FoldCase instance for ByteStrings is only guaranteed to be correct for ISO-8859-1 encoded strings!". +-- So we don't have those instances. + +-- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default +-- connection option). +instance ToPgField (CI Text) where + fieldEncoder = typeFieldEncoder (typeOidWithName "citext") $ contramap CI.original fieldEncoder + +-- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default +-- connection option). +instance ToPgField (CI LT.Text) where + fieldEncoder = typeFieldEncoder (typeOidWithName "citext") $ contramap CI.original fieldEncoder + +-- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default +-- connection option). +instance ToPgField (CI String) where + fieldEncoder = typeFieldEncoder (typeOidWithName "citext") $ contramap CI.original fieldEncoder + +instance ToPgField UUID where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just uuidOid, + toPgField = \_ -> NotNull . LBS.toStrict . UUID.toByteString + } + +instance ToPgField Aeson.Value where + fieldEncoder = + FieldEncoder + { toTypeOid = \_ -> Just jsonbOid, + toPgField = \_ -> \v -> + let bs = BS.cons 1 (LBS.toStrict $ Aeson.encode v) + in NotNull bs + } + +instance (ToPgField a) => ToPgField (Maybe a) where + fieldEncoder = + let fe = fieldEncoder @a + in FieldEncoder + { toTypeOid = fe.toTypeOid, + toPgField = \encCtx -> \case + Nothing -> SqlNull + Just n -> fe.toPgField encCtx n + } + +instance (ToPgField a) => ToPgField (Vector a) where + fieldEncoder = + let fe = fieldEncoder @a + in FieldEncoder + { toTypeOid = \encodingContext -> do + -- Maybe monad + elOid <- fe.toTypeOid encodingContext + arrayTypInfo <- lookupTypeByOid elOid encodingContext.typeInfoCache + arrayTypInfo.oidOfArrayType, + toPgField = toPgVectorField + } + +data RowEncoder a = RowEncoder + { toPgParams :: !(a -> [EncodingContext -> (Maybe Oid, BinaryField)]), + toTypeOids :: !(Proxy a -> [EncodingContext -> Maybe Oid]), + -- | This produces bytes for Binary COPY FROM STDIN rows, which can increase performance + -- and reduce memory usage comparing to deriving these bytes from `toPgParams`. + -- The produced bytes should not contain the total number of fields in the + -- beginning. + toBinaryCopyBytes :: !(EncodingContext -> a -> Builder.Builder) + } + +instance Contravariant RowEncoder where + contramap f rec = RowEncoder (\v -> rec.toPgParams (f v)) (\_ -> rec.toTypeOids Proxy) (\encCtx -> let !toBytes = rec.toBinaryCopyBytes encCtx in \v -> toBytes (f v)) + +-- | These are from `Divisible`, but we don't currently pull in the extra dependency that has that. +divide :: (a -> (b, c)) -> RowEncoder b -> RowEncoder c -> RowEncoder a +divide d re1 re2 = + RowEncoder + { toPgParams = \a -> let (b, c) = d a in re1.toPgParams b ++ re2.toPgParams c, + toTypeOids = \_ -> re1.toTypeOids Proxy ++ re2.toTypeOids Proxy, + toBinaryCopyBytes = \encCtx -> + let !toBytes1 = re1.toBinaryCopyBytes encCtx + !toBytes2 = re2.toBinaryCopyBytes encCtx + in \a -> let (b, c) = d a in toBytes1 b <> toBytes2 c + } + +class ToPgRow a where + rowEncoder :: RowEncoder a + default rowEncoder :: (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a + rowEncoder = genericToPgRow + +instance ToPgRow () where + rowEncoder = RowEncoder (\_ -> []) (\_ -> []) (\_ -> \_ -> mempty) + +singleFieldRowEncoder :: forall a. (ToPgField a) => RowEncoder a +singleFieldRowEncoder = + let fe = fieldEncoder @a + in RowEncoder + { toPgParams = \a -> [\encodingContext -> (fe.toTypeOid encodingContext, fe.toPgField encodingContext a)], + toTypeOids = \_ -> [fe.toTypeOid], + toBinaryCopyBytes = \encCtx -> let !enc = fe.toPgField encCtx in \a -> Builder.binaryField $ enc a + } + +instance (ToPgField a) => ToPgRow (Only a) where + rowEncoder = contramap fromOnly singleFieldRowEncoder + +instance (ToPgField a, ToPgField b) => ToPgRow (a, b) where + rowEncoder = divide id singleFieldRowEncoder singleFieldRowEncoder + +instance (ToPgField a, ToPgField b, ToPgField c) => ToPgRow (a, b, c) where + rowEncoder = divide (\(a, b, c) -> ((a, b), c)) rowEncoder singleFieldRowEncoder + +instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d) => ToPgRow (a, b, c, d) where + rowEncoder = divide (\(a, b, c, d) -> ((a, b), (c, d))) rowEncoder rowEncoder + +instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e) => ToPgRow (a, b, c, d, e) where + rowEncoder = divide (\(a, b, c, d, e) -> ((a, b, c), (d, e))) rowEncoder rowEncoder + +instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f) => ToPgRow (a, b, c, d, e, f) where + rowEncoder = divide (\(a, b, c, d, e, f) -> ((a, b, c), (d, e, f))) rowEncoder rowEncoder + +instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g) => ToPgRow (a, b, c, d, e, f, g) where + rowEncoder = divide (\(a, b, c, d, e, f, g) -> ((a, b, c), (d, e, f, g))) rowEncoder rowEncoder + +instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g, ToPgField h) => ToPgRow (a, b, c, d, e, f, g, h) where + rowEncoder = divide (\(a, b, c, d, e, f, g, h) -> ((a, b, c, d), (e, f, g, h))) rowEncoder rowEncoder + +instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g, ToPgField h, ToPgField i) => ToPgRow (a, b, c, d, e, f, g, h, i) where + rowEncoder = divide (\(a, b, c, d, e, f, g, h, i) -> ((a, b, c, d), (e, f, g, h, i))) rowEncoder rowEncoder + +instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g, ToPgField h, ToPgField i, ToPgField j) => ToPgRow (a, b, c, d, e, f, g, h, i, j) where + rowEncoder = divide (\(a, b, c, d, e, f, g, h, i, j) -> ((a, b, c, d, e), (f, g, h, i, j))) rowEncoder rowEncoder + +instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e, ToPgField f, ToPgField g, ToPgField h, ToPgField i, ToPgField j, ToPgField k) => ToPgRow (a, b, c, d, e, f, g, h, i, j, k) where + rowEncoder = divide (\(a, b, c, d, e, f, g, h, i, j, k) -> ((a, b, c, d, e, f), (g, h, i, j, k))) rowEncoder rowEncoder + +-- | The OID for `Data.Int`, which is machine dependent. +haskellIntOid :: Oid + +-- | All pg type OIDs that fit into Haskell's `Data.Int`, whose size is machine dependent. +haskellIntOids :: [Oid] +(haskellIntOid, haskellIntOids) + | (fromIntegral (maxBound @Int) :: Integer) > fromIntegral (maxBound @Int32) = (int8Oid, [int2Oid, int4Oid, int8Oid]) + | (fromIntegral (maxBound @Int) :: Integer) > fromIntegral (maxBound @Int16) = (int4Oid, [int2Oid, int4Oid]) + | otherwise = (int2Oid, [int2Oid]) + +-- | Big-Endian binary encoder for Haskell's `Data.Int`, which is machine-dependent. +binaryIntEncoder :: Int -> BinaryField +binaryIntEncoder + | haskellIntOid == int8Oid = NotNull . PBA.encodeInt64BE . fromIntegral + | haskellIntOid == int4Oid = NotNull . PBA.encodeInt32BE . fromIntegral + | otherwise = NotNull . PBA.encodeInt16BE . fromIntegral + +-- | Big-Endian binary decoder for Haskell's various IntXX types. +binaryIntDecoder :: forall a. (Integral a, Bounded a) => Oid -> PinnedByteArray -> Either String a +binaryIntDecoder typOid = \bs -> + if doesFit + then intDecoder bs + else Left $ "Chosen integral type does not fit every value for PG type with OID " ++ show typOid + where + maxBoundPgType :: Integer + intDecoder :: PinnedByteArray -> Either String a + (maxBoundPgType, intDecoder) + | typOid == int8Oid = (fromIntegral $ maxBound @Int64, fmap fromIntegral . PBA.decodeInt64BE 0) + | typOid == int4Oid = (fromIntegral $ maxBound @Int32, fmap fromIntegral . PBA.decodeInt32BE 0) + | typOid == int2Oid = (fromIntegral $ maxBound @Int16, fmap fromIntegral . PBA.decodeInt16BE 0) + | otherwise = error "Bug in Hpgsql. Decoding binary integral type not an int2, int4 or int8" + doesFit = maxBoundPgType <= fromIntegral (maxBound @a) + +binaryFloat4Decoder :: PinnedByteArray -> Float +binaryFloat4Decoder = castWord32ToFloat . either error id . PBA.decodeWord32BE 0 + +binaryFloat8Decoder :: PinnedByteArray -> Double +binaryFloat8Decoder = castWord64ToDouble . either error id . PBA.decodeWord64BE 0 + +parsePgType :: String -> [Oid] -> (PinnedByteArray -> Either String a) -> FieldDecoder a +parsePgType !typeName !requiredTypeOids !fieldValueDecoder = + FieldDecoder + { fieldValueDecoder = \_oid -> fieldValueDecoder, + decodesSqlNullTo = Left $ "Cannot decode SQL null as the Haskell " ++ typeName ++ " type. Use a `Maybe " ++ show typeName ++ "`", + allowedPgTypes = (`elem` requiredTypeOids) . fieldTypeOid + } + +instance FromPgField () where + {-# INLINE fieldDecoder #-} + fieldDecoder = + FieldDecoder + { fieldValueDecoder = \_oid -> \bs -> + if PBA.length bs == 0 + then Right () + else + Left $ "Invalid value for postgres void type", + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell () type. Use a `Maybe ()`", + allowedPgTypes = (== voidOid) . fieldTypeOid + } + +instance FromPgField Int where + {-# INLINE fieldDecoder #-} + fieldDecoder = + FieldDecoder + { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> + let !decode = binaryIntDecoder oid + in \bs -> decode bs, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int type. Use a `Maybe Int`", + allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid + } + + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just $ do + fieldLen <- Parser.takeInt32BE + -- TODO: We're assuming `Int` is always 64 bits, so 64bit CPUs? Is that ok? + -- TODO: Is there a way to optimistically assume <=4 bytes and use our custom new parser? + case fieldLen of + 4 -> Just . fromIntegral <$> Parser.takeInt32BE + (-1) -> pure Nothing + 8 -> Just . fromIntegral <$> Parser.takeInt64BE + 2 -> Just . fromIntegral <$> Parser.takeInt16BE + _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" + +instance FromPgField Int16 where + {-# INLINE fieldDecoder #-} + fieldDecoder = + FieldDecoder + { fieldValueDecoder = + let !decode = binaryIntDecoder int2Oid + in const decode, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int16 type. Use a `Maybe Int16`", + allowedPgTypes = (== int2Oid) . fieldTypeOid + } + +instance FromPgField Int32 where + {-# INLINE fieldDecoder #-} + fieldDecoder = + FieldDecoder + { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> binaryIntDecoder oid, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int32 type. Use a `Maybe Int32`", + allowedPgTypes = (`elem` [int2Oid, int4Oid]) . fieldTypeOid + } + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just $ do + fieldLen <- Parser.takeInt32BE + case fieldLen of + 4 -> Just <$> Parser.takeInt32BE + (-1) -> pure Nothing + 2 -> Just . fromIntegral <$> Parser.takeInt16BE + _ -> fail "Trying to decode PG int4 but it's not 2 or 4 bytes long" + +instance FromPgField Int64 where + {-# INLINE fieldDecoder #-} + fieldDecoder = + FieldDecoder + { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> binaryIntDecoder oid, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int64 type. Use a `Maybe Int64`", + allowedPgTypes = (`elem` [int2Oid, int4Oid, int8Oid]) . fieldTypeOid + } + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just $ do + fieldLen <- Parser.takeInt32BE + case fieldLen of + 8 -> Just <$> Parser.takeInt64BE + 4 -> Just . fromIntegral <$> Parser.takeInt32BE + (-1) -> pure Nothing + 2 -> Just . fromIntegral <$> Parser.takeInt16BE + _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" + +instance FromPgField Integer where + {-# INLINE fieldDecoder #-} + fieldDecoder = + FieldDecoder + { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> + let !decodeInt = binaryIntDecoder @Int64 oid + in if oid /= numericOid + then fmap fromIntegral <$> decodeInt + else \bs -> case Parser.parseOnly (scientificDecoder True <* Parser.endOfInput) bs of + Parser.ParseOk sci -> case floatingOrInteger @Double @Integer sci of + Right i -> Right i + Left _ -> Left "Internal error in Hpgsql. Scientific to Integer conversion failed" + Parser.ParseFail err -> Left err, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Integer type. Use a `Maybe Integer`", + allowedPgTypes = (`elem` [int8Oid, numericOid, int4Oid, int2Oid]) . fieldTypeOid + } + +instance FromPgField Oid where + {-# INLINE fieldDecoder #-} + fieldDecoder = + FieldDecoder + { fieldValueDecoder = \_ -> \case + -- Oids are just int4 + bs -> Oid <$> binaryIntDecoder int4Oid bs, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Oid type. Use a `Maybe Oid`", + allowedPgTypes = (== oidOid) . fieldTypeOid + } + +instance FromPgField Float where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "Float" [float4Oid] $ Right . binaryFloat4Decoder + + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just Parser.takeFloatBEWithFieldLength + +{-# INLINE doubleRowDecoder #-} +doubleRowDecoder :: Parser.Parser (Maybe Double) +doubleRowDecoder = do + len <- Parser.takeInt32BE + case len of + 8 -> Just <$> Parser.takeDoubleBE + 4 -> Just . float2Double <$> Parser.takeFloatBE + _ -> pure Nothing + +instance FromPgField Double where + {-# INLINE fieldDecoder #-} + fieldDecoder = + FieldDecoder + { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> + let decoder + | oid == float8Oid = binaryFloat8Decoder + | otherwise = float2Double . binaryFloat4Decoder + in Right . decoder, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`", + allowedPgTypes = (`elem` [float8Oid, float4Oid]) . fieldTypeOid + } + + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just doubleRowDecoder + +-- | Allows you to specify a type (and other checks, possibly) for a `FieldDecoder`. +-- This can be useful to ensure you're not accidentally decoding a different type. +-- +-- > data MyEnum = Val1 | Val2 | Val3 +-- > myEnumFieldDecoderWithTypeInfoCheck :: FieldDecoder MyEnum +-- > myEnumFieldDecoderWithTypeInfoCheck = +-- > let convert = \case +-- > "val1" -> Val1 +-- > "val2" -> Val2 +-- > "val3" -> Val3 +-- > _ -> error "Invalid value for MyEnum" +-- > in typeFieldDecoder +-- > (typeMustBeNamed "my_enum") +-- > $ convert <$> rawBytesFieldDecoder +-- +-- This will work unless you use non-default flags in your connection options. +typeFieldDecoder :: (FieldInfo -> Bool) -> FieldDecoder a -> FieldDecoder a +typeFieldDecoder fieldCheck dec = dec {allowedPgTypes = fieldCheck} + +typeMustBeNamed :: Text -> (FieldInfo -> Bool) +typeMustBeNamed typName = \fieldInfo -> + (typeName <$> lookupTypeByOid fieldInfo.fieldTypeOid fieldInfo.encodingContext.typeInfoCache) == Just typName + +{-# INLINE scientificDecoder #-} +scientificDecoder :: Bool -> Parser.Parser Scientific +scientificDecoder mustBeInteger = do + ndigits <- Parser.takeInt16BE + weight <- Parser.takeInt16BE + sign <- Parser.takeInt16BE -- 0x0000 is positive, 0x4000 is negative, 0xC000 is NAN, 0xD000 is Positive Infinity, 0xF000 is Negative Infinity + unless (sign == 0x0000 || sign == 0x4000) $ fail "NaN, positive or negative infinities cannot be decoded into Integer or Scientific" + !dscale <- Parser.takeInt16BE + when (mustBeInteger && dscale /= 0) $ fail "Decoding into `Integer` requires explicit casting with `numeric(X,0)` to force integral values" + valueAbs <- parseAndMult ndigits (fromIntegral weight * 4) 0 + pure $ (if sign == 0x0000 then 1 else (-1)) * valueAbs + where + parseAndMult :: Int16 -> Int -> Scientific -> Parser.Parser Scientific + parseAndMult 0 _ !val = pure val + parseAndMult !ndigitsLeft !currexpon !val = do + !digit <- fromIntegral <$> Parser.takeInt16BE + parseAndMult (ndigitsLeft - 1) (currexpon - 4) (val + scientific digit currexpon) + +{-# INLINE numericRowParser #-} +numericRowParser :: Parser.Parser (Maybe Scientific) +numericRowParser = do + fieldLen <- Parser.takeInt32BE + case fieldLen of + (-1) -> pure Nothing + _ -> Just <$> scientificDecoder False + +instance FromPgField Scientific where + -- See https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/numeric.c#L1163 + {-# INLINE fieldDecoder #-} + fieldDecoder = + FieldDecoder + { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> + if fieldTypeOid /= numericOid + then + let intdec = binaryIntDecoder @Int64 fieldTypeOid + in \bs -> flip scientific 0 . fromIntegral <$> intdec bs + else \case + bs -> + -- TODO: There is loss converting from Float/Double to Scientific, but it might be quite small, so should we accept + -- float4Oid and float8Oid here? + case Parser.parseOnly (scientificDecoder False <* Parser.endOfInput) bs of + Parser.ParseOk sci -> Right sci + Parser.ParseFail err -> Left err, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`", + allowedPgTypes = (`elem` [numericOid, int2Oid, int4Oid, int8Oid]) . fieldTypeOid + } + {-# INLINE notConstFieldDecoder #-} + notConstFieldDecoder = + let !int64RowDec = fromMaybe (error "Bug in HPgsql: Int64 does not have an inlinedConstFieldDecoder") $ inlinedConstFieldDecoder @Int64 + in \singleColInfo -> + if singleColInfo.fieldTypeOid /= numericOid + then fmap (flip scientific 0 . fromIntegral) <$> int64RowDec + else numericRowParser + +instance FromPgField (Ratio Integer) where + {-# INLINE fieldDecoder #-} + fieldDecoder = toRational <$> fieldDecoder @Scientific + +binaryTrue :: PinnedByteArray +binaryTrue = PBA.fromByteString $ PBA.encodePgBoolean True + +{-# INLINE boolRowDecoder #-} +boolRowDecoder :: Parser.Parser (Maybe Bool) +boolRowDecoder = fmap (== 1) <$> Parser.parsePgFieldWithAtMost4Bytes PBA.TypeSize1 + +instance FromPgField Bool where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "Bool" [boolOid] $ \bs -> Right $ bs == binaryTrue + + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just boolRowDecoder + +instance FromPgField Char where + {-# INLINE fieldDecoder #-} + fieldDecoder = + let textParser = fieldValueDecoder (fieldDecoder @Text) + in FieldDecoder + { fieldValueDecoder = \colInfo@FieldInfo {fieldTypeOid = oid} -> + let !decodeText = textParser colInfo + in \bs -> + if oid == charOid + then Right $ BSC.head $ PBA.toByteString bs + else case decodeText bs of + Left err -> Left err + Right t -> if Text.length t > 1 then Left "Cannot parse text with more than one character into a Haskell Char type." else Right (Text.head t), + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Char type. Use a `Maybe Char`", + -- TODO: All the varchar types? + allowedPgTypes = (`elem` [charOid, textOid]) . fieldTypeOid + } + +instance FromPgField ByteString where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "byteString" [byteaOid] (Right . PBA.toByteString) + +instance FromPgField LBS.ByteString where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "ByteString" [byteaOid] $ (Right . LBS.fromStrict . PBA.toByteString) + +{-# INLINE textDecoder #-} +textDecoder :: Parser.Parser (Maybe Text) +textDecoder = do + len <- Parser.takeInt32BE + if len >= 0 + then Just <$> Parser.takeUtf8Text (fromIntegral len) + else pure Nothing + +instance FromPgField Text where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> PBA.unsafeToUtf8Text 0 (PBA.length bs) bs + + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just textDecoder + +instance FromPgField LT.Text where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> LT.fromStrict <$> PBA.unsafeToUtf8Text 0 (PBA.length bs) bs + +instance FromPgField String where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "String" [textOid, varcharOid, nameOid] $ \bs -> Text.unpack <$> PBA.unsafeToUtf8Text 0 (PBA.length bs) bs + +-- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default +-- connection option). +instance FromPgField (CI Text) where + {-# INLINE fieldDecoder #-} + fieldDecoder = typeFieldDecoder (typeMustBeNamed "citext") $ CI.mk <$> fieldDecoder + +-- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default +-- connection option). +instance FromPgField (CI LT.Text) where + {-# INLINE fieldDecoder #-} + fieldDecoder = typeFieldDecoder (typeMustBeNamed "citext") $ CI.mk <$> fieldDecoder + +-- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default +-- connection option). +instance FromPgField (CI String) where + {-# INLINE fieldDecoder #-} + fieldDecoder = typeFieldDecoder (typeMustBeNamed "citext") $ CI.mk <$> fieldDecoder + +{-# INLINE utcTimeRowDecoder #-} +utcTimeRowDecoder :: Parser.Parser (Maybe UTCTime) +utcTimeRowDecoder = do + len <- Parser.takeInt32BE + case len of + 8 -> do + totalusecs <- Parser.takeInt64BE + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + pure $ Just $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + _ -> pure Nothing + +instance FromPgField UTCTime where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "UTCTime" [timestamptzOid] $ \case + bs -> do + -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 + totalusecs <- PBA.decodeInt64BE 0 bs + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + Right $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just utcTimeRowDecoder + +instance FromPgField (Unbounded UTCTime) where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "Unbounded UTCTime" [timestamptzOid] $ \case + bs -> do + -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 + totalusecs <- PBA.decodeInt64BE 0 bs + Right $ + if totalusecs == minBound + then NegInfinity + else + if totalusecs == maxBound + then PosInfinity + else + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + in Finite $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + +instance FromPgField ZonedTime where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "ZonedTime" [timestamptzOid] $ \case + bs -> do + -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 + totalusecs <- PBA.decodeInt64BE 0 bs + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + Right $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + +instance FromPgField (Unbounded ZonedTime) where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "Unbounded ZonedTime" [timestamptzOid] $ \case + bs -> do + -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 + totalusecs <- PBA.decodeInt64BE 0 bs + Right $ + if totalusecs == minBound + then NegInfinity + else + if totalusecs == maxBound + then PosInfinity + else + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + in Finite $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + +instance FromPgField LocalTime where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "LocalTime" [timestampOid] $ \case + bs -> do + totalusecs <- PBA.decodeInt64BE 0 bs + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + Right $ LocalTime parsedDate (timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + +instance FromPgField TimeOfDay where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "TimeOfDay" [timeOid] $ \case + bs -> do + usecs <- PBA.decodeInt64BE 0 bs + Right $ timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral usecs * 1_000_000 + +{-# INLINE dayRowDecoder #-} +dayRowDecoder :: Parser.Parser (Maybe Day) +dayRowDecoder = + let int32ToDay (i32 :: Int32) = let jd = fromIntegral i32 :: Integer in addJulianDurationClip (CalendarDiffDays 0 (jd - 13)) $ fromJulian 2000 01 01 + in fmap int32ToDay <$> Parser.takeInt32BEWithFieldLength + +instance FromPgField Day where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "Day" [dateOid] $ \case + bs -> do + -- There is a very specific conversion function for these, which I poorly translated to Haskell + -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 + -- But I found a simpler way to do this. Let's see if it works in our property based tests + jd <- PBA.decodeInt32BE 0 bs + Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 + + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just dayRowDecoder + +instance FromPgField (Unbounded Day) where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "Unbounded Day" [dateOid] $ \case + bs -> do + -- There is a very specific conversion function for these, which I poorly translated to Haskell + -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 + -- But I found a simpler way to do this. Let's see if it works in our property based tests + jd <- PBA.decodeInt32BE 0 bs + Right $ + if jd == minBound + then NegInfinity + else + if jd == maxBound + then PosInfinity + else + Finite $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 + +instance FromPgField CalendarDiffTime where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "CalendarDiffTime " [intervalOid] $ \bs -> do + nMicrosecs <- PBA.decodeInt64BE 0 bs + nDays <- PBA.decodeInt32BE 8 bs + nMonths <- PBA.decodeInt32BE 12 bs + Right $ CalendarDiffTime {ctMonths = fromIntegral nMonths, ctTime = secondsToNominalDiffTime (fromIntegral nDays * 86400) + realToFrac (picosecondsToDiffTime (fromIntegral nMicrosecs * 1_000_000))} + +instance FromPgField UUID where + {-# INLINE fieldDecoder #-} + fieldDecoder = parsePgType "UUID" [uuidOid] $ \case + bs -> case UUID.fromByteString (LBS.fromStrict $ PBA.toByteString bs) of + Just uuid -> Right uuid + Nothing -> Left "Bug in Hpgsql: UUID field could not be decoded" + +instance FromPgField Aeson.Value where + {-# INLINE fieldDecoder #-} + fieldDecoder = + FieldDecoder + { fieldValueDecoder = + \FieldInfo {fieldTypeOid} -> + let + -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in + \case + bs -> case Aeson.decodeStrict $ fixJsonb (PBA.toByteString bs) of + Just d -> Right d + Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls", + allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid + } + +-- | A FieldDecoder that accepts and decodes SQL NULLs into `Nothing` values +-- for a given decoder. +nullableField :: FieldDecoder a -> FieldDecoder (Maybe a) +nullableField FieldDecoder {..} = + FieldDecoder + { fieldValueDecoder = \oid -> + let origFieldValueParser = fieldValueDecoder oid + in \bs -> Just <$> origFieldValueParser bs, + decodesSqlNullTo = Right Nothing, + allowedPgTypes + } + +instance (FromPgField a) => FromPgField (Maybe a) where + {-# INLINE fieldDecoder #-} + fieldDecoder = nullableField fieldDecoder + + {-# INLINE notConstFieldDecoder #-} + notConstFieldDecoder finfo = do + mv <- notConstFieldDecoder @a finfo + case mv of + Nothing -> pure Nothing + jv -> pure $ Just jv + + {-# INLINE inlinedConstFieldDecoder #-} + -- \| For types where there is a fast way to decode fields+values + -- without knowing the OID of the value in the query (of course, the + -- possible OIDs are still limited by the FieldDecoder's allowed types), + -- this can help provide a significant boost to inlined row decoders. + -- Define as `Nothing` if this isn't possible. + -- inlinedConstFieldDecoder :: Maybe (Parser.Parser (Maybe (Maybe a))) + inlinedConstFieldDecoder = case inlinedConstFieldDecoder @a of + Nothing -> Nothing + Just p -> Just $ do + mv <- p + case mv of + Nothing -> pure Nothing -- Must return Nothing for SQL Nulls + jv -> pure $ Just jv + +allowOnlyArrayTypes :: FieldInfo -> Bool +allowOnlyArrayTypes fieldInfo = + -- TODO: We could check the elemTypeOid too, but maybe later + case lookupTypeByOid fieldInfo.fieldTypeOid fieldInfo.encodingContext.typeInfoCache of + Just (TypeInfo {typeDetails = ArrayType _}) -> True + Nothing -> True -- Assume user knows what they're doing + Just _ -> False -- Definitely not an array + +instance forall a. (FromPgField a) => FromPgField (Vector a) where + fieldDecoder = arrayField Vector.replicateM fieldDecoder + +instance {-# OVERLAPPING #-} forall a. (FromPgField a) => FromPgField (Vector (Vector a)) where + -- From https://github.com/postgres/postgres/blob/5941946d0934b9eccb0d5bfebd40b155249a0130/src/backend/utils/adt/arrayfuncs.c#L1548 + fieldDecoder = + FieldDecoder + { fieldValueDecoder = \colInfo -> + let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput + in \bs -> case Parser.parseOnly arrayFieldDecoder bs of + Parser.ParseOk v -> Right v + Parser.ParseFail err -> Left err, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell (Vector (Vector a)) type. Use a `Maybe (Vector (Vector a))`", + allowedPgTypes = allowOnlyArrayTypes + } + where + !elementParser = fieldDecoder @a + arrayParser :: EncodingContext -> Parser.Parser (Vector (Vector a)) + arrayParser encodingContext = do + !ndim <- Parser.takeInt32BE + !_hasNull <- Parser.takeInt32BE + !elementTypeOid :: Oid <- Oid . fromIntegral <$> Parser.takeInt32BE + let !elementColInfo = FieldInfo elementTypeOid Nothing encodingContext + when (ndim /= 2) $ fail $ "TODO: No support for " ++ show ndim ++ "-dimensional arrays in Hpgsql. Got array with ndim=" ++ show ndim + unless (elementParser.allowedPgTypes elementColInfo) $ fail $ "Array contains elements of type OID " ++ show elementTypeOid ++ " but decoder does not handle that type" + numRows <- do + !dim_i :: Int <- fromIntegral <$> Parser.takeInt32BE + !_lb_i <- Parser.takeInt32BE + pure dim_i + lengthEachRow <- do + !dim_i :: Int <- fromIntegral <$> Parser.takeInt32BE + !_lb_i <- Parser.takeInt32BE + pure dim_i + + Vector.replicateM numRows $ do + Vector.replicateM lengthEachRow $ + do + size :: Int <- fromIntegral <$> Parser.takeInt32BE + if size == (-1) + then case elementParser.decodesSqlNullTo of + Left err -> fail err + Right v -> pure v + else do + elementBs <- Parser.take size + case elementParser.fieldValueDecoder elementColInfo elementBs of + Left err -> fail $ "Error parsing array element: " ++ show err + Right el -> pure el + +{-# INLINE genericFromPgRow #-} + +-- | Derives `FromPgRow` generically. +genericFromPgRow :: forall a. (Generic a, ProductTypeDecoder (Rep a)) => RowDecoder a +genericFromPgRow = to <$> genRowDecoder @(Rep a) + +class ProductTypeDecoder f where + genRowDecoder :: RowDecoder (f a) + +instance (ProductTypeDecoder a, ProductTypeDecoder b) => ProductTypeDecoder (a :*: b) where + {-# INLINE genRowDecoder #-} + genRowDecoder = (:*:) <$> genRowDecoder <*> genRowDecoder + +instance (ProductTypeDecoder f) => ProductTypeDecoder (M1 a c f) where + {-# INLINE genRowDecoder #-} + genRowDecoder = M1 <$> genRowDecoder + +instance (FromPgField a) => ProductTypeDecoder (K1 r a) where + {-# INLINE genRowDecoder #-} + -- coercing instead of fmap reduces memory usage, apparently + -- by reducing (unnecessary) closures in the final row decoder, + -- as per looking at GHC Core + genRowDecoder = coerce $ notInlinedSingleFieldRowDecoder @a + +genericToPgRow :: forall a. (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a +genericToPgRow = contramap from genRowEncoder + +class ProductTypeEncoder f where + genRowEncoder :: RowEncoder (f a) + +instance (ProductTypeEncoder a, ProductTypeEncoder b) => ProductTypeEncoder (a :*: b) where + genRowEncoder = divide (\(a :*: b) -> (a, b)) genRowEncoder genRowEncoder + +instance (ProductTypeEncoder f) => ProductTypeEncoder (M1 i c f) where + genRowEncoder = contramap unM1 genRowEncoder + +instance (ToPgField a) => ProductTypeEncoder (K1 r a) where + genRowEncoder = contramap unK1 singleFieldRowEncoder + +-- | For the very common case of a Haskell enum matching a custom postgres enum type +-- that has its values all as lower case strings, this newtype can help you derive +-- instances as such: +-- +-- > data Mood = Sad | Ok | Happy +-- > deriving stock (Generic) +-- > deriving (FromPgField, ToPgField) via (LowerCasedPgEnum Mood) +-- +-- And this would match the Postgres equivalent: +-- +-- > CREATE TYPE mood AS ENUM ('sad', 'ok', 'happy'); +-- +-- If you run into PostgreSQL type inference problems with this, you can +-- write instances manually with 'genericEnumFieldDecoder', 'genericEnumFieldEncoder', +-- 'typeFieldEncoder', and 'typeFieldDecoder'. +newtype LowerCasedPgEnum a = LowerCasedPgEnum a + +instance (Generic a, EnumDecoder (Rep a)) => FromPgField (LowerCasedPgEnum a) where + fieldDecoder = LowerCasedPgEnum <$> genericEnumFieldDecoder LT.toLower + +instance (Generic a, EnumEncoder (Rep a)) => ToPgField (LowerCasedPgEnum a) where + fieldEncoder = untypedFieldEncoder $ \_encCtx -> \(LowerCasedPgEnum v) -> NotNull $ genericEnumFieldEncoder Text.toLower v + +-- | One of the functions behind 'LowerCasedPgEnum', but you can decide +-- how to map your type's constructor names arbitrarily, which can be +-- useful if you're not using lowercase values in your postgres enums. +genericEnumFieldDecoder :: + forall a. + (Generic a, EnumDecoder (Rep a)) => + -- | A function that takes in the Haskell constructor name and returns the textual representation of the enum in postgres + (LT.Text -> LT.Text) -> + FieldDecoder a +genericEnumFieldDecoder nameTransform = fromMaybe (error $ "Invalid enum value. Not one of " ++ show (Map.keys allValuesMap)) . flip Map.lookup allValuesMap <$> rawBytesFieldDecoder + where + -- TODO: Vector of pointers to ByteStrings for a bit more memory locality? Does it make a perf difference? + allValuesMap = Map.mapKeys (LBS.toStrict . LT.encodeUtf8 . nameTransform) $ fmap to genEnumDecoder + +class EnumDecoder f where + -- | Returns the textual representation and constructed object for every possible + -- value of the enum. + genEnumDecoder :: Map LT.Text (f a) + +instance (EnumDecoder a, EnumDecoder b) => EnumDecoder (a :+: b) where + genEnumDecoder = (L1 <$> genEnumDecoder) `Map.union` (R1 <$> genEnumDecoder) + +instance (EnumDecoder f) => EnumDecoder (M1 D c f) where + genEnumDecoder = M1 <$> genEnumDecoder + +-- U1 is "Unit"-type, that is: no value in the constructor, AKA "pure enum". +instance (KnownSymbol ctorName) => EnumDecoder (M1 C ('MetaCons ctorName ctorFixity 'False) U1) where + genEnumDecoder = Map.singleton (LT.pack $ symbolVal (Proxy @ctorName)) (M1 U1) + +-- | One of the functions behind 'LowerCasedPgEnum', but you can decide +-- how to map your type's constructor names arbitrarily, which can be +-- useful if you're not using lowercase values in your postgres enums. +genericEnumFieldEncoder :: + forall a. + (Generic a, EnumEncoder (Rep a)) => + -- | A function that takes in the Haskell constructor name and returns the textual representation of the enum in postgres + (Text -> Text) -> + a -> + ByteString +genericEnumFieldEncoder nameTransform = encodeUtf8 . nameTransform . genEnumEncoder . from + +class EnumEncoder f where + -- | Returns the textual representation of an enum value's constructor. + genEnumEncoder :: f a -> Text + +instance (EnumEncoder a, EnumEncoder b) => EnumEncoder (a :+: b) where + genEnumEncoder (L1 x) = genEnumEncoder x + genEnumEncoder (R1 x) = genEnumEncoder x + +instance (EnumEncoder f) => EnumEncoder (M1 D c f) where + genEnumEncoder (M1 x) = genEnumEncoder x + +-- U1 is "Unit"-type, that is: no value in the constructor, AKA "pure enum". +instance (KnownSymbol ctorName) => EnumEncoder (M1 C ('MetaCons ctorName ctorFixity 'False) U1) where + genEnumEncoder _ = Text.pack $ symbolVal (Proxy @ctorName) + +-- | Returns a `FieldEncoder` that is sent without a type OID in queries. +-- This means postgres will try to infer the type of these arguments. +-- Check `typedFieldEncoder` if you're interested in encoding your custom types, +-- you probably don't need this. +untypedFieldEncoder :: (EncodingContext -> a -> BinaryField) -> FieldEncoder a +untypedFieldEncoder enc = FieldEncoder {toTypeOid = \_ -> Nothing, toPgField = enc} + +-- | A decoder that accepts any PG type and returns the object's +-- postgres' binary representation as a ByteString. +rawBytesFieldDecoder :: FieldDecoder ByteString +rawBytesFieldDecoder = + FieldDecoder + { fieldValueDecoder = \_oid -> \case + bs -> Right $ PBA.toByteString bs, + decodesSqlNullTo = Left "Cannot decode SQL null as the `rawBytesFieldDecoder`.", + allowedPgTypes = const True + } + +-- | Returns a field-encoding function for a vector-like Foldable (e.g. Lists and Vector itself). +toPgVectorField :: forall f a. (Foldable f, ToPgField a) => EncodingContext -> f a -> BinaryField +toPgVectorField encCtx = + let fe = fieldEncoder @a + encodeElement el = Builder.binaryField $ fe.toPgField encCtx el + Oid elemOid = fromMaybe (Oid 0) (fe.toTypeOid encCtx) + in \vec -> + let ndim = Builder.int32BE 1 + -- Postgres seems to build the "has_nulls" flag itself in the ReadArrayBinary function at https://github.com/postgres/postgres/blob/aa7f9493a02f5981c09b924323f0e7a58a32f2ed/src/backend/utils/adt/arrayfuncs.c#L1429, so we can just set it to 0 + hasNull = Builder.byteString $ PBA.encodeInt32BE 0 + -- hasNull = Builder.byteString $ PBA.encodeInt32BE (if Vector.any (\e -> toPgField e == Nothing) vec then 1 else 0) + elemOidBs = Builder.byteString $ PBA.encodeInt32BE elemOid + lb1 = Builder.byteString $ PBA.encodeInt32BE 1 + (Sum len, encodedElements) = foldMap (\el -> (Sum 1, encodeElement el)) vec + dim1 = Builder.byteString $ PBA.encodeInt32BE len + fullBs = ndim <> hasNull <> elemOidBs <> dim1 <> lb1 <> encodedElements + in NotNull (Builder.toStrictByteString fullBs) + +-- | A FieldDecoder that accepts and decodes Postgres arrays. +arrayField :: forall a f. (Monoid (f a)) => (forall m. (Monad m) => Int -> m a -> m (f a)) -> FieldDecoder a -> FieldDecoder (f a) +arrayField !replicateFunction !elementParser = + -- From https://github.com/postgres/postgres/blob/5941946d0934b9eccb0d5bfebd40b155249a0130/src/backend/utils/adt/arrayfuncs.c#L1548 + FieldDecoder + { fieldValueDecoder = \colInfo -> + let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput + in \bs -> case Parser.parseOnly arrayFieldDecoder bs of + Parser.ParseOk v -> Right v + Parser.ParseFail err -> Left err, + decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Vector type. Use a `Maybe (Vector a)`", + allowedPgTypes = allowOnlyArrayTypes + } + where + arrayParser :: EncodingContext -> Parser.Parser (f a) + arrayParser encodingContext = do + !ndim <- Parser.takeInt32BE + !_hasNull <- Parser.takeInt32BE + !elementTypeOid :: Oid <- Oid . fromIntegral <$> Parser.takeInt32BE + let !elementColInfo = FieldInfo elementTypeOid Nothing encodingContext + when (ndim > 1) $ fail $ "TODO: No support for multi-dimensional arrays in Hpgsql. Got array with ndim=" ++ show ndim + if ndim == 0 + then pure mempty + else do + !dim_i :: Int <- fromIntegral <$> Parser.takeInt32BE + !_lb_i <- Parser.takeInt32BE + unless (elementParser.allowedPgTypes elementColInfo) $ fail $ "Array contains elements of type OID " ++ show elementTypeOid ++ " but decoder does not handle that type" + replicateFunction dim_i $ do + size :: Int <- fromIntegral <$> Parser.takeInt32BE + if size == (-1) + then case elementParser.decodesSqlNullTo of + Left err -> fail err + Right v -> pure v + else do + elementBs <- Parser.take size + case elementParser.fieldValueDecoder elementColInfo elementBs of + Left err -> fail $ "Error parsing array element: " ++ show err + Right el -> pure el diff --git a/hpgsql/src/Hpgsql/Internal.hs b/hpgsql/src/Hpgsql/Internal.hs index 509d60f..ec0f9ee 100644 --- a/hpgsql/src/Hpgsql/Internal.hs +++ b/hpgsql/src/Hpgsql/Internal.hs @@ -115,8 +115,6 @@ import qualified Control.Concurrent.STM as STM import Control.Exception.Safe (Exception (..), MonadThrow, SomeException, bracket, bracketOnError, finally, handleJust, mask, mask_, onException, throw, toException, tryJust) import Control.Monad (forM, forM_, join, replicateM, unless, void, when) import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.ByteString.Internal (w2c) import qualified Data.ByteString.Lazy as LBS import Data.Data (Proxy (..)) import Data.Either (isLeft, isRight) @@ -137,13 +135,14 @@ import GHC.Conc (ThreadStatus (..), threadStatus) import Hpgsql.Base import qualified Hpgsql.Builder as Builder import Hpgsql.Encoding (FieldInfo (..), FromPgRow (..), RowDecoder (..), RowEncoder (..), ToPgRow (..)) -import qualified Hpgsql.Encoding.BinarySerializer as BinSer import Hpgsql.Encoding.RowDecoderMonadic (ConversionState (..), RowDecoderMonadic (..)) import Hpgsql.InternalTypes (BindComplete (..), CommandComplete (..), ConnectOpts (..), ConnectionString (..), CopyInResponse (..), CopyQueryState (..), DataRow (..), Either3 (..), EncodingContext (..), ErrorDetail (..), ErrorResponse (..), HPgConnection (..), InternalConnectionState (..), IrrecoverableHpgsqlError (..), NoData (..), NotificationResponse (..), ParseComplete (..), Pipeline (..), PostgresError (..), Query (..), QueryId (..), QueryProtocol (..), QueryState (..), ReadyForQuery (..), ResetConnectionOpts (..), ResponseMsg (..), ResponseMsgsReceived (..), RowDescription (..), SingleQuery (..), TransactionStatus (..), WeakThreadId (..), mkMutex, queryToByteString, throwIrrecoverableError) import Hpgsql.Locking (getMyWeakThreadId, withMutex) import Hpgsql.Msgs (AuthenticationMethod (..), AuthenticationResponse (..), BackendKeyData (..), Bind (..), CancelRequest (..), CopyData (..), CopyDone (..), Describe (..), Execute (..), FromPgMessage (..), NoticeResponse (..), ParameterStatus (..), Parse (..), PasswordMessage (..), PgMsgParser (..), SASLInitialResponse (..), SASLResponse (..), StartupMessage (..), Sync (..), Terminate (..), ToPgMessage (..), parsePgMessage) import qualified Hpgsql.Msgs as Msgs import Hpgsql.Networking (recvNonBlocking, sendNonBlocking, socketWaitRead, socketWaitWrite) +import Hpgsql.PinnedByteArray (LazyPinnedByteArray, PinnedByteArray, takePgMessageIdentAndLen) +import qualified Hpgsql.PinnedByteArray as PBA import Hpgsql.Query (breakQueryIntoStatements) import qualified Hpgsql.ScramSHA256 as ScramSHA256 import qualified Hpgsql.SimpleParser as Parser @@ -507,7 +506,7 @@ receiveNextMsgWithMaskedContinuation conn parser f = Left (msgIdentChar, mPgError) -> throw IrrecoverableHpgsqlError {hpgsqlDetails = "Could not parse postgres message with ident char " <> Text.pack (show msgIdentChar) <> ". This is an internal error in Hpgsql. Please report it.", innerException = toException <$> mPgError, relatedStatement = Nothing} data ReceiveWhat a b where - ReceiveDataRows :: ReceiveWhat DataRow (ByteString, Int) + ReceiveDataRows :: ReceiveWhat DataRow (PinnedByteArray, Int) ReceiveArbitraryMsg :: PgMsgParser a -> (Either (Char, Maybe PostgresError) a -> STM b) -> ReceiveWhat a b -- | Masks asynchronous exceptions in between the moment the message is extracted from @@ -533,13 +532,12 @@ receiveNextMsgGeneric conn@HPgConnection {socket, recvBuffer} receiveWhat = do -- So we append to the buffer up until it has been fully fetched, -- and then extract it from the buffer in one piece. (initialBuf, initialBufLen) <- receiveUntilBufferHasAtLeast 5 - let charAndLength = LBS.take 5 initialBuf - let (w2c -> msgIdentChar, lenbs) = fromMaybe (error "impossible") $ LBS.uncons charAndLength - lenLeftToFetch :: Int64 = fromIntegral $ either error id (BinSer.decodeInt32BE 0 $ LBS.toStrict lenbs) - 4 + let (msgIdentChar, lenPlus4) = fromMaybe (error "impossible") $ takePgMessageIdentAndLen initialBuf + let lenLeftToFetch :: Int = fromIntegral $ lenPlus4 - 4 fullMessageLen = 5 + lenLeftToFetch - (nowBuf, _nowBufLen) <- if initialBufLen >= fullMessageLen then pure (initialBuf, initialBufLen) else receiveUntilBufferHasAtLeast fullMessageLen - let fullMsg = LBS.take fullMessageLen nowBuf - receivedNoticeOrParameterSoTryAgain <- go msgIdentChar fullMsg fullMessageLen nowBuf + (nowBuf, nowBufLen) <- if initialBufLen >= fullMessageLen then pure (initialBuf, initialBufLen) else receiveUntilBufferHasAtLeast fullMessageLen + let fullMsg = PBA.toStrictN 0 fullMessageLen nowBuf + receivedNoticeOrParameterSoTryAgain <- go msgIdentChar fullMsg nowBuf nowBufLen case receivedNoticeOrParameterSoTryAgain of Nothing -> receiveNextMsgGeneric conn receiveWhat Just res -> pure res @@ -552,8 +550,9 @@ receiveNextMsgGeneric conn@HPgConnection {socket, recvBuffer} receiveWhat = do -- the recvBuffer, then we _must_ remove that message from recvBuffer. -- Ideally we'd have non-retriable STM at the type-level here. Maybe later. -- Make sure to do very little work inside `go`! - go msgIdentChar fullMsg fullMessageLen nowBuf = mask_ $ modifyIORefIO recvBuffer $ do - let bufferWithoutMsg = LBS.drop fullMessageLen nowBuf + go msgIdentChar fullMsgPBA nowBuf nowBufLen = mask_ $ modifyIORefIO recvBuffer $ do + let bufferWithoutMsg = PBA.fromStrict $ PBA.toStrictN (PBA.length fullMsgPBA) (nowBufLen - PBA.length fullMsgPBA) nowBuf + fullMsg = LBS.fromStrict $ PBA.toByteString fullMsgPBA handleUnexpectedMsg onNotAnyReasonableMsg = -- This could be a Notification, NOTICE or a ParameterStatus message, since these -- can be received _at any time_ according to the docs. @@ -584,13 +583,13 @@ receiveNextMsgGeneric conn@HPgConnection {socket, recvBuffer} receiveWhat = do case receiveWhat of ReceiveDataRows -> -- Parse as many DataRows as we can to do as much work as we can per buffer "churn" - let fullBuf = LBS.toStrict nowBuf - in case Parser.parseOnly Parser.parseManyRows fullBuf of + let strictNowBuf = PBA.toStrict nowBuf + in case Parser.parseOnly Parser.parseManyRows strictNowBuf of Parser.ParseOk (unconsumedBufferBegin, nRowsParsed) | nRowsParsed > 0 -> do - let (msgs, unconsumedBuffer) = BS.splitAt unconsumedBufferBegin.idx fullBuf - debugPrint $ "Received " ++ show nRowsParsed ++ " messages with total length " ++ show (BS.length msgs) - pure (LBS.fromStrict unconsumedBuffer, Just (msgs, nRowsParsed)) - _ -> handleUnexpectedMsg $ const $ pure ("", 0) -- No error when we stop receiving DataRows, only emptiness + let (msgs, unconsumedBuffer) = PBA.splitAt unconsumedBufferBegin.idx strictNowBuf + debugPrint $ "Received " ++ show nRowsParsed ++ " messages with total length " ++ show (PBA.length msgs) + pure (PBA.fromStrict unconsumedBuffer, Just (msgs, nRowsParsed)) + _ -> handleUnexpectedMsg $ const $ pure (PBA.emptyPBA, 0) -- No error when we stop receiving DataRows, only emptiness ReceiveArbitraryMsg parser f -> case parsePgMessage msgIdentChar fullMsg parser of Just msg -> do @@ -601,10 +600,10 @@ receiveNextMsgGeneric conn@HPgConnection {socket, recvBuffer} receiveWhat = do -- \| Appends into the internal buffer by reading from the socket -- until the buffer has at least N bytes. -- Returns the current buffer and its length. - receiveUntilBufferHasAtLeast :: Int64 -> IO (LBS.ByteString, Int64) + receiveUntilBufferHasAtLeast :: Int -> IO (LazyPinnedByteArray, Int) receiveUntilBufferHasAtLeast minBytesNecessary = do currentBuffer <- readIORef recvBuffer - let nBytesInBuffer = LBS.length currentBuffer + let nBytesInBuffer = PBA.lazyLength currentBuffer if nBytesInBuffer >= minBytesNecessary then pure (currentBuffer, nBytesInBuffer) else do @@ -613,7 +612,7 @@ receiveNextMsgGeneric conn@HPgConnection {socket, recvBuffer} receiveWhat = do mask $ \restore -> rethrowAsIrrecoverable $ do restore $ socketWaitRead socket someBytes <- timeDebugNonBlockingOperation "recv" $ recvNonBlocking socket (max conn.connOpts.recvChunkSize $ fromIntegral $ minBytesNecessary - nBytesInBuffer) - atomicWriteIORef recvBuffer (currentBuffer <> LBS.fromStrict someBytes) + atomicWriteIORef recvBuffer (currentBuffer <> PBA.fromStrict someBytes) receiveUntilBufferHasAtLeast minBytesNecessary sendCancellationRequest :: HPgConnection -> IO () @@ -846,7 +845,7 @@ receiveOutstandingResponseMsgsAtomically thisThreadId conn qryId = do -- | A sequence of all the bytes of one or more DataRow messages and the total -- number of DataRow messages. -newtype DataRows = DataRows (ByteString, Int) +newtype DataRows = DataRows (PinnedByteArray, Int) -- | After sending one or more queries to the backend, run this function for each query to fetch that query's results. -- You must call the returned IO function and consume the returned Stream completely until you get to the diff --git a/hpgsql/src/Hpgsql/InternalTypes.hs b/hpgsql/src/Hpgsql/InternalTypes.hs index af81141..9381db6 100644 --- a/hpgsql/src/Hpgsql/InternalTypes.hs +++ b/hpgsql/src/Hpgsql/InternalTypes.hs @@ -77,6 +77,7 @@ import Data.Set (Set) import Hpgsql.Base (lastTwoAndInit, maximumOnOrDef, minimumOnOrDef) import Hpgsql.Builder (BinaryField) import Hpgsql.ParsingInternal (BlockOrNotBlock (..), ParsingOpts (..), parseSql) +import Hpgsql.PinnedByteArray (LazyPinnedByteArray, PinnedByteArray) import Hpgsql.TransactionStatusInternal (TransactionStatus (..)) import Hpgsql.TypeInfo (EncodingContext (..), Oid (..)) import Network.Socket (AddrInfo, Socket) @@ -370,7 +371,7 @@ newtype CommandComplete = CommandComplete {numRows :: Int64} -- | A DataRow with its leading identifying character ('D'), the 32bits self-length, -- the 2 bytes for the number of fields and the fields' lengths and values themselves. -newtype DataRow = DataRow {fullDataRow :: ByteString} +newtype DataRow = DataRow {fullDataRow :: PinnedByteArray} instance Show DataRow where show _ = "DataRow" @@ -464,7 +465,7 @@ data InternalConnectionState = InternalConnectionState data HPgConnection = HPgConnection { socket :: !Socket, socketClosed :: !(MVar Bool), - recvBuffer :: !(IORef LBS.ByteString), + recvBuffer :: !(IORef LazyPinnedByteArray), sendBuffer :: !(MVar [(LBS.ByteString, STM ())]), socketMutex :: !Mutex, originalConnStr :: !ConnectionString, diff --git a/hpgsql/src/Hpgsql/Msgs.hs b/hpgsql/src/Hpgsql/Msgs.hs index 3446e15..2a05096 100644 --- a/hpgsql/src/Hpgsql/Msgs.hs +++ b/hpgsql/src/Hpgsql/Msgs.hs @@ -23,8 +23,8 @@ import Data.Text.Encoding (decodeASCII, decodeUtf8, encodeUtf8) import Data.Word (Word8) import Hpgsql.Builder (BinaryField, Builder, builderLength) import qualified Hpgsql.Builder as Builder -import qualified Hpgsql.Encoding.BinarySerializer as BinSer import Hpgsql.InternalTypes (BindComplete (..), CommandComplete (..), CopyInResponse (..), DataRow (..), ErrorDetail (..), ErrorResponse (..), NoData (..), NotificationResponse (..), ParseComplete (..), ReadyForQuery (..), RowDescription (..), TransactionStatus (..)) +import qualified Hpgsql.PinnedByteArray as PBA import Hpgsql.ScramSHA256 (ScramClientFinalMessage (..), ScramServerFirstMessage (..)) import Hpgsql.TypeInfo (Oid (..)) @@ -54,7 +54,7 @@ colParser = do colName <- nulTerminatedCStringParser -- Column name as C string void $ Parsec.take (4 + 2) -- TODO: OIDs are unsigned integers! Try `select (-1)::oid` to see. Change to UInt32 somehow - typOid <- either fail pure . BinSer.decodeInt32BE 0 =<< Parsec.take 4 + typOid <- either fail pure . PBA.decodeInt32BE 0 . PBA.fromByteString =<< Parsec.take 4 void $ Parsec.take (2 + 4 + 2) pure (colName, Oid (fromIntegral typOid)) @@ -138,7 +138,7 @@ data Terminate = Terminate instance FromPgMessage AuthenticationResponse where msgParser = PgMsgParser $ \c (LBS.drop 5 -> restOfMsg) -> case c of - 'R' -> case first (BinSer.decodeInt32BE 0 . LBS.toStrict) $ LBS.splitAt 4 restOfMsg of + 'R' -> case first (PBA.decodeInt32BE 0 . PBA.fromByteString . LBS.toStrict) $ LBS.splitAt 4 restOfMsg of (Right 0, _) -> Just $ AuthenticationResponse AuthOk (Right 2, _) -> Just $ AuthenticationResponse AuthKerberosV5 (Right 3, _) -> Just $ AuthenticationResponse AuthCleartextPassword @@ -155,7 +155,7 @@ instance FromPgMessage AuthenticationResponse where instance FromPgMessage BackendKeyData where msgParser = PgMsgParser $ \c (LBS.splitAt 4 . LBS.drop 5 -> (pidBS, backendSecretKey)) -> case c of - 'K' -> case BinSer.decodeInt32BE 0 $ LBS.toStrict pidBS of + 'K' -> case PBA.decodeInt32BE 0 $ PBA.fromByteString $ LBS.toStrict pidBS of Right pid -> Just $ BackendKeyData {backendPid = pid, backendSecretKey = LBS.toStrict backendSecretKey} Left _ -> Nothing _ -> Nothing @@ -225,7 +225,7 @@ instance FromPgMessage CopyInResponse where instance FromPgMessage DataRow where msgParser = PgMsgParser $ \c !fullDataRow -> case c of - 'D' -> Just $ DataRow {fullDataRow = LBS.toStrict fullDataRow} + 'D' -> Just $ DataRow {fullDataRow = PBA.fromByteString $ LBS.toStrict fullDataRow} _ -> Nothing instance FromPgMessage NoData where @@ -359,7 +359,7 @@ instance FromPgMessage RowDescription where if c == 'T' then let (numColsBS, colContents) = LBS.splitAt 2 restOfMsg - numCols = either error id $ BinSer.decodeInt16BE 0 $ LBS.toStrict numColsBS + numCols = either error id $ PBA.decodeInt16BE 0 $ PBA.fromByteString $ LBS.toStrict numColsBS allColOidsParser :: Parsec.Parser [(Text, Oid)] allColOidsParser = replicateM (fromIntegral numCols) colParser in case LazyParsec.parseOnly (allColOidsParser <* Parsec.endOfInput) colContents of @@ -406,7 +406,7 @@ instance FromPgMessage NotificationResponse where then Nothing else let (notifierPidBs, channelNameAndPayload) = LBS.splitAt 4 restOfMsg - notifierPid = either error id $ BinSer.decodeInt32BE 0 $ LBS.toStrict notifierPidBs + notifierPid = either error id $ PBA.decodeInt32BE 0 $ PBA.fromByteString $ LBS.toStrict notifierPidBs in case LazyParsec.parseOnly ((NotificationResponse notifierPid <$> nulTerminatedCStringParser <*> nulTerminatedCStringParser) <* Parsec.endOfInput) channelNameAndPayload of diff --git a/hpgsql/src/Hpgsql/Networking.hs b/hpgsql/src/Hpgsql/Networking.hs index 29232c2..4ef48c0 100644 --- a/hpgsql/src/Hpgsql/Networking.hs +++ b/hpgsql/src/Hpgsql/Networking.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} + -- | -- This module contains code largely copied from the @network@ library -- (BSD-3-Clause), with modifications to remove blocking calls @@ -18,13 +21,13 @@ where import Control.Concurrent (threadWaitRead, threadWaitWrite) import Control.Exception.Safe (throw) -import Data.ByteString (ByteString) -import Data.ByteString.Internal (createAndTrim) import qualified Data.ByteString.Lazy as L import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import Data.Int (Int64) import Foreign (Ptr, Storable (..), Word8, allocaArray, castPtr, nullPtr, plusPtr) -import Foreign.C (CChar (..), CInt (..), CSize (..), eAGAIN, eWOULDBLOCK, getErrno) +import Foreign.C (CInt (..), CSize (..), eAGAIN, eWOULDBLOCK, getErrno) +import GHC.Base (Addr#) +import Hpgsql.PinnedByteArray (PinnedByteArray, createPinnedByteArray) import Network.Socket (Socket, withFdSocket) import System.Posix.Types (CSsize (..)) @@ -34,11 +37,11 @@ socketWaitRead socket = withFdSocket socket (threadWaitRead . fromIntegral) socketWaitWrite :: Socket -> IO () socketWaitWrite socket = withFdSocket socket (threadWaitWrite . fromIntegral) -recvNonBlocking :: Socket -> Int -> IO ByteString -recvNonBlocking s nbytes = withFdSocket s $ \fd -> createAndTrim nbytes $ \buffer -> do +recvNonBlocking :: Socket -> Int -> IO PinnedByteArray +recvNonBlocking s nbytes = withFdSocket s $ \fd -> createPinnedByteArray nbytes $ \buffer -> do -- Largely copied from https://hackage-content.haskell.org/package/network-3.2.8.0/docs/src/Network.Socket.Buffer.html#recvBufNoWait and other functions from the network library, -- but then modified to our needs. - r <- c_recv fd (castPtr buffer) (fromIntegral nbytes) 0 {-flags-} + r <- c_recv fd buffer (fromIntegral nbytes) 0 {-flags-} if r >= 0 then do -- putStrLn $ "Asked for " ++ show nbytes ++ ", got " ++ show r @@ -115,7 +118,7 @@ instance Storable IOVec where -- pokeIov ptr (sPtr, sLen) = poke ptr $ IOVec sPtr (fromIntegral sLen) foreign import ccall unsafe "recv" - c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt + c_recv :: CInt -> Addr# -> CSize -> CInt -> IO CInt foreign import ccall unsafe "writev" c_writev :: CInt -> Ptr IOVec -> CInt -> IO CSsize diff --git a/hpgsql/src/Hpgsql/PinnedByteArray.hs b/hpgsql/src/Hpgsql/PinnedByteArray.hs new file mode 100644 index 0000000..5742823 --- /dev/null +++ b/hpgsql/src/Hpgsql/PinnedByteArray.hs @@ -0,0 +1,409 @@ +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} + +-- | +-- Why our own `PinnedByteArray` type instead of just using `ByteString`? +-- It all started when upon inspecting our row decoder's GHC Core, I saw +-- `lazy`, `keepAlive` and boxing+unboxing of Word32s that seemed completely +-- unnecessary. Claude suggested `lazy` - which appeared in GHC Core - acted +-- like an optimization fence, and I don't remember the details now, but +-- basically a `ByteString` uses a `ForeignPtr` under the hood, which requires +-- `withForeignPtr`, which uses `keepAlive#`, adding a lot of code to peek a +-- Word from a pointer. +-- Whether Claude's assumption that that code acts as an optimization fence +-- is correct is inconsequential, what matters is that we can remove all that +-- code by using pinned `ByteArray`s, and that the extra Word boxing+unboxing +-- indeed goes away with that. +-- +-- After I wrote this, I realized _maybe_ I could've moved `withForeignPtr` +-- higher up in the call stack and in a single location, then pass down the +-- `Ptr Word8` in a newtype instead of doing this. But it wasn't only late, +-- `PinnedByteArray` has the advantage that I can push it down even to user +-- facing methods without being concerned with everything happening inside +-- the context of `withForeignPtr` (though I don't think it would've been a +-- problem). Also, we only use pinned byte arrays for our receive buffer, +-- which has such a short life span (it gets decoded into user rows immediately) +-- that heap fragmentation doesn't sound too concerning. +module Hpgsql.PinnedByteArray + ( PinnedByteArray (..), + LazyPinnedByteArray, + createPinnedByteArray, + takePgMessageIdentAndLen, + drop, + fromStrict, + toStrict, + splitAt, + length, + take, + lazyLength, + null, + emptyPBA, + fromByteString, + toByteString, + toStrictN, + + -- * Binary (de)serializer + ByteStringIdx (..), + decodeInt16BE, + decodeInt32BE, + decodeInt64BE, + decodeWord32BE, + decodeWord64BE, + encodeInt32BE, + encodeDouble, + encodeFloat, + encodeInt64BE, + encodeInt16BE, + encodePgBoolean, + decodeDataRow, + decodePgFieldWithAtMost4Bytes, + CoolWordDec (..), + WordDecoding (..), + unsafeToUtf8Text, + ) +where + +import Control.Monad (when) +import Data.ByteString (ByteString) +import Data.ByteString.Internal (ByteString (..)) +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Internal as InternalBS +import Data.Int (Int16, Int32, Int64) +import Foreign (withForeignPtr) +import Foreign.C (CInt (..)) +import Foreign.Marshal.Utils (copyBytes) +import Foreign.Ptr (plusPtr) +import GHC.Base (Addr#, ByteArray#, Char (..), IO (..), Int (..), MutableByteArray#, RealWorld, byteArrayContents#, compareByteArrays#, indexWord8ArrayAsChar#, indexWord8ArrayAsWord32#, mutableByteArrayContents#, newPinnedByteArray#, unIO, unsafeFreezeByteArray#, (+#)) +import GHC.Exts (indexWord8Array#, indexWord8ArrayAsWord16#, indexWord8ArrayAsWord64#) +import GHC.Ptr (Ptr (..)) +import GHC.Word (Word32 (..)) +import System.IO.Unsafe (unsafeDupablePerformIO) +import Prelude hiding (drop, encodeFloat, length, null, splitAt, take) +#if WORDS_BIGENDIAN +import Data.Word (Word16, Word32, Word64) +#else +import Data.Word (Word16, Word64, byteSwap16, byteSwap64, Word8, byteSwap32) +#endif +import Data.Array.Byte (ByteArray (..)) +import Data.Bits (Bits (unsafeShiftR)) +import Data.Coerce (coerce) +import Data.Text.Internal (Text (..)) +import Foreign (Storable (..), (.&.)) +import GHC.Float (castDoubleToWord64, castFloatToWord32) +import GHC.Word (Word16 (..), Word64 (..), Word8 (..)) + +data PinnedByteArray = PinnedByteArray + { start :: !Int, + len :: !Int, + array :: !ByteArray# + } + +instance Eq PinnedByteArray where + PinnedByteArray (I# s1) l1@(I# len) arr1# == PinnedByteArray (I# s2) l2 arr2# = + l1 == l2 && case compareByteArrays# arr1# s1 arr2# s2 len of + 0# -> True + _ -> False + +-- TODO: dlist for efficient snoc, because buffers can grow very large when fetching binaries/json/text blobs +data LazyPinnedByteArray = LazyPinnedByteArray !Int ![PinnedByteArray] + +instance Semigroup LazyPinnedByteArray where + LazyPinnedByteArray l1 pbs1 <> LazyPinnedByteArray l2 pbs2 = LazyPinnedByteArray (l1 + l2) (pbs1 ++ pbs2) + +instance Monoid LazyPinnedByteArray where + mempty = LazyPinnedByteArray 0 [] + +{-# NOINLINE emptyPBA #-} +emptyPBA :: PinnedByteArray +emptyPBA = unsafeDupablePerformIO $ createPinnedByteArray 0 (\_ -> pure 0) + +-- TODO: write property-based tests for these functions. This is tricky to get right. + +createPinnedByteArray :: Int -> (Addr# -> IO CInt) -> IO PinnedByteArray +createPinnedByteArray (I# size#) f = IO $ \s0 -> + let !(# newRW, (mutArr# :: MutableByteArray# RealWorld) #) = newPinnedByteArray# size# s0 + !(# newRW', lenCopied #) = unIO (f (mutableByteArrayContents# mutArr#)) newRW + !(# finalRW, frozenArr# #) = unsafeFreezeByteArray# mutArr# newRW' + in (# finalRW, PinnedByteArray 0 (fromIntegral lenCopied) frozenArr# #) + +fromByteString :: ByteString -> PinnedByteArray +fromByteString (BS fptr len) = unsafeDupablePerformIO $ createPinnedByteArray len $ \dst -> withForeignPtr fptr $ \src -> do + copyBytes (Ptr dst) src len + pure $ fromIntegral len + +toByteString :: PinnedByteArray -> ByteString +toByteString (PinnedByteArray start len src) = unsafeDupablePerformIO $ BS.create len $ \dst -> + copyBytes dst (Ptr (byteArrayContents# src) `plusPtr` start) len + +{-# INLINE unsafeToUtf8Text #-} + +-- | Assuming the pinned byte array contains valid UTF8 text, creates +-- returns an instance of `Text` with the same contents (but does make a copy). +unsafeToUtf8Text :: ByteStringIdx -> Int -> PinnedByteArray -> Either String Text +unsafeToUtf8Text idx desiredLen pba@(PinnedByteArray _ _ _) = let !(PinnedByteArray start arrLen arr#) = toStrictN idx.idx desiredLen (fromStrict pba) in if arrLen /= desiredLen then Left "Insufficient bytes in buffer in unsafeToUtf8Text" else Right $ Text (ByteArray arr#) start arrLen + +takePgMessageIdentAndLen :: LazyPinnedByteArray -> Maybe (Char, Int32) +takePgMessageIdentAndLen lpba@(LazyPinnedByteArray len _) = + if len >= 5 + then + let !(PinnedByteArray (I# start) _ arr#) = toStrictN 0 5 lpba + in Just (C# (indexWord8ArrayAsChar# arr# start), fromIntegral $ fromBigEndian32 $ W32# (indexWord8ArrayAsWord32# arr# (start +# 1#))) + else Nothing + +-- | Drops the next `n` bytes. +drop :: Int -> PinnedByteArray -> PinnedByteArray +drop n (PinnedByteArray start len arr#) = + if n >= len + then emptyPBA + else + PinnedByteArray (start + n) (len - n) arr# + +-- | Takes the first `n` bytes. +take :: Int -> PinnedByteArray -> PinnedByteArray +take n (PinnedByteArray start len arr#) = + PinnedByteArray start (min n len) arr# + +fromStrict :: PinnedByteArray -> LazyPinnedByteArray +fromStrict pba@(PinnedByteArray _ len _) = LazyPinnedByteArray len [pba] + +-- | Copies chunks into a single contiguous 'PinnedByteArray'. Avoids the copy +-- when there's already just a single chunk. +toStrict :: LazyPinnedByteArray -> PinnedByteArray +toStrict (LazyPinnedByteArray _ [pba]) = pba +toStrict lpba@(LazyPinnedByteArray totalLen _) = toStrictN 0 totalLen lpba + +-- | Creates strict PBA from a Lazy one, but just with the first @n@ +-- bytes after the first `skip` (or less if they're not all there). +toStrictN :: Int -> Int -> LazyPinnedByteArray -> PinnedByteArray +toStrictN skip n' (LazyPinnedByteArray totalLen' chunks) = + let n = min n' totalLen' + in unsafeDupablePerformIO $ createPinnedByteArray n $ \dst -> do + let go copied _ _ [] = pure copied + go copied _ 0 _ = pure copied + go offset skipLeft nLeft (PinnedByteArray start l arr# : rest) = do + let toSkipSrc = min l skipLeft + toCopy = min nLeft (l - toSkipSrc) + when (toCopy > 0 && toSkipSrc < l) $ copyBytes (Ptr dst `plusPtr` offset) (Ptr (byteArrayContents# arr#) `plusPtr` (start + toSkipSrc)) toCopy + when (toCopy < 0) $ error "toCopy < 0 should be impossible" + go (offset + toCopy) (skipLeft - toSkipSrc) (nLeft - toCopy) rest + fromIntegral <$> go 0 skip n chunks + +splitAt :: Int -> PinnedByteArray -> (PinnedByteArray, PinnedByteArray) +splitAt n pba = (take n pba, drop n pba) + +length :: PinnedByteArray -> Int +length (PinnedByteArray _ len _) = len + +null :: PinnedByteArray -> Bool +null = (== 0) . length + +lazyLength :: LazyPinnedByteArray -> Int +lazyLength (LazyPinnedByteArray len _) = len + +-- * Binary (de)serializer + +-- A replacement for libraries like cereal or binary. +-- In our tests, this is ~6.0% faster than cereal, and it also +-- (or by virtue of) allocates ~13% less memory in some of our benchmarks. +-- And it also means one fewer dependency. +-- The caveat is that this module makes unaligned memory access. For the target +-- CPU architectures of this library, this should be fine. + +fromBigEndian32 :: Word32 -> Word32 +#if WORDS_BIGENDIAN +fromBigEndian32 = Prelude.id +#else +fromBigEndian32 = byteSwap32 +#endif + +fromBigEndian64 :: Word64 -> Word64 +#if WORDS_BIGENDIAN +fromBigEndian64 = Prelude.id +#else +fromBigEndian64 = byteSwap64 +#endif + +fromBigEndian16 :: Word16 -> Word16 +#if WORDS_BIGENDIAN +fromBigEndian16 = Prelude.id +#else +fromBigEndian16 = byteSwap16 +#endif + +data CoolWordDec a where + CWord8 :: CoolWordDec Word8 + CWord16 :: CoolWordDec Word16 + CWord32 :: CoolWordDec Word32 + CWord64 :: CoolWordDec Word64 + +{-# INLINE decodeWord #-} +decodeWord :: CoolWordDec a -> ByteStringIdx -> PinnedByteArray -> (a -> a) -> Either String a +decodeWord wdec (ByteStringIdx boxedIdx@(I# idx)) (PinnedByteArray (I# start) len byArrSharp) endianConvert = + case wdec of + CWord8 -> if len < 1 + boxedIdx then Left "Less than enough bytes to decode" else Right $ endianConvert $ W8# $ indexWord8Array# byArrSharp (idx +# start) + CWord16 -> if len < 2 + boxedIdx then Left "Less than enough bytes to decode" else Right $ endianConvert $ W16# $ indexWord8ArrayAsWord16# byArrSharp (idx +# start) + CWord32 -> if len < 4 + boxedIdx then Left "Less than enough bytes to decode" else Right $ endianConvert $ W32# $ indexWord8ArrayAsWord32# byArrSharp (idx +# start) + CWord64 -> if len < 8 + boxedIdx then Left "Less than enough bytes to decode" else Right $ endianConvert $ W64# $ indexWord8ArrayAsWord64# byArrSharp (idx +# start) + +{-# INLINE unsafeEncodeWord #-} +unsafeEncodeWord :: (Storable a) => a -> (a -> a) -> Int -> ByteString +unsafeEncodeWord n endianConvert len = + InternalBS.unsafeCreate len $ \bufferPtr -> + poke (coerce bufferPtr) $ endianConvert n + +newtype ByteStringIdx = ByteStringIdx {idx :: Int} + deriving newtype (Num) + +{-# INLINE decodeInt16BE #-} +decodeInt16BE :: ByteStringIdx -> PinnedByteArray -> Either String Int16 +decodeInt16BE idx bs = fromIntegral <$> decodeWord CWord16 idx bs fromBigEndian16 + +{-# INLINE encodeInt16BE #-} +encodeInt16BE :: Int16 -> ByteString +encodeInt16BE n = unsafeEncodeWord (fromIntegral n) fromBigEndian16 2 + +{-# INLINE decodeWord8 #-} +decodeWord8 :: ByteStringIdx -> PinnedByteArray -> Either String Word8 +decodeWord8 idx bs = decodeWord CWord8 idx bs Prelude.id + +{-# INLINE decodeWord32BE #-} +decodeWord32BE :: ByteStringIdx -> PinnedByteArray -> Either String Word32 +decodeWord32BE idx bs = decodeWord CWord32 idx bs fromBigEndian32 + +{-# INLINE decodeWord64BE #-} +decodeWord64BE :: ByteStringIdx -> PinnedByteArray -> Either String Word64 +decodeWord64BE idx bs = decodeWord CWord64 idx bs fromBigEndian64 + +{-# INLINE decodeInt32BE #-} +decodeInt32BE :: ByteStringIdx -> PinnedByteArray -> Either String Int32 +decodeInt32BE idx bs = fromIntegral <$> decodeWord CWord32 idx bs fromBigEndian32 + +{-# INLINE encodeInt32BE #-} +encodeInt32BE :: Int32 -> ByteString +encodeInt32BE n = unsafeEncodeWord (fromIntegral n) fromBigEndian32 4 + +{-# INLINE decodeInt64BE #-} +decodeInt64BE :: ByteStringIdx -> PinnedByteArray -> Either String Int64 +decodeInt64BE idx bs = fromIntegral <$> decodeWord CWord64 idx bs fromBigEndian64 + +{-# INLINE encodeInt64BE #-} +encodeInt64BE :: Int64 -> ByteString +encodeInt64BE n = unsafeEncodeWord (fromIntegral n) fromBigEndian64 8 + +{-# INLINE encodeFloat #-} +encodeFloat :: Float -> ByteString +encodeFloat n = unsafeEncodeWord (castFloatToWord32 n) fromBigEndian32 4 + +{-# INLINE encodeDouble #-} +encodeDouble :: Double -> ByteString +encodeDouble n = unsafeEncodeWord (castDoubleToWord64 n) fromBigEndian64 8 + +-- TODO: Encode field length together with value for small types. +-- This can also be a performance boost by having fewer bytestrings? +{-# INLINE encodePgBoolean #-} +encodePgBoolean :: Bool -> ByteString +encodePgBoolean v = if v then "\SOH" else "\NUL" + +{-# INLINE decodeDataRow #-} + +-- | A super specialized decoder to decode a postgres DataRow message +-- more quickly than a naive implementation. +-- Returns the index into the left-unparsed contents of the supplied bytestring. +decodeDataRow :: ByteStringIdx -> PinnedByteArray -> Either String ByteStringIdx +decodeDataRow idx sbs@(PinnedByteArray _ len _) = + -- We have a fast path when rows are at least 8 bytes long (should be the case + -- for all but 0-column query results or bytestring chunks "cut in the middle of the message") + -- by playing with bitwise operations. + -- Whether this is worth keeping is sort of questionable. It's complex + -- (even if I think it's safe and well tested) and reduces runtime of one of + -- our benchmarks by 2% compared to not having it. + case decodeWord CWord64 idx sbs fromBigEndian64 of + Right (w64 :: Word64) -> + -- After fromBigEndian64, the Word64 has bytes in big-endian order: + -- byte 0 (msg type) in MSB, bytes 1-4 (length) next, bytes 5-6 (col count), byte 7 in LSB. + let msgIdentByte64 = w64 .&. 0b11111111_00000000_00000000_00000000_00000000_00000000_00000000_00000000 + lenFullMsg = flip unsafeShiftR 24 $ w64 .&. 0b00000000_11111111_11111111_11111111_11111111_00000000_00000000_00000000 + letterD :: Word64 = 0b01000100_00000000_00000000_00000000_00000000_00000000_00000000_00000000 + in if msgIdentByte64 == letterD + then + toResult (fromIntegral lenFullMsg) + else Left "Not a DataRow (Word64 bits decoding path)" + Left _ -> + -- It is possible the DataRow has length less than 8 bytes, so + -- we still have to try to parse that. + if len >= 5 + idx.idx + then do + msgIdentChar <- decodeWord8 idx sbs + lenFullMsg <- decodeInt32BE (1 + idx) sbs + if msgIdentChar == 68 -- Letter 'D' + then toResult (fromIntegral lenFullMsg) + else Left "Not a DataRow" + else Left "Less than enough bytes to decode a DataRow" + where + toResult lenFullMsg + | len >= 1 + lenFullMsg + idx.idx = Right $ ByteStringIdx $ 1 + lenFullMsg + idx.idx + | otherwise = Left "Less than enough bytes to decode a full DataRow" + +data WordDecoding a where + TypeSize1 :: WordDecoding Word8 + TypeSize2 :: WordDecoding Word16 + TypeSize4 :: WordDecoding Word32 + +fromWordDec :: WordDecoding a -> CoolWordDec a +fromWordDec = \case + TypeSize1 -> CWord8 + TypeSize2 -> CWord16 + TypeSize4 -> CWord32 + +{-# INLINE decodePgFieldWithAtMost4Bytes #-} + +-- | A specialized decoder that decoders a query result's +-- field's contents, but only for PG fields at most 4 bytes long and +-- at least 1 byte long (so no text or void types, for example). +-- This includes essentially int32, int16, and booleans. +-- Pass in as type argument a Word8, Word16 or Word32 to indicate +-- the size of the PG type you're decoding. +-- Returns the index into the first yet-unparsed byte. +decodePgFieldWithAtMost4Bytes :: forall a. (Storable a, Integral a) => WordDecoding a -> ByteStringIdx -> PinnedByteArray -> Either String (Maybe a, ByteStringIdx) +decodePgFieldWithAtMost4Bytes wdec = + let (pgTypeSize, endianSwap, valueMask :: Word64) = case wdec of + TypeSize1 -> (1, Prelude.id, 0b00000000_00000000_00000000_00000000_11111111_00000000_00000000_00000000) + TypeSize2 -> (2, fromBigEndian16, 0b00000000_00000000_00000000_00000000_11111111_11111111_00000000_00000000) + TypeSize4 -> (4, fromBigEndian32, 0b00000000_00000000_00000000_00000000_11111111_11111111_11111111_11111111) + valueShift :: Int = 8 * (4 - pgTypeSize) + in \idx bs -> + -- We try the most optimistic case first: + -- - Non-null 4 byte long types (like int32) + -- - Null int32 followed by at least one other field (not the last field in the row) + -- - Shorter types (int16, bool) followed by at least one other field (not the last field in the row) + -- In all the cases above, there are at least 8 bytes in the row, so our decoding into a Word64 will succeed. + case 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 fromIntegral fieldLenW64 == pgTypeSize + then + Right (Just fieldIfNotNull, idx + 4 + fromIntegral fieldLenW64) + else Left "decodePgFieldWithAtMost4Bytes being used to decode field with different length than the one asked for" + 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 == fromIntegral pgTypeSize + then do + -- peek after the next 4 bytes for @a + fieldValue <- decodeWord (fromWordDec wdec) (idx + 4) bs endianSwap + Right (Just fieldValue, idx + 4 + fromIntegral lenField) + else + if lenField == (-1) + then + Right (Nothing, idx + 4) + else Left "decodePgFieldWithAtMost4Bytes being used to decode field with different length than the one asked for" diff --git a/hpgsql/src/Hpgsql/SimpleParser.hs b/hpgsql/src/Hpgsql/SimpleParser.hs index 717184a..e3e9896 100644 --- a/hpgsql/src/Hpgsql/SimpleParser.hs +++ b/hpgsql/src/Hpgsql/SimpleParser.hs @@ -32,17 +32,17 @@ module Hpgsql.SimpleParser takeDoubleBE, takeFloatBEWithFieldLength, peekInt32BE, + takeUtf8Text, ) where import Control.Applicative (Alternative (..)) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS import Data.Int (Int16, Int32, Int64) +import Data.Text (Text) import Foreign.Storable (Storable) import GHC.Float (castWord32ToFloat, castWord64ToDouble) -import Hpgsql.Encoding.BinarySerializer (ByteStringIdx (..)) -import qualified Hpgsql.Encoding.BinarySerializer as BinSer +import Hpgsql.PinnedByteArray (ByteStringIdx (..), PinnedByteArray) +import qualified Hpgsql.PinnedByteArray as PBA import Prelude hiding (take) data ParseResult a @@ -50,16 +50,16 @@ data ParseResult a | ParseOk !a deriving stock (Show) --- | A parser that consumes a strict 'ByteString'. +-- | A parser that consumes a strict 'PinnedByteArray'. newtype Parser a = Parser { unParser :: forall r. ByteStringIdx -> - ByteString -> + PinnedByteArray -> (String -> r) -> -- \^ failure continuation - (a -> ByteStringIdx -> ByteString -> r) -> - -- \^ success continuation, taking original or new ByteString, the index into the original/new bytestring of the first yet-unparsed byte, and parsed value + (a -> ByteStringIdx -> PinnedByteArray -> r) -> + -- \^ success continuation, taking original or new PinnedByteArray, the index into the original/new bytestring of the first yet-unparsed byte, and parsed value r } @@ -98,31 +98,45 @@ instance MonadFail Parser where -- | Run a parser and return either an error message or the parsed value, -- using the strict 'ParseResult' type. Any unconsumed trailing input is -- discarded. -parseOnly :: Parser a -> ByteString -> ParseResult a +parseOnly :: Parser a -> PinnedByteArray -> ParseResult a parseOnly p = parseOnlyOffset p 0 {-# INLINE parseOnly #-} -- | Run a parser and return either an error message or the parsed value, -- using the strict 'ParseResult' type. Any unconsumed trailing input is -- discarded. -parseOnlyOffset :: Parser a -> ByteStringIdx -> ByteString -> ParseResult a +parseOnlyOffset :: Parser a -> ByteStringIdx -> PinnedByteArray -> ParseResult a parseOnlyOffset (Parser p) idx bs = p idx bs ParseFail (\a _ _ -> ParseOk a) {-# INLINE parseOnlyOffset #-} --- | Consume exactly @n@ bytes of input, failing if fewer than @n@ bytes +-- | Consume exactly `n` bytes of input, failing if fewer than `n` bytes -- remain. -take :: Int -> Parser ByteString -take n = Parser $ \idx bs kf ks -> +take :: Int -> Parser PinnedByteArray +take n = Parser $ \idx sbs kf ks -> let skip' = n + idx.idx - in if BS.length bs >= skip' - then case BS.take n $ BS.drop idx.idx bs of + in if PBA.length sbs >= skip' + -- TODO: dropAndTake in a single call + then case PBA.take n $ PBA.drop idx.idx sbs of -- Strict on the bytestring because we're pretty sure -- the field decoder will need to evaluate this anyway, -- so no need for an extra thunk - !h -> ks h (ByteStringIdx skip') bs + !h -> ks h (ByteStringIdx skip') sbs else kf "take: insufficient bytes" {-# INLINE take #-} +-- | Consume exactly `n` bytes of input, failing if fewer than `n` bytes +-- remain, and assumes those next `n` bytes are UTF8 text, so returns them +-- as `Text`. +takeUtf8Text :: Int -> Parser Text +takeUtf8Text n = Parser $ \idx sbs kf ks -> + let skip' = n + idx.idx + in if PBA.length sbs >= skip' + then case PBA.unsafeToUtf8Text idx n sbs of + Left err -> kf err + Right t -> ks t (ByteStringIdx skip') sbs + else kf ("take: wanted " <> show skip' <> " bytes but only " <> show (PBA.length sbs) <> " remain") +{-# INLINE takeUtf8Text #-} + -- | Consume exactly @n@ bytes of input, failing if fewer than @n@ bytes -- remain. skip :: Int -> Parser () @@ -133,7 +147,7 @@ skip n = Parser $ \idx bs _ ks -> {-# INLINE takeInt16BE #-} takeInt16BE :: Parser Int16 takeInt16BE = Parser $ \idx bs kf ks -> - case BinSer.decodeInt16BE idx bs of + case PBA.decodeInt16BE idx bs of Right v -> ks v (idx + 2) bs Left err -> kf err @@ -143,20 +157,20 @@ takeInt16BE = Parser $ \idx bs kf ks -> -- an Int16 in a row. takeInt16BEWithFieldLength :: Parser (Maybe Int16) takeInt16BEWithFieldLength = do - mi16 <- parsePgFieldWithAtMost4Bytes BinSer.CWord16 + mi16 <- parsePgFieldWithAtMost4Bytes PBA.TypeSize2 pure $ fromIntegral <$> mi16 {-# INLINE takeInt32BE #-} takeInt32BE :: Parser Int32 takeInt32BE = Parser $ \idx bs kf ks -> - case BinSer.decodeInt32BE idx bs of + case PBA.decodeInt32BE idx bs of Right v -> ks v (idx + 4) bs Left err -> kf err {-# INLINE peekInt32BE #-} peekInt32BE :: Parser Int32 peekInt32BE = Parser $ \idx bs kf ks -> - case BinSer.decodeInt32BE idx bs of + case PBA.decodeInt32BE idx bs of Right v -> ks v idx bs Left err -> kf err @@ -166,7 +180,7 @@ peekInt32BE = Parser $ \idx bs kf ks -> -- an Int32 in a row. takeInt32BEWithFieldLength :: Parser (Maybe Int32) takeInt32BEWithFieldLength = do - mi32 <- parsePgFieldWithAtMost4Bytes BinSer.CWord32 + mi32 <- parsePgFieldWithAtMost4Bytes PBA.TypeSize4 pure $ fromIntegral <$> mi32 {-# INLINE takeFloatBEWithFieldLength #-} @@ -175,20 +189,20 @@ takeInt32BEWithFieldLength = do -- a Float in a row. takeFloatBEWithFieldLength :: Parser (Maybe Float) takeFloatBEWithFieldLength = do - mf <- parsePgFieldWithAtMost4Bytes BinSer.CWord32 + mf <- parsePgFieldWithAtMost4Bytes PBA.TypeSize4 pure $ castWord32ToFloat <$> mf {-# INLINE takeFloatBE #-} takeFloatBE :: Parser Float takeFloatBE = Parser $ \idx bs kf ks -> - case BinSer.decodeWord32BE idx bs of + case PBA.decodeWord32BE idx bs of Right v -> ks (castWord32ToFloat v) (idx + 4) bs Left err -> kf err {-# INLINE takeDoubleBE #-} takeDoubleBE :: Parser Double takeDoubleBE = Parser $ \idx bs kf ks -> - case BinSer.decodeWord64BE idx bs of + case PBA.decodeWord64BE idx bs of Right v -> ks (castWord64ToDouble v) (idx + 8) bs Left err -> kf err @@ -206,7 +220,7 @@ takeInt64BEWithFieldLength = do {-# INLINE takeInt64BE #-} takeInt64BE :: Parser Int64 takeInt64BE = Parser $ \idx bs kf ks -> - case BinSer.decodeInt64BE idx bs of + case PBA.decodeInt64BE idx bs of Right v -> ks v (idx + 8) bs Left err -> kf err @@ -216,7 +230,7 @@ takeInt64BE = Parser $ \idx bs kf ks -> -- returning the index of the byte after this DataRow's last. takeDataRow :: Parser ByteStringIdx takeDataRow = Parser $ \idx bs kf ks -> - case BinSer.decodeDataRow idx bs of + case PBA.decodeDataRow idx bs of Left err -> kf err Right idxRest -> ks idxRest idxRest bs @@ -224,9 +238,9 @@ takeDataRow = Parser $ \idx bs kf ks -> -- | A specialized parser that reads a query result's -- field's contents. -parsePgFieldWithAtMost4Bytes :: forall a. (Storable a, Integral a) => BinSer.CoolWordDec a -> Parser (Maybe a) +parsePgFieldWithAtMost4Bytes :: forall a. (Storable a, Integral a) => PBA.WordDecoding a -> Parser (Maybe a) parsePgFieldWithAtMost4Bytes wdec = - let dec = BinSer.decodePgFieldWithAtMost4Bytes wdec + let dec = PBA.decodePgFieldWithAtMost4Bytes wdec in Parser $ \idx bs kf ks -> case dec idx bs of Right (v, restIdx) -> ks v restIdx bs @@ -254,20 +268,21 @@ parseManyRows = Parser $ \idx' bs' _kf ks -> let (restIdx, nParsed) = go idx' bs -- | Succeeds only when the input has been fully consumed. endOfInput :: Parser () endOfInput = Parser $ \idx bs kf ks -> - if BS.length bs <= idx.idx then ks () idx bs else kf "endOfInput: input remaining" + if PBA.length bs <= idx.idx then ks () idx bs else kf "endOfInput: input remaining" {-# INLINE endOfInput #-} -- | Run a parser and additionally return the slice of input it consumed. --- Because the input is a strict 'ByteString', the returned slice is a view +-- Because the input is a strict 'PinnedByteArray', the returned slice is a view -- over the original buffer and allocates no extra memory. -match :: Parser a -> Parser (ByteString, a) +match :: Parser a -> Parser (PinnedByteArray, a) match (Parser p) = Parser $ \idx bs kf ks -> p idx bs kf ( \a idx' bs' -> - let !consumed = BS.take (idx'.idx - idx.idx) $ BS.drop idx.idx bs + -- TODO: Is take . drop this being inlined or rewritten? + let !consumed = PBA.take (idx'.idx - idx.idx) $ PBA.drop idx.idx bs in ks (consumed, a) idx' bs' ) {-# INLINE match #-} diff --git a/hpgsql/src/Hpgsql/Types.hs b/hpgsql/src/Hpgsql/Types.hs index 2fc1dbe..728f24b 100644 --- a/hpgsql/src/Hpgsql/Types.hs +++ b/hpgsql/src/Hpgsql/Types.hs @@ -19,7 +19,8 @@ import qualified Data.ByteString.Lazy as LBS import Data.Tuple.Only (Only (..)) import Data.Typeable (Proxy (..)) import Hpgsql.Builder (BinaryField (..)) -import Hpgsql.Encoding (FieldDecoder (..), FieldEncoder (..), FieldInfo (..), FromPgField (..), FromPgRow (..), RowEncoder (..), ToPgField (..), ToPgRow (..), arrayField, toPgVectorField) +import Hpgsql.Encoding.Internal (FieldDecoder (..), FieldEncoder (..), FieldInfo (..), FromPgField (..), FromPgRow (..), RowEncoder (..), ToPgField (..), ToPgRow (..), arrayField, toPgVectorField) +import qualified Hpgsql.PinnedByteArray as PBA import qualified Hpgsql.SimpleParser as Parser import Hpgsql.TypeInfo (EncodingContext (..), TypeInfo (..), jsonOid, jsonbOid, lookupTypeByOid) @@ -90,9 +91,11 @@ instance FromPgField PgJson where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in \bs -> Right $ PgJson $ fixJsonb bs, + let + -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in + \bs -> Right $ PgJson $ fixJsonb (PBA.toByteString bs), decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell PgJson type. Use a `Maybe PgJson` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } @@ -102,7 +105,7 @@ instance FromPgField PgJson where if len == (-1) then pure Nothing else - fmap (Just . PgJson) $ + fmap (Just . PgJson . PBA.toByteString) $ if finfo.fieldTypeOid == jsonbOid then Parser.skip 1 >> Parser.take (len - 1) else Parser.take len @@ -120,11 +123,13 @@ instance (FromJSON a) => FromPgField (Aeson a) where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in \bs -> case Aeson.decodeStrict $ fixJsonb bs of - Just v -> Right $ Aeson v - Nothing -> Left "Failed to decode the postgres JSON value into your `Aeson a` type with aeson", + let + -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in + \bs -> case Aeson.decodeStrict $ fixJsonb (PBA.toByteString bs) of + Just v -> Right $ Aeson v + Nothing -> Left "Failed to decode the postgres JSON value into your `Aeson a` type with aeson", decodesSqlNullTo = Left "Cannot decode SQL null as a Haskell (Aeson a) type. Use a `Maybe (Aeson a)` if you want SQL nulls", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } From a2cd77de89a94371b53a47b4784cc023b1583e06 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sun, 6 Sep 2026 09:53:47 -0300 Subject: [PATCH 13/38] Wire up new benchmarks --- hpgsql-benchmarks/src/Main.hs | 25 +++++-------------------- scripts/run-full-benchmark-suite.nu | 2 ++ 2 files changed, 7 insertions(+), 20 deletions(-) diff --git a/hpgsql-benchmarks/src/Main.hs b/hpgsql-benchmarks/src/Main.hs index 81543a2..498b80b 100644 --- a/hpgsql-benchmarks/src/Main.hs +++ b/hpgsql-benchmarks/src/Main.hs @@ -92,14 +92,6 @@ data BenchRow = BenchRow deriving stock (Generic, Show, Eq) deriving anyclass (NFData, Hpgsql.FromPgRow, PGSimple.FromRow) -singleFieldFieldDecoderBenchRowDecoder :: Hpgsql.RowDecoder BenchRow -singleFieldFieldDecoderBenchRowDecoder = - BenchRow <$> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder - -notInlinedHandWrittenBenchRowDecoder :: Hpgsql.RowDecoder BenchRow -notInlinedHandWrittenBenchRowDecoder = - BenchRow <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder - fullyInlinedBenchRowDecoder :: Hpgsql.RowDecoder BenchRow fullyInlinedBenchRowDecoder = BenchRow <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder @@ -270,6 +262,11 @@ main = do bench ("hpgsql Record List (" ++ show n ++ " rows, Generically derived row decoder)") $ withMultipleConnections numConcurrentConnections hpgsqlConnect Hpgsql.Connection.closeGracefully $ \conn -> do Hpgsql.queryWith (Hpgsql.rowDecoder @BenchRow) conn (Hpgsql.mkQuery sql17 (Hpgsql.Only n)) + it ("hpgsql Record List (" ++ show n ++ " rows, fully inlined row decoder)") $ + void $ + bench ("hpgsql Record List (" ++ show n ++ " rows, fully inlined row decoder)") $ + withMultipleConnections numConcurrentConnections hpgsqlConnect Hpgsql.Connection.closeGracefully $ \conn -> do + Hpgsql.queryWith fullyInlinedBenchRowDecoder conn (Hpgsql.mkQuery sql17 (Hpgsql.Only n)) it ("hasql Record List (" ++ show n ++ " rows)") $ void $ bench ("hasql Record List (" ++ show n ++ " rows)") $ @@ -314,18 +311,6 @@ main = do runResourceT @IO $ do let res :: Stream (Of BenchRow) (ResourceT IO) () = StreamingPostgresSimple.query pgSimpleConn sql17Simple (PGSimple.Only n) S.effects res - it ("hpgsql Record Stream (" ++ show n ++ " rows, `singleField fieldDecoder` row decoder)") $ - void $ - bench ("hpgsql Record Stream (" ++ show n ++ " rows, `singleField fieldDecoder` row decoder)") $ do - withMultipleConnections numConcurrentConnections hpgsqlConnect Hpgsql.Connection.closeGracefully $ \conn -> do - res <- Hpgsql.querySWith singleFieldFieldDecoderBenchRowDecoder conn (Hpgsql.mkQuery sql17 (Hpgsql.Only n)) - S.effects res - it ("hpgsql Record Stream (" ++ show n ++ " rows, hand-written row decoder)") $ - void $ - bench ("hpgsql Record Stream (" ++ show n ++ " rows, hand-written row decoder)") $ do - withMultipleConnections numConcurrentConnections hpgsqlConnect Hpgsql.Connection.closeGracefully $ \conn -> do - res <- Hpgsql.querySWith notInlinedHandWrittenBenchRowDecoder conn (Hpgsql.mkQuery sql17 (Hpgsql.Only n)) - S.effects res it ("hpgsql Record Stream (" ++ show n ++ " rows, fully inlined row decoder)") $ void $ bench ("hpgsql Record Stream (" ++ show n ++ " rows, fully inlined row decoder)") $ do diff --git a/scripts/run-full-benchmark-suite.nu b/scripts/run-full-benchmark-suite.nu index 7512a65..b60864e 100755 --- a/scripts/run-full-benchmark-suite.nu +++ b/scripts/run-full-benchmark-suite.nu @@ -230,6 +230,7 @@ def main [] { {name: "postgresql-simple Record List (100000 rows, Generically derived row decoder)", lang: "Haskell"} {name: "hasql Record List (100000 rows)", lang: "Haskell"} {name: "hpgsql Record List (100000 rows, Generically derived row decoder)", lang: "Haskell"} + {name: "hpgsql Record List (100000 rows, fully inlined row decoder)", lang: "Haskell"} {name: "rust-tokio-postgres Record List (100000 rows)", lang: "Rust"} {name: "Npgsql Record List (100000 rows)", lang: "Csharp"} ] @@ -245,6 +246,7 @@ def main [] { {name: "streaming-postgresql-simple Record Stream (100000 rows, Generically derived row decoder)", lang: "Haskell"} {name: "postgresql-simple Record fold (100000 rows, Generically derived row decoder)", lang: "Haskell"} {name: "hpgsql Record Stream (100000 rows, Generically derived row decoder)", lang: "Haskell"} + {name: "hpgsql Record Stream (100000 rows, fully inlined row decoder)", lang: "Haskell"} {name: "rust-tokio-postgres Record Stream (100000 rows)", lang: "Rust"} {name: "Npgsql Record Stream (100000 rows)", lang: "Csharp"} ] From a648f7ebbfa50462f4ba9803a86bb71250220713 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Tue, 8 Sep 2026 17:35:51 -0300 Subject: [PATCH 14/38] Change `FieldDecoder` back to what it was in `master` --- BENCHMARKS.md | 34 +- hpgsql-benchmarks/src/Main.hs | 9 + .../Database/PostgreSQL/Simple/FromField.hs | 10 +- .../Database/PostgreSQL/Simple/HpgsqlUtils.hs | 20 +- hpgsql/src/Hpgsql/Encoding/Internal.hs | 306 ++++++++++-------- hpgsql/src/Hpgsql/PinnedByteArray.hs | 12 +- hpgsql/src/Hpgsql/Types.hs | 14 +- 7 files changed, 222 insertions(+), 183 deletions(-) diff --git a/BENCHMARKS.md b/BENCHMARKS.md index feff5bb..974b4ed 100644 --- a/BENCHMARKS.md +++ b/BENCHMARKS.md @@ -49,11 +49,12 @@ This benchmark is unfair towards both hpgsql and postgresql-simple (compared to | name | wall_clock_time | peak_live_rts_memory | peak_memory_upper_bound | total_managed_memory_allocated | |---|---|---|---|---| -| postgresql-simple Record List (100000 rows, Generically derived row decoder) | 14.72s | 146.3MB | 315.1MB | 49595.9MB | -| hasql Record List (100000 rows) | 8.450s | 99.2MB | 285.5MB | 14422.7MB | -| *hpgsql Record List (100000 rows, Generically derived row decoder)* | 4.033s | 140.4MB | 140.4MB | 14966.0MB | -| Npgsql Record List (100000 rows) | 1.050s | - | - | 481.7MB | -| rust-tokio-postgres Record List (100000 rows) | 950.2ms | - | 50.2MB | - | +| postgresql-simple Record List (100000 rows, Generically derived row decoder) | 14.65s | 142.6MB | 311.3MB | 49596.0MB | +| hasql Record List (100000 rows) | 8.574s | 99.3MB | 285.6MB | 14422.7MB | +| *hpgsql Record List (100000 rows, Generically derived row decoder)* | 3.504s | 112.2MB | 112.2MB | 9612.7MB | +| *hpgsql Record List (100000 rows, fully inlined row decoder)* | 3.034s | 112.9MB | 112.9MB | 6420.4MB | +| Npgsql Record List (100000 rows) | 1.015s | - | - | 481.6MB | +| rust-tokio-postgres Record List (100000 rows) | 981.7ms | - | 50.2MB | - | ### Materializing 100_000 rows with 13 columns each into a List of Tuples @@ -61,9 +62,9 @@ This runs with 2 concurrent queries, 10 times over: | name | wall_clock_time | peak_live_rts_memory | peak_memory_upper_bound | total_managed_memory_allocated | |---|---|---|---|---| -| postgresql-simple Tuple List (100000 rows) | 14.07s | 148.5MB | 218.9MB | 43243.5MB | -| hasql Tuple List (100000 rows) | 7.802s | 201.7MB | 342.5MB | 9841.6MB | -| *hpgsql Tuple List (100000 rows)* | 3.969s | 151.8MB | 151.8MB | 9985.4MB | +| postgresql-simple Tuple List (100000 rows) | 14.18s | 148.3MB | 218.7MB | 43243.4MB | +| hasql Tuple List (100000 rows) | 7.824s | 202.6MB | 343.4MB | 9841.6MB | +| *hpgsql Tuple List (100000 rows)* | 3.365s | 147.9MB | 147.9MB | 7312.0MB | ### Streaming 100_000 rows with 17 columns as Records @@ -75,11 +76,12 @@ cursors simultaneously, but not hpgsql's Streamed-from-socket streams). | name | wall_clock_time | peak_live_rts_memory | peak_memory_upper_bound | total_managed_memory_allocated | |---|---|---|---|---| -| postgresql-simple Record fold (100000 rows, Generically derived row decoder) | 16.20s | 0.0MB | 34.3MB | 48921.4MB | -| streaming-postgresql-simple Record Stream (100000 rows, Generically derived row decoder) | 16.13s | 0.0MB | 1.2MB | 62278.5MB | -| *hpgsql Record Stream (100000 rows, Generically derived row decoder)* | 1.592s | 0.3MB | 0.3MB | 14318.5MB | -| Npgsql Record Stream (100000 rows) | 1.034s | - | - | 441.9MB | -| rust-tokio-postgres Record Stream (100000 rows) | 876.1ms | - | 0.4MB | - | +| streaming-postgresql-simple Record Stream (100000 rows, Generically derived row decoder) | 16.17s | 0.0MB | 1.0MB | 62278.5MB | +| *hpgsql Record Stream (100000 rows, Generically derived row decoder)* | 1.108s | 0.3MB | 0.3MB | 9088.9MB | +| Npgsql Record Stream (100000 rows) | 992.5ms | - | - | 441.4MB | +| *hpgsql Record Stream (100000 rows, fully inlined row decoder)* | 967.0ms | 0.2MB | 0.2MB | 6112.3MB | +| rust-tokio-postgres Record Stream (100000 rows) | 894.1ms | - | 0.4MB | - | +| postgresql-simple Record fold (100000 rows, Generically derived row decoder) | | 0.0MB | 0.0MB | - | ### Streaming 100_000 rows with 13 columns as Tuples @@ -91,9 +93,9 @@ cursors simultaneously, but not hpgsql's Streamed-from-socket streams). | name | wall_clock_time | peak_live_rts_memory | peak_memory_upper_bound | total_managed_memory_allocated | |---|---|---|---|---| -| streaming-postgresql-simple Tuple Stream (100000 rows) | 13.23s | 0.0MB | 1.3MB | 55905.7MB | -| postgresql-simple Tuple fold (100000 rows) | 12.95s | 0.0MB | 12.3MB | 42538.1MB | -| *hpgsql Tuple Stream (100000 rows)* | 774.3ms | 0.3MB | 0.3MB | 8270.3MB | +| streaming-postgresql-simple Tuple Stream (100000 rows) | 13.26s | 0.0MB | 1.3MB | 55905.7MB | +| postgresql-simple Tuple fold (100000 rows) | 12.94s | 0.0MB | 10.6MB | 42538.1MB | +| *hpgsql Tuple Stream (100000 rows)* | 768.3ms | 0.2MB | 0.2MB | 6479.9MB | ### COPY FROM STDIN diff --git a/hpgsql-benchmarks/src/Main.hs b/hpgsql-benchmarks/src/Main.hs index 498b80b..0d24c3d 100644 --- a/hpgsql-benchmarks/src/Main.hs +++ b/hpgsql-benchmarks/src/Main.hs @@ -92,6 +92,10 @@ data BenchRow = BenchRow deriving stock (Generic, Show, Eq) deriving anyclass (NFData, Hpgsql.FromPgRow, PGSimple.FromRow) +singleFieldBenchRowDecoder :: Hpgsql.RowDecoder BenchRow +singleFieldBenchRowDecoder = + BenchRow <$> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder <*> Hpgsql.singleField Hpgsql.fieldDecoder + fullyInlinedBenchRowDecoder :: Hpgsql.RowDecoder BenchRow fullyInlinedBenchRowDecoder = BenchRow <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder @@ -267,6 +271,11 @@ main = do bench ("hpgsql Record List (" ++ show n ++ " rows, fully inlined row decoder)") $ withMultipleConnections numConcurrentConnections hpgsqlConnect Hpgsql.Connection.closeGracefully $ \conn -> do Hpgsql.queryWith fullyInlinedBenchRowDecoder conn (Hpgsql.mkQuery sql17 (Hpgsql.Only n)) + it ("hpgsql Record List (" ++ show n ++ " rows, `singleField fieldDecoder` row decoder)") $ + void $ + bench ("hpgsql Record List (" ++ show n ++ " rows, `singleField fieldDecoder` row decoder)") $ + withMultipleConnections numConcurrentConnections hpgsqlConnect Hpgsql.Connection.closeGracefully $ \conn -> do + Hpgsql.queryWith singleFieldBenchRowDecoder conn (Hpgsql.mkQuery sql17 (Hpgsql.Only n)) it ("hasql Record List (" ++ show n ++ " rows)") $ void $ bench ("hasql Record List (" ++ show n ++ " rows)") $ diff --git a/hpgsql-simple-compat/src/Database/PostgreSQL/Simple/FromField.hs b/hpgsql-simple-compat/src/Database/PostgreSQL/Simple/FromField.hs index 42e124e..3a2b83b 100644 --- a/hpgsql-simple-compat/src/Database/PostgreSQL/Simple/FromField.hs +++ b/hpgsql-simple-compat/src/Database/PostgreSQL/Simple/FromField.hs @@ -177,13 +177,9 @@ class FromField a where let dec = Hpgsql.fieldDecoder in \f -> if Hpgsql.allowedPgTypes dec f - 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] + then \mbs -> Conversion $ \_encCtx -> case Hpgsql.fieldValueDecoder dec f mbs 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 cf42a1d..8b22f5c 100644 --- a/hpgsql-simple-compat/src/Database/PostgreSQL/Simple/HpgsqlUtils.hs +++ b/hpgsql-simple-compat/src/Database/PostgreSQL/Simple/HpgsqlUtils.hs @@ -95,29 +95,19 @@ type FieldParser a = Field -> Maybe ByteString -> Conversion a toHpgsqlFieldDecoder :: FieldParser a -> FieldDecoder a toHpgsqlFieldDecoder fp = FieldDecoder - { fieldValueDecoder = \colInfo bs -> - let valConv = fp colInfo (Just bs) + { fieldValueDecoder = \colInfo mbs -> + let valConv = fp colInfo mbs 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 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] + case dec.fieldValueDecoder f mbs of + Right v -> Ok v + Left err -> Errors [toException $ userError $ show err] -- | Given a Hpgsql query, returns the text format with question marks -- for query arguments and a row object. With both, you can call diff --git a/hpgsql/src/Hpgsql/Encoding/Internal.hs b/hpgsql/src/Hpgsql/Encoding/Internal.hs index 05637cf..c65ac8f 100644 --- a/hpgsql/src/Hpgsql/Encoding/Internal.hs +++ b/hpgsql/src/Hpgsql/Encoding/Internal.hs @@ -96,8 +96,7 @@ data FieldInfo = FieldInfo -- | A decoder for a single field/column. data FieldDecoder a = FieldDecoder - { fieldValueDecoder :: FieldInfo -> PinnedByteArray -> Either String a, - decodesSqlNullTo :: Either String a, + { fieldValueDecoder :: FieldInfo -> Maybe ByteString -> Either String a, allowedPgTypes :: FieldInfo -> Bool } deriving stock (Functor) @@ -113,7 +112,6 @@ 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 } @@ -137,12 +135,7 @@ instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in {-# INLINE singleField #-} singleField :: FieldDecoder a -> RowDecoder a singleField fdec = - -- This `case` is why we require `fieldAndValueDecoder` to decode - -- SQL NULL into `Nothing`: we do check decodesSqlNullTo. - let !valueForNull = case fdec.decodesSqlNullTo of - Left err -> fail err - Right v -> pure v - !typeCheck = fdec.allowedPgTypes + let !typeCheck = fdec.allowedPgTypes in RowDecoder { fullRowDecoder = \case [singleColInfo] -> @@ -152,10 +145,12 @@ singleField fdec = if lenNextCol >= 0 then do nextColBs <- Parser.take lenNextCol - case decode nextColBs of + case decode (Just (PBA.toByteString nextColBs)) of Right v -> pure v Left err -> fail err - else valueForNull + else case decode Nothing 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, typeCheck singleColInfo)] @@ -204,9 +199,9 @@ class FromPgField a where then pure Nothing else do bs <- Parser.take (fromIntegral len) - case fieldDecoder.fieldValueDecoder singleColInfo bs of + case fieldDecoder.fieldValueDecoder singleColInfo (Just (PBA.toByteString bs)) of Left err -> fail err - Right v -> pure v + Right v -> pure (Just v) -- | Semantically equivalent to `singleField fieldDecoder`, but for -- most types it can provide a much faster `RowDecoder`. This doesn't @@ -227,17 +222,18 @@ class FromPgField a where -- 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 + let !typeCheck = (fieldDecoder @a).allowedPgTypes in RowDecoder { fullRowDecoder = \case - [singleColInfo] -> do - mv <- notConstFieldDecoder singleColInfo - case mv of - Nothing -> valueForNull - Just v -> pure v + [singleColInfo] -> + let !valueForNull = case (fieldDecoder @a).fieldValueDecoder singleColInfo Nothing of + Left err -> fail err + Right v -> pure v + in 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)] @@ -249,16 +245,19 @@ class FromPgField a where -- 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 + let !typeCheck = (fieldDecoder @a).allowedPgTypes in RowDecoder - { fullRowDecoder = const $ do - mv <- p - case mv of - Nothing -> valueForNull - Just v -> pure v, + { fullRowDecoder = \case + [singleColInfo] -> + let !valueForNull = case (fieldDecoder @a).fieldValueDecoder singleColInfo Nothing of + Left err -> fail err + Right v -> pure v + in do + mv <- p + 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", @@ -286,11 +285,12 @@ compositeTypeDecoder (RowDecoder {..}) = FieldDecoder { fieldValueDecoder = \compositeTypeOid -> let !prs = parserForRecord compositeTypeOid.encodingContext <* Parser.endOfInput - in \bs -> - case Parser.parseOnly prs bs of - Parser.ParseOk v -> Right v - Parser.ParseFail err -> Left err, - decodesSqlNullTo = Left "Got NULL in composite type but it was not allowed", + in \case + Nothing -> Left "Got NULL in composite type but it was not allowed" + Just bs -> + case Parser.parseOnly prs (PBA.fromByteString bs) of + Parser.ParseOk v -> Right v + Parser.ParseFail err -> Left err, allowedPgTypes = const True -- There's no way to enforce a custom type's OID. We only check if it's structurally the same in the parser (same subtypes in same order) } where @@ -825,11 +825,10 @@ binaryFloat4Decoder = castWord32ToFloat . either error id . PBA.decodeWord32BE 0 binaryFloat8Decoder :: PinnedByteArray -> Double binaryFloat8Decoder = castWord64ToDouble . either error id . PBA.decodeWord64BE 0 -parsePgType :: String -> [Oid] -> (PinnedByteArray -> Either String a) -> FieldDecoder a -parsePgType !typeName !requiredTypeOids !fieldValueDecoder = +parsePgType :: String -> [Oid] -> (Maybe 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 } @@ -837,12 +836,13 @@ instance FromPgField () where {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder - { fieldValueDecoder = \_oid -> \bs -> - if PBA.length bs == 0 - then Right () - else - Left $ "Invalid value for postgres void type", - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell () type. Use a `Maybe ()`", + { fieldValueDecoder = \_oid -> \case + Nothing -> Left "Cannot decode SQL null as the Haskell () type. Use a `Maybe ()`" + Just bs -> + if BS.length bs == 0 + then Right () + else + Left "Invalid value for postgres void type", allowedPgTypes = (== voidOid) . fieldTypeOid } @@ -852,8 +852,9 @@ instance FromPgField Int where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> let !decode = binaryIntDecoder oid - in \bs -> decode bs, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int type. Use a `Maybe Int`", + in \case + Nothing -> Left "Cannot decode SQL null as the Haskell Int type. Use a `Maybe Int`" + Just bs -> decode (PBA.fromByteString bs), allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid } @@ -873,10 +874,11 @@ instance FromPgField Int16 where {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder - { fieldValueDecoder = + { fieldValueDecoder = \_ -> let !decode = binaryIntDecoder int2Oid - in const decode, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int16 type. Use a `Maybe Int16`", + in \case + Nothing -> Left "Cannot decode SQL null as the Haskell Int16 type. Use a `Maybe Int16`" + Just bs -> decode (PBA.fromByteString bs), allowedPgTypes = (== int2Oid) . fieldTypeOid } @@ -884,8 +886,11 @@ instance FromPgField Int32 where {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder - { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> binaryIntDecoder oid, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int32 type. Use a `Maybe Int32`", + { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> + let !decode = binaryIntDecoder oid + in \case + Nothing -> Left "Cannot decode SQL null as the Haskell Int32 type. Use a `Maybe Int32`" + Just bs -> decode (PBA.fromByteString bs), allowedPgTypes = (`elem` [int2Oid, int4Oid]) . fieldTypeOid } {-# INLINE inlinedConstFieldDecoder #-} @@ -901,8 +906,11 @@ instance FromPgField Int64 where {-# INLINE fieldDecoder #-} fieldDecoder = FieldDecoder - { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> binaryIntDecoder oid, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Int64 type. Use a `Maybe Int64`", + { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> + let !decode = binaryIntDecoder oid + in \case + Nothing -> Left "Cannot decode SQL null as the Haskell Int64 type. Use a `Maybe Int64`" + Just bs -> decode (PBA.fromByteString bs), allowedPgTypes = (`elem` [int2Oid, int4Oid, int8Oid]) . fieldTypeOid } {-# INLINE inlinedConstFieldDecoder #-} @@ -921,14 +929,17 @@ instance FromPgField Integer where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> let !decodeInt = binaryIntDecoder @Int64 oid - in if oid /= numericOid - then fmap fromIntegral <$> decodeInt - else \bs -> case Parser.parseOnly (scientificDecoder True <* Parser.endOfInput) bs of - Parser.ParseOk sci -> case floatingOrInteger @Double @Integer sci of - Right i -> Right i - Left _ -> Left "Internal error in Hpgsql. Scientific to Integer conversion failed" - Parser.ParseFail err -> Left err, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Integer type. Use a `Maybe Integer`", + in \case + Nothing -> Left "Cannot decode SQL null as the Haskell Integer type. Use a `Maybe Integer`" + Just bs -> + let !pbaBs = PBA.fromByteString bs + in if oid /= numericOid + then fromIntegral <$> decodeInt pbaBs + else case Parser.parseOnly (scientificDecoder True <* Parser.endOfInput) pbaBs 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, allowedPgTypes = (`elem` [int8Oid, numericOid, int4Oid, int2Oid]) . fieldTypeOid } @@ -937,15 +948,17 @@ instance FromPgField Oid where fieldDecoder = FieldDecoder { fieldValueDecoder = \_ -> \case + Nothing -> Left "Cannot decode SQL null as the Haskell Oid type. Use a `Maybe Oid`" -- Oids are just int4 - bs -> Oid <$> binaryIntDecoder int4Oid bs, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Oid type. Use a `Maybe Oid`", + Just bs -> Oid <$> binaryIntDecoder int4Oid (PBA.fromByteString bs), allowedPgTypes = (== oidOid) . fieldTypeOid } instance FromPgField Float where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Float" [float4Oid] $ Right . binaryFloat4Decoder + fieldDecoder = parsePgType "Float" [float4Oid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell Float type. Use a `Maybe Float`" + Just bs -> Right $ binaryFloat4Decoder (PBA.fromByteString bs) {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just Parser.takeFloatBEWithFieldLength @@ -967,8 +980,9 @@ instance FromPgField Double where let decoder | oid == float8Oid = binaryFloat8Decoder | otherwise = float2Double . binaryFloat4Decoder - in Right . decoder, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`", + in \case + Nothing -> Left "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`" + Just bs -> Right $ decoder (PBA.fromByteString bs), allowedPgTypes = (`elem` [float8Oid, float4Oid]) . fieldTypeOid } @@ -1030,18 +1044,18 @@ instance FromPgField Scientific where fieldDecoder = FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - if fieldTypeOid /= numericOid - then - let intdec = binaryIntDecoder @Int64 fieldTypeOid - in \bs -> flip scientific 0 . fromIntegral <$> intdec bs - else \case - bs -> - -- TODO: There is loss converting from Float/Double to Scientific, but it might be quite small, so should we accept - -- float4Oid and float8Oid here? - case Parser.parseOnly (scientificDecoder False <* Parser.endOfInput) bs of - Parser.ParseOk sci -> Right sci - Parser.ParseFail err -> Left err, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`", + \case + Nothing -> Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`" + Just bs -> + let !pbaBs = PBA.fromByteString bs + in if fieldTypeOid /= numericOid + then let intdec = binaryIntDecoder @Int64 fieldTypeOid in flip scientific 0 . fromIntegral <$> intdec pbaBs + else + -- 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) pbaBs of + Parser.ParseOk sci -> Right sci + Parser.ParseFail err -> Left err, allowedPgTypes = (`elem` [numericOid, int2Oid, int4Oid, int8Oid]) . fieldTypeOid } {-# INLINE notConstFieldDecoder #-} @@ -1065,7 +1079,9 @@ boolRowDecoder = fmap (== 1) <$> Parser.parsePgFieldWithAtMost4Bytes PBA.TypeSiz instance FromPgField Bool where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Bool" [boolOid] $ \bs -> Right $ bs == binaryTrue + fieldDecoder = parsePgType "Bool" [boolOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell Bool type. Use a `Maybe Bool`" + Just bs -> Right $ PBA.fromByteString bs == binaryTrue {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just boolRowDecoder @@ -1077,24 +1093,29 @@ instance FromPgField Char where in FieldDecoder { fieldValueDecoder = \colInfo@FieldInfo {fieldTypeOid = oid} -> let !decodeText = textParser colInfo - in \bs -> - if oid == charOid - then Right $ BSC.head $ PBA.toByteString bs - else case decodeText bs of - Left err -> Left err - Right t -> if Text.length t > 1 then Left "Cannot parse text with more than one character into a Haskell Char type." else Right (Text.head t), - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Char type. Use a `Maybe Char`", + in \case + Nothing -> Left "Cannot decode SQL null as the Haskell Char type. Use a `Maybe Char`" + Just bs -> + if oid == charOid + then Right $ BSC.head bs + else case decodeText (Just 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), -- TODO: All the varchar types? allowedPgTypes = (`elem` [charOid, textOid]) . fieldTypeOid } instance FromPgField ByteString where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "byteString" [byteaOid] (Right . PBA.toByteString) + fieldDecoder = parsePgType "byteString" [byteaOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell byteString type. Use a `Maybe byteString`" + Just bs -> Right bs instance FromPgField LBS.ByteString where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "ByteString" [byteaOid] $ (Right . LBS.fromStrict . PBA.toByteString) + fieldDecoder = parsePgType "ByteString" [byteaOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell ByteString type. Use a `Maybe ByteString`" + Just bs -> Right $ LBS.fromStrict bs {-# INLINE textDecoder #-} textDecoder :: Parser.Parser (Maybe Text) @@ -1106,18 +1127,24 @@ textDecoder = do instance FromPgField Text where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> PBA.unsafeToUtf8Text 0 (PBA.length bs) bs + fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell Text type. Use a `Maybe Text`" + Just bs -> PBA.unsafeToUtf8Text 0 (BS.length bs) (PBA.fromByteString bs) {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just textDecoder instance FromPgField LT.Text where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \bs -> LT.fromStrict <$> PBA.unsafeToUtf8Text 0 (PBA.length bs) bs + fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell Text type. Use a `Maybe Text`" + Just bs -> LT.fromStrict <$> PBA.unsafeToUtf8Text 0 (BS.length bs) (PBA.fromByteString bs) instance FromPgField String where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "String" [textOid, varcharOid, nameOid] $ \bs -> Text.unpack <$> PBA.unsafeToUtf8Text 0 (PBA.length bs) bs + fieldDecoder = parsePgType "String" [textOid, varcharOid, nameOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell String type. Use a `Maybe String`" + Just bs -> Text.unpack <$> PBA.unsafeToUtf8Text 0 (BS.length bs) (PBA.fromByteString bs) -- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default -- connection option). @@ -1152,9 +1179,10 @@ utcTimeRowDecoder = do instance FromPgField UTCTime where {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "UTCTime" [timestamptzOid] $ \case - bs -> do + Nothing -> Left "Cannot decode SQL null as the Haskell UTCTime type. Use a `Maybe UTCTime`" + Just bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- PBA.decodeInt64BE 0 bs + totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString 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) @@ -1165,9 +1193,10 @@ instance FromPgField UTCTime where instance FromPgField (Unbounded UTCTime) where {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Unbounded UTCTime" [timestamptzOid] $ \case - bs -> do + Nothing -> Left "Cannot decode SQL null as the Haskell Unbounded UTCTime type. Use a `Maybe (Unbounded UTCTime)`" + Just bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- PBA.decodeInt64BE 0 bs + totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString bs) Right $ if totalusecs == minBound then NegInfinity @@ -1182,9 +1211,10 @@ instance FromPgField (Unbounded UTCTime) where instance FromPgField ZonedTime where {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "ZonedTime" [timestamptzOid] $ \case - bs -> do + Nothing -> Left "Cannot decode SQL null as the Haskell ZonedTime type. Use a `Maybe ZonedTime`" + Just bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- PBA.decodeInt64BE 0 bs + totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString 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) @@ -1192,9 +1222,10 @@ instance FromPgField ZonedTime where instance FromPgField (Unbounded ZonedTime) where {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Unbounded ZonedTime" [timestamptzOid] $ \case - bs -> do + Nothing -> Left "Cannot decode SQL null as the Haskell Unbounded ZonedTime type. Use a `Maybe (Unbounded ZonedTime)`" + Just bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- PBA.decodeInt64BE 0 bs + totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString bs) Right $ if totalusecs == minBound then NegInfinity @@ -1209,8 +1240,9 @@ instance FromPgField (Unbounded ZonedTime) where instance FromPgField LocalTime where {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "LocalTime" [timestampOid] $ \case - bs -> do - totalusecs <- PBA.decodeInt64BE 0 bs + Nothing -> Left "Cannot decode SQL null as the Haskell LocalTime type. Use a `Maybe LocalTime`" + Just bs -> do + totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString 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) @@ -1218,8 +1250,9 @@ instance FromPgField LocalTime where instance FromPgField TimeOfDay where {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "TimeOfDay" [timeOid] $ \case - bs -> do - usecs <- PBA.decodeInt64BE 0 bs + Nothing -> Left "Cannot decode SQL null as the Haskell TimeOfDay type. Use a `Maybe TimeOfDay`" + Just bs -> do + usecs <- PBA.decodeInt64BE 0 (PBA.fromByteString bs) Right $ timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral usecs * 1_000_000 {-# INLINE dayRowDecoder #-} @@ -1231,11 +1264,12 @@ dayRowDecoder = instance FromPgField Day where {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Day" [dateOid] $ \case - bs -> do + Nothing -> Left "Cannot decode SQL null as the Haskell Day type. Use a `Maybe Day`" + Just bs -> do -- There is a very specific conversion function for these, which I poorly translated to Haskell -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 -- But I found a simpler way to do this. Let's see if it works in our property based tests - jd <- PBA.decodeInt32BE 0 bs + jd <- PBA.decodeInt32BE 0 (PBA.fromByteString bs) Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 {-# INLINE inlinedConstFieldDecoder #-} @@ -1244,11 +1278,12 @@ instance FromPgField Day where instance FromPgField (Unbounded Day) where {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "Unbounded Day" [dateOid] $ \case - bs -> do + Nothing -> Left "Cannot decode SQL null as the Haskell Unbounded Day type. Use a `Maybe (Unbounded Day)`" + Just bs -> do -- There is a very specific conversion function for these, which I poorly translated to Haskell -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 -- But I found a simpler way to do this. Let's see if it works in our property based tests - jd <- PBA.decodeInt32BE 0 bs + jd <- PBA.decodeInt32BE 0 (PBA.fromByteString bs) Right $ if jd == minBound then NegInfinity @@ -1260,16 +1295,20 @@ instance FromPgField (Unbounded Day) where instance FromPgField CalendarDiffTime where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "CalendarDiffTime " [intervalOid] $ \bs -> do - nMicrosecs <- PBA.decodeInt64BE 0 bs - nDays <- PBA.decodeInt32BE 8 bs - nMonths <- PBA.decodeInt32BE 12 bs - Right $ CalendarDiffTime {ctMonths = fromIntegral nMonths, ctTime = secondsToNominalDiffTime (fromIntegral nDays * 86400) + realToFrac (picosecondsToDiffTime (fromIntegral nMicrosecs * 1_000_000))} + fieldDecoder = parsePgType "CalendarDiffTime " [intervalOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell CalendarDiffTime type. Use a `Maybe CalendarDiffTime `" + Just bs -> do + let !pbaBs = PBA.fromByteString bs + nMicrosecs <- PBA.decodeInt64BE 0 pbaBs + nDays <- PBA.decodeInt32BE 8 pbaBs + nMonths <- PBA.decodeInt32BE 12 pbaBs + Right $ CalendarDiffTime {ctMonths = fromIntegral nMonths, ctTime = secondsToNominalDiffTime (fromIntegral nDays * 86400) + realToFrac (picosecondsToDiffTime (fromIntegral nMicrosecs * 1_000_000))} instance FromPgField UUID where {-# INLINE fieldDecoder #-} fieldDecoder = parsePgType "UUID" [uuidOid] $ \case - bs -> case UUID.fromByteString (LBS.fromStrict $ PBA.toByteString bs) of + Nothing -> Left "Cannot decode SQL null as the Haskell UUID type. Use a `Maybe UUID`" + Just bs -> case UUID.fromByteString (LBS.fromStrict bs) of Just uuid -> Right uuid Nothing -> Left "Bug in Hpgsql: UUID field could not be decoded" @@ -1284,10 +1323,10 @@ instance FromPgField Aeson.Value where !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id in \case - bs -> case Aeson.decodeStrict $ fixJsonb (PBA.toByteString bs) of + Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls" + Just bs -> case Aeson.decodeStrict $ fixJsonb bs of Just d -> Right d Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", - 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 } @@ -1298,8 +1337,9 @@ nullableField FieldDecoder {..} = FieldDecoder { fieldValueDecoder = \oid -> let origFieldValueParser = fieldValueDecoder oid - in \bs -> Just <$> origFieldValueParser bs, - decodesSqlNullTo = Right Nothing, + in \case + Nothing -> Right Nothing + Just bs -> Just <$> origFieldValueParser (Just bs), allowedPgTypes } @@ -1346,10 +1386,11 @@ instance {-# OVERLAPPING #-} forall a. (FromPgField a) => FromPgField (Vector (V FieldDecoder { fieldValueDecoder = \colInfo -> let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput - in \bs -> case Parser.parseOnly arrayFieldDecoder bs of - Parser.ParseOk v -> Right v - Parser.ParseFail err -> Left err, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell (Vector (Vector a)) type. Use a `Maybe (Vector (Vector a))`", + in \case + Nothing -> Left "Cannot decode SQL null as the Haskell (Vector (Vector a)) type. Use a `Maybe (Vector (Vector a))`" + Just bs -> case Parser.parseOnly arrayFieldDecoder (PBA.fromByteString bs) of + Parser.ParseOk v -> Right v + Parser.ParseFail err -> Left err, allowedPgTypes = allowOnlyArrayTypes } where @@ -1376,12 +1417,12 @@ instance {-# OVERLAPPING #-} forall a. (FromPgField a) => FromPgField (Vector (V do size :: Int <- fromIntegral <$> Parser.takeInt32BE if size == (-1) - then case elementParser.decodesSqlNullTo of + then case elementParser.fieldValueDecoder elementColInfo Nothing of Left err -> fail err Right v -> pure v else do elementBs <- Parser.take size - case elementParser.fieldValueDecoder elementColInfo elementBs of + case elementParser.fieldValueDecoder elementColInfo (Just (PBA.toByteString elementBs)) of Left err -> fail $ "Error parsing array element: " ++ show err Right el -> pure el @@ -1516,8 +1557,8 @@ rawBytesFieldDecoder :: FieldDecoder ByteString rawBytesFieldDecoder = FieldDecoder { fieldValueDecoder = \_oid -> \case - bs -> Right $ PBA.toByteString bs, - decodesSqlNullTo = Left "Cannot decode SQL null as the `rawBytesFieldDecoder`.", + Nothing -> Left "Cannot decode SQL null as the `rawBytesFieldDecoder`." + Just bs -> Right bs, allowedPgTypes = const True } @@ -1546,10 +1587,11 @@ arrayField !replicateFunction !elementParser = FieldDecoder { fieldValueDecoder = \colInfo -> let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput - in \bs -> case Parser.parseOnly arrayFieldDecoder bs of - Parser.ParseOk v -> Right v - Parser.ParseFail err -> Left err, - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell Vector type. Use a `Maybe (Vector a)`", + in \case + Nothing -> Left "Cannot decode SQL null as the Haskell Vector type. Use a `Maybe (Vector a)`" + Just bs -> case Parser.parseOnly arrayFieldDecoder (PBA.fromByteString bs) of + Parser.ParseOk v -> Right v + Parser.ParseFail err -> Left err, allowedPgTypes = allowOnlyArrayTypes } where @@ -1569,11 +1611,11 @@ arrayField !replicateFunction !elementParser = replicateFunction dim_i $ do size :: Int <- fromIntegral <$> Parser.takeInt32BE if size == (-1) - then case elementParser.decodesSqlNullTo of + then case elementParser.fieldValueDecoder elementColInfo Nothing of Left err -> fail err Right v -> pure v else do elementBs <- Parser.take size - case elementParser.fieldValueDecoder elementColInfo elementBs of + case elementParser.fieldValueDecoder elementColInfo (Just (PBA.toByteString elementBs)) of Left err -> fail $ "Error parsing array element: " ++ show err Right el -> pure el diff --git a/hpgsql/src/Hpgsql/PinnedByteArray.hs b/hpgsql/src/Hpgsql/PinnedByteArray.hs index 5742823..8f6bbf5 100644 --- a/hpgsql/src/Hpgsql/PinnedByteArray.hs +++ b/hpgsql/src/Hpgsql/PinnedByteArray.hs @@ -72,18 +72,16 @@ import Data.ByteString.Internal (ByteString (..)) import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Internal as InternalBS import Data.Int (Int16, Int32, Int64) -import Foreign (withForeignPtr) import Foreign.C (CInt (..)) import Foreign.Marshal.Utils (copyBytes) import Foreign.Ptr (plusPtr) import GHC.Base (Addr#, ByteArray#, Char (..), IO (..), Int (..), MutableByteArray#, RealWorld, byteArrayContents#, compareByteArrays#, indexWord8ArrayAsChar#, indexWord8ArrayAsWord32#, mutableByteArrayContents#, newPinnedByteArray#, unIO, unsafeFreezeByteArray#, (+#)) import GHC.Exts (indexWord8Array#, indexWord8ArrayAsWord16#, indexWord8ArrayAsWord64#) import GHC.Ptr (Ptr (..)) -import GHC.Word (Word32 (..)) import System.IO.Unsafe (unsafeDupablePerformIO) import Prelude hiding (drop, encodeFloat, length, null, splitAt, take) #if WORDS_BIGENDIAN -import Data.Word (Word16, Word32, Word64) +import Data.Word (Word16, Word64) #else import Data.Word (Word16, Word64, byteSwap16, byteSwap64, Word8, byteSwap32) #endif @@ -91,9 +89,9 @@ import Data.Array.Byte (ByteArray (..)) import Data.Bits (Bits (unsafeShiftR)) import Data.Coerce (coerce) import Data.Text.Internal (Text (..)) -import Foreign (Storable (..), (.&.)) +import Foreign (Storable (..), withForeignPtr, (.&.)) import GHC.Float (castDoubleToWord64, castFloatToWord32) -import GHC.Word (Word16 (..), Word64 (..), Word8 (..)) +import GHC.Word (Word16 (..), Word32 (..), Word64 (..), Word8 (..)) data PinnedByteArray = PinnedByteArray { start :: !Int, @@ -124,7 +122,7 @@ emptyPBA = unsafeDupablePerformIO $ createPinnedByteArray 0 (\_ -> pure 0) createPinnedByteArray :: Int -> (Addr# -> IO CInt) -> IO PinnedByteArray createPinnedByteArray (I# size#) f = IO $ \s0 -> - let !(# newRW, (mutArr# :: MutableByteArray# RealWorld) #) = newPinnedByteArray# size# s0 + let !(# newRW, mutArr# :: MutableByteArray# RealWorld #) = newPinnedByteArray# size# s0 !(# newRW', lenCopied #) = unIO (f (mutableByteArrayContents# mutArr#)) newRW !(# finalRW, frozenArr# #) = unsafeFreezeByteArray# mutArr# newRW' in (# finalRW, PinnedByteArray 0 (fromIntegral lenCopied) frozenArr# #) @@ -143,7 +141,7 @@ toByteString (PinnedByteArray start len src) = unsafeDupablePerformIO $ BS.creat -- | Assuming the pinned byte array contains valid UTF8 text, creates -- returns an instance of `Text` with the same contents (but does make a copy). unsafeToUtf8Text :: ByteStringIdx -> Int -> PinnedByteArray -> Either String Text -unsafeToUtf8Text idx desiredLen pba@(PinnedByteArray _ _ _) = let !(PinnedByteArray start arrLen arr#) = toStrictN idx.idx desiredLen (fromStrict pba) in if arrLen /= desiredLen then Left "Insufficient bytes in buffer in unsafeToUtf8Text" else Right $ Text (ByteArray arr#) start arrLen +unsafeToUtf8Text idx desiredLen pba@(PinnedByteArray {}) = let !(PinnedByteArray start arrLen arr#) = toStrictN idx.idx desiredLen (fromStrict pba) in if arrLen /= desiredLen then Left "Insufficient bytes in buffer in unsafeToUtf8Text" else Right $ Text (ByteArray arr#) start arrLen takePgMessageIdentAndLen :: LazyPinnedByteArray -> Maybe (Char, Int32) takePgMessageIdentAndLen lpba@(LazyPinnedByteArray len _) = diff --git a/hpgsql/src/Hpgsql/Types.hs b/hpgsql/src/Hpgsql/Types.hs index 728f24b..077685b 100644 --- a/hpgsql/src/Hpgsql/Types.hs +++ b/hpgsql/src/Hpgsql/Types.hs @@ -95,8 +95,9 @@ 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 - \bs -> Right $ PgJson $ fixJsonb (PBA.toByteString bs), - decodesSqlNullTo = Left "Cannot decode SQL null as the Haskell PgJson type. Use a `Maybe PgJson` if you want SQL nulls", + \case + Nothing -> Left "Cannot decode SQL null as the Haskell PgJson type. Use a `Maybe PgJson` if you want SQL nulls" + Just bs -> Right $ PgJson $ fixJsonb bs, allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } {-# INLINE notConstFieldDecoder #-} @@ -127,10 +128,11 @@ 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 - \bs -> case Aeson.decodeStrict $ fixJsonb (PBA.toByteString bs) of - Just v -> Right $ Aeson v - Nothing -> Left "Failed to decode the postgres JSON value into your `Aeson a` type with aeson", - decodesSqlNullTo = Left "Cannot decode SQL null as a Haskell (Aeson a) type. Use a `Maybe (Aeson a)` if you want SQL nulls", + \case + Nothing -> Left "Cannot decode SQL null as a Haskell (Aeson a) type. Use a `Maybe (Aeson a)` if you want SQL nulls" + Just 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", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } {-# INLINE notConstFieldDecoder #-} From a4d67792f141094016fd59fa0bf7a1b8f7415f82 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 12 Sep 2026 16:57:23 -0300 Subject: [PATCH 15/38] Rewrite rules to transform `singleField fieldDecoder` to `notInlinedSingleFieldRowDecoder` --- BENCHMARKS.md | 34 ++- TODO.md | 5 +- hpgsql-benchmarks/src/Main.hs | 2 +- hpgsql/src/Hpgsql/Encoding.hs | 11 +- hpgsql/src/Hpgsql/Encoding/Internal.hs | 222 +++++++++++------- .../src/Hpgsql/Encoding/RowDecoderMonadic.hs | 2 +- hpgsql/src/Hpgsql/Internal.hs | 2 +- 7 files changed, 163 insertions(+), 115 deletions(-) diff --git a/BENCHMARKS.md b/BENCHMARKS.md index 974b4ed..feff5bb 100644 --- a/BENCHMARKS.md +++ b/BENCHMARKS.md @@ -49,12 +49,11 @@ This benchmark is unfair towards both hpgsql and postgresql-simple (compared to | name | wall_clock_time | peak_live_rts_memory | peak_memory_upper_bound | total_managed_memory_allocated | |---|---|---|---|---| -| postgresql-simple Record List (100000 rows, Generically derived row decoder) | 14.65s | 142.6MB | 311.3MB | 49596.0MB | -| hasql Record List (100000 rows) | 8.574s | 99.3MB | 285.6MB | 14422.7MB | -| *hpgsql Record List (100000 rows, Generically derived row decoder)* | 3.504s | 112.2MB | 112.2MB | 9612.7MB | -| *hpgsql Record List (100000 rows, fully inlined row decoder)* | 3.034s | 112.9MB | 112.9MB | 6420.4MB | -| Npgsql Record List (100000 rows) | 1.015s | - | - | 481.6MB | -| rust-tokio-postgres Record List (100000 rows) | 981.7ms | - | 50.2MB | - | +| postgresql-simple Record List (100000 rows, Generically derived row decoder) | 14.72s | 146.3MB | 315.1MB | 49595.9MB | +| hasql Record List (100000 rows) | 8.450s | 99.2MB | 285.5MB | 14422.7MB | +| *hpgsql Record List (100000 rows, Generically derived row decoder)* | 4.033s | 140.4MB | 140.4MB | 14966.0MB | +| Npgsql Record List (100000 rows) | 1.050s | - | - | 481.7MB | +| rust-tokio-postgres Record List (100000 rows) | 950.2ms | - | 50.2MB | - | ### Materializing 100_000 rows with 13 columns each into a List of Tuples @@ -62,9 +61,9 @@ This runs with 2 concurrent queries, 10 times over: | name | wall_clock_time | peak_live_rts_memory | peak_memory_upper_bound | total_managed_memory_allocated | |---|---|---|---|---| -| postgresql-simple Tuple List (100000 rows) | 14.18s | 148.3MB | 218.7MB | 43243.4MB | -| hasql Tuple List (100000 rows) | 7.824s | 202.6MB | 343.4MB | 9841.6MB | -| *hpgsql Tuple List (100000 rows)* | 3.365s | 147.9MB | 147.9MB | 7312.0MB | +| postgresql-simple Tuple List (100000 rows) | 14.07s | 148.5MB | 218.9MB | 43243.5MB | +| hasql Tuple List (100000 rows) | 7.802s | 201.7MB | 342.5MB | 9841.6MB | +| *hpgsql Tuple List (100000 rows)* | 3.969s | 151.8MB | 151.8MB | 9985.4MB | ### Streaming 100_000 rows with 17 columns as Records @@ -76,12 +75,11 @@ cursors simultaneously, but not hpgsql's Streamed-from-socket streams). | name | wall_clock_time | peak_live_rts_memory | peak_memory_upper_bound | total_managed_memory_allocated | |---|---|---|---|---| -| streaming-postgresql-simple Record Stream (100000 rows, Generically derived row decoder) | 16.17s | 0.0MB | 1.0MB | 62278.5MB | -| *hpgsql Record Stream (100000 rows, Generically derived row decoder)* | 1.108s | 0.3MB | 0.3MB | 9088.9MB | -| Npgsql Record Stream (100000 rows) | 992.5ms | - | - | 441.4MB | -| *hpgsql Record Stream (100000 rows, fully inlined row decoder)* | 967.0ms | 0.2MB | 0.2MB | 6112.3MB | -| rust-tokio-postgres Record Stream (100000 rows) | 894.1ms | - | 0.4MB | - | -| postgresql-simple Record fold (100000 rows, Generically derived row decoder) | | 0.0MB | 0.0MB | - | +| postgresql-simple Record fold (100000 rows, Generically derived row decoder) | 16.20s | 0.0MB | 34.3MB | 48921.4MB | +| streaming-postgresql-simple Record Stream (100000 rows, Generically derived row decoder) | 16.13s | 0.0MB | 1.2MB | 62278.5MB | +| *hpgsql Record Stream (100000 rows, Generically derived row decoder)* | 1.592s | 0.3MB | 0.3MB | 14318.5MB | +| Npgsql Record Stream (100000 rows) | 1.034s | - | - | 441.9MB | +| rust-tokio-postgres Record Stream (100000 rows) | 876.1ms | - | 0.4MB | - | ### Streaming 100_000 rows with 13 columns as Tuples @@ -93,9 +91,9 @@ cursors simultaneously, but not hpgsql's Streamed-from-socket streams). | name | wall_clock_time | peak_live_rts_memory | peak_memory_upper_bound | total_managed_memory_allocated | |---|---|---|---|---| -| streaming-postgresql-simple Tuple Stream (100000 rows) | 13.26s | 0.0MB | 1.3MB | 55905.7MB | -| postgresql-simple Tuple fold (100000 rows) | 12.94s | 0.0MB | 10.6MB | 42538.1MB | -| *hpgsql Tuple Stream (100000 rows)* | 768.3ms | 0.2MB | 0.2MB | 6479.9MB | +| streaming-postgresql-simple Tuple Stream (100000 rows) | 13.23s | 0.0MB | 1.3MB | 55905.7MB | +| postgresql-simple Tuple fold (100000 rows) | 12.95s | 0.0MB | 12.3MB | 42538.1MB | +| *hpgsql Tuple Stream (100000 rows)* | 774.3ms | 0.3MB | 0.3MB | 8270.3MB | ### COPY FROM STDIN diff --git a/TODO.md b/TODO.md index 68027de..1ece16a 100644 --- a/TODO.md +++ b/TODO.md @@ -1,11 +1,8 @@ -- Check that users can define their own types and create FromPgField instances that derive performant instances. Do they override the specialized methods? How do they do that? - - newtype-derived and simple `fmap`'d instances can, but instances that want to fail on some values cannot (no Monad instance for RowDecoder) and have to override the FieldDecoder. -- Expose a `PinnedByteArray` with `toByteString` to users, move current module to PinnedByteArray.Internal - Test both `singleField fieldDecoder` and `singleFieldRowDecoder` for every type in our tests. - Do _not_ expose new FromPgField methods. Add new EncodingInternal module, instead. - Check that the non-exposed methods are safe wrt bytearray bounds access by construction, and users can't break that. If that's true, we can omit bounds checks in our row decoding, making row decoders smaller and maybe faster. - Some types might still not derive specialized row decoders -- "Oh no! No colInfo here.. what do we do!?" in hpgsql-simple-compat. This might require a big rethinking of things.. + - And rewrite rules too are missing for many - Double-check which row encoders we want to use the inlined versions for and which we don't. Tuples? - Text internals usage.. is it safe? Double-check. - Expose in the FromPgField class two new methods.. inlined and non inlined row decoders with/without bounds checks. Use with-bounds-checks for MonadicRowDecoder, and without-bounds-checks for regular row decoder, because the latter checks type oids diff --git a/hpgsql-benchmarks/src/Main.hs b/hpgsql-benchmarks/src/Main.hs index 0d24c3d..414f639 100644 --- a/hpgsql-benchmarks/src/Main.hs +++ b/hpgsql-benchmarks/src/Main.hs @@ -47,7 +47,7 @@ import Hpgsql.Connection (renderLibpqConnectionString) import qualified Hpgsql.Connection import qualified Hpgsql.Connection as Hpgsql import qualified Hpgsql.Copy -import Hpgsql.Encoding (inlinedSingleFieldRowDecoder, notInlinedSingleFieldRowDecoder) +import Hpgsql.Encoding (inlinedSingleFieldRowDecoder) import qualified Hpgsql.Encoding as Hpgsql import qualified Hpgsql.Query as Hpgsql import qualified Hpgsql.Types as Hpgsql diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index cf4b978..98a2a20 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -20,8 +20,8 @@ -- -- = Performant row decoders -- --- Hpgsql provides roughly two* ways to derive row decoders from your types. --- You can use `notInlinedSingleFieldRowDecoder` or `inlinedSingleFieldRowDecoder` for each field. +-- Hpgsql provides two ways to derive row decoders from your types. +-- You can use `singleField fieldDecoder` or `inlinedSingleFieldRowDecoder` for each field. -- For example you can define: -- -- > data Car = Car { model :: Text, year :: Maybe Int, inGoodCondition :: Bool } @@ -40,15 +40,14 @@ -- -- Some notes: -- --- * Generically derived row decoders are not fully inlined, and perform as well as hand-written row decoders built with `notInlinedSingleFieldRowDecoder`. --- * Another derivation method is to use `singleField fieldDecoder`. That is the least performant way of deriving row decoders, and is only useful if you need the ability to compose `FieldDecoder`s in ways that you can't otherwise. If you can, use `notInlinedSingleFieldRowDecoder` instead. +-- * Generically derived row decoders are not fully inlined, and perform as well as hand-written row decoders built with `singleField fieldDecoder`. module Hpgsql.Encoding ( -- * Decoding - FromPgField (fieldDecoder, notInlinedSingleFieldRowDecoder, inlinedSingleFieldRowDecoder), -- Do not export other methods so we can change them + FromPgField (fieldDecoder, inlinedSingleFieldRowDecoder), -- Do not export other methods so we can change them FieldDecoder (..), FieldInfo (..), FromPgRow (..), - RowDecoder (..), -- TODO: Can we export ctor? + RowDecoder, -- Do not export ctor because we may want to change it singleField, nullableField, genericFromPgRow, diff --git a/hpgsql/src/Hpgsql/Encoding/Internal.hs b/hpgsql/src/Hpgsql/Encoding/Internal.hs index c65ac8f..5d809bc 100644 --- a/hpgsql/src/Hpgsql/Encoding/Internal.hs +++ b/hpgsql/src/Hpgsql/Encoding/Internal.hs @@ -1,4 +1,6 @@ +-- See Note [singleField fieldDecoder rewrite rules] {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-inline-rule-shadowing #-} module Hpgsql.Encoding.Internal ( -- * Decoding @@ -132,7 +134,40 @@ 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 #-} +-- Note [singleField fieldDecoder rewrite rules] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- There are strictly speaking three ways to derive a single-field/column +-- row decoder in hpgsql: `singleField fieldDecoder`, `notInlinedSingleFieldRowDecoder`, and +-- `inlinedSingleFieldRowDecoder`. +-- +-- The last two are sensible: one is more aggressive with inlining and produces faster row decoders +-- at the cost of compilation times and binary sizes, the other produces row decoders that call out +-- to functions when decoding each field, hence being smaller but slower. +-- +-- But what about the first? It forces the allocation of `ByteString` values from our Pinned Byte Arrays, +-- and is hence the slower of all three, except that it doesn't produce row decoders any smaller +-- than `notInlinedSingleFieldRowDecoder`. It is strictly worse than that. +-- +-- Since `singleField fieldDecoder` might be used by users of hpgsql, however, we can't just remove it. +-- So we introduce rewrite rules to rewrite those to `notInlinedSingleFieldRowDecoder` instead. +-- These rewrite rules require the implementations of each Field Decoder to be separated and not +-- inlinable, or else GHC inlines `fieldDecoder` too early and these rules don't fire. + +{-# RULES +"singleField intFieldDecoder" singleField intFieldDecoder = notInlinedSingleFieldRowDecoder +"singleField utcTimeFieldDecoder" singleField utcTimeFieldDecoder = notInlinedSingleFieldRowDecoder +"singleField floatFieldDecoder" singleField floatFieldDecoder = notInlinedSingleFieldRowDecoder +"singleField doubleFieldDecoder" singleField doubleFieldDecoder = notInlinedSingleFieldRowDecoder +"singleField boolFieldDecoder" singleField boolFieldDecoder = notInlinedSingleFieldRowDecoder +"singleField textFieldDecoder" singleField textFieldDecoder = notInlinedSingleFieldRowDecoder +"singleField dayFieldDecoder" singleField dayFieldDecoder = notInlinedSingleFieldRowDecoder +"singleField scientificFieldDecoder" singleField scientificFieldDecoder = notInlinedSingleFieldRowDecoder +-- This last rule is still useful and triggers at call sites where the type is not known at compile time +"singleField fieldDecoder" singleField fieldDecoder = notInlinedSingleFieldRowDecoder + #-} + +{-# INLINE [1] singleField #-} singleField :: FieldDecoder a -> RowDecoder a singleField fdec = let !typeCheck = fdec.allowedPgTypes @@ -162,12 +197,6 @@ 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. @@ -846,17 +875,21 @@ instance FromPgField () where allowedPgTypes = (== voidOid) . fieldTypeOid } +{-# NOINLINE intFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +intFieldDecoder :: FieldDecoder Int +intFieldDecoder = + FieldDecoder + { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> + let !decode = binaryIntDecoder oid + in \case + Nothing -> Left "Cannot decode SQL null as the Haskell Int type. Use a `Maybe Int`" + Just bs -> decode (PBA.fromByteString bs), + allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid + } + instance FromPgField Int where {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> - let !decode = binaryIntDecoder oid - in \case - Nothing -> Left "Cannot decode SQL null as the Haskell Int type. Use a `Maybe Int`" - Just bs -> decode (PBA.fromByteString bs), - allowedPgTypes = (`elem` haskellIntOids) . fieldTypeOid - } + fieldDecoder = intFieldDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just $ do @@ -954,11 +987,15 @@ instance FromPgField Oid where allowedPgTypes = (== oidOid) . fieldTypeOid } +{-# NOINLINE floatFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +floatFieldDecoder :: FieldDecoder Float +floatFieldDecoder = parsePgType "Float" [float4Oid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell Float type. Use a `Maybe Float`" + Just bs -> Right $ binaryFloat4Decoder (PBA.fromByteString bs) + instance FromPgField Float where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Float" [float4Oid] $ \case - Nothing -> Left "Cannot decode SQL null as the Haskell Float type. Use a `Maybe Float`" - Just bs -> Right $ binaryFloat4Decoder (PBA.fromByteString bs) + fieldDecoder = floatFieldDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just Parser.takeFloatBEWithFieldLength @@ -972,19 +1009,23 @@ doubleRowDecoder = do 4 -> Just . float2Double <$> Parser.takeFloatBE _ -> pure Nothing +{-# NOINLINE doubleFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +doubleFieldDecoder :: FieldDecoder Double +doubleFieldDecoder = + FieldDecoder + { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> + let decoder + | oid == float8Oid = binaryFloat8Decoder + | otherwise = float2Double . binaryFloat4Decoder + in \case + Nothing -> Left "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`" + Just bs -> Right $ decoder (PBA.fromByteString bs), + allowedPgTypes = (`elem` [float8Oid, float4Oid]) . fieldTypeOid + } + instance FromPgField Double where {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> - let decoder - | oid == float8Oid = binaryFloat8Decoder - | otherwise = float2Double . binaryFloat4Decoder - in \case - Nothing -> Left "Cannot decode SQL null as the Haskell Double type. Use a `Maybe Double`" - Just bs -> Right $ decoder (PBA.fromByteString bs), - allowedPgTypes = (`elem` [float8Oid, float4Oid]) . fieldTypeOid - } + fieldDecoder = doubleFieldDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just doubleRowDecoder @@ -1038,26 +1079,31 @@ numericRowParser = do (-1) -> pure Nothing _ -> Just <$> scientificDecoder False +{-# NOINLINE scientificFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +scientificFieldDecoder :: FieldDecoder Scientific +scientificFieldDecoder = + FieldDecoder + { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> + \case + Nothing -> Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`" + Just bs -> + let !pbaBs = PBA.fromByteString bs + in if fieldTypeOid /= numericOid + then let intdec = binaryIntDecoder @Int64 fieldTypeOid in flip scientific 0 . fromIntegral <$> intdec pbaBs + else + -- 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) pbaBs of + Parser.ParseOk sci -> Right sci + Parser.ParseFail err -> Left err, + allowedPgTypes = (`elem` [numericOid, int2Oid, int4Oid, int8Oid]) . fieldTypeOid + } + 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} -> - \case - Nothing -> Left "Cannot decode SQL null as the Haskell Scientific type. Use a `Maybe Scientific`" - Just bs -> - let !pbaBs = PBA.fromByteString bs - in if fieldTypeOid /= numericOid - then let intdec = binaryIntDecoder @Int64 fieldTypeOid in flip scientific 0 . fromIntegral <$> intdec pbaBs - else - -- 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) pbaBs of - Parser.ParseOk sci -> Right sci - Parser.ParseFail err -> Left err, - allowedPgTypes = (`elem` [numericOid, int2Oid, int4Oid, int8Oid]) . fieldTypeOid - } + fieldDecoder = scientificFieldDecoder + {-# INLINE notConstFieldDecoder #-} notConstFieldDecoder = let !int64RowDec = fromMaybe (error "Bug in HPgsql: Int64 does not have an inlinedConstFieldDecoder") $ inlinedConstFieldDecoder @Int64 @@ -1077,11 +1123,15 @@ binaryTrue = PBA.fromByteString $ PBA.encodePgBoolean True boolRowDecoder :: Parser.Parser (Maybe Bool) boolRowDecoder = fmap (== 1) <$> Parser.parsePgFieldWithAtMost4Bytes PBA.TypeSize1 +{-# NOINLINE boolFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +boolFieldDecoder :: FieldDecoder Bool +boolFieldDecoder = parsePgType "Bool" [boolOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell Bool type. Use a `Maybe Bool`" + Just bs -> Right $ PBA.fromByteString bs == binaryTrue + instance FromPgField Bool where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Bool" [boolOid] $ \case - Nothing -> Left "Cannot decode SQL null as the Haskell Bool type. Use a `Maybe Bool`" - Just bs -> Right $ PBA.fromByteString bs == binaryTrue + fieldDecoder = boolFieldDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just boolRowDecoder @@ -1125,11 +1175,15 @@ textDecoder = do then Just <$> Parser.takeUtf8Text (fromIntegral len) else pure Nothing +{-# NOINLINE textFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +textFieldDecoder :: FieldDecoder Text +textFieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell Text type. Use a `Maybe Text`" + Just bs -> PBA.unsafeToUtf8Text 0 (BS.length bs) (PBA.fromByteString bs) + instance FromPgField Text where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \case - Nothing -> Left "Cannot decode SQL null as the Haskell Text type. Use a `Maybe Text`" - Just bs -> PBA.unsafeToUtf8Text 0 (BS.length bs) (PBA.fromByteString bs) + fieldDecoder = textFieldDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just textDecoder @@ -1176,16 +1230,20 @@ utcTimeRowDecoder = do pure $ Just $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) _ -> pure Nothing +{-# NOINLINE utcTimeFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +utcTimeFieldDecoder :: FieldDecoder UTCTime +utcTimeFieldDecoder = parsePgType "UTCTime" [timestamptzOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell UTCTime type. Use a `Maybe UTCTime`" + Just bs -> do + -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 + totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString 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) + instance FromPgField UTCTime where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "UTCTime" [timestamptzOid] $ \case - Nothing -> Left "Cannot decode SQL null as the Haskell UTCTime type. Use a `Maybe UTCTime`" - Just bs -> do - -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString 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) + fieldDecoder = utcTimeFieldDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just utcTimeRowDecoder @@ -1261,16 +1319,20 @@ 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 +{-# NOINLINE dayFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +dayFieldDecoder :: FieldDecoder Day +dayFieldDecoder = parsePgType "Day" [dateOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell Day type. Use a `Maybe Day`" + Just bs -> do + -- There is a very specific conversion function for these, which I poorly translated to Haskell + -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 + -- But I found a simpler way to do this. Let's see if it works in our property based tests + jd <- PBA.decodeInt32BE 0 (PBA.fromByteString bs) + Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 + instance FromPgField Day where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Day" [dateOid] $ \case - Nothing -> Left "Cannot decode SQL null as the Haskell Day type. Use a `Maybe Day`" - Just bs -> do - -- There is a very specific conversion function for these, which I poorly translated to Haskell - -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 - -- But I found a simpler way to do this. Let's see if it works in our property based tests - jd <- PBA.decodeInt32BE 0 (PBA.fromByteString bs) - Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 + fieldDecoder = dayFieldDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just dayRowDecoder @@ -1318,15 +1380,13 @@ instance FromPgField Aeson.Value where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let - -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in - \case - Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls" - Just bs -> case Aeson.decodeStrict $ fixJsonb bs of - Just d -> Right d - Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", + let -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in \case + Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls" + Just bs -> case Aeson.decodeStrict $ fixJsonb bs of + Just d -> Right d + Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } @@ -1355,12 +1415,6 @@ instance (FromPgField a) => FromPgField (Maybe a) where 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 diff --git a/hpgsql/src/Hpgsql/Encoding/RowDecoderMonadic.hs b/hpgsql/src/Hpgsql/Encoding/RowDecoderMonadic.hs index a26cb28..60f730b 100644 --- a/hpgsql/src/Hpgsql/Encoding/RowDecoderMonadic.hs +++ b/hpgsql/src/Hpgsql/Encoding/RowDecoderMonadic.hs @@ -8,7 +8,7 @@ where import Control.Monad (unless) import Data.Bifunctor (first) import qualified Data.List as List -import Hpgsql.Encoding (FieldInfo, RowDecoder (..)) +import Hpgsql.Encoding.Internal (FieldInfo, RowDecoder (..)) import qualified Hpgsql.SimpleParser as Parser -- | Unlike @Hpgsql.Encoding.RowDecoder@, this has a @Monad@ instance. diff --git a/hpgsql/src/Hpgsql/Internal.hs b/hpgsql/src/Hpgsql/Internal.hs index ec0f9ee..cd6c5ec 100644 --- a/hpgsql/src/Hpgsql/Internal.hs +++ b/hpgsql/src/Hpgsql/Internal.hs @@ -134,7 +134,7 @@ import Data.Time (DiffTime, diffTimeToPicoseconds, secondsToDiffTime) import GHC.Conc (ThreadStatus (..), threadStatus) import Hpgsql.Base import qualified Hpgsql.Builder as Builder -import Hpgsql.Encoding (FieldInfo (..), FromPgRow (..), RowDecoder (..), RowEncoder (..), ToPgRow (..)) +import Hpgsql.Encoding.Internal (FieldInfo (..), FromPgRow (..), RowDecoder (..), RowEncoder (..), ToPgRow (..)) import Hpgsql.Encoding.RowDecoderMonadic (ConversionState (..), RowDecoderMonadic (..)) import Hpgsql.InternalTypes (BindComplete (..), CommandComplete (..), ConnectOpts (..), ConnectionString (..), CopyInResponse (..), CopyQueryState (..), DataRow (..), Either3 (..), EncodingContext (..), ErrorDetail (..), ErrorResponse (..), HPgConnection (..), InternalConnectionState (..), IrrecoverableHpgsqlError (..), NoData (..), NotificationResponse (..), ParseComplete (..), Pipeline (..), PostgresError (..), Query (..), QueryId (..), QueryProtocol (..), QueryState (..), ReadyForQuery (..), ResetConnectionOpts (..), ResponseMsg (..), ResponseMsgsReceived (..), RowDescription (..), SingleQuery (..), TransactionStatus (..), WeakThreadId (..), mkMutex, queryToByteString, throwIrrecoverableError) import Hpgsql.Locking (getMyWeakThreadId, withMutex) From 7a0c7e87233a90c187a81893395dfa7179889e1a Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 12 Sep 2026 17:43:56 -0300 Subject: [PATCH 16/38] Improve benchmarks for `Maybe a` instances The rewrite rules for these weren't really being tested be for `FromPgField (Maybe a)` instances, and this shows that clearly --- TODO.md | 1 + hpgsql-benchmarks/src/Main.hs | 8 ++++---- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/TODO.md b/TODO.md index 1ece16a..74ff2a4 100644 --- a/TODO.md +++ b/TODO.md @@ -1,3 +1,4 @@ +- Update Rust and C# benchmarks query to match - Test both `singleField fieldDecoder` and `singleFieldRowDecoder` for every type in our tests. - Do _not_ expose new FromPgField methods. Add new EncodingInternal module, instead. - Check that the non-exposed methods are safe wrt bytearray bounds access by construction, and users can't break that. If that's true, we can omit bounds checks in our row decoding, making row decoders smaller and maybe faster. diff --git a/hpgsql-benchmarks/src/Main.hs b/hpgsql-benchmarks/src/Main.hs index 414f639..ff20955 100644 --- a/hpgsql-benchmarks/src/Main.hs +++ b/hpgsql-benchmarks/src/Main.hs @@ -192,10 +192,10 @@ main = do statsBefore <- getRTSStats hspecWith defaultConfig {configFormat = Just (formatterToFormat silent)} $ do let n :: Int = 100_000 - 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" + 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, (CASE WHEN g%2=1 THEN NULL ELSE g::int4 END), (CASE WHEN g%2=1 THEN NULL ELSE '' END)::text, (CASE WHEN g%2=1 THEN NULL ELSE 0.0 END)::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, (CASE WHEN g%2=1 THEN NULL ELSE g::int4 END), (CASE WHEN g%2=1 THEN NULL ELSE '' END)::text, (CASE WHEN g%2=1 THEN NULL ELSE 0.0 END)::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, (CASE WHEN g%2=1 THEN NULL ELSE g END)::int4, (CASE WHEN g%2=1 THEN NULL ELSE '' END)::text, (CASE WHEN g%2=1 THEN NULL ELSE 0.0 END)::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, (CASE WHEN g%2=1 THEN NULL ELSE g END)::int4, (CASE WHEN g%2=1 THEN NULL ELSE '' END)::text, (CASE WHEN g%2=1 THEN NULL ELSE 0.0 END)::float8, NULL::date FROM generate_series(1,?) g" describe "Parsing 13-column rows into a List" $ do let hasqlListStmt = HasqlStmt.Statement From e8e4feec2138565d8c8cf1f546e2b347bd030250 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 12 Sep 2026 18:21:59 -0300 Subject: [PATCH 17/38] Add rewrite rules for many (Maybe a) decoders --- hpgsql/src/Hpgsql/Encoding/Internal.hs | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/hpgsql/src/Hpgsql/Encoding/Internal.hs b/hpgsql/src/Hpgsql/Encoding/Internal.hs index 5d809bc..ba6406d 100644 --- a/hpgsql/src/Hpgsql/Encoding/Internal.hs +++ b/hpgsql/src/Hpgsql/Encoding/Internal.hs @@ -156,15 +156,24 @@ instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in {-# RULES "singleField intFieldDecoder" singleField intFieldDecoder = notInlinedSingleFieldRowDecoder +"singleField (nullableField intFieldDecoder)" singleField (nullableField intFieldDecoder) = notInlinedSingleFieldRowDecoder "singleField utcTimeFieldDecoder" singleField utcTimeFieldDecoder = notInlinedSingleFieldRowDecoder +"singleField (nullableField utcTimeFieldDecoder)" singleField (nullableField utcTimeFieldDecoder) = notInlinedSingleFieldRowDecoder "singleField floatFieldDecoder" singleField floatFieldDecoder = notInlinedSingleFieldRowDecoder +"singleField (nullableField floatFieldDecoder)" singleField (nullableField floatFieldDecoder) = notInlinedSingleFieldRowDecoder "singleField doubleFieldDecoder" singleField doubleFieldDecoder = notInlinedSingleFieldRowDecoder +"singleField (nullableField doubleFieldDecoder)" singleField (nullableField doubleFieldDecoder) = notInlinedSingleFieldRowDecoder "singleField boolFieldDecoder" singleField boolFieldDecoder = notInlinedSingleFieldRowDecoder +"singleField (nullableField boolFieldDecoder)" singleField (nullableField boolFieldDecoder) = notInlinedSingleFieldRowDecoder "singleField textFieldDecoder" singleField textFieldDecoder = notInlinedSingleFieldRowDecoder +"singleField (nullableField textFieldDecoder)" singleField (nullableField textFieldDecoder) = notInlinedSingleFieldRowDecoder "singleField dayFieldDecoder" singleField dayFieldDecoder = notInlinedSingleFieldRowDecoder +"singleField (nullableField dayFieldDecoder)" singleField (nullableField dayFieldDecoder) = notInlinedSingleFieldRowDecoder "singleField scientificFieldDecoder" singleField scientificFieldDecoder = notInlinedSingleFieldRowDecoder +"singleField (nullableField scientificFieldDecoder)" singleField (nullableField scientificFieldDecoder) = notInlinedSingleFieldRowDecoder -- This last rule is still useful and triggers at call sites where the type is not known at compile time "singleField fieldDecoder" singleField fieldDecoder = notInlinedSingleFieldRowDecoder +"singleField (nullableField fieldDecoder)" singleField (nullableField fieldDecoder) = notInlinedSingleFieldRowDecoder #-} {-# INLINE [1] singleField #-} @@ -247,9 +256,6 @@ class FromPgField a where {-# 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 !typeCheck = (fieldDecoder @a).allowedPgTypes in RowDecoder @@ -270,10 +276,6 @@ class FromPgField a where 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 !typeCheck = (fieldDecoder @a).allowedPgTypes in RowDecoder { fullRowDecoder = \case @@ -1390,6 +1392,8 @@ instance FromPgField Aeson.Value where allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } +{-# INLINE [1] nullableField #-} + -- | A FieldDecoder that accepts and decodes SQL NULLs into `Nothing` values -- for a given decoder. nullableField :: FieldDecoder a -> FieldDecoder (Maybe a) From fc8a3599d72ca4a97602056bee3a8f524207712b Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 12 Sep 2026 18:25:51 -0300 Subject: [PATCH 18/38] Make queries in C# and Rust match Haskell's --- TODO.md | 1 - csharp-benchmarks/Program.cs | 6 +++--- hpgsql/src/Hpgsql/Encoding/Internal.hs | 16 +++++++++------- rust-bench/src/lib.rs | 2 +- 4 files changed, 13 insertions(+), 12 deletions(-) diff --git a/TODO.md b/TODO.md index 74ff2a4..1ece16a 100644 --- a/TODO.md +++ b/TODO.md @@ -1,4 +1,3 @@ -- Update Rust and C# benchmarks query to match - Test both `singleField fieldDecoder` and `singleFieldRowDecoder` for every type in our tests. - Do _not_ expose new FromPgField methods. Add new EncodingInternal module, instead. - Check that the non-exposed methods are safe wrt bytearray bounds access by construction, and users can't break that. If that's true, we can omit bounds checks in our row decoding, making row decoders smaller and maybe faster. diff --git a/csharp-benchmarks/Program.cs b/csharp-benchmarks/Program.cs index 7f5540a..fd63e5b 100644 --- a/csharp-benchmarks/Program.cs +++ b/csharp-benchmarks/Program.cs @@ -103,9 +103,9 @@ string FormatSecs(double s) 'item-' || g::text, g::float8 * 1.5, g::float8 * 2.5, - NULL::int4, - NULL::text, - NULL::float8, + (CASE WHEN g%2=1 THEN NULL ELSE g::int4 END), + (CASE WHEN g%2=1 THEN NULL ELSE '' END)::text, + (CASE WHEN g%2=1 THEN NULL ELSE 0.0 END)::float8, NULL::date, g::numeric, g::float4, diff --git a/hpgsql/src/Hpgsql/Encoding/Internal.hs b/hpgsql/src/Hpgsql/Encoding/Internal.hs index ba6406d..32083a2 100644 --- a/hpgsql/src/Hpgsql/Encoding/Internal.hs +++ b/hpgsql/src/Hpgsql/Encoding/Internal.hs @@ -1382,13 +1382,15 @@ instance FromPgField Aeson.Value where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in \case - Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls" - Just bs -> case Aeson.decodeStrict $ fixJsonb bs of - Just d -> Right d - Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", + let + -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in + \case + Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls" + Just bs -> case Aeson.decodeStrict $ fixJsonb bs of + Just d -> Right d + Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } diff --git a/rust-bench/src/lib.rs b/rust-bench/src/lib.rs index 8a9587d..8d94a93 100644 --- a/rust-bench/src/lib.rs +++ b/rust-bench/src/lib.rs @@ -58,7 +58,7 @@ pub const SQL17: &str = "SELECT g, ('2000-01-01'::date + g::int4), ('2000-06-15' ('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, \ + (CASE WHEN g%2=1 THEN NULL ELSE g::int4 END), (CASE WHEN g%2=1 THEN NULL ELSE '' END)::text, (CASE WHEN g%2=1 THEN NULL ELSE 0.0 END)::float8, NULL::date, \ g::numeric, g::float4, g%2=0, g%2=1 \ FROM generate_series(1,$1) g"; From ba524a12d40bdba6f08b6483d9b31bbae2096489 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 12 Sep 2026 18:27:08 -0300 Subject: [PATCH 19/38] Update TODO --- TODO.md | 6 ------ 1 file changed, 6 deletions(-) diff --git a/TODO.md b/TODO.md index 1ece16a..7eca88f 100644 --- a/TODO.md +++ b/TODO.md @@ -1,12 +1,6 @@ - Test both `singleField fieldDecoder` and `singleFieldRowDecoder` for every type in our tests. -- Do _not_ expose new FromPgField methods. Add new EncodingInternal module, instead. - - Check that the non-exposed methods are safe wrt bytearray bounds access by construction, and users can't break that. If that's true, we can omit bounds checks in our row decoding, making row decoders smaller and maybe faster. - Some types might still not derive specialized row decoders - And rewrite rules too are missing for many -- Double-check which row encoders we want to use the inlined versions for and which we don't. Tuples? - Text internals usage.. is it safe? Double-check. -- Expose in the FromPgField class two new methods.. inlined and non inlined row decoders with/without bounds checks. Use with-bounds-checks for MonadicRowDecoder, and without-bounds-checks for regular row decoder, because the latter checks type oids - - The specialized row decoders are already a problem here! They don't check type OIDs and can read bytes partially. We should ensure this mismatch is not possible. -- Is `notInlinedSingleFieldRowDecoder` worth keeping? The Generically derived decoder is almost as fast. Maybe for types that aren't records it's a different story, though? - Check that we're not holding on to internal buffers when Record fields being materialized into aren't strict - Write property-based tests for PinnedByteArray functions From 31fa9e06eec4e191f5a7f949ae127a4ccdeade52 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 12 Sep 2026 18:37:05 -0300 Subject: [PATCH 20/38] Tidy up and avoid breaking changes --- hpgsql/src/Hpgsql/Encoding.hs | 2 +- hpgsql/src/Hpgsql/Encoding/Internal.hs | 23 +++++++++++++---------- 2 files changed, 14 insertions(+), 11 deletions(-) diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index 98a2a20..97e5062 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -47,7 +47,7 @@ module Hpgsql.Encoding FieldDecoder (..), FieldInfo (..), FromPgRow (..), - RowDecoder, -- Do not export ctor because we may want to change it + RowDecoder (..), -- TODO: We should consider not exporting everything to give us freedom singleField, nullableField, genericFromPgRow, diff --git a/hpgsql/src/Hpgsql/Encoding/Internal.hs b/hpgsql/src/Hpgsql/Encoding/Internal.hs index 32083a2..e94c064 100644 --- a/hpgsql/src/Hpgsql/Encoding/Internal.hs +++ b/hpgsql/src/Hpgsql/Encoding/Internal.hs @@ -1,4 +1,4 @@ --- See Note [singleField fieldDecoder rewrite rules] +-- For the disabled warning, see Note [singleField fieldDecoder rewrite rules] {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-inline-rule-shadowing #-} @@ -153,6 +153,11 @@ instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in -- So we introduce rewrite rules to rewrite those to `notInlinedSingleFieldRowDecoder` instead. -- These rewrite rules require the implementations of each Field Decoder to be separated and not -- inlinable, or else GHC inlines `fieldDecoder` too early and these rules don't fire. +-- +-- So there will be some phase annotations in some places and this requires a delicate choice +-- of both INLINE and NOINLINE pragmas to work properly. To know if something's broken, the +-- benchmarks with "Generically derived" and "singleField fieldDecoder" row decoders both +-- should allocate the same amount of memory. {-# RULES "singleField intFieldDecoder" singleField intFieldDecoder = notInlinedSingleFieldRowDecoder @@ -1382,15 +1387,13 @@ instance FromPgField Aeson.Value where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let - -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in - \case - Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls" - Just bs -> case Aeson.decodeStrict $ fixJsonb bs of - Just d -> Right d - Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", + let -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in \case + Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls" + Just bs -> case Aeson.decodeStrict $ fixJsonb bs of + Just d -> Right d + Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } From 5f1c5ea1788f73dd415954c95f1d1c41406b56ac Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 12 Sep 2026 18:53:28 -0300 Subject: [PATCH 21/38] A few more types with specialized row decoders and rewrite rules --- hpgsql/src/Hpgsql/Encoding/Internal.hs | 90 ++++++++++++++++---------- 1 file changed, 56 insertions(+), 34 deletions(-) diff --git a/hpgsql/src/Hpgsql/Encoding/Internal.hs b/hpgsql/src/Hpgsql/Encoding/Internal.hs index e94c064..c063ca7 100644 --- a/hpgsql/src/Hpgsql/Encoding/Internal.hs +++ b/hpgsql/src/Hpgsql/Encoding/Internal.hs @@ -162,6 +162,12 @@ instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in {-# RULES "singleField intFieldDecoder" singleField intFieldDecoder = notInlinedSingleFieldRowDecoder "singleField (nullableField intFieldDecoder)" singleField (nullableField intFieldDecoder) = notInlinedSingleFieldRowDecoder +"singleField int16FieldDecoder" singleField int16FieldDecoder = notInlinedSingleFieldRowDecoder +"singleField (nullableField int16FieldDecoder)" singleField (nullableField int16FieldDecoder) = notInlinedSingleFieldRowDecoder +"singleField int32FieldDecoder" singleField int32FieldDecoder = notInlinedSingleFieldRowDecoder +"singleField (nullableField int32FieldDecoder)" singleField (nullableField int32FieldDecoder) = notInlinedSingleFieldRowDecoder +"singleField int64FieldDecoder" singleField int64FieldDecoder = notInlinedSingleFieldRowDecoder +"singleField (nullableField int64FieldDecoder)" singleField (nullableField int64FieldDecoder) = notInlinedSingleFieldRowDecoder "singleField utcTimeFieldDecoder" singleField utcTimeFieldDecoder = notInlinedSingleFieldRowDecoder "singleField (nullableField utcTimeFieldDecoder)" singleField (nullableField utcTimeFieldDecoder) = notInlinedSingleFieldRowDecoder "singleField floatFieldDecoder" singleField floatFieldDecoder = notInlinedSingleFieldRowDecoder @@ -910,29 +916,39 @@ instance FromPgField Int where 2 -> Just . fromIntegral <$> Parser.takeInt16BE _ -> fail "Trying to decode PG integer but it's not 2, 4 or 8 bytes long" +{-# NOINLINE int16FieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +int16FieldDecoder :: FieldDecoder Int16 +int16FieldDecoder = + FieldDecoder + { fieldValueDecoder = \_ -> + let !decode = binaryIntDecoder int2Oid + in \case + Nothing -> Left "Cannot decode SQL null as the Haskell Int16 type. Use a `Maybe Int16`" + Just bs -> decode (PBA.fromByteString bs), + allowedPgTypes = (== int2Oid) . fieldTypeOid + } + instance FromPgField Int16 where {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = \_ -> - let !decode = binaryIntDecoder int2Oid - in \case - Nothing -> Left "Cannot decode SQL null as the Haskell Int16 type. Use a `Maybe Int16`" - Just bs -> decode (PBA.fromByteString bs), - allowedPgTypes = (== int2Oid) . fieldTypeOid - } + fieldDecoder = int16FieldDecoder + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just Parser.takeInt16BEWithFieldLength + +{-# NOINLINE int32FieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +int32FieldDecoder :: FieldDecoder Int32 +int32FieldDecoder = + FieldDecoder + { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> + let !decode = binaryIntDecoder oid + in \case + Nothing -> Left "Cannot decode SQL null as the Haskell Int32 type. Use a `Maybe Int32`" + Just bs -> decode (PBA.fromByteString bs), + allowedPgTypes = (`elem` [int2Oid, int4Oid]) . fieldTypeOid + } instance FromPgField Int32 where {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> - let !decode = binaryIntDecoder oid - in \case - Nothing -> Left "Cannot decode SQL null as the Haskell Int32 type. Use a `Maybe Int32`" - Just bs -> decode (PBA.fromByteString bs), - allowedPgTypes = (`elem` [int2Oid, int4Oid]) . fieldTypeOid - } + fieldDecoder = int32FieldDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just $ do fieldLen <- Parser.takeInt32BE @@ -942,17 +958,21 @@ instance FromPgField Int32 where 2 -> Just . fromIntegral <$> Parser.takeInt16BE _ -> fail "Trying to decode PG int4 but it's not 2 or 4 bytes long" +{-# NOINLINE int64FieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +int64FieldDecoder :: FieldDecoder Int64 +int64FieldDecoder = + FieldDecoder + { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> + let !decode = binaryIntDecoder oid + in \case + Nothing -> Left "Cannot decode SQL null as the Haskell Int64 type. Use a `Maybe Int64`" + Just bs -> decode (PBA.fromByteString bs), + allowedPgTypes = (`elem` [int2Oid, int4Oid, int8Oid]) . fieldTypeOid + } + instance FromPgField Int64 where {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = \FieldInfo {fieldTypeOid = oid} -> - let !decode = binaryIntDecoder oid - in \case - Nothing -> Left "Cannot decode SQL null as the Haskell Int64 type. Use a `Maybe Int64`" - Just bs -> decode (PBA.fromByteString bs), - allowedPgTypes = (`elem` [int2Oid, int4Oid, int8Oid]) . fieldTypeOid - } + fieldDecoder = int64FieldDecoder {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just $ do fieldLen <- Parser.takeInt32BE @@ -1387,13 +1407,15 @@ instance FromPgField Aeson.Value where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in \case - Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls" - Just bs -> case Aeson.decodeStrict $ fixJsonb bs of - Just d -> Right d - Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", + let + -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in + \case + Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls" + Just bs -> case Aeson.decodeStrict $ fixJsonb bs of + Just d -> Right d + Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } From 80a0fb1dc4a6c03c3081080ee815942b533b3e66 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 12 Sep 2026 19:20:52 -0300 Subject: [PATCH 22/38] Actually test Field Decoders in tests now --- hpgsql-tests/EncodingDecodingSpec.hs | 43 +++++++++++++++++----------- 1 file changed, 26 insertions(+), 17 deletions(-) diff --git a/hpgsql-tests/EncodingDecodingSpec.hs b/hpgsql-tests/EncodingDecodingSpec.hs index af7d8ee..337bf65 100644 --- a/hpgsql-tests/EncodingDecodingSpec.hs +++ b/hpgsql-tests/EncodingDecodingSpec.hs @@ -210,7 +210,7 @@ smallerThan4BytesValuesAndNullsRoundtrip conn = hedgehog $ do -- 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 + -- TODO: Test `singleField notRewrittenFieldDecoder` 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) @@ -381,7 +381,7 @@ byteaTextDecoding conn = hedgehog $ do <$> 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 + <*> pipeline1With ((,) <$> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder) qry let expectedResult = (someBs, lazyBs) liftIO res1 >>= (=== expectedResult) liftIO res2 >>= (=== expectedResult) @@ -437,7 +437,7 @@ dateAndTimestampTextDecoding conn = hedgehog $ do <$> 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 + <*> pipeline1With ((,,,,,) <$> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder) qry let expectedResult = (date, timetz, someCalendarDiffTime, Finite timetz, Finite date, CalendarDiffTime 0 someNominalDiffTime) liftIO res1 >>= (=== expectedResult) liftIO res2 >>= (=== expectedResult) @@ -474,7 +474,7 @@ numericTextDecoding conn = hedgehog $ do <$> 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 + <*> pipeline1With ((,,,,,,,) <$> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder) qry let expectedResult = (1.521 :: Scientific, 1.5 :: Scientific, 1.521 :: Scientific, floatVal, floatVal2, doubleVal, doubleVal2, integerVal) liftIO res1 >>= (=== expectedResult) liftIO res2 >>= (=== expectedResult) @@ -524,7 +524,7 @@ numericTextDecodingLargerTypes conn = hedgehog $ do <$> 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 + <*> pipeline1With ((,,,,,,,,,) <$> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder) 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) @@ -543,17 +543,17 @@ numericExtremeTextDecoding conn = do runPipeline conn $ (,,,,,,,,,,,) <$> pipeline1With rowDecoder int16Qry - <*> pipeline1With ((,) <$> singleField fieldDecoder <*> singleField fieldDecoder) int16Qry + <*> pipeline1With ((,) <$> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder) int16Qry <*> pipeline1With rowDecoder int32Qry - <*> pipeline1With ((,) <$> singleField fieldDecoder <*> singleField fieldDecoder) int32Qry + <*> pipeline1With ((,) <$> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder) int32Qry <*> pipeline1With rowDecoder int64Qry - <*> pipeline1With ((,) <$> singleField fieldDecoder <*> singleField fieldDecoder) int64Qry + <*> pipeline1With ((,) <$> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder) int64Qry <*> pipeline1With rowDecoder nanQry - <*> pipeline1With ((,) <$> singleField fieldDecoder <*> singleField fieldDecoder) nanQry + <*> pipeline1With ((,) <$> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder) nanQry <*> pipeline1With rowDecoder infQry - <*> pipeline1With ((,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder) infQry + <*> pipeline1With ((,,,) <$> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder) infQry <*> pipeline1With rowDecoder mixQry - <*> pipeline1With ((,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder) mixQry + <*> pipeline1With ((,,) <$> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder) mixQry -- Integer boundary values int16Res1 `shouldReturn` (minBound :: Int16, maxBound :: Int16) int16Res2 `shouldReturn` (minBound :: Int16, maxBound :: Int16) @@ -614,7 +614,7 @@ jsonTextDecoding conn = hedgehog $ do runPipeline conn $ (,) <$> pipeline1With rowDecoder qry - <*> pipeline1With ((,,,) <$> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder <*> singleField fieldDecoder) qry + <*> pipeline1With ((,,,) <$> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder) qry (v1, v2, v3, v4) :: (Aeson.Value, Aeson.Value, PgJson, PgJson) <- liftIO res1 v1 === jsonVal1 v2 === jsonVal1 @@ -652,7 +652,7 @@ uuidTextDecoding conn = hedgehog $ do <$> 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 + <*> pipeline1With (Only <$> singleField notRewrittenFieldDecoder) qry let expectedResult = Only uuid liftIO res1 >>= (=== expectedResult) liftIO res2 >>= (=== expectedResult) @@ -691,7 +691,7 @@ ciTextTextDecoding conn = hedgehog $ do <$> 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 + <*> pipeline1With ((,,) <$> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder) qry let expectedResult = (CI.mk someText, CI.mk (LT.fromStrict someText), CI.mk (Text.unpack someText)) liftIO res1 >>= (=== expectedResult) liftIO res2 >>= (=== expectedResult) @@ -730,7 +730,7 @@ textTextDecoding conn = hedgehog $ do <$> 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 + <*> pipeline1With ((,,) <$> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder) qry let expectedResult = (someText, LT.fromStrict someText, Text.unpack someText) liftIO res1 >>= (=== expectedResult) liftIO res2 >>= (=== expectedResult) @@ -804,7 +804,7 @@ timeOfDayTextDecoding conn = hedgehog $ do <$> 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 + <*> pipeline1With ((,,,,,,,,,) <$> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder) qry liftIO res1 >>= (=== row) liftIO res2 >>= (=== row) @@ -867,7 +867,7 @@ localTimeTextDecoding conn = hedgehog $ do <$> 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 + <*> pipeline1With ((,,,,,,,,,) <$> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder) qry (,) <$> res1 <*> res2 res1Val === row res2Val === row @@ -1065,3 +1065,12 @@ valuesTypeRoundTrip conn = hedgehog $ do data Person = Person {name :: Text, born :: Day, heightMeters :: Double} deriving stock (Generic) deriving anyclass (FromPgRow) + +-- | Due to our rewrite rules (see Note [singleField notRewrittenFieldDecoder rewrite rules]), +-- it's a bit hard to test our FieldDecoders directly - without the specialized row +-- decoders taking their place. +-- This helps with that by having a NOINLINE annotation ensure the rules don't +-- apply. +{-# NOINLINE notRewrittenFieldDecoder #-} +notRewrittenFieldDecoder :: (FromPgField a) => FieldDecoder a +notRewrittenFieldDecoder = fieldDecoder From 6c9186bf0f120d2496620dfe3b68596a33b336f1 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 12 Sep 2026 19:24:29 -0300 Subject: [PATCH 23/38] Important TODO entry --- TODO.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/TODO.md b/TODO.md index 7eca88f..b045ebb 100644 --- a/TODO.md +++ b/TODO.md @@ -4,3 +4,7 @@ - Text internals usage.. is it safe? Double-check. - Check that we're not holding on to internal buffers when Record fields being materialized into aren't strict - Write property-based tests for PinnedByteArray functions +- Do expose `notInlinedSingleFieldRowDecoder` because rewrite rules are not so reliable. If users fmap over field decoders or compose over them, our rewrite rules might not apply. They might also not apply when compiling with `-O0`. + - Just think of better method names. + - Also amend our docs of the multiple ways to derive row decoders. + From 590eb852ee115b43f088ba2dfefe8fb0f03d3164 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 12 Sep 2026 19:41:58 -0300 Subject: [PATCH 24/38] Expose the not inlined method and choose better names Rewrite rules are not reliable --- TODO.md | 4 - hpgsql-benchmarks/src/Main.hs | 4 +- hpgsql-tests/RowDecoderGhcCore.hs | 4 +- hpgsql/src/Hpgsql/Encoding.hs | 15 ++-- hpgsql/src/Hpgsql/Encoding/Internal.hs | 101 +++++++++++++------------ 5 files changed, 64 insertions(+), 64 deletions(-) diff --git a/TODO.md b/TODO.md index b045ebb..7eca88f 100644 --- a/TODO.md +++ b/TODO.md @@ -4,7 +4,3 @@ - Text internals usage.. is it safe? Double-check. - Check that we're not holding on to internal buffers when Record fields being materialized into aren't strict - Write property-based tests for PinnedByteArray functions -- Do expose `notInlinedSingleFieldRowDecoder` because rewrite rules are not so reliable. If users fmap over field decoders or compose over them, our rewrite rules might not apply. They might also not apply when compiling with `-O0`. - - Just think of better method names. - - Also amend our docs of the multiple ways to derive row decoders. - diff --git a/hpgsql-benchmarks/src/Main.hs b/hpgsql-benchmarks/src/Main.hs index ff20955..cc7ee82 100644 --- a/hpgsql-benchmarks/src/Main.hs +++ b/hpgsql-benchmarks/src/Main.hs @@ -47,7 +47,7 @@ import Hpgsql.Connection (renderLibpqConnectionString) import qualified Hpgsql.Connection import qualified Hpgsql.Connection as Hpgsql import qualified Hpgsql.Copy -import Hpgsql.Encoding (inlinedSingleFieldRowDecoder) +import Hpgsql.Encoding (inlinedFieldRowDecoder) import qualified Hpgsql.Encoding as Hpgsql import qualified Hpgsql.Query as Hpgsql import qualified Hpgsql.Types as Hpgsql @@ -98,7 +98,7 @@ singleFieldBenchRowDecoder = fullyInlinedBenchRowDecoder :: Hpgsql.RowDecoder BenchRow fullyInlinedBenchRowDecoder = - BenchRow <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder + BenchRow <$> inlinedFieldRowDecoder <*> inlinedFieldRowDecoder <*> inlinedFieldRowDecoder <*> inlinedFieldRowDecoder <*> inlinedFieldRowDecoder <*> inlinedFieldRowDecoder <*> inlinedFieldRowDecoder <*> inlinedFieldRowDecoder <*> inlinedFieldRowDecoder <*> inlinedFieldRowDecoder <*> inlinedFieldRowDecoder <*> inlinedFieldRowDecoder <*> inlinedFieldRowDecoder <*> inlinedFieldRowDecoder <*> inlinedFieldRowDecoder <*> inlinedFieldRowDecoder <*> inlinedFieldRowDecoder data HasqlBenchRow = HasqlBenchRow { hbrId :: !Int32, diff --git a/hpgsql-tests/RowDecoderGhcCore.hs b/hpgsql-tests/RowDecoderGhcCore.hs index 0f8ceb4..a607197 100644 --- a/hpgsql-tests/RowDecoderGhcCore.hs +++ b/hpgsql-tests/RowDecoderGhcCore.hs @@ -10,7 +10,7 @@ import Data.Int (Int64) import Data.Text (Text) import Data.Time (Day, UTCTime) import GHC.Generics (Generic) -import Hpgsql.Encoding (FromPgField (..), FromPgRow (..), genericFromPgRow, inlinedSingleFieldRowDecoder, singleField) +import Hpgsql.Encoding (FromPgField (..), FromPgRow (..), genericFromPgRow, inlinedFieldRowDecoder, 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 @@ -31,7 +31,7 @@ data BestCaseScenarioRecord = BestCaseScenarioRecord } instance FromPgRow BestCaseScenarioRecord where - rowDecoder = BestCaseScenarioRecord <$> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder <*> inlinedSingleFieldRowDecoder + rowDecoder = BestCaseScenarioRecord <$> inlinedFieldRowDecoder <*> inlinedFieldRowDecoder <*> inlinedFieldRowDecoder -- data BenchRow = BenchRow -- { brId :: !Int, diff --git a/hpgsql/src/Hpgsql/Encoding.hs b/hpgsql/src/Hpgsql/Encoding.hs index 97e5062..6eac6db 100644 --- a/hpgsql/src/Hpgsql/Encoding.hs +++ b/hpgsql/src/Hpgsql/Encoding.hs @@ -20,16 +20,16 @@ -- -- = Performant row decoders -- --- Hpgsql provides two ways to derive row decoders from your types. --- You can use `singleField fieldDecoder` or `inlinedSingleFieldRowDecoder` for each field. +-- Hpgsql provides roughly two* ways to derive row decoders from your types. +-- You can use `fieldRowDecoder` or `inlinedFieldRowDecoder` for each field. -- For example you can define: -- -- > data Car = Car { model :: Text, year :: Maybe Int, inGoodCondition :: Bool } -- > -- > instance FromPgRow Car where --- > rowDecoder = Car <$> inlinedSingleFieldRowDecoder --- > <*> inlinedSingleFieldRowDecoder --- > <*> inlinedSingleFieldRowDecoder +-- > rowDecoder = Car <$> inlinedFieldRowDecoder +-- > <*> inlinedFieldRowDecoder +-- > <*> inlinedFieldRowDecoder -- -- And hpgsql will derive a row decoder that is extremely fast because almost all the -- decoding code is inlined. Fully inlined row decoders can be ~15% faster than not fully @@ -40,10 +40,11 @@ -- -- Some notes: -- --- * Generically derived row decoders are not fully inlined, and perform as well as hand-written row decoders built with `singleField fieldDecoder`. +-- * Generically derived row decoders are not fully inlined, and perform as well as hand-written row decoders built with `fieldRowDecoder`. +-- * Another derivation method is to use `singleField fieldDecoder`. That is the least performant way of deriving row decoders, and is only useful if you need the ability to compose `FieldDecoder`s in ways that you can't otherwise. If you can, use `fieldRowDecoder` instead. module Hpgsql.Encoding ( -- * Decoding - FromPgField (fieldDecoder, inlinedSingleFieldRowDecoder), -- Do not export other methods so we can change them + FromPgField (fieldDecoder, fieldRowDecoder, inlinedFieldRowDecoder), -- Do not export other methods so we can change them FieldDecoder (..), FieldInfo (..), FromPgRow (..), diff --git a/hpgsql/src/Hpgsql/Encoding/Internal.hs b/hpgsql/src/Hpgsql/Encoding/Internal.hs index c063ca7..f3507cf 100644 --- a/hpgsql/src/Hpgsql/Encoding/Internal.hs +++ b/hpgsql/src/Hpgsql/Encoding/Internal.hs @@ -138,8 +138,8 @@ instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- There are strictly speaking three ways to derive a single-field/column --- row decoder in hpgsql: `singleField fieldDecoder`, `notInlinedSingleFieldRowDecoder`, and --- `inlinedSingleFieldRowDecoder`. +-- row decoder in hpgsql: `singleField fieldDecoder`, `fieldRowDecoder`, and +-- `inlinedFieldRowDecoder`. -- -- The last two are sensible: one is more aggressive with inlining and produces faster row decoders -- at the cost of compilation times and binary sizes, the other produces row decoders that call out @@ -147,10 +147,10 @@ instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in -- -- But what about the first? It forces the allocation of `ByteString` values from our Pinned Byte Arrays, -- and is hence the slower of all three, except that it doesn't produce row decoders any smaller --- than `notInlinedSingleFieldRowDecoder`. It is strictly worse than that. +-- than `fieldRowDecoder`. It is strictly worse than that. -- -- Since `singleField fieldDecoder` might be used by users of hpgsql, however, we can't just remove it. --- So we introduce rewrite rules to rewrite those to `notInlinedSingleFieldRowDecoder` instead. +-- So we introduce rewrite rules to rewrite those to `fieldRowDecoder` instead. -- These rewrite rules require the implementations of each Field Decoder to be separated and not -- inlinable, or else GHC inlines `fieldDecoder` too early and these rules don't fire. -- @@ -160,34 +160,37 @@ instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in -- should allocate the same amount of memory. {-# RULES -"singleField intFieldDecoder" singleField intFieldDecoder = notInlinedSingleFieldRowDecoder -"singleField (nullableField intFieldDecoder)" singleField (nullableField intFieldDecoder) = notInlinedSingleFieldRowDecoder -"singleField int16FieldDecoder" singleField int16FieldDecoder = notInlinedSingleFieldRowDecoder -"singleField (nullableField int16FieldDecoder)" singleField (nullableField int16FieldDecoder) = notInlinedSingleFieldRowDecoder -"singleField int32FieldDecoder" singleField int32FieldDecoder = notInlinedSingleFieldRowDecoder -"singleField (nullableField int32FieldDecoder)" singleField (nullableField int32FieldDecoder) = notInlinedSingleFieldRowDecoder -"singleField int64FieldDecoder" singleField int64FieldDecoder = notInlinedSingleFieldRowDecoder -"singleField (nullableField int64FieldDecoder)" singleField (nullableField int64FieldDecoder) = notInlinedSingleFieldRowDecoder -"singleField utcTimeFieldDecoder" singleField utcTimeFieldDecoder = notInlinedSingleFieldRowDecoder -"singleField (nullableField utcTimeFieldDecoder)" singleField (nullableField utcTimeFieldDecoder) = notInlinedSingleFieldRowDecoder -"singleField floatFieldDecoder" singleField floatFieldDecoder = notInlinedSingleFieldRowDecoder -"singleField (nullableField floatFieldDecoder)" singleField (nullableField floatFieldDecoder) = notInlinedSingleFieldRowDecoder -"singleField doubleFieldDecoder" singleField doubleFieldDecoder = notInlinedSingleFieldRowDecoder -"singleField (nullableField doubleFieldDecoder)" singleField (nullableField doubleFieldDecoder) = notInlinedSingleFieldRowDecoder -"singleField boolFieldDecoder" singleField boolFieldDecoder = notInlinedSingleFieldRowDecoder -"singleField (nullableField boolFieldDecoder)" singleField (nullableField boolFieldDecoder) = notInlinedSingleFieldRowDecoder -"singleField textFieldDecoder" singleField textFieldDecoder = notInlinedSingleFieldRowDecoder -"singleField (nullableField textFieldDecoder)" singleField (nullableField textFieldDecoder) = notInlinedSingleFieldRowDecoder -"singleField dayFieldDecoder" singleField dayFieldDecoder = notInlinedSingleFieldRowDecoder -"singleField (nullableField dayFieldDecoder)" singleField (nullableField dayFieldDecoder) = notInlinedSingleFieldRowDecoder -"singleField scientificFieldDecoder" singleField scientificFieldDecoder = notInlinedSingleFieldRowDecoder -"singleField (nullableField scientificFieldDecoder)" singleField (nullableField scientificFieldDecoder) = notInlinedSingleFieldRowDecoder +"singleField intFieldDecoder" singleField intFieldDecoder = fieldRowDecoder +"singleField (nullableField intFieldDecoder)" singleField (nullableField intFieldDecoder) = fieldRowDecoder +"singleField int16FieldDecoder" singleField int16FieldDecoder = fieldRowDecoder +"singleField (nullableField int16FieldDecoder)" singleField (nullableField int16FieldDecoder) = fieldRowDecoder +"singleField int32FieldDecoder" singleField int32FieldDecoder = fieldRowDecoder +"singleField (nullableField int32FieldDecoder)" singleField (nullableField int32FieldDecoder) = fieldRowDecoder +"singleField int64FieldDecoder" singleField int64FieldDecoder = fieldRowDecoder +"singleField (nullableField int64FieldDecoder)" singleField (nullableField int64FieldDecoder) = fieldRowDecoder +"singleField utcTimeFieldDecoder" singleField utcTimeFieldDecoder = fieldRowDecoder +"singleField (nullableField utcTimeFieldDecoder)" singleField (nullableField utcTimeFieldDecoder) = fieldRowDecoder +"singleField floatFieldDecoder" singleField floatFieldDecoder = fieldRowDecoder +"singleField (nullableField floatFieldDecoder)" singleField (nullableField floatFieldDecoder) = fieldRowDecoder +"singleField doubleFieldDecoder" singleField doubleFieldDecoder = fieldRowDecoder +"singleField (nullableField doubleFieldDecoder)" singleField (nullableField doubleFieldDecoder) = fieldRowDecoder +"singleField boolFieldDecoder" singleField boolFieldDecoder = fieldRowDecoder +"singleField (nullableField boolFieldDecoder)" singleField (nullableField boolFieldDecoder) = fieldRowDecoder +"singleField textFieldDecoder" singleField textFieldDecoder = fieldRowDecoder +"singleField (nullableField textFieldDecoder)" singleField (nullableField textFieldDecoder) = fieldRowDecoder +"singleField dayFieldDecoder" singleField dayFieldDecoder = fieldRowDecoder +"singleField (nullableField dayFieldDecoder)" singleField (nullableField dayFieldDecoder) = fieldRowDecoder +"singleField scientificFieldDecoder" singleField scientificFieldDecoder = fieldRowDecoder +"singleField (nullableField scientificFieldDecoder)" singleField (nullableField scientificFieldDecoder) = fieldRowDecoder -- This last rule is still useful and triggers at call sites where the type is not known at compile time -"singleField fieldDecoder" singleField fieldDecoder = notInlinedSingleFieldRowDecoder -"singleField (nullableField fieldDecoder)" singleField (nullableField fieldDecoder) = notInlinedSingleFieldRowDecoder +"singleField fieldDecoder" singleField fieldDecoder = fieldRowDecoder +"singleField (nullableField fieldDecoder)" singleField (nullableField fieldDecoder) = fieldRowDecoder #-} {-# INLINE [1] singleField #-} + +-- | Builds a single-field row decoder. Prefer to use `fieldRowDecoder` +-- if you can because that's much faster. singleField :: FieldDecoder a -> RowDecoder a singleField fdec = let !typeCheck = fdec.allowedPgTypes @@ -254,19 +257,19 @@ class FromPgField a where -- | Semantically equivalent to `singleField fieldDecoder`, but for -- most types it can provide a much faster `RowDecoder`. This doesn't - -- cause the same amount of size blowup that `inlinedSingleFieldRowDecoder` + -- cause the same amount of size blowup that `inlinedFieldRowDecoder` -- does, but is also not as fast as that. - {-# NOINLINE notInlinedSingleFieldRowDecoder #-} - notInlinedSingleFieldRowDecoder :: RowDecoder a - notInlinedSingleFieldRowDecoder = inlinedSingleFieldRowDecoder + {-# NOINLINE fieldRowDecoder #-} + fieldRowDecoder :: RowDecoder a + fieldRowDecoder = inlinedFieldRowDecoder -- | Semantically equivalent to `singleField fieldDecoder`, but for -- most types it can provide a much faster `RowDecoder`. Beware that -- using will produce more code in your row decoders, which can affect -- compilation times and binary size. - {-# INLINE inlinedSingleFieldRowDecoder #-} - inlinedSingleFieldRowDecoder :: RowDecoder a - inlinedSingleFieldRowDecoder = case inlinedConstFieldDecoder @a of + {-# INLINE inlinedFieldRowDecoder #-} + inlinedFieldRowDecoder :: RowDecoder a + inlinedFieldRowDecoder = case inlinedConstFieldDecoder @a of Nothing -> let !typeCheck = (fieldDecoder @a).allowedPgTypes in RowDecoder @@ -380,43 +383,43 @@ compositeTypeEncoder rowEnc = } instance (FromPgField a) => FromPgRow (Only a) where - rowDecoder = Only <$> notInlinedSingleFieldRowDecoder + rowDecoder = Only <$> fieldRowDecoder instance (FromPgField a, FromPgField b) => FromPgRow (a, b) where - rowDecoder = (,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + rowDecoder = (,) <$> fieldRowDecoder <*> fieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c) => FromPgRow (a, b, c) where - rowDecoder = (,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + rowDecoder = (,,) <$> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d) => FromPgRow (a, b, c, d) where - rowDecoder = (,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + rowDecoder = (,,,) <$> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e) => FromPgRow (a, b, c, d, e) where - rowDecoder = (,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + rowDecoder = (,,,,) <$> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f) => FromPgRow (a, b, c, d, e, f) where - rowDecoder = (,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + rowDecoder = (,,,,,) <$> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g) => FromPgRow (a, b, c, d, e, f, g) where - rowDecoder = (,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + rowDecoder = (,,,,,,) <$> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h) => FromPgRow (a, b, c, d, e, f, g, h) where - rowDecoder = (,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + rowDecoder = (,,,,,,,) <$> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i) => FromPgRow (a, b, c, d, e, f, g, h, i) where - rowDecoder = (,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + rowDecoder = (,,,,,,,,) <$> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j) => FromPgRow (a, b, c, d, e, f, g, h, i, j) where - rowDecoder = (,,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + rowDecoder = (,,,,,,,,,) <$> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k) where - rowDecoder = (,,,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + rowDecoder = (,,,,,,,,,,) <$> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k, FromPgField l) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k, l) where - rowDecoder = (,,,,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + rowDecoder = (,,,,,,,,,,,) <$> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder instance (FromPgField a, FromPgField b, FromPgField c, FromPgField d, FromPgField e, FromPgField f, FromPgField g, FromPgField h, FromPgField i, FromPgField j, FromPgField k, FromPgField l, FromPgField m) => FromPgRow (a, b, c, d, e, f, g, h, i, j, k, l, m) where - rowDecoder = (,,,,,,,,,,,,) <$> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder <*> notInlinedSingleFieldRowDecoder + rowDecoder = (,,,,,,,,,,,,) <$> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder <*> fieldRowDecoder data FieldEncoder a = FieldEncoder { toTypeOid :: !(EncodingContext -> Maybe Oid), @@ -1533,7 +1536,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 $ notInlinedSingleFieldRowDecoder @a + genRowDecoder = coerce $ fieldRowDecoder @a genericToPgRow :: forall a. (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a genericToPgRow = contramap from genRowEncoder From d5791886dec0fba6fde488c347ef5896e750e027 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 12 Sep 2026 19:46:36 -0300 Subject: [PATCH 25/38] Important TODO entry --- TODO.md | 1 + 1 file changed, 1 insertion(+) diff --git a/TODO.md b/TODO.md index 7eca88f..09c9de7 100644 --- a/TODO.md +++ b/TODO.md @@ -4,3 +4,4 @@ - Text internals usage.. is it safe? Double-check. - Check that we're not holding on to internal buffers when Record fields being materialized into aren't strict - Write property-based tests for PinnedByteArray functions +- Double check that for this PR the inlined and not inlined versions really differ in performance From e0e7ec5a70d2c7b7e68c5c9729174bb0bc3da4ab Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sun, 13 Sep 2026 11:21:04 -0300 Subject: [PATCH 26/38] More specialized instances --- hpgsql/src/Hpgsql/Encoding/Internal.hs | 74 ++++++++++++++++---------- 1 file changed, 46 insertions(+), 28 deletions(-) diff --git a/hpgsql/src/Hpgsql/Encoding/Internal.hs b/hpgsql/src/Hpgsql/Encoding/Internal.hs index f3507cf..a6f560e 100644 --- a/hpgsql/src/Hpgsql/Encoding/Internal.hs +++ b/hpgsql/src/Hpgsql/Encoding/Internal.hs @@ -182,6 +182,12 @@ instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in "singleField (nullableField dayFieldDecoder)" singleField (nullableField dayFieldDecoder) = fieldRowDecoder "singleField scientificFieldDecoder" singleField scientificFieldDecoder = fieldRowDecoder "singleField (nullableField scientificFieldDecoder)" singleField (nullableField scientificFieldDecoder) = fieldRowDecoder +"singleField unboundedDayFieldDecoder" singleField unboundedDayFieldDecoder = fieldRowDecoder +"singleField (nullableField unboundedDayFieldDecoder)" singleField (nullableField unboundedDayFieldDecoder) = fieldRowDecoder +"singleField calendarDiffTimeFieldDecoder" singleField calendarDiffTimeFieldDecoder = fieldRowDecoder +"singleField (nullableField calendarDiffTimeFieldDecoder)" singleField (nullableField calendarDiffTimeFieldDecoder) = fieldRowDecoder +"singleField uuidFieldDecoder" singleField uuidFieldDecoder = fieldRowDecoder +"singleField (nullableField uuidFieldDecoder)" singleField (nullableField uuidFieldDecoder) = fieldRowDecoder -- This last rule is still useful and triggers at call sites where the type is not known at compile time "singleField fieldDecoder" singleField fieldDecoder = fieldRowDecoder "singleField (nullableField fieldDecoder)" singleField (nullableField fieldDecoder) = fieldRowDecoder @@ -1367,42 +1373,54 @@ instance FromPgField Day where {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just dayRowDecoder +{-# NOINLINE unboundedDayFieldDecoder #-} +unboundedDayFieldDecoder :: FieldDecoder (Unbounded Day) +unboundedDayFieldDecoder = parsePgType "Unbounded Day" [dateOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell Unbounded Day type. Use a `Maybe (Unbounded Day)`" + Just bs -> do + -- There is a very specific conversion function for these, which I poorly translated to Haskell + -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 + -- But I found a simpler way to do this. Let's see if it works in our property based tests + jd <- PBA.decodeInt32BE 0 (PBA.fromByteString bs) + Right $ + if jd == minBound + then NegInfinity + else + if jd == maxBound + then PosInfinity + else + Finite $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 + instance FromPgField (Unbounded Day) where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Unbounded Day" [dateOid] $ \case - Nothing -> Left "Cannot decode SQL null as the Haskell Unbounded Day type. Use a `Maybe (Unbounded Day)`" - Just bs -> do - -- There is a very specific conversion function for these, which I poorly translated to Haskell - -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 - -- But I found a simpler way to do this. Let's see if it works in our property based tests - jd <- PBA.decodeInt32BE 0 (PBA.fromByteString bs) - Right $ - if jd == minBound - then NegInfinity - else - if jd == maxBound - then PosInfinity - else - Finite $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 + fieldDecoder = unboundedDayFieldDecoder + +{-# NOINLINE calendarDiffTimeFieldDecoder #-} +calendarDiffTimeFieldDecoder :: FieldDecoder CalendarDiffTime +calendarDiffTimeFieldDecoder = parsePgType "CalendarDiffTime " [intervalOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell CalendarDiffTime type. Use a `Maybe CalendarDiffTime `" + Just bs -> do + let !pbaBs = PBA.fromByteString bs + nMicrosecs <- PBA.decodeInt64BE 0 pbaBs + nDays <- PBA.decodeInt32BE 8 pbaBs + nMonths <- PBA.decodeInt32BE 12 pbaBs + Right $ CalendarDiffTime {ctMonths = fromIntegral nMonths, ctTime = secondsToNominalDiffTime (fromIntegral nDays * 86400) + realToFrac (picosecondsToDiffTime (fromIntegral nMicrosecs * 1_000_000))} instance FromPgField CalendarDiffTime where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "CalendarDiffTime " [intervalOid] $ \case - Nothing -> Left "Cannot decode SQL null as the Haskell CalendarDiffTime type. Use a `Maybe CalendarDiffTime `" - Just bs -> do - let !pbaBs = PBA.fromByteString bs - nMicrosecs <- PBA.decodeInt64BE 0 pbaBs - nDays <- PBA.decodeInt32BE 8 pbaBs - nMonths <- PBA.decodeInt32BE 12 pbaBs - Right $ CalendarDiffTime {ctMonths = fromIntegral nMonths, ctTime = secondsToNominalDiffTime (fromIntegral nDays * 86400) + realToFrac (picosecondsToDiffTime (fromIntegral nMicrosecs * 1_000_000))} + fieldDecoder = calendarDiffTimeFieldDecoder + +{-# NOINLINE uuidFieldDecoder #-} +uuidFieldDecoder :: FieldDecoder UUID +uuidFieldDecoder = parsePgType "UUID" [uuidOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell UUID type. Use a `Maybe UUID`" + Just bs -> case UUID.fromByteString (LBS.fromStrict bs) of + Just uuid -> Right uuid + Nothing -> Left "Bug in Hpgsql: UUID field could not be decoded" instance FromPgField UUID where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "UUID" [uuidOid] $ \case - Nothing -> Left "Cannot decode SQL null as the Haskell UUID type. Use a `Maybe UUID`" - Just bs -> case UUID.fromByteString (LBS.fromStrict bs) of - Just uuid -> Right uuid - Nothing -> Left "Bug in Hpgsql: UUID field could not be decoded" + fieldDecoder = uuidFieldDecoder instance FromPgField Aeson.Value where {-# INLINE fieldDecoder #-} From b5cdf670802c2f9dc858616cfa5f765ee46c9ad4 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sun, 13 Sep 2026 11:41:53 -0300 Subject: [PATCH 27/38] Faster array decoders --- TODO.md | 1 + hpgsql/src/Hpgsql/Encoding/Internal.hs | 46 +++++++++++++++++++++++++- hpgsql/src/Hpgsql/Types.hs | 4 +-- 3 files changed, 48 insertions(+), 3 deletions(-) diff --git a/TODO.md b/TODO.md index 09c9de7..7fb882f 100644 --- a/TODO.md +++ b/TODO.md @@ -1,4 +1,5 @@ - Test both `singleField fieldDecoder` and `singleFieldRowDecoder` for every type in our tests. + - For array types too we have more than one arrayField* variant - Some types might still not derive specialized row decoders - And rewrite rules too are missing for many - Text internals usage.. is it safe? Double-check. diff --git a/hpgsql/src/Hpgsql/Encoding/Internal.hs b/hpgsql/src/Hpgsql/Encoding/Internal.hs index a6f560e..5458f79 100644 --- a/hpgsql/src/Hpgsql/Encoding/Internal.hs +++ b/hpgsql/src/Hpgsql/Encoding/Internal.hs @@ -41,6 +41,7 @@ module Hpgsql.Encoding.Internal untypedFieldEncoder, toPgVectorField, arrayField, + arrayFieldRowDec, ) where @@ -1484,7 +1485,8 @@ allowOnlyArrayTypes fieldInfo = Just _ -> False -- Definitely not an array instance forall a. (FromPgField a) => FromPgField (Vector a) where - fieldDecoder = arrayField Vector.replicateM fieldDecoder + {-# INLINE fieldDecoder #-} + fieldDecoder = arrayFieldRowDec Vector.replicateM instance {-# OVERLAPPING #-} forall a. (FromPgField a) => FromPgField (Vector (Vector a)) where -- From https://github.com/postgres/postgres/blob/5941946d0934b9eccb0d5bfebd40b155249a0130/src/backend/utils/adt/arrayfuncs.c#L1548 @@ -1725,3 +1727,45 @@ arrayField !replicateFunction !elementParser = case elementParser.fieldValueDecoder elementColInfo (Just (PBA.toByteString elementBs)) of Left err -> fail $ "Error parsing array element: " ++ show err Right el -> pure el + +-- | A FieldDecoder that accepts and decodes Postgres arrays. +arrayFieldRowDec :: forall a f. (FromPgField a, Monoid (f a)) => (forall m. (Monad m) => Int -> m a -> m (f a)) -> FieldDecoder (f a) +arrayFieldRowDec !replicateFunction = + -- From https://github.com/postgres/postgres/blob/5941946d0934b9eccb0d5bfebd40b155249a0130/src/backend/utils/adt/arrayfuncs.c#L1548 + FieldDecoder + { fieldValueDecoder = \colInfo -> + let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput + in \case + Nothing -> Left "Cannot decode SQL null as the Haskell Vector type. Use a `Maybe (Vector a)`" + Just bs -> case Parser.parseOnly arrayFieldDecoder (PBA.fromByteString bs) of + Parser.ParseOk v -> Right v + Parser.ParseFail err -> Left err, + allowedPgTypes = allowOnlyArrayTypes + } + where + fdec = fieldDecoder @a + handleNulls p = \finfo -> do + mv <- p + case mv of + Nothing -> case fdec.fieldValueDecoder finfo Nothing of + Left err -> fail $ "Array element is NULL: " ++ err + Right v -> pure v + Just v -> pure v + fieldDec = case inlinedConstFieldDecoder of + Just d -> handleNulls d + Nothing -> \finfo -> handleNulls (notConstFieldDecoder finfo) finfo + arrayParser :: EncodingContext -> Parser.Parser (f a) + arrayParser encodingContext = do + !ndim <- Parser.takeInt32BE + !_hasNull <- Parser.takeInt32BE + !elementTypeOid :: Oid <- Oid . fromIntegral <$> Parser.takeInt32BE + let !elementColInfo = FieldInfo elementTypeOid Nothing encodingContext + when (ndim > 1) $ fail $ "TODO: No support for multi-dimensional arrays in Hpgsql. Got array with ndim=" ++ show ndim + if ndim == 0 + then pure mempty + else do + !dim_i :: Int <- fromIntegral <$> Parser.takeInt32BE + !_lb_i <- Parser.takeInt32BE + unless (fdec.allowedPgTypes elementColInfo) $ fail $ "Array contains elements of type OID " ++ show elementTypeOid ++ " but decoder does not handle that type" + let p = fieldDec elementColInfo + replicateFunction dim_i p diff --git a/hpgsql/src/Hpgsql/Types.hs b/hpgsql/src/Hpgsql/Types.hs index 077685b..582344a 100644 --- a/hpgsql/src/Hpgsql/Types.hs +++ b/hpgsql/src/Hpgsql/Types.hs @@ -19,7 +19,7 @@ import qualified Data.ByteString.Lazy as LBS import Data.Tuple.Only (Only (..)) import Data.Typeable (Proxy (..)) import Hpgsql.Builder (BinaryField (..)) -import Hpgsql.Encoding.Internal (FieldDecoder (..), FieldEncoder (..), FieldInfo (..), FromPgField (..), FromPgRow (..), RowEncoder (..), ToPgField (..), ToPgRow (..), arrayField, toPgVectorField) +import Hpgsql.Encoding.Internal (FieldDecoder (..), FieldEncoder (..), FieldInfo (..), FromPgField (..), FromPgRow (..), RowEncoder (..), ToPgField (..), ToPgRow (..), arrayFieldRowDec, toPgVectorField) import qualified Hpgsql.PinnedByteArray as PBA import qualified Hpgsql.SimpleParser as Parser import Hpgsql.TypeInfo (EncodingContext (..), TypeInfo (..), jsonOid, jsonbOid, lookupTypeByOid) @@ -43,7 +43,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 + fieldDecoder = PGArray <$> arrayFieldRowDec replicateM -- | A way to compose two rows. data h :. t = !h :. !t deriving (Eq, Ord, Show, Read) From 6284506d158321121dcdfc8703825eacf2ae0787 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sun, 13 Sep 2026 12:01:52 -0300 Subject: [PATCH 28/38] Faster UUID decoder --- hpgsql-tests/EncodingDecodingSpec.hs | 2 +- hpgsql/src/Hpgsql/Encoding/Internal.hs | 10 ++++++++++ hpgsql/src/Hpgsql/SimpleParser.hs | 9 +++++++++ 3 files changed, 20 insertions(+), 1 deletion(-) diff --git a/hpgsql-tests/EncodingDecodingSpec.hs b/hpgsql-tests/EncodingDecodingSpec.hs index 337bf65..154c948 100644 --- a/hpgsql-tests/EncodingDecodingSpec.hs +++ b/hpgsql-tests/EncodingDecodingSpec.hs @@ -632,7 +632,7 @@ jsonTextDecoding conn = hedgehog $ do uuidRoundTrip :: HPgConnection -> PropertyT IO () uuidRoundTrip conn = hedgehog $ do - let genUuid = do + let genUuid = Gen.maybe $ do uuidBytes <- Gen.bytes (Gen.singleton 16) let Just uuid = UUID.fromByteString (LBS.fromStrict uuidBytes) pure uuid diff --git a/hpgsql/src/Hpgsql/Encoding/Internal.hs b/hpgsql/src/Hpgsql/Encoding/Internal.hs index 5458f79..ce8ee8e 100644 --- a/hpgsql/src/Hpgsql/Encoding/Internal.hs +++ b/hpgsql/src/Hpgsql/Encoding/Internal.hs @@ -1422,6 +1422,16 @@ uuidFieldDecoder = parsePgType "UUID" [uuidOid] $ \case instance FromPgField UUID where {-# INLINE fieldDecoder #-} fieldDecoder = uuidFieldDecoder + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just $ do + len <- Parser.takeInt32BE + case len of + (-1) -> pure Nothing + _ -> + fmap Just $ + UUID.fromWords64 + <$> Parser.takeWord64BE + <*> Parser.takeWord64BE instance FromPgField Aeson.Value where {-# INLINE fieldDecoder #-} diff --git a/hpgsql/src/Hpgsql/SimpleParser.hs b/hpgsql/src/Hpgsql/SimpleParser.hs index e3e9896..c9ac219 100644 --- a/hpgsql/src/Hpgsql/SimpleParser.hs +++ b/hpgsql/src/Hpgsql/SimpleParser.hs @@ -33,12 +33,14 @@ module Hpgsql.SimpleParser takeFloatBEWithFieldLength, peekInt32BE, takeUtf8Text, + takeWord64BE, ) where import Control.Applicative (Alternative (..)) import Data.Int (Int16, Int32, Int64) import Data.Text (Text) +import Data.Word (Word64) import Foreign.Storable (Storable) import GHC.Float (castWord32ToFloat, castWord64ToDouble) import Hpgsql.PinnedByteArray (ByteStringIdx (..), PinnedByteArray) @@ -224,6 +226,13 @@ takeInt64BE = Parser $ \idx bs kf ks -> Right v -> ks v (idx + 8) bs Left err -> kf err +{-# INLINE takeWord64BE #-} +takeWord64BE :: Parser Word64 +takeWord64BE = Parser $ \idx bs kf ks -> + case PBA.decodeWord64BE idx bs of + Right v -> ks v (idx + 8) bs + Left err -> kf err + {-# INLINE takeDataRow #-} -- | A specialized parser to parse a postgres DataRow, From b84e1531567febabdb6d6a3773bde4cee5a995a1 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Thu, 17 Sep 2026 16:01:21 -0300 Subject: [PATCH 29/38] Make `Int` decoding a tiny bit faster with the not-const field decoder --- hpgsql/src/Hpgsql/Encoding/Internal.hs | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/hpgsql/src/Hpgsql/Encoding/Internal.hs b/hpgsql/src/Hpgsql/Encoding/Internal.hs index ce8ee8e..cfe7587 100644 --- a/hpgsql/src/Hpgsql/Encoding/Internal.hs +++ b/hpgsql/src/Hpgsql/Encoding/Internal.hs @@ -914,17 +914,20 @@ instance FromPgField Int where {-# INLINE fieldDecoder #-} fieldDecoder = intFieldDecoder - {-# 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" + -- Interestingly, the notConst field decoder is a tiny little bit + -- faster than the constFieldDecoder + {-# INLINE notConstFieldDecoder #-} + notConstFieldDecoder = \finfo -> + if finfo.fieldTypeOid == int4Oid + then fmap fromIntegral <$> Parser.takeInt32BEWithFieldLength + else + if finfo.fieldTypeOid == int8Oid + then do + fieldLen <- Parser.takeInt32BE + case fieldLen of + (-1) -> pure Nothing + _ -> Just . fromIntegral <$> Parser.takeInt64BE + else fmap fromIntegral <$> Parser.takeInt16BEWithFieldLength {-# NOINLINE int16FieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] int16FieldDecoder :: FieldDecoder Int16 From d2778d57ea9c78fc15ed8b039e240b25f89dc365 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Thu, 17 Sep 2026 17:03:41 -0300 Subject: [PATCH 30/38] Speed up enums and Lazy Text, replace one `error` with a proper failure Enum decoding failures used `error` before. That's gone. --- hpgsql-tests/EncodingDecodingSpec.hs | 37 +++++++++++--- hpgsql/src/Hpgsql/Encoding/Internal.hs | 69 ++++++++++++++++++++------ 2 files changed, 82 insertions(+), 24 deletions(-) diff --git a/hpgsql-tests/EncodingDecodingSpec.hs b/hpgsql-tests/EncodingDecodingSpec.hs index 154c948..f0d1bbb 100644 --- a/hpgsql-tests/EncodingDecodingSpec.hs +++ b/hpgsql-tests/EncodingDecodingSpec.hs @@ -30,6 +30,7 @@ import Data.Vector (Vector) import qualified Data.Vector as Vector import DbUtils ( aroundConn, + irrecoverableErrorWithMsg, irrecoverableErrorWithMsgAndStmt, testConnInfo, withRollback, @@ -43,7 +44,7 @@ import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Gen import Hpgsql import Hpgsql.Connection (ConnectOpts (..), connect, connectOpts, defaultConnectOpts, refreshTypeInfoCache, withConnectionOpts) -import Hpgsql.Encoding (EncodingContext (..), FieldDecoder (..), FieldEncoder (..), FieldInfo (..), FromPgField (..), FromPgRow (..), LowerCasedPgEnum (..), RowEncoder (..), ToPgField (..), ToPgRow (..), compositeTypeDecoder, compositeTypeEncoder, nullableField, rawBytesFieldDecoder, singleField, typeFieldDecoder, typeFieldEncoder, typeMustBeNamed, typeOidWithName) +import Hpgsql.Encoding (EncodingContext (..), FieldDecoder (..), FieldEncoder (..), FieldInfo (..), FromPgField (..), FromPgRow (..), LowerCasedPgEnum (..), RowDecoder, RowEncoder (..), ToPgField (..), ToPgRow (..), compositeTypeDecoder, compositeTypeEncoder, nullableField, rawBytesFieldDecoder, singleField, typeFieldDecoder, typeFieldEncoder, typeMustBeNamed, typeOidWithName) import Hpgsql.Pipeline (pipeline, pipeline1With, pipelineWith, runPipeline) import Hpgsql.Query (mkQuery, sql, vALUES) import Hpgsql.Time (Unbounded (..)) @@ -943,7 +944,7 @@ instance FromPgField MyEnum where "val1" -> Val1 "val2" -> Val2 "val3" -> Val3 - _ -> error "Invalid value for MyEnum" + x -> error $ "Invalid value for MyEnum:" ++ show x in convert <$> rawBytesFieldDecoder myEnumFieldDecoderWithTypeInfoCheck :: FieldDecoder MyEnum @@ -952,7 +953,7 @@ myEnumFieldDecoderWithTypeInfoCheck = "val1" -> Val1 "val2" -> Val2 "val3" -> Val3 - _ -> error "Invalid value for MyEnum" + x -> error $ "Invalid value for MyEnum: " ++ show x in typeFieldDecoder (typeMustBeNamed "myenum") $ convert <$> rawBytesFieldDecoder @@ -970,8 +971,12 @@ instance ToPgField MyEnum where queryEnumTypes :: HPgConnection -> IO () queryEnumTypes conn = withRollback conn $ do execute conn "CREATE TYPE myenum AS ENUM ('val1', 'val2', 'val3');" - queryWith (rowDecoder @(MyEnum, MyEnum, MyEnum, Maybe MyEnum)) conn "SELECT 'val1'::myenum, 'val2'::myenum, 'val3'::myenum, NULL::myenum" `shouldReturn` [(Val1, Val2, Val3, Nothing)] - queryWith (rowDecoder @(MyEnum, MyEnum, MyEnum, Maybe MyEnum)) conn (mkQuery "SELECT $1, $2, $3, $4" (Val1, Val2, Val3, Nothing :: Maybe MyEnum)) `shouldReturn` [(Val1, Val2, Val3, Nothing)] + -- Specialized row parsers of each type are a different implementation from + -- the simpler fieldDecoders, so we need to test both + queryWith rowDecoder conn "SELECT 'val1'::myenum, 'val2'::myenum, 'val3'::myenum, NULL::myenum" `shouldReturn` [(Val1, Val2, Val3, Nothing :: Maybe MyEnum)] + queryWith ((,,,) <$> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder) conn "SELECT 'val1'::myenum, 'val2'::myenum, 'val3'::myenum, NULL::myenum" `shouldReturn` [(Val1, Val2, Val3, Nothing :: Maybe MyEnum)] + queryWith rowDecoder conn (mkQuery "SELECT $1, $2, $3, $4" (Val1, Val2, Val3, Nothing :: Maybe MyEnum)) `shouldReturn` [(Val1, Val2, Val3, Nothing :: Maybe MyEnum)] + queryWith ((,,,) <$> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder) conn (mkQuery "SELECT $1, $2, $3, $4" (Val1, Val2, Val3, Nothing :: Maybe MyEnum)) `shouldReturn` [(Val1, Val2, Val3, Nothing :: Maybe MyEnum)] -- The statement below will fail because the new myenum type is not in the typeCache -- yet. Then we add it and it will pass queryWith (singleField myEnumFieldDecoderWithTypeInfoCheck) conn "SELECT 'val2'::myenum" @@ -987,6 +992,16 @@ queryEnumTypes conn = withRollback conn $ do queryRes `shouldReturn` [Val2] query conn "SELECT ARRAY['val2'::myenum]" `shouldReturn` [Only (PGArray [Val2])] + -- LowerCasedPGEnum for both specialized row decoder and field decoder + execute conn "CREATE TYPE lcenum AS ENUM ('eval1', 'eval2', 'eval3', 'unmapped_value');" + queryWith rowDecoder conn "SELECT 'eval1'::lcenum, 'eval2'::lcenum, 'eval3'::lcenum, NULL::lcenum" `shouldReturn` [(EVal1, EVal2, EVal3, Nothing :: Maybe SomeGenericEnum)] + + queryWith ((,,,) <$> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder) conn "SELECT 'eval1'::lcenum, 'eval2'::lcenum, 'eval3'::lcenum, NULL::lcenum" `shouldReturn` [(EVal1, EVal2, EVal3, Nothing :: Maybe SomeGenericEnum)] + + -- Now with an unmapped value, for which we expect a good error message + queryWith (rowDecoder :: RowDecoder (Only SomeGenericEnum)) conn "SELECT 'unmapped_value'::lcenum" `shouldThrow` irrecoverableErrorWithMsg "Invalid enum value. Not one of" + queryWith (singleField $ notRewrittenFieldDecoder @SomeGenericEnum) conn "SELECT 'unmapped_value'::lcenum" `shouldThrow` irrecoverableErrorWithMsg "Invalid enum value. Not one of" + data SomeGenericEnum = EVal1 | EVal2 | EVal3 deriving stock (Eq, Generic, Show) deriving (FromPgField, ToPgField) via (LowerCasedPgEnum SomeGenericEnum) @@ -1035,9 +1050,15 @@ genSomeGenericProdType = queryGenericallyDerivedTypes :: HPgConnection -> IO () queryGenericallyDerivedTypes conn = withRollback conn $ do execute conn "CREATE TYPE myenum AS ENUM ('eval1', 'eval2', 'eval3');" - queryWith rowDecoder conn "SELECT 13, 'eval2'::myenum, 'Some text', true, false" `shouldReturn` [SomeGenericRecord 13 EVal2 "Some text" True False] - queryWith rowDecoder conn "SELECT 13, 'eval2'::myenum, 'Some text', true, false" `shouldReturn` [SomeGenericProdType 13 EVal2 "Some text" True False] - queryWith rowDecoder conn "SELECT 'eval1'::myenum, 'eval2'::myenum, 'eval3'::myenum" `shouldReturn` [(EVal1, EVal2, EVal3)] + (r1, r2, r3) <- + runPipeline conn $ + (,,) + <$> pipelineWith rowDecoder "SELECT 13, 'eval2'::myenum, 'Some text', true, false" + <*> pipelineWith rowDecoder "SELECT 13, 'eval2'::myenum, 'Some text', true, false" + <*> pipelineWith rowDecoder "SELECT 'eval1'::myenum, 'eval2'::myenum, 'eval3'::myenum" + r1 `shouldReturn` [SomeGenericRecord 13 EVal2 "Some text" True False] + r2 `shouldReturn` [SomeGenericProdType 13 EVal2 "Some text" True False] + r3 `shouldReturn` [(EVal1, EVal2, EVal3)] queryGenericallyDerivedTypesRoundTrip :: HPgConnection -> PropertyT IO () queryGenericallyDerivedTypesRoundTrip conn = hedgehog $ do diff --git a/hpgsql/src/Hpgsql/Encoding/Internal.hs b/hpgsql/src/Hpgsql/Encoding/Internal.hs index cfe7587..6842e4e 100644 --- a/hpgsql/src/Hpgsql/Encoding/Internal.hs +++ b/hpgsql/src/Hpgsql/Encoding/Internal.hs @@ -179,6 +179,8 @@ instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in "singleField (nullableField boolFieldDecoder)" singleField (nullableField boolFieldDecoder) = fieldRowDecoder "singleField textFieldDecoder" singleField textFieldDecoder = fieldRowDecoder "singleField (nullableField textFieldDecoder)" singleField (nullableField textFieldDecoder) = fieldRowDecoder +"singleField lazyTextFieldDecoder" singleField lazyTextFieldDecoder = fieldRowDecoder +"singleField (nullableField lazyTextFieldDecoder)" singleField (nullableField lazyTextFieldDecoder) = fieldRowDecoder "singleField dayFieldDecoder" singleField dayFieldDecoder = fieldRowDecoder "singleField (nullableField dayFieldDecoder)" singleField (nullableField dayFieldDecoder) = fieldRowDecoder "singleField scientificFieldDecoder" singleField scientificFieldDecoder = fieldRowDecoder @@ -878,10 +880,13 @@ binaryFloat8Decoder :: PinnedByteArray -> Double binaryFloat8Decoder = castWord64ToDouble . either error id . PBA.decodeWord64BE 0 parsePgType :: String -> [Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a -parsePgType !_typeName !requiredTypeOids !fieldValueDecoder = +parsePgType !_typeName !requiredTypeOids !fieldValueDecoder = parsePgTypeFull ((`elem` requiredTypeOids) . fieldTypeOid) fieldValueDecoder + +parsePgTypeFull :: (FieldInfo -> Bool) -> (Maybe ByteString -> Either String a) -> FieldDecoder a +parsePgTypeFull !allowedPgTypes !fieldValueDecoder = FieldDecoder { fieldValueDecoder = \_oid -> fieldValueDecoder, - allowedPgTypes = (`elem` requiredTypeOids) . fieldTypeOid + allowedPgTypes } instance FromPgField () where @@ -1228,11 +1233,20 @@ instance FromPgField Text where {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just textDecoder +{-# INLINE lazyTextDecoder #-} +lazyTextDecoder :: Parser.Parser (Maybe LT.Text) +lazyTextDecoder = fmap LT.fromStrict <$> textDecoder + +{-# NOINLINE lazyTextFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +lazyTextFieldDecoder :: FieldDecoder LT.Text +lazyTextFieldDecoder = LT.fromStrict <$> textFieldDecoder + instance FromPgField LT.Text where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \case - Nothing -> Left "Cannot decode SQL null as the Haskell Text type. Use a `Maybe Text`" - Just bs -> LT.fromStrict <$> PBA.unsafeToUtf8Text 0 (BS.length bs) (PBA.fromByteString bs) + fieldDecoder = lazyTextFieldDecoder + + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just lazyTextDecoder instance FromPgField String where {-# INLINE fieldDecoder #-} @@ -1442,15 +1456,13 @@ instance FromPgField Aeson.Value where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let - -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in - \case - Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls" - Just bs -> case Aeson.decodeStrict $ fixJsonb bs of - Just d -> Right d - Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", + let -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in \case + Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls" + Just bs -> case Aeson.decodeStrict $ fixJsonb bs of + Just d -> Right d + Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } @@ -1605,6 +1617,15 @@ newtype LowerCasedPgEnum a = LowerCasedPgEnum a instance (Generic a, EnumDecoder (Rep a)) => FromPgField (LowerCasedPgEnum a) where fieldDecoder = LowerCasedPgEnum <$> genericEnumFieldDecoder LT.toLower + inlinedConstFieldDecoder = Just $ do + enumAsText <- lazyTextDecoder + case enumAsText of + Nothing -> pure Nothing + Just e -> case textToEnum e of + Left err -> fail err + Right v -> pure $ Just (LowerCasedPgEnum v) + where + textToEnum = enumFieldMapper @a LT.toLower instance (Generic a, EnumEncoder (Rep a)) => ToPgField (LowerCasedPgEnum a) where fieldEncoder = untypedFieldEncoder $ \_encCtx -> \(LowerCasedPgEnum v) -> NotNull $ genericEnumFieldEncoder Text.toLower v @@ -1618,10 +1639,26 @@ genericEnumFieldDecoder :: -- | A function that takes in the Haskell constructor name and returns the textual representation of the enum in postgres (LT.Text -> LT.Text) -> FieldDecoder a -genericEnumFieldDecoder nameTransform = fromMaybe (error $ "Invalid enum value. Not one of " ++ show (Map.keys allValuesMap)) . flip Map.lookup allValuesMap <$> rawBytesFieldDecoder +genericEnumFieldDecoder nameTransform = parsePgTypeFull (const True) $ \case + Nothing -> Left "Cannot decode SQL null with the Enum decoder. Use a `Maybe` if you want SQL nulls" + Just bs -> transform (LT.decodeUtf8 $ BS.fromStrict bs) + where + transform = enumFieldMapper nameTransform + +-- | Returns a function that maps an enum value coming from Postgres +-- into the enum while respecting the Haskell-constructor mapping function. +enumFieldMapper :: + forall a. + (Generic a, EnumDecoder (Rep a)) => + -- | A function that takes in the Haskell constructor name and returns the textual representation of the enum in postgres + (LT.Text -> LT.Text) -> + (LT.Text -> Either String a) +enumFieldMapper nameTransform = \enumVal -> case Map.lookup enumVal allValuesMap of + Nothing -> Left $ "Invalid enum value. Not one of " ++ show (Map.keys allValuesMap) + Just v -> Right v where -- TODO: Vector of pointers to ByteStrings for a bit more memory locality? Does it make a perf difference? - allValuesMap = Map.mapKeys (LBS.toStrict . LT.encodeUtf8 . nameTransform) $ fmap to genEnumDecoder + allValuesMap = Map.mapKeys nameTransform $ fmap to genEnumDecoder class EnumDecoder f where -- | Returns the textual representation and constructed object for every possible From 81ba9880d301f4a31d1899221f265dfd199fe943 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Thu, 17 Sep 2026 17:15:41 -0300 Subject: [PATCH 31/38] Apply new decoding pattern to `String` --- hpgsql/src/Hpgsql/Encoding/Internal.hs | 35 ++++++++++++++++++-------- 1 file changed, 25 insertions(+), 10 deletions(-) diff --git a/hpgsql/src/Hpgsql/Encoding/Internal.hs b/hpgsql/src/Hpgsql/Encoding/Internal.hs index 6842e4e..c306fa4 100644 --- a/hpgsql/src/Hpgsql/Encoding/Internal.hs +++ b/hpgsql/src/Hpgsql/Encoding/Internal.hs @@ -181,6 +181,8 @@ instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in "singleField (nullableField textFieldDecoder)" singleField (nullableField textFieldDecoder) = fieldRowDecoder "singleField lazyTextFieldDecoder" singleField lazyTextFieldDecoder = fieldRowDecoder "singleField (nullableField lazyTextFieldDecoder)" singleField (nullableField lazyTextFieldDecoder) = fieldRowDecoder +"singleField stringFieldDecoder" singleField stringFieldDecoder = fieldRowDecoder +"singleField (nullableField stringFieldDecoder)" singleField (nullableField stringFieldDecoder) = fieldRowDecoder "singleField dayFieldDecoder" singleField dayFieldDecoder = fieldRowDecoder "singleField (nullableField dayFieldDecoder)" singleField (nullableField dayFieldDecoder) = fieldRowDecoder "singleField scientificFieldDecoder" singleField scientificFieldDecoder = fieldRowDecoder @@ -1248,11 +1250,22 @@ instance FromPgField LT.Text where {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just lazyTextDecoder +{-# INLINE stringDecoder #-} +stringDecoder :: Parser.Parser (Maybe String) +stringDecoder = fmap Text.unpack <$> textDecoder + +{-# NOINLINE stringFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +stringFieldDecoder :: FieldDecoder String +stringFieldDecoder = parsePgType "String" [textOid, varcharOid, nameOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell String type. Use a `Maybe String`" + Just bs -> Text.unpack <$> PBA.unsafeToUtf8Text 0 (BS.length bs) (PBA.fromByteString bs) + instance FromPgField String where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "String" [textOid, varcharOid, nameOid] $ \case - Nothing -> Left "Cannot decode SQL null as the Haskell String type. Use a `Maybe String`" - Just bs -> Text.unpack <$> PBA.unsafeToUtf8Text 0 (BS.length bs) (PBA.fromByteString bs) + fieldDecoder = stringFieldDecoder + + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just stringDecoder -- | This instance does not work if you have fillTypeInfoCache disabled (that would be a non-default -- connection option). @@ -1456,13 +1469,15 @@ instance FromPgField Aeson.Value where FieldDecoder { fieldValueDecoder = \FieldInfo {fieldTypeOid} -> - let -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in \case - Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls" - Just bs -> case Aeson.decodeStrict $ fixJsonb bs of - Just d -> Right d - Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", + let + -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in + \case + Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls" + Just bs -> case Aeson.decodeStrict $ fixJsonb bs of + Just d -> Right d + Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid } From 954dc8c3449f9d0b63c12ffb26b02f0223904691 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Thu, 17 Sep 2026 17:37:46 -0300 Subject: [PATCH 32/38] Apply same pattern to many more tests --- hpgsql-tests/EncodingDecodingSpec.hs | 90 +++++++++- hpgsql/src/Hpgsql/Encoding/Internal.hs | 219 +++++++++++++++++++------ 2 files changed, 257 insertions(+), 52 deletions(-) diff --git a/hpgsql-tests/EncodingDecodingSpec.hs b/hpgsql-tests/EncodingDecodingSpec.hs index f0d1bbb..5104a16 100644 --- a/hpgsql-tests/EncodingDecodingSpec.hs +++ b/hpgsql-tests/EncodingDecodingSpec.hs @@ -23,7 +23,7 @@ import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as LT import Data.Time (Day, DiffTime, LocalTime (..), NominalDiffTime, TimeOfDay, UTCTime (..), ZonedTime (..), fromGregorian, picosecondsToDiffTime, secondsToDiffTime, timeOfDayToTime, timeToTimeOfDay) import Data.Time.Format.ISO8601 (iso8601Show) -import Data.Time.LocalTime (CalendarDiffTime (..)) +import Data.Time.LocalTime (CalendarDiffTime (..), zonedTimeToUTC) import Data.UUID.Types (UUID) import qualified Data.UUID.Types as UUID import Data.Vector (Vector) @@ -142,6 +142,9 @@ spec = parallel $ do it "LocalTime text decoding" localTimeTextDecoding + it + "ZonedTime text decoding" + zonedTimeTextDecoding it "Json text decoding" jsonTextDecoding @@ -346,7 +349,32 @@ jsonValuesRoundTrip conn = hedgehog $ do dateDecoding :: HPgConnection -> IO () dateDecoding conn = do let rowRes = (fromGregorian 1999 12 31, fromGregorian 2010 01 01, fromGregorian 2011 07 04, fromGregorian 1981 03 17, NegInfinity @UTCTime, PosInfinity @UTCTime, NegInfinity @Day, PosInfinity @Day) - queryWith rowDecoder conn (mkQuery "SELECT '1999-12-31'::date, '2010-01-01'::date, '2011-07-04'::date, '1981-03-17'::date, '-infinity'::timestamptz, 'infinity'::timestamptz, '-infinity'::date, 'infinity'::date" ()) `shouldReturn` [rowRes] + qry = mkQuery "SELECT '1999-12-31'::date, '2010-01-01'::date, '2011-07-04'::date, '1981-03-17'::date, '-infinity'::timestamptz, 'infinity'::timestamptz, '-infinity'::date, 'infinity'::date" () + queryWith rowDecoder conn qry `shouldReturn` [rowRes] + -- Specialized row parsers of each type are a different implementation from + -- the simpler fieldDecoders, so we need to test both + queryWith + ( (,,,,,,,) + <$> singleField notRewrittenFieldDecoder + <*> singleField notRewrittenFieldDecoder + <*> singleField notRewrittenFieldDecoder + <*> singleField notRewrittenFieldDecoder + <*> singleField notRewrittenFieldDecoder + <*> singleField notRewrittenFieldDecoder + <*> singleField notRewrittenFieldDecoder + <*> singleField notRewrittenFieldDecoder + ) + conn + qry + `shouldReturn` [rowRes] + -- ZonedTime has no Eq instance, so Unbounded ZonedTime infinities are compared via zonedTimeToUTC + let zonedTimeInfinityQry = mkQuery "SELECT '-infinity'::timestamptz, 'infinity'::timestamptz" () + expectedZonedTimeInfinities = (NegInfinity @UTCTime, PosInfinity @UTCTime) + toUtcPair (a, b) = (fmap zonedTimeToUTC a, fmap zonedTimeToUTC b) + [ztRow1] <- queryWith (rowDecoder @(Unbounded ZonedTime, Unbounded ZonedTime)) conn zonedTimeInfinityQry + toUtcPair ztRow1 `shouldBe` expectedZonedTimeInfinities + [ztRow2] <- queryWith ((,) <$> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder) conn zonedTimeInfinityQry + toUtcPair ztRow2 `shouldBe` expectedZonedTimeInfinities dateEncoding :: HPgConnection -> IO () dateEncoding conn = do @@ -873,6 +901,64 @@ localTimeTextDecoding conn = hedgehog $ do res1Val === row res2Val === row +zonedTimeTextDecoding :: HPgConnection -> PropertyT IO () +zonedTimeTextDecoding conn = hedgehog $ do + let genUTCTime = do + year <- Gen.integral (Gen.linear 1 9999) + month <- Gen.int $ Gen.linear 1 12 + day <- Gen.int $ Gen.linear 1 28 + timeOfDayMicros <- Gen.integral $ Gen.linear 0 86_399_999_999 + pure $ UTCTime (fromGregorian year month day) (picosecondsToDiffTime (timeOfDayMicros * 1_000_000)) + row <- Gen.forAll $ (,,,,,,,,,) <$> genUTCTime <*> genUTCTime <*> genUTCTime <*> genUTCTime <*> genUTCTime <*> genUTCTime <*> genUTCTime <*> genUTCTime <*> genUTCTime <*> genUTCTime + let (ut1, ut2, ut3, ut4, ut5, ut6, ut7, ut8, ut9, ut10) = row + qry = + fromString $ + "SELECT '" + <> iso8601Show ut1 + <> "'::timestamptz" + <> ", '" + <> iso8601Show ut2 + <> "'::timestamptz" + <> ", '" + <> iso8601Show ut3 + <> "'::timestamptz" + <> ", '" + <> iso8601Show ut4 + <> "'::timestamptz" + <> ", '" + <> iso8601Show ut5 + <> "'::timestamptz" + <> ", '" + <> iso8601Show ut6 + <> "'::timestamptz" + <> ", '" + <> iso8601Show ut7 + <> "'::timestamptz" + <> ", '" + <> iso8601Show ut8 + <> "'::timestamptz" + <> ", '" + <> iso8601Show ut9 + <> "'::timestamptz" + <> ", '" + <> iso8601Show ut10 + <> "'::timestamptz" + -- ZonedTime has no Eq instance, so we compare the UTCTime each value represents instead. + let toComparable :: (ZonedTime, ZonedTime, ZonedTime, ZonedTime, ZonedTime, Unbounded ZonedTime, Unbounded ZonedTime, Unbounded ZonedTime, Unbounded ZonedTime, Unbounded ZonedTime) -> (UTCTime, UTCTime, UTCTime, UTCTime, UTCTime, Unbounded UTCTime, Unbounded UTCTime, Unbounded UTCTime, Unbounded UTCTime, Unbounded UTCTime) + toComparable (zt1, zt2, zt3, zt4, zt5, uzt1, uzt2, uzt3, uzt4, uzt5) = + (zonedTimeToUTC zt1, zonedTimeToUTC zt2, zonedTimeToUTC zt3, zonedTimeToUTC zt4, zonedTimeToUTC zt5, fmap zonedTimeToUTC uzt1, fmap zonedTimeToUTC uzt2, fmap zonedTimeToUTC uzt3, fmap zonedTimeToUTC uzt4, fmap zonedTimeToUTC uzt5) + expectedResult = (ut1, ut2, ut3, ut4, ut5, Finite ut6, Finite ut7, Finite ut8, Finite ut9, Finite ut10) + (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 notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder) qry + (toComparable <$> liftIO res1) >>= (=== expectedResult) + (toComparable <$> liftIO res2) >>= (=== expectedResult) + fieldDecoderSemigroup :: HPgConnection -> IO () fieldDecoderSemigroup conn = do let eitherIntOrText :: FieldDecoder (Either Int Text) diff --git a/hpgsql/src/Hpgsql/Encoding/Internal.hs b/hpgsql/src/Hpgsql/Encoding/Internal.hs index c306fa4..53cf8eb 100644 --- a/hpgsql/src/Hpgsql/Encoding/Internal.hs +++ b/hpgsql/src/Hpgsql/Encoding/Internal.hs @@ -171,6 +171,16 @@ instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in "singleField (nullableField int64FieldDecoder)" singleField (nullableField int64FieldDecoder) = fieldRowDecoder "singleField utcTimeFieldDecoder" singleField utcTimeFieldDecoder = fieldRowDecoder "singleField (nullableField utcTimeFieldDecoder)" singleField (nullableField utcTimeFieldDecoder) = fieldRowDecoder +"singleField unboundedUtcTimeFieldDecoder" singleField unboundedUtcTimeFieldDecoder = fieldRowDecoder +"singleField (nullableField unboundedUtcTimeFieldDecoder)" singleField (nullableField unboundedUtcTimeFieldDecoder) = fieldRowDecoder +"singleField zonedTimeFieldDecoder" singleField zonedTimeFieldDecoder = fieldRowDecoder +"singleField (nullableField zonedTimeFieldDecoder)" singleField (nullableField zonedTimeFieldDecoder) = fieldRowDecoder +"singleField unboundedZonedTimeFieldDecoder" singleField unboundedZonedTimeFieldDecoder = fieldRowDecoder +"singleField (nullableField unboundedZonedTimeFieldDecoder)" singleField (nullableField unboundedZonedTimeFieldDecoder) = fieldRowDecoder +"singleField localTimeFieldDecoder" singleField localTimeFieldDecoder = fieldRowDecoder +"singleField (nullableField localTimeFieldDecoder)" singleField (nullableField localTimeFieldDecoder) = fieldRowDecoder +"singleField timeOfDayFieldDecoder" singleField timeOfDayFieldDecoder = fieldRowDecoder +"singleField (nullableField timeOfDayFieldDecoder)" singleField (nullableField timeOfDayFieldDecoder) = fieldRowDecoder "singleField floatFieldDecoder" singleField floatFieldDecoder = fieldRowDecoder "singleField (nullableField floatFieldDecoder)" singleField (nullableField floatFieldDecoder) = fieldRowDecoder "singleField doubleFieldDecoder" singleField doubleFieldDecoder = fieldRowDecoder @@ -1315,70 +1325,179 @@ instance FromPgField UTCTime where {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just utcTimeRowDecoder +{-# INLINE unboundedUtcTimeRowDecoder #-} +unboundedUtcTimeRowDecoder :: Parser.Parser (Maybe (Unbounded UTCTime)) +unboundedUtcTimeRowDecoder = do + len <- Parser.takeInt32BE + case len of + 8 -> do + totalusecs <- Parser.takeInt64BE + pure $ + Just $ + if totalusecs == minBound + then NegInfinity + else + if totalusecs == maxBound + then PosInfinity + else + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + in Finite $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + _ -> pure Nothing + +{-# NOINLINE unboundedUtcTimeFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +unboundedUtcTimeFieldDecoder :: FieldDecoder (Unbounded UTCTime) +unboundedUtcTimeFieldDecoder = parsePgType "Unbounded UTCTime" [timestamptzOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell Unbounded UTCTime type. Use a `Maybe (Unbounded UTCTime)`" + Just bs -> do + -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 + totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString bs) + Right $ + if totalusecs == minBound + then NegInfinity + else + if totalusecs == maxBound + then PosInfinity + else + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + in Finite $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + instance FromPgField (Unbounded UTCTime) where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Unbounded UTCTime" [timestamptzOid] $ \case - Nothing -> Left "Cannot decode SQL null as the Haskell Unbounded UTCTime type. Use a `Maybe (Unbounded UTCTime)`" - Just bs -> do - -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString bs) - Right $ - if totalusecs == minBound - then NegInfinity - else - if totalusecs == maxBound - then PosInfinity - else - let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day - parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - in Finite $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + fieldDecoder = unboundedUtcTimeFieldDecoder -instance FromPgField ZonedTime where - {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "ZonedTime" [timestamptzOid] $ \case - Nothing -> Left "Cannot decode SQL null as the Haskell ZonedTime type. Use a `Maybe ZonedTime`" - Just bs -> do - -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString bs) + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just unboundedUtcTimeRowDecoder + +{-# INLINE zonedTimeRowDecoder #-} +zonedTimeRowDecoder :: Parser.Parser (Maybe ZonedTime) +zonedTimeRowDecoder = 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 - Right $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + pure $ Just $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + _ -> pure Nothing -instance FromPgField (Unbounded ZonedTime) where +{-# NOINLINE zonedTimeFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +zonedTimeFieldDecoder :: FieldDecoder ZonedTime +zonedTimeFieldDecoder = parsePgType "ZonedTime" [timestamptzOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell ZonedTime type. Use a `Maybe ZonedTime`" + Just bs -> do + -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 + totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString bs) + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + Right $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + +instance FromPgField ZonedTime where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "Unbounded ZonedTime" [timestamptzOid] $ \case - Nothing -> Left "Cannot decode SQL null as the Haskell Unbounded ZonedTime type. Use a `Maybe (Unbounded ZonedTime)`" - Just bs -> do - -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString bs) - Right $ - if totalusecs == minBound - then NegInfinity - else - if totalusecs == maxBound - then PosInfinity - else - let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day - parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - in Finite $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + fieldDecoder = zonedTimeFieldDecoder -instance FromPgField LocalTime where + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just zonedTimeRowDecoder + +{-# INLINE unboundedZonedTimeRowDecoder #-} +unboundedZonedTimeRowDecoder :: Parser.Parser (Maybe (Unbounded ZonedTime)) +unboundedZonedTimeRowDecoder = do + len <- Parser.takeInt32BE + case len of + 8 -> do + totalusecs <- Parser.takeInt64BE + pure $ + Just $ + if totalusecs == minBound + then NegInfinity + else + if totalusecs == maxBound + then PosInfinity + else + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + in Finite $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + _ -> pure Nothing + +{-# NOINLINE unboundedZonedTimeFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +unboundedZonedTimeFieldDecoder :: FieldDecoder (Unbounded ZonedTime) +unboundedZonedTimeFieldDecoder = parsePgType "Unbounded ZonedTime" [timestamptzOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell Unbounded ZonedTime type. Use a `Maybe (Unbounded ZonedTime)`" + Just bs -> do + -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 + totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString bs) + Right $ + if totalusecs == minBound + then NegInfinity + else + if totalusecs == maxBound + then PosInfinity + else + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + in Finite $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + +instance FromPgField (Unbounded ZonedTime) where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "LocalTime" [timestampOid] $ \case - Nothing -> Left "Cannot decode SQL null as the Haskell LocalTime type. Use a `Maybe LocalTime`" - Just bs -> do - totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString bs) + fieldDecoder = unboundedZonedTimeFieldDecoder + + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just unboundedZonedTimeRowDecoder + +{-# INLINE localTimeRowDecoder #-} +localTimeRowDecoder :: Parser.Parser (Maybe LocalTime) +localTimeRowDecoder = 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 - Right $ LocalTime parsedDate (timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + pure $ Just $ LocalTime parsedDate (timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + _ -> pure Nothing + +{-# NOINLINE localTimeFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +localTimeFieldDecoder :: FieldDecoder LocalTime +localTimeFieldDecoder = parsePgType "LocalTime" [timestampOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell LocalTime type. Use a `Maybe LocalTime`" + Just bs -> do + totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString bs) + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + Right $ LocalTime parsedDate (timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + +instance FromPgField LocalTime where + {-# INLINE fieldDecoder #-} + fieldDecoder = localTimeFieldDecoder + + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just localTimeRowDecoder + +{-# INLINE timeOfDayRowDecoder #-} +timeOfDayRowDecoder :: Parser.Parser (Maybe TimeOfDay) +timeOfDayRowDecoder = do + len <- Parser.takeInt32BE + case len of + 8 -> do + usecs <- Parser.takeInt64BE + pure $ Just $ timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral usecs * 1_000_000 + _ -> pure Nothing + +{-# NOINLINE timeOfDayFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +timeOfDayFieldDecoder :: FieldDecoder TimeOfDay +timeOfDayFieldDecoder = parsePgType "TimeOfDay" [timeOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell TimeOfDay type. Use a `Maybe TimeOfDay`" + Just bs -> do + usecs <- PBA.decodeInt64BE 0 (PBA.fromByteString bs) + Right $ timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral usecs * 1_000_000 instance FromPgField TimeOfDay where {-# INLINE fieldDecoder #-} - fieldDecoder = parsePgType "TimeOfDay" [timeOid] $ \case - Nothing -> Left "Cannot decode SQL null as the Haskell TimeOfDay type. Use a `Maybe TimeOfDay`" - Just bs -> do - usecs <- PBA.decodeInt64BE 0 (PBA.fromByteString bs) - Right $ timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral usecs * 1_000_000 + fieldDecoder = timeOfDayFieldDecoder + + {-# INLINE inlinedConstFieldDecoder #-} + inlinedConstFieldDecoder = Just timeOfDayRowDecoder {-# INLINE dayRowDecoder #-} dayRowDecoder :: Parser.Parser (Maybe Day) From 82d7d46636556c204bb62e52c3b5ebc4bc84336d Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Thu, 17 Sep 2026 17:50:51 -0300 Subject: [PATCH 33/38] Move each pair of rewrite rules closer to their inlined bindings --- hpgsql/src/Hpgsql/Encoding/Internal.hs | 349 ++++++++++++++----------- 1 file changed, 197 insertions(+), 152 deletions(-) diff --git a/hpgsql/src/Hpgsql/Encoding/Internal.hs b/hpgsql/src/Hpgsql/Encoding/Internal.hs index 53cf8eb..5f5527f 100644 --- a/hpgsql/src/Hpgsql/Encoding/Internal.hs +++ b/hpgsql/src/Hpgsql/Encoding/Internal.hs @@ -160,50 +160,11 @@ instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in -- benchmarks with "Generically derived" and "singleField fieldDecoder" row decoders both -- should allocate the same amount of memory. +-- Per-type rewrite rules for this Note live immediately above each type's +-- FieldDecoder/RowDecoder definitions further down this file. This rule right below +-- is still useful and triggers at call sites where the type is not known at +-- compile time. {-# RULES -"singleField intFieldDecoder" singleField intFieldDecoder = fieldRowDecoder -"singleField (nullableField intFieldDecoder)" singleField (nullableField intFieldDecoder) = fieldRowDecoder -"singleField int16FieldDecoder" singleField int16FieldDecoder = fieldRowDecoder -"singleField (nullableField int16FieldDecoder)" singleField (nullableField int16FieldDecoder) = fieldRowDecoder -"singleField int32FieldDecoder" singleField int32FieldDecoder = fieldRowDecoder -"singleField (nullableField int32FieldDecoder)" singleField (nullableField int32FieldDecoder) = fieldRowDecoder -"singleField int64FieldDecoder" singleField int64FieldDecoder = fieldRowDecoder -"singleField (nullableField int64FieldDecoder)" singleField (nullableField int64FieldDecoder) = fieldRowDecoder -"singleField utcTimeFieldDecoder" singleField utcTimeFieldDecoder = fieldRowDecoder -"singleField (nullableField utcTimeFieldDecoder)" singleField (nullableField utcTimeFieldDecoder) = fieldRowDecoder -"singleField unboundedUtcTimeFieldDecoder" singleField unboundedUtcTimeFieldDecoder = fieldRowDecoder -"singleField (nullableField unboundedUtcTimeFieldDecoder)" singleField (nullableField unboundedUtcTimeFieldDecoder) = fieldRowDecoder -"singleField zonedTimeFieldDecoder" singleField zonedTimeFieldDecoder = fieldRowDecoder -"singleField (nullableField zonedTimeFieldDecoder)" singleField (nullableField zonedTimeFieldDecoder) = fieldRowDecoder -"singleField unboundedZonedTimeFieldDecoder" singleField unboundedZonedTimeFieldDecoder = fieldRowDecoder -"singleField (nullableField unboundedZonedTimeFieldDecoder)" singleField (nullableField unboundedZonedTimeFieldDecoder) = fieldRowDecoder -"singleField localTimeFieldDecoder" singleField localTimeFieldDecoder = fieldRowDecoder -"singleField (nullableField localTimeFieldDecoder)" singleField (nullableField localTimeFieldDecoder) = fieldRowDecoder -"singleField timeOfDayFieldDecoder" singleField timeOfDayFieldDecoder = fieldRowDecoder -"singleField (nullableField timeOfDayFieldDecoder)" singleField (nullableField timeOfDayFieldDecoder) = fieldRowDecoder -"singleField floatFieldDecoder" singleField floatFieldDecoder = fieldRowDecoder -"singleField (nullableField floatFieldDecoder)" singleField (nullableField floatFieldDecoder) = fieldRowDecoder -"singleField doubleFieldDecoder" singleField doubleFieldDecoder = fieldRowDecoder -"singleField (nullableField doubleFieldDecoder)" singleField (nullableField doubleFieldDecoder) = fieldRowDecoder -"singleField boolFieldDecoder" singleField boolFieldDecoder = fieldRowDecoder -"singleField (nullableField boolFieldDecoder)" singleField (nullableField boolFieldDecoder) = fieldRowDecoder -"singleField textFieldDecoder" singleField textFieldDecoder = fieldRowDecoder -"singleField (nullableField textFieldDecoder)" singleField (nullableField textFieldDecoder) = fieldRowDecoder -"singleField lazyTextFieldDecoder" singleField lazyTextFieldDecoder = fieldRowDecoder -"singleField (nullableField lazyTextFieldDecoder)" singleField (nullableField lazyTextFieldDecoder) = fieldRowDecoder -"singleField stringFieldDecoder" singleField stringFieldDecoder = fieldRowDecoder -"singleField (nullableField stringFieldDecoder)" singleField (nullableField stringFieldDecoder) = fieldRowDecoder -"singleField dayFieldDecoder" singleField dayFieldDecoder = fieldRowDecoder -"singleField (nullableField dayFieldDecoder)" singleField (nullableField dayFieldDecoder) = fieldRowDecoder -"singleField scientificFieldDecoder" singleField scientificFieldDecoder = fieldRowDecoder -"singleField (nullableField scientificFieldDecoder)" singleField (nullableField scientificFieldDecoder) = fieldRowDecoder -"singleField unboundedDayFieldDecoder" singleField unboundedDayFieldDecoder = fieldRowDecoder -"singleField (nullableField unboundedDayFieldDecoder)" singleField (nullableField unboundedDayFieldDecoder) = fieldRowDecoder -"singleField calendarDiffTimeFieldDecoder" singleField calendarDiffTimeFieldDecoder = fieldRowDecoder -"singleField (nullableField calendarDiffTimeFieldDecoder)" singleField (nullableField calendarDiffTimeFieldDecoder) = fieldRowDecoder -"singleField uuidFieldDecoder" singleField uuidFieldDecoder = fieldRowDecoder -"singleField (nullableField uuidFieldDecoder)" singleField (nullableField uuidFieldDecoder) = fieldRowDecoder --- This last rule is still useful and triggers at call sites where the type is not known at compile time "singleField fieldDecoder" singleField fieldDecoder = fieldRowDecoder "singleField (nullableField fieldDecoder)" singleField (nullableField fieldDecoder) = fieldRowDecoder #-} @@ -915,6 +876,10 @@ instance FromPgField () where allowedPgTypes = (== voidOid) . fieldTypeOid } +{-# RULES +"singleField intFieldDecoder" singleField intFieldDecoder = fieldRowDecoder +"singleField (nullableField intFieldDecoder)" singleField (nullableField intFieldDecoder) = fieldRowDecoder + #-} {-# NOINLINE intFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] intFieldDecoder :: FieldDecoder Int intFieldDecoder = @@ -946,6 +911,10 @@ instance FromPgField Int where _ -> Just . fromIntegral <$> Parser.takeInt64BE else fmap fromIntegral <$> Parser.takeInt16BEWithFieldLength +{-# RULES +"singleField int16FieldDecoder" singleField int16FieldDecoder = fieldRowDecoder +"singleField (nullableField int16FieldDecoder)" singleField (nullableField int16FieldDecoder) = fieldRowDecoder + #-} {-# NOINLINE int16FieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] int16FieldDecoder :: FieldDecoder Int16 int16FieldDecoder = @@ -964,6 +933,10 @@ instance FromPgField Int16 where {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just Parser.takeInt16BEWithFieldLength +{-# RULES +"singleField int32FieldDecoder" singleField int32FieldDecoder = fieldRowDecoder +"singleField (nullableField int32FieldDecoder)" singleField (nullableField int32FieldDecoder) = fieldRowDecoder + #-} {-# NOINLINE int32FieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] int32FieldDecoder :: FieldDecoder Int32 int32FieldDecoder = @@ -988,6 +961,10 @@ instance FromPgField Int32 where 2 -> Just . fromIntegral <$> Parser.takeInt16BE _ -> fail "Trying to decode PG int4 but it's not 2 or 4 bytes long" +{-# RULES +"singleField int64FieldDecoder" singleField int64FieldDecoder = fieldRowDecoder +"singleField (nullableField int64FieldDecoder)" singleField (nullableField int64FieldDecoder) = fieldRowDecoder + #-} {-# NOINLINE int64FieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] int64FieldDecoder :: FieldDecoder Int64 int64FieldDecoder = @@ -1044,6 +1021,10 @@ instance FromPgField Oid where allowedPgTypes = (== oidOid) . fieldTypeOid } +{-# RULES +"singleField floatFieldDecoder" singleField floatFieldDecoder = fieldRowDecoder +"singleField (nullableField floatFieldDecoder)" singleField (nullableField floatFieldDecoder) = fieldRowDecoder + #-} {-# NOINLINE floatFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] floatFieldDecoder :: FieldDecoder Float floatFieldDecoder = parsePgType "Float" [float4Oid] $ \case @@ -1057,15 +1038,10 @@ instance FromPgField Float where {-# 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 - +{-# RULES +"singleField doubleFieldDecoder" singleField doubleFieldDecoder = fieldRowDecoder +"singleField (nullableField doubleFieldDecoder)" singleField (nullableField doubleFieldDecoder) = fieldRowDecoder + #-} {-# NOINLINE doubleFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] doubleFieldDecoder :: FieldDecoder Double doubleFieldDecoder = @@ -1080,6 +1056,15 @@ doubleFieldDecoder = allowedPgTypes = (`elem` [float8Oid, float4Oid]) . fieldTypeOid } +{-# 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 = doubleFieldDecoder @@ -1136,6 +1121,10 @@ numericRowParser = do (-1) -> pure Nothing _ -> Just <$> scientificDecoder False +{-# RULES +"singleField scientificFieldDecoder" singleField scientificFieldDecoder = fieldRowDecoder +"singleField (nullableField scientificFieldDecoder)" singleField (nullableField scientificFieldDecoder) = fieldRowDecoder + #-} {-# NOINLINE scientificFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] scientificFieldDecoder :: FieldDecoder Scientific scientificFieldDecoder = @@ -1176,16 +1165,20 @@ instance FromPgField (Ratio Integer) where binaryTrue :: PinnedByteArray binaryTrue = PBA.fromByteString $ PBA.encodePgBoolean True -{-# INLINE boolRowDecoder #-} -boolRowDecoder :: Parser.Parser (Maybe Bool) -boolRowDecoder = fmap (== 1) <$> Parser.parsePgFieldWithAtMost4Bytes PBA.TypeSize1 - +{-# RULES +"singleField boolFieldDecoder" singleField boolFieldDecoder = fieldRowDecoder +"singleField (nullableField boolFieldDecoder)" singleField (nullableField boolFieldDecoder) = fieldRowDecoder + #-} {-# NOINLINE boolFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] boolFieldDecoder :: FieldDecoder Bool boolFieldDecoder = parsePgType "Bool" [boolOid] $ \case Nothing -> Left "Cannot decode SQL null as the Haskell Bool type. Use a `Maybe Bool`" Just bs -> Right $ PBA.fromByteString bs == binaryTrue +{-# INLINE boolRowDecoder #-} +boolRowDecoder :: Parser.Parser (Maybe Bool) +boolRowDecoder = fmap (== 1) <$> Parser.parsePgFieldWithAtMost4Bytes PBA.TypeSize1 + instance FromPgField Bool where {-# INLINE fieldDecoder #-} fieldDecoder = boolFieldDecoder @@ -1224,6 +1217,16 @@ instance FromPgField LBS.ByteString where Nothing -> Left "Cannot decode SQL null as the Haskell ByteString type. Use a `Maybe ByteString`" Just bs -> Right $ LBS.fromStrict bs +{-# RULES +"singleField textFieldDecoder" singleField textFieldDecoder = fieldRowDecoder +"singleField (nullableField textFieldDecoder)" singleField (nullableField textFieldDecoder) = fieldRowDecoder + #-} +{-# NOINLINE textFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +textFieldDecoder :: FieldDecoder Text +textFieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell Text type. Use a `Maybe Text`" + Just bs -> PBA.unsafeToUtf8Text 0 (BS.length bs) (PBA.fromByteString bs) + {-# INLINE textDecoder #-} textDecoder :: Parser.Parser (Maybe Text) textDecoder = do @@ -1232,12 +1235,6 @@ textDecoder = do then Just <$> Parser.takeUtf8Text (fromIntegral len) else pure Nothing -{-# NOINLINE textFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] -textFieldDecoder :: FieldDecoder Text -textFieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \case - Nothing -> Left "Cannot decode SQL null as the Haskell Text type. Use a `Maybe Text`" - Just bs -> PBA.unsafeToUtf8Text 0 (BS.length bs) (PBA.fromByteString bs) - instance FromPgField Text where {-# INLINE fieldDecoder #-} fieldDecoder = textFieldDecoder @@ -1245,14 +1242,18 @@ instance FromPgField Text where {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just textDecoder -{-# INLINE lazyTextDecoder #-} -lazyTextDecoder :: Parser.Parser (Maybe LT.Text) -lazyTextDecoder = fmap LT.fromStrict <$> textDecoder - +{-# RULES +"singleField lazyTextFieldDecoder" singleField lazyTextFieldDecoder = fieldRowDecoder +"singleField (nullableField lazyTextFieldDecoder)" singleField (nullableField lazyTextFieldDecoder) = fieldRowDecoder + #-} {-# NOINLINE lazyTextFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] lazyTextFieldDecoder :: FieldDecoder LT.Text lazyTextFieldDecoder = LT.fromStrict <$> textFieldDecoder +{-# INLINE lazyTextDecoder #-} +lazyTextDecoder :: Parser.Parser (Maybe LT.Text) +lazyTextDecoder = fmap LT.fromStrict <$> textDecoder + instance FromPgField LT.Text where {-# INLINE fieldDecoder #-} fieldDecoder = lazyTextFieldDecoder @@ -1260,16 +1261,20 @@ instance FromPgField LT.Text where {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just lazyTextDecoder -{-# INLINE stringDecoder #-} -stringDecoder :: Parser.Parser (Maybe String) -stringDecoder = fmap Text.unpack <$> textDecoder - +{-# RULES +"singleField stringFieldDecoder" singleField stringFieldDecoder = fieldRowDecoder +"singleField (nullableField stringFieldDecoder)" singleField (nullableField stringFieldDecoder) = fieldRowDecoder + #-} {-# NOINLINE stringFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] stringFieldDecoder :: FieldDecoder String stringFieldDecoder = parsePgType "String" [textOid, varcharOid, nameOid] $ \case Nothing -> Left "Cannot decode SQL null as the Haskell String type. Use a `Maybe String`" Just bs -> Text.unpack <$> PBA.unsafeToUtf8Text 0 (BS.length bs) (PBA.fromByteString bs) +{-# INLINE stringDecoder #-} +stringDecoder :: Parser.Parser (Maybe String) +stringDecoder = fmap Text.unpack <$> textDecoder + instance FromPgField String where {-# INLINE fieldDecoder #-} fieldDecoder = stringFieldDecoder @@ -1295,6 +1300,21 @@ instance FromPgField (CI String) where {-# INLINE fieldDecoder #-} fieldDecoder = typeFieldDecoder (typeMustBeNamed "citext") $ CI.mk <$> fieldDecoder +{-# RULES +"singleField utcTimeFieldDecoder" singleField utcTimeFieldDecoder = fieldRowDecoder +"singleField (nullableField utcTimeFieldDecoder)" singleField (nullableField utcTimeFieldDecoder) = fieldRowDecoder + #-} +{-# NOINLINE utcTimeFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +utcTimeFieldDecoder :: FieldDecoder UTCTime +utcTimeFieldDecoder = parsePgType "UTCTime" [timestamptzOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell UTCTime type. Use a `Maybe UTCTime`" + Just bs -> do + -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 + totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString bs) + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + Right $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + {-# INLINE utcTimeRowDecoder #-} utcTimeRowDecoder :: Parser.Parser (Maybe UTCTime) utcTimeRowDecoder = do @@ -1307,17 +1327,6 @@ utcTimeRowDecoder = do pure $ Just $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) _ -> pure Nothing -{-# NOINLINE utcTimeFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] -utcTimeFieldDecoder :: FieldDecoder UTCTime -utcTimeFieldDecoder = parsePgType "UTCTime" [timestamptzOid] $ \case - Nothing -> Left "Cannot decode SQL null as the Haskell UTCTime type. Use a `Maybe UTCTime`" - Just bs -> do - -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString 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) - instance FromPgField UTCTime where {-# INLINE fieldDecoder #-} fieldDecoder = utcTimeFieldDecoder @@ -1325,6 +1334,28 @@ instance FromPgField UTCTime where {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just utcTimeRowDecoder +{-# RULES +"singleField unboundedUtcTimeFieldDecoder" singleField unboundedUtcTimeFieldDecoder = fieldRowDecoder +"singleField (nullableField unboundedUtcTimeFieldDecoder)" singleField (nullableField unboundedUtcTimeFieldDecoder) = fieldRowDecoder + #-} +{-# NOINLINE unboundedUtcTimeFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +unboundedUtcTimeFieldDecoder :: FieldDecoder (Unbounded UTCTime) +unboundedUtcTimeFieldDecoder = parsePgType "Unbounded UTCTime" [timestamptzOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell Unbounded UTCTime type. Use a `Maybe (Unbounded UTCTime)`" + Just bs -> do + -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 + totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString bs) + Right $ + if totalusecs == minBound + then NegInfinity + else + if totalusecs == maxBound + then PosInfinity + else + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + in Finite $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + {-# INLINE unboundedUtcTimeRowDecoder #-} unboundedUtcTimeRowDecoder :: Parser.Parser (Maybe (Unbounded UTCTime)) unboundedUtcTimeRowDecoder = do @@ -1345,24 +1376,6 @@ unboundedUtcTimeRowDecoder = do in Finite $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) _ -> pure Nothing -{-# NOINLINE unboundedUtcTimeFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] -unboundedUtcTimeFieldDecoder :: FieldDecoder (Unbounded UTCTime) -unboundedUtcTimeFieldDecoder = parsePgType "Unbounded UTCTime" [timestamptzOid] $ \case - Nothing -> Left "Cannot decode SQL null as the Haskell Unbounded UTCTime type. Use a `Maybe (Unbounded UTCTime)`" - Just bs -> do - -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString bs) - Right $ - if totalusecs == minBound - then NegInfinity - else - if totalusecs == maxBound - then PosInfinity - else - let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day - parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - in Finite $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - instance FromPgField (Unbounded UTCTime) where {-# INLINE fieldDecoder #-} fieldDecoder = unboundedUtcTimeFieldDecoder @@ -1370,6 +1383,21 @@ instance FromPgField (Unbounded UTCTime) where {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just unboundedUtcTimeRowDecoder +{-# RULES +"singleField zonedTimeFieldDecoder" singleField zonedTimeFieldDecoder = fieldRowDecoder +"singleField (nullableField zonedTimeFieldDecoder)" singleField (nullableField zonedTimeFieldDecoder) = fieldRowDecoder + #-} +{-# NOINLINE zonedTimeFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +zonedTimeFieldDecoder :: FieldDecoder ZonedTime +zonedTimeFieldDecoder = parsePgType "ZonedTime" [timestamptzOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell ZonedTime type. Use a `Maybe ZonedTime`" + Just bs -> do + -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 + totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString 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) + {-# INLINE zonedTimeRowDecoder #-} zonedTimeRowDecoder :: Parser.Parser (Maybe ZonedTime) zonedTimeRowDecoder = do @@ -1382,17 +1410,6 @@ zonedTimeRowDecoder = do pure $ Just $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) _ -> pure Nothing -{-# NOINLINE zonedTimeFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] -zonedTimeFieldDecoder :: FieldDecoder ZonedTime -zonedTimeFieldDecoder = parsePgType "ZonedTime" [timestamptzOid] $ \case - Nothing -> Left "Cannot decode SQL null as the Haskell ZonedTime type. Use a `Maybe ZonedTime`" - Just bs -> do - -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString bs) - let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day - parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - Right $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - instance FromPgField ZonedTime where {-# INLINE fieldDecoder #-} fieldDecoder = zonedTimeFieldDecoder @@ -1400,6 +1417,28 @@ instance FromPgField ZonedTime where {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just zonedTimeRowDecoder +{-# RULES +"singleField unboundedZonedTimeFieldDecoder" singleField unboundedZonedTimeFieldDecoder = fieldRowDecoder +"singleField (nullableField unboundedZonedTimeFieldDecoder)" singleField (nullableField unboundedZonedTimeFieldDecoder) = fieldRowDecoder + #-} +{-# NOINLINE unboundedZonedTimeFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +unboundedZonedTimeFieldDecoder :: FieldDecoder (Unbounded ZonedTime) +unboundedZonedTimeFieldDecoder = parsePgType "Unbounded ZonedTime" [timestamptzOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell Unbounded ZonedTime type. Use a `Maybe (Unbounded ZonedTime)`" + Just bs -> do + -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 + totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString bs) + Right $ + if totalusecs == minBound + then NegInfinity + else + if totalusecs == maxBound + then PosInfinity + else + let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day + parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 + in Finite $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) + {-# INLINE unboundedZonedTimeRowDecoder #-} unboundedZonedTimeRowDecoder :: Parser.Parser (Maybe (Unbounded ZonedTime)) unboundedZonedTimeRowDecoder = do @@ -1420,24 +1459,6 @@ unboundedZonedTimeRowDecoder = do in Finite $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) _ -> pure Nothing -{-# NOINLINE unboundedZonedTimeFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] -unboundedZonedTimeFieldDecoder :: FieldDecoder (Unbounded ZonedTime) -unboundedZonedTimeFieldDecoder = parsePgType "Unbounded ZonedTime" [timestamptzOid] $ \case - Nothing -> Left "Cannot decode SQL null as the Haskell Unbounded ZonedTime type. Use a `Maybe (Unbounded ZonedTime)`" - Just bs -> do - -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909 - totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString bs) - Right $ - if totalusecs == minBound - then NegInfinity - else - if totalusecs == maxBound - then PosInfinity - else - let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day - parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - in Finite $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - instance FromPgField (Unbounded ZonedTime) where {-# INLINE fieldDecoder #-} fieldDecoder = unboundedZonedTimeFieldDecoder @@ -1445,6 +1466,20 @@ instance FromPgField (Unbounded ZonedTime) where {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just unboundedZonedTimeRowDecoder +{-# RULES +"singleField localTimeFieldDecoder" singleField localTimeFieldDecoder = fieldRowDecoder +"singleField (nullableField localTimeFieldDecoder)" singleField (nullableField localTimeFieldDecoder) = fieldRowDecoder + #-} +{-# NOINLINE localTimeFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +localTimeFieldDecoder :: FieldDecoder LocalTime +localTimeFieldDecoder = parsePgType "LocalTime" [timestampOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell LocalTime type. Use a `Maybe LocalTime`" + Just bs -> do + totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString 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) + {-# INLINE localTimeRowDecoder #-} localTimeRowDecoder :: Parser.Parser (Maybe LocalTime) localTimeRowDecoder = do @@ -1457,16 +1492,6 @@ localTimeRowDecoder = do pure $ Just $ LocalTime parsedDate (timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) _ -> pure Nothing -{-# NOINLINE localTimeFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] -localTimeFieldDecoder :: FieldDecoder LocalTime -localTimeFieldDecoder = parsePgType "LocalTime" [timestampOid] $ \case - Nothing -> Left "Cannot decode SQL null as the Haskell LocalTime type. Use a `Maybe LocalTime`" - Just bs -> do - totalusecs <- PBA.decodeInt64BE 0 (PBA.fromByteString bs) - let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day - parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 - Right $ LocalTime parsedDate (timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000) - instance FromPgField LocalTime where {-# INLINE fieldDecoder #-} fieldDecoder = localTimeFieldDecoder @@ -1474,6 +1499,18 @@ instance FromPgField LocalTime where {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just localTimeRowDecoder +{-# RULES +"singleField timeOfDayFieldDecoder" singleField timeOfDayFieldDecoder = fieldRowDecoder +"singleField (nullableField timeOfDayFieldDecoder)" singleField (nullableField timeOfDayFieldDecoder) = fieldRowDecoder + #-} +{-# NOINLINE timeOfDayFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +timeOfDayFieldDecoder :: FieldDecoder TimeOfDay +timeOfDayFieldDecoder = parsePgType "TimeOfDay" [timeOid] $ \case + Nothing -> Left "Cannot decode SQL null as the Haskell TimeOfDay type. Use a `Maybe TimeOfDay`" + Just bs -> do + usecs <- PBA.decodeInt64BE 0 (PBA.fromByteString bs) + Right $ timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral usecs * 1_000_000 + {-# INLINE timeOfDayRowDecoder #-} timeOfDayRowDecoder :: Parser.Parser (Maybe TimeOfDay) timeOfDayRowDecoder = do @@ -1484,14 +1521,6 @@ timeOfDayRowDecoder = do pure $ Just $ timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral usecs * 1_000_000 _ -> pure Nothing -{-# NOINLINE timeOfDayFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] -timeOfDayFieldDecoder :: FieldDecoder TimeOfDay -timeOfDayFieldDecoder = parsePgType "TimeOfDay" [timeOid] $ \case - Nothing -> Left "Cannot decode SQL null as the Haskell TimeOfDay type. Use a `Maybe TimeOfDay`" - Just bs -> do - usecs <- PBA.decodeInt64BE 0 (PBA.fromByteString bs) - Right $ timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral usecs * 1_000_000 - instance FromPgField TimeOfDay where {-# INLINE fieldDecoder #-} fieldDecoder = timeOfDayFieldDecoder @@ -1499,12 +1528,10 @@ instance FromPgField TimeOfDay where {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just timeOfDayRowDecoder -{-# 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 - +{-# RULES +"singleField dayFieldDecoder" singleField dayFieldDecoder = fieldRowDecoder +"singleField (nullableField dayFieldDecoder)" singleField (nullableField dayFieldDecoder) = fieldRowDecoder + #-} {-# NOINLINE dayFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] dayFieldDecoder :: FieldDecoder Day dayFieldDecoder = parsePgType "Day" [dateOid] $ \case @@ -1516,6 +1543,12 @@ dayFieldDecoder = parsePgType "Day" [dateOid] $ \case jd <- PBA.decodeInt32BE 0 (PBA.fromByteString bs) Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 +{-# INLINE dayRowDecoder #-} +dayRowDecoder :: Parser.Parser (Maybe Day) +dayRowDecoder = + let int32ToDay (i32 :: Int32) = let jd = fromIntegral i32 :: Integer in addJulianDurationClip (CalendarDiffDays 0 (jd - 13)) $ fromJulian 2000 01 01 + in fmap int32ToDay <$> Parser.takeInt32BEWithFieldLength + instance FromPgField Day where {-# INLINE fieldDecoder #-} fieldDecoder = dayFieldDecoder @@ -1523,6 +1556,10 @@ instance FromPgField Day where {-# INLINE inlinedConstFieldDecoder #-} inlinedConstFieldDecoder = Just dayRowDecoder +{-# RULES +"singleField unboundedDayFieldDecoder" singleField unboundedDayFieldDecoder = fieldRowDecoder +"singleField (nullableField unboundedDayFieldDecoder)" singleField (nullableField unboundedDayFieldDecoder) = fieldRowDecoder + #-} {-# NOINLINE unboundedDayFieldDecoder #-} unboundedDayFieldDecoder :: FieldDecoder (Unbounded Day) unboundedDayFieldDecoder = parsePgType "Unbounded Day" [dateOid] $ \case @@ -1545,6 +1582,10 @@ instance FromPgField (Unbounded Day) where {-# INLINE fieldDecoder #-} fieldDecoder = unboundedDayFieldDecoder +{-# RULES +"singleField calendarDiffTimeFieldDecoder" singleField calendarDiffTimeFieldDecoder = fieldRowDecoder +"singleField (nullableField calendarDiffTimeFieldDecoder)" singleField (nullableField calendarDiffTimeFieldDecoder) = fieldRowDecoder + #-} {-# NOINLINE calendarDiffTimeFieldDecoder #-} calendarDiffTimeFieldDecoder :: FieldDecoder CalendarDiffTime calendarDiffTimeFieldDecoder = parsePgType "CalendarDiffTime " [intervalOid] $ \case @@ -1560,6 +1601,10 @@ instance FromPgField CalendarDiffTime where {-# INLINE fieldDecoder #-} fieldDecoder = calendarDiffTimeFieldDecoder +{-# RULES +"singleField uuidFieldDecoder" singleField uuidFieldDecoder = fieldRowDecoder +"singleField (nullableField uuidFieldDecoder)" singleField (nullableField uuidFieldDecoder) = fieldRowDecoder + #-} {-# NOINLINE uuidFieldDecoder #-} uuidFieldDecoder :: FieldDecoder UUID uuidFieldDecoder = parsePgType "UUID" [uuidOid] $ \case From edb7f8902d4e3b1cea6e795d431fa0ce70207fa5 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Thu, 17 Sep 2026 17:52:27 -0300 Subject: [PATCH 34/38] The `Int` parser can be simplified a bit --- hpgsql/src/Hpgsql/Encoding/Internal.hs | 27 +++++++++++++++++++++----- 1 file changed, 22 insertions(+), 5 deletions(-) diff --git a/hpgsql/src/Hpgsql/Encoding/Internal.hs b/hpgsql/src/Hpgsql/Encoding/Internal.hs index 5f5527f..5b8a448 100644 --- a/hpgsql/src/Hpgsql/Encoding/Internal.hs +++ b/hpgsql/src/Hpgsql/Encoding/Internal.hs @@ -880,6 +880,7 @@ instance FromPgField () where "singleField intFieldDecoder" singleField intFieldDecoder = fieldRowDecoder "singleField (nullableField intFieldDecoder)" singleField (nullableField intFieldDecoder) = fieldRowDecoder #-} + {-# NOINLINE intFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] intFieldDecoder :: FieldDecoder Int intFieldDecoder = @@ -904,17 +905,14 @@ instance FromPgField Int where then fmap fromIntegral <$> Parser.takeInt32BEWithFieldLength else if finfo.fieldTypeOid == int8Oid - then do - fieldLen <- Parser.takeInt32BE - case fieldLen of - (-1) -> pure Nothing - _ -> Just . fromIntegral <$> Parser.takeInt64BE + then fmap fromIntegral <$> Parser.takeInt64BEWithFieldLength else fmap fromIntegral <$> Parser.takeInt16BEWithFieldLength {-# RULES "singleField int16FieldDecoder" singleField int16FieldDecoder = fieldRowDecoder "singleField (nullableField int16FieldDecoder)" singleField (nullableField int16FieldDecoder) = fieldRowDecoder #-} + {-# NOINLINE int16FieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] int16FieldDecoder :: FieldDecoder Int16 int16FieldDecoder = @@ -937,6 +935,7 @@ instance FromPgField Int16 where "singleField int32FieldDecoder" singleField int32FieldDecoder = fieldRowDecoder "singleField (nullableField int32FieldDecoder)" singleField (nullableField int32FieldDecoder) = fieldRowDecoder #-} + {-# NOINLINE int32FieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] int32FieldDecoder :: FieldDecoder Int32 int32FieldDecoder = @@ -965,6 +964,7 @@ instance FromPgField Int32 where "singleField int64FieldDecoder" singleField int64FieldDecoder = fieldRowDecoder "singleField (nullableField int64FieldDecoder)" singleField (nullableField int64FieldDecoder) = fieldRowDecoder #-} + {-# NOINLINE int64FieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] int64FieldDecoder :: FieldDecoder Int64 int64FieldDecoder = @@ -1025,6 +1025,7 @@ instance FromPgField Oid where "singleField floatFieldDecoder" singleField floatFieldDecoder = fieldRowDecoder "singleField (nullableField floatFieldDecoder)" singleField (nullableField floatFieldDecoder) = fieldRowDecoder #-} + {-# NOINLINE floatFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] floatFieldDecoder :: FieldDecoder Float floatFieldDecoder = parsePgType "Float" [float4Oid] $ \case @@ -1042,6 +1043,7 @@ instance FromPgField Float where "singleField doubleFieldDecoder" singleField doubleFieldDecoder = fieldRowDecoder "singleField (nullableField doubleFieldDecoder)" singleField (nullableField doubleFieldDecoder) = fieldRowDecoder #-} + {-# NOINLINE doubleFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] doubleFieldDecoder :: FieldDecoder Double doubleFieldDecoder = @@ -1125,6 +1127,7 @@ numericRowParser = do "singleField scientificFieldDecoder" singleField scientificFieldDecoder = fieldRowDecoder "singleField (nullableField scientificFieldDecoder)" singleField (nullableField scientificFieldDecoder) = fieldRowDecoder #-} + {-# NOINLINE scientificFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] scientificFieldDecoder :: FieldDecoder Scientific scientificFieldDecoder = @@ -1169,6 +1172,7 @@ binaryTrue = PBA.fromByteString $ PBA.encodePgBoolean True "singleField boolFieldDecoder" singleField boolFieldDecoder = fieldRowDecoder "singleField (nullableField boolFieldDecoder)" singleField (nullableField boolFieldDecoder) = fieldRowDecoder #-} + {-# NOINLINE boolFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] boolFieldDecoder :: FieldDecoder Bool boolFieldDecoder = parsePgType "Bool" [boolOid] $ \case @@ -1221,6 +1225,7 @@ instance FromPgField LBS.ByteString where "singleField textFieldDecoder" singleField textFieldDecoder = fieldRowDecoder "singleField (nullableField textFieldDecoder)" singleField (nullableField textFieldDecoder) = fieldRowDecoder #-} + {-# NOINLINE textFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] textFieldDecoder :: FieldDecoder Text textFieldDecoder = parsePgType "Text" [textOid, varcharOid, nameOid] $ \case @@ -1246,6 +1251,7 @@ instance FromPgField Text where "singleField lazyTextFieldDecoder" singleField lazyTextFieldDecoder = fieldRowDecoder "singleField (nullableField lazyTextFieldDecoder)" singleField (nullableField lazyTextFieldDecoder) = fieldRowDecoder #-} + {-# NOINLINE lazyTextFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] lazyTextFieldDecoder :: FieldDecoder LT.Text lazyTextFieldDecoder = LT.fromStrict <$> textFieldDecoder @@ -1265,6 +1271,7 @@ instance FromPgField LT.Text where "singleField stringFieldDecoder" singleField stringFieldDecoder = fieldRowDecoder "singleField (nullableField stringFieldDecoder)" singleField (nullableField stringFieldDecoder) = fieldRowDecoder #-} + {-# NOINLINE stringFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] stringFieldDecoder :: FieldDecoder String stringFieldDecoder = parsePgType "String" [textOid, varcharOid, nameOid] $ \case @@ -1304,6 +1311,7 @@ instance FromPgField (CI String) where "singleField utcTimeFieldDecoder" singleField utcTimeFieldDecoder = fieldRowDecoder "singleField (nullableField utcTimeFieldDecoder)" singleField (nullableField utcTimeFieldDecoder) = fieldRowDecoder #-} + {-# NOINLINE utcTimeFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] utcTimeFieldDecoder :: FieldDecoder UTCTime utcTimeFieldDecoder = parsePgType "UTCTime" [timestamptzOid] $ \case @@ -1338,6 +1346,7 @@ instance FromPgField UTCTime where "singleField unboundedUtcTimeFieldDecoder" singleField unboundedUtcTimeFieldDecoder = fieldRowDecoder "singleField (nullableField unboundedUtcTimeFieldDecoder)" singleField (nullableField unboundedUtcTimeFieldDecoder) = fieldRowDecoder #-} + {-# NOINLINE unboundedUtcTimeFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] unboundedUtcTimeFieldDecoder :: FieldDecoder (Unbounded UTCTime) unboundedUtcTimeFieldDecoder = parsePgType "Unbounded UTCTime" [timestamptzOid] $ \case @@ -1387,6 +1396,7 @@ instance FromPgField (Unbounded UTCTime) where "singleField zonedTimeFieldDecoder" singleField zonedTimeFieldDecoder = fieldRowDecoder "singleField (nullableField zonedTimeFieldDecoder)" singleField (nullableField zonedTimeFieldDecoder) = fieldRowDecoder #-} + {-# NOINLINE zonedTimeFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] zonedTimeFieldDecoder :: FieldDecoder ZonedTime zonedTimeFieldDecoder = parsePgType "ZonedTime" [timestamptzOid] $ \case @@ -1421,6 +1431,7 @@ instance FromPgField ZonedTime where "singleField unboundedZonedTimeFieldDecoder" singleField unboundedZonedTimeFieldDecoder = fieldRowDecoder "singleField (nullableField unboundedZonedTimeFieldDecoder)" singleField (nullableField unboundedZonedTimeFieldDecoder) = fieldRowDecoder #-} + {-# NOINLINE unboundedZonedTimeFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] unboundedZonedTimeFieldDecoder :: FieldDecoder (Unbounded ZonedTime) unboundedZonedTimeFieldDecoder = parsePgType "Unbounded ZonedTime" [timestamptzOid] $ \case @@ -1470,6 +1481,7 @@ instance FromPgField (Unbounded ZonedTime) where "singleField localTimeFieldDecoder" singleField localTimeFieldDecoder = fieldRowDecoder "singleField (nullableField localTimeFieldDecoder)" singleField (nullableField localTimeFieldDecoder) = fieldRowDecoder #-} + {-# NOINLINE localTimeFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] localTimeFieldDecoder :: FieldDecoder LocalTime localTimeFieldDecoder = parsePgType "LocalTime" [timestampOid] $ \case @@ -1503,6 +1515,7 @@ instance FromPgField LocalTime where "singleField timeOfDayFieldDecoder" singleField timeOfDayFieldDecoder = fieldRowDecoder "singleField (nullableField timeOfDayFieldDecoder)" singleField (nullableField timeOfDayFieldDecoder) = fieldRowDecoder #-} + {-# NOINLINE timeOfDayFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] timeOfDayFieldDecoder :: FieldDecoder TimeOfDay timeOfDayFieldDecoder = parsePgType "TimeOfDay" [timeOid] $ \case @@ -1532,6 +1545,7 @@ instance FromPgField TimeOfDay where "singleField dayFieldDecoder" singleField dayFieldDecoder = fieldRowDecoder "singleField (nullableField dayFieldDecoder)" singleField (nullableField dayFieldDecoder) = fieldRowDecoder #-} + {-# NOINLINE dayFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] dayFieldDecoder :: FieldDecoder Day dayFieldDecoder = parsePgType "Day" [dateOid] $ \case @@ -1560,6 +1574,7 @@ instance FromPgField Day where "singleField unboundedDayFieldDecoder" singleField unboundedDayFieldDecoder = fieldRowDecoder "singleField (nullableField unboundedDayFieldDecoder)" singleField (nullableField unboundedDayFieldDecoder) = fieldRowDecoder #-} + {-# NOINLINE unboundedDayFieldDecoder #-} unboundedDayFieldDecoder :: FieldDecoder (Unbounded Day) unboundedDayFieldDecoder = parsePgType "Unbounded Day" [dateOid] $ \case @@ -1586,6 +1601,7 @@ instance FromPgField (Unbounded Day) where "singleField calendarDiffTimeFieldDecoder" singleField calendarDiffTimeFieldDecoder = fieldRowDecoder "singleField (nullableField calendarDiffTimeFieldDecoder)" singleField (nullableField calendarDiffTimeFieldDecoder) = fieldRowDecoder #-} + {-# NOINLINE calendarDiffTimeFieldDecoder #-} calendarDiffTimeFieldDecoder :: FieldDecoder CalendarDiffTime calendarDiffTimeFieldDecoder = parsePgType "CalendarDiffTime " [intervalOid] $ \case @@ -1605,6 +1621,7 @@ instance FromPgField CalendarDiffTime where "singleField uuidFieldDecoder" singleField uuidFieldDecoder = fieldRowDecoder "singleField (nullableField uuidFieldDecoder)" singleField (nullableField uuidFieldDecoder) = fieldRowDecoder #-} + {-# NOINLINE uuidFieldDecoder #-} uuidFieldDecoder :: FieldDecoder UUID uuidFieldDecoder = parsePgType "UUID" [uuidOid] $ \case From d755821979eacce7759a8cba9185057ebad35fa4 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Thu, 17 Sep 2026 18:02:19 -0300 Subject: [PATCH 35/38] Specialized row decoders for arrays --- hpgsql/src/Hpgsql/Encoding/Internal.hs | 35 ++++++++++++++++---------- hpgsql/src/Hpgsql/Types.hs | 8 +++++- 2 files changed, 29 insertions(+), 14 deletions(-) diff --git a/hpgsql/src/Hpgsql/Encoding/Internal.hs b/hpgsql/src/Hpgsql/Encoding/Internal.hs index 5b8a448..b35ad60 100644 --- a/hpgsql/src/Hpgsql/Encoding/Internal.hs +++ b/hpgsql/src/Hpgsql/Encoding/Internal.hs @@ -1707,7 +1707,13 @@ allowOnlyArrayTypes fieldInfo = instance forall a. (FromPgField a) => FromPgField (Vector a) where {-# INLINE fieldDecoder #-} - fieldDecoder = arrayFieldRowDec Vector.replicateM + fieldDecoder = fst $ arrayFieldRowDec Vector.replicateM + {-# INLINE notConstFieldDecoder #-} + notConstFieldDecoder = \finfo -> do + len <- Parser.takeInt32BE + case len of + (-1) -> pure Nothing + _ -> fmap Just $ snd (arrayFieldRowDec Vector.replicateM) finfo instance {-# OVERLAPPING #-} forall a. (FromPgField a) => FromPgField (Vector (Vector a)) where -- From https://github.com/postgres/postgres/blob/5941946d0934b9eccb0d5bfebd40b155249a0130/src/backend/utils/adt/arrayfuncs.c#L1548 @@ -1974,20 +1980,23 @@ arrayField !replicateFunction !elementParser = Left err -> fail $ "Error parsing array element: " ++ show err Right el -> pure el --- | A FieldDecoder that accepts and decodes Postgres arrays. -arrayFieldRowDec :: forall a f. (FromPgField a, Monoid (f a)) => (forall m. (Monad m) => Int -> m a -> m (f a)) -> FieldDecoder (f a) +-- | Returns a `fieldDecoder` and a specialized parser that both accept and decodes Postgres arrays. +{-# INLINE arrayFieldRowDec #-} +arrayFieldRowDec :: forall a f. (FromPgField a, Monoid (f a)) => (forall m. (Monad m) => Int -> m a -> m (f a)) -> (FieldDecoder (f a), FieldInfo -> Parser.Parser (f a)) arrayFieldRowDec !replicateFunction = -- From https://github.com/postgres/postgres/blob/5941946d0934b9eccb0d5bfebd40b155249a0130/src/backend/utils/adt/arrayfuncs.c#L1548 - FieldDecoder - { fieldValueDecoder = \colInfo -> - let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput - in \case - Nothing -> Left "Cannot decode SQL null as the Haskell Vector type. Use a `Maybe (Vector a)`" - Just bs -> case Parser.parseOnly arrayFieldDecoder (PBA.fromByteString bs) of - Parser.ParseOk v -> Right v - Parser.ParseFail err -> Left err, - allowedPgTypes = allowOnlyArrayTypes - } + ( FieldDecoder + { 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 (PBA.fromByteString bs) of + Parser.ParseOk v -> Right v + Parser.ParseFail err -> Left err, + allowedPgTypes = allowOnlyArrayTypes + }, + \finfo -> arrayParser finfo.encodingContext + ) where fdec = fieldDecoder @a handleNulls p = \finfo -> do diff --git a/hpgsql/src/Hpgsql/Types.hs b/hpgsql/src/Hpgsql/Types.hs index 582344a..74d271e 100644 --- a/hpgsql/src/Hpgsql/Types.hs +++ b/hpgsql/src/Hpgsql/Types.hs @@ -43,7 +43,13 @@ instance forall a. (ToPgField a) => ToPgField (PGArray a) where instance forall a. (FromPgField a) => FromPgField (PGArray a) where {-# INLINE fieldDecoder #-} - fieldDecoder = PGArray <$> arrayFieldRowDec replicateM + fieldDecoder = PGArray <$> fst (arrayFieldRowDec replicateM) + {-# INLINE notConstFieldDecoder #-} + notConstFieldDecoder = \finfo -> do + len <- Parser.takeInt32BE + case len of + (-1) -> pure Nothing + _ -> fmap (Just . PGArray) $ snd (arrayFieldRowDec replicateM) finfo -- | A way to compose two rows. data h :. t = !h :. !t deriving (Eq, Ord, Show, Read) From bf69debe13da0e9adeed602cd547793d8204f438 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Thu, 17 Sep 2026 18:44:50 -0300 Subject: [PATCH 36/38] Specialized row decoders for arrays --- hpgsql-tests/EncodingDecodingSpec.hs | 106 ++++++++++++++++++++++--- hpgsql/src/Hpgsql/Encoding/Internal.hs | 55 +++++++------ hpgsql/src/Hpgsql/Types.hs | 15 +++- 3 files changed, 139 insertions(+), 37 deletions(-) diff --git a/hpgsql-tests/EncodingDecodingSpec.hs b/hpgsql-tests/EncodingDecodingSpec.hs index 5104a16..1110789 100644 --- a/hpgsql-tests/EncodingDecodingSpec.hs +++ b/hpgsql-tests/EncodingDecodingSpec.hs @@ -1009,17 +1009,101 @@ queryArrayTypes conn = hedgehog $ do -- TODO: hedgehog gen arrays with varying lengths, NULLs, etc. intArrDim1 <- fmap Vector.fromList $ Gen.forAll $ Gen.list (Gen.linear 0 20) $ Gen.int (Gen.linearFrom 0 (-1000) 1000) nullIntArrDim1 <- fmap PGArray $ Gen.forAll $ Gen.list (Gen.linear 0 20) $ Gen.maybe $ Gen.int (Gen.linearFrom 0 (-1000) 1000) - liftIO $ do - queryWith rowDecoder conn (mkQuery "SELECT $1, $1, $2" (intArrDim1, nullIntArrDim1)) `shouldReturn` [(intArrDim1, intArrDim1, nullIntArrDim1)] - queryWith (rowDecoder @(Only (Vector Int))) conn (mkQuery "SELECT ARRAY[$1,$2,$3]" (13 :: Int, 31 :: Int, 45 :: Int)) `shouldReturn` [Only $ Vector.fromList [13 :: Int, 31, 45]] - queryWith (rowDecoder @(Only (Vector Int16))) conn (mkQuery "SELECT ARRAY[$1,$2,$3]" (13 :: Int16, 49 :: Int16, 91 :: Int16)) `shouldReturn` [Only $ Vector.fromList [13, 49, 91]] - queryWith (rowDecoder @(Only (Vector (Maybe Int16)))) conn (mkQuery "SELECT ARRAY[$1,$2,$3]" (13 :: Int16, Nothing :: Maybe Int16, Just (91 :: Int16))) `shouldReturn` [Only $ Vector.fromList [Just 13, Nothing, Just 91]] - queryWith (rowDecoder @(Only (Vector (Maybe Text)))) conn (mkQuery "SELECT ARRAY[$1,$2,$3] -- Maybe Text" (Just ("Hello" :: Text), Nothing :: Maybe String, Just ("again" :: Text))) `shouldReturn` [Only $ Vector.fromList [Just "Hello", Nothing, Just "again"]] - queryWith (rowDecoder @(Only (Vector Aeson.Value))) conn (mkQuery "SELECT ARRAY[$1,$2,$3] -- json" (Aeson.String "Hello", Aeson.Null, Aeson.Number 4)) `shouldReturn` [Only $ Vector.fromList [Aeson.String "Hello", Aeson.Null, Aeson.Number 4]] - let multiDimArray1 = Vector.fromList [Vector.fromList [1, 2, 3, 4], Vector.fromList [4, 5, 6, 7 :: Int]] - query conn [sql|SELECT ARRAY[ARRAY[1,2,3,4],ARRAY[4,5,6, 7]]|] `shouldReturn` [Only multiDimArray1] - let multiDimArray2 = Vector.fromList [Vector.fromList [1, 2, 3], Vector.fromList [4, 5, 6 :: Int], Vector.fromList [7, 8, 9 :: Int]] - query conn [sql|SELECT ARRAY[ARRAY[1,2,3],ARRAY[4,5,6], ARRAY[7,8,9]]|] `shouldReturn` [Only multiDimArray2] + let qryIntArrays = mkQuery "SELECT $1, $1, $2" (intArrDim1, nullIntArrDim1) + qryIntVec = mkQuery "SELECT ARRAY[$1,$2,$3]" (13 :: Int, 31 :: Int, 45 :: Int) + qryInt16Vec = mkQuery "SELECT ARRAY[$1,$2,$3]" (13 :: Int16, 49 :: Int16, 91 :: Int16) + qryMaybeInt16Vec = mkQuery "SELECT ARRAY[$1,$2,$3]" (13 :: Int16, Nothing :: Maybe Int16, Just (91 :: Int16)) + qryMaybeTextVec = mkQuery "SELECT ARRAY[$1,$2,$3] -- Maybe Text" (Just ("Hello" :: Text), Nothing :: Maybe String, Just ("again" :: Text)) + qryJsonVec = mkQuery "SELECT ARRAY[$1,$2,$3] -- json" (Aeson.String "Hello", Aeson.Null, Aeson.Number 4) + qryMultiDim1 = [sql|SELECT ARRAY[ARRAY[1,2,3,4],ARRAY[4,5,6, 7]]|] + qryMultiDim2 = [sql|SELECT ARRAY[ARRAY[1,2,3],ARRAY[4,5,6], ARRAY[7,8,9]]|] + multiDimArray1 = Vector.fromList [Vector.fromList [1, 2, 3, 4], Vector.fromList [4, 5, 6, 7 :: Int]] + multiDimArray2 = Vector.fromList [Vector.fromList [1, 2, 3], Vector.fromList [4, 5, 6 :: Int], Vector.fromList [7, 8, 9 :: Int]] + -- Specialized row parsers of each type are a different implementation from + -- the simpler fieldDecoders, so we need to test both. We also decode each + -- single-dimension array query into both `Vector` and `PGArray`. + ( resIntArrays1, + resIntArrays2, + resIntVecV1, + resIntVecV2, + resIntArrP1, + resIntArrP2, + resInt16VecV1, + resInt16VecV2, + resInt16ArrP1, + resInt16ArrP2, + resMaybeInt16VecV1, + resMaybeInt16VecV2, + resMaybeInt16ArrP1, + resMaybeInt16ArrP2, + resMaybeTextVecV1, + resMaybeTextVecV2, + resMaybeTextArrP1, + resMaybeTextArrP2, + resJsonVecV1, + resJsonVecV2, + resJsonArrP1, + resJsonArrP2, + resMultiDim1a, + resMultiDim1b, + resMultiDim2a, + resMultiDim2b + ) <- + liftIO $ + runPipeline conn $ + (,,,,,,,,,,,,,,,,,,,,,,,,,) + <$> pipeline1With rowDecoder qryIntArrays + <*> pipeline1With ((,,) <$> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder <*> singleField notRewrittenFieldDecoder) qryIntArrays + <*> pipeline1With (rowDecoder @(Only (Vector Int))) qryIntVec + <*> pipeline1With (Only <$> singleField (notRewrittenFieldDecoder @(Vector Int))) qryIntVec + <*> pipeline1With (rowDecoder @(Only (PGArray Int))) qryIntVec + <*> pipeline1With (Only <$> singleField (notRewrittenFieldDecoder @(PGArray Int))) qryIntVec + <*> pipeline1With (rowDecoder @(Only (Vector Int16))) qryInt16Vec + <*> pipeline1With (Only <$> singleField (notRewrittenFieldDecoder @(Vector Int16))) qryInt16Vec + <*> pipeline1With (rowDecoder @(Only (PGArray Int16))) qryInt16Vec + <*> pipeline1With (Only <$> singleField (notRewrittenFieldDecoder @(PGArray Int16))) qryInt16Vec + <*> pipeline1With (rowDecoder @(Only (Vector (Maybe Int16)))) qryMaybeInt16Vec + <*> pipeline1With (Only <$> singleField (notRewrittenFieldDecoder @(Vector (Maybe Int16)))) qryMaybeInt16Vec + <*> pipeline1With (rowDecoder @(Only (PGArray (Maybe Int16)))) qryMaybeInt16Vec + <*> pipeline1With (Only <$> singleField (notRewrittenFieldDecoder @(PGArray (Maybe Int16)))) qryMaybeInt16Vec + <*> pipeline1With (rowDecoder @(Only (Vector (Maybe Text)))) qryMaybeTextVec + <*> pipeline1With (Only <$> singleField (notRewrittenFieldDecoder @(Vector (Maybe Text)))) qryMaybeTextVec + <*> pipeline1With (rowDecoder @(Only (PGArray (Maybe Text)))) qryMaybeTextVec + <*> pipeline1With (Only <$> singleField (notRewrittenFieldDecoder @(PGArray (Maybe Text)))) qryMaybeTextVec + <*> pipeline1With (rowDecoder @(Only (Vector Aeson.Value))) qryJsonVec + <*> pipeline1With (Only <$> singleField (notRewrittenFieldDecoder @(Vector Aeson.Value))) qryJsonVec + <*> pipeline1With (rowDecoder @(Only (PGArray Aeson.Value))) qryJsonVec + <*> pipeline1With (Only <$> singleField (notRewrittenFieldDecoder @(PGArray Aeson.Value))) qryJsonVec + <*> pipeline1With (rowDecoder @(Only (Vector (Vector Int)))) qryMultiDim1 + <*> pipeline1With (Only <$> singleField (notRewrittenFieldDecoder @(Vector (Vector Int)))) qryMultiDim1 + <*> pipeline1With (rowDecoder @(Only (Vector (Vector Int)))) qryMultiDim2 + <*> pipeline1With (Only <$> singleField (notRewrittenFieldDecoder @(Vector (Vector Int)))) qryMultiDim2 + liftIO resIntArrays1 >>= (=== (intArrDim1, intArrDim1, nullIntArrDim1)) + liftIO resIntArrays2 >>= (=== (intArrDim1, intArrDim1, nullIntArrDim1)) + liftIO resIntVecV1 >>= (=== Only (Vector.fromList [13 :: Int, 31, 45])) + liftIO resIntVecV2 >>= (=== Only (Vector.fromList [13 :: Int, 31, 45])) + liftIO resIntArrP1 >>= (=== Only (PGArray [13 :: Int, 31, 45])) + liftIO resIntArrP2 >>= (=== Only (PGArray [13 :: Int, 31, 45])) + liftIO resInt16VecV1 >>= (=== Only (Vector.fromList [13, 49, 91 :: Int16])) + liftIO resInt16VecV2 >>= (=== Only (Vector.fromList [13, 49, 91 :: Int16])) + liftIO resInt16ArrP1 >>= (=== Only (PGArray [13, 49, 91 :: Int16])) + liftIO resInt16ArrP2 >>= (=== Only (PGArray [13, 49, 91 :: Int16])) + liftIO resMaybeInt16VecV1 >>= (=== Only (Vector.fromList [Just 13, Nothing, Just 91 :: Maybe Int16])) + liftIO resMaybeInt16VecV2 >>= (=== Only (Vector.fromList [Just 13, Nothing, Just 91 :: Maybe Int16])) + liftIO resMaybeInt16ArrP1 >>= (=== Only (PGArray [Just 13, Nothing, Just 91 :: Maybe Int16])) + liftIO resMaybeInt16ArrP2 >>= (=== Only (PGArray [Just 13, Nothing, Just 91 :: Maybe Int16])) + liftIO resMaybeTextVecV1 >>= (=== Only (Vector.fromList [Just "Hello", Nothing, Just "again"])) + liftIO resMaybeTextVecV2 >>= (=== Only (Vector.fromList [Just "Hello", Nothing, Just "again"])) + liftIO resMaybeTextArrP1 >>= (=== Only (PGArray [Just "Hello", Nothing, Just "again"])) + liftIO resMaybeTextArrP2 >>= (=== Only (PGArray [Just "Hello", Nothing, Just "again"])) + liftIO resJsonVecV1 >>= (=== Only (Vector.fromList [Aeson.String "Hello", Aeson.Null, Aeson.Number 4])) + liftIO resJsonVecV2 >>= (=== Only (Vector.fromList [Aeson.String "Hello", Aeson.Null, Aeson.Number 4])) + liftIO resJsonArrP1 >>= (=== Only (PGArray [Aeson.String "Hello", Aeson.Null, Aeson.Number 4])) + liftIO resJsonArrP2 >>= (=== Only (PGArray [Aeson.String "Hello", Aeson.Null, Aeson.Number 4])) + liftIO resMultiDim1a >>= (=== Only multiDimArray1) + liftIO resMultiDim1b >>= (=== Only multiDimArray1) + liftIO resMultiDim2a >>= (=== Only multiDimArray2) + liftIO resMultiDim2b >>= (=== Only multiDimArray2) data MyEnum = Val1 | Val2 | Val3 deriving stock (Eq, Show) diff --git a/hpgsql/src/Hpgsql/Encoding/Internal.hs b/hpgsql/src/Hpgsql/Encoding/Internal.hs index b35ad60..a91b5c3 100644 --- a/hpgsql/src/Hpgsql/Encoding/Internal.hs +++ b/hpgsql/src/Hpgsql/Encoding/Internal.hs @@ -1705,31 +1705,50 @@ allowOnlyArrayTypes fieldInfo = Nothing -> True -- Assume user knows what they're doing Just _ -> False -- Definitely not an array +{-# RULES +"singleField arrayFieldDecoder" singleField arrayFieldDecoder = fieldRowDecoder +"singleField (nullableField arrayFieldDecoder)" singleField (nullableField arrayFieldDecoder) = fieldRowDecoder + #-} + +{-# NOINLINE arrayFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +arrayFieldDecoder :: (FromPgField a) => FieldDecoder (Vector a) +arrayFieldDecoder = fst $ arrayFieldRowDec Vector.replicateM + instance forall a. (FromPgField a) => FromPgField (Vector a) where {-# INLINE fieldDecoder #-} - fieldDecoder = fst $ arrayFieldRowDec Vector.replicateM + fieldDecoder = arrayFieldDecoder {-# INLINE notConstFieldDecoder #-} notConstFieldDecoder = \finfo -> do len <- Parser.takeInt32BE case len of (-1) -> pure Nothing - _ -> fmap Just $ snd (arrayFieldRowDec Vector.replicateM) finfo + _ -> Just <$> snd (arrayFieldRowDec Vector.replicateM) finfo -instance {-# OVERLAPPING #-} forall a. (FromPgField a) => FromPgField (Vector (Vector a)) where +instance {-# INCOHERENT #-} forall a. (FromPgField a) => FromPgField (Vector (Vector a)) where -- From https://github.com/postgres/postgres/blob/5941946d0934b9eccb0d5bfebd40b155249a0130/src/backend/utils/adt/arrayfuncs.c#L1548 fieldDecoder = FieldDecoder { fieldValueDecoder = \colInfo -> - let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput + let !arrfdec = arrayParser colInfo.encodingContext <* Parser.endOfInput in \case Nothing -> Left "Cannot decode SQL null as the Haskell (Vector (Vector a)) type. Use a `Maybe (Vector (Vector a))`" - Just bs -> case Parser.parseOnly arrayFieldDecoder (PBA.fromByteString bs) of + Just bs -> case Parser.parseOnly arrfdec (PBA.fromByteString bs) of Parser.ParseOk v -> Right v Parser.ParseFail err -> Left err, allowedPgTypes = allowOnlyArrayTypes } where - !elementParser = fieldDecoder @a + fdec = fieldDecoder @a + handleNulls p = \finfo -> do + mv <- p + case mv of + Nothing -> case fdec.fieldValueDecoder finfo Nothing of + Left err -> fail $ "Array element is NULL: " ++ err + Right v -> pure v + Just v -> pure v + fieldDec = case inlinedConstFieldDecoder of + Just d -> handleNulls d + Nothing -> \finfo -> handleNulls (notConstFieldDecoder finfo) finfo arrayParser :: EncodingContext -> Parser.Parser (Vector (Vector a)) arrayParser encodingContext = do !ndim <- Parser.takeInt32BE @@ -1737,7 +1756,7 @@ instance {-# OVERLAPPING #-} forall a. (FromPgField a) => FromPgField (Vector (V !elementTypeOid :: Oid <- Oid . fromIntegral <$> Parser.takeInt32BE let !elementColInfo = FieldInfo elementTypeOid Nothing encodingContext when (ndim /= 2) $ fail $ "TODO: No support for " ++ show ndim ++ "-dimensional arrays in Hpgsql. Got array with ndim=" ++ show ndim - unless (elementParser.allowedPgTypes elementColInfo) $ fail $ "Array contains elements of type OID " ++ show elementTypeOid ++ " but decoder does not handle that type" + unless (fdec.allowedPgTypes elementColInfo) $ fail $ "Array contains elements of type OID " ++ show elementTypeOid ++ " but decoder does not handle that type" numRows <- do !dim_i :: Int <- fromIntegral <$> Parser.takeInt32BE !_lb_i <- Parser.takeInt32BE @@ -1748,18 +1767,7 @@ instance {-# OVERLAPPING #-} forall a. (FromPgField a) => FromPgField (Vector (V pure dim_i Vector.replicateM numRows $ do - Vector.replicateM lengthEachRow $ - do - size :: Int <- fromIntegral <$> Parser.takeInt32BE - if size == (-1) - then case elementParser.fieldValueDecoder elementColInfo Nothing of - Left err -> fail err - Right v -> pure v - else do - elementBs <- Parser.take size - case elementParser.fieldValueDecoder elementColInfo (Just (PBA.toByteString elementBs)) of - Left err -> fail $ "Error parsing array element: " ++ show err - Right el -> pure el + Vector.replicateM lengthEachRow (fieldDec elementColInfo) {-# INLINE genericFromPgRow #-} @@ -1946,10 +1954,10 @@ arrayField !replicateFunction !elementParser = -- From https://github.com/postgres/postgres/blob/5941946d0934b9eccb0d5bfebd40b155249a0130/src/backend/utils/adt/arrayfuncs.c#L1548 FieldDecoder { fieldValueDecoder = \colInfo -> - let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput + let !fdec = 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 (PBA.fromByteString bs) of + Just bs -> case Parser.parseOnly fdec (PBA.fromByteString bs) of Parser.ParseOk v -> Right v Parser.ParseFail err -> Left err, allowedPgTypes = allowOnlyArrayTypes @@ -1976,6 +1984,7 @@ arrayField !replicateFunction !elementParser = Right v -> pure v else do elementBs <- Parser.take size + -- We need to convert to ByteString here or we need to change the API in breaking fashion.. case elementParser.fieldValueDecoder elementColInfo (Just (PBA.toByteString elementBs)) of Left err -> fail $ "Error parsing array element: " ++ show err Right el -> pure el @@ -1987,10 +1996,10 @@ arrayFieldRowDec !replicateFunction = -- From https://github.com/postgres/postgres/blob/5941946d0934b9eccb0d5bfebd40b155249a0130/src/backend/utils/adt/arrayfuncs.c#L1548 ( FieldDecoder { fieldValueDecoder = \colInfo -> - let !arrayFieldDecoder = arrayParser colInfo.encodingContext <* Parser.endOfInput + let !dec = 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 (PBA.fromByteString bs) of + Just bs -> case Parser.parseOnly dec (PBA.fromByteString bs) of Parser.ParseOk v -> Right v Parser.ParseFail err -> Left err, allowedPgTypes = allowOnlyArrayTypes diff --git a/hpgsql/src/Hpgsql/Types.hs b/hpgsql/src/Hpgsql/Types.hs index 74d271e..550a98a 100644 --- a/hpgsql/src/Hpgsql/Types.hs +++ b/hpgsql/src/Hpgsql/Types.hs @@ -19,7 +19,7 @@ import qualified Data.ByteString.Lazy as LBS import Data.Tuple.Only (Only (..)) import Data.Typeable (Proxy (..)) import Hpgsql.Builder (BinaryField (..)) -import Hpgsql.Encoding.Internal (FieldDecoder (..), FieldEncoder (..), FieldInfo (..), FromPgField (..), FromPgRow (..), RowEncoder (..), ToPgField (..), ToPgRow (..), arrayFieldRowDec, toPgVectorField) +import Hpgsql.Encoding.Internal (FieldDecoder (..), FieldEncoder (..), FieldInfo (..), FromPgField (..), FromPgRow (..), RowEncoder (..), ToPgField (..), ToPgRow (..), arrayFieldRowDec, nullableField, singleField, toPgVectorField) import qualified Hpgsql.PinnedByteArray as PBA import qualified Hpgsql.SimpleParser as Parser import Hpgsql.TypeInfo (EncodingContext (..), TypeInfo (..), jsonOid, jsonbOid, lookupTypeByOid) @@ -41,15 +41,24 @@ instance forall a. (ToPgField a) => ToPgField (PGArray a) where toPgField = \encCtx -> toPgVectorField encCtx . fromPGArray } +{-# RULES +"singleField pgArrayFieldDecoder" singleField pgArrayFieldDecoder = fieldRowDecoder +"singleField (nullableField pgArrayFieldDecoder)" singleField (nullableField pgArrayFieldDecoder) = fieldRowDecoder + #-} + +{-# NOINLINE pgArrayFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +pgArrayFieldDecoder :: (FromPgField a) => FieldDecoder (PGArray a) +pgArrayFieldDecoder = PGArray <$> fst (arrayFieldRowDec replicateM) + instance forall a. (FromPgField a) => FromPgField (PGArray a) where {-# INLINE fieldDecoder #-} - fieldDecoder = PGArray <$> fst (arrayFieldRowDec replicateM) + fieldDecoder = pgArrayFieldDecoder {-# INLINE notConstFieldDecoder #-} notConstFieldDecoder = \finfo -> do len <- Parser.takeInt32BE case len of (-1) -> pure Nothing - _ -> fmap (Just . PGArray) $ snd (arrayFieldRowDec replicateM) finfo + _ -> Just . PGArray <$> snd (arrayFieldRowDec replicateM) finfo -- | A way to compose two rows. data h :. t = !h :. !t deriving (Eq, Ord, Show, Read) From bd9b6ecd9fd61dbe187b329d8150a105fcdf6df2 Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sat, 19 Sep 2026 12:08:20 -0300 Subject: [PATCH 37/38] Specialized row decoders for json types --- hpgsql-tests/EncodingDecodingSpec.hs | 30 ++++++++++- hpgsql/src/Hpgsql/Encoding/Internal.hs | 53 ++++++++++++------ hpgsql/src/Hpgsql/Types.hs | 75 ++++++++++++++++---------- 3 files changed, 113 insertions(+), 45 deletions(-) diff --git a/hpgsql-tests/EncodingDecodingSpec.hs b/hpgsql-tests/EncodingDecodingSpec.hs index 1110789..d0c4cd4 100644 --- a/hpgsql-tests/EncodingDecodingSpec.hs +++ b/hpgsql-tests/EncodingDecodingSpec.hs @@ -339,12 +339,38 @@ jsonValuesRoundTrip conn = hedgehog $ do jsonVal1 :: Aeson.Value <- Gen.forAll genJsonValue jsonVal2 :: Aeson.Value <- Gen.forAll genJsonValue jsonVal3 :: Aeson.Value <- Gen.forAll genJsonValue - let row = (jsonVal1, jsonVal2, jsonVal3) - [(v1, v2, v3, v4) :: (Aeson.Value, Aeson.Value, PgJson, PgJson)] <- liftIO $ queryWith rowDecoder conn [sql|SELECT #{jsonVal1}, #{jsonVal1}::jsonb, #{jsonVal2}::json, #{jsonVal3}::jsonb|] + let qry = [sql|SELECT #{jsonVal1}, #{jsonVal1}::jsonb, #{jsonVal2}::json, #{jsonVal3}::jsonb, NULL::json, NULL::jsonb|] + -- Specialized row parsers of each type are a different implementation from + -- the simpler fieldDecoders, so we need to test both + (res1, res2) <- + liftIO $ + runPipeline conn $ + (,) + <$> pipeline1With rowDecoder qry + <*> pipeline1With + ( (,,,,,) + <$> singleField notRewrittenFieldDecoder + <*> singleField notRewrittenFieldDecoder + <*> singleField notRewrittenFieldDecoder + <*> singleField notRewrittenFieldDecoder + <*> singleField (nullableField (notRewrittenFieldDecoder @Aeson.Value)) + <*> singleField (nullableField (notRewrittenFieldDecoder @PgJson)) + ) + qry + (v1, v2, v3, v4, v5, v6) :: (Aeson.Value, Aeson.Value, PgJson, PgJson, Maybe Aeson.Value, Maybe PgJson) <- liftIO res1 v1 === jsonVal1 v2 === jsonVal1 Aeson.toJSON v3 === jsonVal2 Aeson.toJSON v4 === jsonVal3 + v5 === Nothing + isNothing v6 === True + (v7, v8, v9, v10, v11, v12) :: (Aeson.Value, Aeson.Value, PgJson, PgJson, Maybe Aeson.Value, Maybe PgJson) <- liftIO res2 + v7 === jsonVal1 + v8 === jsonVal1 + Aeson.toJSON v9 === jsonVal2 + Aeson.toJSON v10 === jsonVal3 + v11 === Nothing + isNothing v12 === True dateDecoding :: HPgConnection -> IO () dateDecoding conn = do diff --git a/hpgsql/src/Hpgsql/Encoding/Internal.hs b/hpgsql/src/Hpgsql/Encoding/Internal.hs index a91b5c3..498ca22 100644 --- a/hpgsql/src/Hpgsql/Encoding/Internal.hs +++ b/hpgsql/src/Hpgsql/Encoding/Internal.hs @@ -1644,23 +1644,46 @@ instance FromPgField UUID where <$> Parser.takeWord64BE <*> Parser.takeWord64BE +{-# RULES +"singleField aesonFieldDecoder" singleField aesonFieldDecoder = fieldRowDecoder +"singleField (nullableField aesonFieldDecoder)" singleField (nullableField aesonFieldDecoder) = fieldRowDecoder + #-} + +{-# NOINLINE aesonFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +aesonFieldDecoder :: FieldDecoder Aeson.Value +aesonFieldDecoder = + FieldDecoder + { fieldValueDecoder = + \FieldInfo {fieldTypeOid} -> + let + -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in + \case + Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls" + Just bs -> case Aeson.decodeStrict $ fixJsonb bs of + Just d -> Right d + Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", + allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid + } + instance FromPgField Aeson.Value where {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = - \FieldInfo {fieldTypeOid} -> - let - -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in - \case - Nothing -> Left "Cannot decode SQL null as the Haskell Aeson.Value type. Use a `Maybe Aeson.Value` if you want SQL nulls" - Just bs -> case Aeson.decodeStrict $ fixJsonb bs of - Just d -> Right d - Nothing -> Left "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid.", - allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid - } + fieldDecoder = aesonFieldDecoder + {-# INLINE notConstFieldDecoder #-} + notConstFieldDecoder finfo = do + len <- fromIntegral <$> Parser.takeInt32BE + if len == (-1) + then pure Nothing + else do + bs <- + PBA.toByteString + <$> if finfo.fieldTypeOid == jsonbOid + then Parser.skip 1 >> Parser.take (len - 1) + else Parser.take len + case Aeson.decodeStrict bs of + Just d -> pure (Just d) + Nothing -> fail "Bug in Hpgsql. Postgres produced a json or jsonb value that Aeson does not consider valid." {-# INLINE [1] nullableField #-} diff --git a/hpgsql/src/Hpgsql/Types.hs b/hpgsql/src/Hpgsql/Types.hs index 550a98a..bc60bd2 100644 --- a/hpgsql/src/Hpgsql/Types.hs +++ b/hpgsql/src/Hpgsql/Types.hs @@ -100,21 +100,31 @@ instance ToJSON PgJson where pgJsonByteString :: PgJson -> ByteString pgJsonByteString (PgJson bs) = bs +{-# RULES +"singleField pgJsonFieldDecoder" singleField pgJsonFieldDecoder = fieldRowDecoder +"singleField (nullableField pgJsonFieldDecoder)" singleField (nullableField pgJsonFieldDecoder) = fieldRowDecoder + #-} + +{-# NOINLINE pgJsonFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +pgJsonFieldDecoder :: FieldDecoder PgJson +pgJsonFieldDecoder = + FieldDecoder + { fieldValueDecoder = + \FieldInfo {fieldTypeOid} -> + let + -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in + \case + Nothing -> Left "Cannot decode SQL null as the Haskell PgJson type. Use a `Maybe PgJson` if you want SQL nulls" + Just bs -> Right $ PgJson $ fixJsonb bs, + allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid + } + instance FromPgField PgJson where {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = - \FieldInfo {fieldTypeOid} -> - let - -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in - \case - Nothing -> Left "Cannot decode SQL null as the Haskell PgJson type. Use a `Maybe PgJson` if you want SQL nulls" - Just bs -> Right $ PgJson $ fixJsonb bs, - allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid - } + fieldDecoder = pgJsonFieldDecoder + {-# INLINE notConstFieldDecoder #-} notConstFieldDecoder finfo = do len <- fromIntegral <$> Parser.takeInt32BE @@ -133,23 +143,32 @@ newtype Aeson a = Aeson {getAeson :: a} deriving stock (Functor, Read, Show) deriving newtype (Eq) +{-# RULES +"singleField aesonFieldDecoder" singleField aesonFieldDecoder = fieldRowDecoder +"singleField (nullableField aesonFieldDecoder)" singleField (nullableField aesonFieldDecoder) = fieldRowDecoder + #-} + +{-# NOINLINE aesonFieldDecoder #-} -- See Note [singleField fieldDecoder rewrite rules] +aesonFieldDecoder :: (FromJSON a) => FieldDecoder (Aeson a) +aesonFieldDecoder = + FieldDecoder + { fieldValueDecoder = + \FieldInfo {fieldTypeOid} -> + let + -- jsonb has a byte prepended to the contents and json does not + !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id + in + \case + Nothing -> Left "Cannot decode SQL null as a Haskell (Aeson a) type. Use a `Maybe (Aeson a)` if you want SQL nulls" + Just 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", + allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid + } + instance (FromJSON a) => FromPgField (Aeson a) where {-# INLINE fieldDecoder #-} - fieldDecoder = - FieldDecoder - { fieldValueDecoder = - \FieldInfo {fieldTypeOid} -> - let - -- jsonb has a byte prepended to the contents and json does not - !fixJsonb = if fieldTypeOid == jsonbOid then BS.drop 1 else Prelude.id - in - \case - Nothing -> Left "Cannot decode SQL null as a Haskell (Aeson a) type. Use a `Maybe (Aeson a)` if you want SQL nulls" - Just 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", - allowedPgTypes = (`elem` [jsonOid, jsonbOid]) . fieldTypeOid - } + fieldDecoder = aesonFieldDecoder {-# INLINE notConstFieldDecoder #-} notConstFieldDecoder finfo = notConstFieldDecoder finfo >>= \case From 0e11e1e1bfedf932cccc75f50eeadb949c6efc4d Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Sun, 20 Sep 2026 11:05:34 -0300 Subject: [PATCH 38/38] Fix compilation for GHC 9.6 `$` is not levity polymorphic enough and the type used for `Data.Text.Text`'s internal representation is imported from a different module --- TODO.md | 1 + hpgsql/src/Hpgsql/PinnedByteArray.hs | 16 +++++++++------- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/TODO.md b/TODO.md index 7fb882f..d3407b9 100644 --- a/TODO.md +++ b/TODO.md @@ -6,3 +6,4 @@ - Check that we're not holding on to internal buffers when Record fields being materialized into aren't strict - Write property-based tests for PinnedByteArray functions - Double check that for this PR the inlined and not inlined versions really differ in performance +- Check all TODOs diff --git a/hpgsql/src/Hpgsql/PinnedByteArray.hs b/hpgsql/src/Hpgsql/PinnedByteArray.hs index 8f6bbf5..e95450d 100644 --- a/hpgsql/src/Hpgsql/PinnedByteArray.hs +++ b/hpgsql/src/Hpgsql/PinnedByteArray.hs @@ -67,9 +67,7 @@ module Hpgsql.PinnedByteArray where import Control.Monad (when) -import Data.ByteString (ByteString) import Data.ByteString.Internal (ByteString (..)) -import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Internal as InternalBS import Data.Int (Int16, Int32, Int64) import Foreign.C (CInt (..)) @@ -85,7 +83,11 @@ import Data.Word (Word16, Word64) #else import Data.Word (Word16, Word64, byteSwap16, byteSwap64, Word8, byteSwap32) #endif +#if MIN_VERSION_base(4,19,0) import Data.Array.Byte (ByteArray (..)) +#else +import Data.Text.Array (Array (..)) +#endif import Data.Bits (Bits (unsafeShiftR)) import Data.Coerce (coerce) import Data.Text.Internal (Text (..)) @@ -133,7 +135,7 @@ fromByteString (BS fptr len) = unsafeDupablePerformIO $ createPinnedByteArray le pure $ fromIntegral len toByteString :: PinnedByteArray -> ByteString -toByteString (PinnedByteArray start len src) = unsafeDupablePerformIO $ BS.create len $ \dst -> +toByteString (PinnedByteArray start len src) = unsafeDupablePerformIO $ InternalBS.create len $ \dst -> copyBytes dst (Ptr (byteArrayContents# src) `plusPtr` start) len {-# INLINE unsafeToUtf8Text #-} @@ -241,10 +243,10 @@ data CoolWordDec a where decodeWord :: CoolWordDec a -> ByteStringIdx -> PinnedByteArray -> (a -> a) -> Either String a decodeWord wdec (ByteStringIdx boxedIdx@(I# idx)) (PinnedByteArray (I# start) len byArrSharp) endianConvert = case wdec of - CWord8 -> if len < 1 + boxedIdx then Left "Less than enough bytes to decode" else Right $ endianConvert $ W8# $ indexWord8Array# byArrSharp (idx +# start) - CWord16 -> if len < 2 + boxedIdx then Left "Less than enough bytes to decode" else Right $ endianConvert $ W16# $ indexWord8ArrayAsWord16# byArrSharp (idx +# start) - CWord32 -> if len < 4 + boxedIdx then Left "Less than enough bytes to decode" else Right $ endianConvert $ W32# $ indexWord8ArrayAsWord32# byArrSharp (idx +# start) - CWord64 -> if len < 8 + boxedIdx then Left "Less than enough bytes to decode" else Right $ endianConvert $ W64# $ indexWord8ArrayAsWord64# byArrSharp (idx +# start) + CWord8 -> if len < 1 + boxedIdx then Left "Less than enough bytes to decode" else Right $ endianConvert $ W8# (indexWord8Array# byArrSharp (idx +# start)) + CWord16 -> if len < 2 + boxedIdx then Left "Less than enough bytes to decode" else Right $ endianConvert $ W16# (indexWord8ArrayAsWord16# byArrSharp (idx +# start)) + CWord32 -> if len < 4 + boxedIdx then Left "Less than enough bytes to decode" else Right $ endianConvert $ W32# (indexWord8ArrayAsWord32# byArrSharp (idx +# start)) + CWord64 -> if len < 8 + boxedIdx then Left "Less than enough bytes to decode" else Right $ endianConvert $ W64# (indexWord8ArrayAsWord64# byArrSharp (idx +# start)) {-# INLINE unsafeEncodeWord #-} unsafeEncodeWord :: (Storable a) => a -> (a -> a) -> Int -> ByteString