From 11c6abc3b790eb4a4623059911878e24fd3729b8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=A9gys=20Borges=20da=20Silveira?= Date: Tue, 20 Oct 2026 13:09:20 -0300 Subject: [PATCH] fix(fpc): keep header hash arithmetic in range with checks enabled --- .github/workflows/tests.yml | 10 ++ src/Horse.Core.Param.Header.pas | 3 +- tests/fpc-header-hash/HeaderHashCheck.dpr | 148 ++++++++++++++++++ tests/fpc-header-hash/README.md | 21 +++ tests/fpc-header-hash/run-header-hash-test.sh | 29 ++++ 5 files changed, 210 insertions(+), 1 deletion(-) create mode 100644 tests/fpc-header-hash/HeaderHashCheck.dpr create mode 100644 tests/fpc-header-hash/README.md create mode 100644 tests/fpc-header-hash/run-header-hash-test.sh diff --git a/.github/workflows/tests.yml b/.github/workflows/tests.yml index f5444abf..b94a409b 100644 --- a/.github/workflows/tests.yml +++ b/.github/workflows/tests.yml @@ -33,6 +33,11 @@ jobs: - name: Run FPC URL decoding regression run: sh tests/fpc-url-decoding/run-url-decoding-test.sh + - name: Run FPC header hash regression with range and overflow checks + run: | + sh tests/fpc-header-hash/run-header-hash-test.sh + sh tests/fpc-header-hash/run-header-hash-test.sh -dHORSE_PROVIDER_EPOLL + # Console.dpr uses Delphi/DUnitX; validate it with run_delphi_tests.ps1. # The Linux job runs the standalone FPC suites instead. - name: Run FPC stream factory regression @@ -70,6 +75,11 @@ jobs: sudo "$compiler_dir/samplecfg" "$compiler_dir" /etc echo "/opt/fpc/bin" >> "$GITHUB_PATH" + - name: Run FPC trunk header hash regression with range and overflow checks + run: | + sh tests/fpc-header-hash/run-header-hash-test.sh + sh tests/fpc-header-hash/run-header-hash-test.sh -dHORSE_PROVIDER_EPOLL + - name: Compile keep-alive regression server run: | mkdir -p /tmp/horse-fpc-units /tmp/horse-fpc-bin diff --git a/src/Horse.Core.Param.Header.pas b/src/Horse.Core.Param.Header.pas index 7962bc43..449cb899 100644 --- a/src/Horse.Core.Param.Header.pas +++ b/src/Horse.Core.Param.Header.pas @@ -90,7 +90,8 @@ function THorseHeaderComparer.GetHashCode(CONST_GENERIC Value: string): DWord; LChar := Value[I]; if LChar in ['A'..'Z'] then Inc(LChar, 32); - Result := ((Result shl 5) + Result) + Ord(LChar); + // DJB2 wraps modulo 2^32; keep the intermediate and conversion in range. + Result := DWord((QWord(Result) * 33 + Ord(LChar)) and QWord($FFFFFFFF)); end; end; {$ENDIF} diff --git a/tests/fpc-header-hash/HeaderHashCheck.dpr b/tests/fpc-header-hash/HeaderHashCheck.dpr new file mode 100644 index 00000000..c3ce743d --- /dev/null +++ b/tests/fpc-header-hash/HeaderHashCheck.dpr @@ -0,0 +1,148 @@ +program HeaderHashCheck; + +{$MODE DELPHI}{$H+} +{$IFOPT R-}{$FATAL Range checking must be enabled}{$ENDIF} +{$IFOPT Q-}{$FATAL Overflow checking must be enabled}{$ENDIF} + +uses + SysUtils, Generics.Defaults, HTTPDefs, + Horse.Core.Param, Horse.Core.Param.Header; + +type + THashCase = record + Name: string; + Expected: DWord; + end; + TTestProc = procedure; + +const + // Independent DJB2 modulo-2^32 vectors, including values above MaxInt. + Cases: array[0..6] of THashCase = ( + (Name: ''; Expected: 5381), + (Name: 'Host'; Expected: 2090335843), + (Name: 'Content-Type'; Expected: 4200957359), + (Name: 'Authorization'; Expected: 1595898102), + (Name: 'X-Custom-Header'; Expected: 4148212891), + (Name: 'Accept-Encoding'; Expected: 1116246921), + (Name: 'X-Trace-Id'; Expected: 3544274515) + ); + +var + Checks, Groups, Failures: Integer; + +procedure Check(Condition: Boolean; const MessageText: string); +begin + Inc(Checks); + if not Condition then + raise Exception.Create(MessageText); +end; + +procedure RunTest(const Name: string; TestProc: TTestProc); +begin + Inc(Groups); + try + TestProc; + Writeln('PASS ', Name); + except + on E: Exception do + begin + Inc(Failures); + Writeln('FAIL ', Name, ': ', E.ClassName, ': ', E.Message); + end; + end; +end; + +procedure TestHashVectors; +var + Comparer: IEqualityComparer; + I: Integer; +begin + Comparer := THorseHeaderComparer.Create; + for I := Low(Cases) to High(Cases) do + begin + Check(Comparer.GetHashCode(Cases[I].Name) = Cases[I].Expected, + 'Unexpected hash for ' + Cases[I].Name); + Check(Comparer.GetHashCode(UpperCase(Cases[I].Name)) = Cases[I].Expected, + 'Uppercase hash mismatch for ' + Cases[I].Name); + Check(Comparer.GetHashCode(LowerCase(Cases[I].Name)) = Cases[I].Expected, + 'Lowercase hash mismatch for ' + Cases[I].Name); + Check(Comparer.Equals(Cases[I].Name, UpperCase(Cases[I].Name)), + 'Comparer equality mismatch for ' + Cases[I].Name); + end; +end; + +procedure TestLongHeader; +var + Comparer: IEqualityComparer; + Name: string; +begin + Comparer := THorseHeaderComparer.Create; + Name := StringOfChar('X', 4096); + Check(Comparer.GetHashCode(Name) = 2600047877, 'Long header hash changed'); + Check(Comparer.GetHashCode(LowerCase(Name)) = 2600047877, + 'Long lowercase header hash changed'); +end; + +procedure TestDictionaryOperations; +var + Comparer: IEqualityComparer; + Headers: THorseList; + I: Integer; + Value: string; +begin + Comparer := THorseHeaderComparer.Create; + Headers := THorseList.Create(Comparer); + try + for I := Low(Cases) to High(Cases) do + Headers.AddOrSetValue(Cases[I].Name, IntToStr(I)); + Check(Headers.Count = Length(Cases), 'Header insertion count'); + for I := Low(Cases) to High(Cases) do + begin + Check(Headers.TryGetValue(LowerCase(Cases[I].Name), Value), + 'Lowercase header lookup'); + Check(Value = IntToStr(I), 'Incorrect header value'); + Headers.AddOrSetValue(UpperCase(Cases[I].Name), 'updated'); + Check(Headers[Cases[I].Name] = 'updated', 'Case-insensitive update'); + end; + Check(Headers.Count = Length(Cases), 'Updates must not duplicate keys'); + for I := Low(Cases) to High(Cases) do + begin + Headers.Remove(LowerCase(Cases[I].Name)); + Check(not Headers.ContainsKey(UpperCase(Cases[I].Name)), 'Header removal'); + end; + Check(Headers.Count = 0, 'Dictionary must be empty after removal'); + finally + Headers.Free; + end; +end; + +procedure TestRequestHeaderExtraction; +var + Request: TRequest; + Headers: THorseList; +begin + Request := TRequest.Create; + try + Request.ContentType := 'application/json'; + Request.Host := 'localhost'; + Headers := THorseCoreParamHeader.GetHeaders(Request); + try + Check(Headers['content-type'] = 'application/json', 'Content-Type extraction'); + Check(Headers['HOST'] = 'localhost', 'Host extraction'); + finally + Headers.Free; + end; + finally + Request.Free; + end; +end; + +begin + RunTest('known hashes and ASCII case equivalence', @TestHashVectors); + RunTest('4096-character header', @TestLongHeader); + RunTest('header dictionary insert/lookup/update/remove', @TestDictionaryOperations); + RunTest('request header extraction', @TestRequestHeaderExtraction); + Writeln('Groups: ', Groups, '; checks: ', Checks, '; failures: ', Failures); + if Failures <> 0 then + Halt(1); +end. diff --git a/tests/fpc-header-hash/README.md b/tests/fpc-header-hash/README.md new file mode 100644 index 00000000..32f888a1 --- /dev/null +++ b/tests/fpc-header-hash/README.md @@ -0,0 +1,21 @@ +# Regressão do hash de headers no FPC + +Na raiz do repositório, em Linux com FPC/FCL: + +```sh +sh tests/fpc-header-hash/run-header-hash-test.sh +sh tests/fpc-header-hash/run-header-hash-test.sh -dHORSE_PROVIDER_EPOLL +``` + +O script recompila o teste **e as units do Horse** (`-B`) com range checking +(`-Cr`) e overflow checking (`-Co`) ativados. O programa recusa compilação sem +essas verificações. `heaptrc` (`-gh`) detecta blocos não liberados; falhas de +compilação, verificações ou memória retornam código diferente de zero. + +Os testes verificam hashes DJB2 conhecidos módulo 2³², equivalência entre +maiúsculas/minúsculas ASCII, chave vazia e chave longa de 4096 caracteres, +operações do dicionário de headers e extração de headers de uma requisição FPC. +Eles exercitam as classes diretamente, sem abrir um servidor HTTP. + +`HORSE_TEST_SOURCE` pode apontar para um diretório com uma versão anterior da +unit, permitindo reproduzir a falha sem modificar os fontes do checkout. diff --git a/tests/fpc-header-hash/run-header-hash-test.sh b/tests/fpc-header-hash/run-header-hash-test.sh new file mode 100644 index 00000000..a37f1379 --- /dev/null +++ b/tests/fpc-header-hash/run-header-hash-test.sh @@ -0,0 +1,29 @@ +#!/bin/sh +set -eu + +test_dir=$(CDPATH= cd -- "$(dirname -- "$0")" && pwd) +source_dir=${HORSE_TEST_SOURCE:-"$test_dir/../../src"} +output_dir=$(mktemp -d /tmp/horse-header-hash.XXXXXX) + +cd "$test_dir" +# Rebuild Horse too: checks on the test program alone do not exercise the bug. +fpc -B -Mdelphi -Sh -gh -gl "$@" -Cr -Co \ + -Fu"$source_dir" -Fu../../src -Fi../../src \ + -FU"$output_dir" -FE"$output_dir" HeaderHashCheck.dpr \ + >"$output_dir/build.log" 2>&1 || { + cat "$output_dir/build.log" + exit 1 + } + +set +e +run_output=$("$output_dir/HeaderHashCheck" 2>&1) +run_status=$? +set -e +printf '%s\n' "$run_output" +if [ "$run_status" -ne 0 ]; then + exit "$run_status" +fi +if printf '%s\n' "$run_output" | grep -Eq '[1-9][0-9]* unfreed memory blocks'; then + echo 'Header hash regression: FPC reported unfreed memory.' >&2 + exit 1 +fi