test: reorganize the Std.Http tests into case tables
diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index f14d4d1..a8554cc 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml
@@ -362,7 +362,7 @@ // We take a small subset of tests for tsan and run with reduced test parallelism. // This is necessary as running tsan in parallel on all of our test suite would // easily OOM the runner. - "CTEST_OPTIONS": "-j2 -E 'async_http_body|async_http_dispatch|async_http_encode|async_http_fuzz|async_http_response_framing|async_http_hang_regressions|task_iterators' -R '(compile/534)|(elab/(async.*|sync_.*|task.*|bv_bitwise|net_addr|networkInterfaces|openssl|idbg.*|Process|handleLocking|ioNulBytes|ioRandomBytes|libuv|readDir|realPath|st_test|stateRef|grind_list_count|vcgenSymBlock|doControlInfoAggregate))'" + "CTEST_OPTIONS": "-j2 -E 'async_http_body|async_http_dispatch|async_http_encode|async_http_fuzz|async_http_hang_regressions|async_http_h1_parser|async_http_h1_client_framing|async_http_uri|async_http_redirect|async_http_exports|task_iterators' -R '(compile/534)|(elab/(async.*|sync_.*|task.*|bv_bitwise|net_addr|networkInterfaces|openssl|idbg.*|Process|handleLocking|ioNulBytes|ioRandomBytes|libuv|readDir|realPath|st_test|stateRef|grind_list_count|vcgenSymBlock|doControlInfoAggregate))'" }, { "name": "macOS",
diff --git a/CMakePresets.json b/CMakePresets.json index 4ec17a7..2522c94 100644 --- a/CMakePresets.json +++ b/CMakePresets.json
@@ -59,7 +59,7 @@ "STRIP_BINARIES": "OFF", "USE_MIMALLOC": "OFF", "BSYMBOLIC": "OFF", - "LEAN_TEST_VARS": "MAIN_STACK_SIZE=16000 TEST_STACK_SIZE=16000 LSAN_OPTIONS=max_leaks=10" + "LEAN_TEST_VARS": "MAIN_STACK_SIZE=16000 TEST_STACK_SIZE=16000 LSAN_OPTIONS=max_leaks=10 LEAN_TEST_TIME_SCALE=50" }, "generator": "Unix Makefiles", "binaryDir": "${sourceDir}/build/sanitize" @@ -74,7 +74,8 @@ "STRIP_BINARIES": "OFF", "SMALL_ALLOCATOR": "OFF", "USE_MIMALLOC": "OFF", - "BSYMBOLIC": "OFF" + "BSYMBOLIC": "OFF", + "LEAN_TEST_VARS": "LEAN_TEST_TIME_SCALE=50" }, "generator": "Unix Makefiles", "binaryDir": "${sourceDir}/build/sanitize-thread"
diff --git a/src/Std.lean b/src/Std.lean index 85f5d08..2f71289 100644 --- a/src/Std.lean +++ b/src/Std.lean
@@ -15,3 +15,5 @@ public import Std.Internal public import Std.Net public import Std.WP +import Std.Http.Test.Helpers +import Std.Http.Test.Machine
diff --git a/src/Std/Http.lean b/src/Std/Http.lean index ff22577..1c62e8b 100644 --- a/src/Std/Http.lean +++ b/src/Std/Http.lean
@@ -7,7 +7,6 @@ prelude public import Std.Http.Server -import Std.Http.Test.Helpers public section
diff --git a/src/Std/Http/Test/Assert.lean b/src/Std/Http/Test/Assert.lean new file mode 100644 index 0000000..4584a3a --- /dev/null +++ b/src/Std/Http/Test/Assert.lean
@@ -0,0 +1,271 @@ +/- +Copyright (c) 2026 Lean FRO, LLC. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sofia Rodrigues +-/ +module + +prelude +public import Std.Http.Server +public import Std.Async +import Init.Data.String.Legacy + +public section + +/-! +# Assertions for the Std.Http tests + +Table-driven checks shared by the `tests/async/elab/async_http_*` files. `checkCases` runs every +case of a table under `hangGuard` and reports each failing case by its label. Deadlines are +multiplied by `LEAN_TEST_TIME_SCALE`, which the sanitizer presets set, so a guard only detects +hangs and never asserts a duration. +-/ + +open Std.Async +open Std Http + +namespace Std.Http.Internal.Test + +/-- +The factor applied to every test deadline: `LEAN_TEST_TIME_SCALE` when it is a positive number, +otherwise 1. +-/ +def timeScale : IO Nat := do + match (← IO.getEnv "LEAN_TEST_TIME_SCALE").bind String.toNat? with + | some n => pure (if n == 0 then 1 else n) + | none => pure 1 + +private partial def awaitUntil {α : Type} (task : Task (Except IO.Error α)) (deadline : Nat) + (pause : UInt32) : IO (Option α) := do + if (← IO.getTaskState task) == .finished then + match ← IO.wait task with + | .ok x => pure (some x) + | .error e => throw e + else if (← IO.monoMsNow) ≥ deadline then + pure none + else + IO.sleep pause + awaitUntil task deadline (min (pause * 2) 10) + +/-- +Runs `act`, failing with `name` if it has not finished after `ms × timeScale` milliseconds. +-/ +def hangGuard {α : Type} (name : String) (ms : Nat) (act : IO α) : IO α := do + let scale ← timeScale + let task ← IO.asTask act + match ← awaitUntil task ((← IO.monoMsNow) + ms * scale) 1 with + | some x => pure x + | none => + IO.cancel task + throw <| IO.userError s!"'{name}' did not finish within {ms * scale} ms" + +/-- +Fails with `msg` unless `cond` holds. +-/ +def ensure (cond : Bool) (msg : String) : IO Unit := + unless cond do throw <| IO.userError msg + +/-- +`repr a` on a single line, for comparing whole values against a string in a table. +-/ +def reprLine {α : Type} [Repr α] (a : α) : String := + (repr a).pretty 100000 + +/-- +Fails unless `got == want`, showing both values. +-/ +def expectEq {α : Type} [BEq α] [Repr α] (what : String) (got want : α) : IO Unit := + unless got == want do + throw <| IO.userError s!"{what}: expected {reprLine want}, got {reprLine got}" + +/-- +How a table case names itself in failure messages. +-/ +class CaseLabel (α : Type) where + label : α → String + +instance : CaseLabel String := ⟨id⟩ + +instance {β : Type} : CaseLabel (String × β) := ⟨(·.1)⟩ + +/-- +Runs `run` on every case under `hangGuard` (`ms` per case) and fails once at the end, listing every +failing case by its label. A case that hangs fails like any other. +-/ +def checkCases {α : Type} [CaseLabel α] (group : String) (cases : Array α) (run : α → IO Unit) + (ms : Nat := 10000) : IO Unit := do + let mut failures : Array String := #[] + for c in cases do + let label := CaseLabel.label c + try hangGuard s!"{group}: {label}" ms (run c) + catch e => failures := failures.push s!" {label}: {e}" + unless failures.isEmpty do + throw <| IO.userError + s!"[{group}] {failures.size} of {cases.size} cases failed:\n{"\n".intercalate failures.toList}" + +/-- +A deterministic SplitMix64 generator. +-/ +structure Rng where + state : UInt64 + +namespace Rng + +/-- +Returns the next 64-bit output and the advanced generator. +-/ +def next (g : Rng) : UInt64 × Rng := + let s := g.state + 0x9E3779B97F4A7C15 + let z := (s ^^^ (s >>> 30)) * 0xBF58476D1CE4E5B9 + let z := (z ^^^ (z >>> 27)) * 0x94D049BB133111EB + (z ^^^ (z >>> 31), ⟨s⟩) + +/-- +Returns a number in `[0, n)`, or 0 when `n = 0`. +-/ +def below (g : Rng) (n : Nat) : Nat × Rng := + let (x, g) := g.next + (if n == 0 then 0 else x.toNat % n, g) + +end Rng + +/-- +A raw HTTP/1.x request. `host := none` omits the `Host` field; `extra` holds complete field lines +(each ending in CRLF) and goes after `Host`. +-/ +def rawRequest (method : String := "GET") (target : String := "/") (version : String := "HTTP/1.1") + (host : Option String := some "example.com") (extra : String := "") (body : String := "") : + String := + let hostLine := match host with + | some h => s!"Host: {h}\x0d\n" + | none => "" + s!"{method} {target} {version}\x0d\n{hostLine}{extra}\x0d\n{body}" + +/-- +The exact response a server writes for `Response.ok |>.text content` on a connection that closes +after it. +-/ +def okResponse (content : String := "ok") (close : Bool := true) : String := + let connection := if close then "Connection: close\x0d\n" else "" + s!"HTTP/1.1 200 OK\x0d\nContent-Type: text/plain; charset=utf-8\x0d\nServer: LeanHTTP/1.1\x0d\n" ++ + s!"{connection}Content-Length: {content.utf8ByteSize}\x0d\n\x0d\n{content}" + +/-- +The server config of the table helpers: a short lingering timeout and no `Date` field. +-/ +def testConfig : Config := + { lingeringTimeout := 1000, generateDate := false } + +/-- +Sends `raw` to `serveConnection` over a mock transport and returns every byte the server wrote. +With `closeInput`, the client's side is closed after `raw`, so the server sees EOF. +-/ +def serveBytes {σ : Type} [Server.Handler σ] (raw : ByteArray) (handler : σ) + (config : Config := testConfig) (closeInput : Bool := false) : IO ByteArray := do + let (client, server) ← Mock.new + Async.block do + client.send raw + if closeInput then client.getSendChan.close + Server.serveConnection server handler config |>.run + return (← client.recv?).getD .empty + +/-- +`serveBytes` with the UTF-8 bytes of `raw`. +-/ +def serveRaw {σ : Type} [Server.Handler σ] (raw : String) (handler : σ) + (config : Config := testConfig) (closeInput : Bool := false) : IO ByteArray := + serveBytes raw.toUTF8 handler config closeInput + +/-- +`serveRaw` with the client's side closed after `raw`. +-/ +def serveRawClosed {σ : Type} [Server.Handler σ] (raw : String) (handler : σ) + (config : Config := testConfig) : IO ByteArray := + serveRaw raw handler config (closeInput := true) + +/-- +A request as a recording handler saw it. +-/ +structure Seen where + method : String + target : String + body : String + deriving Repr, BEq + +private structure Recorder where + seen : IO.Ref (Array Seen) + readBody : Bool + +private instance : Server.Handler Recorder where + onRequest self req := do + let body ← if self.readBody then req.body.readAll else pure "" + self.seen.modify (·.push ⟨toString req.line.method, toString req.line.uri, body⟩) + Response.ok |>.text "ok" + +/-- +Serves `raw` with a handler that records every request it is called with and answers `200 ok`. +Returns the bytes written and the recorded requests, in order. +-/ +def serveRecording (raw : String) (readBody : Bool := true) (config : Config := testConfig) + (closeInput : Bool := false) : IO (ByteArray × Array Seen) := do + let seen ← IO.mkRef #[] + let response ← serveRaw raw ({ seen, readBody } : Recorder) config closeInput + return (response, ← seen.get) + +/-- +What a response must look like. +-/ +inductive Want where + /-- These exact bytes. -/ + | exact (response : String) + /-- A response that starts with this prefix, e.g. `"HTTP/1.1 200"`. -/ + | status (prefix_ : String) + /-- A single `200` response whose content is exactly this. -/ + | body (content : String) + /-- The bytes contain this. -/ + | contains (needle : String) + /-- The bytes do not contain this. -/ + | absent (needle : String) + /-- Exactly this many `HTTP/1.1 ` status lines. -/ + | responses (n : Nat) + /-- Every one of these. -/ + | all (wants : List Want) + +namespace Want + +private def text (response : ByteArray) : String := + String.fromUTF8? response |>.getD s!"<{response.size} bytes, not UTF-8>" + +/-- +Fails unless `response` matches `want`. +-/ +partial def check (want : Want) (response : ByteArray) : IO Unit := do + let t := text response + match want with + | .exact r => + ensure (t == r) s!"expected:\n{r.quote}\ngot:\n{t.quote}" + | .status p => + ensure (t.startsWith p) s!"expected status {p.quote}, got:\n{t.quote}" + | .body c => + ensure (t.startsWith "HTTP/1.1 200" && (t.splitOn "HTTP/1.1 ").length == 2 && + (t.splitOn "\x0d\n\x0d\n").drop 1 == [c]) + s!"expected one 200 response with content {c.quote}, got:\n{t.quote}" + | .contains n => + ensure (t.contains n) s!"expected to contain {n.quote}, got:\n{t.quote}" + | .absent n => + ensure (!t.contains n) s!"expected NOT to contain {n.quote}, got:\n{t.quote}" + | .responses n => + let got := (t.splitOn "HTTP/1.1 ").length - 1 + ensure (got == n) s!"expected {n} HTTP/1.1 responses, got {got}:\n{t.quote}" + | .all ws => ws.forM (check · response) + +end Want + +/-- +Serves `raw` with `handler` and checks the response against `want`. +-/ +def checkHandler {σ : Type} [Server.Handler σ] (raw : String) (handler : σ) (want : Want) + (config : Config := testConfig) (closeInput : Bool := false) : IO Unit := do + want.check (← serveRaw raw handler config closeInput) + +end Std.Http.Internal.Test
diff --git a/src/Std/Http/Test/Helpers.lean b/src/Std/Http/Test/Helpers.lean index dd79daa..380f357 100644 --- a/src/Std/Http/Test/Helpers.lean +++ b/src/Std/Http/Test/Helpers.lean
@@ -9,6 +9,7 @@ public import Std.Http.Server public import Std.Async public import Std.Async.Timer +public import Std.Http.Test.Assert import Init.Data.String.Legacy public section
diff --git a/src/Std/Http/Test/Machine.lean b/src/Std/Http/Test/Machine.lean new file mode 100644 index 0000000..86fd94f --- /dev/null +++ b/src/Std/Http/Test/Machine.lean
@@ -0,0 +1,448 @@ +/- +Copyright (c) 2026 Lean FRO, LLC. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sofia Rodrigues +-/ +module + +prelude +public import Std.Http.Protocol.H1 +public import Std.Http.Test.Assert +import Init.Data.String.Legacy + +public section + +/-! +# Drivers for the HTTP/1.1 machine tests + +`MachineTester` is a chainable builder over `Machine dir`: each operation returns a new tester, +assertion failures accumulate, and `run` throws them as one error. The functions after it drive a +server machine through a request split into reads in a given way, and step a machine until it halts. +-/ + +open Std Http +open Std.Http.Protocol.H1 + +namespace Std.Http.Internal.Test + +structure MachineTester (dir : Direction) where + + /-- + Human-readable name used in error messages. + -/ + name : String + + /-- + The machine under test. + -/ + machine : Machine dir + + /-- + Events and output produced by the most recent `step` or `pullBody`. + -/ + lastStep : Option (StepResult dir) := none + + /-- + Body chunks collected by `drainBody` / `pullBody`. + -/ + pulled : Array PulledChunk := #[] + + /-- + Cumulative wire output across all `step` calls. + -/ + allOutput : ByteArray := .empty + + /-- + Accumulated assertion failures; `run` throws if non-empty. + -/ + errors : Array String := #[] + +namespace MachineTester + +def addError (t : MachineTester dir) (msg : String) : MachineTester dir := + { t with errors := t.errors.push s!"[{t.name}] {msg}" } + +def withLastStep + (t : MachineTester dir) (ctx : String) + (k : MachineTester dir → StepResult dir → MachineTester dir) : MachineTester dir := + match t.lastStep with + | none => t.addError s!"{ctx}: no step result (call .step first)" + | some step => k t step + +/-- Create a new server-side tester (receives requests, sends responses). -/ +def receiving (name : String) (config : Protocol.H1.Config := {}) : MachineTester .receiving := + { name, machine := { config } } + +/-- Create a new client-side tester (sends requests, receives responses). -/ +def sending (name : String) (config : Protocol.H1.Config := {}) : MachineTester .sending := + { name, machine := { config } } + +/-- Feed a UTF-8 string to the machine. -/ +def feed (t : MachineTester dir) (data : String) : MachineTester dir := + { t with machine := t.machine.feed data.toUTF8, lastStep := none } + +/-- Feed raw bytes to the machine. -/ +def feedBytes (t : MachineTester dir) (data : ByteArray) : MachineTester dir := + { t with machine := t.machine.feed data, lastStep := none } + +/-- Run one step of the state machine and record the result. -/ +def step (t : MachineTester dir) : MachineTester dir := + let (machine, stepResult) := t.machine.step + let allOutput := t.allOutput ++ stepResult.output.toByteArray + { t with machine, lastStep := some stepResult, allOutput } + +/-- +Pull at most one body chunk. Updates `pulled` and replaces `lastStep` with the +events emitted during the pull. +-/ +def pullBody (t : MachineTester dir) : MachineTester dir := + let (machine, chunk?) := t.machine.pullBody + let (machine, pullEvents) := machine.takeEvents + let pulled := match chunk? with + | some chunk => t.pulled.push chunk + | none => t.pulled + { t with machine, pulled, lastStep := some { events := pullEvents } } + +/-- +Drain all immediately-available body chunks. + +The loop exits when `canPullBodyNow` becomes false (either the body is complete +or the machine stalls waiting for more data). The stall flag is set internally +by `pullBody`, so no explicit `remainingBytes` guard is needed. +-/ +def drainBody (t : MachineTester dir) (fuel : Nat := 4096) : MachineTester dir := Id.run do + let mut t := t + let mut remaining := fuel + while remaining > 0 && t.machine.canPullBodyNow do + remaining := remaining - 1 + t := t.pullBody + t + +/-- Set the known outgoing body size (forwarded to the writer). -/ +def setKnownSize (t : MachineTester dir) (size : Body.Length) : MachineTester dir := + { t with machine := t.machine.setKnownSize size } + +/-- Signal EOF on the reader input (no more socket bytes will arrive). -/ +def noMoreInput (t : MachineTester dir) : MachineTester dir := + { t with machine := t.machine.noMoreInput } + +/-- Send a message head (request for `.sending`, response for `.receiving`). -/ +def send (t : MachineTester dir) (head : Message.Head dir.swap) : MachineTester dir := + { t with machine := t.machine.send head } + +/-- Signal that the application has finished writing the message body. -/ +def userClosedBody (t : MachineTester dir) : MachineTester dir := + { t with machine := t.machine.userClosedBody } + +/-- Resolve an `Expect: 100-continue` decision. No-op for `.sending` direction. -/ +def canContinue (t : MachineTester dir) (status : Status) : MachineTester dir := + { t with machine := t.machine.canContinue status } + +/-- Send an error response with `Connection: close` and shut down input. Only valid for `.receiving`. -/ +def closeWithError (t : MachineTester .receiving) (status : Status) : MachineTester .receiving := + { t with machine := t.machine.closeWithError status } + +/-- Enqueue body chunks into the writer buffer. -/ +def sendData (t : MachineTester dir) (chunks : Array Chunk) : MachineTester dir := + { t with machine := t.machine.sendData chunks } + +/-- Enqueue raw bytes as a single body chunk into the writer buffer. -/ +def sendBytes (t : MachineTester dir) (data : ByteArray) : MachineTester dir := + t.sendData #[{ data, extensions := #[] }] + +/-- Assert a predicate on the current machine. -/ +def assert (t : MachineTester dir) (pred : Machine dir → Bool) (msg : String) : MachineTester dir := + if pred t.machine then t else t.addError msg + +/-- Assert that `machine.error` is `none`. -/ +def assertNoError (t : MachineTester dir) : MachineTester dir := + t.assert (fun m => m.error == none) + s!"machine should have no error, got: {repr t.machine.error}" + +/-- Assert that the machine has failed with the given error. -/ +def assertFailedWith (t : MachineTester dir) (expected : Error) : MachineTester dir := + t.assert (fun m => m.error == some expected) + s!"expected error {repr expected}, got {repr t.machine.error}" + +/-- Assert that `canPullBodyNow` is true. -/ +def assertCanPullBodyNow (t : MachineTester dir) : MachineTester dir := + t.assert (·.canPullBodyNow) "expected canPullBodyNow = true" + +/-- Assert that the reader is in the `complete` state. -/ +def assertReaderComplete (t : MachineTester dir) : MachineTester dir := + t.assert (·.isReaderComplete) + s!"expected reader to be complete, state: {repr t.machine.reader.state}" + +/-- Assert that the reader is in the `closed` state. -/ +def assertReaderClosed (t : MachineTester dir) : MachineTester dir := + t.assert (·.isReaderClosed) + s!"expected reader to be closed, state: {repr t.machine.reader.state}" + +/-- Assert that `keepAlive` is true on the machine. -/ +def assertKeepAlive (t : MachineTester dir) : MachineTester dir := + t.assert (·.keepAlive) "expected keepAlive = true" + +/-- Assert that `keepAlive` is false on the machine. -/ +def assertNotKeepAlive (t : MachineTester dir) : MachineTester dir := + t.assert (fun m => !m.keepAlive) "expected keepAlive = false" + +/-- Assert that `isWaitingMessage` is true (writer in `waitingHeaders`, `!sentMessage`). -/ +def assertIsWaitingMessage (t : MachineTester dir) : MachineTester dir := + t.assert (·.isWaitingMessage) "expected isWaitingMessage = true" + +/-- Assert that `halted` is true (both reader and writer closed, no output). -/ +def assertHalted (t : MachineTester dir) : MachineTester dir := + t.assert (·.halted) "expected machine to be halted" + +/-- Assert that at least one event in the last step matches `pred`. -/ +def assertHasEvent + (t : MachineTester dir) (pred : Event dir → Bool) (msg : String) : MachineTester dir := + t.withLastStep "assertHasEvent" fun t step => + if step.events.any pred then t + else t.addError s!"{msg}\n events: {repr step.events}" + +/-- Assert that no event in the last step matches `pred`. -/ +def assertNoEvent + (t : MachineTester dir) (pred : Event dir → Bool) (msg : String) : MachineTester dir := + t.withLastStep "assertNoEvent" fun t step => + if step.events.any pred then + t.addError s!"{msg}\n events: {repr step.events}" + else t + +/-- Assert that the last step contains an `endHeaders` event. -/ +def assertHasEndHeaders (t : MachineTester dir) : MachineTester dir := + t.assertHasEvent (fun | .endHeaders _ => true | _ => false) "expected endHeaders event" + +/-- Assert that the last step contains a `closeBody` event. -/ +def assertHasCloseBody (t : MachineTester dir) : MachineTester dir := + t.assertHasEvent (fun | .closeBody => true | _ => false) "expected closeBody event" + +/-- Assert that the last step contains a `next` event. -/ +def assertHasNext (t : MachineTester dir) : MachineTester dir := + t.assertHasEvent (fun | .next => true | _ => false) "expected next event" + +/-- Assert that the last step contains a `continue` event. -/ +def assertHasContinue (t : MachineTester dir) : MachineTester dir := + t.assertHasEvent (fun | .«continue» => true | _ => false) "expected continue event" + +/-- Inspect the `endHeaders` payload in the last step. -/ +def onEndHeaders + (t : MachineTester dir) + (f : MachineTester dir → Message.Head dir → MachineTester dir) : MachineTester dir := + t.withLastStep "onEndHeaders" fun t step => + match step.events.findSome? (fun | .endHeaders h => some h | _ => none) with + | none => t.addError "onEndHeaders: no endHeaders event in last step" + | some head => f t head + +/-- Assert that the cumulative output starts with the given ASCII string. -/ +def assertOutputStartsWith (t : MachineTester dir) (pfx : String) (msg : String) : MachineTester dir := + let s := String.fromUTF8! t.allOutput + if s.startsWith pfx then t + else + let preview := String.fromUTF8! (t.allOutput.extract 0 (min t.allOutput.size 120)) + t.addError s!"{msg}: expected output to start with {repr pfx}\n got: {repr preview}" + +/-- Assert that the cumulative output contains the given ASCII substring. -/ +def assertOutputContains (t : MachineTester dir) (needle : String) (msg : String) : MachineTester dir := + if (String.fromUTF8! t.allOutput).contains needle then t + else + let preview := String.fromUTF8! (t.allOutput.extract 0 (min t.allOutput.size 160)) + t.addError s!"{msg}: expected output to contain {repr needle}\n output: {repr preview}" + +/-- Assert that the cumulative output does not contain the given ASCII substring. -/ +def assertOutputNotContains (t : MachineTester dir) (needle : String) (msg : String) : MachineTester dir := + if (String.fromUTF8! t.allOutput).contains needle then + let preview := String.fromUTF8! (t.allOutput.extract 0 (min t.allOutput.size 160)) + t.addError s!"{msg}: expected output NOT to contain {repr needle}\n output: {repr preview}" + else t + +/-- Assert that the total bytes pulled so far equal `expected`. -/ +def assertPulledBody (t : MachineTester dir) (expected : ByteArray) : MachineTester dir := + let got := t.pulled.foldl (fun acc c => acc ++ c.chunk.data) ByteArray.empty + if got == expected then t + else t.addError + s!"body mismatch:\n expected={String.fromUTF8! expected |>.quote}\n got={String.fromUTF8! got |>.quote}" + +/-- Assert that at least one chunk was pulled and the last one is `final`. -/ +def assertLastChunkFinal (t : MachineTester dir) : MachineTester dir := + match t.pulled.back? with + | none => t.addError "assertLastChunkFinal: no chunks pulled yet" + | some chunk => + if chunk.final then t + else t.addError "expected last pulled chunk to be final" + +/-- Run a custom check on the current machine state. -/ +def onMachine (t : MachineTester dir) (f : MachineTester dir → Machine dir → MachineTester dir) : MachineTester dir := + f t t.machine + +/-- Throw if any assertion has failed; otherwise succeed. -/ +def run (t : MachineTester dir) : IO Unit := + unless t.errors.isEmpty do + throw <| IO.userError <| "\n".intercalate t.errors.toList + +end MachineTester + +/-- +Steps `machine` `n` times and returns it with everything it wrote. +-/ +def stepOutput {dir : Direction} (machine : Machine dir) (n : Nat := 4) : Machine dir × String := Id.run do + let mut machine := machine + let mut out := ByteArray.empty + for _ in [0:n] do + let (next, step) := machine.step + machine := next + out := out ++ step.output.toByteArray + return (machine, String.fromUTF8! out) + +/-- +Steps `machine` until it halts. Returns everything it wrote and every event it emitted, or `none` +if it has not halted after `fuel` steps. +-/ +def runToHalt {dir : Direction} (machine : Machine dir) (fuel : Nat := 16) : + Option (String × Array (Event dir)) := Id.run do + let mut machine := machine + let mut out := "" + let mut events := #[] + for _ in [0:fuel] do + let (next, step) := machine.step + machine := next + out := out ++ String.fromUTF8! step.output.toByteArray + events := events ++ step.events + if machine.halted then return some (out, events) + return none + +/-- +What a server machine did with a request fed in pieces. +-/ +structure Trace where + machine : Machine .receiving + events : Array (Event .receiving) := #[] + output : ByteArray := .empty + pulled : Array PulledChunk := #[] + +/-- +The body bytes pulled, in order. +-/ +def Trace.body (t : Trace) : ByteArray := + t.pulled.foldl (fun acc c => acc ++ c.chunk.data) .empty + +/-- +Feeds `parts` to a server machine one read at a time, stepping after each and pulling at most one +body chunk, as a streaming caller does; then steps once more and drains the ready body. +-/ +def feedParts (parts : Array ByteArray) (config : Protocol.H1.Config := {}) : Trace := Id.run do + let mut machine : Machine .receiving := { config := config } + let mut events : Array (Event .receiving) := #[] + let mut output := ByteArray.empty + let mut pulled : Array PulledChunk := #[] + for part in parts do + machine := machine.feed part + let (machine', step) := machine.step + machine := machine' + events := events ++ step.events + output := output ++ step.output.toByteArray + -- An empty buffer is not handed to body parsing. + if machine.canPullBodyNow && machine.reader.input.remainingBytes > 0 then + let (machine', pulledNow?) := machine.pullBody + let (machine', pullEvents) := machine'.takeEvents + machine := machine' + if let some pulledNow := pulledNow? then + pulled := pulled.push pulledNow + events := events ++ pullEvents + let (machine', finalStep) := machine.step + machine := machine' + events := events ++ finalStep.events + output := output ++ finalStep.output.toByteArray + let mut fuel := 4096 + while fuel > 0 && machine.canPullBodyNow && machine.reader.input.remainingBytes > 0 do + fuel := fuel - 1 + let (machine', pulledNow?) := machine.pullBody + let (machine', pullEvents) := machine'.takeEvents + machine := machine' + events := events ++ pullEvents + match pulledNow? with + | some pulledNow => pulled := pulled.push pulledNow + | none => break + return { machine, events, output, pulled } + +/-- +`data` split into the reads `[0, i)` and `[i, size)`. +-/ +def splitAt (data : ByteArray) (i : Nat) : Array ByteArray := + #[data.extract 0 i, data.extract i data.size] + +/-- +`data` split into one-byte reads. +-/ +def eachByte (data : ByteArray) : Array ByteArray := + (Array.range data.size).map fun i => data.extract i (i + 1) + +/-- +`feedParts` with `data` split into two reads at `i`. +-/ +def feedSplit (data : ByteArray) (i : Nat) (config : Protocol.H1.Config := {}) : Trace := + feedParts (splitAt data i) config + +/-- +`feedParts` with `data` fed one byte per read. +-/ +def feedEachByte (data : ByteArray) (config : Protocol.H1.Config := {}) : Trace := + feedParts (eachByte data) config + +/-- +Feeds the first of `parts` and steps once, so the head is read; then feeds each later part and pulls +the body once after each, without stepping again. With `drainLast`, the last part is pulled until no +chunk comes out, since one read can hold several chunks. +-/ +def feedPullOnly (parts : Array ByteArray) (config : Protocol.H1.Config := {}) (drainLast : Bool := false) : + Trace := Id.run do + let mut machine : Machine .receiving := { config := config } + let mut events : Array (Event .receiving) := #[] + let mut output := ByteArray.empty + let mut pulled : Array PulledChunk := #[] + for h : i in [0:parts.size] do + machine := machine.feed parts[i] + if i == 0 then + let (machine', step) := machine.step + machine := machine' + events := events ++ step.events + output := output ++ step.output.toByteArray + let (machine', pulledNow?) := machine.pullBody + let (machine', pullEvents) := machine'.takeEvents + machine := machine' + events := events ++ pullEvents + if let some pulledNow := pulledNow? then + pulled := pulled.push pulledNow + if drainLast then + let mut fuel := 4096 + while fuel > 0 && machine.canPullBodyNow do + fuel := fuel - 1 + let (machine', pulledNow?) := machine.pullBody + let (machine', pullEvents) := machine'.takeEvents + machine := machine' + events := events ++ pullEvents + match pulledNow? with + | some pulledNow => pulled := pulled.push pulledNow + | none => break + return { machine, events, output, pulled } + +/-- +Fails unless the trace read a whole message whose body is `want`: no failure, an `endHeaders` +event, a `needMoreData` event when `needMoreData` is set, the exact body, and, when there is a body, +a `closeBody` event and a final last chunk. +-/ +def expectBody (t : Trace) (want : ByteArray) (needMoreData : Bool := true) : IO Unit := do + ensure (!t.machine.failed) s!"machine ended failed with events:\n{repr t.events}" + ensure (!t.events.any (· matches .failed _)) s!"unexpected failure events:\n{repr t.events}" + ensure (t.events.any (· matches .endHeaders _)) s!"missing endHeaders event:\n{repr t.events}" + if needMoreData then + ensure (t.events.any (· matches .needMoreData _)) + s!"expected at least one needMoreData event:\n{repr t.events}" + ensure (t.body == want) + s!"body mismatch:\nexpected={(String.fromUTF8? want).getD "<binary>" |>.quote}\nactual={(String.fromUTF8? t.body).getD "<binary>" |>.quote}" + if want.size > 0 || t.pulled.size > 0 then + ensure (t.events.any (· matches .closeBody)) s!"missing closeBody event:\n{repr t.events}" + ensure (t.pulled.any (·.final)) "expected at least one final pulled chunk" + ensure ((t.pulled.back?.map (·.final)).getD false) "expected last pulled chunk to be final" + +end Std.Http.Internal.Test
diff --git a/tests/async/compile_bench/http_server_concurrent.lean b/tests/async/compile_bench/http_server_concurrent.lean index 6012f84..e40ea23 100644 --- a/tests/async/compile_bench/http_server_concurrent.lean +++ b/tests/async/compile_bench/http_server_concurrent.lean
@@ -1,4 +1,5 @@ import Std.Http +import Std.Http.Test.Helpers open Std Async open Std Http Internal Test
diff --git a/tests/async/elab/async_http_body_framing.lean b/tests/async/elab/async_http_body_framing.lean deleted file mode 100644 index 0b8d1e9..0000000 --- a/tests/async/elab/async_http_body_framing.lean +++ /dev/null
@@ -1,346 +0,0 @@ -import Std.Http.Test.Helpers - -open Std.Async -open Std Http Internal Test - --- RFC 9112 §6: Transfer-Encoding and Content-Length framing - -#eval runGroup "RFC 9112 §6: chunked body baseline" do - check "CL body accepted and echoed" - (raw := mkPost "/echo" "hello" "Connection: close\x0d\n") - (handler := echoHandler) - (expect := fun r => assertStatus r "HTTP/1.1 200" *> assertContains r "hello") - - check "chunked body accepted and echoed" - (raw := mkChunked "/" (chunk "hello" ++ chunkEnd) "Connection: close\x0d\n") - (handler := echoHandler) - (expect := fun r => assertStatus r "HTTP/1.1 200" *> assertContains r "hello") - - check "chunk-size uppercase and leading zeros accepted" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n000A\x0d\n0123456789\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := fun r => assertStatus r "HTTP/1.1 200" *> assertContains r "0123456789") - - check "chunk extensions with token and quoted value accepted" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5;ext=val;quoted=\"ok\"\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := fun r => assertStatus r "HTTP/1.1 200" *> assertContains r "hello") - -#eval runGroup "RFC 9112 §6: chunked parse errors" do - check "invalid chunk-size token → 400" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\nG\x0d\nabc\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := (assertExact · r400)) - - checkClose "chunk terminator must be CRLF → 400" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n3\x0d\nxxx__1a\x0d\n") - (handler := echoHandler) - (expect := (assertExact · r400)) - - checkClose "missing terminal 0-chunk at EOF → 400" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n") - (handler := echoHandler) - (expect := (assertExact · r400)) - - check "chunk-size trailing whitespace → 400" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5 \x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := (assertExact · r400)) - -#eval runGroup "RFC 9112 §6.1: Transfer-Encoding validation (Critical)" do - -- TE + CL → request smuggling prevention - check "TE + Content-Length → 400" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nContent-Length: 5\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := okHandler) - (expect := (assertExact · r400)) - - -- chunked must be the last coding - check "TE: chunked not last (chunked, gzip) → 400" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked, gzip\x0d\nConnection: close\x0d\n\x0d\nbody") - (handler := okHandler) - (expect := (assertExact · r400)) - - check "TE: duplicate chunked → 400" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked, chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := okHandler) - (expect := (assertExact · r400)) - - check "TE: gzip alone (no chunked framing) → 400" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: gzip\x0d\nConnection: close\x0d\n\x0d\nbody") - (handler := okHandler) - (expect := (assertExact · r400)) - - check "TE: deflate alone → 400" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: deflate\x0d\nConnection: close\x0d\n\x0d\nbody") - (handler := okHandler) - (expect := (assertExact · r400)) - - check "TE: identity alone → 400" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: identity\x0d\nConnection: close\x0d\n\x0d\nbody") - (handler := okHandler) - (expect := (assertExact · r400)) - - -- RFC 9110 §5.6.1.2: a recipient ignores empty list elements - check "TE: empty list element before chunked is ignored" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: ,chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := fun r => assertStatus r "HTTP/1.1 200" *> assertContains r "hello") - - -- RFC 9110 §5.3: the field lines combine into `chunked, gzip`, whose final coding is not chunked - check "TE: field lines chunked then gzip → 400" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nTransfer-Encoding: gzip\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := (assertExact · r400)) - - -- NUL and control chars in TE value - check "NUL byte in TE value → 400" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunk\x00ed\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := okHandler) - (expect := (assertExact · r400)) - - check "control char (0x01) in TE value → 400" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunk\x01ed\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := okHandler) - (expect := (assertExact · r400)) - -#eval runGroup "RFC 9112 §6.1: Transfer-Encoding codings" do - -- §6.1: a server answers a transfer coding it does not understand with 501; only `chunked` is - -- decoded, so the handler never sees a body still coded with another coding - check "gzip, chunked → 501, handler not run" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: gzip, chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := (assertExact · r501)) - - -- RFC 9110 §5.3: the same codings over two field lines are the same list - check "gzip and chunked on two field lines → 501" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: gzip\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := (assertExact · r501)) - - check "br, chunked → 501" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: br, chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := (assertExact · r501)) - - -- A coding the handler decodes itself reaches it with the chunked framing removed and the field - -- that names the codings left - check "gzip, chunked accepted when listed in acceptedTransferCodings" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: gzip, chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := fun req => do - let te := match req.line.headers.getAll? Header.Name.transferEncoding with - | some vs => String.intercalate "|" (vs.map (fun (v : Header.Value) => v.value) |>.toList) - | none => "<none>" - let body : String ← req.body.readAll - Response.ok |>.text s!"{te};{body}") - (config := { defaultConfig with acceptedTransferCodings := #["gzip"] }) - (expect := fun r => assertStatus r "HTTP/1.1 200" *> assertContains r "gzip, chunked;hello") - - check "gzip and chunked on two field lines accepted when gzip is listed" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: gzip\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (config := { defaultConfig with acceptedTransferCodings := #["gzip"] }) - (expect := fun r => assertStatus r "HTTP/1.1 200" *> assertContains r "hello") - - check "br, chunked → 501 when only gzip is accepted" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: br, chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (config := { defaultConfig with acceptedTransferCodings := #["gzip"] }) - (expect := (assertExact · r501)) - - check "mixed-case Chunked accepted (codings are lowercased)" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: Chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := fun r => assertStatus r "HTTP/1.1 200" *> assertContains r "hello") - - check "TE trailing OWS accepted" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked \x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := fun r => assertStatus r "HTTP/1.1 200") - --- RFC 9112 §6.3: Content-Length - -#eval runGroup "RFC 9112 §6.3: Content-Length" do - check "Content-Length with leading zeros accepted" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 005\x0d\nConnection: close\x0d\n\x0d\nhello") - (handler := echoHandler) - (expect := fun r => assertStatus r "HTTP/1.1 200" *> assertContains r "hello") - - check "very large Content-Length → 413" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 99999999999999999999\x0d\nConnection: close\x0d\n\x0d\nhello") - (handler := echoHandler) - (expect := (assertExact · r413)) - - check "duplicate Content-Length same value → 400" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 5\x0d\nContent-Length: 5\x0d\nConnection: close\x0d\n\x0d\nhello") - (handler := echoHandler) - (expect := (assertExact · r400)) - - check "duplicate Content-Length different values → 400" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 3\x0d\nContent-Length: 5\x0d\nConnection: close\x0d\n\x0d\nabc") - (handler := echoHandler) - (expect := (assertExact · r400)) - - check "non-numeric Content-Length → 400" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: abc\x0d\nConnection: close\x0d\n\x0d\nbody") - (handler := okHandler) - (expect := (assertExact · r400)) - - check "negative Content-Length → 400" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: -1\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := (assertExact · r400)) - - check "extra bytes beyond CL become next pipelined request" - (raw := - "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 5\x0d\n\x0d\nhello" ++ - "GET /second HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := fun req => do - let body : String ← req.body.readAll - Response.ok |>.text s!"{toString req.line.uri}:{body}") - (expect := fun r => - assertResponseCount r 2 *> - assertContains r "/:hello" *> - assertContains r "/second:" *> - assertAbsent r "/second:hello") - --- Chunk extension limits - -#eval runGroup "Chunk extension name length (default limit = 256)" do - check "ext name at 256 bytes → accepted" - (raw := - let name := String.ofList (List.replicate 256 'a') - s!"POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5;{name}\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := fun r => assertStatus r "HTTP/1.1 200") - - check "ext name at 257 bytes → 400" - (raw := - let name := String.ofList (List.replicate 257 'a') - s!"POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5;{name}\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := (assertExact · r400)) - -#eval runGroup "Chunk extension value length (default limit = 256)" do - check "ext token value at 256 bytes → accepted" - (raw := - let v := String.ofList (List.replicate 256 'v') - s!"POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5;ext={v}\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := fun r => assertStatus r "HTTP/1.1 200") - - check "ext token value at 257 bytes → 400" - (raw := - let v := String.ofList (List.replicate 257 'v') - s!"POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5;ext={v}\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := (assertExact · r400)) - - check "ext quoted value at 256 bytes → accepted" - (raw := - let v := String.ofList (List.replicate 256 'v') - s!"POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5;ext=\"{v}\"\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := fun r => assertStatus r "HTTP/1.1 200") - - check "ext quoted value at 257 bytes → 400" - (raw := - let v := String.ofList (List.replicate 257 'v') - s!"POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5;ext=\"{v}\"\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := (assertExact · r400)) - -#eval runGroup "Chunk extension count (default limit = 16)" do - check "16 extensions → accepted" - (raw := - let exts := (List.range 16).foldl (fun acc i => acc ++ s!";e{i}") "" - s!"POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5{exts}\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := fun r => assertStatus r "HTTP/1.1 200") - - check "17 extensions → 400" - (raw := - let exts := (List.range 17).foldl (fun acc i => acc ++ s!";e{i}") "" - s!"POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5{exts}\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := (assertExact · r400)) - -#eval runGroup "Chunk extension count (custom limit)" do - let cfg := { defaultConfig with maxChunkExtensions := 1 } - - check "1 extension with limit=1 → accepted" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5;ext1\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (config := cfg) - (expect := fun r => assertStatus r "HTTP/1.1 200") - - check "2 extensions with limit=1 → 400" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5;ext1;ext2\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (config := cfg) - (expect := (assertExact · r400)) - - check "0 extensions with limit=1 → accepted" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (config := cfg) - (expect := fun r => assertStatus r "HTTP/1.1 200") - -#eval runGroup "Chunk extension misc" do - check "name-only extension (no value) → accepted" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5;novalue\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := fun r => assertStatus r "HTTP/1.1 200" *> assertContains r "hello") - - check "extension on terminal zero-chunk → accepted" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0;final-ext=done\x0d\n\x0d\n") - (handler := echoHandler) - (expect := fun r => assertStatus r "HTTP/1.1 200") - - check "extension with quoted-string value → accepted" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5;ext=\"hello world\"\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := fun r => assertStatus r "HTTP/1.1 200") - - check "non-token character in ext name → 400" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5;bad@name\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := (assertExact · r400)) - - check "multiple name=value extensions → accepted" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5;a=1;b=2;c=3\x0d\nhello\x0d\n0\x0d\n\x0d\n") - (handler := echoHandler) - (expect := fun r => assertStatus r "HTTP/1.1 200") - --- RFC 9112 §7.1: zero-size chunk encoding - -#eval runGroup "RFC 9112 §7.1: empty outgoing chunks must not be encoded as last-chunk" do - -- A zero-size chunk IS the last-chunk terminator; the encoder must skip empty non-final chunks - -- so that subsequent data remains visible to the client. - check "empty chunk with extensions before real data — real data still received" - (raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := fun _ => do - let ext := (Chunk.ExtensionName.ofString! "test", some (Chunk.ExtensionValue.ofString! "val")) - Response.ok |>.stream fun s => do - s.send { data := .empty, extensions := #[ext] } - s.send (Chunk.ofByteArray "after\n".toUTF8)) - (expect := fun r => assertStatus r "HTTP/1.1 200" *> assertContains r "after") - - check "multiple empty chunks before real data — real data still received" - (raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := fun _ => do - Response.ok |>.stream fun s => do - s.send Chunk.empty - s.send Chunk.empty - s.send (Chunk.ofByteArray "data\n".toUTF8)) - (expect := fun r => assertContains r "data") - -#eval runGroup "RFC 9110 §8.6: Content-Length strict decimal" do - check "underscore in Content-Length → 400" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 1_0\x0d\nConnection: close\x0d\n\x0d\n0123456789") - (handler := echoHandler) - (expect := fun r => assertExact r r400) - - check "valid Content-Length → 200" - (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 5\x0d\nConnection: close\x0d\n\x0d\nhello") - (handler := echoHandler) - (expect := fun r => assertStatus r "HTTP/1.1 200")
diff --git a/tests/async/elab/async_http_connect_response.lean b/tests/async/elab/async_http_connect_response.lean deleted file mode 100644 index fd55109..0000000 --- a/tests/async/elab/async_http_connect_response.lean +++ /dev/null
@@ -1,42 +0,0 @@ -import Std.Http -import Std.Http.Test.Helpers - -open Std Http -open Std.Http.Internal.Test - -/-! -Tests the server's answer to `CONNECT`. A 2xx turns the connection into a tunnel right after the -head, so it carries no framing fields and no content (RFC 9110 §9.3.6). The server does not tunnel, -so it closes the connection instead of parsing the tunnel's bytes as HTTP. --/ - -def connectRequest : String := - "CONNECT example.com:443 HTTP/1.1\x0d\nHost: example.com:443\x0d\n\x0d\n" - -/-- Bytes a client sends through the tunnel it believes is open. -/ -def tunnelBytes : String := - "GET /admin HTTP/1.1\x0d\nHost: a\x0d\nConnection: close\x0d\n\x0d\n" - -def handledHandler : TestHandler := fun req => - Response.ok |>.text s!"handled {req.line.method} {req.line.uri}" - -#eval runGroup "2xx to CONNECT" do - check "200 with content" (connectRequest ++ tunnelBytes) handledHandler fun r => do - assertStatus r "HTTP/1.1 200 OK" - assertResponseCount r 1 - assertAbsent r "Content-Length" - assertAbsent r "Transfer-Encoding" - assertAbsent r "handled" - check "200 streamed" (connectRequest ++ tunnelBytes) - (fun _ => Response.ok |>.stream fun out => out.send (Chunk.ofByteArray "tunnel".toUTF8)) - fun r => do - assertResponseCount r 1 - assertAbsent r "Transfer-Encoding" - assertAbsent r "tunnel" - --- Any other answer to CONNECT is an ordinary response. -#eval runGroup "non-2xx to CONNECT" do - checkClose "403" connectRequest (fun _ => Response.forbidden |>.text "no") fun r => do - assertStatus r "HTTP/1.1 403" - assertContains r "Content-Length: 2" - assertContains r "\x0d\n\x0d\nno"
diff --git a/tests/async/elab/async_http_connection_options.lean b/tests/async/elab/async_http_connection_options.lean deleted file mode 100644 index 179c90a..0000000 --- a/tests/async/elab/async_http_connection_options.lean +++ /dev/null
@@ -1,71 +0,0 @@ -import Std.Http -import Std.Http.Test.Helpers - -open Std Http -open Std.Http.Internal.Test -open Std.Http.Protocol.H1 - -/-! -Tests the `Connection` field: `close` ends the connection for every HTTP version, even next to -`keep-alive` (RFC 9112 §9.3, §9.6), and empty list elements are ignored (RFC 9110 §5.6.1.2). --/ - -/-- Steps `machine` `n` times and returns it with the bytes it wrote. -/ -def run (machine : Machine dir) (n : Nat := 4) : Machine dir × String := Id.run do - let mut machine := machine - let mut out := ByteArray.empty - for _ in [0:n] do - let (next, step) := machine.step - machine := next - out := out ++ step.output.toByteArray - return (machine, String.fromUTF8! out) - -def expect (cond : Bool) (msg : String) : IO Unit := - unless cond do throw (IO.userError msg) - --- `close` wins over `keep-alive` on an HTTP/1.0 request, in either order: one response, and the --- request pipelined after it is never served. -#eval runGroup "HTTP/1.0 close wins" do - for value in ["keep-alive, close", "close, keep-alive"] do - check s!"Connection: {value}" - s!"GET /1 HTTP/1.0\x0d\nConnection: {value}\x0d\n\x0d\nGET /2 HTTP/1.0\x0d\n\x0d\n" - uriHandler fun r => do - assertResponseCount r 1 - assertContains r "Connection: close" - assertAbsent r "/2" - -- Control: `keep-alive` alone keeps an HTTP/1.0 connection open. - check "Connection: keep-alive" - "GET /1 HTTP/1.0\x0d\nConnection: keep-alive\x0d\n\x0d\nGET /2 HTTP/1.0\x0d\n\x0d\n" - uriHandler fun r => assertResponseCount r 2 - --- A client's HTTP/1.0 request that lists both `keep-alive` and `close` goes out with `close`, and --- the machine does not keep the connection. -#eval show IO Unit from do - let headers := Headers.empty - |>.insert Header.Name.host (.mk "a") - |>.insert Header.Name.connection (.mk "keep-alive, close") - let head : Request.Head := { method := .get, version := .v10, uri := RequestTarget.parse! "/", headers } - let m : Machine .sending := { config := {} } - let (m, out) := run (m.setKnownSize (.fixed 0) |>.send head |>.userClosedBody) - expect (out.contains "Connection: close" && !out.contains "keep-alive") - s!"client HTTP/1.0 request: expected Connection: close, got {out.quote}" - expect (!m.keepAlive) "client HTTP/1.0 request with close: the machine kept the connection" - --- Empty elements of a `Connection` list are skipped, so both pipelined requests are answered. -#eval runGroup "empty list elements" do - for value in ["keep-alive, ", ", keep-alive", "keep-alive,,", ""] do - check s!"Connection: {value.quote}" - (mkGet "/1" s!"Connection: {value}\x0d\n" ++ mkGetClose "/2") - uriHandler fun r => assertResponseCount r 2 - -#eval show IO Unit from do - for (value, tokens) in [("keep-alive, ", #["keep-alive"]), (", upgrade,, close", #["upgrade", "close"]), - ("", #[])] do - let got := (Header.Connection.parse (.ofString! value)).map (·.tokens) - expect (got == some tokens) s!"Connection.parse {value.quote}: expected {tokens}, got {got}" - --- A handler's `upgrade` option survives a trailing empty element. -#eval runGroup "handler options" do - check "handler Connection: upgrade," (mkGetClose "/") - (fun _ => Response.ok |>.header! "Connection" "upgrade," |>.text "ok") - fun r => assertContains r "Connection: upgrade, close"
diff --git a/tests/async/elab/async_http_encode.lean b/tests/async/elab/async_http_encode.lean index 4ed1fe4..74cd169 100644 --- a/tests/async/elab/async_http_encode.lean +++ b/tests/async/elab/async_http_encode.lean
@@ -612,3 +612,29 @@ -/ #guard_msgs in #eval encodeStr ({ status := .ok, version := .v30 } : Response.Head) + +/-! ## Status classes -/ + +-- `isRedirection` is true exactly on the 3xx range, unassigned codes included, and false on the +-- 2xx/4xx boundaries. +#guard Status.isRedirection .multipleChoices +#guard Status.isRedirection .permanentRedirect +#guard !Status.isRedirection .ok +#guard !Status.isRedirection .badRequest +#guard (Status.ofCode none 299).any (!·.isRedirection) +#guard (Status.ofCode none 300).any (·.isRedirection) +#guard (Status.ofCode none 308).any (·.isRedirection) +#guard (Status.ofCode none 350).any (·.isRedirection) +#guard (Status.ofCode none 399).any (·.isRedirection) +#guard (Status.ofCode none 400).any (!·.isRedirection) + +-- Status codes 600–999 count as server errors (RFC 9110 §15). +#eval show IO Unit from do + let expect (cond : Bool) (msg : String) : IO Unit := unless cond do throw (IO.userError msg) + for code in [600, 700, 999] do + let some status := Status.ofCode none code | throw (IO.userError s!"ofCode {code}") + expect (status.isServerError && status.isError) s!"status {code} is not a server error" + let some status := Status.ofCode none 599 | throw (IO.userError "ofCode 599") + expect status.isServerError "599 is not a server error" + let some status := Status.ofCode none 499 | throw (IO.userError "ofCode 499") + expect (!status.isServerError && status.isClientError) "499 is not a client error"
diff --git a/tests/async/elab/async_http_expect.lean b/tests/async/elab/async_http_expect.lean deleted file mode 100644 index b5bf5dc..0000000 --- a/tests/async/elab/async_http_expect.lean +++ /dev/null
@@ -1,204 +0,0 @@ -import Std.Http.Test.Helpers - -open Std.Async -open Std Http Internal Test - --- Handlers for Expect: 100-continue testing - -private structure RejectContinueHandler where - onRequestCalls : IO.Ref Nat - -instance : Std.Http.Server.Handler RejectContinueHandler where - onRequest self _ := do - self.onRequestCalls.modify (· + 1) - Response.ok |>.text "request-ran" - - onContinue _ _ := pure false - -private structure AcceptContinueHandler where - onRequestCalls : IO.Ref Nat - -instance : Std.Http.Server.Handler AcceptContinueHandler where - onRequest self request := do - self.onRequestCalls.modify (· + 1) - let body : String ← request.body.readAll - Response.ok |>.text s!"accepted:{body}" - - onContinue _ _ := pure true - --- Per-test runner for generic handlers - -private def checkH {σ : Type} [Std.Http.Server.Handler σ] - (name : String) - (raw : String) - (handler : σ) - (expect : ByteArray → IO Unit) - (config : Config := defaultConfig) : IO Unit := do - let (client, server) ← Mock.new - let response ← Async.block do - client.send raw.toUTF8 - Std.Http.Server.serveConnection server handler config |>.run - return (← client.recv?).getD .empty - - try expect response - catch e => throw (IO.userError s!"[{name}] {e}") - -private def assertCallCount (ref : IO.Ref Nat) (expected : Nat) : IO Unit := do - let got ← ref.get - unless got == expected do - throw <| IO.userError s!"expected {expected} onRequest calls, got {got}" - --- RFC 9110 §10.1.1: Expect: 100-continue - -#eval runGroup "Expect: 100-continue — reject" do - let calls ← IO.mkRef 0 - let handler : RejectContinueHandler := { onRequestCalls := calls } - - checkH "rejected Expect → 417, handler not called" - (raw := "POST /upload HTTP/1.1\x0d\nHost: example.com\x0d\nExpect: 100-continue\x0d\nContent-Length: 5\x0d\nConnection: close\x0d\n\x0d\nhello") - (handler := handler) - (expect := fun r => - assertContains r "HTTP/1.1 417 Expectation Failed" *> - assertAbsent r "100 Continue" *> - assertAbsent r "request-ran" *> - assertResponseCount r 1) - - assertCallCount calls 0 - -#eval runGroup "Expect: 100-continue — reject blocks pipelining" do - let calls ← IO.mkRef 0 - let handler : RejectContinueHandler := { onRequestCalls := calls } - - checkH "rejected Expect closes exchange, blocks pipelined second request" - (raw := - "POST /first HTTP/1.1\x0d\nHost: example.com\x0d\nExpect: 100-continue\x0d\nContent-Length: 5\x0d\n\x0d\nhello" ++ - "GET /second HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := handler) - (expect := fun r => - assertContains r "HTTP/1.1 417 Expectation Failed" *> - assertAbsent r "/second") - - assertCallCount calls 0 - -#eval runGroup "Expect: 100-continue — accept" do - let calls ← IO.mkRef 0 - let handler : AcceptContinueHandler := { onRequestCalls := calls } - - checkH "accepted Expect → 100 Continue then 200" - (raw := "POST /ok HTTP/1.1\x0d\nHost: example.com\x0d\nExpect: 100-continue\x0d\nContent-Length: 5\x0d\nConnection: close\x0d\n\x0d\nhello") - (handler := handler) - (expect := fun r => - assertContains r "HTTP/1.1 100 Continue" *> - assertContains r "HTTP/1.1 200 OK" *> - assertContains r "accepted:hello" *> - assertResponseCount r 2) -- one interim + one final - - assertCallCount calls 1 - -#eval runGroup "Expect: misc" do - let rejectCalls ← IO.mkRef 0 - let rejectHandler : RejectContinueHandler := { onRequestCalls := rejectCalls } - - checkH "non-100 Expect token → normal request, no interim" - (raw := "POST /odd HTTP/1.1\x0d\nHost: example.com\x0d\nExpect: something-else\x0d\nContent-Length: 5\x0d\nConnection: close\x0d\n\x0d\nhello") - (handler := rejectHandler) - (expect := fun r => - assertContains r "HTTP/1.1 200 OK" *> - assertContains r "request-ran" *> - assertAbsent r "100 Continue") - - assertCallCount rejectCalls 1 - - let acceptCalls ← IO.mkRef 0 - let acceptHandler : AcceptContinueHandler := { onRequestCalls := acceptCalls } - - checkH "Expect: 100-CONTINUE (case-insensitive) → 100 then 200" - (raw := "POST /case HTTP/1.1\x0d\nHost: example.com\x0d\nExpect: 100-CONTINUE\x0d\nContent-Length: 5\x0d\nConnection: close\x0d\n\x0d\nhello") - (handler := acceptHandler) - (expect := fun r => - assertContains r "HTTP/1.1 100 Continue" *> - assertContains r "HTTP/1.1 200 OK") - - assertCallCount acceptCalls 1 - - let noCalls ← IO.mkRef 0 - let noExpectHandler : AcceptContinueHandler := { onRequestCalls := noCalls } - - checkH "no Expect header → no 100 Continue emitted" - (raw := "POST /no-expect HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 5\x0d\nConnection: close\x0d\n\x0d\nhello") - (handler := noExpectHandler) - (expect := fun r => - assertContains r "HTTP/1.1 200 OK" *> - assertContains r "accepted:hello" *> - assertAbsent r "100 Continue" *> - assertResponseCount r 1) - - assertCallCount noCalls 1 - --- Date header generation - -#eval runGroup "Date header" do - check "generateDate: true adds Date header" - (raw := mkGetClose "/date") - (handler := fun _ => Response.ok |>.text "hello") - (config := { defaultConfig with generateDate := true }) - (expect := fun r => - assertStatus r "HTTP/1.1 200" *> - assertContains r "Date: " *> - assertContains r " GMT\x0d\n") - - check "generateDate: false omits Date header" - (raw := mkGetClose "/no-date") - (handler := fun _ => Response.ok |>.text "hello") - (config := { defaultConfig with generateDate := false }) - (expect := fun r => - assertStatus r "HTTP/1.1 200" *> - assertAbsent r "Date: ") - - check "user-supplied Date header preserved and not duplicated" - (raw := mkGetClose "/custom-date") - (handler := fun _ => - Response.ok - |>.header! "Date" "Mon, 01 Jan 2024 00:00:00 GMT" - |>.text "hello") - (config := { defaultConfig with generateDate := true }) - (expect := fun r => do - assertContains r "Date: Mon, 01 Jan 2024 00:00:00 GMT" - let text := String.fromUTF8! r - let count := (text.splitOn "Date: ").length - 1 - unless count == 1 do - throw <| IO.userError s!"expected 1 Date header, got {count}:\n{text.quote}") - - -- RFC 9110 §6.6.1: an origin server MUST generate a Date field in all 2xx, 3xx and 4xx responses, - -- including those the server writes itself - check "generateDate: true adds Date to a 400 the server writes itself" - (raw := "GET / HTTP/1.1\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (config := { defaultConfig with generateDate := true }) - (expect := fun r => - assertStatus r "HTTP/1.1 400" *> - assertContains r "\x0d\nDate: " *> - assertContains r " GMT\x0d\nServer: LeanHTTP/1.1\x0d\n") - - check "generateDate: true adds Date to a 431 the server writes itself" - (raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nA: 1\x0d\nB: 2\x0d\nC: 3\x0d\n\x0d\n") - (handler := okHandler) - (config := { defaultConfig with generateDate := true, maxHeaders := 2 }) - (expect := fun r => - assertStatus r "HTTP/1.1 431" *> - assertContains r "\x0d\nDate: ") - - check "generateDate: true adds Date to the 500 for a handler head with a wrong Content-Length" - (raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n") - (handler := fun _ => Response.ok |>.header! "Content-Length" "1234" |>.text "") - (config := { defaultConfig with generateDate := true }) - (expect := fun r => - assertStatus r "HTTP/1.1 500" *> - assertContains r "\x0d\nDate: " *> - assertContains r "\x0d\n\x0d\nInternal Server Error\n") - - check "generateDate: false adds no Date to a 400 the server writes itself" - (raw := "GET / HTTP/1.1\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (config := { defaultConfig with generateDate := false }) - (expect := (assertExact · r400))
diff --git a/tests/async/elab/async_http_exports.lean b/tests/async/elab/async_http_exports.lean index 39d225d..235245f 100644 --- a/tests/async/elab/async_http_exports.lean +++ b/tests/async/elab/async_http_exports.lean
@@ -1,12 +1,27 @@ -module - import Std.Http /-! `import Std.Http` gives the HTTP library, not the helpers its test suite uses: those come from -`import Std.Http.Test.Helpers`. +`import Std.Http.Test.Helpers` (#16282). This file is not a `module`, so it sees everything that +`import Std.Http` loads. -/ /-- error: Unknown identifier `Std.Http.Internal.Test.mkGet` -/ #guard_msgs in #check Std.Http.Internal.Test.mkGet + +/-- error: Unknown identifier `Std.Http.Internal.Test.check` -/ +#guard_msgs in +#check Std.Http.Internal.Test.check + +/-- error: Unknown identifier `Std.Http.Internal.Test.serveRaw` -/ +#guard_msgs in +#check Std.Http.Internal.Test.serveRaw + +/-- error: Unknown identifier `Std.Http.Internal.Test.hangGuard` -/ +#guard_msgs in +#check Std.Http.Internal.Test.hangGuard + +/-- error: Unknown identifier `Std.Http.Internal.Test.MachineTester` -/ +#guard_msgs in +#check Std.Http.Internal.Test.MachineTester
diff --git a/tests/async/elab/async_http_fuzz.lean b/tests/async/elab/async_http_fuzz.lean deleted file mode 100644 index 8a92f4c..0000000 --- a/tests/async/elab/async_http_fuzz.lean +++ /dev/null
@@ -1,630 +0,0 @@ -import Std.Http -import Std.Http.Test.Helpers -import Std.Async -import Std.Async.Timer - -open Std.Async -open Std Http Internal Test - - - -def bad400 : String := r400 - -def runWithTimeout {α : Type} (name : String) (timeoutMs : Nat := 15000) (action : IO α) : IO α := do - let task ← IO.asTask action - let ticks := (timeoutMs + 9) / 10 - - let rec loop (remaining : Nat) : IO α := do - if (← IO.getTaskState task) == .finished then - match (← IO.wait task) with - | .ok x => pure x - | .error err => throw err - else - match remaining with - | 0 => - IO.cancel task - throw <| IO.userError s!"Test '{name}' timed out after {timeoutMs}ms (possible hang/regression)" - | n + 1 => - IO.sleep 10 - loop n - - loop ticks - -def closeChannelIdempotent {α : Type} (ch : Std.CloseableChannel α) : IO Unit := do - match ← EIO.toBaseIO ch.close with - | .ok _ => pure () - | .error .alreadyClosed => pure () - | .error err => throw <| IO.userError (toString err) - -def sendRaw - (client : Mock.Client) - (server : Mock.Server) - (raw : ByteArray) - (handler : TestHandler) - (config : Config := defaultConfig) : IO ByteArray := Async.block do - client.send raw - Std.Http.Server.serveConnection server handler config - |>.run - let res ← client.recv? - pure (res.getD .empty) - - -def sendRawAndClose - (client : Mock.Client) - (server : Mock.Server) - (raw : ByteArray) - (handler : TestHandler) - (config : Config := defaultConfig) : IO ByteArray := Async.block do - client.send raw - closeChannelIdempotent client.getSendChan - Std.Http.Server.serveConnection server handler config - |>.run - let res ← client.recv? - pure (res.getD .empty) - - -def sendFragmentedAndClose - (client : Mock.Client) - (server : Mock.Server) - (parts : Array ByteArray) - (handler : TestHandler) - (config : Config := defaultConfig) : IO ByteArray := Async.block do - let serverTask ← async (t := AsyncTask) do - Std.Http.Server.serveConnection server handler config - |>.run - - for part in parts do - client.send part - - closeChannelIdempotent client.getSendChan - await serverTask - - let res ← client.recv? - pure (res.getD .empty) - - -def responseText (response : ByteArray) : String := - String.fromUTF8! response - - -def responseBody (response : ByteArray) : String := - let parts := (responseText response).splitOn "\x0d\n\x0d\n" - match parts.drop 1 with - | [] => "" - | body :: _ => body - - -def assertStatusPrefix (name : String) (response : ByteArray) (prefix_ : String) : IO Unit := do - let text := responseText response - unless text.startsWith prefix_ do - throw <| IO.userError s!"Test '{name}' failed:\nExpected status prefix {prefix_.quote}\nGot:\n{text.quote}" - - - - -def countOccurrences (s : String) (needle : String) : Nat := - if needle.isEmpty then - 0 - else - (s.splitOn needle).length - 1 - - -def assertStatusCount (name : String) (response : ByteArray) (expected : Nat) : IO Unit := do - let text := responseText response - let got := countOccurrences text "HTTP/1.1 " - if got != expected then - throw <| IO.userError s!"Test '{name}' failed:\nExpected {expected} responses but saw {got}\n{text.quote}" - - -def nextSeed (seed : Nat) : Nat := - (1664525 * seed + 1013904223) % 4294967296 - - -def randBelow (seed : Nat) (maxExclusive : Nat) : Nat × Nat := - let seed' := nextSeed seed - if maxExclusive == 0 then - (0, seed') - else - (seed' % maxExclusive, seed') - - -def randIn (seed : Nat) (low : Nat) (high : Nat) : Nat × Nat := - if high < low then - (low, seed) - else - let (n, seed') := randBelow seed (high - low + 1) - (low + n, seed') - - -def randomAsciiBytes (seed : Nat) (len : Nat) : ByteArray × Nat := Id.run do - let mut s := seed - let mut out := ByteArray.empty - - for _ in [0:len] do - let (r, s') := randBelow s 38 - s := s' - - let code := - if r < 26 then - 97 + r - else if r < 36 then - 48 + (r - 26) - else if r == 36 then - 45 - else - 95 - - out := out.push (UInt8.ofNat code) - - (out, s) - - -def randomTokenBytes (seed : Nat) (len : Nat) : ByteArray × Nat := Id.run do - let mut s := seed - let mut out := ByteArray.empty - - for _ in [0:len] do - let (r, s') := randBelow s 36 - s := s' - - let code := - if r < 26 then - 97 + r - else - 48 + (r - 26) - - out := out.push (UInt8.ofNat code) - - (out, s) - - -def randomSplit (seed : Nat) (data : ByteArray) (maxPart : Nat := 17) : Array ByteArray × Nat := Id.run do - let mut s := seed - let mut out : Array ByteArray := #[] - let mut i := 0 - - while i < data.size do - let remaining := data.size - i - let upper := Nat.min maxPart remaining - let (partLen, s') := randIn s 1 upper - s := s' - - out := out.push (data.extract i (i + partLen)) - i := i + partLen - - (out, s) - - -def randomChunkedPayload (seed : Nat) (body : ByteArray) : ByteArray × Nat := Id.run do - let mut s := seed - let mut out := ByteArray.empty - let mut i := 0 - - while i < body.size do - let remaining := body.size - i - let maxChunk := Nat.min 9 remaining - let (chunkLen, s') := randIn s 1 maxChunk - s := s' - - out := out ++ s!"{chunkLen}\x0d\n".toUTF8 - out := out ++ body.extract i (i + chunkLen) - out := out ++ "\x0d\n".toUTF8 - i := i + chunkLen - - out := out ++ "0\x0d\n\x0d\n".toUTF8 - (out, s) - - -def mkContentLengthHead (path : String) (bodySize : Nat) : ByteArray := - s!"POST {path} HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: {bodySize}\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 - - -def mkChunkedHead (path : String) : ByteArray := - s!"POST {path} HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 - - -def randomChunkExtensionList (seed : Nat) (count : Nat) : String × Nat := Id.run do - let mut s := seed - let mut ext := "" - - for _ in [0:count] do - let (nameLen, s1) := randIn s 1 3 - s := s1 - let (valueLen, s2) := randIn s 1 3 - s := s2 - - let (nameBytes, s3) := randomTokenBytes s nameLen - s := s3 - let (valueBytes, s4) := randomTokenBytes s valueLen - s := s4 - - let name := String.fromUTF8! nameBytes - let value := String.fromUTF8! valueBytes - ext := ext ++ s!";{name}={value}" - - (ext, s) - - -def randomTrailerLines (seed : Nat) (count : Nat) : String × Nat := Id.run do - let mut s := seed - let mut lines := "" - - for i in [0:count] do - let (nameLen, s1) := randIn s 1 4 - s := s1 - let (valueLen, s2) := randIn s 1 6 - s := s2 - - let (nameBytes, s3) := randomTokenBytes s nameLen - s := s3 - let (valueBytes, s4) := randomTokenBytes s valueLen - s := s4 - - let name := String.fromUTF8! nameBytes - let value := String.fromUTF8! valueBytes - lines := lines ++ s!"X{i}-{name}: {value}\x0d\n" - - (lines, s) - - -def echoBodyHandler : TestHandler := fun req => do - let body : String ← req.body.readAll - Response.ok |>.text body - - -def runPipelinedReadAll - (raw : ByteArray) - (config : Config := defaultConfig) : IO (ByteArray × Array String) := Async.block do - let (client, server) ← Mock.new - let seenRef ← IO.mkRef (#[] : Array String) - - let handler : TestHandler := fun req => do - let uri := toString req.line.uri - seenRef.modify (·.push uri) - let _body : String ← req.body.readAll - Response.ok |>.text uri - - client.send raw - closeChannelIdempotent client.getSendChan - - Std.Http.Server.serveConnection server handler config - |>.run - - let response ← client.recv? - let seen ← seenRef.get - pure (response.getD .empty, seen) - - -def fuzzContentLengthEcho (iterations : Nat) (seed0 : Nat) : IO Unit := do - let mut seed := seed0 - - for i in [0:iterations] do - let caseSeed := seed - - let (len, seed1) := randIn seed 0 128 - seed := seed1 - - let (body, seed2) := randomAsciiBytes seed len - seed := seed2 - - let head := mkContentLengthHead s!"/fuzz-cl-{i}" body.size - let (bodyParts, seed3) := randomSplit seed body - seed := seed3 - let parts := #[head] ++ bodyParts - - let (client, server) ← Mock.new - let response ← sendFragmentedAndClose client server parts echoBodyHandler - - let expectedBody := String.fromUTF8! body - assertStatusPrefix s!"fuzzContentLengthEcho case={i} seed={caseSeed}" response "HTTP/1.1 200" - - let gotBody := responseBody response - if gotBody != expectedBody then - throw <| IO.userError s!"fuzzContentLengthEcho case={i} seed={caseSeed} failed:\nExpected body {expectedBody.quote}\nGot body {gotBody.quote}\nFull response:\n{(responseText response).quote}" - - -def fuzzContentLengthLeadingZerosAccepted (iterations : Nat) (seed0 : Nat) : IO Unit := do - let mut seed := seed0 - - for i in [0:iterations] do - let caseSeed := seed - - let (len, seed1) := randIn seed 1 96 - seed := seed1 - - let (leadingZeros, seed2) := randIn seed 1 5 - seed := seed2 - - let (body, seed3) := randomAsciiBytes seed len - seed := seed3 - - let clToken := String.ofList (List.replicate leadingZeros '0') ++ toString len - let raw := - s!"POST /cl-leading-zeros-{i} HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: {clToken}\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 ++ body - - let (client, server) ← Mock.new - let response ← sendRaw client server raw echoBodyHandler - - let expectedBody := String.fromUTF8! body - assertStatusPrefix s!"fuzzContentLengthLeadingZerosAccepted case={i} seed={caseSeed} len={len} zeros={leadingZeros}" response "HTTP/1.1 200" - - let gotBody := responseBody response - if gotBody != expectedBody then - throw <| IO.userError s!"fuzzContentLengthLeadingZerosAccepted case={i} seed={caseSeed} failed:\nExpected body {expectedBody.quote}\nGot body {gotBody.quote}\nFull response:\n{(responseText response).quote}" - - -def fuzzChunkedEcho (iterations : Nat) (seed0 : Nat) : IO Unit := do - let mut seed := seed0 - - for i in [0:iterations] do - let caseSeed := seed - - let (len, seed1) := randIn seed 0 128 - seed := seed1 - - let (body, seed2) := randomAsciiBytes seed len - seed := seed2 - - let (chunkedBody, seed3) := randomChunkedPayload seed body - seed := seed3 - - let head := mkChunkedHead s!"/fuzz-chunked-{i}" - let raw := head ++ chunkedBody - - let (client, server) ← Mock.new - let response ← sendRaw client server raw echoBodyHandler - - let expectedBody := String.fromUTF8! body - assertStatusPrefix s!"fuzzChunkedEcho case={i} seed={caseSeed}" response "HTTP/1.1 200" - - let gotBody := responseBody response - if gotBody != expectedBody then - throw <| IO.userError s!"fuzzChunkedEcho case={i} seed={caseSeed} failed:\nExpected body {expectedBody.quote}\nGot body {gotBody.quote}\nFull response:\n{(responseText response).quote}" - - -def fuzzMixedTransferEncodingAndContentLengthRejected (iterations : Nat) (seed0 : Nat) : IO Unit := do - let mut seed := seed0 - - for i in [0:iterations] do - let caseSeed := seed - - let (len, seed1) := randIn seed 0 96 - seed := seed1 - - let (body, seed2) := randomAsciiBytes seed len - seed := seed2 - - let (chunkedBody, seed3) := randomChunkedPayload seed body - seed := seed3 - - let (declaredCl, seed4) := randIn seed 0 128 - seed := seed4 - - let raw := - s!"POST /te-cl-{i} HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nContent-Length: {declaredCl}\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 ++ chunkedBody - - let (client, server) ← Mock.new - let response ← sendRaw client server raw echoBodyHandler - assertExact response bad400 - - -def fuzzInvalidChunkSizeRejected (iterations : Nat) (seed0 : Nat) : IO Unit := do - let badTokens : Array String := #["g", "G", "z", "Z", "@", "!", "x"] - let mut seed := seed0 - - for i in [0:iterations] do - let caseSeed := seed - - let (idx, seed1) := randBelow seed badTokens.size - seed := seed1 - - let token := badTokens[idx]! - let raw := - s!"POST /bad-size-{i} HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n{token}\x0d\nabc\x0d\n0\x0d\n\x0d\n".toUTF8 - - let (client, server) ← Mock.new - let response ← sendRaw client server raw echoBodyHandler - - assertExact response bad400 - - -def fuzzDuplicateContentLengthRejected (iterations : Nat) (seed0 : Nat) : IO Unit := do - let mut seed := seed0 - - for i in [0:iterations] do - let caseSeed := seed - - let (cl1, seed1) := randIn seed 0 64 - seed := seed1 - - let (same, seed2) := randBelow seed 2 - seed := seed2 - - let (delta, seed3) := randIn seed 1 10 - seed := seed3 - - let cl2 := if same == 0 then cl1 else cl1 + delta - let (body, seed4) := randomAsciiBytes seed cl1 - seed := seed4 - - let raw := - s!"POST /dup-cl-{i} HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: {cl1}\x0d\nContent-Length: {cl2}\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 ++ body - - let (client, server) ← Mock.new - let response ← sendRaw client server raw echoBodyHandler - - assertExact response bad400 - - -def fuzzChunkExtensionLimits (iterations : Nat) (seed0 : Nat) : IO Unit := do - let config : Config := { - lingeringTimeout := 1000 - generateDate := false - maxChunkExtNameLength := 4 - maxChunkExtValueLength := 4 - } - - let mut seed := seed0 - - for i in [0:iterations] do - let caseSeed := seed - - let (nameLen, seed1) := randIn seed 1 8 - seed := seed1 - - let (valueLen, seed2) := randIn seed 1 8 - seed := seed2 - - let (nameBytes, seed3) := randomTokenBytes seed nameLen - seed := seed3 - - let (valueBytes, seed4) := randomTokenBytes seed valueLen - seed := seed4 - - let name := String.fromUTF8! nameBytes - let value := String.fromUTF8! valueBytes - - let raw := - s!"POST /ext-limit-{i} HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n1;{name}={value}\x0d\nx\x0d\n0\x0d\n\x0d\n".toUTF8 - - let expectOk := nameLen ≤ 4 ∧ valueLen ≤ 4 - - let (client, server) ← Mock.new - let response ← sendRaw client server raw echoBodyHandler (config := config) - - if expectOk then - assertStatusPrefix s!"fuzzChunkExtensionLimits case={i} seed={caseSeed} nameLen={nameLen} valueLen={valueLen}" response "HTTP/1.1 200" - else - assertExact response bad400 - - -def fuzzChunkExtensionCountLimit (iterations : Nat) (seed0 : Nat) : IO Unit := do - let config : Config := { - lingeringTimeout := 1000 - generateDate := false - maxChunkExtensions := 2 - } - - let mut seed := seed0 - - for i in [0:iterations] do - let caseSeed := seed - - let (extCount, seed1) := randIn seed 0 5 - seed := seed1 - - let (extList, seed2) := randomChunkExtensionList seed extCount - seed := seed2 - - let raw := - s!"POST /ext-count-{i} HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n1{extList}\x0d\nx\x0d\n0\x0d\n\x0d\n".toUTF8 - - let (client, server) ← Mock.new - let response ← sendRaw client server raw echoBodyHandler (config := config) - - if extCount ≤ 2 then - assertStatusPrefix s!"fuzzChunkExtensionCountLimit case={i} seed={caseSeed} extCount={extCount}" response "HTTP/1.1 200" - else - assertExact response bad400 - - -def fuzzTrailerHeaderCountLimit (iterations : Nat) (seed0 : Nat) : IO Unit := do - let config : Config := { - lingeringTimeout := 1000 - generateDate := false - maxTrailerHeaders := 2 - } - - let mut seed := seed0 - - for i in [0:iterations] do - let caseSeed := seed - - let (trailerCount, seed1) := randIn seed 0 5 - seed := seed1 - - let (trailers, seed2) := randomTrailerLines seed trailerCount - seed := seed2 - - let raw := - s!"POST /trailers-{i} HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n1\x0d\na\x0d\n0\x0d\n{trailers}\x0d\n".toUTF8 - - let (client, server) ← Mock.new - let response ← sendRaw client server raw echoBodyHandler (config := config) - - if trailerCount ≤ 2 then - assertStatusPrefix s!"fuzzTrailerHeaderCountLimit case={i} seed={caseSeed} trailerCount={trailerCount}" response "HTTP/1.1 200" - else - assertExact response bad400 - -def fuzzCompleteFirstBodyAllowsPipeline (iterations : Nat) (seed0 : Nat) : IO Unit := do - let mut seed := seed0 - - for i in [0:iterations] do - let caseSeed := seed - - let (len, seed1) := randIn seed 0 32 - seed := seed1 - - let (body, seed2) := randomAsciiBytes seed len - seed := seed2 - - let uri1 := s!"/first-complete-{i}" - let req1 := - s!"POST {uri1} HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: {len}\x0d\n\x0d\n".toUTF8 ++ body - let req2 := "GET /second HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 - - let (response, seen) ← runPipelinedReadAll (req1 ++ req2) - - let text := responseText response - assertStatusCount s!"fuzzCompleteFirstBodyAllowsPipeline case={i} seed={caseSeed}" response 2 - - unless text.contains uri1 do - throw <| IO.userError s!"fuzzCompleteFirstBodyAllowsPipeline case={i} seed={caseSeed} failed:\nMissing first URI {uri1.quote}\n{text.quote}" - - unless text.contains "/second" do - throw <| IO.userError s!"fuzzCompleteFirstBodyAllowsPipeline case={i} seed={caseSeed} failed:\nMissing second response\n{text.quote}" - - if seen.size != 2 ∨ seen[0]! != uri1 ∨ seen[1]! != "/second" then - throw <| IO.userError s!"fuzzCompleteFirstBodyAllowsPipeline case={i} seed={caseSeed} failed:\nExpected seen=[{uri1.quote}, \"/second\"] got {seen}" - - --- Property: Content-Length framing is stable across random payloads and random transport splits. -#eval runWithTimeout "fuzz_content_length_echo" 20000 do - fuzzContentLengthEcho 40 0x00C0FFEE - --- Property: Content-Length with randomized leading zeros is accepted and decoded to exact body length. -#eval runWithTimeout "fuzz_content_length_leading_zeros_accepted" 20000 do - fuzzContentLengthLeadingZerosAccepted 30 0x00CAB005 - --- Property: Chunked framing reconstructs exact bodies under random chunking and transport splits. -#eval runWithTimeout "fuzz_chunked_echo" 20000 do - fuzzChunkedEcho 40 0x00123456 - --- Property: Mixing Transfer-Encoding with Content-Length is always rejected. -#eval runWithTimeout "fuzz_te_cl_mixed_rejected" 20000 do - fuzzMixedTransferEncodingAndContentLengthRejected 30 0x0010CE11 - --- Property: Invalid chunk-size tokens are rejected deterministically with 400. -#eval runWithTimeout "fuzz_invalid_chunk_size_rejected" 20000 do - fuzzInvalidChunkSizeRejected 30 0x00BAD001 - --- Property: Duplicate Content-Length headers are always rejected (same or different values). -#eval runWithTimeout "fuzz_duplicate_content_length_rejected" 20000 do - fuzzDuplicateContentLengthRejected 30 0x00D0C1A7 - --- Property: Chunk extension name/value limits are enforced under randomized lengths. -#eval runWithTimeout "fuzz_chunk_extension_limits" 20000 do - fuzzChunkExtensionLimits 40 0x00A11CE5 - --- Property: Chunk extension count limit is enforced under randomized extension lists. -#eval runWithTimeout "fuzz_chunk_extension_count_limit" 20000 do - fuzzChunkExtensionCountLimit 35 0x00E77E11 - --- Property: Trailer header count limit is enforced under randomized trailer sections. -#eval runWithTimeout "fuzz_trailer_header_count_limit" 20000 do - fuzzTrailerHeaderCountLimit 35 0x00A71A12 - --- Property: Complete first request body allows pipelined follow-up parsing. -#eval runWithTimeout "fuzz_complete_first_body_allows_pipeline" 20000 do - fuzzCompleteFirstBodyAllowsPipeline 30 0x00777777
diff --git a/tests/async/elab/async_http_fuzz.lean.serial b/tests/async/elab/async_http_fuzz.lean.serial deleted file mode 100644 index b3483f8..0000000 --- a/tests/async/elab/async_http_fuzz.lean.serial +++ /dev/null
@@ -1 +0,0 @@ -This test uses timeouts and thus may fail under heavy load.
diff --git a/tests/async/elab/async_http_fuzz_limits.lean b/tests/async/elab/async_http_fuzz_limits.lean deleted file mode 100644 index 7c94c86..0000000 --- a/tests/async/elab/async_http_fuzz_limits.lean +++ /dev/null
@@ -1,450 +0,0 @@ -import Std.Http -import Std.Async - -open Std.Async -open Std Http Internal Test - -/-! -# Limit-enforcement fuzzing for the HTTP/1.1 server. - -Tests that every configurable limit in `H1.Config` and `Server.Config` is -correctly enforced under randomized inputs. Inspired by hyper's fuzzing of -size and count limits. --/ - -def closeChannelIdempotent {α : Type} (ch : Std.CloseableChannel α) : IO Unit := do - match ← EIO.toBaseIO ch.close with - | .ok _ => pure () - | .error .alreadyClosed => pure () - | .error err => throw <| IO.userError (toString err) - -def sendRaw - (client : Mock.Client) (server : Mock.Server) (raw : ByteArray) - (handler : TestHandler) (config : Config) : IO ByteArray := Async.block do - client.send raw - Std.Http.Server.serveConnection server handler config |>.run - let res ← client.recv? - pure (res.getD .empty) - -def sendRawAndClose - (client : Mock.Client) (server : Mock.Server) (raw : ByteArray) - (handler : TestHandler) (config : Config) : IO ByteArray := Async.block do - client.send raw - closeChannelIdempotent client.getSendChan - Std.Http.Server.serveConnection server handler config |>.run - let res ← client.recv? - pure (res.getD .empty) - -def runWithTimeout {α : Type} (name : String) (timeoutMs : Nat := 20000) (action : IO α) : IO α := do - let task ← IO.asTask action - let ticks := (timeoutMs + 9) / 10 - let rec loop (remaining : Nat) : IO α := do - if (← IO.getTaskState task) == .finished then - match (← IO.wait task) with - | .ok x => pure x - | .error err => throw err - else - match remaining with - | 0 => IO.cancel task; throw <| IO.userError s!"Test '{name}' timed out" - | n + 1 => IO.sleep 10; loop n - loop ticks - --- PRNG -def nextSeed (seed : Nat) : Nat := (1664525 * seed + 1013904223) % 4294967296 -def randBelow (seed : Nat) (n : Nat) : Nat × Nat := - let s := nextSeed seed - (if n == 0 then 0 else s % n, s) -def randIn (seed : Nat) (lo hi : Nat) : Nat × Nat := - if hi < lo then (lo, seed) else - let (r, s) := randBelow seed (hi - lo + 1) - (lo + r, s) - -def randomTokenBytes (seed : Nat) (len : Nat) : ByteArray × Nat := Id.run do - let mut s := seed; let mut out := ByteArray.empty - for _ in [0:len] do - let (r, s') := randBelow s 36; s := s' - let code := if r < 26 then 97 + r else 48 + (r - 26) - out := out.push (UInt8.ofNat code) - (out, s) - -def randomAsciiBytes (seed : Nat) (len : Nat) : ByteArray × Nat := Id.run do - let mut s := seed; let mut out := ByteArray.empty - for _ in [0:len] do - let (r, s') := randBelow s 26; s := s' - out := out.push (UInt8.ofNat (97 + r)) - (out, s) - -private def toHexAux : Nat → Nat → String → String - | 0, _, acc => acc - | fuel + 1, n, acc => - if n == 0 then acc - else - let d := n % 16 - let c : Char := if d < 10 then Char.ofNat (48 + d) else Char.ofNat (87 + d) - toHexAux fuel (n / 16) (String.ofList [c] ++ acc) - -def natToHex (n : Nat) : String := - if n == 0 then "0" else toHexAux 16 n "" - -def assertStatusPrefix (name : String) (response : ByteArray) (pfx : String) : IO Unit := do - let text := String.fromUTF8! response - unless text.startsWith pfx do - throw <| IO.userError s!"Test '{name}' failed:\nExpected {pfx.quote}\nGot:\n{text.quote}" - -def countOccurrences (s needle : String) : Nat := - if needle.isEmpty then 0 else (s.splitOn needle).length - 1 - -def bad400 : String := r400 - -def echoBodyHandler : TestHandler := fun req => do - let body : String ← req.body.readAll - Response.ok |>.text body - --- ============================================================================ --- maxBodySize — Content-Length framing --- ============================================================================ - --- Property: Content-Length body exactly at or below maxBodySize → 200. --- Content-Length body above maxBodySize → 413 (no body bytes needed). -def fuzzBodySizeLimitContentLength (iterations : Nat) (seed0 : Nat) : IO Unit := do - let limit : Nat := 64 - let config : Config := { lingeringTimeout := 1000, generateDate := false, maxBodySize := limit } - let mut seed := seed0 - for i in [0:iterations] do - let caseSeed := seed - let (bodySize, s1) := randIn seed 0 (limit + 20); seed := s1 - let (bodyBytes, s2) := randomAsciiBytes seed bodySize; seed := s2 - let raw := - s!"POST /bl-cl-{i} HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: {bodySize}\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 - ++ bodyBytes - let (client, server) ← Mock.new - let response ← sendRaw client server raw (fun req => do - let _body : String ← req.body.readAll; Response.ok |>.text "ok") config - if bodySize ≤ limit then - assertStatusPrefix s!"fuzzBodySizeLimitCL iter={i} seed={caseSeed} size={bodySize}" response "HTTP/1.1 200" - else - assertStatusPrefix s!"fuzzBodySizeLimitCL iter={i} seed={caseSeed} size={bodySize}" response "HTTP/1.1 413" - --- ============================================================================ --- maxBodySize — chunked framing --- ============================================================================ - --- Property: chunked bodies whose wire size (data plus chunk framing) is at or below --- maxBodySize → 200. Chunked bodies exceeding maxBodySize → 413. -def fuzzBodySizeLimitChunked (iterations : Nat) (seed0 : Nat) : IO Unit := do - let limit : Nat := 64 - let config : Config := { lingeringTimeout := 1000, generateDate := false, maxBodySize := limit } - let mut seed := seed0 - for i in [0:iterations] do - let caseSeed := seed - -- Total body size across 1-4 chunks - let (totalSize, s1) := randIn seed 0 (limit + 16); seed := s1 - let (numChunks, s2) := randIn seed 1 4; seed := s2 - - -- Build chunks that sum to totalSize - let chunkSize := (totalSize + numChunks - 1) / numChunks - let mut chunkedBody := ByteArray.empty - let mut remaining := totalSize - for _ in [0:numChunks] do - if remaining == 0 then break - let thisChunk := Nat.min chunkSize remaining - let (chunkBytes, s3) := randomAsciiBytes seed thisChunk; seed := s3 - chunkedBody := chunkedBody ++ s!"{natToHex thisChunk}\x0d\n".toUTF8 ++ chunkBytes ++ "\x0d\n".toUTF8 - remaining := remaining - thisChunk - chunkedBody := chunkedBody ++ "0\x0d\n\x0d\n".toUTF8 - - let raw := - s!"POST /bl-ch-{i} HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 - ++ chunkedBody - let (client, server) ← Mock.new - let response ← sendRaw client server raw (fun req => do - let _body : String ← req.body.readAll; Response.ok |>.text "ok") config - let label := s!"fuzzBodySizeLimitChunked iter={i} seed={caseSeed} total={totalSize} wire={chunkedBody.size}" - if chunkedBody.size ≤ limit then - assertStatusPrefix label response "HTTP/1.1 200" - else - assertStatusPrefix label response "HTTP/1.1 413" - --- ============================================================================ --- maxHeaders — header count limit --- ============================================================================ - --- Property: header count at or below maxHeaders → 200. --- header count above maxHeaders → 400. -def fuzzHeaderCountLimit (iterations : Nat) (seed0 : Nat) : IO Unit := do - let limit : Nat := 5 - let config : Config := { lingeringTimeout := 1000, generateDate := false, maxHeaders := limit } - let mut seed := seed0 - for i in [0:iterations] do - let caseSeed := seed - -- Host counts as 1 header, Connection as 1, so extra headers = headerCount - 2 - let (headerCount, s1) := randIn seed 2 (limit + 4); seed := s1 - let extraCount := headerCount - 2 -- we always add Host + Connection - - let mut extraHeaders := "" - let mut s := s1 - for j in [0:extraCount] do - let (nameLen, s2) := randIn s 1 8; s := s2 - let (nameBytes, s3) := randomTokenBytes s nameLen; s := s3 - let name := String.fromUTF8! nameBytes - extraHeaders := extraHeaders ++ s!"X-Extra-{j}-{name}: value\x0d\n" - seed := s - - let raw := - s!"GET /hc-{i} HTTP/1.1\x0d\nHost: example.com\x0d\n{extraHeaders}Connection: close\x0d\n\x0d\n".toUTF8 - let (client, server) ← Mock.new - let response ← sendRawAndClose client server raw okHandler config - -- headerCount includes Host and Connection (always present) - if headerCount ≤ limit then - assertStatusPrefix s!"fuzzHeaderCount iter={i} seed={caseSeed} count={headerCount}" response "HTTP/1.1 200" - else - assertStatusPrefix s!"fuzzHeaderCount iter={i} seed={caseSeed} count={headerCount}" response "HTTP/1.1 431" - --- ============================================================================ --- maxHeaderBytes — total header bytes limit --- ============================================================================ - --- Property: headers whose aggregate bytes (name + ": " + value + "\r\n") are at or --- below maxHeaderBytes are accepted; above it they are rejected with 400. -def fuzzHeaderTotalBytesLimit (iterations : Nat) (seed0 : Nat) : IO Unit := do - -- Fixed baseline: "Host: example.com\r\n" + "Connection: close\r\n" = 20 + 20 = 40 bytes. - -- We'll add a single large X-Payload header to cross the boundary. - let limit : Nat := 200 - let config : Config := { - lingeringTimeout := 1000 - generateDate := false - maxHeaderBytes := limit - maxHeaderValueLength := limit + 100 -- allow value longer than total limit for testing - } - let baseline := ("Host: example.com\x0d\nConnection: close\x0d\n".toUTF8).size - let mut seed := seed0 - for i in [0:iterations] do - let caseSeed := seed - -- Pick a value size that puts total bytes just under or over the limit - -- Each "X-Payload: " header = name(9) + ": "(2) + value + "\r\n"(2) = value + 13 - let overhead := baseline + 13 -- "X-Payload" (9) + ": " (2) + "\r\n" (2) + baseline - -- We want value sizes that land on both sides of (limit - overhead) - let boundary := if limit > overhead then limit - overhead else 0 - let (valueSize, s1) := randIn seed 0 (boundary + 20); seed := s1 - let (valueBytes, s2) := randomAsciiBytes seed valueSize; seed := s2 - let value := String.fromUTF8! valueBytes - - let raw := - s!"GET /hb-{i} HTTP/1.1\x0d\nHost: example.com\x0d\nX-Payload: {value}\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 - let (client, server) ← Mock.new - let response ← sendRawAndClose client server raw okHandler config - -- Total bytes = baseline + "X-Payload: " + value + "\r\n" - let totalBytes := baseline + 9 + 2 + valueSize + 2 - if totalBytes ≤ limit then - assertStatusPrefix s!"fuzzHeaderBytes iter={i} seed={caseSeed} total={totalBytes}" response "HTTP/1.1 200" - else - assertStatusPrefix s!"fuzzHeaderBytes iter={i} seed={caseSeed} total={totalBytes}" response "HTTP/1.1 431" - --- ============================================================================ --- maxMessages — requests per connection --- ============================================================================ - --- Property: after maxMessages requests on a single connection, the server --- closes the connection (disables keep-alive). All maxMessages --- requests receive a valid response. -def fuzzMaxMessagesPerConnection (iterations : Nat) (seed0 : Nat) : IO Unit := do - let limit : Nat := 3 - let config : Config := { - lingeringTimeout := 1000 - generateDate := false - maxRequests := limit - } - let mut seed := seed0 - for i in [0:iterations] do - let caseSeed := seed - let (reqCount, s1) := randIn seed 1 (limit + 3); seed := s1 - - -- Build reqCount keep-alive requests followed by close - let mut raw := ByteArray.empty - for j in [0:reqCount] do - let connHeader := - if j + 1 == reqCount then "Connection: close\x0d\n" else "Connection: keep-alive\x0d\n" - raw := raw ++ s!"GET /msg-{i}-{j} HTTP/1.1\x0d\nHost: example.com\x0d\n{connHeader}\x0d\n".toUTF8 - - let (client, server) ← Mock.new - let response ← sendRawAndClose client server raw okHandler config - let text := String.fromUTF8! response - let seen := countOccurrences text "HTTP/1.1 200" - let expected := Nat.min reqCount limit - if seen != expected then - throw <| IO.userError - s!"fuzzMaxMessages iter={i} seed={caseSeed} reqCount={reqCount}: expected {expected} responses, got {seen}\n{text.quote}" - --- ============================================================================ --- maxLeadingEmptyLines — leading CRLF before request-line --- ============================================================================ - --- Property: at most maxLeadingEmptyLines bare CRLFs before the request-line are tolerated. --- More than that → 400. -def fuzzLeadingEmptyLinesLimit (iterations : Nat) (seed0 : Nat) : IO Unit := do - let limit : Nat := 4 - let config : Config := { lingeringTimeout := 1000, generateDate := false, maxLeadingEmptyLines := limit } - let mut seed := seed0 - for i in [0:iterations] do - let caseSeed := seed - let (lineCount, s1) := randIn seed 0 (limit + 4); seed := s1 - let leadingCRLF := (List.replicate lineCount "\x0d\n").foldl (· ++ ·) "" - let raw := - (leadingCRLF ++ s!"GET /le-{i} HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n").toUTF8 - let (client, server) ← Mock.new - let response ← sendRawAndClose client server raw okHandler config - if lineCount ≤ limit then - assertStatusPrefix s!"fuzzLeadingEmptyLines iter={i} seed={caseSeed} count={lineCount}" response "HTTP/1.1 200" - else - assertStatusPrefix s!"fuzzLeadingEmptyLines iter={i} seed={caseSeed} count={lineCount}" response "HTTP/1.1 400" - --- ============================================================================ --- maxSpaceSequence — OWS (optional whitespace) limit --- ============================================================================ - --- Property: OWS sequences at or below maxSpaceSequence are accepted. --- OWS sequences exceeding the limit → 400. -def fuzzOWSSequenceLimit (iterations : Nat) (seed0 : Nat) : IO Unit := do - let limit : Nat := 4 - let config : Config := { lingeringTimeout := 1000, generateDate := false, maxSpaceSequence := limit } - let mut seed := seed0 - for i in [0:iterations] do - let caseSeed := seed - let (spaceCount, s1) := randIn seed 0 (limit + 4); seed := s1 - let spaces := String.ofList (List.replicate spaceCount ' ') - -- OWS appears between ':' and value in header fields - let raw := - s!"GET /ows-{i} HTTP/1.1\x0d\nHost: example.com\x0d\nX-OWS:{spaces}value\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 - let (client, server) ← Mock.new - let response ← sendRawAndClose client server raw okHandler config - if spaceCount ≤ limit then - assertStatusPrefix s!"fuzzOWSLimit iter={i} seed={caseSeed} spaces={spaceCount}" response "HTTP/1.1 200" - else - assertStatusPrefix s!"fuzzOWSLimit iter={i} seed={caseSeed} spaces={spaceCount}" response "HTTP/1.1 400" - --- ============================================================================ --- maxStartLineLength — request-line length limit --- ============================================================================ - --- Property: request lines at or below maxStartLineLength → 200. --- Request lines above maxStartLineLength → 414 (URI too long) or 400. -def fuzzStartLineLengthLimit (iterations : Nat) (seed0 : Nat) : IO Unit := do - let limit : Nat := 64 - let config : Config := { - lingeringTimeout := 1000 - generateDate := false - maxStartLineLength := limit - maxUriLength := limit - } - let mut seed := seed0 - for i in [0:iterations] do - let caseSeed := seed - -- "GET " (4) + path + " HTTP/1.1\r\n" (12) → path can be up to (limit - 16) - let pathBudget := if limit > 16 then limit - 16 else 1 - let (pathLen, s1) := randIn seed 1 (pathBudget + 10); seed := s1 - let path := "/" ++ String.ofList (List.replicate (pathLen - 1) 'a') - let raw := - s!"GET {path} HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 - let (client, server) ← Mock.new - let response ← sendRawAndClose client server raw okHandler config - -- start-line = "GET " + path + " HTTP/1.1\r\n" - let lineLen := 4 + pathLen + 11 - if lineLen ≤ limit then - assertStatusPrefix s!"fuzzStartLineLen iter={i} seed={caseSeed} len={lineLen}" response "HTTP/1.1 200" - else - -- Either 414 (URI too long) or 400 - let text := String.fromUTF8! response - unless text.startsWith "HTTP/1.1 414" || text.startsWith "HTTP/1.1 400" do - throw <| IO.userError - s!"fuzzStartLineLen iter={i} seed={caseSeed} len={lineLen}: expected 414 or 400, got {text.quote}" - --- ============================================================================ --- maxHeaderNameLength and maxHeaderValueLength --- ============================================================================ - --- Property: header names exceeding maxHeaderNameLength → 400. -def fuzzHeaderNameLengthLimit (iterations : Nat) (seed0 : Nat) : IO Unit := do - let limit : Nat := 16 - let config : Config := { lingeringTimeout := 1000, generateDate := false, maxHeaderNameLength := limit } - let mut seed := seed0 - for i in [0:iterations] do - let caseSeed := seed - let (nameLen, s1) := randIn seed 1 (limit + 8); seed := s1 - let (nameBytes, s2) := randomTokenBytes seed nameLen; seed := s2 - let name := String.fromUTF8! nameBytes - let raw := - s!"GET /hnl-{i} HTTP/1.1\x0d\nHost: example.com\x0d\n{name}: value\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 - let (client, server) ← Mock.new - let response ← sendRawAndClose client server raw okHandler config - if nameLen ≤ limit then - assertStatusPrefix s!"fuzzHeaderNameLen iter={i} seed={caseSeed} len={nameLen}" response "HTTP/1.1 200" - else - assertStatusPrefix s!"fuzzHeaderNameLen iter={i} seed={caseSeed} len={nameLen}" response "HTTP/1.1 400" - --- Property: header values exceeding maxHeaderValueLength → 400. -def fuzzHeaderValueLengthLimit (iterations : Nat) (seed0 : Nat) : IO Unit := do - let limit : Nat := 32 - let config : Config := { - lingeringTimeout := 1000 - generateDate := false - maxHeaderValueLength := limit - maxHeaderBytes := 65536 -- don't let total bytes limit interfere - } - let mut seed := seed0 - for i in [0:iterations] do - let caseSeed := seed - let (valueLen, s1) := randIn seed 0 (limit + 8); seed := s1 - let (valueBytes, s2) := randomAsciiBytes seed valueLen; seed := s2 - let value := String.fromUTF8! valueBytes - let raw := - s!"GET /hvl-{i} HTTP/1.1\x0d\nHost: example.com\x0d\nX-Long: {value}\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 - let (client, server) ← Mock.new - let response ← sendRawAndClose client server raw okHandler config - if valueLen ≤ limit then - assertStatusPrefix s!"fuzzHeaderValueLen iter={i} seed={caseSeed} len={valueLen}" response "HTTP/1.1 200" - else - assertStatusPrefix s!"fuzzHeaderValueLen iter={i} seed={caseSeed} len={valueLen}" response "HTTP/1.1 400" - --- ============================================================================ --- Run all properties --- ============================================================================ - --- Property: maxBodySize enforced for Content-Length framing. -#eval runWithTimeout "fuzz_body_limit_content_length" 30000 do - fuzzBodySizeLimitContentLength 50 0x00B0DEC0 - --- Property: maxBodySize enforced for chunked framing. -#eval runWithTimeout "fuzz_body_limit_chunked" 30000 do - fuzzBodySizeLimitChunked 40 0x00C8BE11 - --- Property: maxHeaders count limit is enforced. -#eval runWithTimeout "fuzz_header_count_limit" 30000 do - fuzzHeaderCountLimit 50 0x00AA55AA - --- Property: maxHeaderBytes aggregate limit is enforced. -#eval runWithTimeout "fuzz_header_bytes_limit" 30000 do - fuzzHeaderTotalBytesLimit 40 0x00FACE77 - --- Property: maxMessages per connection closes keep-alive after the configured count. -#eval runWithTimeout "fuzz_max_messages_per_connection" 30000 do - fuzzMaxMessagesPerConnection 30 0x00123ABC - --- Property: maxLeadingEmptyLines limit is enforced. -#eval runWithTimeout "fuzz_leading_empty_lines_limit" 30000 do - fuzzLeadingEmptyLinesLimit 50 0x00EEF00D - --- Property: maxSpaceSequence (OWS) limit is enforced. -#eval runWithTimeout "fuzz_ows_sequence_limit" 30000 do - fuzzOWSSequenceLimit 50 0x00ABE5AB - --- Property: maxStartLineLength / maxUriLength is enforced, returning 414 or 400. -#eval runWithTimeout "fuzz_start_line_length_limit" 30000 do - fuzzStartLineLengthLimit 50 0x00C0FFEE - --- Property: maxHeaderNameLength is enforced. -#eval runWithTimeout "fuzz_header_name_length_limit" 30000 do - fuzzHeaderNameLengthLimit 50 0x00DEAD01 - --- Property: maxHeaderValueLength is enforced. -#eval runWithTimeout "fuzz_header_value_length_limit" 30000 do - fuzzHeaderValueLengthLimit 50 0x00BEEF02
diff --git a/tests/async/elab/async_http_fuzz_random.lean b/tests/async/elab/async_http_fuzz_random.lean index 516fbe9..57633c5 100644 --- a/tests/async/elab/async_http_fuzz_random.lean +++ b/tests/async/elab/async_http_fuzz_random.lean
@@ -1,4 +1,5 @@ import Std.Http +import Std.Http.Test.Helpers import Std.Async open Std.Async @@ -194,61 +195,6 @@ let response ← sendRawAndClose client server bytes okHandler assertValidHttpOrEmpty s!"fuzzSingleByte byte={b}" response --- Property: known attack patterns and real-world malformed inputs are handled safely. --- This is the Lean analogue of hyper's denial-of-service and smuggling corpus. -def fuzzKnownMaliciousPatterns : IO Unit := do - let patterns : Array ByteArray := #[ - -- TLS 1.2 client hello prefix - ByteArray.mk #[0x16, 0x03, 0x01, 0x00, 0xa5, 0x01, 0x00, 0x00], - -- TLS 1.3 client hello prefix - ByteArray.mk #[0x16, 0x03, 0x03, 0x00, 0x7c, 0x01, 0x00, 0x00], - -- HTTP/2 connection preface - "PRI * HTTP/2.0\x0d\n\x0d\nSM\x0d\n\x0d\n".toUTF8, - -- Bare LF line endings - "GET / HTTP/1.1\nHost: example.com\n\n".toUTF8, - -- CR-only line endings - "GET / HTTP/1.1\x0dHost: example.com\x0d\x0d".toUTF8, - -- Null bytes everywhere - ByteArray.mk #[0x00, 0x00, 0x00, 0x00], - -- CRLF injection attempt in request-line - "GET /path%0d%0aInjected: header HTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n".toUTF8, - -- Unicode in path (raw multibyte UTF-8) - "GET /caf\xc3\xa9 HTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n".toUTF8, - -- HTTP response sent as a request (should fail, not panic) - "HTTP/1.1 200 OK\x0d\nContent-Length: 2\x0d\n\x0d\nok".toUTF8, - -- Request smuggling: CL.TE - "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 6\x0d\nTransfer-Encoding: chunked\x0d\n\x0d\n0\x0d\n\x0d\nX".toUTF8, - -- Request smuggling: TE.CL - "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nContent-Length: 3\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n".toUTF8, - -- Duplicate chunked coding - "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked, chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n".toUTF8, - -- TE with tab (whitespace obfuscation) - "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding:\x09chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n".toUTF8, - -- TE with null byte injection - "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunk\x00ed\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n".toUTF8, - -- Extremely long method token - (String.ofList (List.replicate 8192 'A') ++ " / HTTP/1.1\x0d\nHost: h\x0d\n\x0d\n").toUTF8, - -- SSRF-like absolute-form URI targeting internal host - "GET http://169.254.169.254/latest/meta-data/ HTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n".toUTF8, - -- Chunk size with non-hex chars - "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\nGG\x0d\nhello\x0d\n0\x0d\n\x0d\n".toUTF8, - -- Chunk size overflow attempt (16+ hex digits) - "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\nffffffffffffffff1\x0d\nhello\x0d\n0\x0d\n\x0d\n".toUTF8, - -- Header with embedded CRLF in value - "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nX-Inject: foo\x0d\nEvil: injected\x0d\nConnection: close\x0d\n\x0d\n".toUTF8, - -- Multiple Host headers (smuggling attempt) - "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nHost: evil.com\x0d\nConnection: close\x0d\n\x0d\n".toUTF8, - -- Absolute-form URI with bad host overrides Host header - "GET http://evil.internal/steal HTTP/1.1\x0d\nHost: public.example.com\x0d\nConnection: close\x0d\n\x0d\n".toUTF8, - -- Folded header (obs-fold, rejected per RFC 9112) - "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nX-Folded: value\x0d\n continuation\x0d\nConnection: close\x0d\n\x0d\n".toUTF8, - ] - for i in [:patterns.size] do - let pattern := patterns[i]! - let (client, server) ← Mock.new - let response ← sendRawAndClose client server pattern okHandler - assertValidHttpOrEmpty s!"fuzzKnownMalicious pattern={i}" response - -- ============================================================================ -- Run all properties -- ============================================================================ @@ -280,7 +226,3 @@ -- Property: every single-byte input is handled safely (all 256 cases). #eval runWithTimeout "fuzz_single_byte_inputs" 30000 do fuzzSingleByteInputs - --- Property: known attack patterns and malformed inputs are handled safely. -#eval runWithTimeout "fuzz_known_malicious_patterns" 30000 do - fuzzKnownMaliciousPatterns
diff --git a/tests/async/elab/async_http_h1_chunked_overhead.lean b/tests/async/elab/async_http_h1_chunked_overhead.lean deleted file mode 100644 index 462c4cd..0000000 --- a/tests/async/elab/async_http_h1_chunked_overhead.lean +++ /dev/null
@@ -1,57 +0,0 @@ -import Std.Http - -open Std Http -open Std.Http.Protocol.H1 - -/-! -Tests that chunked framing counts toward `maxBodySize`: chunk-size lines with their extensions, the -line break after each chunk's data, and the trailer section. Otherwise a body of small chunks with -long extensions makes the server read many times `maxBodySize` from the network for a body that -fits the limit. --/ - -/-- -Feeds `data` to a server machine `piece` bytes at a time, pulling the body as it arrives. Returns -the machine's error, whether the body completed, and the number of content bytes pulled. --/ -def run (config : Protocol.H1.Config) (data : ByteArray) (piece : Nat) : - Option Error × Bool × Nat := Id.run do - let mut m : Machine .receiving := { config } - let mut pulled := 0 - let mut complete := false - let mut i := 0 - while i < data.size && !m.failed do - m := m.feed (data.extract i (i + piece)) - i := i + piece - for _ in [0:4] do - m := m.step.1 - let (m', chunk) := m.pullBody - m := m' - if let some c := chunk then - pulled := pulled + c.chunk.data.size - complete := complete || c.final - return (m.error, complete, pulled) - -def chunkedPost : String := - "POST / HTTP/1.1\r\nHost: a\r\nTransfer-Encoding: chunked\r\n\r\n" - --- 1000 one-byte chunks with ~100-byte extensions: 1000 content bytes, over 100 KB on the wire. -#eval show IO Unit from do - let ext := s!";name={String.ofList (List.replicate 100 'x')}" - let body := String.join (List.replicate 1000 s!"1{ext}\r\nX\r\n") ++ "0\r\n\r\n" - let (error, complete, pulled) := run { maxBodySize := 2000 } (chunkedPost ++ body).toUTF8 4096 - unless error == some .entityTooLarge && !complete && pulled < 2000 do - throw <| IO.userError s!"framing not counted: {repr error}, complete {complete}, pulled {pulled}" - --- The limit is exactly the body's wire size: it fits, and one byte less does not, however the --- input is split. The last byte over the limit is the line break that ends the trailer section. -#eval show IO Unit from do - let body := "5\r\nhello\r\n3;x=y\r\nabc\r\n0\r\nX-Trace: 1\r\n\r\n" - let data := (chunkedPost ++ body).toUTF8 - for piece in [data.size, 1] do - let (error, complete, pulled) := run { maxBodySize := body.utf8ByteSize } data piece - unless error.isNone && complete && pulled == 8 do - throw <| IO.userError s!"exact fit, pieces of {piece}: {repr error}, complete {complete}, pulled {pulled}" - let (error, complete, _) := run { maxBodySize := body.utf8ByteSize - 1 } data piece - unless error == some .entityTooLarge && !complete do - throw <| IO.userError s!"one byte over, pieces of {piece}: {repr error}, complete {complete}"
diff --git a/tests/async/elab/async_http_h1_client_framing.lean b/tests/async/elab/async_http_h1_client_framing.lean new file mode 100644 index 0000000..6cf2690 --- /dev/null +++ b/tests/async/elab/async_http_h1_client_framing.lean
@@ -0,0 +1,648 @@ +module + +import Std.Http.Test.Helpers +import Std.Http.Test.Machine + +/-! +# HTTP/1.1 client framing + +`Machine .sending`: how a client reads the status line, fields, bodies, trailers and interim responses +of a response, and how it writes request heads and request bodies. RFC 9110 §2.5, §5.5, §6.5, +§8.6, §15.2; RFC 9112 §4, §6, §7.1. Regressions: #16282. +-/ + +open Std Http +open Std.Async +open Std.Http.Internal +open Std.Http.Protocol.H1 +open Std.Http.Internal.Test + +private def mkGet10 (path : String := "/") : String := + s!"GET {path} HTTP/1.0\r\n\r\n" + +private def mkPostHead (path : String) (bodyLen : Nat) (extra : String := "") : String := + rawRequest "POST" path (extra := s!"Content-Length: {bodyLen}\r\n{extra}") + +private def minimalGetRequest : Request.Head := + { method := .get, version := .v11, uri := RequestTarget.originForm! "/", + headers := Headers.empty.insert! "Host" "example.com" } + +private def run (machine : Machine dir) (n : Nat := 4) : Machine dir × String := Id.run do + let mut machine := machine + let mut out := ByteArray.empty + for _ in [0:n] do + let (next, step) := machine.step + machine := next + out := out ++ step.output.toByteArray + return (machine, String.fromUTF8! out) + +private def expect (cond : Bool) (msg : String) : IO Unit := + unless cond do throw (IO.userError msg) + +private def post (version : Version) : Request.Head := + { method := .post, version, uri := RequestTarget.parse! "/", + headers := Headers.empty.insert Header.Name.host (.mk "a") } + +/-- Sends a POST whose body arrives in a later step than its head, and returns the wire bytes. -/ +private def sendLateBody (version : Version) : Machine .sending × String := + let m : Machine .sending := { config := {} } + let (m, first) := run (m.send (post version) |>.sendData #[Chunk.ofByteArray "hello".toUTF8]) 2 + let (m, rest) := run m.userClosedBody 3 + (m, first ++ rest) + +/-- A request head that declares a 10-byte body. -/ +private def putHead : Request.Head := + (Request.new |>.method .put |>.uri! "/upload" |>.header! "Host" "example.com" + |>.header! "Content-Length" "10").line + +/-- Steps `machine` until a step writes `needle`, and reports whether that step also closed. -/ +private def closesWhenWriting (machine : Machine dir) (needle : String) : IO Bool := do + let mut machine := machine + for _ in [0:8] do + let (next, step) := machine.step + machine := next + let wrote := String.fromUTF8! (step.output.data.foldl (· ++ ·) .empty) + if wrote.contains needle then + return step.events.any (· matches .close) && machine.error == some .badMessage + throw <| IO.userError s!"{needle.quote} was never written" + +private def getHead (method : Method) : Request.Head := + { method, version := .v11, uri := RequestTarget.parse! "/", headers := Headers.empty.insert .host (.mk "a") } + +/-- Sends a GET, reads `first` and `early`, then sends a HEAD; returns the bytes written for it. -/ +private def secondRequest (early : ByteArray) : ByteArray := Id.run do + let mut m : Machine .sending := { config := {} } + m := m.send (getHead .get) |>.userClosedBody + let (m1, _) := m.step + m := m1.feed ("HTTP/1.1 204 No Content\r\n\r\n".toUTF8 ++ early) + for _ in [0:4] do + m := m.step.1 + m := m.send (getHead .head) |>.userClosedBody + let mut out := ByteArray.empty + for _ in [0:4] do + let (m', res) := m.step + m := m' + out := out ++ res.output.toByteArray + return out + +/-- A server machine that has read `request`. -/ +private def server (request : String) : Machine .receiving := + (({ config := {} } : Machine .receiving).feed request.toUTF8).step.1 + +private def headers (fields : List (Header.Name × String)) : Headers := + fields.foldl (fun hs (name, value) => hs.insert name (Header.Value.ofString! value)) .empty + +private def get : String := "GET / HTTP/1.1\r\nHost: a\r\n\r\n" + +private def abc : Array Chunk := #[Chunk.ofByteArray "abc".toUTF8] + +/-! ## Status line and fields (RFC 9112 §4, RFC 9110 §2.5, §5.5) -/ + +#eval checkCases "Status line and fields: machine" #[ + ("§5.5: obs-text in a response field value is accepted", do + -- §5.5: a recipient treats obs-text in a field value as opaque data + MachineTester.sending "§5.5: obs-text in a response field value is accepted" + |>.send minimalGetRequest |>.step + |>.feedBytes ("HTTP/1.1 200 OK\r\nContent-Disposition: attachment; filename=\"caf".toUTF8 + ++ ByteArray.mk #[0xC3, 0xA9] ++ ".txt\"\r\nX-Latin1: caf".toUTF8 ++ ByteArray.mk #[0xE9] + ++ "\r\nContent-Length: 0\r\n\r\n".toUTF8) + |>.step |>.assertNoError |>.assertHasEndHeaders + |>.onEndHeaders (fun t head => + let disposition := (head.headers.get? (.ofString! "Content-Disposition")).map (·.value) + let latin1 := (head.headers.get? (.ofString! "X-Latin1")).map (·.value) + if disposition != some "attachment; filename=\"café.txt\"" then + t.addError s!"Content-Disposition mismatch: {repr disposition}" + else if latin1 != some "caf\uFFFD" then + t.addError s!"X-Latin1 mismatch: {repr latin1}" + else t) + |>.run), + ("§4: obs-text in the reason phrase is accepted", do + -- §4: obs-text in a reason phrase, which a client ignores + MachineTester.sending "§4: obs-text in the reason phrase is accepted" + |>.send minimalGetRequest |>.step + |>.feedBytes ("HTTP/1.1 200 Tr".toUTF8 ++ ByteArray.mk #[0xC3, 0xA8] ++ "s bien ".toUTF8 + ++ ByteArray.mk #[0xFF] ++ "\r\nContent-Length: 0\r\n\r\n".toUTF8) + |>.step |>.assertNoError + |>.onEndHeaders (fun t head => + if head.status.toCode != 200 then t.addError s!"expected 200, got {head.status.toCode}" else t) + |>.run), + ("§4: status line with no space after the code is accepted", do + -- §4: a status line that ends right after the status code + MachineTester.sending "§4: status line with no space after the code is accepted" + |>.send minimalGetRequest |>.step + |>.feed "HTTP/1.1 204\r\n\r\n" + |>.step |>.assertNoError + |>.onEndHeaders (fun t head => + if head.status != .noContent then t.addError s!"expected 204, got {head.status.toCode}" else t) + |>.run), + ("§2.5: HTTP/1.2 response is read as HTTP/1.1", do + -- §2.5: a higher minor version is processed as the highest minor version the recipient implements + MachineTester.sending "§2.5: HTTP/1.2 response is read as HTTP/1.1" + |>.send minimalGetRequest |>.step + |>.feed "HTTP/1.2 200 OK\r\nContent-Length: 2\r\n\r\nok" + |>.step |>.assertNoError |>.assertKeepAlive + |>.onEndHeaders (fun t head => + if head.version != .v11 then t.addError s!"expected HTTP/1.1, got {repr head.version}" else t) + |>.drainBody |>.assertPulledBody "ok".toUTF8 |>.run) + ] (·.2) + +#eval checkCases "Status line and fields: async_http_response_framing.lean" #[ + ("RFC 9112 §4, §6.3: parse a 200 response with headers", + do + -- Parse a 200 response with headers + let machineA : Protocol.H1.Machine .sending := { config := {}, reader := { state := .needStartLine } } + let rawA := "HTTP/1.1 200 OK\x0d\nContent-Length: 0\x0d\nConnection: close\x0d\n\x0d\n" + let (machineA', stepA) := (machineA.feed rawA.toUTF8).step + if stepA.events.any (fun | .failed _ => true | _ => false) then + throw <| IO.userError s!"unexpected failure parsing 200 response: {repr stepA.events}" + unless stepA.events.any (fun | .endHeaders _ => true | _ => false) do + throw <| IO.userError s!"missing endHeaders event: {repr stepA.events}" + unless machineA'.reader.messageHead.status == .ok do + throw <| IO.userError s!"unexpected status: {repr machineA'.reader.messageHead.status}" + unless machineA'.reader.messageHead.headers.hasEntry Header.Name.contentLength (Header.Value.ofString! "0") do + throw <| IO.userError "missing Content-Length header in parsed response") + ] (·.2) + + +/-- A client that sent `request` and then read `raw` in one read. -/ +private def clientRead (raw : ByteArray) (request : Request.Head := minimalGetRequest) : MachineTester .sending := + MachineTester.sending "client" |>.send request |>.step |>.feedBytes raw |>.step + +/-- A failure leaves `error` set; the reader may already have moved on from `.failed`. -/ +private def hasFailed (m : Machine .sending) : Bool := m.failed || m.error.isSome + +private def expectFailed (raw : ByteArray) (request : Request.Head := minimalGetRequest) : IO Unit := do + let t := clientRead raw request + ensure (hasFailed t.machine) s!"expected a failure for {(String.fromUTF8? raw).getD "<bytes>" |>.quote}, got {repr (t.lastStep.map (·.events))}" + +private def expectStatus (raw : ByteArray) (check : Status → Bool) (what : String) : IO Unit := + clientRead raw |>.assertNoError |>.assertHasEndHeaders + |>.onEndHeaders (fun t head => if check head.status then t else t.addError s!"{what}: got {head.status.toCode}") |>.run + +-- RFC 9112 §4: `status-code = 3DIGIT`, then SP. +#eval checkCases "Status lines that fail" #[ + "HTTP/1.1 20X OK", "HTTP/1.1 abcd", "HTTP/1.1 Unknown", "HTTP/1.1 c8 OK", "HTTP/1.1 0x12d OK", + "HTTP/1.1 20 OK", "HTTP/1.1 1000 OK", "HTTP/1.1 -10 OK", "HTTP/1.1 400.100 Not Ok", "HTTP/1.1 99 200 OK", + "HTTP/1.1 200 OK", "HTTP/1.0 401 Unauthorized", "HTTP/1.1 200\x0dOK" + ] fun line => expectFailed s!"{line}\r\nContent-Length: 0\r\n\r\n".toUTF8 + +-- RFC 9110 §15: a client treats a status code outside 100–599 as a 5xx. +#eval checkCases "Status codes that are accepted" #[ + ("200 OK", "200 OK", fun (s : Status) => s.toCode == 200), ("404 NOTFOUND", "404 NOTFOUND", (·.toCode == 404)), + ("999 Done", "999 Done", (·.isServerError)), + ("600–999", "", (·.isServerError)), + ("000", "000 X", (·.isServerError)), ("001", "001 X", (·.isServerError)), ("099", "099 X", (·.isServerError)) + ] fun (label, rest, check) => do + if label == "600–999" then + for code in [600:1000] do + expectStatus s!"HTTP/1.1 {code} X\r\nContent-Length: 0\r\n\r\n".toUTF8 check s!"{code}" + else + expectStatus s!"HTTP/1.1 {rest}\r\nContent-Length: 0\r\n\r\n".toUTF8 check label + +#eval checkCases "Reason phrases" #[ + ("HTTP/1.0 303 SP, then CRLF", "HTTP/1.0 303 \r\nContent-Length: 0\r\n\r\n".toUTF8, true), + ("no reason, then a field", "HTTP/1.1 200\r\nFoo: bar\r\nContent-Length: 0\r\n\r\n".toUTF8, true), + ("a reason ending in HTAB", "HTTP/1.1 200 OK\t\r\nContent-Length: 0\r\n\r\n".toUTF8, true), + ("obs-text", "HTTP/1.1 200 X".toUTF8 ++ ByteArray.mk #[0xFF] ++ "Z\r\nContent-Length: 0\r\n\r\n".toUTF8, true), + ("NUL", "HTTP/1.1 200 O\x00K\r\nContent-Length: 0\r\n\r\n".toUTF8, false) + ] fun (_, raw, ok) => if ok then (clientRead raw |>.assertNoError |>.assertHasEndHeaders |>.run) else expectFailed raw + +#eval checkCases "Status-line versions" #[ + ("HTTP/2.0 is unsupported", clientRead "HTTP/2.0 200 OK\r\nContent-Length: 0\r\n\r\n".toUTF8 + |>.assertFailedWith .unsupportedVersion |>.run), + ("HTTP/1.100000000002", expectFailed "HTTP/1.100000000002 200 OK\r\nContent-Length: 0\r\n\r\n".toUTF8), + ("HTTP/1.-1", expectFailed "HTTP/1.-1 200 OK\r\nContent-Length: 0\r\n\r\n".toUTF8), + ("HTTP/A.B", expectFailed "HTTP/A.B 200 OK\r\nContent-Length: 0\r\n\r\n".toUTF8), + ("HTTP/1", expectFailed "HTTP/1 200 OK\r\nContent-Length: 0\r\n\r\n".toUTF8), + ("http/1.1", expectFailed "http/1.1 200 OK\r\nContent-Length: 0\r\n\r\n".toUTF8) + ] (·.2) + +-- RFC 9112 §4: a response starts with `HTTP-name`; other first bytes fail without waiting for a line. +#eval checkCases "Non-HTTP first bytes" #[ + ("NUL", ByteArray.mk #[0x00]), ("SP", " ".toUTF8), + ("a TLS ServerHello", ByteArray.mk #[0x16, 0x03, 0x03, 0x00, 0x31]), ("CRLF", "\r\n".toUTF8) + ] fun (_, raw) => expectFailed raw + +#eval checkCases "Response field syntax that fails" #[ + ("a SP line before the first field", "HTTP/1.1 200 OK\r\n Foo: bar\r\nContent-Length: 0\r\n\r\n"), + ("a HTAB line before the first field", "HTTP/1.1 200 OK\r\n\tFoo: bar\r\nContent-Length: 0\r\n\r\n"), + (": nval", "HTTP/1.1 200 OK\r\n: nval\r\nContent-Length: 0\r\n\r\n"), + ("a line without a colon", "HTTP/1.1 200 OK\r\nFoo\r\nContent-Length: 0\r\n\r\n") + ] fun (_, raw) => expectFailed raw.toUTF8 + +private def foldedValue (raw : String) : Option String := Id.run do + let t := clientRead raw.toUTF8 + let some step := t.lastStep | return none + for e in step.events do + if let .endHeaders head := e then + return (head.headers.get? (.ofString! "X-Fold")).map (·.value) + return none + +-- RFC 9112 §5.2: a user agent MUST replace each obs-fold with one or more SP before interpreting the value. +#eval checkCases "obs-fold in a response is unfolded" #[ + ("in the middle", "X-Fold: text\r\n folded with space\r\n\tfolded with tab", "text folded with space folded with tab"), + ("at the start", "X-Fold:\r\n text", "text"), ("at the end", "X-Fold: text\r\n ", "text"), + ("the whole value", "X-Fold:\r\n ", "") + ] fun (_, field, want) => do + let got := foldedValue s!"HTTP/1.1 200 OK\r\n{field}\r\nContent-Length: 0\r\n\r\n" + ensure (got == some want) s!"expected {want.quote}, got {repr got}" + +-- RFC 9110 §5.3: `Set-Cookie` lines are never combined. +#eval checkCases "Two Set-Cookie lines" #[ + ("two values, in order", clientRead "HTTP/1.1 200 OK\r\nSet-Cookie: a=1; Path=/\r\nSet-Cookie: b=2\r\nContent-Length: 0\r\n\r\n".toUTF8 + |>.assertNoError + |>.onEndHeaders (fun t head => + let vs := (head.headers.getAll? (.ofString! "Set-Cookie")).map (·.map (·.value)) + if vs == some #["a=1; Path=/", "b=2"] then t else t.addError s!"got {repr vs}") + |>.run) + ] (·.2) + +/-! ## Response body framing (RFC 9112 §6.3, §7.1) -/ + +#eval checkCases "Response body framing: machine" #[ + ("§6.3: response Content-Length body delivered exactly", do + let respBody := "Hello!".toUTF8 + MachineTester.sending "§6.3: response Content-Length body delivered exactly" + |>.send minimalGetRequest |>.step + |>.feed s!"HTTP/1.1 200 OK\r\nContent-Length: {respBody.size}\r\n\r\n" + |>.feedBytes respBody |>.step |>.assertNoError + |>.drainBody |>.assertPulledBody respBody |>.assertLastChunkFinal |>.run), + ("§6.3: EOF-delimited response body; keep-alive disabled", do + let eofBody := "eof body".toUTF8 + MachineTester.sending "§6.3: EOF-delimited response body; keep-alive disabled" + |>.send minimalGetRequest |>.step + |>.feed "HTTP/1.1 200 OK\r\n\r\n" + |>.step |>.assertNoError |>.assertNotKeepAlive + |>.feedBytes eofBody |>.noMoreInput + |>.drainBody |>.assertPulledBody eofBody |>.assertLastChunkFinal |>.run), + ("§7.1: response chunked body decoded", do + -- §7.1: 200 response with chunked body decoded correctly + let respBody := "chunked".toUTF8 + MachineTester.sending "§7.1: response chunked body decoded" + |>.send minimalGetRequest |>.step + |>.feed "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n7\r\nchunked\r\n0\r\n\r\n" + |>.step |>.assertNoError + |>.drainBody |>.assertPulledBody respBody |>.assertLastChunkFinal |>.run), + ("§6.3: HEAD response with contradictory framing fields completes", do + -- §6.3 rule 1: a response to HEAD ends at its header block, whatever its framing fields say + MachineTester.sending "§6.3: HEAD response with contradictory framing fields completes" + |>.send { minimalGetRequest with method := .head } |>.step + |>.feed "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\nContent-Length: 10\r\n\r\n" + |>.step |>.assertNoError |>.assertReaderComplete |>.run), + ("§6.3: 204 response with contradictory framing fields completes", do + -- §6.3 rule 1: so does a 204 response + MachineTester.sending "§6.3: 204 response with contradictory framing fields completes" + |>.send minimalGetRequest |>.step + |>.feed "HTTP/1.1 204 No Content\r\nTransfer-Encoding: chunked\r\nContent-Length: 5\r\n\r\n" + |>.step |>.assertNoError |>.assertReaderComplete |>.run), + ("§6.3 rule 4: a response whose final transfer coding is not chunked is read until the server closes", do + -- §6.3 rule 4: a response whose final transfer coding is not chunked is read until the server closes + for coding in ["gzip", "chunked, gzip", "gzip;level=1", "gzip ; level = \"9\""] do + MachineTester.sending s!"§6.3: Transfer-Encoding: {coding} response is close-delimited" + |>.send minimalGetRequest |>.step + |>.feed s!"HTTP/1.1 200 OK\r\nTransfer-Encoding: {coding}\r\n\r\nabc" + |>.step |>.assertNoError |>.assertNotKeepAlive + |>.noMoreInput |>.drainBody |>.assertNoError + |>.assertPulledBody "abc".toUTF8 |>.assertLastChunkFinal |>.run), + ("§6.3: Transfer-Encoding: gzip;level=1, chunked response is chunked", do + -- §7: transfer parameters do not change which coding is final + MachineTester.sending "§6.3: Transfer-Encoding: gzip;level=1, chunked response is chunked" + |>.send minimalGetRequest |>.step + |>.feed "HTTP/1.1 200 OK\r\nTransfer-Encoding: gzip;level=1, chunked\r\n\r\n3\r\nabc\r\n0\r\n\r\n" + |>.step |>.assertNoError |>.assertKeepAlive + |>.drainBody |>.assertNoError |>.assertPulledBody "abc".toUTF8 |>.assertLastChunkFinal |>.run), + ("§7.1: chunked defines no parameters", do + -- §7.1: chunked defines no parameters + for coding in ["chunked;x=1", "gzip;level, chunked", "gzip;=1, chunked"] do + MachineTester.sending s!"§7: Transfer-Encoding: {coding} → badMessage" + |>.send minimalGetRequest |>.step + |>.feed s!"HTTP/1.1 200 OK\r\nTransfer-Encoding: {coding}\r\n\r\n3\r\nabc\r\n0\r\n\r\n" + |>.step |>.assertFailedWith .badMessage |>.run), + ("§8.6: client HEAD response — body suppressed despite Content-Length", do + -- §8.6: a HEAD response has no body regardless of framing headers. The client reader must treat + -- it as zero-length and finish without blocking, even though Content-Length advertises bytes that + -- never arrive on the wire. + MachineTester.sending "§8.6: client HEAD response — body suppressed despite Content-Length" + |>.send { minimalGetRequest with method := .head } |>.step + |>.feed "HTTP/1.1 200 OK\r\nContent-Length: 100\r\n\r\n" + |>.step + |>.assertNoError + |>.assert (fun m => !m.canPullBody) + "HEAD response must expose no body to pull (reader must not block on absent body bytes)" + |>.assertReaderComplete |>.run), + ("§6.3: client zero-length response auto-completes without pullBody", do + -- §6.3: a client response with a known zero-length body (e.g. 204) must auto-complete; otherwise + -- the connection would stall waiting for a `pullBody` that never produces bytes. + MachineTester.sending "§6.3: client zero-length response auto-completes without pullBody" + |>.send minimalGetRequest |>.step + |>.feed "HTTP/1.1 204 No Content\r\nContent-Length: 0\r\n\r\n" + |>.step + |>.assertNoError + |>.assert (fun m => !m.canPullBody) + "zero-length response body must not require a caller pullBody to advance" + |>.assertReaderComplete |>.run) + ] (·.2) + +#eval checkCases "Response body framing: async_http_response_framing.lean" #[ + ("Parse headerless 204", + do + -- Parse headerless 204 + let machineB : Protocol.H1.Machine .sending := { config := {}, reader := { state := .needStartLine } } + let rawB := "HTTP/1.1 204 No Content\x0d\n\x0d\n" + let (_, stepB) := (machineB.feed rawB.toUTF8).step + if stepB.events.any (fun | .failed _ => true | _ => false) then + throw <| IO.userError s!"unexpected failure parsing 204: {repr stepB.events}" + if stepB.events.any (fun | .needMoreData _ => true | _ => false) then + throw <| IO.userError s!"unexpected needMoreData for 204: {repr stepB.events}" + unless stepB.events.any (fun | .endHeaders _ => true | _ => false) do + throw <| IO.userError s!"missing endHeaders for 204: {repr stepB.events}" + + -- 204 with Content-Length in response: body framing should be ignored + let machineC : Protocol.H1.Machine .sending := { config := {}, reader := { state := .needStartLine } } + let rawC := "HTTP/1.1 204 No Content\x0d\nContent-Length: 5\x0d\n\x0d\nHELLO" + let (machineC', stepC) := (machineC.feed rawC.toUTF8).step + if stepC.events.any (fun | .failed _ => true | _ => false) then + throw <| IO.userError s!"unexpected failure for 204 with framing: {repr stepC.events}" + -- The 5 bytes of "HELLO" should remain unread + unless machineC'.reader.input.remainingBytes == 5 do + throw <| IO.userError s!"expected 5 unread bytes, got {machineC'.reader.input.remainingBytes}") + ] (·.2) + + +-- RFC 9112 §6.3 rules 1, 3, 5. +#eval checkCases "Response Content-Length" #[ + ("two lines that differ", expectFailed "HTTP/1.1 200 OK\r\nContent-Length: 3\r\nContent-Length: 4\r\n\r\nabcd".toUTF8), + ("-1: fails, and the connection is not reused", clientRead "HTTP/1.1 200 OK\r\nContent-Length: -1\r\n\r\n".toUTF8 + |>.assert hasFailed "expected a failure" |>.assertNotKeepAlive |>.run), + ("TE chunked with CL", expectFailed "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\nContent-Length: 5\r\n\r\n5\r\nhello\r\n0\r\n\r\n".toUTF8), + ("204 with differing CLs ends at the head", clientRead "HTTP/1.1 204 No Content\r\nContent-Length: 3\r\nContent-Length: 4\r\n\r\n".toUTF8 + |>.assertNoError |>.drainBody |>.assertPulledBody .empty |>.assertReaderComplete |>.run), + ("304 with differing CLs ends at the head", clientRead "HTTP/1.1 304 Not Modified\r\nContent-Length: 3\r\nContent-Length: 4\r\n\r\n".toUTF8 + |>.assertNoError |>.drainBody |>.assertPulledBody .empty |>.assertReaderComplete |>.run) + ] (·.2) + +-- RFC 9112 §8: an incomplete response delivers what arrived, then fails. `…0\r\n` then EOF waits for P2. +#eval checkCases "Truncated responses" #[ + ("CL 123 with 26 bytes", "HTTP/1.1 200 OK\r\nContent-Length: 123\r\n\r\n", "abcdefghijklmnopqrstuvwxyz"), + ("CL 10 with 7 bytes", "HTTP/1.1 200 OK\r\nContent-Length: 10\r\n\r\n", "1234567"), + ("chunked, cut before the last chunk", "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n5\r\nhello\r\n", "") + ] fun (label, head, part) => do + let t := clientRead (head ++ part).toUTF8 |>.drainBody |>.noMoreInput |>.drainBody |>.step + let want := if label.startsWith "chunked" then "hello" else part + let got := t.pulled.foldl (fun acc c => acc ++ c.chunk.data) .empty + ensure (got == want.toUTF8) s!"delivered {(String.fromUTF8! got).quote}" + ensure (t.machine.error == some .connectionClosed) s!"expected connectionClosed, got {repr t.machine.error}" + +#eval checkCases "A status line without CRLF, then EOF" #[ + ("HTTP/1.1 200 Ok", clientRead "HTTP/1.1 200 Ok".toUTF8 |>.noMoreInput |>.step + |>.assertFailedWith .connectionClosed |>.run) + ] (·.2) + +-- RFC 9112 §6.3 rule 1: HEAD, 204 and 304 responses end at the head. +#eval checkCases "Bodyless responses whatever their framing fields" #[ + ("HEAD, CL 100", "HTTP/1.1 200 OK\r\nContent-Length: 100\r\n\r\n", Method.head), + ("HEAD, chunked", "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n", .head), + ("204, CL 100", "HTTP/1.1 204 No Content\r\nContent-Length: 100\r\n\r\n", .get), + ("204, chunked", "HTTP/1.1 204 No Content\r\nTransfer-Encoding: chunked\r\n\r\n", .get), + ("304, CL 100", "HTTP/1.1 304 Not Modified\r\nContent-Length: 100\r\n\r\n", .get), + ("304, chunked", "HTTP/1.1 304 Not Modified\r\nTransfer-Encoding: chunked\r\n\r\n", .get), + ("HEAD, chunked, then chunk bytes", "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n5\r\nhello\r\n0\r\n\r\n", .head) + ] fun (_, raw, method) => + clientRead raw.toUTF8 { minimalGetRequest with method } |>.assertNoError |>.drainBody + |>.assertPulledBody .empty |>.assertReaderComplete |>.run + +-- RFC 9112 §6.3 rule 8: no framing means the body runs to EOF; leftover bytes wait for the next response. +#eval checkCases "Responses without framing, and bytes after a complete response" #[ + ("HTTP/1.0, no CL or TE", clientRead "HTTP/1.0 200 OK\r\n\r\n".toUTF8 |>.assertNoError |>.assertNotKeepAlive + |>.feed "to eof" |>.noMoreInput |>.drainBody |>.assertPulledBody "to eof".toUTF8 |>.assertLastChunkFinal |>.run), + ("bytes after a CL response stay unread", clientRead "HTTP/1.1 200 OK\r\nContent-Length: 2\r\n\r\nokEXTRA".toUTF8 + |>.drainBody |>.assertPulledBody "ok".toUTF8 + |>.assert (·.reader.input.remainingBytes == 5) "expected the 5 extra bytes unread" |>.run), + ("bytes after a chunked response stay unread", clientRead "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n2\r\nok\r\n0\r\n\r\nEXTRA".toUTF8 + |>.drainBody |>.assertPulledBody "ok".toUTF8 + |>.assert (·.reader.input.remainingBytes == 5) "expected the 5 extra bytes unread" |>.run) + ] (·.2) + +private def connectHead : Request.Head := + { method := .connect, version := .v11, uri := RequestTarget.parse! "example.com:443", + headers := Headers.empty.insert! "Host" "example.com:443" } + +-- RFC 9112 §6.3 rule 2: a client MUST ignore framing fields in a 2xx response to CONNECT. +#eval checkCases "2xx to CONNECT ends at the head" #[ + ("Content-Length: 5", "Content-Length: 5\r\n"), ("Transfer-Encoding: chunked", "Transfer-Encoding: chunked\r\n"), + ("no framing", "") + ] fun (_, framing) => + clientRead s!"HTTP/1.1 200 OK\r\n{framing}\r\n\x16\x03\x01tunnel bytes".toUTF8 connectHead + |>.assertNoError |>.drainBody |>.assertPulledBody .empty |>.assertReaderComplete |>.run + +/-! ## Response trailers (RFC 9110 §6.5) -/ + +#eval checkCases "Response trailers: machine" #[ + ("§6.5: forbidden non-framing trailer field in a response is dropped", do + -- §6.5.1: a client drops a trailer field it must not process instead of failing the response + MachineTester.sending "§6.5: forbidden non-framing trailer field in a response is dropped" + |>.send minimalGetRequest |>.step + |>.feed "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n2\r\nok\r\n0\r\nCache-Control: no-cache\r\n\r\n" + |>.step |>.assertNoError + |>.drainBody |>.assertNoError |>.assertPulledBody "ok".toUTF8 |>.assertLastChunkFinal |>.run), + ("§6.5: framing field in response trailers → badMessage", do + -- a field that frames the message is still refused in a response's trailers + MachineTester.sending "§6.5: framing field in response trailers → badMessage" + |>.send minimalGetRequest |>.step + |>.feed "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n2\r\nok\r\n0\r\nContent-Length: 2\r\n\r\n" + |>.step |>.drainBody |>.assertFailedWith .badMessage |>.run) + ] (·.2) + +/-! ## Interim and upgrade (RFC 9110 §15.2) -/ + +#eval checkCases "Interim and upgrade: machine" #[ + ("§15.2: multiple 1xx responses all skipped", do + -- §15.2: multiple 1xx responses before the real response are all skipped + MachineTester.sending "§15.2: multiple 1xx responses all skipped" + |>.send minimalGetRequest |>.step + |>.feed "HTTP/1.1 100 Continue\r\n\r\n" |>.step + |>.feed "HTTP/1.1 102 Processing\r\n\r\n" |>.step + |>.feed "HTTP/1.1 200 OK\r\nContent-Length: 0\r\n\r\n" |>.step + |>.assertNoError + |>.onEndHeaders (fun t head => + if head.status != .ok then + t.addError s!"expected 200 OK after 1xx chain, got {repr head.status}" + else t) + |>.run), + ("§15.2: 103 Early Hints → no closeBody until the final response", do + -- §15.2: an interim response has no body of its own, so it must not end the response body + MachineTester.sending "§15.2: 103 Early Hints → no closeBody until the final response" + |>.send minimalGetRequest |>.step + |>.feed "HTTP/1.1 103 Early Hints\r\nLink: </style.css>; rel=preload\r\n\r\n" |>.step + |>.assertNoError + |>.assertNoEvent (fun | .closeBody => true | _ => false) + "an interim response must not emit closeBody" + |>.feed "HTTP/1.1 200 OK\r\nContent-Length: 2\r\n\r\nok" |>.step + |>.drainBody |>.assertNoError |>.assertPulledBody "ok".toUTF8 + |>.assertHasCloseBody |>.run), + ("§15.2.2: 101 Switching Protocols ends the exchange", do + -- §15.2.2: after 101 the connection speaks the new protocol, so no final response follows and the + -- bytes after the head are not read as HTTP + MachineTester.sending "§15.2.2: 101 Switching Protocols ends the exchange" + |>.send { minimalGetRequest with + headers := minimalGetRequest.headers + |>.insert! "Connection" "upgrade" |>.insert! "Upgrade" "websocket" } + |>.step + |>.feed "HTTP/1.1 101 Switching Protocols\r\nUpgrade: websocket\r\nConnection: Upgrade\r\n\r\n" + |>.feedBytes (ByteArray.mk #[0x81, 0x02, 0x68, 0x69]) + |>.step + |>.assertNoError |>.assertHasEndHeaders |>.assertNotKeepAlive + |>.assertReaderClosed |>.run) + ] (·.2) + + +-- RFC 9112 §8: a connection that closes before a final response is an incomplete exchange. +#eval checkCases "EOF without a final response" #[ + ("before any status line", MachineTester.sending "before any status line" + |>.send minimalGetRequest |>.step |>.noMoreInput |>.step + |>.assert hasFailed "expected a failure, not a normal end" |>.run), + ("after only 100 Continue", clientRead "HTTP/1.1 100 Continue\r\n\r\n".toUTF8 |>.noMoreInput |>.step + |>.assert hasFailed "expected a failure, not a normal end" |>.run) + ] (·.2) + +/-! ## Request heads (RFC 9112 §3, §6.1) -/ + +#eval checkCases "Request heads: machine" #[ + ("§6.1: client keeps the caller's Transfer-Encoding: gzip, chunked", do + MachineTester.sending "§6.1: client keeps the caller's Transfer-Encoding: gzip, chunked" + |>.send { minimalGetRequest with + method := .post, headers := minimalGetRequest.headers.insert! "Transfer-Encoding" "gzip, chunked" } + |>.sendBytes "abc".toUTF8 |>.userClosedBody |>.step + |>.assertOutputContains "Transfer-Encoding: gzip, chunked\r\n" "expected the caller's codings" + |>.assertOutputContains "3\r\nabc\r\n0\r\n\r\n" "expected a chunked body" |>.run) + ] (·.2) + +#eval checkCases "Request heads: async_http_h1_client_request_version.lean" #[ + ("show IO Unit from do", + show IO Unit from do + let late := secondRequest .empty + let early := secondRequest "HTTP/1.0 200 OK\r\n".toUTF8 + unless late == early do + throw <| IO.userError s!"request head changed: {(String.fromUTF8! late).quote} vs {(String.fromUTF8! early).quote}" + unless late == "HEAD / HTTP/1.1\r\nHost: a\r\n\r\n".toUTF8 do + throw <| IO.userError s!"unexpected request head: {(String.fromUTF8! late).quote}") + ] (·.2) + +#eval checkCases "Request heads: async_http_uri_rendering.lean" #[ + ("On the wire, the target reads back as a request-target.", + show IO Unit from do + let absolute := RequestTarget.absoluteForm (URI.parse! "http://user:secret@example.com/x?q#frag") + let headers := Headers.empty.insert Header.Name.host (.mk "example.com") + let head : Request.Head := { method := .get, version := .v11, uri := absolute, headers } + let m : Machine .sending := { config := {} } + let (_, out) := run (m.setKnownSize (.fixed 0) |>.send head |>.userClosedBody) + expect (out.startsWith "GET http://example.com/x?q HTTP/1.1\x0d\n") s!"request line {out.quote}") + ] (·.2) + +/-! ## Request body framing (RFC 9112 §6, RFC 9110 §8.6) -/ + +#eval checkCases "Request body framing: machine" #[ + ("§8.6: bodyless GET request carries no Content-Length", do + -- RFC 9110 §8.6: no Content-Length on a request without content whose method anticipates none + MachineTester.sending "§8.6: bodyless GET request carries no Content-Length" + |>.send minimalGetRequest |>.userClosedBody |>.step + |>.assertOutputStartsWith "GET / HTTP/1.1\r\n" "expected the request line" + |>.assertOutputNotContains "Content-Length" "a bodyless GET must not carry Content-Length" |>.run), + ("§8.6: bodyless POST request still carries Content-Length: 0", do + MachineTester.sending "§8.6: bodyless POST request still carries Content-Length: 0" + |>.send { minimalGetRequest with method := .post } |>.userClosedBody |>.step + |>.assertOutputContains "Content-Length: 0\r\n" "a bodyless POST keeps Content-Length: 0" |>.run), + ("§8.6: a GET whose caller set Content-Length: 0 keeps it", do + MachineTester.sending "§8.6: a GET whose caller set Content-Length: 0 keeps it" + |>.send { minimalGetRequest with headers := minimalGetRequest.headers.insert! "Content-Length" "0" } + |>.userClosedBody |>.step + |>.assertOutputContains "Content-Length: 0\r\n" "an explicit framing field is kept" |>.run) + ] (·.2) + +#eval checkCases "Request body framing: async_http_h1_framing_mismatch.lean" #[ + ("Client side: a request declaring 10 bytes for a 3-byte body ends the exchange unwritten.", + show IO Unit from do + -- Client side: a request declaring 10 bytes for a 3-byte body ends the exchange unwritten. + let request : Request.Head := + (Request.new |>.method .put |>.uri! "/upload" |>.header! "Host" "example.com" + |>.header! "Content-Length" "10").line + let machine := ({ config := {} } : Machine .sending) + |>.setKnownSize (.fixed 3) + |>.send request + |>.sendData abc |>.userClosedBody + let some (out, events) := runToHalt machine + | throw <| IO.userError "the client never halted" + unless out.isEmpty && events.any (· matches .failed (.other _)) do + throw <| IO.userError s!"client: expected a failure and no output, got {repr events}\n{out.quote}" + + -- A streamed upload takes its length from the request's `Content-Length`. + let request : Request.Head := + (Request.new |>.method .put |>.uri! "/upload" |>.header! "Host" "example.com" + |>.header! "Content-Length" "3").line + let machine := ({ config := {} } : Machine .sending) + |>.setKnownSize .chunked + |>.send request + |>.sendData abc |>.userClosedBody + let mut machine := machine + let mut out := "" + for _ in [0:8] do + let (next, step) := machine.step + machine := next + out := out ++ String.fromUTF8! step.output.toByteArray + unless out.contains "Content-Length: 3\r\n" && !out.contains "Transfer-Encoding" && + out.endsWith "\r\n\r\nabc" && machine.error.isNone do + throw <| IO.userError s!"streamed upload: got {repr machine.error}\n{out.quote}") + ] (·.2) + +#eval checkCases "Request body framing: async_http_h1_short_fixed_body.lean" #[ + ("Client side: the request body ends after 5 of its 10 declared bytes.", + show IO Unit from do + let machine : Machine .sending := { config := {} } + let machine := machine.send putHead + |>.sendData #[Chunk.ofByteArray "12345".toUTF8] |>.userClosedBody + unless ← closesWhenWriting machine "12345" do + throw <| IO.userError "a request body 5 bytes short was not reported in the step that wrote it"), + ("Control: the whole declared body completes the message without an error.", + show IO Unit from do + let machine : Machine .sending := { config := {} } + let mut machine := machine.send putHead + |>.sendData #[Chunk.ofByteArray "0123456789".toUTF8] |>.userClosedBody + for _ in [0:8] do + let (next, _) := machine.step + machine := next + if machine.error.isSome then + throw <| IO.userError s!"a complete body failed with {machine.error.map toString}") + ] (·.2) + +#eval checkCases "Request body framing: async_http_h1_v10_framing.lean" #[ + ("Control: an HTTP/1.1 request of unknown length streams chunked.", + show IO Unit from do + let (_, out) := sendLateBody .v10 + expect (!out.contains "Transfer-Encoding" && out.contains "Content-Length: 5\x0d\n" + && out.endsWith "\x0d\n\x0d\nhello") + s!"client HTTP/1.0 POST of unknown length: {out.quote}" + -- Control: an HTTP/1.1 request of unknown length streams chunked. + let (_, out) := sendLateBody .v11 + expect (out.contains "Transfer-Encoding: chunked") s!"client HTTP/1.1 POST of unknown length: {out.quote}"), + ("A length set as `chunked` cannot be sent over HTTP/1.0: the exchange ends with nothing written.", + show IO Unit from do + let m : Machine .sending := { config := {} } + let (m, out) := run (m.setKnownSize .chunked |>.send (post .v10) + |>.sendData #[Chunk.ofByteArray "hello".toUTF8] |>.userClosedBody) + expect (out.isEmpty && m.error.isSome) + s!"client HTTP/1.0 POST set as chunked: expected nothing written and an error, got {out.quote}") + ] (·.2) + + +private def methodHead (method : Method) : Request.Head := + if method == .connect then connectHead else { minimalGetRequest with method } + +-- RFC 9110 §8.6: a request without content carries `Content-Length: 0` only if its method expects content. +#eval checkCases "Bodyless requests" #[ + ("GET", Method.get, false), ("HEAD", .head, false), ("DELETE", .delete, false), + ("OPTIONS", .options, false), ("TRACE", .trace, false), ("CONNECT", .connect, false), + ("POST", .post, true), ("PUT", .put, true), ("PATCH", .patch, true) + ] fun (_, method, zero) => do + let t := MachineTester.sending "bodyless" |>.send (methodHead method) |>.userClosedBody |>.step + let out := String.fromUTF8! t.allOutput + ensure (out.contains "Content-Length: 0\r\n" == zero && (zero || !out.contains "Content-Length")) s!"{out.quote}"
diff --git a/tests/async/elab/async_http_h1_client_request_version.lean b/tests/async/elab/async_http_h1_client_request_version.lean deleted file mode 100644 index d599b60..0000000 --- a/tests/async/elab/async_http_h1_client_request_version.lean +++ /dev/null
@@ -1,36 +0,0 @@ -import Std.Http - -open Std Http -open Std.Http.Protocol.H1 - -/-! -A client's request head depends only on the request: the `Connection` field must not change when -the next response's status line (here `HTTP/1.0`) has already arrived when the request is written. --/ - -def get (method : Method) : Request.Head := - { method, version := .v11, uri := RequestTarget.parse! "/", headers := Headers.empty.insert .host (.mk "a") } - -/-- Sends a GET, reads `first` and `early`, then sends a HEAD; returns the bytes written for it. -/ -def secondRequest (early : ByteArray) : ByteArray := Id.run do - let mut m : Machine .sending := { config := {} } - m := m.send (get .get) |>.userClosedBody - let (m1, _) := m.step - m := m1.feed ("HTTP/1.1 204 No Content\r\n\r\n".toUTF8 ++ early) - for _ in [0:4] do - m := m.step.1 - m := m.send (get .head) |>.userClosedBody - let mut out := ByteArray.empty - for _ in [0:4] do - let (m', res) := m.step - m := m' - out := out ++ res.output.toByteArray - return out - -#eval show IO Unit from do - let late := secondRequest .empty - let early := secondRequest "HTTP/1.0 200 OK\r\n".toUTF8 - unless late == early do - throw <| IO.userError s!"request head changed: {(String.fromUTF8! late).quote} vs {(String.fromUTF8! early).quote}" - unless late == "HEAD / HTTP/1.1\r\nHost: a\r\n\r\n".toUTF8 do - throw <| IO.userError s!"unexpected request head: {(String.fromUTF8! late).quote}"
diff --git a/tests/async/elab/async_http_h1_close_with_error.lean b/tests/async/elab/async_http_h1_close_with_error.lean deleted file mode 100644 index 526aa0f..0000000 --- a/tests/async/elab/async_http_h1_close_with_error.lean +++ /dev/null
@@ -1,37 +0,0 @@ -import Std.Http - -open Std Http -open Std.Http.Protocol.H1 - -/-! -Tests that `Machine.closeWithError` during a streamed response halts the server machine when input it -has not read follows the request, such as a pipelined request or a stray CRLF. A machine that never -halts keeps the server's connection loop spinning, and the connection never closes. --/ - -/-- Steps `machine` until it halts; `none` if it has not halted after 16 steps. -/ -def stepsToHalt (machine : Machine .receiving) : Option Nat := Id.run do - let mut machine := machine - for i in [0:16] do - if machine.halted then return some i - machine := machine.step.1 - return none - -/-- A server machine that has read `input` and is streaming a response to its first request. -/ -def streaming (input : String) : Machine .receiving := - let machine := (({ config := {} } : Machine .receiving).feed input.toUTF8).step.1 - (machine.send { status := .ok } |>.sendData #[Chunk.ofByteArray "hello".toUTF8]).step.1 - -def get : String := "GET / HTTP/1.1\r\nHost: a\r\n\r\n" - -#eval show IO Unit from do - for (name, input) in [ - ("nothing after the request", get), - ("pipelined request", get ++ "GET /2 HTTP/1.1\r\nHost: a\r\n\r\n"), - ("stray CRLF", get ++ "\r\n"), - ("unread body, then a pipelined request", - "POST / HTTP/1.1\r\nHost: a\r\nContent-Length: 3\r\n\r\nabc" ++ get)] do - for status in [Status.serviceUnavailable, .requestTimeout] do - if (stepsToHalt ((streaming input).closeWithError status)).isNone then - throw <| IO.userError - s!"'{name}', {status.toCode}: the machine did not halt after closeWithError"
diff --git a/tests/async/elab/async_http_h1_connection.lean b/tests/async/elab/async_http_h1_connection.lean new file mode 100644 index 0000000..fb387e6 --- /dev/null +++ b/tests/async/elab/async_http_h1_connection.lean
@@ -0,0 +1,812 @@ +module + +import Std.Http.Test.Helpers +import Std.Http.Test.Machine + +/-! +# HTTP/1.1 connections + +Whether a connection persists, how `Connection` options are read and written, pipelining, where the +next request starts after a body, errors that end a connection, and the request count. Machine tables +first, then `serveConnection` tables. RFC 9112 §9.3, §9.6; RFC 9110 §7.6.1, §7.8. Regressions: +#12151. +-/ + +open Std Http +open Std.Async +open Std.Http.Internal +open Std.Http.Protocol.H1 +open Std.Http.Internal.Test + +private def mkGet10 (path : String := "/") : String := + s!"GET {path} HTTP/1.0\r\n\r\n" + +private def mkPostHead (path : String) (bodyLen : Nat) (extra : String := "") : String := + rawRequest "POST" path (extra := s!"Content-Length: {bodyLen}\r\n{extra}") + +private def upgrade (connection : String) : Response.Head := + { status := .upgradeRequired, + headers := Headers.empty |>.insert! "Upgrade" "TLS/1.2" |>.insert! "Connection" connection } + +private def minimalGetRequest : Request.Head := + { method := .get, version := .v11, uri := RequestTarget.originForm! "/", + headers := Headers.empty.insert! "Host" "example.com" } + +/-- Steps `machine` `n` times and returns it with the bytes it wrote. -/ +private def run (machine : Machine dir) (n : Nat := 4) : Machine dir × String := Id.run do + let mut machine := machine + let mut out := ByteArray.empty + for _ in [0:n] do + let (next, step) := machine.step + machine := next + out := out ++ step.output.toByteArray + return (machine, String.fromUTF8! out) + +private def expect (cond : Bool) (msg : String) : IO Unit := + unless cond do throw (IO.userError msg) + +private def runPipelined + (raw : String) + (readBody : Bool := true) + (config : Std.Http.Config := defaultConfig) : IO (ByteArray × Array String) := Async.block do + let (client, server) ← Mock.new + let seenRef ← IO.mkRef (#[] : Array String) + + let handler : TestHandler := fun req => do + seenRef.modify (·.push (toString req.line.uri)) + let body ← + if readBody then req.body.readAll + else pure "<ignored>" + Response.ok |>.text s!"{toString req.line.uri}:{body}" + + client.send raw.toUTF8 + client.getSendChan.close + Std.Http.Server.serveConnection server handler config |>.run + + let response ← client.recv? + let seen ← seenRef.get + pure (response.getD .empty, seen) + +private def assertSeenCount (seen : Array String) (expected : Nat) : IO Unit := do + unless seen.size == expected do + throw <| IO.userError s!"expected {expected} handler calls, got {seen.size}: {seen}" + +private def runWithTimeout {α : Type} (name : String) (timeoutMs : Nat := 2000) (action : IO α) : IO α := do + let task ← IO.asTask action + let ticks := (timeoutMs + 9) / 10 + + let rec loop (remaining : Nat) : IO α := do + if (← IO.getTaskState task) == .finished then + match (← IO.wait task) with + | .ok x => pure x + | .error err => throw err + else + match remaining with + | 0 => + IO.cancel task + throw <| IO.userError s!"Test '{name}' timed out after {timeoutMs}ms (possible hang/loop)" + | n + 1 => + IO.sleep 10 + loop n + + loop ticks + +private def sendRaw (client : Mock.Client) (server : Mock.Server) (raw : ByteArray) + (handler : TestHandler) (config : Std.Http.Config := { lingeringTimeout := 500, generateDate := false }) : IO ByteArray := Async.block do + client.send raw + Std.Http.Server.serveConnection server handler config + |>.run + let res ← client.recv? + pure <| res.getD .empty + +private def sendRawTimed (name : String) (raw : ByteArray) + (handler : TestHandler) (config : Std.Http.Config := { lingeringTimeout := 500, generateDate := false }) : IO ByteArray := + runWithTimeout name 2000 do + let (client, server) ← Mock.new + sendRaw client server raw handler config + +private def runClosedClientTimed (name : String) (raw : ByteArray) + (handler : TestHandler) (config : Std.Http.Config := { lingeringTimeout := 500, generateDate := false }) : IO Unit := + runWithTimeout name 2000 do + Async.block do + let (client, server) ← Mock.new + client.send raw + client.close + Std.Http.Server.serveConnection server handler config + |>.run + +private def countOccurrences (s : String) (needle : String) : Nat := + if needle.isEmpty then 0 else (s.splitOn needle).length - 1 + +private def assertStatusPrefix (name : String) (response : ByteArray) (prefix_ : String) : IO Unit := do + let text := String.fromUTF8! response + unless text.startsWith prefix_ do + throw <| IO.userError s!"Test '{name}' failed:\nExpected prefix: {prefix_.quote}\nGot:\n{text.quote}" + +private def assertNotContains (name : String) (response : ByteArray) (needle : String) : IO Unit := do + let text := String.fromUTF8! response + if text.contains needle then + throw <| IO.userError s!"Test '{name}' failed:\nDid not expect {needle.quote}\nGot:\n{text.quote}" + +private def assertEndsWith (name : String) (response : ByteArray) (suffix_ : String) : IO Unit := do + let text := String.fromUTF8! response + unless text.endsWith suffix_ do + throw <| IO.userError s!"Test '{name}' failed:\nExpected suffix: {suffix_.quote}\nGot:\n{text.quote}" + +private def assertStatusCount (name : String) (response : ByteArray) (expected : Nat) : IO Unit := do + let text := String.fromUTF8! response + let got := countOccurrences text "HTTP/1.1 " + unless got == expected do + throw <| IO.userError s!"Test '{name}' failed:\nExpected {expected} HTTP responses, got {got}\n{text.quote}" + +private def onesChunked (n : Nat) : String := Id.run do + let mut body := "" + for i in [0:n] do + body := body ++ s!"{toString i |>.length}\x0d\n{toString i}\x0d\n" + body ++ "0\x0d\n\x0d\n" + +private def closeChannelIdempotent {α : Type} (ch : Std.CloseableChannel α) : IO Unit := do + match ← EIO.toBaseIO ch.close with + | .ok _ => pure () + | .error .alreadyClosed => pure () + | .error err => throw <| IO.userError (toString err) + +private def responseText (response : ByteArray) : String := + String.fromUTF8! response + +private def nextSeed (seed : Nat) : Nat := + (1664525 * seed + 1013904223) % 4294967296 + +private def randBelow (seed : Nat) (maxExclusive : Nat) : Nat × Nat := + let seed' := nextSeed seed + if maxExclusive == 0 then + (0, seed') + else + (seed' % maxExclusive, seed') + +private def randIn (seed : Nat) (low : Nat) (high : Nat) : Nat × Nat := + if high < low then + (low, seed) + else + let (n, seed') := randBelow seed (high - low + 1) + (low + n, seed') + +private def randomAsciiBytes (seed : Nat) (len : Nat) : ByteArray × Nat := Id.run do + let mut s := seed + let mut out := ByteArray.empty + + for _ in [0:len] do + let (r, s') := randBelow s 38 + s := s' + + let code := + if r < 26 then + 97 + r + else if r < 36 then + 48 + (r - 26) + else if r == 36 then + 45 + else + 95 + + out := out.push (UInt8.ofNat code) + + (out, s) + +private def runPipelinedReadAll + (raw : ByteArray) + (config : Std.Http.Config := defaultConfig) : IO (ByteArray × Array String) := Async.block do + let (client, server) ← Mock.new + let seenRef ← IO.mkRef (#[] : Array String) + + let handler : TestHandler := fun req => do + let uri := toString req.line.uri + seenRef.modify (·.push uri) + let _body : String ← req.body.readAll + Response.ok |>.text uri + + client.send raw + closeChannelIdempotent client.getSendChan + + Std.Http.Server.serveConnection server handler config + |>.run + + let response ← client.recv? + let seen ← seenRef.get + pure (response.getD .empty, seen) + +private def fuzzCompleteFirstBodyAllowsPipeline (iterations : Nat) (seed0 : Nat) : IO Unit := do + let mut seed := seed0 + + for i in [0:iterations] do + let caseSeed := seed + + let (len, seed1) := randIn seed 0 32 + seed := seed1 + + let (body, seed2) := randomAsciiBytes seed len + seed := seed2 + + let uri1 := s!"/first-complete-{i}" + let req1 := + s!"POST {uri1} HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: {len}\x0d\n\x0d\n".toUTF8 ++ body + let req2 := "GET /second HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 + + let (response, seen) ← runPipelinedReadAll (req1 ++ req2) + + let text := responseText response + assertStatusCount s!"fuzzCompleteFirstBodyAllowsPipeline case={i} seed={caseSeed}" response 2 + + unless text.contains uri1 do + throw <| IO.userError s!"fuzzCompleteFirstBodyAllowsPipeline case={i} seed={caseSeed} failed:\nMissing first URI {uri1.quote}\n{text.quote}" + + unless text.contains "/second" do + throw <| IO.userError s!"fuzzCompleteFirstBodyAllowsPipeline case={i} seed={caseSeed} failed:\nMissing second response\n{text.quote}" + + if seen.size != 2 ∨ seen[0]! != uri1 ∨ seen[1]! != "/second" then + throw <| IO.userError s!"fuzzCompleteFirstBodyAllowsPipeline case={i} seed={caseSeed} failed:\nExpected seen=[{uri1.quote}, \"/second\"] got {seen}" + +private def sendRawAndClose + (client : Mock.Client) (server : Mock.Server) (raw : ByteArray) + (handler : TestHandler) (config : Std.Http.Config) : IO ByteArray := Async.block do + client.send raw + closeChannelIdempotent client.getSendChan + Std.Http.Server.serveConnection server handler config |>.run + let res ← client.recv? + pure (res.getD .empty) + +private def fuzzMaxMessagesPerConnection (iterations : Nat) (seed0 : Nat) : IO Unit := do + let limit : Nat := 3 + let config : Std.Http.Config := { + lingeringTimeout := 1000 + generateDate := false + maxRequests := limit + } + let mut seed := seed0 + for i in [0:iterations] do + let caseSeed := seed + let (reqCount, s1) := randIn seed 1 (limit + 3); seed := s1 + + -- Build reqCount keep-alive requests followed by close + let mut raw := ByteArray.empty + for j in [0:reqCount] do + let connHeader := + if j + 1 == reqCount then "Connection: close\x0d\n" else "Connection: keep-alive\x0d\n" + raw := raw ++ s!"GET /msg-{i}-{j} HTTP/1.1\x0d\nHost: example.com\x0d\n{connHeader}\x0d\n".toUTF8 + + let (client, server) ← Mock.new + let response ← sendRawAndClose client server raw okHandler config + let text := String.fromUTF8! response + let seen := countOccurrences text "HTTP/1.1 200" + let expected := Nat.min reqCount limit + if seen != expected then + throw <| IO.userError + s!"fuzzMaxMessages iter={i} seed={caseSeed} reqCount={reqCount}: expected {expected} responses, got {seen}\n{text.quote}" + -- The last response the server writes, whether the request asked or the limit was reached, + -- announces that the connection closes. + let last := ((text.splitOn "HTTP/1.1 200").getLast?).getD "" + unless last.contains "Connection: close" do + throw <| IO.userError + s!"fuzzMaxMessages iter={i} seed={caseSeed} reqCount={reqCount}: the last response lacks Connection: close\n{text.quote}" + +/-- Steps `machine` until it halts; `none` if it has not halted after 16 steps. -/ +private def stepsToHalt (machine : Machine .receiving) : Option Nat := Id.run do + let mut machine := machine + for i in [0:16] do + if machine.halted then return some i + machine := machine.step.1 + return none + +/-- A server machine that has read `input` and is streaming a response to its first request. -/ +private def streaming (input : String) : Machine .receiving := + let machine := (({ config := {} } : Machine .receiving).feed input.toUTF8).step.1 + (machine.send { status := .ok } |>.sendData #[Chunk.ofByteArray "hello".toUTF8]).step.1 + +private def getRequest : String := "GET / HTTP/1.1\r\nHost: a\r\n\r\n" + +/-- A serverAfter machine that has read `request`. -/ +private def serverAfter (request : String) : Machine .receiving := + (({ config := {} } : Machine .receiving).feed request.toUTF8).step.1 + +private def headers (fields : List (Header.Name × String)) : Headers := + fields.foldl (fun hs (name, value) => hs.insert name (Header.Value.ofString! value)) .empty + +private def abc : Array Chunk := #[Chunk.ofByteArray "abc".toUTF8] + +/-! ## Persistence defaults (RFC 9112 §9.3) -/ + +#eval checkCases "Persistence defaults: machine" #[ + ("§9.3: HTTP/1.1 default keep-alive = true", do + -- §9.3: HTTP/1.1 connections are persistent by default + MachineTester.receiving "§9.3: HTTP/1.1 default keep-alive = true" + |>.feed (mkGet "/") |>.step |>.assertNoError |>.assertKeepAlive |>.run), + ("§9.3: HTTP/1.0 default keep-alive = false", do + -- §9.3: HTTP/1.0 connections are not persistent by default + MachineTester.receiving "§9.3: HTTP/1.0 default keep-alive = false" + |>.feed (mkGet10 "/") |>.step |>.assertNoError |>.assertNotKeepAlive |>.run), + ("§9.3: HTTP/1.1 explicit Connection:keep-alive → keepAlive = true", do + -- §9.3: explicit (redundant) Connection: keep-alive MUST NOT suppress default keep-alive + MachineTester.receiving "§9.3: HTTP/1.1 explicit Connection:keep-alive → keepAlive = true" + |>.feed "GET / HTTP/1.1\r\nHost: example.com\r\nConnection: keep-alive\r\n\r\n" + |>.step |>.assertNoError |>.assertKeepAlive |>.run), + ("RFC 9112 §9.3: client receives HTTP/1.0 response → keepAlive = false", do + -- RFC 2616 §8.1: HTTP/1.0 does not default to persistent connections + MachineTester.sending "RFC 9112 §9.3: client receives HTTP/1.0 response → keepAlive = false" + |>.send minimalGetRequest |>.step + |>.feed "HTTP/1.0 200 OK\r\nContent-Length: 0\r\n\r\n" + |>.step |>.assertNoError |>.assertNotKeepAlive |>.run), + ("RFC 9112 §9.3: HTTP/1.0 Connection:keep-alive → keep-alive = true", do + -- RFC 2616 §19.7.1: HTTP/1.0 + Connection: keep-alive → keep-alive enabled + MachineTester.receiving "RFC 9112 §9.3: HTTP/1.0 Connection:keep-alive → keep-alive = true" + |>.feed "GET / HTTP/1.0\r\nConnection: keep-alive\r\n\r\n" + |>.step |>.assertNoError |>.assertKeepAlive |>.run), + ("RFC 9112 §9.3: client receives HTTP/1.0 + Connection:keep-alive → keepAlive = true", do + -- §19.7.1: client side — response Connection:keep-alive → keepAlive = true + MachineTester.sending "RFC 9112 §9.3: client receives HTTP/1.0 + Connection:keep-alive → keepAlive = true" + |>.send minimalGetRequest |>.step + |>.feed "HTTP/1.0 200 OK\r\nConnection: keep-alive\r\nContent-Length: 0\r\n\r\n" + |>.step |>.assertNoError |>.assertKeepAlive |>.run), + ("§6.2: HTTP/1.0 keep-alive request → HTTP/1.1 status line, keep-alive echoed", do + MachineTester.receiving "§6.2: HTTP/1.0 keep-alive request → HTTP/1.1 status line, keep-alive echoed" + |>.feed "GET / HTTP/1.0\r\nConnection: keep-alive\r\n\r\n" |>.step + |>.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody + |>.step |>.step + |>.assertOutputStartsWith "HTTP/1.1 200 OK\r\n" "expected an HTTP/1.1 status line" + |>.assertOutputContains "Connection: keep-alive\r\n" "expected the HTTP/1.0 keep-alive echo" + |>.assertKeepAlive |>.run) + ] (·.2) + + +-- RFC 9112 §9.3: a bodyless status does not end a persistent connection. +#eval checkCases "204 and 304 keep the connection" #[ + ("204, HTTP/1.0 keep-alive", Status.noContent, "GET /1 HTTP/1.0\x0d\nConnection: keep-alive\x0d\n\x0d\nGET /2 HTTP/1.0\x0d\n\x0d\n"), + ("304, HTTP/1.0 keep-alive", .notModified, "GET /1 HTTP/1.0\x0d\nConnection: keep-alive\x0d\n\x0d\nGET /2 HTTP/1.0\x0d\n\x0d\n"), + ("204, HTTP/1.1", .noContent, "GET /1 HTTP/1.1\x0d\nHost: a\x0d\n\x0d\nGET /2 HTTP/1.1\x0d\nHost: a\x0d\nConnection: close\x0d\n\x0d\n"), + ("304, HTTP/1.1", .notModified, "GET /1 HTTP/1.1\x0d\nHost: a\x0d\n\x0d\nGET /2 HTTP/1.1\x0d\nHost: a\x0d\nConnection: close\x0d\n\x0d\n") + ] fun (_, status, raw) => checkHandler raw (show TestHandler from fun _ => Response.withStatus status |>.text "") (.responses 2) + +/-! ## Connection: close (RFC 9112 §9.6) -/ + +#eval checkCases "Connection: close: machine" #[ + ("§9.6: HTTP/1.1 Connection:close → keep-alive = false", do + -- §9.6: Connection: close in request → keep-alive = false + MachineTester.receiving "§9.6: HTTP/1.1 Connection:close → keep-alive = false" + |>.feed "GET / HTTP/1.1\r\nHost: example.com\r\nConnection: close\r\n\r\n" + |>.step |>.assertNoError |>.assertNotKeepAlive |>.run), + ("§9.6: Connection:close injected into response when not keep-alive", do + -- §9.6: Connection: close injected into response when keep-alive is false + MachineTester.receiving "§9.6: Connection:close injected into response when not keep-alive" + |>.feed "GET / HTTP/1.1\r\nHost: example.com\r\nConnection: close\r\n\r\n" + |>.step |>.assertNotKeepAlive + |>.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody |>.step + |>.assertOutputContains "Connection: close" "expected Connection: close in response" |>.run), + ("§9.6: handler Connection:close on keep-alive request → connection closed", do + -- §9.6: a `Connection: close` response header set by the handler ends a keep-alive connection + MachineTester.receiving "§9.6: handler Connection:close on keep-alive request → connection closed" + |>.feed (mkGet "/first" ++ mkGet "/second") |>.step |>.assertHasEndHeaders |>.assertKeepAlive + |>.send { status := .ok, headers := Headers.empty.insert .connection (.mk "close") } + |>.setKnownSize (.fixed 0) |>.userClosedBody |>.step + |>.assertNotKeepAlive + |>.assertOutputContains "Connection: close" "expected Connection: close in response" + |>.assertHasEvent (fun | .close => true | _ => false) "expected .close after the response" + |>.assertNoEvent (fun | .next => true | _ => false) "expected the pipelined request to be dropped" + |>.step |>.assertHalted |>.run), + ("§9.6: the error responses of `closeWithError` end a keep-alive connection", do + -- §9.6: the error responses of `closeWithError` end a keep-alive connection + for status in #[Status.internalServerError, .requestTimeout, .serviceUnavailable] do + MachineTester.receiving s!"§9.6: closeWithError {status.toCode} on keep-alive request → connection closed" + |>.feed (mkGet "/first" ++ mkGet "/second") |>.step |>.assertHasEndHeaders |>.assertKeepAlive + |>.closeWithError status |>.step + |>.assertNotKeepAlive + |>.assertOutputStartsWith s!"HTTP/1.1 {status.toCode} " "expected the error status line" + |>.assertOutputContains "Connection: close" "expected Connection: close in the error response" + |>.assertHasEvent (fun | .close => true | _ => false) "expected .close after the error response" + |>.assertNoEvent (fun | .next => true | _ => false) "expected the pipelined request to be dropped" + |>.run), + ("§9.6: HTTP/1.1 response Connection:close → keep-alive = false", do + -- §9.6: HTTP/1.1 response with Connection: close → keep-alive disabled + MachineTester.sending "§9.6: HTTP/1.1 response Connection:close → keep-alive = false" + |>.send minimalGetRequest |>.step + |>.feed "HTTP/1.1 200 OK\r\nConnection: close\r\nContent-Length: 0\r\n\r\n" + |>.step |>.assertNoError |>.assertNotKeepAlive |>.run) + ] (·.2) + +#eval checkCases "Connection: close: async_http_connection_options.lean" #[ + ("HTTP/1.0 close wins", + do + for value in ["keep-alive, close", "close, keep-alive"] do + check s!"Connection: {value}" + s!"GET /1 HTTP/1.0\x0d\nConnection: {value}\x0d\n\x0d\nGET /2 HTTP/1.0\x0d\n\x0d\n" + uriHandler fun r => do + assertResponseCount r 1 + assertContains r "Connection: close" + assertAbsent r "/2"), + ("A client's HTTP/1.0 request that lists both `keep-alive` and `close` goes out with `close`, and", + show IO Unit from do + let headers := Headers.empty + |>.insert Header.Name.host (.mk "a") + |>.insert Header.Name.connection (.mk "keep-alive, close") + let head : Request.Head := { method := .get, version := .v10, uri := RequestTarget.parse! "/", headers } + let m : Machine .sending := { config := {} } + let (m, out) := run (m.setKnownSize (.fixed 0) |>.send head |>.userClosedBody) + expect (out.contains "Connection: close" && !out.contains "keep-alive") + s!"client HTTP/1.0 request: expected Connection: close, got {out.quote}" + expect (!m.keepAlive) "client HTTP/1.0 request with close: the machine kept the connection") + ] (·.2) + +#eval checkCases "Connection: close: async_http_keepalive.lean" #[ + ("Connection: close on first request blocks pipelined second", + do + check "Connection: close on first request blocks pipelined second" + (raw := + "GET /first HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n" ++ + "GET /second HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") + (handler := fun req => Response.ok |>.text (toString req.line.uri)) + (expect := fun r => + assertResponseCount r 1 *> + assertContains r "/first" *> + assertAbsent r "/second")), + ("enableKeepAlive: false → one response only", + do + check "enableKeepAlive: false → one response only" + (raw := + "GET /1 HTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n" ++ + "GET /2 HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") + (handler := fun req => Response.ok |>.text (toString req.line.uri)) + (config := { defaultConfig with enableKeepAlive := false, lingeringTimeout := 3000 }) + (expect := fun r => + assertResponseCount r 1 *> + assertContains r "/1" *> + assertAbsent r "/2")) + ] (·.2) + + +-- RFC 9110 §7.6.1: `Connection` is a case-insensitive list that may span lines and hold empty elements. +#eval checkCases "Connection lists: server" #[ + ("close, plus a second line with empty elements", "Connection: close\r\nconnectiON: fOo,, , BAR\r\n"), + ("cLOse inside a list", "Connection: a, b, cLOse, foo\r\n") + ] fun (label, fields) => + MachineTester.receiving label |>.feed s!"GET / HTTP/1.1\r\nHost: a\r\n{fields}\r\n" |>.step + |>.assertNoError |>.assertNotKeepAlive |>.run + +#eval checkCases "Connection lists: client" #[ + ("keep-alive, close on one line", "HTTP/1.1 200 OK\r\nConnection: keep-alive, close\r\nContent-Length: 0\r\n\r\n", false), + ("keep-alive, then close on a second line", "HTTP/1.1 200 OK\r\nConnection: keep-alive\r\nConnection: close\r\nContent-Length: 0\r\n\r\n", false), + ("HTTP/1.0", "HTTP/1.0 200 OK\r\nContent-Length: 0\r\n\r\n", false), + ("HTTP/1.0 with keep-ALIVE", "HTTP/1.0 200 OK\r\nConnection: keep-ALIVE\r\nContent-Length: 0\r\n\r\n", true), + ("HTTP/1.1", "HTTP/1.1 200 OK\r\nContent-Length: 0\r\n\r\n", true), + ("HTTP/1.1 with cloSE", "HTTP/1.1 200 OK\r\nConnection: cloSE\r\nContent-Length: 0\r\n\r\n", false) + ] fun (label, raw, reuse) => + let t := MachineTester.sending label |>.send minimalGetRequest |>.step |>.feed raw |>.step |>.assertNoError + (if reuse then t.assertKeepAlive else t.assertNotKeepAlive).run + +-- RFC 9112 §9.6: a server that sends `close` closes after that response. +#eval checkCases "HTTP/1.0 keep-alive, the handler sets Connection: close" #[ + ("one response, close and no keep-alive", do + let r ← serveRaw "GET /1 HTTP/1.0\x0d\nConnection: keep-alive\x0d\n\x0d\nGET /2 HTTP/1.0\x0d\nConnection: keep-alive\x0d\n\x0d\n" + (show TestHandler from fun _ => Response.ok |>.header! "Connection" "close" |>.text "x") (closeInput := true) + (Want.all [.responses 1, .contains "Connection: close\x0d\n", .absent "keep-alive"]).check r) + ] (·.2) + +/-! ## Connection options (RFC 9110 §7.6.1, §7.8) -/ + +#eval checkCases "Connection options: machine" #[ + ("§7.8: 426 keeps Connection: upgrade and appends close", do + -- RFC 9110 §7.6.1, §7.8: the handler's connection options are kept, with the machine's `close` + MachineTester.receiving "§7.8: 426 keeps Connection: upgrade and appends close" + |>.feed "GET / HTTP/1.1\r\nHost: example.com\r\nConnection: close\r\n\r\n" + |>.step |>.assertIsWaitingMessage + |>.send (upgrade "Upgrade") + |>.setKnownSize (.fixed 0) |>.userClosedBody |>.step + |>.assertOutputContains "Connection: upgrade, close\r\n" "expected the handler's upgrade option and close" + |>.assertOutputContains "Upgrade: TLS/1.2\r\n" "expected the Upgrade field" |>.run), + ("§7.8: keep-alive response keeps the handler's Connection: upgrade", do + MachineTester.receiving "§7.8: keep-alive response keeps the handler's Connection: upgrade" + |>.feed (mkGet "/") |>.step |>.assertKeepAlive + |>.send (upgrade "upgrade, keep-alive") + |>.setKnownSize (.fixed 0) |>.userClosedBody |>.step |>.assertKeepAlive + |>.assertOutputContains "Connection: upgrade\r\n" "expected only the upgrade option" |>.run), + ("§7.8: client keeps the caller's Connection: upgrade", do + -- RFC 9110 §7.8: a client that sends `Upgrade` also sends the `upgrade` connection option + MachineTester.sending "§7.8: client keeps the caller's Connection: upgrade" + |>.send { minimalGetRequest with + headers := minimalGetRequest.headers + |>.insert! "Connection" "Upgrade" |>.insert! "Upgrade" "websocket" } + |>.userClosedBody |>.step + |>.assertOutputContains "Connection: upgrade\r\n" "expected the caller's upgrade option" + |>.assertOutputContains "Upgrade: websocket\r\n" "expected the Upgrade field" |>.run), + ("§7.8: client appends close to the caller's connection options", do + MachineTester.sending "§7.8: client appends close to the caller's connection options" + |>.send { minimalGetRequest with + headers := minimalGetRequest.headers + |>.insert! "Connection" "upgrade, close" |>.insert! "Upgrade" "websocket" } + |>.userClosedBody |>.step |>.assertNotKeepAlive + |>.assertOutputContains "Connection: upgrade, close\r\n" "expected the upgrade option, then close" + |>.run) + ] (·.2) + +#eval checkCases "Connection options: async_http_connection_options.lean" #[ + ("for value in ['keep-alive, ', ', keep-alive', 'keep-alive,,'", + do + for value in ["keep-alive, ", ", keep-alive", "keep-alive,,", ""] do + check s!"Connection: {value.quote}" + (mkGet "/1" s!"Connection: {value}\x0d\n" ++ mkGetClose "/2") + uriHandler fun r => assertResponseCount r 2), + ("handler Connection: upgrade,", + do + check "handler Connection: upgrade," (mkGetClose "/") + (fun _ => Response.ok |>.header! "Connection" "upgrade," |>.text "ok") + fun r => assertContains r "Connection: upgrade, close") + ] (·.2) + +/-! ## Pipelining (RFC 9112 §9.3.2) -/ + +#eval checkCases "Pipelining: machine" #[ + ("§9.3: pipelining — two requests on one connection", do + -- §9.3: after completing first request, machine resets and parses second (pipelining) + let req1 := mkGet "/" + let req2 := mkGet "/second" + MachineTester.receiving "§9.3: pipelining — two requests on one connection" + |>.feed (req1 ++ req2) |>.step |>.assertHasEndHeaders |>.assertKeepAlive + |>.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody + |>.drainBody |>.step |>.assertHasNext + |>.step |>.assertHasEndHeaders |>.run), + ("§9.3: pipelining after CL:0 body — second request path correct", do + -- §9.3: pipelining after CL:0 body — second request parses correctly + let post1 := "POST /a HTTP/1.1\r\nHost: example.com\r\nContent-Length: 0\r\n\r\n" + let get2 := "GET /b HTTP/1.1\r\nHost: example.com\r\n\r\n" + MachineTester.receiving "§9.3: pipelining after CL:0 body — second request path correct" + |>.feed (post1 ++ get2) |>.step |>.assertHasEndHeaders + |>.drainBody |>.assertPulledBody .empty + |>.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody + |>.step |>.assertHasNext + |>.step |>.assertHasEndHeaders + |>.onEndHeaders (fun t head => + let path := toString head.uri.path + if path == "/b" then t + else t.addError s!"expected second request path /b, got {path}") + |>.run), + ("§9.3: resetForNextMessage preserves noMoreInput after pipeline exhausted", do + -- §9.3: resetForNextMessage must preserve the noMoreInput flag so the machine + -- halts after the pipeline is exhausted and the socket has closed + let req1 := mkGet "/first" + let req2 := mkGet "/second" + MachineTester.receiving "§9.3: resetForNextMessage preserves noMoreInput after pipeline exhausted" + |>.feed (req1 ++ req2) |>.noMoreInput + |>.step |>.assertHasEndHeaders + |>.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody + |>.drainBody |>.step |>.assertHasNext + |>.step |>.assertHasEndHeaders + |>.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody + |>.drainBody |>.step + |>.assertHasEvent (fun | .close => true | _ => false) + "expected .close after pipeline exhausted on closed socket" + |>.step |>.assertHalted |>.run), + ("RFC 9112 §9.3: HTTP/1.0 keep-alive pipelining — second request parsed", do + -- §19.7.1: HTTP/1.0 keep-alive allows a second request on the same connection + let http10req1 := "GET / HTTP/1.0\r\nConnection: keep-alive\r\n\r\n" + let http10req2 := "GET /second HTTP/1.0\r\n\r\n" + MachineTester.receiving "RFC 9112 §9.3: HTTP/1.0 keep-alive pipelining — second request parsed" + |>.feed (http10req1 ++ http10req2) |>.step |>.assertHasEndHeaders |>.assertKeepAlive + |>.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody + |>.drainBody |>.step |>.assertHasNext + |>.step |>.assertHasEndHeaders |>.run) + ] (·.2) + +#eval checkCases "Pipelining: async_http_connection_options.lean" #[ + ("Connection: keep-alive", + do + -- Control: `keep-alive` alone keeps an HTTP/1.0 connection open. + check "Connection: keep-alive" + "GET /1 HTTP/1.0\x0d\nConnection: keep-alive\x0d\n\x0d\nGET /2 HTTP/1.0\x0d\n\x0d\n" + uriHandler fun r => assertResponseCount r 2) + ] (·.2) + +#eval checkCases "Pipelining: async_http_keepalive.lean" #[ + ("two sequential keep-alive requests → 2 responses", + do + check "two sequential keep-alive requests → 2 responses" + (raw := + "GET /first HTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n" ++ + "GET /second HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") + (handler := fun req => Response.ok |>.text (toString req.line.uri)) + (expect := fun r => + assertResponseCount r 2 *> + assertContains r "/first" *> + assertContains r "/second")) + ] (·.2) + +/-! ## Pipelining after a body (RFC 9112 §6.3, §9.3.2) -/ + +#eval checkCases "Pipelining after a body: async_http_fuzz.lean" #[ + ("fuzz_complete_first_body_allows_pipeline", + runWithTimeout "fuzz_complete_first_body_allows_pipeline" 20000 do + fuzzCompleteFirstBodyAllowsPipeline 30 0x00777777) + ] (·.2) + +#eval checkCases "Pipelining after a body: async_http_hang_regressions.lean" #[ + ("10_pipeline_fixed_then_get", + runWithTimeout "10_pipeline_fixed_then_get" 2000 do + let raw := ("POST /one HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 5\x0d\n\x0d\nhello" ++ + "GET /two HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n").toUTF8 + let response ← sendRawTimed "10_pipeline_fixed_then_get/send" raw uriHandler + assertStatusCount "10_pipeline_fixed_then_get" response 2 + assertContains response "/one" + assertContains response "/two"), + ("11_pipeline_chunked_then_get", + runWithTimeout "11_pipeline_chunked_then_get" 2000 do + let raw := ("POST /chunk HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n" ++ + "GET /two HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n").toUTF8 + let response ← sendRawTimed "11_pipeline_chunked_then_get/send" raw uriHandler + assertStatusCount "11_pipeline_chunked_then_get" response 2 + assertContains response "/chunk" + assertContains response "/two"), + ("19_pipeline_large_unread_then_get", + runWithTimeout "19_pipeline_large_unread_then_get" 2000 do + let body := String.ofList (List.replicate 5000 'b') + let raw := (s!"POST /big HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 5000\x0d\n\x0d\n{body}" ++ + "GET /after HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n").toUTF8 + let response ← sendRawTimed "19_pipeline_large_unread_then_get/send" raw uriHandler + assertStatusCount "19_pipeline_large_unread_then_get" response 2 + assertContains response "/big" + assertContains response "/after"), + ("20_triple_pipeline_mixed", + runWithTimeout "20_triple_pipeline_mixed" 2000 do + let raw := ("POST /a HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 4\x0d\n\x0d\ndata" ++ + "POST /b HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\n\x0d\n3\x0d\nhey\x0d\n0\x0d\n\x0d\n" ++ + "GET /c HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n").toUTF8 + let response ← sendRawTimed "20_triple_pipeline_mixed/send" raw uriHandler + assertStatusCount "20_triple_pipeline_mixed" response 3 + assertContains response "/a" + assertContains response "/b" + assertContains response "/c") + ] (·.2) + +#eval checkCases "Pipelining after a body: async_http_keepalive.lean" #[ + ("pipelined requests after an exact Content-Length", + do + let (response, seen) ← runPipelined + ("POST /first HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 3\x0d\n\x0d\nabc" ++ + "GET /second HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") + + assertResponseCount response 2 + assertContains response "/first" + assertContains response "/second" + assertSeenCount seen 2), + ("bytes inside a declared body are never parsed as a request", + do + let (response1, seen1) ← runPipelined + ("POST /first HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 10\x0d\n\x0d\nabc" ++ + "GET /second HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") + + assertContains response1 "/first" + assertAbsent response1 "/second" + assertSeenCount seen1 1), + ("broken chunked body stops pipelining", + do + let (response2, seen2) ← runPipelined + ("POST /chunked-first HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\n\x0d\nF\x0d\nhel" ++ + "GET /second HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") + + assertAbsent response2 "/second" + assertContains response2 "HTTP/1.1 400" + assertSeenCount seen2 1), + ("pipelining after Content-Length: 0", + do + let (resp1, seen1) ← runPipelined + ("POST /empty HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 0\x0d\n\x0d\n" ++ + "GET /tail HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") + + assertResponseCount resp1 2 + assertContains resp1 "/empty" + assertContains resp1 "/tail" + assertSeenCount seen1 2), + ("pipelining after a complete chunked body", + do + let (resp2, seen2) ← runPipelined + ("POST /chunked HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n" ++ + "GET /tail HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") + + assertResponseCount resp2 2 + assertContains resp2 "/chunked" + assertContains resp2 "/tail" + assertSeenCount seen2 2) + ] (·.2) + +#eval checkCases "Pipelining after a body: server" #[ + ("extra bytes beyond CL become next pipelined request", + check "extra bytes beyond CL become next pipelined request" + (raw := + "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 5\x0d\n\x0d\nhello" ++ + "GET /second HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") + (handler := fun req => do + let body : String ← req.body.readAll + Response.ok |>.text s!"{toString req.line.uri}:{body}") + (expect := fun r => + assertResponseCount r 2 *> + assertContains r "/:hello" *> + assertContains r "/second:" *> + assertAbsent r "/second:hello")) + ] (·.2) + + +-- RFC 9112 §6.3: Content-Length ends the body; what follows is the next request line. +#eval checkCases "Bytes after a Content-Length body" #[ + ("CL 7 with abcdef LF ???", do + let r ← serveRaw "POST / HTTP/1.1\x0d\nHost: a\x0d\nContent-Length: 7\x0d\n\x0d\nabcdef\n???" echoHandler (closeInput := true) + let text := String.fromUTF8! r + ensure (text.startsWith "HTTP/1.1 200" && text.contains "\x0d\n\x0d\nabcdef\n" && text.endsWith r400 && + (text.splitOn "HTTP/1.1 ").length == 3) s!"expected 200 with abcdef LF, then 400:\n{text.quote}") + ] (·.2) + +/-! ## Errors end the connection (RFC 9112 §9.6) -/ + +#eval checkCases "Errors end the connection: async_http_h1_close_with_error.lean" #[ + ("show IO Unit from do", + show IO Unit from do + for (name, input) in [ + ("nothing after the request", getRequest), + ("pipelined request", getRequest ++ "GET /2 HTTP/1.1\r\nHost: a\r\n\r\n"), + ("stray CRLF", getRequest ++ "\r\n"), + ("unread body, then a pipelined request", + "POST / HTTP/1.1\r\nHost: a\r\nContent-Length: 3\r\n\r\nabc" ++ getRequest)] do + for status in [Status.serviceUnavailable, .requestTimeout] do + if (stepsToHalt ((streaming input).closeWithError status)).isNone then + throw <| IO.userError + s!"'{name}', {status.toCode}: the machine did not halt after closeWithError") + ] (·.2) + +#eval checkCases "Errors end the connection: async_http_h1_framing_mismatch.lean" #[ + ("pipelined request after the 500", + do + -- The 500 closes the connection, so a pipelined request gets no answer. + checkTimed "pipelined request after the 500" + (raw := getRequest ++ getRequest) + (handler := fun _ => Response.ok |>.header! "Content-Length" "1234" |>.text "") + (expect := fun r => do + let text := String.fromUTF8! r + unless (text.splitOn "HTTP/1.1 ").length == 2 do + throw <| IO.userError s!"expected exactly one response, got:\n{text.quote}")) + ] (·.2) + +#eval checkCases "Errors end the connection: async_http_hang_regressions.lean" #[ + ("12_malformed_closes_connection", + runWithTimeout "12_malformed_closes_connection" 2000 do + let raw := ("GET / HTTP/1.1\x0d\nHost: example.com\x0d\nBadHeader value\x0d\n\x0d\n" ++ + "GET /second HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n").toUTF8 + let response ← sendRawTimed "12_malformed_closes_connection/send" raw uriHandler + assertStatusPrefix "12_malformed_closes_connection" response "HTTP/1.1 400" + assertStatusCount "12_malformed_closes_connection" response 1) + ] (·.2) + +/-! ## Request count -/ + +#eval checkCases "Request count: async_http_fuzz_limits.lean" #[ + ("fuzz_max_messages_per_connection", + runWithTimeout "fuzz_max_messages_per_connection" 30000 do + fuzzMaxMessagesPerConnection 30 0x00123ABC) + ] (·.2) + +#eval checkCases "Request count: async_http_keepalive.lean" #[ + ("maxRequests: 2 caps third request", + do + check "maxRequests: 2 caps third request" + (raw := + "GET /0 HTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n" ++ + "GET /1 HTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n" ++ + "GET /2 HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") + (handler := fun req => Response.ok |>.text (toString req.line.uri)) + (config := { defaultConfig with maxRequests := 2, lingeringTimeout := 3000 }) + (expect := fun r => + assertResponseCount r 2 *> + assertContains r "/0" *> + assertContains r "/1" *> + assertAbsent r "/2")) + ] (·.2) + + +-- RFC 9112 §9.6: a server that will not reuse the connection says so. +#eval checkCases "enableKeepAlive := false" #[ + ("a 1.1 request gets Connection: close", checkHandler "GET / HTTP/1.1\x0d\nHost: a\x0d\n\x0d\n" okHandler + (.all [.status "HTTP/1.1 200", .contains "Connection: close\x0d\n"]) { testConfig with enableKeepAlive := false }) + ] (·.2)
diff --git a/tests/async/elab/async_http_h1_expect.lean b/tests/async/elab/async_http_h1_expect.lean new file mode 100644 index 0000000..14b0548 --- /dev/null +++ b/tests/async/elab/async_http_h1_expect.lean
@@ -0,0 +1,298 @@ +module + +import Std.Http.Test.Helpers +import Std.Http.Test.Machine + +/-! +# HTTP/1.1 `Expect: 100-continue` + +How a server answers `Expect: 100-continue`: on the machine (`canContinue`, interim and final +responses while the decision is pending) and through `serveConnection` with `Handler.onContinue`. +RFC 9110 §10.1.1, §15.2, §15.5.18. +-/ + +open Std Http +open Std.Http.Protocol.H1 +open Std.Http.Internal.Test + +private def mkPostHead (path : String) (bodyLen : Nat) (extra : String := "") : String := + rawRequest "POST" path (extra := s!"Content-Length: {bodyLen}\r\n{extra}") + +private structure RejectContinueHandler where + onRequestCalls : IO.Ref Nat + +private instance : Server.Handler RejectContinueHandler where + onRequest self _ := do + self.onRequestCalls.modify (· + 1) + Response.ok |>.text "request-ran" + onContinue _ _ := pure false + +private structure AcceptContinueHandler where + onRequestCalls : IO.Ref Nat + +private instance : Server.Handler AcceptContinueHandler where + onRequest self request := do + self.onRequestCalls.modify (· + 1) + let body : String ← request.body.readAll + Response.ok |>.text s!"accepted:{body}" + onContinue _ _ := pure true + +private def checkH {σ : Type} [Server.Handler σ] (name : String) (raw : String) (handler : σ) + (expect : ByteArray → IO Unit) (config : Std.Http.Config := defaultConfig) : IO Unit := do + try expect (← serveRaw raw handler config) + catch e => throw (IO.userError s!"[{name}] {e}") + +private def assertCallCount (ref : IO.Ref Nat) (expected : Nat) : IO Unit := do + let got ← ref.get + unless got == expected do + throw <| IO.userError s!"expected {expected} onRequest calls, got {got}" + +private def expectRequest : String := + "POST / HTTP/1.1\r\nHost: a\r\nExpect: 100-continue\r\nContent-Length: 5\r\n\r\n" + +/-- Steps `machine` until it halts. Returns its output, or `none` if it has not halted after 16 steps. -/ +private def outputToHalt (machine : Machine .receiving) : Option String := + (runToHalt machine).map (·.1) + +/-! ## Machine (RFC 9110 §10.1.1, §15.2) -/ + +#eval checkCases "Machine: machine" #[ + ("§10.1.1: Expect:100-continue accepted → body readable", do + -- accepted: body becomes readable after canContinue .continue + let body := "hello".toUTF8 + MachineTester.receiving "§10.1.1: Expect:100-continue accepted → body readable" + |>.feed (mkPostHead "/upload" body.size "Expect: 100-continue\r\n") + |>.step |>.assertHasEndHeaders |>.assertHasContinue + |>.canContinue .«continue» + |>.feedBytes body |>.step |>.assertCanPullBodyNow + |>.drainBody |>.assertPulledBody body |>.run), + ("§15.5.18: Expect:100-continue rejected → reader closed", do + -- rejected: reader closed, body not delivered + MachineTester.receiving "§15.5.18: Expect:100-continue rejected → reader closed" + |>.feed (mkPostHead "/upload" 5 "Expect: 100-continue\r\n") + |>.step |>.assertHasContinue + |>.canContinue .expectationFailed + |>.assertReaderClosed + |>.assert (fun m => !m.canPullBody) "body must not be pullable after rejection" |>.run), + ("§10.1.1: Expect:100-continue + Content-Length:0 → empty body after acceptance", do + -- CL:0 + Expect:100-continue → empty body after acceptance + MachineTester.receiving "§10.1.1: Expect:100-continue + Content-Length:0 → empty body after acceptance" + |>.feed "POST / HTTP/1.1\r\nHost: example.com\r\nContent-Length: 0\r\nExpect: 100-continue\r\n\r\n" + |>.step |>.assertHasEndHeaders |>.assertHasContinue + |>.canContinue .«continue» + |>.pullBody |>.assertPulledBody .empty |>.assertLastChunkFinal |>.run), + ("§10.1.1, §15.5.18: final response sent while the reader awaits canContinue → .close", do + -- §15.5.14: writer completing a non-1xx response while reader is in .continue state + -- must force-close the reader (body will never arrive after rejection) + MachineTester.receiving "§10.1.1, §15.5.18: final response sent while the reader awaits canContinue → .close" + |>.feed (mkPostHead "/upload" 5 "Expect: 100-continue\r\n") + |>.step |>.assertHasContinue + |>.send { status := .expectationFailed } |>.setKnownSize (.fixed 0) |>.userClosedBody + |>.step + |>.assertHasEvent (fun | .close => true | _ => false) + "expected .close: writer completed after rejecting Expect: 100-continue, body will never arrive" + |>.run), + ("§10.1.1: 1xx interim response while reader awaits canContinue → writer stays open", do + -- §15.2: 1xx responses are valid while awaiting canContinue; writer must remain open + MachineTester.receiving "§10.1.1: 1xx interim response while reader awaits canContinue → writer stays open" + |>.feed (mkPostHead "/upload" 5 "Expect: 100-continue\r\n") + |>.step |>.assertHasContinue + |>.send { status := .processing } |>.step + |>.assertIsWaitingMessage |>.run), + ("§15.5: a 417 from canContinue explains itself", do + MachineTester.receiving "§15.5: a 417 from canContinue explains itself" + |>.feed (mkPostHead "/" 5 "Expect: 100-continue\r\n") |>.step |>.assertHasContinue + |>.canContinue .expectationFailed |>.step + |>.assertOutputStartsWith "HTTP/1.1 417 Expectation Failed\r\n" "expected 417" + |>.assertOutputContains "Content-Length: 19\r\n\r\nExpectation Failed\n" "expected an explanation" + |>.assertNotKeepAlive |>.run), + ("§15.5: canContinue after a final response leaves that response intact", do + -- A final response sent before the rejection keeps its length and body; the rejection only stops + -- the request body and the connection + MachineTester.receiving "§15.5: canContinue after a final response leaves that response intact" + |>.feed (mkPostHead "/" 5 "Expect: 100-continue\r\n") |>.step |>.assertHasContinue + |>.setKnownSize (.fixed 5) |>.send { status := .ok } |>.sendBytes "hello".toUTF8 |>.userClosedBody + |>.canContinue .expectationFailed |>.step |>.step + |>.assertOutputStartsWith "HTTP/1.1 200 OK\r\nConnection: close\r\nContent-Length: 5\r\n\r\nhello" + "expected the 200 with its own length and body" + |>.assertOutputNotContains "Expectation Failed" "no 417 content after a final response" + |>.assertNoError |>.assertNotKeepAlive |>.run) + ] (·.2) + +#eval checkCases "Machine: async_http_h1_expect_final_response.lean" #[ + ("A `canContinue` after the final response writes nothing more.", + show IO Unit from do + let machine := (({ config := {} } : Machine .receiving).feed expectRequest.toUTF8).step.1 + let answered := machine.setKnownSize (.fixed 2) |>.send { status := .ok } + |>.sendData #[Chunk.ofByteArray "ok".toUTF8] |>.userClosedBody + let some out := outputToHalt answered + | throw <| IO.userError "the machine did not halt after its final response" + unless out == "HTTP/1.1 200 OK\r\nContent-Length: 2\r\n\r\nok" do + throw <| IO.userError s!"unexpected output {out.quote}" + -- A `canContinue` after the final response writes nothing more. + let some out := outputToHalt (answered.step.1.canContinue .«continue») + | throw <| IO.userError "the machine did not halt after a late canContinue" + unless out.isEmpty do + throw <| IO.userError s!"a late canContinue wrote {out.quote}") + ] (·.2) + + +-- RFC 9110 §10.1.1: a server that answers before reading the body SHOULD close the connection. +#eval checkCases "A final response while the 100-continue decision is pending" #[ + ("its head says Connection: close", MachineTester.receiving "final response before canContinue" + |>.feed (mkPostHead "/upload" 5 "Expect: 100-continue\r\n") |>.step |>.assertHasContinue + |>.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody |>.step |>.step + |>.assertOutputStartsWith "HTTP/1.1 200 OK\r\n" "expected the 200" + |>.assertOutputContains "Connection: close\r\n" "expected Connection: close" |>.run) + ] (·.2) + +-- RFC 9110 §10.1.1: a server MUST ignore `Expect: 100-continue` in an HTTP/1.0 request. +#eval checkCases "HTTP/1.0 with Expect: 100-continue: machine" #[ + ("no continue event, the body is readable", MachineTester.receiving "HTTP/1.0 Expect" + |>.feed "POST / HTTP/1.0\r\nExpect: 100-continue\r\nContent-Length: 5\r\n\r\nhello" |>.step + |>.assertNoError |>.assertHasEndHeaders |>.assertNoEvent (· matches .«continue») "no continue event for HTTP/1.0" + |>.drainBody |>.assertPulledBody "hello".toUTF8 |>.run) + ] (·.2) + +/-! ## Server (RFC 9110 §10.1.1, §15.5.18) -/ + +#eval checkCases "Server: async_http_expect.lean" #[ + ("rejected Expect → 417, handler not called", + do + let calls ← IO.mkRef 0 + let handler : RejectContinueHandler := { onRequestCalls := calls } + checkH "rejected Expect → 417, handler not called" + (raw := "POST /upload HTTP/1.1\x0d\nHost: example.com\x0d\nExpect: 100-continue\x0d\nContent-Length: 5\x0d\nConnection: close\x0d\n\x0d\nhello") + (handler := handler) + (expect := fun r => + assertContains r "HTTP/1.1 417 Expectation Failed" *> + assertAbsent r "100 Continue" *> + assertAbsent r "request-ran" *> + assertResponseCount r 1) + + assertCallCount calls 0), + ("rejected Expect closes exchange, blocks pipelined second request", + do + let calls ← IO.mkRef 0 + let handler : RejectContinueHandler := { onRequestCalls := calls } + checkH "rejected Expect closes exchange, blocks pipelined second request" + (raw := + "POST /first HTTP/1.1\x0d\nHost: example.com\x0d\nExpect: 100-continue\x0d\nContent-Length: 5\x0d\n\x0d\nhello" ++ + "GET /second HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") + (handler := handler) + (expect := fun r => + assertContains r "HTTP/1.1 417 Expectation Failed" *> + assertResponseCount r 1) + + assertCallCount calls 0), + ("accepted Expect → 100 Continue then 200", + do + let calls ← IO.mkRef 0 + let handler : AcceptContinueHandler := { onRequestCalls := calls } + checkH "accepted Expect → 100 Continue then 200" + (raw := "POST /ok HTTP/1.1\x0d\nHost: example.com\x0d\nExpect: 100-continue\x0d\nContent-Length: 5\x0d\nConnection: close\x0d\n\x0d\nhello") + (handler := handler) + (expect := fun r => + assertContains r "HTTP/1.1 100 Continue" *> + assertContains r "HTTP/1.1 200 OK" *> + assertContains r "accepted:hello" *> + assertResponseCount r 2) -- one interim + one final + + assertCallCount calls 1), + ("non-100 Expect token → normal request, no interim", + do + let rejectCalls ← IO.mkRef 0 + let rejectHandler : RejectContinueHandler := { onRequestCalls := rejectCalls } + checkH "non-100 Expect token → normal request, no interim" + (raw := "POST /odd HTTP/1.1\x0d\nHost: example.com\x0d\nExpect: something-else\x0d\nContent-Length: 5\x0d\nConnection: close\x0d\n\x0d\nhello") + (handler := rejectHandler) + (expect := fun r => + assertContains r "HTTP/1.1 200 OK" *> + assertContains r "request-ran" *> + assertAbsent r "100 Continue") + + assertCallCount rejectCalls 1), + ("Expect: 100-CONTINUE (case-insensitive) → 100 then 200", + do + let acceptCalls ← IO.mkRef 0 + let acceptHandler : AcceptContinueHandler := { onRequestCalls := acceptCalls } + checkH "Expect: 100-CONTINUE (case-insensitive) → 100 then 200" + (raw := "POST /case HTTP/1.1\x0d\nHost: example.com\x0d\nExpect: 100-CONTINUE\x0d\nContent-Length: 5\x0d\nConnection: close\x0d\n\x0d\nhello") + (handler := acceptHandler) + (expect := fun r => + assertContains r "HTTP/1.1 100 Continue" *> + assertContains r "HTTP/1.1 200 OK") + + assertCallCount acceptCalls 1), + ("no Expect header → no 100 Continue emitted", + do + let noCalls ← IO.mkRef 0 + let noExpectHandler : AcceptContinueHandler := { onRequestCalls := noCalls } + checkH "no Expect header → no 100 Continue emitted" + (raw := "POST /no-expect HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 5\x0d\nConnection: close\x0d\n\x0d\nhello") + (handler := noExpectHandler) + (expect := fun r => + assertContains r "HTTP/1.1 200 OK" *> + assertContains r "accepted:hello" *> + assertAbsent r "100 Continue" *> + assertResponseCount r 1) + + assertCallCount noCalls 1) + ] (·.2) + + +private structure CountContinue where + continues : IO.Ref Nat + +private instance : Server.Handler CountContinue where + onRequest _ request := do + let body : String ← request.body.readAll + Response.ok |>.text s!"accepted:{body}" + onContinue self _ := do + self.continues.modify (· + 1) + pure true + +#eval checkCases "HTTP/1.0 with Expect: 100-continue: server" #[ + ("no 100, onContinue not called, body read", do + let continues ← IO.mkRef 0 + let r ← serveRaw "POST / HTTP/1.0\x0d\nExpect: 100-continue\x0d\nContent-Length: 5\x0d\n\x0d\nhello" ({ continues } : CountContinue) + (closeInput := true) + (Want.all [.status "HTTP/1.1 200", .absent "100 Continue", .contains "accepted:hello"]).check r + ensure ((← continues.get) == 0) s!"onContinue was called {← continues.get} times") + ] (·.2) + +#eval checkCases "Expect: 100-continue without a Content-Length body" #[ + ("Content-Length: 0", "POST / HTTP/1.1\x0d\nHost: a\x0d\nExpect: 100-continue\x0d\nContent-Length: 0\x0d\nConnection: close\x0d\n\x0d\n", + Want.all [.contains "HTTP/1.1 200 OK", .contains "accepted:"]), + ("no framing", "GET / HTTP/1.1\x0d\nHost: a\x0d\nExpect: 100-continue\x0d\nConnection: close\x0d\n\x0d\n", + .all [.contains "HTTP/1.1 200 OK", .contains "accepted:"]), + ("chunked", "POST / HTTP/1.1\x0d\nHost: a\x0d\nExpect: 100-continue\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n", + .all [.status "HTTP/1.1 100 Continue", .contains "HTTP/1.1 200 OK", .contains "accepted:hello"]) + ] fun (_, raw, want) => do + let calls ← IO.mkRef 0 + want.check (← serveRaw raw ({ onRequestCalls := calls } : AcceptContinueHandler) (closeInput := true)) + +-- RFC 9110 §10.1.1: a client may send the body without waiting; a 100 only ever precedes its own final response. +#eval checkCases "Two pipelined Expect requests with their bodies" #[ + ("both served in order, no stray 100", do + let calls ← IO.mkRef 0 + let r ← serveRaw ("POST /1 HTTP/1.1\x0d\nHost: a\x0d\nExpect: 100-continue\x0d\nContent-Length: 5\x0d\n\x0d\nhello" ++ + "POST /2 HTTP/1.1\x0d\nHost: a\x0d\nExpect: 100-continue\x0d\nContent-Length: 5\x0d\nConnection: close\x0d\n\x0d\nworld") + ({ onRequestCalls := calls } : AcceptContinueHandler) (closeInput := true) + let text := String.fromUTF8! r + let codes := (text.splitOn "HTTP/1.1 ").drop 1 |>.map fun c => String.ofList (c.toList.take 3) + ensure ((codes.filter (· == "200")).length == 2) s!"statuses {codes}" + ensure (codes.getLast? == some "200" && !(codes.zip (codes.drop 1)).any (· == ("100", "100"))) s!"stray 100: {codes}" + let some i := (text.splitOn "accepted:hello").head?.map (·.length) | throw <| IO.userError "no first body" + let some j := (text.splitOn "accepted:world").head?.map (·.length) | throw <| IO.userError "no second body" + ensure (i < j && text.contains "accepted:hello" && text.contains "accepted:world") s!"out of order:\n{text.quote}") + ] (·.2) + +private def expectField : TestHandler := fun req => + Response.ok |>.text ((req.line.headers.get? (.ofString! "Expect")).map (·.value) |>.getD "<none>") + +#eval checkCases "Expect accepted, the handler does not read the body" #[ + ("no hang, and the handler sees Expect", checkHandler + "POST / HTTP/1.1\x0d\nHost: a\x0d\nExpect: 100-continue\x0d\nContent-Length: 5\x0d\n\x0d\nhello" expectField + (.all [.contains "HTTP/1.1 200 OK", .contains "\x0d\n\x0d\n100-continue"]) (closeInput := true)) + ] (·.2)
diff --git a/tests/async/elab/async_http_h1_expect_final_response.lean b/tests/async/elab/async_http_h1_expect_final_response.lean deleted file mode 100644 index 315e61e..0000000 --- a/tests/async/elab/async_http_h1_expect_final_response.lean +++ /dev/null
@@ -1,38 +0,0 @@ -import Std.Http - -open Std Http -open Std.Http.Protocol.H1 - -/-! -Tests a server machine whose final response is written while it still waits for the -`Expect: 100-continue` decision. The request body will never be read, so the machine closes the -connection and halts; a later `canContinue` writes nothing after the final response. --/ - -def request : String := - "POST / HTTP/1.1\r\nHost: a\r\nExpect: 100-continue\r\nContent-Length: 5\r\n\r\n" - -/-- Steps `machine` until it halts. Returns its output, or `none` if it has not halted after 16 steps. -/ -def runToHalt (machine : Machine .receiving) : Option String := Id.run do - let mut machine := machine - let mut out := "" - for _ in [0:16] do - let (next, step) := machine.step - machine := next - out := out ++ String.fromUTF8! step.output.toByteArray - if machine.halted then return some out - return none - -#eval show IO Unit from do - let machine := (({ config := {} } : Machine .receiving).feed request.toUTF8).step.1 - let answered := machine.setKnownSize (.fixed 2) |>.send { status := .ok } - |>.sendData #[Chunk.ofByteArray "ok".toUTF8] |>.userClosedBody - let some out := runToHalt answered - | throw <| IO.userError "the machine did not halt after its final response" - unless out == "HTTP/1.1 200 OK\r\nContent-Length: 2\r\n\r\nok" do - throw <| IO.userError s!"unexpected output {out.quote}" - -- A `canContinue` after the final response writes nothing more. - let some out := runToHalt (answered.step.1.canContinue .«continue») - | throw <| IO.userError "the machine did not halt after a late canContinue" - unless out.isEmpty do - throw <| IO.userError s!"a late canContinue wrote {out.quote}"
diff --git a/tests/async/elab/async_http_h1_framing_mismatch.lean b/tests/async/elab/async_http_h1_framing_mismatch.lean deleted file mode 100644 index 7883bb0..0000000 --- a/tests/async/elab/async_http_h1_framing_mismatch.lean +++ /dev/null
@@ -1,195 +0,0 @@ -import Std.Http -import Std.Http.Test.Helpers - -open Std.Async -open Std Http Internal Test -open Std.Http.Protocol.H1 - -/-! -Tests a message head whose framing fields contradict the body length set for it, such as a handler -response with `Content-Length: 3` and an empty body. The server answers `500 Internal Server Error` -with a short `text/plain` explanation and closes the connection instead of spinning in its -connection loop, and a client ends the -exchange. A `Content-Length` gives the length of a streamed body, which has none of its own. A -response that carries no body (to `HEAD`, 204, 304) cannot contradict it: a HEAD response -advertises the handler's `Content-Length`. --/ - -/-- -Steps `machine` until it halts. Returns everything it wrote and every event it emitted, or `none` -if it has not halted after 16 steps. --/ -def runToHalt (machine : Machine dir) : Option (String × Array (Event dir)) := Id.run do - let mut machine := machine - let mut out := "" - let mut events := #[] - for _ in [0:16] do - let (next, step) := machine.step - machine := next - out := out ++ String.fromUTF8! step.output.toByteArray - events := events ++ step.events - if machine.halted then return some (out, events) - return none - -/-- A server machine that has read `request`. -/ -def server (request : String) : Machine .receiving := - (({ config := {} } : Machine .receiving).feed request.toUTF8).step.1 - -def headers (fields : List (Header.Name × String)) : Headers := - fields.foldl (fun hs (name, value) => hs.insert name (Header.Value.ofString! value)) .empty - -def get : String := "GET / HTTP/1.1\r\nHost: a\r\n\r\n" - -def abc : Array Chunk := #[Chunk.ofByteArray "abc".toUTF8] - -/-- Runs `machine` to a halt and checks that it answered 500 with its explanation, not the body. -/ -def expect500 (name : String) (machine : Machine .receiving) : IO Unit := do - let some (out, events) := runToHalt (machine.sendData abc |>.userClosedBody) - | throw <| IO.userError s!"[{name}] the server never halted" - unless out == "HTTP/1.1 500 Internal Server Error\r\nContent-Type: text/plain; charset=utf-8\r\n" ++ - "Connection: close\r\nContent-Length: 22\r\n\r\nInternal Server Error\n" do - throw <| IO.userError s!"[{name}] expected a 500 with its explanation only, got:\n{out.quote}" - unless events.any (· matches .failed (.other _)) do - throw <| IO.userError s!"[{name}] no framing failure reported: {repr events}" - -/-- Runs `machine` to a halt and returns its output, failing on a reported failure. -/ -def expectOk (name : String) (machine : Machine .receiving) : IO String := do - let some (out, events) := runToHalt machine - | throw <| IO.userError s!"[{name}] the server never halted" - if events.any (· matches .failed _) then - throw <| IO.userError s!"[{name}] unexpected failure: {repr events}\n{out.quote}" - return out - -#eval runGroup "server machine: contradictory framing" do - -- An empty body with a handler's `Content-Length`. - expect500 "empty body, Content-Length: 1234" <| server get - |>.setKnownSize (.fixed 0) - |>.send { status := .ok, headers := headers [(Header.Name.contentLength, "1234")] } - - -- Framing fields that describe no length. - let both := headers [(Header.Name.contentLength, "3"), (Header.Name.transferEncoding, "chunked")] - expect500 "Content-Length with Transfer-Encoding" <| server get - |>.send { status := .ok, headers := both } - - -- Control: matching framing writes the response. - let out ← expectOk "matching Content-Length" <| server - "GET / HTTP/1.1\r\nHost: a\r\nConnection: close\r\n\r\n" - |>.setKnownSize (.fixed 3) - |>.send { status := .ok, headers := headers [(Header.Name.contentLength, "3")] } - |>.sendData abc |>.userClosedBody - unless out.startsWith "HTTP/1.1 200 OK\r\n" && out.endsWith "\r\n\r\nabc" do - throw <| IO.userError s!"matching Content-Length: got\n{out.quote}" - -#eval runGroup "server machine: Content-Length gives a streamed body its length" do - let close := "GET / HTTP/1.1\r\nHost: a\r\nConnection: close\r\n\r\n" - -- `Body.stream` sets `chunked` before its producer runs, and a producer may set the length - -- itself before the server reads it: the head's length wins over `chunked` and matches the other. - for size in [Body.Length.chunked, .fixed 3] do - let out ← expectOk s!"{repr size}, Content-Length: 3" <| server close - |>.setKnownSize size - |>.send { status := .ok, headers := headers [(Header.Name.contentLength, "3")] } - |>.sendData abc |>.userClosedBody - unless out.startsWith "HTTP/1.1 200 OK\r\n" && out.contains "Content-Length: 3\r\n" && - !out.contains "Transfer-Encoding" && out.endsWith "\r\n\r\nabc" do - throw <| IO.userError s!"{repr size}, Content-Length: 3: got\n{out.quote}" - - -- A stream longer than its `Content-Length` closes the connection without writing its bytes. - let some (out, events) := runToHalt (server close - |>.setKnownSize .chunked - |>.send { status := .ok, headers := headers [(Header.Name.contentLength, "3")] } - |>.sendData #[Chunk.ofByteArray "abcd".toUTF8] |>.userClosedBody) - | throw <| IO.userError "overlong stream: the server never halted" - unless out.endsWith "Content-Length: 3\r\n\r\n" && events.any (· matches .close) do - throw <| IO.userError s!"overlong stream: got {repr events}\n{out.quote}" - -#eval runGroup "server machine: bodyless responses keep the handler's length" do - let head := "HEAD / HTTP/1.1\r\nHost: a\r\nConnection: close\r\n\r\n" - for size in [Body.Length.chunked, .fixed 0] do - let out ← expectOk s!"HEAD, {repr size}" <| server head - |>.setKnownSize size - |>.send { status := .ok, headers := headers [(Header.Name.contentLength, "1234")] } - unless out.startsWith "HTTP/1.1 200 OK\r\n" && out.contains "Content-Length: 1234\r\n" && - !out.contains "Transfer-Encoding" do - throw <| IO.userError s!"HEAD, {repr size}: expected Content-Length: 1234, got\n{out.quote}" - - let close := "GET / HTTP/1.1\r\nHost: a\r\nConnection: close\r\n\r\n" - for status in [Status.noContent, .notModified] do - let out ← expectOk s!"{status}" <| server close - |>.setKnownSize (.fixed 0) - |>.send { status, headers := headers [(Header.Name.contentLength, "9")] } - unless out.startsWith s!"HTTP/1.1 {status.toCode} " && !out.contains "Content-Length" do - throw <| IO.userError s!"{status}: expected no framing fields, got\n{out.quote}" - -#eval show IO Unit from do - -- Client side: a request declaring 10 bytes for a 3-byte body ends the exchange unwritten. - let request : Request.Head := - (Request.new |>.method .put |>.uri! "/upload" |>.header! "Host" "example.com" - |>.header! "Content-Length" "10").line - let machine := ({ config := {} } : Machine .sending) - |>.setKnownSize (.fixed 3) - |>.send request - |>.sendData abc |>.userClosedBody - let some (out, events) := runToHalt machine - | throw <| IO.userError "the client never halted" - unless out.isEmpty && events.any (· matches .failed (.other _)) do - throw <| IO.userError s!"client: expected a failure and no output, got {repr events}\n{out.quote}" - - -- A streamed upload takes its length from the request's `Content-Length`. - let request : Request.Head := - (Request.new |>.method .put |>.uri! "/upload" |>.header! "Host" "example.com" - |>.header! "Content-Length" "3").line - let machine := ({ config := {} } : Machine .sending) - |>.setKnownSize .chunked - |>.send request - |>.sendData abc |>.userClosedBody - let mut machine := machine - let mut out := "" - for _ in [0:8] do - let (next, step) := machine.step - machine := next - out := out ++ String.fromUTF8! step.output.toByteArray - unless out.contains "Content-Length: 3\r\n" && !out.contains "Transfer-Encoding" && - out.endsWith "\r\n\r\nabc" && machine.error.isNone do - throw <| IO.userError s!"streamed upload: got {repr machine.error}\n{out.quote}" - -#eval runGroup "server: handler framing contradicts its body" do - checkTimed "streamed body with Content-Length: 3" - (raw := mkGetClose) - (handler := fun _ => Response.ok |>.header! "Content-Length" "3" - |>.stream fun s => s.send (Chunk.ofByteArray "abc".toUTF8)) - (expect := fun r => do - assertStatus r "HTTP/1.1 200 OK" - assertContains r "Content-Length: 3\r\n" - assertAbsent r "Transfer-Encoding" - assertContains r "\r\n\r\nabc") - - checkTimed "streamed body longer than its Content-Length: 3" - (raw := get) - (handler := fun _ => Response.ok |>.header! "Content-Length" "3" - |>.stream fun s => s.send (Chunk.ofByteArray "abcd".toUTF8)) - (expect := fun r => do - assertStatus r "HTTP/1.1 200 OK" - assertAbsent r "abc") - - checkTimed "empty body with Content-Length: 1234" - (raw := get) - (handler := fun _ => Response.ok |>.header! "Content-Length" "1234" |>.text "") - (expect := (assertStatus · "HTTP/1.1 500 Internal Server Error")) - - -- The 500 closes the connection, so a pipelined request gets no answer. - checkTimed "pipelined request after the 500" - (raw := get ++ get) - (handler := fun _ => Response.ok |>.header! "Content-Length" "1234" |>.text "") - (expect := fun r => do - let text := String.fromUTF8! r - unless (text.splitOn "HTTP/1.1 ").length == 2 do - throw <| IO.userError s!"expected exactly one response, got:\n{text.quote}") - - checkTimed "HEAD with a streamed body and Content-Length: 1234" - (raw := "HEAD / HTTP/1.1\r\nHost: a\r\nConnection: close\r\n\r\n") - (handler := fun _ => Response.ok |>.header! "Content-Length" "1234" - |>.stream fun s => s.send (Chunk.ofByteArray "abc".toUTF8)) - (expect := fun r => do - assertStatus r "HTTP/1.1 200 OK" - assertContains r "Content-Length: 1234\r\n" - assertAbsent r "abc")
diff --git a/tests/async/elab/async_http_h1_incremental.lean b/tests/async/elab/async_http_h1_incremental.lean deleted file mode 100644 index 3bfa068..0000000 --- a/tests/async/elab/async_http_h1_incremental.lean +++ /dev/null
@@ -1,396 +0,0 @@ -import Std.Http - -open Std Http -open Std.Http.Protocol.H1 - -private def ensure (name : String) (cond : Bool) (msg : String) : IO Unit := do - unless cond do - throw <| IO.userError s!"Test '{name}' failed:\n{msg}" - -private def hasFailedEvent (events : Array (Event .receiving)) : Bool := - events.any fun - | .failed _ => true - | _ => false - -private def hasNeedMoreDataEvent (events : Array (Event .receiving)) : Bool := - events.any fun - | .needMoreData _ => true - | _ => false - -private def hasEndHeadersEvent (events : Array (Event .receiving)) : Bool := - events.any fun - | .endHeaders _ => true - | _ => false - -private def hasCloseBodyEvent (events : Array (Event .receiving)) : Bool := - events.any fun - | .closeBody => true - | _ => false - -private def hasContinueEvent (events : Array (Event .receiving)) : Bool := - events.any fun - | .«continue» => true - | _ => false - -private def countNeedAnswerEvents (events : Array (Event .receiving)) : Nat := - events.foldl (init := 0) fun n e => - match e with - | .needAnswer => n + 1 - | _ => n - -private def countFailedEvents (events : Array (Event .receiving)) : Nat := - events.foldl (init := 0) fun n e => - match e with - | .failed _ => n + 1 - | _ => n - -private def pulledBodyBytes (chunks : Array PulledChunk) : ByteArray := - chunks.foldl (fun acc c => acc ++ c.chunk.data) .empty - -private def splitEveryByte (data : ByteArray) : Array ByteArray := Id.run do - let mut parts : Array ByteArray := #[] - for i in [0:data.size] do - parts := parts.push (data.extract i (i + 1)) - parts - -private def nextSeed (seed : Nat) : Nat := - (1664525 * seed + 1013904223) % 4294967296 - -private def randBelow (seed : Nat) (maxExclusive : Nat) : Nat × Nat := - let seed' := nextSeed seed - if maxExclusive = 0 then - (0, seed') - else - (seed' % maxExclusive, seed') - -private def randIn (seed : Nat) (low : Nat) (high : Nat) : Nat × Nat := - if high < low then - (low, seed) - else - let (n, seed') := randBelow seed (high - low + 1) - (low + n, seed') - -private def randomAsciiBytes (seed : Nat) (len : Nat) : ByteArray × Nat := Id.run do - let mut s := seed - let mut out := ByteArray.empty - for _ in [0:len] do - let (r, s') := randBelow s 38 - s := s' - let code := - if r < 26 then 97 + r - else if r < 36 then 48 + (r - 26) - else if r = 36 then 45 - else 95 - out := out.push (UInt8.ofNat code) - (out, s) - -private def randomSplit (seed : Nat) (data : ByteArray) (maxPart : Nat := 13) : Array ByteArray × Nat := Id.run do - let mut s := seed - let mut out : Array ByteArray := #[] - let mut i := 0 - while i < data.size do - let remaining := data.size - i - let upper := Nat.min maxPart remaining - let (partLen, s') := randIn s 1 upper - s := s' - out := out.push (data.extract i (i + partLen)) - i := i + partLen - (out, s) - -private def randomChunkedPayload (seed : Nat) (body : ByteArray) : ByteArray × Nat := Id.run do - let mut s := seed - let mut out := ByteArray.empty - let mut i := 0 - while i < body.size do - let remaining := body.size - i - let upper := Nat.min 9 remaining - let (chunkLen, s') := randIn s 1 upper - s := s' - out := out ++ s!"{chunkLen}\r\n".toUTF8 - out := out ++ body.extract i (i + chunkLen) - out := out ++ "\r\n".toUTF8 - i := i + chunkLen - out := out ++ "0\r\n\r\n".toUTF8 - (out, s) - -private def mkContentLengthRequest (path : String) (body : ByteArray) : ByteArray := - s!"POST {path} HTTP/1.1\r\nHost: example.com\r\nContent-Length: {body.size}\r\nConnection: keep-alive\r\n\r\n".toUTF8 ++ body - -private def mkChunkedRequest (path : String) (chunkedPayload : ByteArray) : ByteArray := - s!"POST {path} HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: chunked\r\nConnection: keep-alive\r\n\r\n".toUTF8 ++ chunkedPayload - -private def mkChunkedHead (path : String) : ByteArray := - s!"POST {path} HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: chunked\r\nConnection: keep-alive\r\n\r\n".toUTF8 - -private structure IncrementalTrace where - machine : Machine .receiving - events : Array (Event .receiving) := #[] - output : ByteArray := .empty - pulled : Array PulledChunk := #[] - -private def runIncrementalReceiving - (parts : Array ByteArray) - (config : Protocol.H1.Config := {}) : IncrementalTrace := Id.run do - let mut machine : Machine .receiving := { config := config } - let mut events : Array (Event .receiving) := #[] - let mut output := ByteArray.empty - let mut pulled : Array PulledChunk := #[] - - for part in parts do - machine := machine.feed part - let (machine', step) := machine.step - machine := machine' - events := events ++ step.events - output := output ++ step.output.toByteArray - - -- Pull at most one body chunk per input part to simulate streaming callers. - -- Guard on buffered bytes to avoid calling into body parsing on an empty buffer. - if machine.canPullBodyNow && machine.reader.input.remainingBytes > 0 then - let (machine', pulledNow?) := machine.pullBody - let (machine', pullEvents) := machine'.takeEvents - machine := machine' - if let some pulledNow := pulledNow? then - pulled := pulled.push pulledNow - events := events ++ pullEvents - else - pure () - - let (machine', finalStep) := machine.step - machine := machine' - events := events ++ finalStep.events - output := output ++ finalStep.output.toByteArray - - -- After all input has arrived, drain the remaining ready body chunks. - let mut fuel := 4096 - while fuel > 0 && machine.canPullBodyNow && machine.reader.input.remainingBytes > 0 do - fuel := fuel - 1 - let (machine', pulledNow?) := machine.pullBody - let (machine', pullEvents) := machine'.takeEvents - machine := machine' - events := events ++ pullEvents - match pulledNow? with - | some pulledNow => - pulled := pulled.push pulledNow - | none => - break - - return { machine, events, output, pulled } - -private def assertIncrementalSuccess - (name : String) - (trace : IncrementalTrace) - (expectedBody : ByteArray) - (expectNeedMoreData : Bool := true) : IO Unit := do - ensure name (!trace.machine.failed) s!"machine ended failed with events:\n{repr trace.events}" - ensure name (!hasFailedEvent trace.events) s!"unexpected failure events:\n{repr trace.events}" - ensure name (hasEndHeadersEvent trace.events) s!"missing endHeaders event:\n{repr trace.events}" - - if expectNeedMoreData then - ensure name (hasNeedMoreDataEvent trace.events) s!"expected at least one needMoreData event:\n{repr trace.events}" - else - pure () - - let got := pulledBodyBytes trace.pulled - ensure name (got == expectedBody) - s!"body mismatch:\nexpected={String.fromUTF8! expectedBody |>.quote}\nactual={String.fromUTF8! got |>.quote}" - - let expectsPullSignals := expectedBody.size > 0 || trace.pulled.size > 0 - if expectsPullSignals then - ensure name (hasCloseBodyEvent trace.events) s!"missing closeBody event:\n{repr trace.events}" - ensure name (trace.pulled.any (·.final)) "expected at least one final pulled chunk" - ensure name ((trace.pulled.back?.map (·.final)).getD false) "expected last pulled chunk to be final" - else - pure () - -private def runOneStepReceiving - (payload : ByteArray) - (config : Protocol.H1.Config := {}) : - Machine .receiving × StepResult .receiving := - let machine0 : Machine .receiving := { config := config } - (machine0.feed payload).step - -private def assertFailedWith - (name : String) - (payload : ByteArray) - (expected : Error) - (config : Protocol.H1.Config := {}) : IO Unit := do - let (machine, step) := runOneStepReceiving payload config - ensure name (hasFailedEvent step.events) s!"expected failure event, events:\n{repr step.events}" - ensure name (machine.error == some expected) - s!"expected error {repr expected}, got {repr machine.error}" - --- Deterministic: one-byte incremental content-length request. -#eval show IO Unit from do - let body := "hello".toUTF8 - let request := mkContentLengthRequest "/inc-every-byte" body - let trace := runIncrementalReceiving (splitEveryByte request) - assertIncrementalSuccess "CL one-byte incremental parse" trace body - --- Deterministic: fragmented chunked request with boundaries through chunk metadata and payload. -#eval show IO Unit from do - let body := "abcXYZ".toUTF8 - let payload := "3\r\nabc\r\n3\r\nXYZ\r\n0\r\n\r\n".toUTF8 - let request := mkChunkedRequest "/inc-chunked" payload - let parts : Array ByteArray := #[ - request.extract 0 17, - request.extract 17 39, - request.extract 39 58, - request.extract 58 (request.size - 4), - request.extract (request.size - 4) request.size - ] - let trace := runIncrementalReceiving parts - assertIncrementalSuccess "Chunked fragmented parse" trace body - --- Regression: calling `pullBody` in chunked mode before any chunk-size byte arrives --- must request more data rather than failing the machine. -#eval show IO Unit from do - let headOnly := mkChunkedHead "/wait-for-chunk-size" - let machine0 : Machine .receiving := { config := {} } - let (machine1, step1) := (machine0.feed headOnly).step - ensure "Chunked pull on empty input (setup)" (!machine1.failed) s!"unexpected setup failure events:\n{repr step1.events}" - ensure "Chunked pull on empty input (setup)" (hasEndHeadersEvent step1.events) "expected endHeaders in setup" - ensure "Chunked pull on empty input (setup)" machine1.canPullBodyNow "expected body state to be pullable" - - let (machine2, pulled?) := machine1.pullBody - let (machine2, pullEvents) := machine2.takeEvents - - ensure "Chunked pull on empty input" pulled?.isNone "expected no pulled body chunk" - ensure "Chunked pull on empty input" (!machine2.failed) s!"unexpected machine failure:\n{repr pullEvents}" - ensure "Chunked pull on empty input" (hasNeedMoreDataEvent pullEvents) - s!"expected needMoreData after empty pull:\n{repr pullEvents}" - --- Regression: unread buffered input must stay bounded to avoid memory blowups --- when upper layers stall request-body consumption. -#eval show IO Unit from do - let cfg : Protocol.H1.Config := { - maxBodySize := 32 - maxHeaderBytes := 16 - maxStartLineLength := 16 - maxChunkLineLength := 16 - } - let cap := cfg.maxBodySize + cfg.maxHeaderBytes + cfg.maxStartLineLength + cfg.maxChunkLineLength - let payload := ByteArray.mk (Array.replicate (cap + 1) (UInt8.ofNat 97)) - let machine0 : Machine .receiving := { config := cfg } - let machine1 := machine0.feed payload - - ensure "Buffered input cap triggers failure" machine1.failed "expected machine to fail on oversized buffered input" - ensure "Buffered input cap triggers entityTooLarge" (machine1.error == some .entityTooLarge) - s!"expected entityTooLarge failure, got {repr machine1.error}" - --- Regression: a request-target longer than `maxUriLength` gets `uriTooLong` however the request --- line is split into reads, including reads that end between `maxStartLineLength` bytes and the --- parser's `maxUriLength` check. -#eval show IO Unit from do - let request := s!"GET /{String.ofList (List.replicate 8193 'a')} HTTP/1.1\r\nHost: a\r\n\r\n".toUTF8 - for k in [0, 8191, 8192, 8193, 8194, 8195, 8196, 8197] do - let parts := if k == 0 then #[request] else #[request.extract 0 k, request.extract k request.size] - let trace := runIncrementalReceiving parts - ensure s!"Overlong request-target, split at {k}" (trace.machine.error == some .uriTooLong) - s!"expected uriTooLong, got {repr trace.machine.error}" - --- Property-style: randomized content-length body and randomized split boundaries. -#eval show IO Unit from do - let mut seed : Nat := 0x21436587 - for i in [0:120] do - let (bodyLen, s1) := randIn seed 0 128 - seed := s1 - let (body, s2) := randomAsciiBytes seed bodyLen - seed := s2 - - let request := mkContentLengthRequest s!"/prop-cl-{i}" body - let (parts, s3) := randomSplit seed request 11 - seed := s3 - - let trace := runIncrementalReceiving parts - assertIncrementalSuccess s!"Property CL #{i}" trace body (expectNeedMoreData := parts.size > 1) - --- Property-style: randomized chunked payload and randomized split boundaries. -#eval show IO Unit from do - let mut seed : Nat := 0x89abcdef - for i in [0:120] do - let (bodyLen, s1) := randIn seed 0 128 - seed := s1 - let (body, s2) := randomAsciiBytes seed bodyLen - seed := s2 - - let (payload, s3) := randomChunkedPayload seed body - seed := s3 - let request := mkChunkedRequest s!"/prop-chunked-{i}" payload - let (parts, s4) := randomSplit seed request 9 - seed := s4 - - let trace := runIncrementalReceiving parts - assertIncrementalSuccess s!"Property chunked #{i}" trace body (expectNeedMoreData := parts.size > 1) - -private def getEndHeadersHead (events : Array (Event .receiving)) : Option Request.Head := - events.findSome? fun - | .endHeaders head => some head - | _ => none - --- Regression: a read boundary inside a chunk extension must not fail a valid request. --- `parseChunkSize` used to wrap `parseChunkExt` in `optional (attempt …)`, which turned the --- extension parser's `.eof` into "no extension", so the following CRLF check failed on `;`. -#eval show IO Unit from do - let body := "hello".toUTF8 - let payloads := #[ - "5;a=b\r\nhello\r\n0\r\n\r\n", - "5 ; a = b\r\nhello\r\n0\r\n\r\n", - "5;a=\"b c\"\r\nhello\r\n0\r\n\r\n", - "5\r\nhello\r\n0;a\r\n\r\n" - ] - for payload in payloads do - let request := mkChunkedRequest "/inc-chunk-ext" payload.toUTF8 - let trace := runIncrementalReceiving (splitEveryByte request) - assertIncrementalSuccess s!"Chunk extension one-byte incremental parse {payload.quote}" trace body - --- Regression: a read boundary inside a trailer field must not fail a valid request --- (`manyItems` had the same `optional (attempt …)` pattern). -#eval show IO Unit from do - let body := "hello".toUTF8 - let request := mkChunkedRequest "/inc-trailer" "5\r\nhello\r\n0\r\nX-T: a\r\nY: b\r\n\r\n".toUTF8 - let trace := runIncrementalReceiving (splitEveryByte request) - assertIncrementalSuccess "Trailer one-byte incremental parse" trace body - --- A chunk-size line cut inside an extension must report `.eof` so the machine waits for more data. -#eval show IO Unit from do - for input in ["5", "5;", "5 ", "5;a", "5;a=", "5;a=b", "5;a=\"b"] do - match parseChunkSize {} input.toUTF8.iter with - | .error _ .eof => pure () - | _ => throw <| IO.userError s!"expected .eof for truncated chunk-size line {input.quote}" - --- A chunk-size line that is still arriving is held to `maxChunkLineLength` by every byte read so --- far, including those of an extension the read cut off. -#eval show IO Unit from do - let config : Protocol.H1.Config := { maxChunkLineLength := 16 } - let input := mkChunkedHead "/inc-chunk-line" ++ s!"5;{String.ofList (List.replicate 40 'a')}".toUTF8 - let trace := runIncrementalReceiving #[input] config - ensure "Unfinished chunk-size line over the limit" (trace.machine.error == some .badMessage) - s!"expected badMessage, got {repr trace.machine.error}" - --- The trailer section is consumed one field at a time: after a read that ends inside the second --- field, only that field is still buffered, so the next read does not parse the first one again. -#eval show IO Unit from do - let input := "5\r\nhello\r\n0\r\nX-A: 1\r\nX-B: 2" - let trace := runIncrementalReceiving #[mkChunkedRequest "/inc-trailer-fields" input.toUTF8] - let name := "Trailer fields consumed one at a time" - ensure name (!trace.machine.failed) s!"machine ended failed with events:\n{repr trace.events}" - ensure name (trace.machine.reader.state matches .readBody (.trailers _ 1)) - s!"unexpected reader state {repr trace.machine.reader.state}" - ensure name (trace.machine.reader.input.remainingBytes == "X-B: 2".length) - s!"expected only the incomplete field buffered, got {trace.machine.reader.input.remainingBytes} bytes" - --- The trailer count limit and the forbidden-field check still apply when the section arrives one --- byte per read. -#eval show IO Unit from do - let config : Protocol.H1.Config := { maxTrailerHeaders := 2 } - let atLimit := mkChunkedRequest "/inc-trailer-limit" "5\r\nhello\r\n0\r\nA: 1\r\nB: 2\r\n\r\n".toUTF8 - let trace := runIncrementalReceiving (splitEveryByte atLimit) config - assertIncrementalSuccess "Trailers at the count limit, one byte per read" trace "hello".toUTF8 - let overLimit := mkChunkedRequest "/inc-trailer-limit" "5\r\nhello\r\n0\r\nA: 1\r\nB: 2\r\nC: 3\r\n\r\n".toUTF8 - let trace := runIncrementalReceiving (splitEveryByte overLimit) config - ensure "Trailers over the count limit, one byte per read" (trace.machine.error == some .badMessage) - s!"expected badMessage, got {repr trace.machine.error}" - let forbidden := mkChunkedRequest "/inc-trailer-forbidden" "5\r\nhello\r\n0\r\nA: 1\r\nContent-Length: 5\r\n\r\n".toUTF8 - let trace := runIncrementalReceiving (splitEveryByte forbidden) - ensure "Forbidden trailer field, one byte per read" (trace.machine.error == some .badMessage) - s!"expected badMessage, got {repr trace.machine.error}"
diff --git a/tests/async/elab/async_http_h1_lenient_parsing.lean b/tests/async/elab/async_http_h1_lenient_parsing.lean deleted file mode 100644 index 3aa3919..0000000 --- a/tests/async/elab/async_http_h1_lenient_parsing.lean +++ /dev/null
@@ -1,36 +0,0 @@ -import Std.Http -import Std.Http.Test.Helpers - -open Std Http -open Std.Http.Internal.Test - -/-! -Tests request syntax that HTTP/1.1 allows and the server must accept: empty lines before a request -line, also right before EOF (RFC 9112 §2.2); obs-text in a quoted chunk-extension value (RFC 9112 -§7.1.1, RFC 9110 §5.6.4); and leading zeros in a chunk size (`chunk-size = 1*HEXDIG`, RFC 9112 §7.1). --/ - -#eval runGroup "empty lines before EOF" do - checkClose "CRLF after a body, then EOF" - "POST / HTTP/1.1\x0d\nHost: a\x0d\nContent-Length: 2\x0d\n\x0d\nhi\x0d\n" okHandler fun r => do - assertStatus r "HTTP/1.1 200" - assertResponseCount r 1 - checkClose "only empty lines, then EOF" "\x0d\n\x0d\n" okHandler fun r => - assertExact r "" - -#eval runGroup "obs-text in a quoted chunk extension" do - for ext in [";n=\"é\"", ";n=\"a\\é\"", ";a=1;n=\"é\";b"] do - checkClose s!"extension {ext.quote}" (mkChunked "/" s!"5{ext}\x0d\nhello\x0d\n0\x0d\n\x0d\n") echoHandler - fun r => do - assertStatus r "HTTP/1.1 200" - assertContains r "\x0d\n\x0d\nhello" - -#eval runGroup "leading zeros in a chunk size" do - for size in ["00000000000000005", String.join (List.replicate 40 "0") ++ "5"] do - checkClose s!"chunk size {size}" (mkChunked "/" s!"{size}\x0d\nhello\x0d\n0\x0d\n\x0d\n") echoHandler - fun r => do - assertStatus r "HTTP/1.1 200" - assertContains r "\x0d\n\x0d\nhello" - -- Control: 17 significant digits are still too large. - checkClose "chunk size 10000000000000000" (mkChunked "/" "10000000000000000\x0d\nhello\x0d\n") echoHandler - fun r => assertStatus r "HTTP/1.1 400"
diff --git a/tests/async/elab/async_http_h1_limits.lean b/tests/async/elab/async_http_h1_limits.lean new file mode 100644 index 0000000..c63449c --- /dev/null +++ b/tests/async/elab/async_http_h1_limits.lean
@@ -0,0 +1,376 @@ +module + +import Std.Http.Test.Helpers +import Std.Http.Test.Machine + +/-! +# HTTP/1.1 limits + +Every size and count limit a server applies to a request, at its boundary: the start line and +target, header fields, leading empty lines, the body, chunk extensions, trailers and buffered input. +RFC 9112 §2.2, §3, §5, §6.3, §7.1; RFC 9110 §5.4; RFC 6585 §5. Regressions: #16080, #16282. +`maxBodySize` bounds the bytes of a chunked body on the wire, chunk framing included (Std.Http +policy). +-/ + +open Std Http +open Std.Async +open Std.Http.Protocol.H1 +open Std.Http.Internal.Test + +private def repeatStr (s : String) (n : Nat) : String := String.join (List.replicate n s) + +private def ok200 : Want := .exact okResponse + +/-- Serves `raw` with `handler` and `config`; with `closeInput` the client sends EOF after it. -/ +private def expectServer (raw : String) (want : Want) (config : Std.Http.Config := testConfig) + (handler : TestHandler := okHandler) (closeInput : Bool := false) : IO Unit := + checkHandler raw handler want config closeInput + +/-- Status `200` when `ok`, otherwise `fail`. -/ +private def okOr (ok : Bool) (fail : String) : Want := + .status (if ok then "HTTP/1.1 200" else fail) + +private def readAllOk : TestHandler := fun req => do + let _body : String ← req.body.readAll + Response.ok |>.text "ok" + +/-! ## Start line and target (RFC 9112 §3) -/ + +#eval checkCases "Start line and target limits: server" #[ + -- The method and version are bounded, so a line over the limit is over it because of its target. + ("request-line too long → 414", + s!"GET /{repeatStr "a" 2000} HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n", + Want.status "HTTP/1.1 414", { testConfig with maxStartLineLength := 1000 }, okHandler), + ("URI at maxUriLength limit → 200", + s!"GET /{"/".intercalate (List.replicate 32 (repeatStr "a" 255))} HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n", + ok200, { testConfig with maxStartLineLength := 16384 }, okHandler), + ("URI one byte over limit → 414", + s!"GET /{"/".intercalate (List.replicate 32 (repeatStr "a" 255))}a HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n", + .status "HTTP/1.1 414", { testConfig with maxStartLineLength := 16384 }, okHandler), + ("valid targets under maxUriLength: 257-byte segment", mkGetClose ("/" ++ repeatStr "a" 257), .status "HTTP/1.1 200", testConfig, uriHandler), + ("valid targets under maxUriLength: 600-byte segment", mkGetClose ("/" ++ repeatStr "a" 600), .status "HTTP/1.1 200", testConfig, uriHandler), + ("valid targets under maxUriLength: 129 segments", mkGetClose (repeatStr "/a" 129), .status "HTTP/1.1 200", testConfig, uriHandler), + ("valid targets under maxUriLength: 101 query parameters", + mkGetClose ("/?" ++ "&".intercalate (List.replicate 101 "a=1")), .status "HTTP/1.1 200", testConfig, uriHandler), + -- `GET ` and ` HTTP/1.1\r\n` add 15 bytes, so a 8177-byte target makes a 8192-byte line. + ("8177-byte target", mkGetClose ("/" ++ repeatStr "a" 8176), .status "HTTP/1.1 200", testConfig, uriHandler), + ("8178-byte target", mkGetClose ("/" ++ repeatStr "a" 8177), .status "HTTP/1.1 414", testConfig, uriHandler), + ("8192-byte target", mkGetClose ("/" ++ repeatStr "a" 8191), .status "HTTP/1.1 414", testConfig, uriHandler), + ("8193-byte target", mkGetClose ("/" ++ repeatStr "a" 8192), .status "HTTP/1.1 414", testConfig, uriHandler), + -- A small `maxUriLength` still answers 414. + ("400-byte target, maxUriLength 300", mkGetClose ("/" ++ repeatStr "a" 399), .status "HTTP/1.1 414", + { testConfig with maxUriLength := 300 }, uriHandler) + ] fun (_, raw, want, config, handler) => expectServer raw want config handler + +#eval checkCases "maxStartLineLength = maxUriLength = 64: every path length of 1–58" #[ + ("path lengths 1–58", do + let limit : Nat := 64 + let config : Std.Http.Config := { testConfig with maxStartLineLength := limit, maxUriLength := limit } + for pathLen in [1:59] do + let path := "/" ++ String.ofList (List.replicate (pathLen - 1) 'a') + let lineLen := 4 + pathLen + 11 + try expectServer s!"GET {path} HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n" + (okOr (lineLen ≤ limit) "HTTP/1.1 414") config (closeInput := true) + catch e => throw <| IO.userError s!"line of {lineLen} bytes: {e}") + ] (·.2) + + +private def clientGet : Request.Head := + { method := .get, version := .v11, uri := RequestTarget.originForm! "/", + headers := Headers.empty.insert! "Host" "example.com" } + +#eval checkCases "Client: a 64 KiB reason phrase fails" #[ + ("HTTP/1.1 200 <64 KiB>", MachineTester.sending "a 64 KiB reason phrase" + |>.send clientGet |>.step + |>.feed s!"HTTP/1.1 200 {repeatStr "r" 65536}\r\nContent-Length: 0\r\n\r\n" |>.step + |>.assert (·.failed) "expected a start-line or reason-phrase limit failure" |>.run) + ] (·.2) + +/-! ## Header fields (RFC 9110 §5.4, RFC 6585 §5) -/ + +/-- Feed all bytes at once and run one step. -/ +private def runMachine (raw : String) (cfg : Protocol.H1.Config) : Machine .receiving := + let machine : Machine .receiving := { config := cfg } + (machine.feed raw.toUTF8).step.1 + +#eval checkCases "maxHeaderBytes on the machine" #[ + -- "host" (4) + "example.com" (11) + 4 = 19 bytes for the first field; "x-a" (3) + "somevalue1" + -- (10) + 4 = 17 bytes for the second, 36 in all. + ("two fields over a 35-byte limit fail", do + let m := runMachine "GET / HTTP/1.1\r\nhost: example.com\r\nx-a: somevalue1\r\n\r\n" { maxHeaderBytes := 35 } + ensure (m.error == some .headersTooLarge) s!"expected headersTooLarge, got {repr m.error}"), + ("the same request under a 100-byte limit", do + let machine : Machine .receiving := { config := { maxHeaderBytes := 100 } } + let (m, step) := (machine.feed "GET / HTTP/1.1\r\nhost: example.com\r\nx-a: somevalue1\r\n\r\n".toUTF8).step + ensure (!m.failed && step.events.any (· matches .endHeaders _)) s!"expected the head, got {repr step.events}"), + ("one 19-byte field at a 19-byte limit", ensure + (!(runMachine "GET / HTTP/1.1\r\nhost: example.com\r\n\r\n" { maxHeaderBytes := 19 }).failed) + "unexpected failure"), + ("one 19-byte field at an 18-byte limit", do + let m := runMachine "GET / HTTP/1.1\r\nhost: example.com\r\n\r\n" { maxHeaderBytes := 18 } + ensure (m.error == some .headersTooLarge) s!"expected headersTooLarge, got {repr m.error}") + ] (·.2) + +#eval checkCases "Header size limits: server" #[ + ("header name > 256 bytes → 400", + s!"GET / HTTP/1.1\x0d\nHost: example.com\x0d\n{repeatStr "X" 257}: value\x0d\nConnection: close\x0d\n\x0d\n", Want.exact r400), + ("header value too long → 400", + s!"GET / HTTP/1.1\x0d\nHost: example.com\x0d\nX-Long: {repeatStr "x" 9000}\x0d\nConnection: close\x0d\n\x0d\n", .exact r400), + -- `maxHeaders` is 50 by default, Host and Connection included. + ("50 header fields → 200", + "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n" ++ + String.join ((List.range 48).map fun i => s!"X-Header-{i}: value{i}\x0d\n") ++ "\x0d\n", ok200), + ("too many headers (51) → 431", + "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n" ++ + String.join ((List.range 49).map fun i => s!"X-Header-{i}: value{i}\x0d\n") ++ "\x0d\n", .exact r431), + -- 9 fields of 8000 bytes stay under `maxHeaders` and `maxHeaderValueLength`, over `maxHeaderBytes`. + ("total header bytes too large → 431", + "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n" ++ + String.join ((List.range 9).map fun i => s!"X-Header-{i}: {repeatStr "a" 8000}\x0d\n") ++ "\x0d\n", .exact r431) + ] fun (_, raw, want) => expectServer raw want + +#eval checkCases "maxHeaders = 5: every field count of 2–9" #[ + ("field counts 2–9", do + for count in [2:10] do + let extra := String.join ((List.range (count - 2)).map fun j => s!"X-Extra-{j}: value\x0d\n") + try expectServer s!"GET /hc HTTP/1.1\x0d\nHost: example.com\x0d\n{extra}Connection: close\x0d\n\x0d\n" + (okOr (count ≤ 5) "HTTP/1.1 431") { testConfig with maxHeaders := 5 } (closeInput := true) + catch e => throw <| IO.userError s!"{count} fields: {e}") + ] (·.2) + +-- Host and Connection take 38 bytes; `X-Payload: ` and its CRLF add 13 to the value. +#eval checkCases "maxHeaderBytes = 200: every field total of 195–205 bytes" #[ + ("field totals 195–205", do + let baseline := ("Host: example.com\x0d\nConnection: close\x0d\n".toUTF8).size + for total in [195:206] do + let value := repeatStr "v" (total - baseline - 13) + try expectServer s!"GET /hb HTTP/1.1\x0d\nHost: example.com\x0d\nX-Payload: {value}\x0d\nConnection: close\x0d\n\x0d\n" + (okOr (total ≤ 200) "HTTP/1.1 431") { testConfig with maxHeaderBytes := 200, maxHeaderValueLength := 300 } + (closeInput := true) + catch e => throw <| IO.userError s!"{total} bytes: {e}") + ] (·.2) + +#eval checkCases "maxHeaderNameLength = 16: every name length of 1–24" #[ + ("name lengths 1–24", do + for len in [1:25] do + try expectServer s!"GET /hnl HTTP/1.1\x0d\nHost: example.com\x0d\n{repeatStr "n" len}: value\x0d\nConnection: close\x0d\n\x0d\n" + (okOr (len ≤ 16) "HTTP/1.1 400") { testConfig with maxHeaderNameLength := 16 } (closeInput := true) + catch e => throw <| IO.userError s!"name of {len}: {e}") + ] (·.2) + +#eval checkCases "maxSpaceSequence = 4 (OWS): every count of 0–8 spaces" #[ + ("0", 0), ("1", 1), ("2", 2), ("3", 3), ("4", 4), ("5", 5), ("6", 6), ("7", 7), ("8", 8) + ] fun (_, spaces) => + expectServer s!"GET /ows HTTP/1.1\x0d\nHost: example.com\x0d\nX-OWS:{repeatStr " " spaces}value\x0d\nConnection: close\x0d\n\x0d\n" + (want := okOr (spaces ≤ 4) "HTTP/1.1 400") (config := { testConfig with maxSpaceSequence := 4 }) (closeInput := true) + +#eval checkCases "maxHeaderValueLength = 32: every value length of 0–40" #[ + ("value lengths 0–40", do + for len in [0:41] do + try expectServer s!"GET /hvl HTTP/1.1\x0d\nHost: example.com\x0d\nX-Long: {repeatStr "v" len}\x0d\nConnection: close\x0d\n\x0d\n" + (want := okOr (len ≤ 32) "HTTP/1.1 400") (config := { testConfig with maxHeaderValueLength := 32, maxHeaderBytes := 65536 }) + (closeInput := true) + catch e => throw <| IO.userError s!"length {len}: {e}") + ] (·.2) + + +-- RFC 6585 §5: `maxHeaders` counts field lines, not values. +#eval checkCases "maxHeaders = 15: repeated lines vs one list" #[ + ("16 X-Repeated lines → 431", String.join (List.replicate 16 "X-Repeated: v\x0d\n"), Want.exact r431), + ("one line with 16 values → 200", s!"X-Repeated: {", ".intercalate (List.replicate 16 "v")}\x0d\n", ok200) + ] fun (_, fields, want) => + expectServer s!"GET / HTTP/1.1\x0d\nHost: example.com\x0d\n{fields}Connection: close\x0d\n\x0d\n" want + { testConfig with maxHeaders := 15 } (closeInput := true) + +#eval checkCases "Client: more fields than maxHeaders fails" #[ + ("10 fields, maxHeaders 5", MachineTester.sending "10 fields, maxHeaders 5" { maxHeaders := 5 } + |>.send clientGet |>.step + |>.feed ("HTTP/1.1 200 OK\r\n" ++ String.join ((List.range 10).map fun i => s!"X-F-{i}: v\r\n") ++ "Content-Length: 0\r\n\r\n") + |>.step |>.assert (·.failed) "expected a header-count failure" |>.run) + ] (·.2) + +/-! ## Leading empty lines (RFC 9112 §2.2) -/ + +#eval checkCases "maxLeadingEmptyLines = 4: every count of 0–8 CRLFs" #[ + ("0", 0), ("1", 1), ("2", 2), ("3", 3), ("4", 4), ("5", 5), ("6", 6), ("7", 7), ("8", 8) + ] fun (_, n) => + expectServer (repeatStr "\x0d\n" n ++ "GET /le HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") + (want := okOr (n ≤ 4) "HTTP/1.1 400") (config := { testConfig with maxLeadingEmptyLines := 4 }) (closeInput := true) + +/-! ## Body size (RFC 9112 §6.3, §7.1; RFC 9110 §15.5.14) -/ + +/-- +Feeds `data` to a server machine `piece` bytes at a time, pulling the body as it arrives. Returns +the machine's error, whether the body completed, and the number of content bytes pulled. +-/ +private def runPieces (config : Protocol.H1.Config) (data : ByteArray) (piece : Nat) : + Option Error × Bool × Nat := Id.run do + let mut m : Machine .receiving := { config } + let mut pulled := 0 + let mut complete := false + let mut i := 0 + while i < data.size && !m.failed do + m := m.feed (data.extract i (i + piece)) + i := i + piece + for _ in [0:4] do + m := m.step.1 + let (m', chunk) := m.pullBody + m := m' + if let some c := chunk then + pulled := pulled + c.chunk.data.size + complete := complete || c.final + return (m.error, complete, pulled) + +private def chunkedPost : String := + "POST / HTTP/1.1\r\nHost: a\r\nTransfer-Encoding: chunked\r\n\r\n" + +#eval checkCases "maxBodySize counts chunk framing (#16282)" #[ + -- 1000 one-byte chunks with ~100-byte extensions: 1000 content bytes, over 100 KB on the wire. + ("1000 one-byte chunks with long extensions", do + let ext := s!";name={repeatStr "x" 100}" + let body := String.join (List.replicate 1000 s!"1{ext}\r\nX\r\n") ++ "0\r\n\r\n" + let (error, complete, pulled) := runPieces { maxBodySize := 2000 } (chunkedPost ++ body).toUTF8 4096 + ensure (error == some .entityTooLarge && !complete && pulled < 2000) + s!"framing not counted: {repr error}, complete {complete}, pulled {pulled}"), + -- The last byte over the limit is the line break that ends the trailer section. + ("the limit is exactly the body's wire size", do + let body := "5\r\nhello\r\n3;x=y\r\nabc\r\n0\r\nX-Trace: 1\r\n\r\n" + let data := (chunkedPost ++ body).toUTF8 + for piece in [data.size, 1] do + let (error, complete, pulled) := runPieces { maxBodySize := body.utf8ByteSize } data piece + ensure (error.isNone && complete && pulled == 8) + s!"exact fit, pieces of {piece}: {repr error}, complete {complete}, pulled {pulled}" + let (error, complete, _) := runPieces { maxBodySize := body.utf8ByteSize - 1 } data piece + ensure (error == some .entityTooLarge && !complete) + s!"one byte over, pieces of {piece}: {repr error}, complete {complete}") + ] (·.2) + +#eval checkCases "Content-Length over maxBodySize: server" #[ + ("very large Content-Length → 413", + "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 99999999999999999999\x0d\nConnection: close\x0d\n\x0d\nhello") + ] fun (_, raw) => expectServer raw (.exact r413) (handler := echoHandler) + +#eval checkCases "maxBodySize = 64: every Content-Length of 0–84" #[ + ("Content-Length 0–84", do + for size in [0:85] do + try expectServer + (s!"POST /bl-cl HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: {size}\x0d\nConnection: close\x0d\n\x0d\n" ++ repeatStr "a" size) + (want := okOr (size ≤ 64) "HTTP/1.1 413") (config := { testConfig with maxBodySize := 64 }) (handler := readAllOk) + catch e => throw <| IO.userError s!"size {size}: {e}") + ] (·.2) + +/-- A chunked body of `total` content bytes in `chunks` equal chunks (the last may be shorter). -/ +private def splitChunked (total chunks : Nat) : String := Id.run do + let chunkSize := (total + chunks - 1) / chunks + let mut out := "" + let mut remaining := total + for _ in [0:chunks] do + if remaining == 0 then break + let this := Nat.min chunkSize remaining + out := out ++ s!"{String.ofList (Nat.toDigits 16 this)}\x0d\n{repeatStr "a" this}\x0d\n" + remaining := remaining - this + out ++ "0\x0d\n\x0d\n" + +#eval checkCases "maxBodySize = 64 on the wire: totals 0–80 in 1–4 chunks" #[ + ("1 chunk", 1), ("2 chunks", 2), ("3 chunks", 3), ("4 chunks", 4) + ] fun (_, chunks) => do + for total in [0:81] do + let body := splitChunked total chunks + try expectServer + (s!"POST /bl-ch HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n" ++ body) + (want := okOr (body.utf8ByteSize ≤ 64) "HTTP/1.1 413") (config := { testConfig with maxBodySize := 64 }) (handler := readAllOk) + catch e => throw <| IO.userError s!"total {total}, wire {body.utf8ByteSize}: {e}" + +/-! ## Chunk extensions (RFC 9112 §7.1.1) -/ + +-- A chunk-size line that is still arriving is held to `maxChunkLineLength` by every byte read so +-- far, including those of an extension the read cut off. +#eval checkCases "maxChunkLineLength on an unfinished line" #[ + ("Unfinished chunk-size line over the limit", do + let input := s!"POST /inc-chunk-line HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: chunked\r\nConnection: keep-alive\r\n\r\n5;{repeatStr "a" 40}".toUTF8 + let trace := feedParts #[input] { maxChunkLineLength := 16 } + ensure (trace.machine.error == some .badMessage) s!"expected badMessage, got {repr trace.machine.error}") + ] (·.2) + +private def chunkedWith (ext : String) : String := + s!"POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5{ext}\x0d\nhello\x0d\n0\x0d\n\x0d\n" + +#eval checkCases "Chunk extension limits: server" #[ + ("ext name at 256 bytes → accepted", chunkedWith s!";{repeatStr "a" 256}", Want.status "HTTP/1.1 200", testConfig), + ("ext name at 257 bytes → 400", chunkedWith s!";{repeatStr "a" 257}", .exact r400, testConfig), + ("ext token value at 256 bytes → accepted", chunkedWith s!";ext={repeatStr "v" 256}", .status "HTTP/1.1 200", testConfig), + ("ext token value at 257 bytes → 400", chunkedWith s!";ext={repeatStr "v" 257}", .exact r400, testConfig), + ("ext quoted value at 256 bytes → accepted", chunkedWith s!";ext=\"{repeatStr "v" 256}\"", .status "HTTP/1.1 200", testConfig), + ("ext quoted value at 257 bytes → 400", chunkedWith s!";ext=\"{repeatStr "v" 257}\"", .exact r400, testConfig), + ("16 extensions → accepted", chunkedWith (String.join ((List.range 16).map (s!";e{·}"))), .status "HTTP/1.1 200", testConfig), + ("17 extensions → 400", chunkedWith (String.join ((List.range 17).map (s!";e{·}"))), .exact r400, testConfig), + ("1 extension with limit=1 → accepted", chunkedWith ";ext1", .status "HTTP/1.1 200", { testConfig with maxChunkExtensions := 1 }), + ("2 extensions with limit=1 → 400", chunkedWith ";ext1;ext2", .exact r400, { testConfig with maxChunkExtensions := 1 }), + ("0 extensions with limit=1 → accepted", chunkedWith "", .status "HTTP/1.1 200", { testConfig with maxChunkExtensions := 1 }) + ] fun (_, raw, want, config) => expectServer raw want config (handler := echoHandler) + +#eval checkCases "maxChunkExtNameLength = maxChunkExtValueLength = 4: every pair of lengths 1–8" #[ + ("name and value lengths 1–8", do + for nameLen in [1:9] do + for valueLen in [1:9] do + let raw := s!"POST /ext-limit HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n1;{repeatStr "n" nameLen}={repeatStr "v" valueLen}\x0d\nx\x0d\n0\x0d\n\x0d\n" + try expectServer raw (if nameLen ≤ 4 ∧ valueLen ≤ 4 then .status "HTTP/1.1 200" else .exact r400) + { testConfig with maxChunkExtNameLength := 4, maxChunkExtValueLength := 4 } (handler := echoHandler) + catch e => throw <| IO.userError s!"name {nameLen}, value {valueLen}: {e}") + ] (·.2) + +#eval checkCases "maxChunkExtensions = 2: every count of 0–5" #[ + ("0", 0), ("1", 1), ("2", 2), ("3", 3), ("4", 4), ("5", 5) + ] fun (_, n) => + expectServer + s!"POST /ext-count HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n1{String.join ((List.range n).map (s!";n{·}=v"))}\x0d\nx\x0d\n0\x0d\n\x0d\n" + (want := if n ≤ 2 then .status "HTTP/1.1 200" else .exact r400) (config := { testConfig with maxChunkExtensions := 2 }) + (handler := echoHandler) + + +-- RFC 9112 §7.1: leading zeros are part of the chunk line, so `maxChunkLineLength` bounds them. +#eval checkCases "65 536 leading zeros in a chunk size" #[ + ("0…0a → 400", s!"{repeatStr "0" 65536}a\x0d\n{repeatStr "x" 10}\x0d\n0\x0d\n\x0d\n") + ] fun (_, chunked) => + checkHandler ("POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n" ++ chunked) + readAllOk (.exact r400) (closeInput := true) + +/-! ## Trailers (RFC 9112 §7.1.2) -/ + +private def trailerConfig : Std.Http.Config := { lingeringTimeout := 3000, generateDate := false } + +private def chunkedTrailers (trailers : String) : String := + s!"POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n3\x0d\nabc\x0d\n0\x0d\n{trailers}\x0d\n" + +#eval checkCases "Trailer limits: server" #[ + ("trailer name of 256 characters", chunkedTrailers s!"{repeatStr "X" 256}: value\x0d\n", Want.status "HTTP/1.1 200", trailerConfig), + ("trailer name of 257 characters", chunkedTrailers s!"{repeatStr "X" 257}: value\x0d\n", .exact r400, trailerConfig), + ("trailer value of 8192 characters", chunkedTrailers s!"X-Exact: {repeatStr "v" 8192}\x0d\n", .status "HTTP/1.1 200", trailerConfig), + ("trailer value of 8193 characters", chunkedTrailers s!"X-Too-Long: {repeatStr "v" 8193}\x0d\n", .exact r400, trailerConfig), + ("maxTrailerHeaders 2: 2 trailers", chunkedTrailers "T1: a\x0d\nT2: b\x0d\n", .status "HTTP/1.1 200", { trailerConfig with maxTrailerHeaders := 2 }), + ("maxTrailerHeaders 2: 3 trailers", chunkedTrailers "T1: a\x0d\nT2: b\x0d\nT3: c\x0d\n", .exact r400, { trailerConfig with maxTrailerHeaders := 2 }), + ("maxTrailerHeaders 0: any trailer", chunkedTrailers "X-Trailer: rejected\x0d\n", .exact r400, { trailerConfig with maxTrailerHeaders := 0 }), + ("maxTrailerHeaders 0: no trailer", chunkedTrailers "", .status "HTTP/1.1 200", { trailerConfig with maxTrailerHeaders := 0 }) + ] fun (_, raw, want, config) => expectServer raw want config (handler := echoHandler) + +#eval checkCases "maxTrailerHeaders = 2: every count of 0–5" #[ + ("0", 0), ("1", 1), ("2", 2), ("3", 3), ("4", 4), ("5", 5) + ] fun (_, n) => + expectServer + s!"POST /trailers HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n1\x0d\na\x0d\n0\x0d\n{String.join ((List.range n).map (s!"X{·}-t: v\x0d\n"))}\x0d\n" + (want := if n ≤ 2 then .status "HTTP/1.1 200" else .exact r400) (config := { testConfig with maxTrailerHeaders := 2 }) + (handler := echoHandler) + +/-! ## Buffered input -/ + +-- Unread buffered input stays bounded, so a stalled body consumer cannot grow it without limit. +#eval checkCases "Buffered input cap" #[ + ("Buffered input cap triggers entityTooLarge", do + let cfg : Protocol.H1.Config := { + maxBodySize := 32, maxHeaderBytes := 16, maxStartLineLength := 16, maxChunkLineLength := 16 } + let cap := cfg.maxBodySize + cfg.maxHeaderBytes + cfg.maxStartLineLength + cfg.maxChunkLineLength + let machine1 := ({ config := cfg } : Machine .receiving).feed (ByteArray.mk (Array.replicate (cap + 1) 97)) + ensure machine1.failed "expected machine to fail on oversized buffered input" + ensure (machine1.error == some .entityTooLarge) s!"expected entityTooLarge failure, got {repr machine1.error}") + ] (·.2)
diff --git a/tests/async/elab/async_http_fuzz_limits.lean.serial b/tests/async/elab/async_http_h1_limits.lean.serial similarity index 100% rename from tests/async/elab/async_http_fuzz_limits.lean.serial rename to tests/async/elab/async_http_h1_limits.lean.serial
diff --git a/tests/async/elab/async_http_h1_parser.lean b/tests/async/elab/async_http_h1_parser.lean new file mode 100644 index 0000000..b1cf072 --- /dev/null +++ b/tests/async/elab/async_http_h1_parser.lean
@@ -0,0 +1,205 @@ +module + +import Std.Http.Test.Helpers +import Std.Http.Protocol.H1.Parser + +/-! +# HTTP/1.1 parser units + +The `Std.Http.Protocol.H1` Parsec parsers on their own: request and status lines, field lines, chunk +sizes, chunk data and trailers, and lines of arbitrary tokens. RFC 9112 §3, §4, §5, §7.1. +-/ + +open Std Internal Parsec ByteArray +open Std.Http.Protocol.H1 +open Std.Http.Internal.Test + +private def runParser (p : Parser α) (s : String) : Except String α := + match (p <* eof).run s.toUTF8 with + | .ok x => .ok x + | .error e => .error e + +private def randBelow (gen : StdGen) (maxExclusive : Nat) : Nat × StdGen := + if maxExclusive = 0 then + (0, gen) + else + randNat gen 0 (maxExclusive - 1) + +private def pick! [Inhabited α] (gen : StdGen) (xs : Array α) : α × StdGen := + let (i, gen') := randBelow gen xs.size + (xs[i]!, gen') + +private def randomToken (gen : StdGen) (len : Nat) : String × StdGen := Id.run do + let mut g := gen + let mut out := "" + for _ in [0:len] do + let (r, g') := randBelow g 38 + g := g' + let c := + if r < 26 then Char.ofNat (97 + r) + else if r < 36 then Char.ofNat (48 + (r - 26)) + else if r = 36 then '-' + else '_' + out := out.push c + (out, g) + +private def randomReason (gen : StdGen) (len : Nat) : String × StdGen := Id.run do + let mut g := gen + let mut out := "" + for _ in [0:len] do + let (r, g') := randBelow g 30 + g := g' + let c := if r < 26 then Char.ofNat (65 + r) else ' ' + out := out.push c + (out.trimAscii.toString, g) + +private def pad3 (n : Nat) : String := + if n < 10 then s!"00{n}" else if n < 100 then s!"0{n}" else s!"{n}" + +private def expectRequestOk (s : String) : IO Unit := do + match runParser (parseRequestLine {}) s with + | .ok _ => pure () + | .error e => throw <| IO.userError s!"expected request-line success for {s.quote}, got: {e}" + +private def expectRequestFail (s : String) : IO Unit := do + match runParser (parseRequestLine {}) s with + | .ok _ => throw <| IO.userError s!"expected request-line failure for {s.quote}" + | .error _ => pure () + +private def expectStatusOk (s : String) : IO Unit := do + match runParser (parseStatusLine {}) s with + | .ok _ => pure () + | .error e => throw <| IO.userError s!"expected status-line success for {s.quote}, got: {e}" + +private def expectStatusFail (s : String) : IO Unit := do + match runParser (parseStatusLine {}) s with + | .ok _ => throw <| IO.userError s!"expected status-line failure for {s.quote}" + | .error _ => pure () + +private def expectOk {α} (name : String) (p : Parser α) (s : String) : IO α := do + match runParser p s with + | .ok x => pure x + | .error e => throw <| IO.userError s!"{name}: expected success for {s.quote}, got {e}" + +private def expectFail {α} (name : String) (p : Parser α) (s : String) : IO Unit := do + match runParser p s with + | .ok _ => throw <| IO.userError s!"{name}: expected failure for {s.quote}" + | .error _ => pure () + +/-! ## Request and status lines (RFC 9112 §3, §4) -/ + +#eval checkCases "Generated request and status lines" #[ + ("request lines from 8 methods × 7 targets × 2 versions, and their mutations", do + let methods : Array String := #["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS", "HEAD", "CONNECT"] + let targets : Array String := #["/", "/a", "/a/b", "/a/b?q=1", "*", "http://example.com", "example.com:443"] + let versions : Array String := #["HTTP/1.1", "HTTP/1.0"] + for m in methods do + for t in targets do + for v in versions do + expectRequestOk s!"{m} {t} {v}\r\n" + -- Mutation 1: drop the first space + expectRequestFail s!"{m}{t} {v}\r\n" + -- Mutation 2: invalid version token + expectRequestFail s!"{m} {t} HTTP/2.0\r\n" + -- Mutation 3: bad method character + expectRequestFail s!"{m}! {t} {v}\r\n"), + ("status lines with known codes and generated reasons, and their mutations", do + let knownCodes : Array Nat := #[200, 201, 204, 301, 400, 404, 500, 503] + let mut gen : StdGen := StdGen.mk 0xabcde123 0x777 + for _ in [0:400] do + let (code, g1) := pick! gen knownCodes + let (len, g2) := randBelow g1 20 + let (reasonRaw, g3) := randomReason g2 (len + 1) + gen := g3 + let reason := if reasonRaw.isEmpty then "OK" else reasonRaw + let line := s!"HTTP/1.1 {pad3 code} {reason}\r\n" + expectStatusOk line + -- Mutation 1: unsupported version + expectStatusFail s!"HTTP/2.0 {pad3 code} {reason}\r\n" + -- Mutation 2: non-digit in status code + expectStatusFail s!"HTTP/1.1 A{(pad3 code).drop 1} {reason}\r\n" + -- Mutation 3: illegal reason byte (DEL) + expectStatusFail s!"HTTP/1.1 {pad3 code} bad{Char.ofNat 127}\r\n") + ] (·.2) + +#eval checkCases "Raw-version parsers" #[ + ("parseRequestLineRawVersion", do + let (m1, _, v1) ← expectOk "parseRequestLineRawVersion" (parseRequestLineRawVersion {} <* eof) "GET / HTTP/1.1\r\n" + ensure (m1 == Std.Http.Method.get) "parseRequestLineRawVersion method: method mismatch" + ensure (v1 == some Std.Http.Version.v11) "parseRequestLineRawVersion version: expected recognized v11"), + ("parseStatusLineRawVersion", do + let (_, rv) ← expectOk "parseStatusLineRawVersion" (parseStatusLineRawVersion {} <* eof) "HTTP/1.1 204 No Content\r\n" + ensure (rv == some Std.Http.Version.v11) "parseStatusLineRawVersion recognized: expected v11") + ] (·.2) + +/-! ## Field lines (RFC 9112 §5) -/ + +#eval checkCases "parseSingleHeader" #[ + ("parseSingleHeader some", do + let sh1 ← expectOk "parseSingleHeader some" (parseSingleHeader {} <* eof) "Host: x\r\n" + ensure sh1.isSome "parseSingleHeader some present: expected some header"), + ("parseSingleHeader none", do + let sh2 ← expectOk "parseSingleHeader none" (parseSingleHeader {} <* eof) "\r\n" + ensure sh2.isNone "parseSingleHeader none present: expected header terminator") + ] (·.2) + +/-! ## Chunks and trailers (RFC 9112 §7.1) -/ + +-- A chunk-size line cut inside an extension must report `.eof` so the machine waits for more data. +#eval checkCases "truncated chunk-size line" #[ + "5", "5;", "5 ", "5;a", "5;a=", "5;a=b", "5;a=\"b" + ] fun input => match parseChunkSize {} input.toUTF8.iter with + | .error _ .eof => pure () + | _ => throw <| IO.userError s!"expected .eof for truncated chunk-size line {input.quote}" + +#eval checkCases "Component tests for individual parser parts" #[ + ("parseChunkSize bare", do + let (n1, ext1) ← expectOk "parseChunkSize bare" (parseChunkSize {} <* eof) "A\r\n" + ensure (n1 == 10) "parseChunkSize value: chunk-size mismatch" + ensure ext1.isEmpty "parseChunkSize ext empty: expected no extensions"), + ("parseChunkSize ext", do + let (n2, ext2) ← expectOk "parseChunkSize ext" (parseChunkSize {} <* eof) "4;foo=bar;baz=\"qux\"\r\n" + ensure (n2 == 4) "parseChunkSize ext value: chunk-size mismatch with ext" + ensure (ext2.size == 2) "parseChunkSize ext count: expected 2 extensions"), + ("parseChunkPartial some", do + let cp1 ← expectOk "parseChunkPartial some" (parseChunkPartial {} <* eof) "4\r\nWiki" + ensure cp1.isSome "parseChunkPartial some isSome: expected chunk data" + ensure ((cp1.map (fun (n, _, _) => n)).getD 0 == 4) "parseChunkPartial some size: size mismatch"), + ("parseChunkPartial none", do + let cp0 ← expectOk "parseChunkPartial none" (parseChunkPartial {} <* eof) "0\r\n" + ensure cp0.isNone "parseChunkPartial none isNone: expected last-chunk marker"), + ("parseFixedSizeData complete", do + let fs1 ← expectOk "parseFixedSizeData complete" (parseFixedSizeData 4 <* eof) "Wiki" + ensure (match fs1 with | .complete _ => true | _ => false) "parseFixedSizeData complete shape: expected complete result"), + ("parseFixedSizeData incomplete", do + let fs2 ← expectOk "parseFixedSizeData incomplete" (parseFixedSizeData 4 <* eof) "Wi" + ensure (match fs2 with | .incomplete _ 2 => true | _ => false) + "parseFixedSizeData incomplete shape: expected incomplete result with remaining=2"), + ("parseChunkSizedData complete", do + let cs1 ← expectOk "parseChunkSizedData complete" (parseChunkSizedData 4 <* eof) "Wiki\r\n" + ensure (match cs1 with | .complete _ => true | _ => false) + "parseChunkSizedData complete shape: expected complete chunk-sized result"), + ("parseChunkSizedData incomplete", do + let cs2 ← expectOk "parseChunkSizedData incomplete" (parseChunkSizedData 4 <* eof) "Wi" + ensure (match cs2 with | .incomplete _ 2 => true | _ => false) + "parseChunkSizedData incomplete shape: expected incomplete chunk-sized result with remaining=2"), + ("parseTrailers ok", do + let trailers ← expectOk "parseTrailers ok" (parseTrailers {} <* eof) "X-Test: a\r\nY-Test: b\r\n\r\n" + ensure (trailers.size == 2) "parseTrailers count: expected 2 trailers"), + ("parseTrailers forbidden", expectFail "parseTrailers forbidden" (parseTrailers {} <* eof) + "Content-Length: 1\r\n\r\n") + ] (·.2) + +/-! ## Arbitrary lines -/ + +#eval checkCases "Lines with no version token" #[ + -- A line of token characters has no SP and no version, so neither parser accepts it. + ("300 token lines through both parsers", do + let mut gen : StdGen := StdGen.mk 0x31415926 0x27182818 + for _ in [0:300] do + let (len, g1) := randBelow gen 80 + let (tok, g2) := randomToken g1 (len + 1) + gen := g2 + expectRequestFail (tok ++ "\r\n") + expectStatusFail (tok ++ "\r\n")) + ] (·.2)
diff --git a/tests/async/elab/async_http_h1_parser_fuzz.lean b/tests/async/elab/async_http_h1_parser_fuzz.lean deleted file mode 100644 index 2c9816f..0000000 --- a/tests/async/elab/async_http_h1_parser_fuzz.lean +++ /dev/null
@@ -1,202 +0,0 @@ -import Std.Http -import Std.Http.Protocol.H1.Parser - -open Std Internal Parsec ByteArray -open Std.Http.Protocol.H1 - -private def ensure (name : String) (cond : Bool) (msg : String) : IO Unit := do - unless cond do - throw <| IO.userError s!"{name}: {msg}" - -private def runParser (p : Parser α) (s : String) : Except String α := - match (p <* eof).run s.toUTF8 with - | .ok x => .ok x - | .error e => .error e - -private def randBelow (gen : StdGen) (maxExclusive : Nat) : Nat × StdGen := - if maxExclusive = 0 then - (0, gen) - else - randNat gen 0 (maxExclusive - 1) - -private def pick! [Inhabited α] (gen : StdGen) (xs : Array α) : α × StdGen := - let (i, gen') := randBelow gen xs.size - (xs[i]!, gen') - -private def randomToken (gen : StdGen) (len : Nat) : String × StdGen := Id.run do - let mut g := gen - let mut out := "" - for _ in [0:len] do - let (r, g') := randBelow g 38 - g := g' - let c := - if r < 26 then Char.ofNat (97 + r) - else if r < 36 then Char.ofNat (48 + (r - 26)) - else if r = 36 then '-' - else '_' - out := out.push c - (out, g) - -private def randomReason (gen : StdGen) (len : Nat) : String × StdGen := Id.run do - let mut g := gen - let mut out := "" - for _ in [0:len] do - let (r, g') := randBelow g 30 - g := g' - let c := if r < 26 then Char.ofNat (65 + r) else ' ' - out := out.push c - (out.trimAscii.toString, g) - -private def pad3 (n : Nat) : String := - if n < 10 then s!"00{n}" else if n < 100 then s!"0{n}" else s!"{n}" - -private def expectRequestOk (s : String) : IO Unit := do - match runParser (parseRequestLine {}) s with - | .ok _ => pure () - | .error e => throw <| IO.userError s!"expected request-line success for {s.quote}, got: {e}" - -private def expectRequestFail (s : String) : IO Unit := do - match runParser (parseRequestLine {}) s with - | .ok _ => throw <| IO.userError s!"expected request-line failure for {s.quote}" - | .error _ => pure () - -private def expectStatusOk (s : String) : IO Unit := do - match runParser (parseStatusLine {}) s with - | .ok _ => pure () - | .error e => throw <| IO.userError s!"expected status-line success for {s.quote}, got: {e}" - -private def expectStatusFail (s : String) : IO Unit := do - match runParser (parseStatusLine {}) s with - | .ok _ => throw <| IO.userError s!"expected status-line failure for {s.quote}" - | .error _ => pure () - -private def expectOk {α} (name : String) (p : Parser α) (s : String) : IO α := do - match runParser p s with - | .ok x => pure x - | .error e => throw <| IO.userError s!"{name}: expected success for {s.quote}, got {e}" - -private def expectFail {α} (name : String) (p : Parser α) (s : String) : IO Unit := do - match runParser p s with - | .ok _ => throw <| IO.userError s!"{name}: expected failure for {s.quote}" - | .error _ => pure () - -#eval show IO Unit from do - let methods : Array String := #["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS", "HEAD", "CONNECT"] - let targets : Array String := #["/", "/a", "/a/b", "/a/b?q=1", "*", "http://example.com", "example.com:443"] - let versions : Array String := #["HTTP/1.1", "HTTP/1.0"] - - let mut gen : StdGen := StdGen.mk 0x5eed1234 0x12345 - for i in [0:400] do - let (m, g1) := pick! gen methods - let (t, g2) := pick! g1 targets - let (v, g3) := pick! g2 versions - gen := g3 - - let line := s!"{m} {t} {v}\r\n" - expectRequestOk line - - -- Mutation 1: drop the first space - expectRequestFail s!"{m}{t} {v}\r\n" - - -- Mutation 2: invalid version token - expectRequestFail s!"{m} {t} HTTP/2.0\r\n" - - -- Mutation 3: bad method character - expectRequestFail s!"{m}! {t} {v}\r\n" - - ensure "request fuzz progress" (i < 100000) "unreachable safety check" - -#eval show IO Unit from do - let knownCodes : Array Nat := #[200, 201, 204, 301, 400, 404, 500, 503] - let mut gen : StdGen := StdGen.mk 0xabcde123 0x777 - - for _ in [0:400] do - let (code, g1) := pick! gen knownCodes - let (len, g2) := randBelow g1 20 - let (reasonRaw, g3) := randomReason g2 (len + 1) - gen := g3 - let reason := if reasonRaw.isEmpty then "OK" else reasonRaw - - let line := s!"HTTP/1.1 {pad3 code} {reason}\r\n" - expectStatusOk line - - -- Mutation 1: unsupported version - expectStatusFail s!"HTTP/2.0 {pad3 code} {reason}\r\n" - - -- Mutation 2: non-digit in status code - expectStatusFail s!"HTTP/1.1 A{(pad3 code).drop 1} {reason}\r\n" - - -- Mutation 3: illegal reason byte (DEL) - expectStatusFail s!"HTTP/1.1 {pad3 code} bad{Char.ofNat 127}\r\n" - -#eval show IO Unit from do - -- Randomized malformed gibberish smoke: parser must simply return error or success, - -- but never crash/panic. - let mut gen : StdGen := StdGen.mk 0x31415926 0x27182818 - for _ in [0:300] do - let (len, g1) := randBelow gen 80 - let (tok, g2) := randomToken g1 (len + 1) - gen := g2 - let _ := runParser (parseRequestLine {}) (tok ++ "\r\n") - let _ := runParser (parseStatusLine {}) (tok ++ "\r\n") - pure () - --- Component tests for individual parser parts. -#eval show IO Unit from do - -- parseSingleHeader - let sh1 ← expectOk "parseSingleHeader some" (parseSingleHeader {} <* eof) "Host: x\r\n" - ensure "parseSingleHeader some present" sh1.isSome "expected some header" - - let sh2 ← expectOk "parseSingleHeader none" (parseSingleHeader {} <* eof) "\r\n" - ensure "parseSingleHeader none present" sh2.isNone "expected header terminator" - - -- parseChunkSize / parseChunkPartial - let (n1, ext1) ← expectOk "parseChunkSize bare" (parseChunkSize {} <* eof) "A\r\n" - ensure "parseChunkSize value" (n1 == 10) "chunk-size mismatch" - ensure "parseChunkSize ext empty" (ext1.isEmpty) "expected no extensions" - - let (n2, ext2) ← expectOk "parseChunkSize ext" (parseChunkSize {} <* eof) "4;foo=bar;baz=\"qux\"\r\n" - ensure "parseChunkSize ext value" (n2 == 4) "chunk-size mismatch with ext" - ensure "parseChunkSize ext count" (ext2.size == 2) "expected 2 extensions" - - let cp1 ← expectOk "parseChunkPartial some" (parseChunkPartial {} <* eof) "4\r\nWiki" - ensure "parseChunkPartial some isSome" cp1.isSome "expected chunk data" - ensure "parseChunkPartial some size" ((cp1.map (fun (n, _, _) => n)).getD 0 == 4) "size mismatch" - - let cp0 ← expectOk "parseChunkPartial none" (parseChunkPartial {} <* eof) "0\r\n" - ensure "parseChunkPartial none isNone" cp0.isNone "expected last-chunk marker" - - -- parseFixedSizeData / parseChunkSizedData - let fs1 ← expectOk "parseFixedSizeData complete" (parseFixedSizeData 4 <* eof) "Wiki" - ensure "parseFixedSizeData complete shape" - (match fs1 with | .complete _ => true | _ => false) - "expected complete result" - let fs2 ← expectOk "parseFixedSizeData incomplete" (parseFixedSizeData 4 <* eof) "Wi" - ensure "parseFixedSizeData incomplete shape" - (match fs2 with | .incomplete _ 2 => true | _ => false) - "expected incomplete result with remaining=2" - - let cs1 ← expectOk "parseChunkSizedData complete" (parseChunkSizedData 4 <* eof) "Wiki\r\n" - ensure "parseChunkSizedData complete shape" - (match cs1 with | .complete _ => true | _ => false) - "expected complete chunk-sized result" - let cs2 ← expectOk "parseChunkSizedData incomplete" (parseChunkSizedData 4 <* eof) "Wi" - ensure "parseChunkSizedData incomplete shape" - (match cs2 with | .incomplete _ 2 => true | _ => false) - "expected incomplete chunk-sized result with remaining=2" - - -- parseTrailers - let trailers ← expectOk "parseTrailers ok" (parseTrailers {} <* eof) "X-Test: a\r\nY-Test: b\r\n\r\n" - ensure "parseTrailers count" (trailers.size == 2) "expected 2 trailers" - expectFail "parseTrailers forbidden" (parseTrailers {} <* eof) "Content-Length: 1\r\n\r\n" - - -- parseRequestLineRawVersion / parseStatusLineRawVersion - let (m1, _, v1) ← expectOk "parseRequestLineRawVersion" (parseRequestLineRawVersion {} <* eof) "GET / HTTP/1.1\r\n" - ensure "parseRequestLineRawVersion method" (m1 == Std.Http.Method.get) "method mismatch" - ensure "parseRequestLineRawVersion version" (v1 == some Std.Http.Version.v11) "expected recognized v11" - let (_, rv) ← expectOk "parseStatusLineRawVersion" (parseStatusLineRawVersion {} <* eof) "HTTP/1.1 204 No Content\r\n" - ensure "parseStatusLineRawVersion recognized" (rv == some Std.Http.Version.v11) "expected v11" - - -- parseRequestLine / parseStatusLine failures - expectFail "parseRequestLine invalid version" (parseRequestLine {} <* eof) "GET / HTTP/2.0\r\n" - expectFail "parseStatusLine invalid version" (parseStatusLine {} <* eof) "HTTP/2.0 200 OK\r\n"
diff --git a/tests/async/elab/async_http_h1_request_framing.lean b/tests/async/elab/async_http_h1_request_framing.lean new file mode 100644 index 0000000..67483f9 --- /dev/null +++ b/tests/async/elab/async_http_h1_request_framing.lean
@@ -0,0 +1,484 @@ +module + +import Std.Http.Test.Helpers +import Std.Http.Test.Machine + +/-! +# HTTP/1.1 request framing + +What a server accepts as a request body: `Content-Length`, `Transfer-Encoding`, chunked syntax, chunk +extensions, trailers, truncated bodies and smuggling vectors. Each rule has its machine table next to +its `serveConnection` table. RFC 9112 §6, §7; RFC 9110 §5.3, §6.5, §8.6. Regressions: #16362. +Request trailers that carry a field forbidden in trailers are rejected with 400; RFC 9112 §7.1.2 +would also allow discarding them, so this is Std.Http policy. +-/ + +open Std Http +open Std.Async +open Std.Http.Protocol.H1 +open Std.Http.Internal.Test + +private def mkPostHead (path : String) (bodyLen : Nat) (extra : String := "") : String := + rawRequest "POST" path (extra := s!"Content-Length: {bodyLen}\r\n{extra}") + +private def mkChunkedPost (path : String) (extra : String := "") : String := + rawRequest "POST" path (extra := s!"Transfer-Encoding: chunked\r\n{extra}") + +/-- `(label, raw, handler, want, config)` rows served without closing the input. -/ +private def expectServer (raw : String) (handler : TestHandler) (want : Want) + (config : Std.Http.Config := testConfig) (closeInput : Bool := false) : IO Unit := + checkHandler raw handler want config closeInput + +/-- The trailer tests ran with a 3-second lingering timeout. -/ +private def trailerConfig : Std.Http.Config := { lingeringTimeout := 3000, generateDate := false } + +/-- A `Transfer-Encoding` field value as the handler sees it, then the body. -/ +private def teAndBody : TestHandler := fun req => do + let te := match req.line.headers.getAll? Header.Name.transferEncoding with + | some vs => String.intercalate "|" (vs.map (fun (v : Header.Value) => v.value) |>.toList) + | none => "<none>" + let body : String ← req.body.readAll + Response.ok |>.text s!"{te};{body}" + +private def ok200 : Want := .all [.status "HTTP/1.1 200", .contains "hello"] + +/-! ## Content-Length (RFC 9110 §8.6, RFC 9112 §6.3) -/ + +#eval checkCases "RFC 9112 §6.3: body framing: machine" #[ + ("§6.3: no CL/TE → empty body", MachineTester.receiving "§6.3: no CL/TE → empty body" + |>.feed (mkGet "/") + |>.step |>.assertNoError |>.assertHasEndHeaders + |>.assertCanPullBodyNow |>.drainBody + |>.assertPulledBody .empty |>.assertLastChunkFinal |>.run), + ("§6.3: Content-Length body delivered exactly", do + let body := "Hello, World!".toUTF8 + MachineTester.receiving "§6.3: Content-Length body delivered exactly" + |>.feed (mkPostHead "/" body.size ++ String.fromUTF8! body) + |>.step |>.assertNoError |>.assertHasEndHeaders + |>.drainBody |>.assertPulledBody body |>.assertLastChunkFinal |>.run), + ("§6.3: multiple Content-Length → badMessage", MachineTester.receiving "§6.3: multiple Content-Length → badMessage" + |>.feed "POST / HTTP/1.1\r\nHost: example.com\r\nContent-Length: 5\r\nContent-Length: 5\r\n\r\n" + |>.step |>.assertFailedWith .badMessage |>.run), + ("§6.3: fixed-length body stops at declared byte count", MachineTester.receiving "§6.3: fixed-length body stops at declared byte count" + |>.feed (mkPostHead "/" 5 ++ "helloworld") + |>.step |>.assertHasEndHeaders + |>.drainBody + |>.assertPulledBody "hello".toUTF8 + |>.assertLastChunkFinal |>.assertNoError |>.run) + ] (·.2) + +#eval checkCases "RFC 9112 §6.3: Content-Length: server" #[ + ("CL body accepted and echoed", mkPost "/echo" "hello" "Connection: close\x0d\n", ok200), + ("duplicate Content-Length same value → 400", + "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 5\x0d\nContent-Length: 5\x0d\nConnection: close\x0d\n\x0d\nhello", .exact r400), + ("duplicate Content-Length different values → 400", + "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 3\x0d\nContent-Length: 5\x0d\nConnection: close\x0d\n\x0d\nabc", .exact r400), + ("duplicate Content-Length 0, 0", "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 0\x0d\nContent-Length: 0\x0d\nConnection: close\x0d\n\x0d\n", .exact r400), + ("duplicate Content-Length 64, 64", + s!"POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 64\x0d\nContent-Length: 64\x0d\nConnection: close\x0d\n\x0d\n{String.ofList (List.replicate 64 'a')}", .exact r400), + ("duplicate Content-Length 3, 4", "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 3\x0d\nContent-Length: 4\x0d\nConnection: close\x0d\n\x0d\nabc", .exact r400), + ("duplicate Content-Length 54, 64", + s!"POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 54\x0d\nContent-Length: 64\x0d\nConnection: close\x0d\n\x0d\n{String.ofList (List.replicate 54 'a')}", .exact r400), + ("non-numeric Content-Length → 400", + "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: abc\x0d\nConnection: close\x0d\n\x0d\nbody", .exact r400), + ("negative Content-Length → 400", + "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: -1\x0d\nConnection: close\x0d\n\x0d\n", .exact r400), + ("underscore in Content-Length → 400", + "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 1_0\x0d\nConnection: close\x0d\n\x0d\n0123456789", .exact r400) + ] fun (_, raw, want) => expectServer raw echoHandler want + +-- The leading-zero table compares the exact echoed body. +#eval checkCases "Content-Length with leading zeros accepted" #[ + ("005", "005", "hello"), + ("0005", "0005", "abcde"), + ("00010", "00010", "0123456789"), + ("0096", "0096", String.ofList (List.replicate 96 'z')) + ] fun (_, cl, body) => + expectServer s!"POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: {cl}\x0d\nConnection: close\x0d\n\x0d\n{body}" + echoHandler (.body body) + + +private def clRequest (method : String) (fields : String) (body : String := "") : String := + s!"{method} / HTTP/1.1\x0d\nHost: example.com\x0d\n{fields}Connection: close\x0d\n\x0d\n{body}" + +-- RFC 9110 §8.6: `Content-Length = 1*DIGIT`; RFC 9112 §6.3 rule 5: an invalid value is unrecoverable. +#eval checkCases "Content-Length forms" #[ + ("1 , 1,2", clRequest "POST" "Content-Length: 1 , 1,2\x0d\n" "a", Want.exact r400), + ("empty", clRequest "POST" "Content-Length: \x0d\n", .exact r400), + ("empty, then 3", clRequest "POST" "Content-Length: \x0d\nContent-Length: 3\x0d\n" "abc", .exact r400), + ("+3", clRequest "POST" "Content-Length: +3\x0d\n" "abc", .exact r400), ("-3", clRequest "POST" "Content-Length: -3\x0d\n" "abc", .exact r400), + ("yes", clRequest "POST" "Content-Length: yes\x0d\n" "abc", .exact r400), ("0x10", clRequest "POST" "Content-Length: 0x10\x0d\n" "abc", .exact r400), + ("1x", clRequest "POST" "Content-Length: 1x\x0d\n" "abc", .exact r400), ("asdf", clRequest "POST" "Content-Length: asdf\x0d\n" "abc", .exact r400), + ("HEAD with Content-Length 0", clRequest "HEAD" "Content-Length: 0\x0d\n", .status "HTTP/1.1 200"), + -- RFC 9110 §9.3.2: the 400 to a HEAD request has no content. + ("HEAD with Content-Length 4 and 5", clRequest "HEAD" "Content-Length: 4\x0d\nContent-Length: 5\x0d\n" "abcde", + .all [.status "HTTP/1.1 400 Bad Request", .absent "\x0d\n\x0d\nBad Request"]) + ] fun (_, raw, want) => expectServer raw echoHandler want (closeInput := true) + +/-! ## Transfer-Encoding (RFC 9112 §6.1, RFC 9110 §5.3) -/ + +/-- The field `Transfer-Encoding` of the head, which must be the single value `expected`. -/ +private def teField (expected : String) (t : MachineTester .receiving) (head : Request.Head) : + MachineTester .receiving := + match head.headers.getAll? Header.Name.transferEncoding with + | some #[value] => + if value.value == expected then t + else t.addError s!"expected Transfer-Encoding {expected.quote}, got {value.value.quote}" + | _ => t.addError "expected one Transfer-Encoding field" + +#eval checkCases "RFC 9112 §6: Transfer-Encoding validation: machine" #[ + -- RFC 9110 §5.3: the field lines of Transfer-Encoding form one list, so these are `gzip, chunked` + ("§6.1: gzip and chunked on two field lines → unsupportedTransferCoding", + MachineTester.receiving "§6.1: gzip and chunked on two field lines → unsupportedTransferCoding" + |>.feed "POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: gzip\r\nTransfer-Encoding: chunked\r\n\r\n" + |>.step |>.assertFailedWith .unsupportedTransferCoding |>.run), + ("§6.1: chunked on two field lines is chunked applied twice → badMessage", + MachineTester.receiving "§6.1: chunked on two field lines is chunked applied twice → badMessage" + |>.feed "POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: chunked\r\nTransfer-Encoding: chunked\r\n\r\n" + |>.step |>.assertFailedWith .badMessage |>.run), + -- RFC 9110 §5.6.1.2: empty list elements are ignored + ("§6.1: accepted codings over two field lines with empty elements", + MachineTester.receiving "§6.1: accepted codings over two field lines with empty elements" + (config := { acceptedTransferCodings := #["gzip"] }) + |>.feed ("POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: gzip, \r\n" ++ + "Transfer-Encoding: , chunked\r\n\r\n3\r\nabc\r\n0\r\n\r\n") + |>.step |>.assertNoError + |>.drainBody |>.assertNoError |>.assertPulledBody "abc".toUTF8 |>.assertLastChunkFinal |>.run), + ("§6.1: Transfer-Encoding: gzip, , chunked → unsupportedTransferCoding", + MachineTester.receiving "§6.1: Transfer-Encoding: gzip, , chunked → unsupportedTransferCoding" + |>.feed "POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: gzip, , chunked\r\n\r\n" + |>.step |>.assertFailedWith .unsupportedTransferCoding |>.run), + ("§6.1: Transfer-Encoding: identity → badMessage", MachineTester.receiving "§6.1: Transfer-Encoding: identity → badMessage" + |>.feed "POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: identity\r\n\r\n" + |>.step |>.assertFailedWith .badMessage |>.run), + -- §6.3 rule 4: a request whose final coding is not `chunked` has no reliable length: 400, not 501 + ("§6.3: Transfer-Encoding: gzip request → badMessage", MachineTester.receiving "§6.3: Transfer-Encoding: gzip request → badMessage" + |>.feed "POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: gzip\r\n\r\nabc" + |>.step |>.assertFailedWith .badMessage |>.run), + -- §6.1: a coding the application decodes itself is accepted; the machine removes only the + -- chunked framing and keeps the field that says which codings are left + ("§6.1: accepted gzip;level=1, chunked → body still coded, field kept", + MachineTester.receiving "§6.1: accepted gzip;level=1, chunked → body still coded, field kept" + (config := { acceptedTransferCodings := #["gzip"] }) + |>.feed ("POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: gzip;level=1, chunked\r\n\r\n" ++ + "3\r\nabc\r\n0\r\n\r\n") + |>.step |>.assertNoError |>.onEndHeaders (teField "gzip;level=1, chunked") + |>.drainBody |>.assertNoError |>.assertPulledBody "abc".toUTF8 |>.assertLastChunkFinal |>.run), + ("§6.1: accepted coding names are compared case-insensitively", + MachineTester.receiving "§6.1: accepted coding names are compared case-insensitively" + (config := { acceptedTransferCodings := #["GZIP"] }) + |>.feed ("POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: Gzip, Chunked\r\n\r\n" ++ + "3\r\nabc\r\n0\r\n\r\n") + |>.step |>.assertNoError |>.onEndHeaders (teField "Gzip, Chunked") + |>.drainBody |>.assertNoError |>.assertPulledBody "abc".toUTF8 |>.run), + ("§6.1: every coding before chunked must be accepted", + MachineTester.receiving "§6.1: every coding before chunked must be accepted" + (config := { acceptedTransferCodings := #["gzip"] }) + |>.feed ("POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: br, gzip, chunked\r\n\r\n" ++ + "3\r\nabc\r\n0\r\n\r\n") + |>.step |>.assertFailedWith .unsupportedTransferCoding |>.run), + -- §6.3 rule 4: an accepted coding does not give a request without a final chunked a length + ("§6.3: accepted gzip without chunked → badMessage", + MachineTester.receiving "§6.3: accepted gzip without chunked → badMessage" + (config := { acceptedTransferCodings := #["gzip"] }) + |>.feed "POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: gzip\r\n\r\nabc" + |>.step |>.assertFailedWith .badMessage |>.run), + -- RFC 9112 §7.1: `chunked` defines no parameters + ("§7: Transfer-Encoding: chunked;x=1 request → badMessage", + MachineTester.receiving "§7: Transfer-Encoding: chunked;x=1 request → badMessage" + |>.feed "POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: chunked;x=1\r\n\r\n0\r\n\r\n" + |>.step |>.assertFailedWith .badMessage |>.run), + ("RFC 9112 §6.1: chunked TE on HTTP/1.0 → badMessage", MachineTester.receiving "RFC 9112 §6.1: chunked TE on HTTP/1.0 → badMessage" + |>.feed "POST / HTTP/1.0\r\nTransfer-Encoding: chunked\r\n\r\n" + |>.step |>.assertFailedWith .badMessage |>.run) + ] (·.2) + +-- §6.1: a server answers a transfer coding it does not understand with 501; only `chunked` is +-- decoded, so any other coding before it is not implemented. +#eval checkCases "RFC 9112 §6.1: unknown codings → 501: machine" #[ + "gzip, chunked", "br, chunked", "gzip;level=1, chunked", "x-custom, gzip, chunked" + ] fun coding => + MachineTester.receiving s!"§6.1: Transfer-Encoding: {coding} request → 501 Not Implemented" + |>.feed (s!"POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: {coding}\r\n\r\n" ++ + "3\r\nabc\r\n0\r\n\r\n") + |>.step |>.assertFailedWith .unsupportedTransferCoding + |>.step + |>.assertOutputStartsWith "HTTP/1.1 501 Not Implemented\r\n" "expected 501" + |>.assertOutputContains "Connection: close\r\n" "the unread body ends the connection" |>.run + +#eval checkCases "RFC 9112 §6.1: Transfer-Encoding validation: server" #[ + ("TE: chunked not last (chunked, gzip) → 400", "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked, gzip\x0d\nConnection: close\x0d\n\x0d\nbody", okHandler, Want.exact r400, testConfig), + ("TE: duplicate chunked → 400", "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked, chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n", okHandler, .exact r400, testConfig), + ("TE: gzip alone (no chunked framing) → 400", "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: gzip\x0d\nConnection: close\x0d\n\x0d\nbody", okHandler, .exact r400, testConfig), + ("TE: deflate alone → 400", "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: deflate\x0d\nConnection: close\x0d\n\x0d\nbody", okHandler, .exact r400, testConfig), + ("TE: identity alone → 400", "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: identity\x0d\nConnection: close\x0d\n\x0d\nbody", okHandler, .exact r400, testConfig), + -- RFC 9110 §5.6.1.2: a recipient ignores empty list elements + ("TE: empty list element before chunked is ignored", "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: ,chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n", echoHandler, ok200, testConfig), + -- RFC 9110 §5.3: the field lines combine into `chunked, gzip`, whose final coding is not chunked + ("TE: field lines chunked then gzip → 400", + "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nTransfer-Encoding: gzip\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n", + echoHandler, .exact r400, testConfig), + ("NUL byte in TE value → 400", "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunk\x00ed\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n", okHandler, .exact r400, testConfig), + ("control char (0x01) in TE value → 400", "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunk\x01ed\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n", okHandler, .exact r400, testConfig), + -- §6.1: only `chunked` is decoded, so the handler never sees a body still coded with another coding + ("gzip, chunked → 501, handler not run", "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: gzip, chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n", echoHandler, .exact r501, testConfig), + -- RFC 9110 §5.3: the same codings over two field lines are the same list + ("gzip and chunked on two field lines → 501", + "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: gzip\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n", + echoHandler, .exact r501, testConfig), + ("br, chunked → 501", "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: br, chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n", echoHandler, .exact r501, testConfig), + -- A coding the handler decodes itself reaches it with the chunked framing removed and the field + -- that names the codings left (#16362) + ("gzip, chunked accepted when listed in acceptedTransferCodings", "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: gzip, chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n", + teAndBody, .all [.status "HTTP/1.1 200", .contains "gzip, chunked;hello"], + { testConfig with acceptedTransferCodings := #["gzip"] }), + ("gzip and chunked on two field lines accepted when gzip is listed", + "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: gzip\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n", + echoHandler, ok200, { testConfig with acceptedTransferCodings := #["gzip"] }), + ("br, chunked → 501 when only gzip is accepted", "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: br, chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n", + echoHandler, .exact r501, { testConfig with acceptedTransferCodings := #["gzip"] }), + ("mixed-case Chunked accepted (codings are lowercased)", "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: Chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n", echoHandler, ok200, testConfig), + ("TE trailing OWS accepted", "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked \x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n", echoHandler, .status "HTTP/1.1 200", testConfig), + -- RFC 9110 §5.6.3: HTAB is optional whitespace before a field value. + ("Transfer-Encoding: HTAB before chunked", "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding:\x09chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n", + okHandler, .status "HTTP/1.1 200", testConfig) + ] fun (_, raw, handler, want, config) => expectServer raw handler want config + + +-- RFC 9112 §6.3 rule 4: a request whose final coding is not chunked gets 400 and a close. +#eval checkCases "Transfer-Encoding values that do not frame the request" #[ + ("fugazi", "Transfer-Encoding: fugazi\x0d\n"), ("chunked, smooth", "Transfer-Encoding: chunked, smooth\x0d\n"), + ("chunked, identity", "Transfer-Encoding: chunked, identity\x0d\n"), + ("chunked, then identity on a second line", "Transfer-Encoding: chunked\x0d\nTransfer-Encoding: identity\x0d\n"), + ("empty", "Transfer-Encoding: \x0d\n"), ("quoted", "Transfer-Encoding: \" chunked\"\x0d\n"), + ("VT before chunked", "Transfer-Encoding: \x0bchunked\x0d\n") + ] fun (_, te) => + expectServer s!"POST / HTTP/1.1\x0d\nHost: example.com\x0d\n{te}Connection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n" + echoHandler (.exact r400) (closeInput := true) + +-- RFC 9112 §6.1: HTTP/1.0 has no chunked coding, so TE with CL is faulty framing. +#eval checkCases "HTTP/1.0 with Transfer-Encoding, Content-Length and keep-alive" #[ + ("400, then close", do + let (r, seen) ← serveRecording ("POST / HTTP/1.0\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\n" ++ + "Content-Length: 5\x0d\nConnection: keep-alive\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\nGET /next HTTP/1.0\x0d\n\x0d\n") + ensure seen.isEmpty s!"the handler ran: {repr seen}" + (Want.exact r400).check r) + ] (·.2) + +/-! ## Chunked syntax (RFC 9112 §7.1) -/ + +#eval checkCases "RFC 9112 §7.1: chunked transfer encoding: machine" #[ + ("§7.1: chunked TE decoded to raw body", MachineTester.receiving "§7.1: chunked TE decoded to raw body" + |>.feed (mkChunkedPost "/" ++ "5\r\nhello\r\n5\r\nworld\r\n0\r\n\r\n") + |>.step |>.assertNoError |>.assertHasEndHeaders + |>.drainBody |>.assertPulledBody "helloworld".toUTF8 |>.assertLastChunkFinal |>.run), + ("§7.1: empty chunked body", MachineTester.receiving "§7.1: empty chunked body" + |>.feed (mkChunkedPost "/" ++ "0\r\n\r\n") + |>.step |>.assertNoError + |>.drainBody |>.assertPulledBody .empty |>.assertLastChunkFinal |>.run) + ] (·.2) + +#eval checkCases "RFC 9112 §7.1: chunked bodies and chunk sizes: server" #[ + ("chunked body accepted and echoed", mkChunked "/" (chunk "hello" ++ chunkEnd) "Connection: close\x0d\n", ok200, false), + ("chunk-size uppercase and leading zeros accepted", "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n000A\x0d\n0123456789\x0d\n0\x0d\n\x0d\n", + .all [.status "HTTP/1.1 200", .contains "0123456789"], false), + ("chunk size 00000000000000005", mkChunked "/" "00000000000000005\x0d\nhello\x0d\n0\x0d\n\x0d\n", + .all [.status "HTTP/1.1 200", .contains "\x0d\n\x0d\nhello"], true), + ("chunk size with 40 leading zeros", mkChunked "/" s!"{String.join (List.replicate 40 "0")}5\x0d\nhello\x0d\n0\x0d\n\x0d\n", + .all [.status "HTTP/1.1 200", .contains "\x0d\n\x0d\nhello"], true), + -- Control: 17 significant digits are still too large. + ("chunk size 10000000000000000", mkChunked "/" "10000000000000000\x0d\nhello\x0d\n", .status "HTTP/1.1 400", true), + ("chunk size ffffffffffffffff1", mkChunked "/" "ffffffffffffffff1\x0d\nhello\x0d\n0\x0d\n\x0d\n", .exact r400, true), + ("chunk terminator must be CRLF → 400", "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n3\x0d\nxxx__1a\x0d\n", .exact r400, true), + ("chunk-size trailing whitespace → 400", "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5 \x0d\nhello\x0d\n0\x0d\n\x0d\n", .exact r400, false) + ] fun (_, raw, want, closeInput) => expectServer raw echoHandler want (closeInput := closeInput) + +#eval checkCases "invalid chunk-size token → 400" #[ + ("G", "G\x0d\nabc\x0d\n0\x0d\n\x0d\n"), + ("g", "g\x0d\nabc\x0d\n0\x0d\n\x0d\n"), ("z", "z\x0d\nabc\x0d\n0\x0d\n\x0d\n"), ("Z", "Z\x0d\nabc\x0d\n0\x0d\n\x0d\n"), + ("@", "@\x0d\nabc\x0d\n0\x0d\n\x0d\n"), ("!", "!\x0d\nabc\x0d\n0\x0d\n\x0d\n"), ("x", "x\x0d\nabc\x0d\n0\x0d\n\x0d\n"), + ("GG", "GG\x0d\nhello\x0d\n0\x0d\n\x0d\n") + ] fun (_, chunked) => expectServer ("POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n" ++ chunked) echoHandler (.exact r400) + + +#eval checkCases "Chunk-size table: server" #[ + ("aA is 170", s!"aA\x0d\n{String.ofList (List.replicate 170 'x')}\x0d\n0\x0d\n\x0d\n", Want.body (String.ofList (List.replicate 170 'x'))), + ("ffffffffffffffff is too large", "ffffffffffffffff\x0d\nhello\x0d\n0\x0d\n\x0d\n", .status "HTTP/1.1 413"), + ("100 digits", s!"{String.ofList (List.replicate 100 '1')}\x0d\nhello\x0d\n0\x0d\n\x0d\n", .exact r400), + ("567xf8a", "567xf8a\x0d\nhello\x0d\n0\x0d\n\x0d\n", .exact r400), ("567f8a CR foo", "567f8a\x0dfoo\x0d\nhello\x0d\n0\x0d\n\x0d\n", .exact r400), + ("0x5", "0x5\x0d\nhello\x0d\n0\x0d\n\x0d\n", .exact r400), ("an empty size line", "\x0d\nhello\x0d\n0\x0d\n\x0d\n", .exact r400), + ("NUL after a valid size", "5\x00\x0d\nhello\x0d\n0\x0d\n\x0d\n", .exact r400) + ] fun (_, chunked, want) => + expectServer ("POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n" ++ chunked) + echoHandler want (closeInput := true) + +-- The sizes exceed the default `maxChunkSize`; the machine is configured so only the syntax decides. +#eval checkCases "Chunk-size line syntax: machine" #[ + ("3735AB1;foo bar* → badMessage", MachineTester.receiving "3735AB1;foo bar*" { maxChunkSize := 1 <<< 30, maxBodySize := 1 <<< 30 } + |>.feed (mkChunkedPost "/" ++ "3735AB1;foo bar*\r\nab") |>.step |>.pullBody + |>.assertFailedWith .badMessage |>.run), + ("3735ab1 ; baz is accepted", MachineTester.receiving "3735ab1 ; baz " { maxChunkSize := 1 <<< 30, maxBodySize := 1 <<< 30 } + |>.feed (mkChunkedPost "/" ++ "3735ab1 ; baz \r\nab") |>.step |>.pullBody + |>.assertNoError |>.assertPulledBody "ab".toUTF8 |>.run) + ] (·.2) + +-- RFC 9112 §7.1: chunk framing lines end in CRLF; RFC 9112 §2.2 leaves bare LF to the recipient. +#eval checkCases "Bare LF or stray CR in chunk framing" #[ + ("1 LF a", "1\na\x0d\n0\x0d\n\x0d\n"), ("1 CR CR LF a", "1\x0d\x0d\na\x0d\n0\x0d\n\x0d\n"), + ("bare LF after the data", "1\x0d\na\n0\x0d\n\x0d\n"), ("1; LF a", "1;\na\x0d\n0\x0d\n\x0d\n"), + ("0 CRLF LF", "0\x0d\n\n") + ] fun (_, chunked) => + expectServer ("POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n" ++ chunked) + echoHandler (.exact r400) (closeInput := true) + +/-! ## Chunk extensions (RFC 9112 §7.1.1) -/ + +#eval checkCases "RFC 9112 §7.1.1: chunk extensions: machine" #[ + ("§7.1.1: chunk extensions preserved in PulledChunk", MachineTester.receiving "§7.1.1: chunk extensions preserved in PulledChunk" + |>.feed (mkChunkedPost "/" ++ "5;quality=0.9\r\nhello\r\n0\r\n\r\n") + |>.step |>.assertHasEndHeaders + |>.drainBody |>.assertPulledBody "hello".toUTF8 + |>.onMachine (fun t _ => + match t.pulled[0]? with + | none => t.addError "no chunks pulled" + | some c => + let exts := c.chunk.extensions.map fun (n, v) => (n.value, v.map (·.value)) + if exts == #[("quality", some "0.9")] then t + else t.addError s!"expected the extension quality=0.9, got {repr exts}") + |>.run) + ] (·.2) + +#eval checkCases "RFC 9112 §7.1.1: chunk extensions: server" #[ + ("chunk extensions with token and quoted value accepted", "5;ext=val;quoted=\"ok\"\x0d\nhello\x0d\n0\x0d\n\x0d\n", ok200), + ("extension with quoted-string value → accepted", "5;ext=\"hello world\"\x0d\nhello\x0d\n0\x0d\n\x0d\n", .status "HTTP/1.1 200"), + ("multiple name=value extensions → accepted", "5;a=1;b=2;c=3\x0d\nhello\x0d\n0\x0d\n\x0d\n", .status "HTTP/1.1 200"), + ("name-only extension (no value) → accepted", "5;novalue\x0d\nhello\x0d\n0\x0d\n\x0d\n", ok200), + ("extension on terminal zero-chunk → accepted", "5\x0d\nhello\x0d\n0;final-ext=done\x0d\n\x0d\n", .status "HTTP/1.1 200"), + ("non-token character in ext name → 400", "5;bad@name\x0d\nhello\x0d\n0\x0d\n\x0d\n", .exact r400) + ] fun (_, chunked, want) => expectServer ("POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n" ++ chunked) echoHandler want + +#eval checkCases "obs-text in a quoted chunk extension" #[ + ";n=\"é\"", ";n=\"a\\é\"", ";a=1;n=\"é\";b" + ] fun ext => + expectServer (mkChunked "/" s!"5{ext}\x0d\nhello\x0d\n0\x0d\n\x0d\n") echoHandler + (.all [.status "HTTP/1.1 200", .contains "\x0d\n\x0d\nhello"]) (closeInput := true) + +/-! ## Trailers (RFC 9112 §7.1.2, RFC 9110 §6.5) -/ + +#eval checkCases "RFC 9110 §6.5: forbidden trailer fields: machine" #[ + ("§6.5: forbidden trailer field in a request → badMessage", MachineTester.receiving "§6.5: forbidden trailer field in a request → badMessage" + |>.feed (mkChunkedPost "/" ++ "2\r\nok\r\n0\r\nCache-Control: no-cache\r\n\r\n") + |>.step |>.drainBody |>.assertFailedWith .badMessage |>.run) + ] (·.2) + +#eval checkCases "Trailer fields: server" #[ + ("Single trailer header.", "5\x0d\nhello\x0d\n0\x0d\nChecksum: abc123\x0d\n\x0d\n", ok200), + ("Multiple trailer headers.", + "5\x0d\nhello\x0d\n0\x0d\nChecksum: abc123\x0d\nExpires: Thu, 01 Dec 1994 16:00:00 GMT\x0d\nX-Custom: value\x0d\n\x0d\n", ok200), + ("Terminal chunk extensions can precede trailers.", "5\x0d\nhello\x0d\n0;ext=val\x0d\nX-Trailer: yes\x0d\n\x0d\n", ok200), + ("Trailer syntax validation: no colon", "3\x0d\nabc\x0d\n0\x0d\nBadTrailer value\x0d\n\x0d\n", .exact r400), + ("Trailer syntax validation: leading whitespace", "3\x0d\nabc\x0d\n0\x0d\n X-Bad: folded\x0d\n\x0d\n", .exact r400), + ("Trailer syntax validation: space in name", "3\x0d\nabc\x0d\n0\x0d\nBad Name: value\x0d\n\x0d\n", .exact r400), + ("Trailer byte-level validation: NUL in name", "3\x0d\nabc\x0d\n0\x0d\nX-Bad\x00Name: value\x0d\n\x0d\n", .exact r400), + ("Trailer byte-level validation: NUL in value", "3\x0d\nabc\x0d\n0\x0d\nX-Header: bad\x00value\x0d\n\x0d\n", .exact r400), + ("Trailer byte-level validation: 0x01 in value", "3\x0d\nabc\x0d\n0\x0d\nX-Header: bad\x01value\x0d\n\x0d\n", .exact r400), + ("forbidden-field policy: content-length in trailer", "5\x0d\nhello\x0d\n0\x0d\nContent-Length: 1000\x0d\n\x0d\n", .exact r400), + ("forbidden-field policy: transfer-encoding in trailer", "5\x0d\nhello\x0d\n0\x0d\nTransfer-Encoding: chunked\x0d\n\x0d\n", .exact r400), + ("forbidden-field policy: host in trailer", "5\x0d\nhello\x0d\n0\x0d\nHost: evil.example\x0d\n\x0d\n", .exact r400), + ("forbidden-field policy: connection in trailer", "5\x0d\nhello\x0d\n0\x0d\nConnection: keep-alive\x0d\n\x0d\n", .exact r400), + ("forbidden-field policy: authorization in trailer", "5\x0d\nhello\x0d\n0\x0d\nAuthorization: Bearer token\x0d\n\x0d\n", .exact r400), + ("forbidden-field policy: cache-control in trailer", "5\x0d\nhello\x0d\n0\x0d\nCache-Control: no-cache\x0d\n\x0d\n", .exact r400), + ("forbidden-field policy: te in trailer", "5\x0d\nhello\x0d\n0\x0d\nTE: trailers\x0d\n\x0d\n", .exact r400), + ("Forbidden trailer field names are rejected regardless of case.", "5\x0d\nhello\x0d\n0\x0d\nCONTENT-LENGTH: 0\x0d\n\x0d\n", .exact r400), + ("a forbidden field before an allowed one", "5\x0d\nhello\x0d\n0\x0d\nContent-Length: 0\x0d\nChecksum: abc\x0d\n\x0d\n", .exact r400) + ] fun (_, chunked, want) => expectServer ("POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n" ++ chunked) echoHandler want trailerConfig + + +-- RFC 9112 §7.1.2, §2.2: a malformed trailer section must not let the next bytes become a request. +#eval checkCases "Trailer smuggling: the follower is never served" #[ + ("a trailer line without a colon", "0\x0d\nBadTrailer\x0d\n\x0d\n"), + ("a trailer section ended by a bare LF", "0\x0d\n\n"), + ("a trailer line ended by a bare LF", "0\x0d\nX-T: v\n\x0d\n"), + ("a bare CR in a trailer", "0\x0d\nX-T: v\x0dw\x0d\n\x0d\n") + ] fun (_, tail) => do + let (r, seen) ← serveRecording ("POST /first HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\n\x0d\n3\x0d\nabc\x0d\n" ++ + tail ++ "GET /smuggled HTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n") (config := trailerConfig) + ensure (!seen.any (·.target == "/smuggled")) s!"/smuggled was served: {repr seen}" + (Want.all [.status "HTTP/1.1 400", .responses 1]).check r + +/-! ## Truncated bodies (RFC 9112 §6.3, §7.1, §8) -/ + +#eval checkCases "Truncated bodies: machine" #[ + ("§6.3: noMoreInput mid fixed-length body → connectionClosed", MachineTester.receiving "§6.3: noMoreInput mid fixed-length body → connectionClosed" + |>.feed (mkPostHead "/" 10 ++ "hello") + |>.step |>.assertHasEndHeaders |>.noMoreInput + |>.drainBody |>.assertFailedWith .connectionClosed |>.run), + ("§7.1: noMoreInput mid chunked body → connectionClosed", MachineTester.receiving "§7.1: noMoreInput mid chunked body → connectionClosed" + |>.feed (mkChunkedPost "/" ++ "5\r\n") -- chunk size line but no chunk payload + |>.step |>.assertHasEndHeaders |>.noMoreInput + |>.pullBody -- tries to read 5-byte chunk data, hits EOF → connectionClosed + |>.assertFailedWith .connectionClosed |>.run) + ] (·.2) + +#eval checkCases "Incomplete trailer section at EOF" #[ + -- The client closes both directions: the server returns (inside the guard) and writes nothing. + ("trailer line without the final CRLF, then a full close", do + let (client, server) ← Internal.Mock.new + let raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n3\x0d\nabc\x0d\n0\x0d\nX-Trailer: value\x0d\n".toUTF8 + let response ← Async.block do + client.send raw + client.close + Server.serveConnection server echoHandler { lingeringTimeout := 1000, generateDate := false } |>.run + return (← client.recv?).getD .empty + ensure (response.size == 0) s!"expected no response bytes, got {response.size}"), + -- Only the client's sending side closes: the truncated message is answered with 400. + ("trailer line without the final CRLF, then a half close", checkHandler + "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n3\x0d\nabc\x0d\n0\x0d\nX-Trailer: value\x0d\n" echoHandler (.exact r400) (closeInput := true)) + ] (·.2) + + +-- RFC 9112 §8: a chunked message without its last chunk and trailer section is incomplete. The +-- prefix ending `0\r\n` waits for policy P2. +#eval checkCases "Every proper prefix of a chunked body, then EOF" #[ + ("prefixes", do + let head := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n" + let body := "5;e=v\x0d\nhello\x0d\n0\x0d\nX-T: v\x0d\n\x0d\n" + let p2 := "5;e=v\x0d\nhello\x0d\n0\x0d\n".length + for n in [0:body.length] do + if n == p2 then continue + try checkHandler (head ++ String.ofList (body.toList.take n)) echoHandler (.exact r400) trailerConfig (closeInput := true) + catch e => throw <| IO.userError s!"prefix of {n} body bytes: {e}") + ] (·.2) + +/-! ## Smuggling vectors (RFC 9112 §6.1, §6.3) -/ + +#eval checkCases "Smuggling vectors: machine" #[ + ("§6.3: Transfer-Encoding on two field lines with Content-Length → badMessage", + MachineTester.receiving "§6.3: Transfer-Encoding on two field lines with Content-Length → badMessage" + |>.feed ("POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: gzip\r\n" ++ + "Transfer-Encoding: chunked\r\nContent-Length: 3\r\n\r\n") + |>.step |>.assertFailedWith .badMessage |>.run), + ("§6.3: CL + TE mixed → badMessage (request-smuggling prevention)", + MachineTester.receiving "§6.3: CL + TE mixed → badMessage (request-smuggling prevention)" + |>.feed "POST / HTTP/1.1\r\nHost: example.com\r\nContent-Length: 5\r\nTransfer-Encoding: chunked\r\n\r\n" + |>.step |>.assertFailedWith .badMessage |>.run) + ] (·.2) + +-- TE + CL → request smuggling prevention. +#eval checkCases "TE + Content-Length → 400: server" #[ + ("TE + Content-Length → 400", "5", okHandler), + ("TE + Content-Length: 0", "0", echoHandler), ("TE + Content-Length: 1", "1", echoHandler), + ("TE + Content-Length: 5", "5", echoHandler), ("TE + Content-Length: 128", "128", echoHandler) + ] fun (_, cl, handler) => + expectServer s!"POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nContent-Length: {cl}\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n" + handler (.exact r400) + +#eval checkCases "Smuggling vectors: exact answers" #[ + ("Request smuggling: CL.TE", + "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 6\x0d\nTransfer-Encoding: chunked\x0d\n\x0d\n0\x0d\n\x0d\nX"), + ("Request smuggling: TE.CL", + "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nContent-Length: 3\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n"), + -- RFC 9112 §5.1: no whitespace is allowed between a field name and the colon. + ("Transfer-Encoding : chunked", + "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding : chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n") + ] fun (_, raw) => checkHandler raw okHandler (.exact r400) (closeInput := true)
diff --git a/tests/async/elab/async_http_h1_request_head.lean b/tests/async/elab/async_http_h1_request_head.lean new file mode 100644 index 0000000..9cf868c --- /dev/null +++ b/tests/async/elab/async_http_h1_request_head.lean
@@ -0,0 +1,491 @@ +module + +import Std.Http.Test.Helpers +import Std.Http.Test.Machine + +/-! +# HTTP/1.1 request heads + +What a server accepts as a request head: the request line, leading empty lines, the method, the +version, the request-target form, `Host`, field lines, and heads that are not HTTP at all. Each rule +has its machine table (`MachineTester`) next to its `serveConnection` table, which pins the exact +response. RFC 9112 §2.2, §2.3, §3, §5; RFC 9110 §5.5, §7.2, §9.1, §9.3.6. +-/ + +open Std Http +open Std.Http.Protocol.H1 +open Std.Http.Internal.Test + +/-- Serves `raw` with `okHandler`; with `closeInput` the client sends EOF after it. -/ +private def expectServer (raw : String) (want : Want) (closeInput : Bool := false) : IO Unit := + checkHandler raw okHandler want (closeInput := closeInput) + +/-! ## Request-line syntax (RFC 9112 §3) -/ + +#eval checkCases "RFC 9112 §3: request-line parse failures" #[ + ("missing version → 400", "GET /\x0d\nHost: example.com\x0d\n\x0d\n", Want.exact r400, false), + ("missing URI (double space) → 400", "GET HTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n", .exact r400, false), + ("extra spaces in request-line → 400", + "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n", .exact r400, false), + ("whitespace-only request-line → 400", " \x0d\n\x0d\n", .exact r400, false), + ("no spaces in request-line → 400", "GETHTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n", .exact r400, false), + ("garbage after request-line version → 400", + "GET / HTTP/1.1 xxxxxx\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n", .exact r400, false), + ("empty connection → silent close", "", .exact "", true) + ] fun (_, raw, want, closeInput) => expectServer raw want closeInput + +#eval checkCases "RFC 9112 §2.2, §3: early invalid bytes" #[ + ("NUL byte → 400", "\x00"), + ("SP byte → 400", "\x20"), + ("TLS client-hello prefix → 400", "\x16\x03\x01\x00\xa5") + ] fun (_, raw) => expectServer raw (.exact r400) (closeInput := true) + + +#eval checkCases "Request-line shapes that are not a request line" #[ + (" / HTTP/1.1", " / HTTP/1.1\x0d\nHost: a\x0d\n\x0d\n"), + (" HTTP/1.1", " HTTP/1.1\x0d\nHost: a\x0d\n\x0d\n"), + (" GET / HTTP/1.1", " GET / HTTP/1.1\x0d\nHost: a\x0d\n\x0d\n"), + ("GET /spaced out HTTP/1.1", "GET /spaced out HTTP/1.1\x0d\nHost: a\x0d\n\x0d\n"), + ("a token with no SP gets 400, not 501", "gibberish\x0d\n\x0d\n"), + ("CR as a separator", "GET\x0d/\x0dHTTP/1.1\x0d\nHost: a\x0d\n\x0d\n"), + ("LF inside the request line", "GET\n/ HTTP/1.1\x0d\nHost: a\x0d\n\x0d\n"), + ("CR CR LF after the version", "GET / HTTP/1.1\x0d\x0d\nHost: a\x0d\n\x0d\n") + ] fun (_, raw) => checkHandler raw okHandler (.exact r400) (closeInput := true) + +-- RFC 9112 §3: an invalid request line SHOULD get 400, without waiting for more input. +#eval checkCases "A request line with no version fails at once" #[ + ("GET / then an empty line", "GET /\r\n\r\n"), + ("GET /x then a field", "GET /x\r\nHost:a\r\n\r\n") + ] fun (label, raw) => MachineTester.receiving label |>.feed raw |>.step |>.assertFailedWith .badMessage |>.run + +-- RFC 9112 §8: an incomplete request is never handed to the handler. +#eval checkCases "Every proper prefix of a request head, then EOF" #[ + ("prefixes of a GET head", do + let head := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n" + for n in [1:head.length] do + let (r, seen) ← serveRecording (String.ofList (head.toList.take n)) (closeInput := true) + ensure seen.isEmpty s!"prefix of {n} bytes: the handler ran" + ensure (String.fromUTF8! r == r400) s!"prefix of {n} bytes: got {(String.fromUTF8! r).quote}"), + ("zero bytes, then EOF", do + let (r, seen) ← serveRecording "" (closeInput := true) + ensure (r.isEmpty && seen.isEmpty) "expected a silent close") + ] (·.2) + +/-! ## Leading empty lines (RFC 9112 §2.2) -/ + +#eval checkCases "RFC 9112 §2.2: leading CRLF before request-line: machine" #[ + ("§2.2: leading CRLF ignored", MachineTester.receiving "§2.2: leading CRLF ignored" (config := { maxLeadingEmptyLines := 8 }) + |>.feed "\r\n\r\nGET / HTTP/1.1\r\nHost: example.com\r\n\r\n" + |>.step |>.assertNoError |>.assertHasEndHeaders |>.run), + ("§2.2: maximum leading CRLFs", MachineTester.receiving "§2.2: maximum leading CRLFs" (config := { maxLeadingEmptyLines := 2 }) + |>.feed "\r\n\r\n\r\nGET / HTTP/1.1\r\nHost: example.com\r\n\r\n" + |>.step |>.assertFailedWith .badMessage |>.run) + ] (·.2) + +#eval checkCases "RFC 9112 §2.2: empty lines before a request and before EOF: server" #[ + ("CRLF after a body, then EOF", "POST / HTTP/1.1\x0d\nHost: a\x0d\nContent-Length: 2\x0d\n\x0d\nhi\x0d\n", + Want.all [.status "HTTP/1.1 200", .responses 1], true), + ("only empty lines, then EOF", "\x0d\n\x0d\n", .exact "", true), + ("single leading CRLF accepted", + "\x0d\nGET / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n", .exact okResponse, false) + ] fun (_, raw, want, closeInput) => expectServer raw want closeInput + + +#eval checkCases "Empty lines between pipelined requests" #[ + ("CRLF CRLF after a body, then a GET", do + let (r, seen) ← serveRecording ("POST / HTTP/1.1\x0d\nHost: a\x0d\nContent-Length: 3\x0d\n\x0d\nABC" ++ + "\x0d\n\x0d\nGET / HTTP/1.1\x0d\nHost: a\x0d\nConnection: close\x0d\n\x0d\n") (closeInput := true) + (Want.responses 2).check r + ensure (seen.size == 2) s!"expected 2 handler calls, got {seen.size}") + ] (·.2) + +/-! ## Method (RFC 9110 §9.1, RFC 9112 §3) -/ + +-- A well-formed method the server does not recognize, or one longer than any it implements, is +-- answered with 501. Methods are case-sensitive. +#eval checkCases "RFC 9110 §9.1: unrecognized methods: machine" #[ + ("LEAN", "LEAN"), ("GETX", "GETX"), ("get", "get"), ("X-CUSTOM", "X-CUSTOM"), ("UPDATEX", "UPDATEX"), + ("a 65-byte token", String.ofList (List.replicate 65 'G')) + ] fun (label, method) => + MachineTester.receiving s!"§3: unrecognized method {label} → unsupportedMethod" + |>.feed s!"{method} / HTTP/1.1\r\nHost: example.com\r\n\r\n" + |>.step |>.assertFailedWith .unsupportedMethod + |>.step |>.assertOutputStartsWith "HTTP/1.1 501 Not Implemented\r\n" "expected 501" |>.run + +-- A method that is not a token makes the request line malformed. +#eval checkCases "RFC 9112 §3: non-token methods: machine" #[ + "G@T / HTTP/1.1", "GÉT / HTTP/1.1", "GET\t/ HTTP/1.1", "GETHTTP/1.1" + ] fun line => + MachineTester.receiving s!"§3: {line.quote} → badMessage" + |>.feed s!"{line}\r\nHost: example.com\r\n\r\n" + |>.step |>.assertFailedWith .badMessage |>.run + +#eval checkCases "RFC 9110 §9: method validation: server" #[ + ("unknown method FOOBAR → 501", "FOOBAR / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n", r501), + ("lowercase method → 501", "get / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n", r501), + ("non-ASCII method → 400", "GÉT / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n", r400), + ("very long unrecognized method → 501", + s!"{String.ofList (List.replicate 100 'G')} / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n", r501), + ("token method with hyphen (X-CUSTOM) → 501", + "X-CUSTOM / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n", r501), + ("method that starts with a known one (GETX) → 501", + "GETX / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n", r501) + ] fun (_, raw, want) => expectServer raw (.exact want) + +/-! ## Version (RFC 9112 §2.3, RFC 9110 §2.5) -/ + +#eval checkCases "RFC 9112 §2.3: HTTP version: machine" #[ + ("§2: HTTP/2.0 → unsupportedVersion", MachineTester.receiving "§2: HTTP/2.0 → unsupportedVersion" + |>.feed "GET / HTTP/2.0\r\nHost: example.com\r\n\r\n" + |>.step |>.assertFailedWith .unsupportedVersion |>.run), + ("§2: HTTP/0.9 → unsupportedVersion", MachineTester.receiving "§2: HTTP/0.9 → unsupportedVersion" + |>.feed "GET / HTTP/0.9\r\nHost: example.com\r\n\r\n" + |>.step |>.assertFailedWith .unsupportedVersion |>.run), + ("§2: HTTP/3.0 → unsupportedVersion", MachineTester.receiving "§2: HTTP/3.0 → unsupportedVersion" + |>.feed "GET / HTTP/3.0\r\nHost: example.com\r\n\r\n" + |>.step |>.assertFailedWith .unsupportedVersion |>.run) + ] (·.2) + +-- RFC 9110 §6.2: a higher minor version is processed as the highest minor version the recipient +-- implements. +#eval checkCases "RFC 9110 §6.2: a higher minor version is read as HTTP/1.1: machine" #[ + "HTTP/1.2", "HTTP/1.9" + ] fun version => + MachineTester.receiving s!"§2: {version} request is read as HTTP/1.1" + |>.feed s!"GET / {version}\r\nHost: example.com\r\n\r\n" + |>.step |>.assertNoError |>.assertHasEndHeaders |>.assertKeepAlive + |>.onEndHeaders (fun t head => + if head.version != .v11 then t.addError s!"expected HTTP/1.1, got {repr head.version}" else t) + |>.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody |>.step + |>.assertOutputStartsWith "HTTP/1.1 200 OK\r\nContent-Length: 0\r\n\r\n" "expected an HTTP/1.1 response" + |>.assertKeepAlive |>.run + +#eval checkCases "RFC 9112 §2.3, RFC 9110 §2.5: HTTP version: server" #[ + ("HTTP/2.0 → 505", "GET / HTTP/2.0\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") + ] fun (_, raw) => expectServer raw (.exact r505) + + +#eval checkCases "Version table" #[ + ("HTTP/0.0 → 505", "HTTP/0.0", r505), + ("HTTP/3.14", "HTTP/3.14", r400), ("HTTP/12.3", "HTTP/12.3", r400), ("HTTP/1.+1", "HTTP/1.+1", r400), + ("HTTP/1,1", "HTTP/1,1", r400), ("HTTP/1", "HTTP/1", r400), ("http/1.1", "http/1.1", r400), + ("HTTP/1.1/", "HTTP/1.1/", r400), ("FUBAR", "FUBAR", r400), ("HTTP/9.9.9", "HTTP/9.9.9", r400), + ("HTTP/-9_9_9.+9_9_9", "HTTP/-9_9_9.+9_9_9", r400), ("HTTP/909876543210.0", "HTTP/909876543210.0", r400), + ("HTTP/1.909876543210", "HTTP/1.909876543210", r400) + ] fun (_, v, want) => checkHandler s!"GET / {v}\x0d\nHost: a\x0d\nConnection: close\x0d\n\x0d\n" okHandler (.exact want) + +#eval checkCases "A malformed version fails before its CRLF" #[ + ("GET / HTTP/1!", MachineTester.receiving "GET / HTTP/1!" |>.feed "GET / HTTP/1!" |>.step + |>.assertFailedWith .badMessage |>.run) + ] (·.2) + +/-! ## Request-target form (RFC 9112 §3.2) -/ + +#eval checkCases "RFC 9112 §3.2: request-target form: machine" #[ + ("§3.2.1: origin-form path preserved", MachineTester.receiving "§3.2.1: origin-form path preserved" + |>.feed "GET /api/v1/users?active=true HTTP/1.1\r\nHost: api.example.com\r\n\r\n" + |>.step |>.assertNoError + |>.onEndHeaders (fun t head => + let path := toString head.uri.path + if path != "/api/v1/users" then t.addError s!"expected path /api/v1/users, got {path}" + else t) + |>.run), + ("§3.2: non-OPTIONS asterisk-form → badMessage", MachineTester.receiving "§3.2: non-OPTIONS asterisk-form → badMessage" + |>.feed "GET * HTTP/1.1\r\nHost: example.com\r\n\r\n" + |>.step |>.assertFailedWith .badMessage |>.run), + ("§3.2: non-CONNECT authority-form → badMessage", MachineTester.receiving "§3.2: non-CONNECT authority-form → badMessage" + |>.feed "GET example.com:80 HTTP/1.1\r\nHost: example.com\r\n\r\n" + |>.step |>.assertFailedWith .badMessage |>.run), + ("§3.3: absolute-form with explicit :80", MachineTester.receiving "§3.3: absolute-form with explicit :80" + |>.feed "GET http://example.com:80/path HTTP/1.1\r\nHost: example.com\r\n\r\n" + |>.step |>.assertNoError |>.assertHasEndHeaders |>.run) + ] (·.2) + +#eval checkCases "RFC 9112 §3.2: request target forms: server" #[ + ("GET authority-form → 400", "GET example.com:443 HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n", r400), + ("GET asterisk-form → 400", "GET * HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n", r400), + ("OPTIONS * accepted", "OPTIONS * HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n", okResponse), + ("absolute-form URI accepted", "GET http://example.com/path HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n", okResponse) + ] fun (_, raw, want) => expectServer raw (.exact want) + + +private def pathAndAuthority : TestHandler := fun req => + Response.ok |>.text s!"{toString req.line.uri}|{req.line.uri.authority?.isNone}" + +-- RFC 9112 §3.2.1: an origin-form target may begin with `//`; it is a path, never an authority. +#eval checkCases "Origin-form targets that begin with `//`" #[ + "//user@host/is/actually/a/path/", "//", "///////", "//@", "//://///" + ] fun target => + checkHandler s!"GET {target} HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n" pathAndAuthority + (.body s!"{target}|true") + +#eval checkCases "Targets that fit no form" #[ + "../../../../etc/passwd", "sd", "test?test", "x@x.com", "?x", "example.com/", "1234567890", + ":a@example.net", "http:www.example.com/", "/p#f", "http://h/p#f" + ] fun target => + checkHandler s!"GET {target} HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n" okHandler (.exact r400) + +#eval checkCases "Accepted target forms" #[ + ("the scheme is case-insensitive", "GET HTTP://example.com/ HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n"), + ("OPTIONS * over HTTP/1.0 without Host", "OPTIONS * HTTP/1.0\x0d\n\x0d\n"), + ("absolute-form of another scheme reaches the handler", "GET urn:isbn:0451450523 HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") + ] fun (_, raw) => checkHandler raw okHandler (.status "HTTP/1.1 200") + +private def targetRequest (target : ByteArray) : ByteArray := + "GET ".toUTF8 ++ target ++ " HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 + +-- RFC 3986 §2: a byte outside the URI grammar must be percent-encoded. +#eval checkCases "Raw bytes in the target" #[ + ("0x80", ByteArray.mk #[0x2F, 0x61, 0x80], Want.exact r400), ("0xEE", ByteArray.mk #[0x2F, 0x61, 0xEE], .exact r400), + ("HTAB", "/a\tb".toUTF8, .exact r400), ("DEL", "/a\x7fb".toUTF8, .exact r400), ("NUL", "/a\x00b".toUTF8, .exact r400), + ("raw UTF-8 in the path", "/caf\xc3\xa9".toUTF8, .exact r400), ("raw UTF-8 in the query", "/?q=caf\xc3\xa9".toUTF8, .exact r400), + ("an invalid UTF-8 byte", ByteArray.mk #[0x2F, 0xC3], .exact r400), + ("`", "/a`b".toUTF8, .exact r400), ("{", "/a{b".toUTF8, .exact r400), ("}", "/a}b".toUTF8, .exact r400), ("^", "/a^b".toUTF8, .exact r400), + ("|", "/a|b".toUTF8, .exact r400), ("\\", "/a\\b".toUTF8, .exact r400), ("[", "/a[b".toUTF8, .exact r400), ("]", "/a]b".toUTF8, .exact r400), + ("\"", "/a\"b".toUTF8, .exact r400), + ("percent-encoded forms", "/%80%EE%09%7F%00%C3%A9%60%7B%7D%5E%7C%5C%5B%5D%22?q=caf%C3%A9".toUTF8, .status "HTTP/1.1 200") + ] fun (_, target, want) => do want.check (← serveBytes (targetRequest target) okHandler) + +-- RFC 9110 §4.2.4: a recipient SHOULD treat userinfo in a request-target as an error. +#eval checkCases "absolute-form with userinfo" #[ + ("http://user:pass@example.com/", "GET http://user:pass@example.com/ HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") + ] fun (_, raw) => checkHandler raw okHandler (.exact r400) + +#eval checkCases "CONNECT targets that are not an authority" #[ + ("origin-form", "CONNECT /_goRPC_ HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n"), + ("a bad authority", "CONNECT []%20%48%54%54%50 HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") + ] fun (_, raw) => checkHandler raw okHandler (.exact r400) + +/-! ## Host (RFC 9112 §3.2, RFC 9110 §7.2) -/ + +#eval checkCases "RFC 9112 §3.2: Host: machine" #[ + ("§3.2: HTTP/1.1 missing Host → badMessage", MachineTester.receiving "§3.2: HTTP/1.1 missing Host → badMessage" + |>.feed "GET / HTTP/1.1\r\n\r\n" + |>.step |>.assertFailedWith .badMessage |>.run), + ("§3.2: HTTP/1.1 duplicate Host → badMessage", MachineTester.receiving "§3.2: HTTP/1.1 duplicate Host → badMessage" + |>.feed "GET / HTTP/1.1\r\nHost: a.com\r\nHost: b.com\r\n\r\n" + |>.step |>.assertFailedWith .badMessage |>.run), + ("§7.2: HTTP/1.1 empty Host valid for origin-form", MachineTester.receiving "§7.2: HTTP/1.1 empty Host valid for origin-form" + |>.feed "GET / HTTP/1.1\r\nHost: \r\n\r\n" + |>.step |>.assertNoError |>.assertHasEndHeaders |>.run), + ("RFC 9112 §3.2: HTTP/1.0 without Host → valid", MachineTester.receiving "RFC 9112 §3.2: HTTP/1.0 without Host → valid" + |>.feed "GET / HTTP/1.0\r\n\r\n" + |>.step |>.assertNoError |>.assertHasEndHeaders |>.run), + ("RFC 9112 §3.2: HTTP/1.0 single Host → valid", MachineTester.receiving "RFC 9112 §3.2: HTTP/1.0 single Host → valid" + |>.feed "GET / HTTP/1.0\r\nHost: example.com\r\n\r\n" + |>.step |>.assertNoError |>.assertHasEndHeaders |>.run), + ("RFC 9112 §3.2: HTTP/1.0 duplicate Host → badMessage", MachineTester.receiving "RFC 9112 §3.2: HTTP/1.0 duplicate Host → badMessage" + |>.feed "GET / HTTP/1.0\r\nHost: a.com\r\nHost: b.com\r\n\r\n" + |>.step |>.assertFailedWith .badMessage |>.run), + -- RFC 9110 §7.2: `Host` is an RFC 3986 `host`, which may be percent-encoded. The field reaches + -- the handler as sent. + ("§3.2: percent-encoded Host accepted", MachineTester.receiving "§3.2: percent-encoded Host accepted" + |>.feed "GET / HTTP/1.1\r\nHost: ex%41mple.com\r\n\r\n" + |>.step |>.assertNoError + |>.onEndHeaders (fun t head => + match head.headers.get? .host with + | some v => if v.value == "ex%41mple.com" then t else t.addError s!"expected Host=ex%41mple.com, got {v.value.quote}" + | none => t.addError "missing Host header") + |>.run), + ("§3.3: percent-encoded absolute-form host decoded", MachineTester.receiving "§3.3: percent-encoded absolute-form host decoded" + |>.feed "GET http://ex%41mple.com/ HTTP/1.1\r\nHost: example.com\r\n\r\n" + |>.step |>.assertNoError + |>.onEndHeaders (fun t head => + match head.uri.authority? with + | some a => if toString a == "example.com" then t else t.addError s!"expected URI authority=example.com, got {toString a}" + | none => t.addError "missing URI authority") + |>.run), + ("§3.2: Host with a percent-encoded `/` → badMessage", MachineTester.receiving "§3.2: Host with a percent-encoded `/` → badMessage" + |>.feed "GET / HTTP/1.1\r\nHost: exa%2Fmple.com\r\n\r\n" + |>.step |>.assertFailedWith .badMessage |>.run), + -- RFC 9112 §3.2.2: Host is left as-is; the authority is available through the URI. + ("§3.2: absolute-form Host preserved, authority in URI", MachineTester.receiving "§3.2: absolute-form Host preserved, authority in URI" + |>.feed "GET http://example.com:80/path HTTP/1.1\r\nHost: random.com\r\n\r\n" + |>.step |>.assertNoError + |>.onEndHeaders (fun t head => + let t := match head.headers.get? .host with + | some v => if v.value == "random.com" then t else t.addError s!"expected Host=random.com, got {v.value.quote}" + | none => t.addError "missing Host header" + match head.uri.authority? with + | some a => if toString a == "example.com:80" then t else t.addError s!"expected URI authority=example.com:80, got {toString a}" + | none => t.addError "missing URI authority") + |>.run) + ] (·.2) + +#eval checkCases "RFC 9112 §3.2: Host header: server" #[ + ("missing Host header → 400", "GET / HTTP/1.1\x0d\nConnection: close\x0d\n\x0d\n", Want.exact r400), + ("empty Host allowed for origin-form", "GET / HTTP/1.1\x0d\nHost: \x0d\nConnection: close\x0d\n\x0d\n", .exact okResponse), + ("multiple Host headers → 400", + "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nHost: other.com\x0d\nConnection: close\x0d\n\x0d\n", .exact r400), + ("Host: example.com:000080", + "GET / HTTP/1.1\x0d\nHost: example.com:000080\x0d\nConnection: close\x0d\n\x0d\n", .status "HTTP/1.1 200"), + ("CONNECT with an empty port", + "CONNECT example.com: HTTP/1.1\x0d\nHost: example.com:\x0d\nConnection: close\x0d\n\x0d\n", .status "HTTP/1.1 400") + ] fun (_, raw, want) => expectServer raw want + +-- RFC 9112 §3.2.2: for an absolute-form target, the server uses the target's authority, not `Host`. +#eval checkCases "absolute-form: URI authority takes precedence over Host" #[ + ("absolute-form: URI authority takes precedence over Host", + "GET http://good.example/path HTTP/1.1\x0d\nHost: other.example\x0d\nConnection: close\x0d\n\x0d\n") + ] fun (_, raw) => + checkHandler raw (show TestHandler from fun req => Response.ok |>.text ((req.line.uri.authority?.map toString).getD "<none>")) + (.body "good.example") + +-- A 2xx to CONNECT starts a tunnel, so it has no framing fields or content (RFC 9110 §9.3.6). +#eval checkCases "CONNECT authority vs Host: server" #[ + ("CONNECT authority-form accepted", + "CONNECT example.com:443 HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n", + "HTTP/1.1 200 OK\x0d\nContent-Type: text/plain; charset=utf-8\x0d\nServer: LeanHTTP/1.1\x0d\nConnection: close\x0d\n\x0d\n"), + ("CONNECT authority-form port mismatch → 400", + "CONNECT example.com:444 HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n", r400) + ] fun (_, raw, want) => expectServer raw (.exact want) + + +private def hostRequest (version : String) (host : ByteArray) : ByteArray := + s!"GET / {version}\x0d\nHost: ".toUTF8 ++ host ++ "\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 + +-- RFC 9110 §7.2: `Host` is `uri-host [ ":" port ]`. +#eval checkCases "Host values" #[ + ("1.2.3.4", "1.2.3.4".toUTF8, true), ("foo.com:80", "foo.com:80".toUTF8, true), ("foo-bar_baz.com", "foo-bar_baz.com".toUTF8, true), + ("[::1]", "[::1]".toUTF8, true), ("[::1]:80", "[::1]:80".toUTF8, true), ("[::1]:8080", "[::1]:8080".toUTF8, true), + ("[::ffff:12.34.56.78]", "[::ffff:12.34.56.78]".toUTF8, true), ("an empty port", "example.com:".toUTF8, true), ("empty", ByteArray.empty, true), + ("::1", "::1".toUTF8, false), ("[::1", "[::1".toUTF8, false), ("::1]", "::1]".toUTF8, false), ("{", "{".toUTF8, false), + ("}", "}".toUTF8, false), ("0x06", ByteArray.mk #[0x06], false), ("0xFF", ByteArray.mk #[0xFF], false), + ("user@example.com", "user@example.com".toUTF8, false), ("example.com:abc", "example.com:abc".toUTF8, false), + ("example.com:80:", "example.com:80:".toUTF8, false) + ] fun (_, host, ok) => do + (if ok then Want.status "HTTP/1.1 200" else .exact r400).check (← serveBytes (hostRequest "HTTP/1.1" host) okHandler) + +#eval checkCases "Host presence" #[ + ("HTTP/1.0 with an invalid Host", hostRequest "HTTP/1.0" (ByteArray.mk #[0xFF])), + ("CONNECT without Host", "CONNECT example.com:443 HTTP/1.1\x0d\nConnection: close\x0d\n\x0d\n".toUTF8), + ("absolute-form without Host", "GET http://example.com/ HTTP/1.1\x0d\nConnection: close\x0d\n\x0d\n".toUTF8) + ] fun (_, raw) => do (Want.exact r400).check (← serveBytes raw okHandler) + +-- RFC 9110 §9.3.6's own example: a port-less `Host` matches a target port of 80. +#eval checkCases "CONNECT authority vs Host: port 80" #[ + ("CONNECT server.example.com:80 with Host server.example.com", + "CONNECT server.example.com:80 HTTP/1.1\x0d\nHost: server.example.com\x0d\nConnection: close\x0d\n\x0d\n") + ] fun (_, raw) => checkHandler raw okHandler + (.exact "HTTP/1.1 200 OK\x0d\nContent-Type: text/plain; charset=utf-8\x0d\nServer: LeanHTTP/1.1\x0d\nConnection: close\x0d\n\x0d\n") + +/-! ## Field lines (RFC 9112 §5, RFC 9110 §5.5) -/ + +#eval checkCases "RFC 9110 §6–§7: header handling: machine" #[ + ("§6.3: custom headers preserved", MachineTester.receiving "§6.3: custom headers preserved" + |>.feed "GET / HTTP/1.1\r\nHost: example.com\r\nX-Custom: my-value\r\nAuthorization: Bearer tok\r\n\r\n" + |>.step |>.assertNoError + |>.onEndHeaders (fun t head => + let custom := (head.headers.get? (.ofString! "X-Custom")).map (·.value) + let auth := (head.headers.get? .authorization).map (·.value) + if custom != some "my-value" then t.addError s!"X-Custom mismatch: {repr custom}" + else if auth != some "Bearer tok" then t.addError s!"Authorization mismatch: {repr auth}" + else t) + |>.run) + ] (·.2) + +#eval checkCases "RFC 9112 §5: header field syntax: server" #[ + ("header without colon → 400", + "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nBadHeader value\x0d\nConnection: close\x0d\n\x0d\n", r400), + ("leading whitespace (obs-fold) → 400", + "GET / HTTP/1.1\x0d\nHost: example.com\x0d\n X-Bad: folded\x0d\nConnection: close\x0d\n\x0d\n", r400), + ("space in header name → 400", + "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nBad Header: value\x0d\nConnection: close\x0d\n\x0d\n", r400), + ("bare LF line endings → 400", "GET / HTTP/1.1\nHost: example.com\nConnection: close\n\n", r400), + ("tab in header value → accepted", + "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nX-Tab: value\twith\ttabs\x0d\nConnection: close\x0d\n\x0d\n", okResponse), + ("NUL in header name → 400", + "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nX-Bad\x00Header: value\x0d\nConnection: close\x0d\n\x0d\n", r400), + ("NUL in header value → 400", + "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nX-Header: bad\x00value\x0d\nConnection: close\x0d\n\x0d\n", r400), + ("control char (0x01) in header value → 400", + "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nX-Header: bad\x01value\x0d\nConnection: close\x0d\n\x0d\n", r400) + ] fun (_, raw, want) => expectServer raw (.exact want) + +-- The name ends at the first `:`; later colons belong to the value. +#eval checkCases "additional colon in header value stays in value" #[ + ("additional colon in header value stays in value", + "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nBad:Name: value\x0d\nConnection: close\x0d\n\x0d\n") + ] fun (_, raw) => + checkHandler raw + (show TestHandler from fun req => + Response.ok |>.text (((req.line.headers.get? (Header.Name.ofString! "Bad")).map (·.value)).getD "<none>")) + (.body "Name: value") + + +-- RFC 9112 §5.1: no whitespace between a field name and its colon; RFC 9112 §2.2: a whitespace-led +-- line right after the request line is rejected. +#eval checkCases "Field-line syntax" #[ + ("Host : x", "GET / HTTP/1.1\x0d\nHost : example.com\x0d\nConnection: close\x0d\n\x0d\n"), + ("Foo HTAB :", "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nFoo\t: x\x0d\nConnection: close\x0d\n\x0d\n"), + ("Content-Length : 5", "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length : 5\x0d\nConnection: close\x0d\n\x0d\nhello"), + ("an empty name", "GET / HTTP/1.1\x0d\nHost: example.com\x0d\n: value\x0d\nConnection: close\x0d\n\x0d\n"), + ("a SP-led line after the request line", "GET / HTTP/1.1\x0d\n Host: example.com\x0d\nConnection: close\x0d\n\x0d\n"), + ("a HTAB-led line after the request line", "GET / HTTP/1.1\x0d\n\tHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") + ] fun (_, raw) => checkHandler raw okHandler (.exact r400) + +private def isTchar (b : UInt8) : Bool := + let c := Char.ofNat b.toNat + c.isAlphanum && b < 128 || "!#$%&'*+-.^_`|~".contains c + +-- RFC 9110 §5.1, §5.5, §5.6.2: a field name is a token; a field value is VCHAR, obs-text, SP and HTAB. +#eval checkCases "Every byte in a field name and in a field value" #[ + ("name Foo?Bar: foo", do + for n in [0:256] do + let b := n.toUInt8 + let raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nFoo".toUTF8.push b ++ "Bar: foo\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 + let ok := isTchar b || b == ':'.toUInt8 + try (if ok then Want.status "HTTP/1.1 200" else .exact r400).check (← serveBytes raw okHandler) + catch e => throw <| IO.userError s!"byte {n}: {e}"), + ("value Foo: foo?bar", do + for n in [0:256] do + let b := n.toUInt8 + let raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nFoo: foo".toUTF8.push b ++ "bar\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 + let ok := b == 0x20 || b == 0x09 || (0x21 ≤ b && b ≤ 0x7E) || 0x80 ≤ b + try (if ok then Want.status "HTTP/1.1 200" else .exact r400).check (← serveBytes raw okHandler) + catch e => throw <| IO.userError s!"byte {n}: {e}"), + ("a name made only of tchar specials", checkHandler + "GET / HTTP/1.1\x0d\nHost: example.com\x0d\n!#$%&'*+-.^_`|~: x\x0d\nConnection: close\x0d\n\x0d\n" okHandler (.status "HTTP/1.1 200")) + ] (·.2) + +private def fieldValues (name : String) : TestHandler := fun req => + Response.ok |>.text (match req.line.headers.getAll? (Header.Name.ofString! name) with + | some vs => "|".intercalate (vs.map (·.value)).toList + | none => "<none>") + +-- RFC 9110 §5.5, §5.6.3: OWS around a value is not part of it; RFC 9110 §5.3: field lines with one +-- name are one field, in order. +#eval checkCases "What the handler sees of a field" #[ + ("b:1 SP HTAB", "b:1 \t", "b", "1"), ("X: HTAB SP v", "X:\t v", "X", "v"), + ("trailing SP", "Foo: a a a a a ", "Foo", "a a a a a"), ("Foo:", "Foo:", "Foo", ""), + ("only OWS", "Foo: \t \t ", "Foo", ""), ("two lines, one name", "my-key: 1\x0d\nmy-Key: 2", "my-key", "1|2") + ] fun (_, line, name, want) => + checkHandler s!"GET / HTTP/1.1\x0d\nHost: example.com\x0d\n{line}\x0d\nConnection: close\x0d\n\x0d\n" (fieldValues name) (.body want) + +/-! ## Hostile heads (RFC 9112 §2.2, §3) -/ + +#eval checkCases "Inputs that are not an HTTP/1.1 request" #[ + ("TLS 1.2 client hello prefix", ByteArray.mk #[0x16, 0x03, 0x01, 0x00, 0xa5, 0x01, 0x00, 0x00], Want.exact r400), + ("TLS 1.3 client hello prefix", ByteArray.mk #[0x16, 0x03, 0x03, 0x00, 0x7c, 0x01, 0x00, 0x00], .exact r400), + -- The version is checked before the method, so the preface gets 505 (RFC 9110 §15.6.6). + ("HTTP/2 connection preface", "PRI * HTTP/2.0\x0d\n\x0d\nSM\x0d\n\x0d\n".toUTF8, .exact r505), + ("HTTP response sent as a request", "HTTP/1.1 200 OK\x0d\nContent-Length: 2\x0d\n\x0d\nok".toUTF8, .exact r400), + ("Bare LF line endings", "GET / HTTP/1.1\nHost: example.com\n\n".toUTF8, .exact r400), + ("CR-only line endings", "GET / HTTP/1.1\x0dHost: example.com\x0d\x0d".toUTF8, .exact r400), + ("Null bytes everywhere", ByteArray.mk #[0x00, 0x00, 0x00, 0x00], .exact r400), + ("CRLF injection attempt in request-line", + "GET /path%0d%0aInjected: header HTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n".toUTF8, .exact r400), + ("Unicode in path (raw multibyte UTF-8)", "GET /caf\xc3\xa9 HTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n".toUTF8, .exact r400), + ("Extremely long method token", + (String.ofList (List.replicate 8192 'A') ++ " / HTTP/1.1\x0d\nHost: h\x0d\n\x0d\n").toUTF8, .exact r501), + ("absolute-form target naming an internal address", + "GET http://169.254.169.254/latest/meta-data/ HTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n".toUTF8, .status "HTTP/1.1 200") + ] fun (_, raw, want) => do want.check (← serveBytes raw okHandler (closeInput := true)) + + +#eval checkCases "The HTTP/2 preface never reaches the handler" #[ + ("PRI * HTTP/2.0", do + let (r, seen) ← serveRecording "PRI * HTTP/2.0\x0d\n\x0d\nSM\x0d\n\x0d\n" (closeInput := true) + ensure seen.isEmpty "the handler ran" + (Want.status "HTTP/1.1 505").check r) + ] (·.2)
diff --git a/tests/async/elab/async_http_h1_response_framing.lean b/tests/async/elab/async_http_h1_response_framing.lean new file mode 100644 index 0000000..0d816bd --- /dev/null +++ b/tests/async/elab/async_http_h1_response_framing.lean
@@ -0,0 +1,841 @@ +module + +import Std.Http.Test.Helpers +import Std.Http.Test.Machine + +/-! +# HTTP/1.1 response framing + +What a server writes as a response: `Date` and the responses it writes itself, HEAD, 204, 205 and 304, +interim responses, HTTP/1.0 peers, handler framing that contradicts the body, transfer codings from +the handler, the chunked writer, and CONNECT. Machine tables first, then `serveConnection` tables. +RFC 9110 §6.6.1, §9.3.2, §9.3.6, §15.2–§15.6; RFC 9112 §6, §7.1. Regressions: #15469, #16282, +#16362. +-/ + +open Std Http +open Std.Async +open Std.Http.Internal +open Std.Http.Protocol.H1 +open Std.Http.Internal.Test + +private def mkGet10 (path : String := "/") : String := + s!"GET {path} HTTP/1.0\r\n\r\n" + +private def mkPostHead (path : String) (bodyLen : Nat) (extra : String := "") : String := + rawRequest "POST" path (extra := s!"Content-Length: {bodyLen}\r\n{extra}") + +private def minimalGetRequest : Request.Head := + { method := .get, version := .v11, uri := RequestTarget.originForm! "/", + headers := Headers.empty.insert! "Host" "example.com" } + +private def ok200Head : String := + "HTTP/1.1 200 OK\x0d\nContent-Type: text/plain; charset=utf-8\x0d\nServer: LeanHTTP/1.1\x0d\nConnection: close\x0d\nContent-Length: 2\x0d\n\x0d\n" + +/-- A server machine that has read `request`. -/ +private def server (request : String) : Machine .receiving := + (({ config := {} } : Machine .receiving).feed request.toUTF8).step.1 + +private def headers (fields : List (Header.Name × String)) : Headers := + fields.foldl (fun hs (name, value) => hs.insert name (Header.Value.ofString! value)) .empty + +private def get : String := "GET / HTTP/1.1\r\nHost: a\r\n\r\n" + +private def abc : Array Chunk := #[Chunk.ofByteArray "abc".toUTF8] + +/-- Runs `machine` to a halt and checks that it answered 500 with its explanation, not the body. -/ +private def expect500 (name : String) (machine : Machine .receiving) : IO Unit := do + let some (out, events) := runToHalt (machine.sendData abc |>.userClosedBody) + | throw <| IO.userError s!"[{name}] the server never halted" + unless out == "HTTP/1.1 500 Internal Server Error\r\nContent-Type: text/plain; charset=utf-8\r\n" ++ + "Connection: close\r\nContent-Length: 22\r\n\r\nInternal Server Error\n" do + throw <| IO.userError s!"[{name}] expected a 500 with its explanation only, got:\n{out.quote}" + unless events.any (· matches .failed (.other _)) do + throw <| IO.userError s!"[{name}] no framing failure reported: {repr events}" + +/-- Runs `machine` to a halt and returns its output, failing on a reported failure. -/ +private def expectOk (name : String) (machine : Machine .receiving) : IO String := do + let some (out, events) := runToHalt machine + | throw <| IO.userError s!"[{name}] the server never halted" + if events.any (· matches .failed _) then + throw <| IO.userError s!"[{name}] unexpected failure: {repr events}\n{out.quote}" + return out + +private def connectRequest : String := + "CONNECT example.com:443 HTTP/1.1\x0d\nHost: example.com:443\x0d\n\x0d\n" + +/-- Bytes a client sends through the tunnel it believes is open. -/ +private def tunnelBytes : String := + "GET /admin HTTP/1.1\x0d\nHost: a\x0d\nConnection: close\x0d\n\x0d\n" + +private def handledHandler : TestHandler := fun req => + Response.ok |>.text s!"handled {req.line.method} {req.line.uri}" + +private def codedHandler : TestHandler := fun _ => + Response.ok + |>.header! "Transfer-Encoding" "gzip, chunked" + |>.stream fun out => out.send (Chunk.ofByteArray "GZIPPED".toUTF8) + +private def date : Header.Value := .mk "Mon, 01 Jan 2024 00:00:00 GMT" + +private def withDate (t : MachineTester .receiving) : MachineTester .receiving := + { t with machine := { t.machine with date := some date } } + +/-! ## Server-written responses and Date (RFC 9110 §6.6.1, §15.5, §15.6) -/ + +#eval checkCases "Server-written responses and Date: machine" #[ + ("§6.6.1: the machine's date goes into a response without Date", do + MachineTester.receiving "§6.6.1: the machine's date goes into a response without Date" + |> withDate + |>.feed (mkGet "/") |>.step + |>.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody |>.step + |>.assertOutputStartsWith "HTTP/1.1 200 OK\r\nDate: Mon, 01 Jan 2024 00:00:00 GMT\r\nContent-Length: 0\r\n" + "expected the machine's Date after the handler's fields" |>.run), + ("§6.6.1: the handler's own Date is kept and not duplicated", do + MachineTester.receiving "§6.6.1: the handler's own Date is kept and not duplicated" + |> withDate + |>.feed (mkGet "/") |>.step + |>.send { status := .ok, headers := Headers.empty.insert! "Date" "Tue, 02 Jan 2024 00:00:00 GMT" } + |>.setKnownSize (.fixed 0) |>.userClosedBody |>.step + |>.assertOutputContains "Date: Tue, 02 Jan 2024 00:00:00 GMT\r\n" "expected the handler's Date" + |>.assertOutputNotContains "Mon, 01 Jan 2024" "the machine's Date must not be added too" |>.run), + ("§6.6.1: a 400 the machine writes itself carries Date", do + MachineTester.receiving "§6.6.1: a 400 the machine writes itself carries Date" + |> withDate + |>.feed "GET / HTTP/1.1\r\n\r\n" |>.step |>.step + |>.assertOutputStartsWith + "HTTP/1.1 400 Bad Request\r\nContent-Type: text/plain; charset=utf-8\r\nDate: Mon, 01 Jan 2024 00:00:00 GMT\r\n" + "expected Date on the machine's 400" |>.run), + ("§6.6.1: a 408 from closeWithError carries Date", do + MachineTester.receiving "§6.6.1: a 408 from closeWithError carries Date" + |> withDate + |>.feed (mkPostHead "/" 5) |>.step + |>.closeWithError .requestTimeout |>.step + |>.assertOutputStartsWith + "HTTP/1.1 408 Request Timeout\r\nContent-Type: text/plain; charset=utf-8\r\nDate: Mon, 01 Jan 2024 00:00:00 GMT\r\n" + "expected Date on the 408" |>.run), + ("§6.6.1: the 500 for a rejected head carries Date and an explanation", do + MachineTester.receiving "§6.6.1: the 500 for a rejected head carries Date and an explanation" + |> withDate + |>.feed (mkGet "/") |>.step + |>.setKnownSize (.fixed 0) + |>.send { status := .ok, headers := Headers.empty.insert! "Content-Length" "4" } |>.step + |>.assertOutputStartsWith + ("HTTP/1.1 500 Internal Server Error\r\nContent-Type: text/plain; charset=utf-8\r\n" ++ + "Date: Mon, 01 Jan 2024 00:00:00 GMT\r\nConnection: close\r\nContent-Length: 22\r\n\r\n" ++ + "Internal Server Error\n") + "expected Date and the explanation on the 500" |>.run), + ("§6.6.1: without a date the machine adds no Date", do + MachineTester.receiving "§6.6.1: without a date the machine adds no Date" + |>.feed "GET / HTTP/1.1\r\n\r\n" |>.step |>.step + |>.assertOutputNotContains "Date" "no Date without a date value" |>.run), + ("§15.5: a 400 the machine writes explains itself", do + -- §15.5, §15.6: except for a response to HEAD, a 4xx or 5xx response should explain the error + MachineTester.receiving "§15.5: a 400 the machine writes explains itself" + |>.feed "GET / HTTP/1.1\r\n\r\n" |>.step |>.step + |>.assertOutputStartsWith + ("HTTP/1.1 400 Bad Request\r\nContent-Type: text/plain; charset=utf-8\r\n" ++ + "Connection: close\r\nContent-Length: 12\r\n\r\nBad Request\n") + "expected a text/plain explanation" |>.run), + ("§15.6.6: a 505 names the supported versions", do + -- §15.6.6: a 505 says which versions the server supports + MachineTester.receiving "§15.6.6: a 505 names the supported versions" + |>.feed "GET / HTTP/2.0\r\nHost: example.com\r\n\r\n" |>.step |>.step + |>.assertOutputStartsWith "HTTP/1.1 505 HTTP Version Not Supported\r\n" "expected 505" + |>.assertOutputContains "\r\n\r\nHTTP Version Not Supported: this server supports HTTP/1.0 and HTTP/1.1\n" + "expected the supported versions" |>.run), + ("§9.3.2: a 400 to HEAD keeps Content-Length and omits the content", do + -- §9.3.2: a response to HEAD has no content, but keeps the Content-Length GET would have + MachineTester.receiving "§9.3.2: a 400 to HEAD keeps Content-Length and omits the content" + |>.feed "HEAD / HTTP/1.1\r\n\r\n" |>.step |>.step + |>.assertOutputStartsWith "HTTP/1.1 400 Bad Request\r\n" "expected 400" + |>.assertOutputContains "Content-Length: 12\r\n\r\n" "expected the content's length" + |>.assertOutputNotContains "\r\n\r\nBad Request" "a HEAD response carries no content" |>.run), + ("§15.5: a 408 from closeWithError explains itself", do + MachineTester.receiving "§15.5: a 408 from closeWithError explains itself" + |>.feed (mkPostHead "/" 5) |>.step + |>.closeWithError .requestTimeout |>.step + |>.assertOutputStartsWith "HTTP/1.1 408 Request Timeout\r\n" "expected 408" + |>.assertOutputContains "Connection: close\r\n" "expected Connection: close" + |>.assertOutputContains "Content-Length: 16\r\n\r\nRequest Timeout\n" "expected an explanation" + |>.assertNotKeepAlive |>.run) + ] (·.2) + +#eval checkCases "Server-written responses and Date: async_http_expect.lean" #[ + ("generateDate: true adds Date header", + do + check "generateDate: true adds Date header" + (raw := mkGetClose "/date") + (handler := fun _ => Response.ok |>.text "hello") + (config := { defaultConfig with generateDate := true }) + (expect := fun r => + assertStatus r "HTTP/1.1 200" *> + assertContains r "Date: " *> + assertContains r " GMT\x0d\n")), + ("generateDate: false omits Date header", + do + check "generateDate: false omits Date header" + (raw := mkGetClose "/no-date") + (handler := fun _ => Response.ok |>.text "hello") + (config := { defaultConfig with generateDate := false }) + (expect := fun r => + assertStatus r "HTTP/1.1 200" *> + assertAbsent r "Date: ")), + ("user-supplied Date header preserved and not duplicated", + do + check "user-supplied Date header preserved and not duplicated" + (raw := mkGetClose "/custom-date") + (handler := fun _ => + Response.ok + |>.header! "Date" "Mon, 01 Jan 2024 00:00:00 GMT" + |>.text "hello") + (config := { defaultConfig with generateDate := true }) + (expect := fun r => do + assertContains r "Date: Mon, 01 Jan 2024 00:00:00 GMT" + let text := String.fromUTF8! r + let count := (text.splitOn "Date: ").length - 1 + unless count == 1 do + throw <| IO.userError s!"expected 1 Date header, got {count}:\n{text.quote}")), + ("generateDate: true adds Date to a 400 the server writes itself", + do + -- RFC 9110 §6.6.1: an origin server MUST generate a Date field in all 2xx, 3xx and 4xx responses, + -- including those the server writes itself + check "generateDate: true adds Date to a 400 the server writes itself" + (raw := "GET / HTTP/1.1\x0d\nConnection: close\x0d\n\x0d\n") + (handler := okHandler) + (config := { defaultConfig with generateDate := true }) + (expect := fun r => + assertStatus r "HTTP/1.1 400" *> + assertContains r "\x0d\nDate: " *> + assertContains r " GMT\x0d\nServer: LeanHTTP/1.1\x0d\n")), + ("generateDate: true adds Date to a 431 the server writes itself", + do + check "generateDate: true adds Date to a 431 the server writes itself" + (raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nA: 1\x0d\nB: 2\x0d\nC: 3\x0d\n\x0d\n") + (handler := okHandler) + (config := { defaultConfig with generateDate := true, maxHeaders := 2 }) + (expect := fun r => + assertStatus r "HTTP/1.1 431" *> + assertContains r "\x0d\nDate: ")), + ("generateDate: true adds Date to the 500 for a handler head with a wrong Content-Length", + do + check "generateDate: true adds Date to the 500 for a handler head with a wrong Content-Length" + (raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n") + (handler := fun _ => Response.ok |>.header! "Content-Length" "1234" |>.text "") + (config := { defaultConfig with generateDate := true }) + (expect := fun r => + assertStatus r "HTTP/1.1 500" *> + assertContains r "\x0d\nDate: " *> + assertContains r "\x0d\n\x0d\nInternal Server Error\n")), + ("generateDate: false adds no Date to a 400 the server writes itself", + do + check "generateDate: false adds no Date to a 400 the server writes itself" + (raw := "GET / HTTP/1.1\x0d\nConnection: close\x0d\n\x0d\n") + (handler := okHandler) + (config := { defaultConfig with generateDate := false }) + (expect := (assertExact · r400))) + ] (·.2) + +#eval checkCases "Server-written responses and Date: async_http_h1_framing_mismatch.lean" #[ + ("empty body with Content-Length: 1234", + do + checkTimed "empty body with Content-Length: 1234" + (raw := get) + (handler := fun _ => Response.ok |>.header! "Content-Length" "1234" |>.text "") + (expect := (assertStatus · "HTTP/1.1 500 Internal Server Error"))) + ] (·.2) + + +/-- The number of field lines named `name` in the first head of `text`. -/ +private def fieldCount (text name : String) : Nat := + ((text.splitOn "\x0d\n\x0d\n").headD "").splitOn "\x0d\n" |>.filter (·.toLower.startsWith (name.toLower ++ ":")) |>.length + +private def ownFields : TestHandler := fun _ => + Response.ok |>.header! "Server" "Mine/1.0" |>.header! "Date" "Mon, 01 Jan 2024 00:00:00 GMT" + |>.header! "Content-Type" "text/html" |>.text "x" + +-- RFC 9110 §6.6.1, §10.2.4, §8.3: a response has at most one `Date`, `Server` and `Content-Type`. +#eval checkCases "One Server, one Date, one Content-Type" #[ + ("server defaults", (okHandler : TestHandler)), ("set by the handler", ownFields) + ] fun (_, handler) => do + let r ← serveRaw "GET / HTTP/1.1\x0d\nHost: a\x0d\nConnection: close\x0d\n\x0d\n" handler + { testConfig with generateDate := true } + let text := String.fromUTF8! r + for name in ["Server", "Date", "Content-Type"] do + ensure (fieldCount text name == 1) s!"{fieldCount text name} {name} fields:\n{text.quote}" + +/-! ## HEAD (RFC 9110 §9.3.2) -/ + +#eval checkCases "HEAD: machine" #[ + ("RFC 9110 §9.3.2: HEAD response — body bytes suppressed, Content-Length preserved", do + -- body bytes suppressed; Content-Length metadata still emitted so client knows size + let body := "hello".toUTF8 + MachineTester.receiving "RFC 9110 §9.3.2: HEAD response — body bytes suppressed, Content-Length preserved" + |>.feed "HEAD / HTTP/1.1\r\nHost: example.com\r\n\r\n" + |>.step |>.assertIsWaitingMessage + |>.send { status := .ok, headers := Headers.empty.insert! "Content-Length" "5" } + |>.sendBytes body |>.userClosedBody |>.step |>.step + |>.assertOutputContains "HTTP/1.1 200" "expected 200 OK status line" + |>.assertOutputContains "Content-Length: 5" "expected Content-Length metadata preserved" + |>.assertOutputNotContains "hello" "HEAD response must not contain body bytes on the wire" + |>.run), + ("§9.3.2: HEAD response of unknown length has no Content-Length: 0", do + -- RFC 9110 §9.3.2, §8.6: with no known length a HEAD response has GET's framing; a + -- `Content-Length: 0` would claim the GET response is empty + MachineTester.receiving "§9.3.2: HEAD response of unknown length has no Content-Length: 0" + |>.feed ("HEAD / HTTP/1.1\r\nHost: example.com\r\n\r\n" ++ mkGet "/next") + |>.step |>.assertIsWaitingMessage + |>.send { status := .ok } |>.userClosedBody |>.step + |>.assertOutputNotContains "Content-Length" "unknown length must not be sent as Content-Length: 0" + |>.assertOutputContains "Transfer-Encoding: chunked\r\n" "expected the framing GET would have" + |>.assertOutputNotContains "0\r\n\r\n" "a HEAD response carries no body, not even a last chunk" + |>.assertHasNext |>.run) + ] (·.2) + +#eval checkCases "HEAD: async_http_h1_framing_mismatch.lean" #[ + ("HEAD keeps the handler's Content-Length", + do + let head := "HEAD / HTTP/1.1\r\nHost: a\r\nConnection: close\r\n\r\n" + for size in [Body.Length.chunked, .fixed 0] do + let out ← expectOk s!"HEAD, {repr size}" <| server head + |>.setKnownSize size + |>.send { status := .ok, headers := headers [(Header.Name.contentLength, "1234")] } + unless out.startsWith "HTTP/1.1 200 OK\r\n" && out.contains "Content-Length: 1234\r\n" && + !out.contains "Transfer-Encoding" do + throw <| IO.userError s!"HEAD, {repr size}: expected Content-Length: 1234, got\n{out.quote}"), + ("HEAD with a streamed body and Content-Length: 1234", + do + checkTimed "HEAD with a streamed body and Content-Length: 1234" + (raw := "HEAD / HTTP/1.1\r\nHost: a\r\nConnection: close\r\n\r\n") + (handler := fun _ => Response.ok |>.header! "Content-Length" "1234" + |>.stream fun s => s.send (Chunk.ofByteArray "abc".toUTF8)) + (expect := fun r => do + assertStatus r "HTTP/1.1 200 OK" + assertContains r "Content-Length: 1234\r\n" + assertAbsent r "abc")) + ] (·.2) + +#eval checkCases "HEAD: async_http_response_framing.lean" #[ + ("HEAD omits body bytes, preserves headers", + do + check "HEAD omits body bytes, preserves headers" + (raw := "HEAD / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") + (handler := okHandler) + (expect := fun r => assertExact r ok200Head)), + ("GET and HEAD produce identical header sections", + do + check "GET and HEAD produce identical header sections" + (raw := "GET /frame HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") + (handler := fun _ => Response.ok |>.text "hello") + (expect := fun getResp => do + -- Run HEAD against the same handler + let (client2, server2) ← Mock.new + let headResp ← Async.block do + client2.send "HEAD /frame HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 + Std.Http.Server.serveConnection server2 (show TestHandler from fun _ => Response.ok |>.text "hello") defaultConfig |>.run + return (← client2.recv?).getD .empty + + let getHeaders := (String.fromUTF8! getResp).splitOn "\x0d\n\x0d\n" |>.headD "" + let headHeaders := (String.fromUTF8! headResp).splitOn "\x0d\n\x0d\n" |>.headD "" + unless getHeaders == headHeaders do + throw <| IO.userError s!"headers differ:\nGET: {getHeaders.quote}\nHEAD: {headHeaders.quote}" + assertContains getResp "hello" *> + assertAbsent headResp "hello")) + ] (·.2) + + +private def sized (n : Nat) : TestHandler := fun _ => + Response.ok |>.text (String.ofList (List.replicate n 'b')) + +-- RFC 9110 §9.3.2: a HEAD response carries the GET's framing fields and no content. +#eval checkCases "HEAD, then a pipelined GET" #[ + ("10 bytes", 10), ("4 KiB", 4096) + ] fun (_, n) => do + let r ← serveRaw "HEAD / HTTP/1.1\x0d\nHost: a\x0d\n\x0d\nGET / HTTP/1.1\x0d\nHost: a\x0d\nConnection: close\x0d\n\x0d\n" (sized n) + let text := String.fromUTF8! r + let some [h1, h2, body] := some (text.splitOn "\x0d\n\x0d\n") + | throw <| IO.userError s!"expected two heads and one body:\n{text.quote}" + ensure (h1.startsWith "HTTP/1.1 200" && h1.contains s!"Content-Length: {n}" && !h1.contains "Transfer-Encoding") + s!"HEAD response head:\n{h1.quote}" + ensure (h2.startsWith "HTTP/1.1 200" && h2.contains s!"Content-Length: {n}") s!"GET response head:\n{h2.quote}" + ensure (body == String.ofList (List.replicate n 'b')) s!"GET body of {body.length} bytes" + +private def streamed : TestHandler := fun _ => + Response.ok |>.stream fun s => s.send (Chunk.ofByteArray "abc".toUTF8) + +private def bothFraming : TestHandler := fun _ => + Response.ok |>.header! "Content-Length" "3" |>.header! "Transfer-Encoding" "chunked" |>.text "abc" + +#eval checkCases "HEAD with an unknown length" #[ + ("HTTP/1.0, streamed: Connection: close and no TE", "HEAD / HTTP/1.0\x0d\n\x0d\n", streamed, + Want.all [.status "HTTP/1.1 200", .contains "Connection: close\x0d\n", .absent "Transfer-Encoding", .absent "abc"]), + ("CL and TE from the handler: no 500", "HEAD / HTTP/1.1\x0d\nHost: a\x0d\nConnection: close\x0d\n\x0d\n", bothFraming, + .all [.status "HTTP/1.1 200", .absent "abc"]) + ] fun (_, raw, handler, want) => checkHandler raw handler want (closeInput := true) + +/-! ## 204, 205 and 304 (RFC 9110 §15.3.5, §15.3.6, §15.4.5) -/ + +#eval checkCases "204, 205 and 304: machine" #[ + ("§15.3.6: 205 drops the handler's content and sends Content-Length: 0", do + -- RFC 9110 §15.3.6: a server must not generate content in a 205 response; it sends + -- `Content-Length: 0` whatever length or framing the handler gave + MachineTester.receiving "§15.3.6: 205 drops the handler's content and sends Content-Length: 0" + |>.feed (mkGet "/") |>.step |>.assertIsWaitingMessage + |>.send { status := .resetContent } |>.sendBytes "body".toUTF8 |>.userClosedBody |>.step + |>.assertOutputStartsWith "HTTP/1.1 205 Reset Content\r\nContent-Length: 0\r\n\r\n" + "expected a 205 head with Content-Length: 0" + |>.assertOutputNotContains "body" "a 205 response carries no content" + |>.assertNoError |>.assertKeepAlive |>.run), + ("§15.3.6: 205 with the handler's Content-Length: 4 still sends Content-Length: 0", do + MachineTester.receiving "§15.3.6: 205 with the handler's Content-Length: 4 still sends Content-Length: 0" + |>.feed (mkGet "/") |>.step |>.assertIsWaitingMessage + |>.send { status := .resetContent, headers := Headers.empty.insert! "Content-Length" "4" } + |>.sendBytes "body".toUTF8 |>.userClosedBody |>.step + |>.assertOutputContains "Content-Length: 0\r\n\r\n" "expected Content-Length: 0" + |>.assertOutputNotContains "Content-Length: 4" "the handler's length must not be advertised" + |>.assertOutputNotContains "body" "a 205 response carries no content" + |>.assertNoError |>.run), + ("§15.3.6: 205 of unknown length is not chunked", do + MachineTester.receiving "§15.3.6: 205 of unknown length is not chunked" + |>.feed (mkGet "/") |>.step |>.assertIsWaitingMessage + |>.send { status := .resetContent } |>.setKnownSize .chunked |>.sendBytes "body".toUTF8 + |>.userClosedBody |>.step + |>.assertOutputContains "Content-Length: 0\r\n\r\n" "expected Content-Length: 0" + |>.assertOutputNotContains "Transfer-Encoding" "a 205 response is not chunked" + |>.assertOutputNotContains "body" "a 205 response carries no content" |>.run) + ] (·.2) + +#eval checkCases "204, 205 and 304: async_http_h1_framing_mismatch.lean" #[ + ("204 and 304 drop the handler's framing fields", + do + let close := "GET / HTTP/1.1\r\nHost: a\r\nConnection: close\r\n\r\n" + for status in [Status.noContent, .notModified] do + let out ← expectOk s!"{status}" <| server close + |>.setKnownSize (.fixed 0) + |>.send { status, headers := headers [(Header.Name.contentLength, "9")] } + unless out.startsWith s!"HTTP/1.1 {status.toCode} " && !out.contains "Content-Length" do + throw <| IO.userError s!"{status}: expected no framing fields, got\n{out.quote}") + ] (·.2) + +#eval checkCases "204, 205 and 304: async_http_response_framing.lean" #[ + ("Direct machine test: write a 304 head with Content-Length: 5 and verify it is stripped.", + do + -- Direct machine test: write a 304 head with Content-Length: 5 and verify it is stripped. + -- RFC 9110 §8.6 permits Content-Length in 304 as optional metadata, but we strip it to + -- avoid forwarding a stale or wrong value from a handler that did not intend to advertise + -- a body size. + let request := "GET /cache HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 + let machine0 : Protocol.H1.Machine .receiving := { config := {} } + let (machine1, _) := (machine0.feed request).step + let headers304 := Headers.empty.insert Header.Name.contentLength (Header.Value.ofString! "5") + let (_, step304) := (machine1.send ({ status := .notModified, headers := headers304 } : Response.Head)).step + let text304 := String.fromUTF8! step304.output.toByteArray + unless text304.contains "HTTP/1.1 304 Not Modified" do + throw <| IO.userError s!"expected 304 status in output:\n{text304.quote}" + if text304.contains "Content-Length:" || text304.contains "Transfer-Encoding:" then + throw <| IO.userError s!"unexpected framing headers in 304:\n{text304.quote}"), + ("RFC 9110 §15.3.5: 204 No Content strips framing headers", + do + let request := "GET /empty HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 + let machine0 : Protocol.H1.Machine .receiving := { config := {} } + let (machine1, _) := (machine0.feed request).step + let headers204 := Headers.empty.insert Header.Name.contentLength (Header.Value.ofString! "9") + let (_, step204) := (machine1.send ({ status := .noContent, headers := headers204 } : Response.Head)).step + let text204 := String.fromUTF8! step204.output.toByteArray + unless step204.output.size > 0 do + throw <| IO.userError "expected serialized response output" + unless text204.contains "HTTP/1.1 204 No Content" do + throw <| IO.userError s!"expected 204 status:\n{text204.quote}" + if text204.contains "Content-Length:" || text204.contains "Transfer-Encoding:" then + throw <| IO.userError s!"unexpected framing headers in 204:\n{text204.quote}") + ] (·.2) + + +private def withLength (status : Status) : TestHandler := fun _ => + Response.withStatus status |>.header! "Content-Length" "123" |>.text "stuff" + +-- RFC 9110 §8.6, §15.3.5, §15.4.5: 204 and 304 have no content and no framing fields. +#eval checkCases "204 and 304 with a handler's Content-Length and content" #[ + ("204, HTTP/1.1", Status.noContent, "GET / HTTP/1.1\x0d\nHost: a\x0d\nConnection: close\x0d\n\x0d\n"), + ("204, HTTP/1.0", .noContent, "GET / HTTP/1.0\x0d\n\x0d\n"), + ("304, HTTP/1.1", .notModified, "GET / HTTP/1.1\x0d\nHost: a\x0d\nConnection: close\x0d\n\x0d\n"), + ("304, HTTP/1.0", .notModified, "GET / HTTP/1.0\x0d\n\x0d\n") + ] fun (_, status, raw) => do + let text := String.fromUTF8! (← serveRaw raw (withLength status) (closeInput := true)) + ensure (text.startsWith s!"HTTP/1.1 {status.toCode}") s!"status:\n{text.quote}" + ensure (fieldCount text "Content-Length" == 0 && fieldCount text "Transfer-Encoding" == 0) s!"framing fields:\n{text.quote}" + ensure (fieldCount text "Content-Type" == 1) s!"Content-Type dropped:\n{text.quote}" + ensure (text.endsWith "\x0d\n\x0d\n" && !text.contains "stuff") s!"content bytes:\n{text.quote}" + +/-! ## Interim responses (RFC 9110 §15.2) -/ + +#eval checkCases "Interim responses: machine" #[ + ("§15.2: 103 Early Hints is not sent to an HTTP/1.0 client", do + -- RFC 9110 §15.2: a server must not send a 1xx response to an HTTP/1.0 client + MachineTester.receiving "§15.2: 103 Early Hints is not sent to an HTTP/1.0 client" + |>.feed (mkGet10 "/") |>.step |>.assertIsWaitingMessage + |>.send { status := .earlyHints, headers := Headers.empty.insert! "Link" "</a.css>; rel=preload" } + |>.step |>.assertIsWaitingMessage + |>.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody |>.step + |>.assertOutputNotContains "103" "a 1xx response must not reach an HTTP/1.0 client" + |>.assertOutputStartsWith "HTTP/1.1 200" "expected the final response first" |>.run) + ] (·.2) + +#eval checkCases "Interim responses: async_http_response_framing.lean" #[ + ("100 Continue: handler-set Content-Length must be stripped", + do + let request := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 + let machine0 : Protocol.H1.Machine .receiving := { config := {} } + let (machine1, _) := (machine0.feed request).step + -- 100 Continue: handler-set Content-Length must be stripped + let headers100 := Headers.empty + |>.insert Header.Name.contentLength (Header.Value.ofString! "5") + let (machine2, step100) := (machine1.send ({ status := .«continue», headers := headers100 } : Response.Head)).step + let text100 := String.fromUTF8! step100.output.toByteArray + unless text100.contains "HTTP/1.1 100 Continue" do + throw <| IO.userError s!"expected 100 status in output:\n{text100.quote}" + if text100.contains "Content-Length:" then + throw <| IO.userError s!"Content-Length must not appear in 1xx output:\n{text100.quote}" + + -- 103 Early Hints: both Content-Length and Transfer-Encoding must be stripped + let headers103 := Headers.empty + |>.insert Header.Name.contentLength (Header.Value.ofString! "42") + |>.insert Header.Name.transferEncoding (Header.Value.ofString! "chunked") + let (machine3, step103) := (machine2.send ({ status := .earlyHints, headers := headers103 } : Response.Head)).step + let text103 := String.fromUTF8! step103.output.toByteArray + unless text103.contains "HTTP/1.1 103 Early Hints" do + throw <| IO.userError s!"expected 103 status in output:\n{text103.quote}" + if text103.contains "Content-Length:" || text103.contains "Transfer-Encoding:" then + throw <| IO.userError s!"framing headers must not appear in 1xx output:\n{text103.quote}" + + -- Machine must remain in waitingHeaders after sending 1xx (interim does not advance writer) + unless machine3.writer.state == .waitingHeaders do + throw <| IO.userError s!"writer must stay in waitingHeaders after 1xx, got: {repr machine3.writer.state}" + + -- Final 200 OK still works after chained 1xx responses + let headers200 := Headers.empty + |>.insert Header.Name.contentLength (Header.Value.ofString! "0") + let (_, step200) := (machine3.send ({ status := .ok, headers := headers200 } : Response.Head)).step + let text200 := String.fromUTF8! step200.output.toByteArray + unless text200.contains "HTTP/1.1 200 OK" do + throw <| IO.userError s!"expected 200 after 1xx chain:\n{text200.quote}" + unless text200.contains "Content-Length: 0" do + throw <| IO.userError s!"Content-Length must be preserved in final response:\n{text200.quote}") + ] (·.2) + + +private structure Counting where + failures : IO.Ref Nat + seen : IO.Ref (Array String) + respond : TestHandler + +private instance : Server.Handler Counting where + onRequest self req := do + self.seen.modify (·.push (toString req.line.uri)) + self.respond req + onFailure self _ := self.failures.modify (· + 1) + +/-- Serves `raw`, then EOF; returns the bytes written, the targets served and the `onFailure` count. -/ +private def serveCounting (raw : String) (respond : TestHandler) : IO (String × Array String × Nat) := do + let failures ← IO.mkRef 0 + let seen ← IO.mkRef #[] + let r ← serveRaw raw ({ failures, seen, respond } : Counting) (closeInput := true) + return (String.fromUTF8! r, ← seen.get, ← failures.get) + +-- RFC 9110 §15.2: a 1xx is interim; a handler cannot end the exchange with one. +#eval checkCases "A 1xx as the handler's final response" #[ + ("100", Status.«continue», "GET / HTTP/1.1\x0d\nHost: a\x0d\n\x0d\n"), + ("102", .processing, "GET / HTTP/1.1\x0d\nHost: a\x0d\n\x0d\n"), + ("103", .earlyHints, "GET / HTTP/1.1\x0d\nHost: a\x0d\n\x0d\n"), + ("101 to a request without Upgrade", .switchingProtocols, "GET / HTTP/1.1\x0d\nHost: a\x0d\n\x0d\n"), + ("103 to HTTP/1.0", .earlyHints, "GET / HTTP/1.0\x0d\n\x0d\n") + ] fun (_, status, raw) => do + let (text, _, failures) ← serveCounting raw fun _ => Response.withStatus status |>.text "" + ensure (text.startsWith "HTTP/1.1 500") s!"expected a 500 first:\n{text.quote}" + ensure (failures > 0) "onFailure was not called" + +/-! ## HTTP/1.0 peers (RFC 9112 §6.1, §9.3) -/ + +#eval checkCases "HTTP/1.0 peers: machine" #[ + ("§6.2: HTTP/1.0 request → HTTP/1.1 status line, connection-close framing", do + -- RFC 9110 §6.2: a server sends the highest version it conforms to whose major version is at most + -- the request's, so an HTTP/1.0 request gets an HTTP/1.1 status line with HTTP/1.0 framing + MachineTester.receiving "§6.2: HTTP/1.0 request → HTTP/1.1 status line, connection-close framing" + |>.feed (mkGet10 "/") |>.step + |>.send { status := .ok } |>.sendBytes "hello".toUTF8 |>.userClosedBody + |>.step |>.step + |>.assertOutputStartsWith "HTTP/1.1 200 OK\r\n" "expected an HTTP/1.1 status line" + |>.assertOutputContains "Connection: close\r\n" "an HTTP/1.0 connection without keep-alive closes" + |>.assertOutputNotContains "Transfer-Encoding" "HTTP/1.0 has no chunked framing" |>.run), + ("§6.3: HTTP/1.0 HEAD of unknown length keeps the connection alive", do + -- RFC 9112 §6.3: a HEAD response ends at its header block, so a length the server does not know + -- does not cost an HTTP/1.0 client its keep-alive connection + MachineTester.receiving "§6.3: HTTP/1.0 HEAD of unknown length keeps the connection alive" + |>.feed ("HEAD / HTTP/1.0\r\nConnection: keep-alive\r\n\r\n" ++ + "GET /second HTTP/1.0\r\nConnection: keep-alive\r\n\r\n") + |>.step |>.assertIsWaitingMessage + |>.send { status := .ok } |>.userClosedBody |>.step + |>.assertOutputContains "Connection: keep-alive\r\n" "expected the HTTP/1.0 keep-alive echo" + |>.assertOutputNotContains "Content-Length" "unknown length must not be sent as Content-Length: 0" + |>.assertOutputNotContains "close" "a HEAD response has no body to delimit by closing" + |>.assertHasNext + |>.step |>.assertHasEndHeaders |>.assertKeepAlive |>.run) + ] (·.2) + +#eval checkCases "HTTP/1.0 peers: async_http_h1_v10_framing.lean" #[ + ("HTTP/1.0 GET", + do + check "HTTP/1.0 GET" "GET / HTTP/1.0\x0d\nHost: a\x0d\n\x0d\n" codedHandler fun r => do + assertStatus r "HTTP/1.1 500" + assertAbsent r "GZIPPED" + -- Control: an HTTP/1.1 client gets the coding and the coded bytes. + check "HTTP/1.1 GET" (mkGetClose "/") codedHandler fun r => do + assertStatus r "HTTP/1.1 200" + assertContains r "Transfer-Encoding: gzip, chunked" + assertContains r "GZIPPED") + ] (·.2) + +#eval checkCases "HTTP/1.0 peers: async_http_response_framing.lean" #[ + ("RFC 9112 §6.1: HTTP/1.0 connection-close — headers", + do + let request10 := "GET / HTTP/1.0\x0d\nHost: example.com\x0d\n\x0d\n".toUTF8 + let machine0 : Protocol.H1.Machine .receiving := { config := {} } + let (machine1, _) := (machine0.feed request10).step + let (_, stepA) := (machine1.send ({ status := .ok, headers := .empty } : Response.Head)).step + let textA := String.fromUTF8! stepA.output.toByteArray + unless textA.contains "200 OK" do + throw <| IO.userError s!"expected 200 status line:\n{textA.quote}" + if textA.contains "Transfer-Encoding:" then + throw <| IO.userError s!"Transfer-Encoding must not appear in HTTP/1.0 response:\n{textA.quote}" + if textA.contains "Content-Length:" then + throw <| IO.userError s!"Content-Length must not appear when body length is unknown:\n{textA.quote}"), + ("Non-empty body: raw bytes must appear in output without chunk framing.", + do + let request10 := "GET / HTTP/1.0\x0d\nHost: example.com\x0d\n\x0d\n".toUTF8 + let machine0 : Protocol.H1.Machine .receiving := { config := {} } + let (machine1, _) := (machine0.feed request10).step + -- Non-empty body: raw bytes must appear in output without chunk framing. + let body := "hello world".toUTF8 + let machine2 := + machine1 + |>.send ({ status := .ok, headers := .empty } : Response.Head) + |>.sendData #[{ data := body, extensions := #[] }] + |>.userClosedBody + let (machine3, step2) := machine2.step + let output2 := String.fromUTF8! step2.output.toByteArray + unless output2.contains "hello world" do + throw <| IO.userError s!"body bytes must appear in output:\n{output2.quote}" + -- Chunk framing would look like "b\r\nhello world\r\n0\r\n\r\n" + if output2.contains "0\x0d\x0a\x0d\x0a" then + throw <| IO.userError s!"body must not be chunk-framed (found final-chunk terminator):\n{output2.quote}" + unless step2.events.any (fun | .close => true | _ => false) do + throw <| IO.userError s!"expected .close event after connection-close body:\n{repr step2.events}" + unless !machine3.keepAlive do + throw <| IO.userError "keepAlive must be false for HTTP/1.0 connection-close response" + + -- Empty body: userClosedBody with no data must still emit .close. + let (machine1b, _) := (machine0.feed request10).step + let machine4 := + machine1b + |>.send ({ status := .ok, headers := .empty } : Response.Head) + |>.userClosedBody + let (_, step3) := machine4.step + unless step3.events.any (fun | .close => true | _ => false) do + throw <| IO.userError s!"expected .close event for empty HTTP/1.0 body:\n{repr step3.events}") + ] (·.2) + +/-! ## Handler framing vs body (RFC 9112 §6.3) -/ + +#eval checkCases "Handler framing vs body: async_http_h1_framing_mismatch.lean" #[ + ("An empty body with a handler's `Content-Length`.", + do + -- An empty body with a handler's `Content-Length`. + expect500 "empty body, Content-Length: 1234" <| server get + |>.setKnownSize (.fixed 0) + |>.send { status := .ok, headers := headers [(Header.Name.contentLength, "1234")] }), + ("Framing fields that describe no length.", + do + -- Framing fields that describe no length. + let both := headers [(Header.Name.contentLength, "3"), (Header.Name.transferEncoding, "chunked")] + expect500 "Content-Length with Transfer-Encoding" <| server get + |>.send { status := .ok, headers := both }), + ("Control: matching framing writes the response.", + do + -- Control: matching framing writes the response. + let out ← expectOk "matching Content-Length" <| server + "GET / HTTP/1.1\r\nHost: a\r\nConnection: close\r\n\r\n" + |>.setKnownSize (.fixed 3) + |>.send { status := .ok, headers := headers [(Header.Name.contentLength, "3")] } + |>.sendData abc |>.userClosedBody + unless out.startsWith "HTTP/1.1 200 OK\r\n" && out.endsWith "\r\n\r\nabc" do + throw <| IO.userError s!"matching Content-Length: got\n{out.quote}"), + ("`Body.stream` sets `chunked` before its producer runs, and a producer may set the length", + do + let close := "GET / HTTP/1.1\r\nHost: a\r\nConnection: close\r\n\r\n" + -- `Body.stream` sets `chunked` before its producer runs, and a producer may set the length + -- itself before the server reads it: the head's length wins over `chunked` and matches the other. + for size in [Body.Length.chunked, .fixed 3] do + let out ← expectOk s!"{repr size}, Content-Length: 3" <| server close + |>.setKnownSize size + |>.send { status := .ok, headers := headers [(Header.Name.contentLength, "3")] } + |>.sendData abc |>.userClosedBody + unless out.startsWith "HTTP/1.1 200 OK\r\n" && out.contains "Content-Length: 3\r\n" && + !out.contains "Transfer-Encoding" && out.endsWith "\r\n\r\nabc" do + throw <| IO.userError s!"{repr size}, Content-Length: 3: got\n{out.quote}" + + -- A stream longer than its `Content-Length` closes the connection without writing its bytes. + let some (out, events) := runToHalt (server close + |>.setKnownSize .chunked + |>.send { status := .ok, headers := headers [(Header.Name.contentLength, "3")] } + |>.sendData #[Chunk.ofByteArray "abcd".toUTF8] |>.userClosedBody) + | throw <| IO.userError "overlong stream: the server never halted" + unless out.endsWith "Content-Length: 3\r\n\r\n" && events.any (· matches .close) do + throw <| IO.userError s!"overlong stream: got {repr events}\n{out.quote}"), + ("streamed body with Content-Length: 3", + do + checkTimed "streamed body with Content-Length: 3" + (raw := mkGetClose) + (handler := fun _ => Response.ok |>.header! "Content-Length" "3" + |>.stream fun s => s.send (Chunk.ofByteArray "abc".toUTF8)) + (expect := fun r => do + assertStatus r "HTTP/1.1 200 OK" + assertContains r "Content-Length: 3\r\n" + assertAbsent r "Transfer-Encoding" + assertContains r "\r\n\r\nabc")), + ("streamed body longer than its Content-Length: 3", + do + checkTimed "streamed body longer than its Content-Length: 3" + (raw := get) + (handler := fun _ => Response.ok |>.header! "Content-Length" "3" + |>.stream fun s => s.send (Chunk.ofByteArray "abcd".toUTF8)) + (expect := fun r => do + assertStatus r "HTTP/1.1 200 OK" + assertAbsent r "abc")) + ] (·.2) + + +-- RFC 9112 §6.3: a response shorter than its Content-Length is incomplete, so the connection ends. +#eval checkCases "A streamed body shorter than its Content-Length" #[ + ("500 declared, 9 written", do + let (text, seen, failures) ← serveCounting + "GET /a HTTP/1.1\x0d\nHost: a\x0d\n\x0d\nGET /b HTTP/1.1\x0d\nHost: a\x0d\n\x0d\n" + fun _ => Response.ok |>.header! "Content-Length" "500" |>.stream fun s => s.send (Chunk.ofByteArray "123456789".toUTF8) + ensure (seen == #["/a"]) s!"served {seen}" + ensure ((text.splitOn "HTTP/1.1 ").length == 2 && text.endsWith "123456789") s!"expected one short response:\n{text.quote}" + ensure (failures > 0) "onFailure was not called") + ] (·.2) + +#eval checkCases "After a rejected head, a second send writes nothing" #[ + ("Content-Length 1234 for an empty body, then a 200", do + let m := server get |>.setKnownSize (.fixed 0) + |>.send { status := .ok, headers := headers [(Header.Name.contentLength, "1234")] } + |>.sendData abc |>.userClosedBody + let (m, first) := stepOutput m 8 + ensure (first.startsWith "HTTP/1.1 500") s!"first:\n{first.quote}" + let (_, second) := stepOutput (m.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody) 8 + ensure (second == "") s!"second send wrote:\n{second.quote}") + ] (·.2) + +/-! ## Transfer codings from the handler (RFC 9112 §6.1, RFC 9110 §5.3) -/ + +#eval checkCases "Transfer codings from the handler: machine" #[ + ("§6.1: server keeps the handler's Transfer-Encoding: gzip, chunked", do + -- §6.1: a chunked message keeps the transfer codings its body was coded with + MachineTester.receiving "§6.1: server keeps the handler's Transfer-Encoding: gzip, chunked" + |>.feed (mkGet "/") |>.step |>.assertIsWaitingMessage + |>.send { status := .ok, headers := Headers.empty.insert! "Transfer-Encoding" "gzip, chunked" } + |>.sendBytes "abc".toUTF8 |>.userClosedBody |>.step + |>.assertOutputContains "Transfer-Encoding: gzip, chunked\r\n" "expected the handler's codings" + |>.assertOutputContains "3\r\nabc\r\n0\r\n\r\n" "expected a chunked body" |>.run), + ("§6.1: server keeps the handler's Transfer-Encoding: gzip;level=1, chunked", do + MachineTester.receiving "§6.1: server keeps the handler's Transfer-Encoding: gzip;level=1, chunked" + |>.feed (mkGet "/") |>.step |>.assertIsWaitingMessage + |>.send { status := .ok, headers := Headers.empty.insert! "Transfer-Encoding" "gzip;level=1, chunked" } + |>.sendBytes "abc".toUTF8 |>.userClosedBody |>.step + |>.assertOutputContains "Transfer-Encoding: gzip;level=1, chunked\r\n" "expected the handler's codings" + |>.assertOutputContains "3\r\nabc\r\n0\r\n\r\n" "expected a chunked body" |>.run), + ("§6.1: server writes the handler's two Transfer-Encoding lines as one", do + -- RFC 9110 §5.3: codings over several field lines are one list, written as one field + MachineTester.receiving "§6.1: server writes the handler's two Transfer-Encoding lines as one" + |>.feed (mkGet "/") |>.step |>.assertIsWaitingMessage + |>.send { status := .ok, headers := + (Headers.empty.insert! "Transfer-Encoding" "gzip").insert! "Transfer-Encoding" "chunked" } + |>.sendBytes "abc".toUTF8 |>.userClosedBody |>.step + |>.assertOutputContains "Transfer-Encoding: gzip, chunked\r\n" "expected the combined codings" + |>.assertOutputNotContains "Transfer-Encoding: chunked\r\n" "expected one Transfer-Encoding field" + |>.assertOutputContains "3\r\nabc\r\n0\r\n\r\n" "expected a chunked body" |>.run) + ] (·.2) + +/-! ## Chunked writer (RFC 9112 §7.1) -/ + +#eval checkCases "Chunked writer: machine" #[ + ("§7.1: server sends chunked response — wire encoding correct", do + -- §7.1: server writes chunk-size lines and terminal 0\r\n\r\n when userClosedBody is called + let body1 := "Hello, ".toUTF8 + let body2 := "World!".toUTF8 + MachineTester.receiving "§7.1: server sends chunked response — wire encoding correct" + |>.feed (mkGet "/") |>.step |>.assertIsWaitingMessage + |>.send { status := .ok } |>.setKnownSize .chunked + |>.sendBytes body1 |>.step + |>.sendBytes body2 |>.userClosedBody |>.step + |>.assertOutputContains "7\r\nHello, \r\n" "expected first chunk in wire output" + |>.assertOutputContains "6\r\nWorld!\r\n" "expected second chunk in wire output" + |>.assertOutputContains "0\r\n\r\n" "expected final empty chunk in wire output" + |>.run) + ] (·.2) + +-- A zero-size chunk is the last-chunk, so the encoder skips empty non-final chunks and later data +-- still reaches the client. +#eval checkCases "Chunked writer: server" #[ + ("empty chunk with extensions before real data — real data still received", + check "empty chunk with extensions before real data — real data still received" + (raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") + (handler := fun _ => do + let ext := (Chunk.ExtensionName.ofString! "test", some (Chunk.ExtensionValue.ofString! "val")) + Response.ok |>.stream fun s => do + s.send { data := .empty, extensions := #[ext] } + s.send (Chunk.ofByteArray "after\n".toUTF8)) + (expect := fun r => do + assertStatus r "HTTP/1.1 200" + let text := String.fromUTF8! r + ensure (text.endsWith "after\n\x0d\n0\x0d\n\x0d\n") s!"expected the body to end with the data and one last-chunk:\n{text.quote}" + ensure ((text.splitOn "\x0d\n0\x0d\n\x0d\n").length == 2) s!"an empty chunk was written as a last-chunk:\n{text.quote}")), + ("multiple empty chunks before real data — real data still received", + check "multiple empty chunks before real data — real data still received" + (raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") + (handler := fun _ => do + Response.ok |>.stream fun s => do + s.send Chunk.empty + s.send Chunk.empty + s.send (Chunk.ofByteArray "data\n".toUTF8)) + (expect := fun r => do + let text := String.fromUTF8! r + ensure (text.endsWith "data\n\x0d\n0\x0d\n\x0d\n") s!"expected the body to end with the data and one last-chunk:\n{text.quote}" + ensure ((text.splitOn "\x0d\n0\x0d\n\x0d\n").length == 2) s!"an empty chunk was written as a last-chunk:\n{text.quote}")) + ] (·.2) + +/-! ## CONNECT (RFC 9110 §9.3.6) -/ + +#eval checkCases "CONNECT: async_http_connect_response.lean" #[ + ("200 with content", + do + check "200 with content" (connectRequest ++ tunnelBytes) handledHandler fun r => do + assertExact r "HTTP/1.1 200 OK\x0d\nContent-Type: text/plain; charset=utf-8\x0d\nServer: LeanHTTP/1.1\x0d\nConnection: close\x0d\n\x0d\n" + assertStatus r "HTTP/1.1 200 OK" + assertResponseCount r 1 + assertAbsent r "Content-Length" + assertAbsent r "Transfer-Encoding" + assertAbsent r "handled" + check "200 streamed" (connectRequest ++ tunnelBytes) + (fun _ => Response.ok |>.stream fun out => out.send (Chunk.ofByteArray "tunnel".toUTF8)) + fun r => do + assertResponseCount r 1 + assertAbsent r "Transfer-Encoding" + assertAbsent r "tunnel"), + ("403", + do + checkClose "403" connectRequest (fun _ => Response.forbidden |>.text "no") fun r => do + assertStatus r "HTTP/1.1 403" + assertContains r "Content-Length: 2" + assertContains r "\x0d\n\x0d\nno") + ] (·.2)
diff --git a/tests/async/elab/async_http_h1_rfc_compliance.lean b/tests/async/elab/async_http_h1_rfc_compliance.lean deleted file mode 100644 index 1717f8a..0000000 --- a/tests/async/elab/async_http_h1_rfc_compliance.lean +++ /dev/null
@@ -1,1344 +0,0 @@ -import Std.Http -import Std.Http.Test.Helpers - -open Std Http -open Std.Http.Internal.Test -open Std.Http.Protocol.H1 -open Std.Http.Protocol.H1.Machine - -/-! -`MachineTester (dir : Direction)` is a direction-parameterized, chainable builder for exercising -`Machine dir`. Operations return a new tester; failures accumulate and are thrown as a single -`IO.userError` by `run`. - -Use `MachineTester.receiving` for server-side (request parsing) tests and -`MachineTester.sending` for client-side (response parsing) tests. --/ - -private structure MachineTester (dir : Direction) where - - /-- - Human-readable name used in error messages. - -/ - name : String - - /-- - The machine under test. - -/ - machine : Machine dir - - /-- - Events and output produced by the most recent `step` or `pullBody`. - -/ - lastStep : Option (StepResult dir) := none - - /-- - Body chunks collected by `drainBody` / `pullBody`. - -/ - pulled : Array PulledChunk := #[] - - /-- - Cumulative wire output across all `step` calls. - -/ - allOutput : ByteArray := .empty - - /-- - Accumulated assertion failures; `run` throws if non-empty. - -/ - errors : Array String := #[] - -namespace MachineTester - -private def addError (t : MachineTester dir) (msg : String) : MachineTester dir := - { t with errors := t.errors.push s!"[{t.name}] {msg}" } - -private def withLastStep - (t : MachineTester dir) (ctx : String) - (k : MachineTester dir → StepResult dir → MachineTester dir) : MachineTester dir := - match t.lastStep with - | none => t.addError s!"{ctx}: no step result (call .step first)" - | some step => k t step - -/-- Create a new tester for the given direction. -/ -def new (name : String) (config : Protocol.H1.Config := {}) : MachineTester dir := - { name, machine := { config } } - -/-- Create a new server-side tester (receives requests, sends responses). -/ -def receiving (name : String) (config : Protocol.H1.Config := {}) : MachineTester .receiving := - { name, machine := { config } } - -/-- Create a new client-side tester (sends requests, receives responses). -/ -def sending (name : String) (config : Protocol.H1.Config := {}) : MachineTester .sending := - { name, machine := { config } } - -/-- Feed a UTF-8 string to the machine. -/ -def feed (t : MachineTester dir) (data : String) : MachineTester dir := - { t with machine := t.machine.feed data.toUTF8, lastStep := none } - -/-- Feed raw bytes to the machine. -/ -def feedBytes (t : MachineTester dir) (data : ByteArray) : MachineTester dir := - { t with machine := t.machine.feed data, lastStep := none } - -/-- Run one step of the state machine and record the result. -/ -def step (t : MachineTester dir) : MachineTester dir := - let (machine, stepResult) := t.machine.step - let allOutput := t.allOutput ++ stepResult.output.toByteArray - { t with machine, lastStep := some stepResult, allOutput } - - -def debug (t : MachineTester dir) : MachineTester dir := - dbg_trace "resp: {repr <| t.lastStep.map (StepResult.events)}"; - t - -/-- -Pull at most one body chunk. Updates `pulled` and replaces `lastStep` with the -events emitted during the pull. --/ -def pullBody (t : MachineTester dir) : MachineTester dir := - let (machine, chunk?) := t.machine.pullBody - let (machine, pullEvents) := machine.takeEvents - let pulled := match chunk? with - | some chunk => t.pulled.push chunk - | none => t.pulled - { t with machine, pulled, lastStep := some { events := pullEvents } } - -/-- -Drain all immediately-available body chunks. - -The loop exits when `canPullBodyNow` becomes false (either the body is complete -or the machine stalls waiting for more data). The stall flag is set internally -by `pullBody`, so no explicit `remainingBytes` guard is needed. --/ -def drainBody (t : MachineTester dir) (fuel : Nat := 4096) : MachineTester dir := Id.run do - let mut t := t - let mut remaining := fuel - while remaining > 0 && t.machine.canPullBodyNow do - remaining := remaining - 1 - t := t.pullBody - t - -/-- Set the known outgoing body size (forwarded to the writer). -/ -def setKnownSize (t : MachineTester dir) (size : Body.Length) : MachineTester dir := - { t with machine := t.machine.setKnownSize size } - -/-- Signal EOF on the reader input (no more socket bytes will arrive). -/ -def noMoreInput (t : MachineTester dir) : MachineTester dir := - { t with machine := t.machine.noMoreInput } - -/-- Send a message head (request for `.sending`, response for `.receiving`). -/ -def send (t : MachineTester dir) (head : Message.Head dir.swap) : MachineTester dir := - { t with machine := t.machine.send head } - -/-- Signal that the application has finished writing the message body. -/ -def userClosedBody (t : MachineTester dir) : MachineTester dir := - { t with machine := t.machine.userClosedBody } - -/-- Resolve an `Expect: 100-continue` decision. No-op for `.sending` direction. -/ -def canContinue (t : MachineTester dir) (status : Status) : MachineTester dir := - { t with machine := t.machine.canContinue status } - -/-- Send an error response with `Connection: close` and shut down input. Only valid for `.receiving`. -/ -def closeWithError (t : MachineTester .receiving) (status : Status) : MachineTester .receiving := - { t with machine := t.machine.closeWithError status } - -/-- Enqueue body chunks into the writer buffer. -/ -def sendData (t : MachineTester dir) (chunks : Array Chunk) : MachineTester dir := - { t with machine := t.machine.sendData chunks } - -/-- Enqueue raw bytes as a single body chunk into the writer buffer. -/ -def sendBytes (t : MachineTester dir) (data : ByteArray) : MachineTester dir := - t.sendData #[{ data, extensions := #[] }] - -/-- Assert a predicate on the current machine. -/ -def assert (t : MachineTester dir) (pred : Machine dir → Bool) (msg : String) : MachineTester dir := - if pred t.machine then t else t.addError msg - -/-- -Assert that the machine has not failed (reader state ≠ `.failed`). - -**Note:** `machine.failed` returns `false` after any `step` call because `step` transitions -the reader from `.failed` to `.closed`. Use `assertNoError` for post-step success checks. --/ -def assertNoFailure (t : MachineTester dir) : MachineTester dir := - t.assert (fun m => !m.failed) - s!"machine should not fail, got error: {repr t.machine.error}" - -/-- Assert that `machine.error` is `none`. -/ -def assertNoError (t : MachineTester dir) : MachineTester dir := - t.assert (fun m => m.error == none) - s!"machine should have no error, got: {repr t.machine.error}" - -/-- Assert that the machine has failed with the given error. -/ -def assertFailedWith (t : MachineTester dir) (expected : Error) : MachineTester dir := - t.assert (fun m => m.error == some expected) - s!"expected error {repr expected}, got {repr t.machine.error}" - -/-- Assert that `canPullBody` is true. -/ -def assertCanPullBody (t : MachineTester dir) : MachineTester dir := - t.assert (·.canPullBody) "expected canPullBody = true" - -/-- Assert that `canPullBodyNow` is true. -/ -def assertCanPullBodyNow (t : MachineTester dir) : MachineTester dir := - t.assert (·.canPullBodyNow) "expected canPullBodyNow = true" - -/-- Assert that the reader is in the `complete` state. -/ -def assertReaderComplete (t : MachineTester dir) : MachineTester dir := - t.assert (·.isReaderComplete) - s!"expected reader to be complete, state: {repr t.machine.reader.state}" - -/-- Assert that the reader is in the `closed` state. -/ -def assertReaderClosed (t : MachineTester dir) : MachineTester dir := - t.assert (·.isReaderClosed) - s!"expected reader to be closed, state: {repr t.machine.reader.state}" - -/-- Assert that `keepAlive` is true on the machine. -/ -def assertKeepAlive (t : MachineTester dir) : MachineTester dir := - t.assert (·.keepAlive) "expected keepAlive = true" - -/-- Assert that `keepAlive` is false on the machine. -/ -def assertNotKeepAlive (t : MachineTester dir) : MachineTester dir := - t.assert (fun m => !m.keepAlive) "expected keepAlive = false" - -/-- Assert that `isWaitingMessage` is true (writer in `waitingHeaders`, `!sentMessage`). -/ -def assertIsWaitingMessage (t : MachineTester dir) : MachineTester dir := - t.assert (·.isWaitingMessage) "expected isWaitingMessage = true" - -/-- Assert that `halted` is true (both reader and writer closed, no output). -/ -def assertHalted (t : MachineTester dir) : MachineTester dir := - t.assert (·.halted) "expected machine to be halted" - -/-- Assert that at least one event in the last step matches `pred`. -/ -def assertHasEvent - (t : MachineTester dir) (pred : Event dir → Bool) (msg : String) : MachineTester dir := - t.withLastStep "assertHasEvent" fun t step => - if step.events.any pred then t - else t.addError s!"{msg}\n events: {repr step.events}" - -/-- Assert that no event in the last step matches `pred`. -/ -def assertNoEvent - (t : MachineTester dir) (pred : Event dir → Bool) (msg : String) : MachineTester dir := - t.withLastStep "assertNoEvent" fun t step => - if step.events.any pred then - t.addError s!"{msg}\n events: {repr step.events}" - else t - -/-- Assert that the last step contains an `endHeaders` event. -/ -def assertHasEndHeaders (t : MachineTester dir) : MachineTester dir := - t.assertHasEvent (fun | .endHeaders _ => true | _ => false) "expected endHeaders event" - -/-- Assert that the last step contains a `failed` event for the given error. -/ -def assertHasFailedEvent (t : MachineTester dir) (expected : Error) : MachineTester dir := - t.assertHasEvent (fun | .failed err => err == expected | _ => false) - s!"expected failed event with {repr expected}" - -/-- Assert that the last step contains a `closeBody` event. -/ -def assertHasCloseBody (t : MachineTester dir) : MachineTester dir := - t.assertHasEvent (fun | .closeBody => true | _ => false) "expected closeBody event" - -/-- Assert that the last step contains a `next` event. -/ -def assertHasNext (t : MachineTester dir) : MachineTester dir := - t.assertHasEvent (fun | .next => true | _ => false) "expected next event" - -/-- Assert that the last step contains a `continue` event. -/ -def assertHasContinue (t : MachineTester dir) : MachineTester dir := - t.assertHasEvent (fun | .«continue» => true | _ => false) "expected continue event" - -/-- Inspect the `endHeaders` payload in the last step. -/ -def onEndHeaders - (t : MachineTester dir) - (f : MachineTester dir → Message.Head dir → MachineTester dir) : MachineTester dir := - t.withLastStep "onEndHeaders" fun t step => - match step.events.findSome? (fun | .endHeaders h => some h | _ => none) with - | none => t.addError "onEndHeaders: no endHeaders event in last step" - | some head => f t head - -/-- Assert that the cumulative output starts with the given ASCII string. -/ -def assertOutputStartsWith (t : MachineTester dir) (pfx : String) (msg : String) : MachineTester dir := - let s := String.fromUTF8! t.allOutput - if s.startsWith pfx then t - else - let preview := String.fromUTF8! (t.allOutput.extract 0 (min t.allOutput.size 120)) - t.addError s!"{msg}: expected output to start with {repr pfx}\n got: {repr preview}" - -/-- Assert that the cumulative output contains the given ASCII substring. -/ -def assertOutputContains (t : MachineTester dir) (needle : String) (msg : String) : MachineTester dir := - let haystack := t.allOutput - let nb := needle.toUTF8 - let found := - if nb.isEmpty then true - else if nb.size > haystack.size then false - else (Array.range (haystack.size - nb.size + 1)).any fun i => - (Array.range nb.size).all fun j => haystack.get! (i + j) == nb.get! j - if found then t - else - let preview := String.fromUTF8! (haystack.extract 0 (min haystack.size 160)) - t.addError s!"{msg}: expected output to contain {repr needle}\n output: {repr preview}" - -/-- Assert that the cumulative output does not contain the given ASCII substring. -/ -def assertOutputNotContains (t : MachineTester dir) (needle : String) (msg : String) : MachineTester dir := - let haystack := t.allOutput - let nb := needle.toUTF8 - let found := - if nb.isEmpty then true - else if nb.size > haystack.size then false - else (Array.range (haystack.size - nb.size + 1)).any fun i => - (Array.range nb.size).all fun j => haystack.get! (i + j) == nb.get! j - if found then - let preview := String.fromUTF8! (haystack.extract 0 (min haystack.size 160)) - t.addError s!"{msg}: expected output NOT to contain {repr needle}\n output: {repr preview}" - else t - -/-- Assert that the total bytes pulled so far equal `expected`. -/ -def assertPulledBody (t : MachineTester dir) (expected : ByteArray) : MachineTester dir := - let got := t.pulled.foldl (fun acc c => acc ++ c.chunk.data) ByteArray.empty - if got == expected then t - else t.addError - s!"body mismatch:\n expected={String.fromUTF8! expected |>.quote}\n got={String.fromUTF8! got |>.quote}" - -/-- Assert that at least one chunk was pulled and the last one is `final`. -/ -def assertLastChunkFinal (t : MachineTester dir) : MachineTester dir := - match t.pulled.back? with - | none => t.addError "assertLastChunkFinal: no chunks pulled yet" - | some chunk => - if chunk.final then t - else t.addError "expected last pulled chunk to be final" - -/-- Run a custom check on the current machine state. -/ -def onMachine (t : MachineTester dir) (f : MachineTester dir → Machine dir → MachineTester dir) : MachineTester dir := - f t t.machine - -/-- Throw if any assertion has failed; otherwise succeed. -/ -def run (t : MachineTester dir) : IO Unit := - unless t.errors.isEmpty do - throw <| IO.userError <| "\n".intercalate t.errors.toList - -end MachineTester - ----------------------------------------------------------------------------------------------------- - -private def mkGet10 (path : String := "/") : String := - s!"GET {path} HTTP/1.0\r\n\r\n" - -private def mkPostHead (path : String) (bodyLen : Nat) (extra : String := "") : String := - s!"POST {path} HTTP/1.1\r\nHost: example.com\r\nContent-Length: {bodyLen}\r\n{extra}\r\n" - -private def mkChunkedPost (path : String) (extra : String := "") : String := - s!"POST {path} HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: chunked\r\n{extra}\r\n" - ----------------------------------------------------------------------------------------------------- - -private def minimalGetRequest : Request.Head := - { method := .get, version := .v11, uri := RequestTarget.originForm! "/", - headers := Headers.empty.insert! "Host" "example.com" } - ----------------------------------------------------------------------------------------------------- - -#eval runGroup "RFC 9112 §2.2: leading CRLF before request-line" do - MachineTester.receiving "§2.2: leading CRLF ignored" (config := { maxLeadingEmptyLines := 8 }) - |>.feed "\r\n\r\nGET / HTTP/1.1\r\nHost: example.com\r\n\r\n" - |>.step |>.assertNoError |>.assertHasEndHeaders |>.run - - MachineTester.receiving "§2.2: maximum leading CRLFs" (config := { maxLeadingEmptyLines := 2 }) - |>.feed "\r\n\r\n\r\nGET / HTTP/1.1\r\nHost: example.com\r\n\r\n" - |>.step |>.assertFailedWith .badMessage |>.run - -#eval runGroup "RFC 9112 §2–§3: version and method parsing" do - MachineTester.receiving "§2: HTTP/2.0 → unsupportedVersion" - |>.feed "GET / HTTP/2.0\r\nHost: example.com\r\n\r\n" - |>.step |>.assertFailedWith .unsupportedVersion |>.run - - for version in ["HTTP/0.9", "HTTP/3.0"] do - MachineTester.receiving s!"§2: {version} → unsupportedVersion" - |>.feed s!"GET / {version}\r\nHost: example.com\r\n\r\n" - |>.step |>.assertFailedWith .unsupportedVersion |>.run - - -- RFC 9110 §6.2: a higher minor version is processed as the highest minor version the recipient - -- implements - for version in ["HTTP/1.2", "HTTP/1.9"] do - MachineTester.receiving s!"§2: {version} request is read as HTTP/1.1" - |>.feed s!"GET / {version}\r\nHost: example.com\r\n\r\n" - |>.step |>.assertNoError |>.assertHasEndHeaders |>.assertKeepAlive - |>.onEndHeaders (fun t head => - if head.version != .v11 then t.addError s!"expected HTTP/1.1, got {repr head.version}" else t) - |>.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody |>.step - |>.assertOutputStartsWith "HTTP/1.1 200 OK\r\nContent-Length: 0\r\n\r\n" "expected an HTTP/1.1 response" - |>.assertKeepAlive |>.run - - -- RFC 9110 §9.1, RFC 9112 §3: a well-formed method the server does not recognize, or one longer - -- than any it implements, is answered with 501. Methods are case-sensitive. - let longMethod := String.ofList (List.replicate 65 'G') - for (label, method) in [("LEAN", "LEAN"), ("GETX", "GETX"), ("get", "get"), ("X-CUSTOM", "X-CUSTOM"), - ("UPDATEX", "UPDATEX"), ("a 65-byte token", longMethod)] do - MachineTester.receiving s!"§3: unrecognized method {label} → unsupportedMethod" - |>.feed s!"{method} / HTTP/1.1\r\nHost: example.com\r\n\r\n" - |>.step |>.assertFailedWith .unsupportedMethod - |>.step |>.assertOutputStartsWith "HTTP/1.1 501 Not Implemented\r\n" "expected 501" |>.run - - -- A method that is not a token makes the request line malformed - for line in ["G@T / HTTP/1.1", "GÉT / HTTP/1.1", "GET\t/ HTTP/1.1", "GETHTTP/1.1"] do - MachineTester.receiving s!"§3: {line.quote} → badMessage" - |>.feed s!"{line}\r\nHost: example.com\r\n\r\n" - |>.step |>.assertFailedWith .badMessage |>.run - - -- The method is read whole before it is matched, so the outcome does not depend on where a read - -- ends inside it (#16111: `UPDATE` must not match the start of `UPDATEREDIRECTREF`) - for expected in Method.all do - let name := toString expected - unless Method.ofString? name == some expected do - throw <| IO.userError s!"Method.ofString? {name.quote} is not {repr expected}" - let (target, host) := if name == "CONNECT" then ("example.com:443", "example.com:443") else ("/", "example.com") - let request := s!"{name} {target} HTTP/1.1\r\nHost: {host}\r\n\r\n".toUTF8 - for i in [1:name.length + 2] do - MachineTester.receiving s!"§3: {name} split after byte {i}" - |>.feedBytes (request.extract 0 i) |>.step |>.assertNoError - |>.feedBytes (request.extract i request.size) |>.step |>.assertNoError - |>.onEndHeaders (fun t head => - if head.method == expected then t else t.addError s!"expected {name}, got {repr head.method}") - |>.run - - for method in ["LEAN", "GETX", "UPDATEX", "UPDATEREDIRECTREFS"] do - let request := s!"{method} / HTTP/1.1\r\nHost: example.com\r\n\r\n".toUTF8 - for i in [1:method.length + 1] do - MachineTester.receiving s!"§3: unrecognized {method} split after byte {i} → unsupportedMethod" - |>.feedBytes (request.extract 0 i) |>.step |>.assertNoError - |>.feedBytes (request.extract i request.size) |>.step - |>.assertFailedWith .unsupportedMethod |>.run - - MachineTester.receiving "§3: GET method and HTTP/1.1 version parsed correctly" - |>.feed "GET /path HTTP/1.1\r\nHost: example.com\r\n\r\n" - |>.step |>.assertNoError - |>.onEndHeaders (fun t head => - if head.method != .get then t.addError s!"expected method GET, got {repr head.method}" - else if head.version != .v11 then t.addError s!"expected HTTP/1.1, got {repr head.version}" - else t) - |>.run - -#eval runGroup "RFC 9110 §2.5, §5.5 / RFC 9112 §4: response start line and field values" do - -- §5.5: a recipient treats obs-text in a field value as opaque data - MachineTester.sending "§5.5: obs-text in a response field value is accepted" - |>.send minimalGetRequest |>.step - |>.feedBytes ("HTTP/1.1 200 OK\r\nContent-Disposition: attachment; filename=\"caf".toUTF8 - ++ ByteArray.mk #[0xC3, 0xA9] ++ ".txt\"\r\nX-Latin1: caf".toUTF8 ++ ByteArray.mk #[0xE9] - ++ "\r\nContent-Length: 0\r\n\r\n".toUTF8) - |>.step |>.assertNoError |>.assertHasEndHeaders - |>.onEndHeaders (fun t head => - let disposition := (head.headers.get? (.ofString! "Content-Disposition")).map (·.value) - let latin1 := (head.headers.get? (.ofString! "X-Latin1")).map (·.value) - if disposition != some "attachment; filename=\"café.txt\"" then - t.addError s!"Content-Disposition mismatch: {repr disposition}" - else if latin1 != some "caf\uFFFD" then - t.addError s!"X-Latin1 mismatch: {repr latin1}" - else t) - |>.run - - -- §4: obs-text in a reason phrase, which a client ignores - MachineTester.sending "§4: obs-text in the reason phrase is accepted" - |>.send minimalGetRequest |>.step - |>.feedBytes ("HTTP/1.1 200 Tr".toUTF8 ++ ByteArray.mk #[0xC3, 0xA8] ++ "s bien ".toUTF8 - ++ ByteArray.mk #[0xFF] ++ "\r\nContent-Length: 0\r\n\r\n".toUTF8) - |>.step |>.assertNoError - |>.onEndHeaders (fun t head => - if head.status.toCode != 200 then t.addError s!"expected 200, got {head.status.toCode}" else t) - |>.run - - -- §4: a status line that ends right after the status code - MachineTester.sending "§4: status line with no space after the code is accepted" - |>.send minimalGetRequest |>.step - |>.feed "HTTP/1.1 204\r\n\r\n" - |>.step |>.assertNoError - |>.onEndHeaders (fun t head => - if head.status != .noContent then t.addError s!"expected 204, got {head.status.toCode}" else t) - |>.run - - -- §2.5: a higher minor version is processed as the highest minor version the recipient implements - MachineTester.sending "§2.5: HTTP/1.2 response is read as HTTP/1.1" - |>.send minimalGetRequest |>.step - |>.feed "HTTP/1.2 200 OK\r\nContent-Length: 2\r\n\r\nok" - |>.step |>.assertNoError |>.assertKeepAlive - |>.onEndHeaders (fun t head => - if head.version != .v11 then t.addError s!"expected HTTP/1.1, got {repr head.version}" else t) - |>.drainBody |>.assertPulledBody "ok".toUTF8 |>.run - -#eval runGroup "RFC 9112 §7.1.2 / RFC 9110 §6.5: trailer fields" do - -- §6.5.1: a client drops a trailer field it must not process instead of failing the response - MachineTester.sending "§6.5: forbidden non-framing trailer field in a response is dropped" - |>.send minimalGetRequest |>.step - |>.feed "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n2\r\nok\r\n0\r\nCache-Control: no-cache\r\n\r\n" - |>.step |>.assertNoError - |>.drainBody |>.assertNoError |>.assertPulledBody "ok".toUTF8 |>.assertLastChunkFinal |>.run - - -- a field that frames the message is still refused in a response's trailers - MachineTester.sending "§6.5: framing field in response trailers → badMessage" - |>.send minimalGetRequest |>.step - |>.feed "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n2\r\nok\r\n0\r\nContent-Length: 2\r\n\r\n" - |>.step |>.drainBody |>.assertFailedWith .badMessage |>.run - - -- a server keeps rejecting every field forbidden in a request's trailers - MachineTester.receiving "§6.5: forbidden trailer field in a request → badMessage" - |>.feed (mkChunkedPost "/" ++ "2\r\nok\r\n0\r\nCache-Control: no-cache\r\n\r\n") - |>.step |>.drainBody |>.assertFailedWith .badMessage |>.run - -#eval runGroup "RFC 9112 §3.2–§3.3: request-target form and Host" do - MachineTester.receiving "§3.2.1: origin-form path preserved" - |>.feed "GET /api/v1/users?active=true HTTP/1.1\r\nHost: api.example.com\r\n\r\n" - |>.step |>.assertNoError - |>.onEndHeaders (fun t head => - let path := toString head.uri.path - if path != "/api/v1/users" then t.addError s!"expected path /api/v1/users, got {path}" - else t) - |>.run - - MachineTester.receiving "§3.2: non-OPTIONS asterisk-form → badMessage" - |>.feed "GET * HTTP/1.1\r\nHost: example.com\r\n\r\n" - |>.step |>.assertFailedWith .badMessage |>.run - - MachineTester.receiving "§3.2: non-CONNECT authority-form → badMessage" - |>.feed "GET example.com:80 HTTP/1.1\r\nHost: example.com\r\n\r\n" - |>.step |>.assertFailedWith .badMessage |>.run - - MachineTester.receiving "§3.2: origin-form valid for GET" - |>.feed "GET /ata HTTP/1.1\r\nHost: example.com\r\n\r\n" - |>.step |>.assertNoError |>.run - - MachineTester.receiving "§3.3: absolute-form with explicit :80" - |>.feed "GET http://example.com:80/path HTTP/1.1\r\nHost: example.com\r\n\r\n" - |>.step |>.assertNoError |>.assertHasEndHeaders |>.run - - MachineTester.receiving "§3.2: HTTP/1.1 missing Host → badMessage" - |>.feed "GET / HTTP/1.1\r\n\r\n" - |>.step |>.assertFailedWith .badMessage |>.run - - MachineTester.receiving "§3.2: HTTP/1.1 duplicate Host → badMessage" - |>.feed "GET / HTTP/1.1\r\nHost: a.com\r\nHost: b.com\r\n\r\n" - |>.step |>.assertFailedWith .badMessage |>.run - - -- RFC 9110 §7.2: `Host` is an RFC 3986 `host`, which may be percent-encoded. The field reaches the - -- handler as sent. - MachineTester.receiving "§3.2: percent-encoded Host accepted" - |>.feed "GET / HTTP/1.1\r\nHost: ex%41mple.com\r\n\r\n" - |>.step |>.assertNoError - |>.onEndHeaders (fun t head => - match head.headers.get? .host with - | some v => if v.value == "ex%41mple.com" then t else t.addError s!"expected Host=ex%41mple.com, got {v.value.quote}" - | none => t.addError "missing Host header") - |>.run - - MachineTester.receiving "§3.3: percent-encoded absolute-form host decoded" - |>.feed "GET http://ex%41mple.com/ HTTP/1.1\r\nHost: example.com\r\n\r\n" - |>.step |>.assertNoError - |>.onEndHeaders (fun t head => - match head.uri.authority? with - | some a => if toString a == "example.com" then t else t.addError s!"expected URI authority=example.com, got {toString a}" - | none => t.addError "missing URI authority") - |>.run - - MachineTester.receiving "§3.2: Host with a percent-encoded `/` → badMessage" - |>.feed "GET / HTTP/1.1\r\nHost: exa%2Fmple.com\r\n\r\n" - |>.step |>.assertFailedWith .badMessage |>.run - - -- RFC 9112 §3.2.2: Host is left as-is; authority is available via the URI. - MachineTester.receiving "§3.2: absolute-form Host preserved, authority in URI" - |>.feed "GET http://example.com:80/path HTTP/1.1\r\nHost: random.com\r\n\r\n" - |>.step |>.assertNoError - |>.onEndHeaders (fun t head => - let t := match head.headers.get? .host with - | some v => if v.value == "random.com" then t else t.addError s!"expected Host=random.com, got {v.value.quote}" - | none => t.addError "missing Host header" - match head.uri.authority? with - | some a => if toString a == "example.com:80" then t else t.addError s!"expected URI authority=example.com:80, got {toString a}" - | none => t.addError "missing URI authority") - |>.run - -#eval runGroup "RFC 9112 §6: Transfer-Encoding validation" do - -- RFC 9110 §5.3: the field lines of Transfer-Encoding form one list, so these are `gzip, chunked` - MachineTester.receiving "§6.1: gzip and chunked on two field lines → unsupportedTransferCoding" - |>.feed "POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: gzip\r\nTransfer-Encoding: chunked\r\n\r\n" - |>.step |>.assertFailedWith .unsupportedTransferCoding |>.run - - MachineTester.receiving "§6.1: chunked on two field lines is chunked applied twice → badMessage" - |>.feed "POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: chunked\r\nTransfer-Encoding: chunked\r\n\r\n" - |>.step |>.assertFailedWith .badMessage |>.run - - MachineTester.receiving "§6.3: Transfer-Encoding on two field lines with Content-Length → badMessage" - |>.feed ("POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: gzip\r\n" ++ - "Transfer-Encoding: chunked\r\nContent-Length: 3\r\n\r\n") - |>.step |>.assertFailedWith .badMessage |>.run - - -- RFC 9110 §5.6.1.2: empty list elements are ignored - MachineTester.receiving "§6.1: accepted codings over two field lines with empty elements" - (config := { acceptedTransferCodings := #["gzip"] }) - |>.feed ("POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: gzip, \r\n" ++ - "Transfer-Encoding: , chunked\r\n\r\n3\r\nabc\r\n0\r\n\r\n") - |>.step |>.assertNoError - |>.drainBody |>.assertNoError |>.assertPulledBody "abc".toUTF8 |>.assertLastChunkFinal |>.run - - MachineTester.receiving "§6.1: Transfer-Encoding: gzip, , chunked → unsupportedTransferCoding" - |>.feed "POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: gzip, , chunked\r\n\r\n" - |>.step |>.assertFailedWith .unsupportedTransferCoding |>.run - - MachineTester.receiving "§6.1: Transfer-Encoding: identity → badMessage" - |>.feed "POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: identity\r\n\r\n" - |>.step |>.assertFailedWith .badMessage |>.run - - -- §6.1: a server answers a transfer coding it does not understand with 501; only `chunked` is - -- decoded, so any other coding before it is not implemented - for coding in ["gzip, chunked", "br, chunked", "gzip;level=1, chunked", "x-custom, gzip, chunked"] do - MachineTester.receiving s!"§6.1: Transfer-Encoding: {coding} request → 501 Not Implemented" - |>.feed (s!"POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: {coding}\r\n\r\n" ++ - "3\r\nabc\r\n0\r\n\r\n") - |>.step |>.assertFailedWith .unsupportedTransferCoding - |>.step - |>.assertOutputStartsWith "HTTP/1.1 501 Not Implemented\r\n" "expected 501" - |>.assertOutputContains "Connection: close\r\n" "the unread body ends the connection" |>.run - - -- §6.3 rule 4: a request whose final coding is not `chunked` has no reliable length: 400, not 501 - MachineTester.receiving "§6.3: Transfer-Encoding: gzip request → badMessage" - |>.feed "POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: gzip\r\n\r\nabc" - |>.step |>.assertFailedWith .badMessage |>.run - - -- §6.1: a coding the application decodes itself is accepted; the machine removes only the chunked - -- framing and keeps the field that says which codings are left - let teField (expected : String) (t : MachineTester .receiving) (head : Request.Head) : - MachineTester .receiving := - match head.headers.getAll? Header.Name.transferEncoding with - | some #[value] => - if value.value == expected then t - else t.addError s!"expected Transfer-Encoding {expected.quote}, got {value.value.quote}" - | _ => t.addError "expected one Transfer-Encoding field" - - MachineTester.receiving "§6.1: accepted gzip;level=1, chunked → body still coded, field kept" - (config := { acceptedTransferCodings := #["gzip"] }) - |>.feed ("POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: gzip;level=1, chunked\r\n\r\n" ++ - "3\r\nabc\r\n0\r\n\r\n") - |>.step |>.assertNoError |>.onEndHeaders (teField "gzip;level=1, chunked") - |>.drainBody |>.assertNoError |>.assertPulledBody "abc".toUTF8 |>.assertLastChunkFinal |>.run - - MachineTester.receiving "§6.1: accepted coding names are compared case-insensitively" - (config := { acceptedTransferCodings := #["GZIP"] }) - |>.feed ("POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: Gzip, Chunked\r\n\r\n" ++ - "3\r\nabc\r\n0\r\n\r\n") - |>.step |>.assertNoError |>.onEndHeaders (teField "Gzip, Chunked") - |>.drainBody |>.assertNoError |>.assertPulledBody "abc".toUTF8 |>.run - - MachineTester.receiving "§6.1: every coding before chunked must be accepted" - (config := { acceptedTransferCodings := #["gzip"] }) - |>.feed ("POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: br, gzip, chunked\r\n\r\n" ++ - "3\r\nabc\r\n0\r\n\r\n") - |>.step |>.assertFailedWith .unsupportedTransferCoding |>.run - - -- §6.3 rule 4: an accepted coding does not give a request without a final chunked a length - MachineTester.receiving "§6.3: accepted gzip without chunked → badMessage" - (config := { acceptedTransferCodings := #["gzip"] }) - |>.feed "POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: gzip\r\n\r\nabc" - |>.step |>.assertFailedWith .badMessage |>.run - - -- RFC 9112 §7.1: `chunked` defines no parameters - MachineTester.receiving "§7: Transfer-Encoding: chunked;x=1 request → badMessage" - |>.feed "POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: chunked;x=1\r\n\r\n0\r\n\r\n" - |>.step |>.assertFailedWith .badMessage |>.run - -#eval runGroup "RFC 9112 §6.3: body framing" do - MachineTester.receiving "§6.3: no CL/TE → empty body" - |>.feed (mkGet "/") - |>.step |>.assertNoError |>.assertHasEndHeaders - |>.assertCanPullBodyNow |>.drainBody - |>.assertPulledBody .empty |>.assertLastChunkFinal |>.run - - let body := "Hello, World!".toUTF8 - MachineTester.receiving "§6.3: Content-Length body delivered exactly" - |>.feed (mkPostHead "/" body.size ++ String.fromUTF8! body) - |>.step |>.assertNoError |>.assertHasEndHeaders - |>.drainBody |>.assertPulledBody body |>.assertLastChunkFinal |>.run - - MachineTester.receiving "§6.3: CL + TE mixed → badMessage (request-smuggling prevention)" - |>.feed "POST / HTTP/1.1\r\nHost: example.com\r\nContent-Length: 5\r\nTransfer-Encoding: chunked\r\n\r\n" - |>.step |>.assertFailedWith .badMessage |>.run - - MachineTester.receiving "§6.3: multiple Content-Length → badMessage" - |>.feed "POST / HTTP/1.1\r\nHost: example.com\r\nContent-Length: 5\r\nContent-Length: 5\r\n\r\n" - |>.step |>.assertFailedWith .badMessage |>.run - - let respBody := "Hello!".toUTF8 - MachineTester.sending "§6.3: response Content-Length body delivered exactly" - |>.send minimalGetRequest |>.step - |>.feed s!"HTTP/1.1 200 OK\r\nContent-Length: {respBody.size}\r\n\r\n" - |>.feedBytes respBody |>.step |>.assertNoError - |>.drainBody |>.assertPulledBody respBody |>.assertLastChunkFinal |>.run - - let eofBody := "eof body".toUTF8 - MachineTester.sending "§6.3: EOF-delimited response body; keep-alive disabled" - |>.send minimalGetRequest |>.step - |>.feed "HTTP/1.1 200 OK\r\n\r\n" - |>.step |>.assertNoError |>.assertNotKeepAlive - |>.feedBytes eofBody |>.noMoreInput - |>.drainBody |>.assertPulledBody eofBody |>.assertLastChunkFinal |>.run - - let partialBody := "hello".toUTF8 - MachineTester.receiving "§6.3: noMoreInput mid fixed-length body → connectionClosed" - |>.feed (mkPostHead "/" 10 ++ String.fromUTF8! partialBody) - |>.step |>.assertHasEndHeaders |>.noMoreInput - |>.drainBody |>.assertFailedWith .connectionClosed |>.run - - MachineTester.receiving "§6.3: fixed-length body stops at declared byte count" - |>.feed (mkPostHead "/" 5 ++ "helloworld") - |>.step |>.assertHasEndHeaders - |>.drainBody - |>.assertPulledBody "hello".toUTF8 - |>.assertLastChunkFinal |>.assertNoError |>.run - - let part1 := "hel".toUTF8 - let part2 := "lo".toUTF8 - MachineTester.receiving "§6.3: fixed-length body assembled across incremental feeds" - |>.feed (mkPostHead "/" 5) |>.step |>.assertHasEndHeaders - |>.feedBytes part1 |>.pullBody - |>.feedBytes part2 |>.pullBody - |>.assertPulledBody (part1 ++ part2) |>.assertLastChunkFinal |>.run - -#eval runGroup "RFC 9112 §7.1: chunked transfer encoding" do - -- §7.1: chunks decoded to raw body bytes - let reqBody := "helloworld".toUTF8 - MachineTester.receiving "§7.1: chunked TE decoded to raw body" - |>.feed (mkChunkedPost "/" ++ "5\r\nhello\r\n5\r\nworld\r\n0\r\n\r\n") - |>.step |>.assertNoError |>.assertHasEndHeaders - |>.drainBody |>.assertPulledBody reqBody |>.assertLastChunkFinal |>.run - - -- §7.1: zero-length chunked body → empty body, final chunk - MachineTester.receiving "§7.1: empty chunked body" - |>.feed (mkChunkedPost "/" ++ "0\r\n\r\n") - |>.step |>.assertNoError - |>.drainBody |>.assertPulledBody .empty |>.assertLastChunkFinal |>.run - - -- §7.1: 200 response with chunked body decoded correctly - let respBody := "chunked".toUTF8 - MachineTester.sending "§7.1: response chunked body decoded" - |>.send minimalGetRequest |>.step - |>.feed "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n7\r\nchunked\r\n0\r\n\r\n" - |>.step |>.assertNoError - |>.drainBody |>.assertPulledBody respBody |>.assertLastChunkFinal |>.run - - -- §7.1: EOF mid chunked body (size line received but no chunk data) → connectionClosed - MachineTester.receiving "§7.1: noMoreInput mid chunked body → connectionClosed" - |>.feed (mkChunkedPost "/" ++ "5\r\n") -- chunk size line but no chunk payload - |>.step |>.assertHasEndHeaders |>.noMoreInput - |>.pullBody -- tries to read 5-byte chunk data, hits EOF → connectionClosed - |>.assertFailedWith .connectionClosed |>.run - - -- §7.1.1: chunk-extension fields preserved in PulledChunk.chunk.extensions - let extBody := "hello".toUTF8 - MachineTester.receiving "§7.1.1: chunk extensions preserved in PulledChunk" - |>.feed (mkChunkedPost "/" ++ "5;quality=0.9\r\nhello\r\n0\r\n\r\n") - |>.step |>.assertHasEndHeaders - |>.drainBody |>.assertPulledBody extBody - |>.onMachine (fun t _ => - match t.pulled[0]? with - | none => t.addError "no chunks pulled" - | some c => - if c.chunk.extensions.isEmpty - then t.addError "expected chunk extensions to be non-empty for chunk with extension" - else t) - |>.run - - -- §7.1: server writes chunk-size lines and terminal 0\r\n\r\n when userClosedBody is called - let body1 := "Hello, ".toUTF8 - let body2 := "World!".toUTF8 - MachineTester.receiving "§7.1: server sends chunked response — wire encoding correct" - |>.feed (mkGet "/") |>.step |>.assertIsWaitingMessage - |>.send { status := .ok } |>.setKnownSize .chunked - |>.sendBytes body1 |>.step - |>.sendBytes body2 |>.userClosedBody |>.step - |>.assertOutputContains "7\r\nHello, \r\n" "expected first chunk in wire output" - |>.assertOutputContains "6\r\nWorld!\r\n" "expected second chunk in wire output" - |>.assertOutputContains "0\r\n\r\n" "expected final empty chunk in wire output" - |>.run - - -- §7.1: chunked body assembled when size line and data arrive in separate feeds - let splitBody := "hello".toUTF8 - MachineTester.receiving "§7.1: chunked body assembled across incremental feeds" - |>.feed (mkChunkedPost "/" ++ "5\r\n") - |>.step |>.assertHasEndHeaders - |>.pullBody - |>.feedBytes ("hello\r\n".toUTF8) - |>.pullBody - |>.feed "0\r\n\r\n" - |>.pullBody - |>.assertPulledBody splitBody |>.assertLastChunkFinal |>.run - -#eval runGroup "RFC 9112 §6: framing of messages without a body, and of written messages" do - -- §6.3 rule 1: a response to HEAD ends at its header block, whatever its framing fields say - MachineTester.sending "§6.3: HEAD response with contradictory framing fields completes" - |>.send { minimalGetRequest with method := .head } |>.step - |>.feed "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\nContent-Length: 10\r\n\r\n" - |>.step |>.assertNoError |>.assertReaderComplete |>.run - - -- §6.3 rule 1: so does a 204 response - MachineTester.sending "§6.3: 204 response with contradictory framing fields completes" - |>.send minimalGetRequest |>.step - |>.feed "HTTP/1.1 204 No Content\r\nTransfer-Encoding: chunked\r\nContent-Length: 5\r\n\r\n" - |>.step |>.assertNoError |>.assertReaderComplete |>.run - - -- §6.3 rule 4: a response whose final transfer coding is not chunked is read until the server closes - for coding in ["gzip", "chunked, gzip", "gzip;level=1", "gzip ; level = \"9\""] do - MachineTester.sending s!"§6.3: Transfer-Encoding: {coding} response is close-delimited" - |>.send minimalGetRequest |>.step - |>.feed s!"HTTP/1.1 200 OK\r\nTransfer-Encoding: {coding}\r\n\r\nabc" - |>.step |>.assertNoError |>.assertNotKeepAlive - |>.noMoreInput |>.drainBody |>.assertNoError - |>.assertPulledBody "abc".toUTF8 |>.assertLastChunkFinal |>.run - - -- §7: transfer parameters do not change which coding is final - MachineTester.sending "§6.3: Transfer-Encoding: gzip;level=1, chunked response is chunked" - |>.send minimalGetRequest |>.step - |>.feed "HTTP/1.1 200 OK\r\nTransfer-Encoding: gzip;level=1, chunked\r\n\r\n3\r\nabc\r\n0\r\n\r\n" - |>.step |>.assertNoError |>.assertKeepAlive - |>.drainBody |>.assertNoError |>.assertPulledBody "abc".toUTF8 |>.assertLastChunkFinal |>.run - - -- §7.1: chunked defines no parameters - for coding in ["chunked;x=1", "gzip;level, chunked", "gzip;=1, chunked"] do - MachineTester.sending s!"§7: Transfer-Encoding: {coding} → badMessage" - |>.send minimalGetRequest |>.step - |>.feed s!"HTTP/1.1 200 OK\r\nTransfer-Encoding: {coding}\r\n\r\n3\r\nabc\r\n0\r\n\r\n" - |>.step |>.assertFailedWith .badMessage |>.run - - -- §6.1: a chunked message keeps the transfer codings its body was coded with - MachineTester.receiving "§6.1: server keeps the handler's Transfer-Encoding: gzip, chunked" - |>.feed (mkGet "/") |>.step |>.assertIsWaitingMessage - |>.send { status := .ok, headers := Headers.empty.insert! "Transfer-Encoding" "gzip, chunked" } - |>.sendBytes "abc".toUTF8 |>.userClosedBody |>.step - |>.assertOutputContains "Transfer-Encoding: gzip, chunked\r\n" "expected the handler's codings" - |>.assertOutputContains "3\r\nabc\r\n0\r\n\r\n" "expected a chunked body" |>.run - - MachineTester.receiving "§6.1: server keeps the handler's Transfer-Encoding: gzip;level=1, chunked" - |>.feed (mkGet "/") |>.step |>.assertIsWaitingMessage - |>.send { status := .ok, headers := Headers.empty.insert! "Transfer-Encoding" "gzip;level=1, chunked" } - |>.sendBytes "abc".toUTF8 |>.userClosedBody |>.step - |>.assertOutputContains "Transfer-Encoding: gzip;level=1, chunked\r\n" "expected the handler's codings" - |>.assertOutputContains "3\r\nabc\r\n0\r\n\r\n" "expected a chunked body" |>.run - - MachineTester.sending "§6.1: client keeps the caller's Transfer-Encoding: gzip, chunked" - |>.send { minimalGetRequest with - method := .post, headers := minimalGetRequest.headers.insert! "Transfer-Encoding" "gzip, chunked" } - |>.sendBytes "abc".toUTF8 |>.userClosedBody |>.step - |>.assertOutputContains "Transfer-Encoding: gzip, chunked\r\n" "expected the caller's codings" - |>.assertOutputContains "3\r\nabc\r\n0\r\n\r\n" "expected a chunked body" |>.run - - -- RFC 9110 §5.3: codings over several field lines are one list, written as one field - MachineTester.receiving "§6.1: server writes the handler's two Transfer-Encoding lines as one" - |>.feed (mkGet "/") |>.step |>.assertIsWaitingMessage - |>.send { status := .ok, headers := - (Headers.empty.insert! "Transfer-Encoding" "gzip").insert! "Transfer-Encoding" "chunked" } - |>.sendBytes "abc".toUTF8 |>.userClosedBody |>.step - |>.assertOutputContains "Transfer-Encoding: gzip, chunked\r\n" "expected the combined codings" - |>.assertOutputNotContains "Transfer-Encoding: chunked\r\n" "expected one Transfer-Encoding field" - |>.assertOutputContains "3\r\nabc\r\n0\r\n\r\n" "expected a chunked body" |>.run - - -- RFC 9110 §15.3.6: a server must not generate content in a 205 response; it sends - -- `Content-Length: 0` whatever length or framing the handler gave - MachineTester.receiving "§15.3.6: 205 drops the handler's content and sends Content-Length: 0" - |>.feed (mkGet "/") |>.step |>.assertIsWaitingMessage - |>.send { status := .resetContent } |>.sendBytes "body".toUTF8 |>.userClosedBody |>.step - |>.assertOutputStartsWith "HTTP/1.1 205 Reset Content\r\nContent-Length: 0\r\n\r\n" - "expected a 205 head with Content-Length: 0" - |>.assertOutputNotContains "body" "a 205 response carries no content" - |>.assertNoError |>.assertKeepAlive |>.run - - MachineTester.receiving "§15.3.6: 205 with the handler's Content-Length: 4 still sends Content-Length: 0" - |>.feed (mkGet "/") |>.step |>.assertIsWaitingMessage - |>.send { status := .resetContent, headers := Headers.empty.insert! "Content-Length" "4" } - |>.sendBytes "body".toUTF8 |>.userClosedBody |>.step - |>.assertOutputContains "Content-Length: 0\r\n\r\n" "expected Content-Length: 0" - |>.assertOutputNotContains "Content-Length: 4" "the handler's length must not be advertised" - |>.assertOutputNotContains "body" "a 205 response carries no content" - |>.assertNoError |>.run - - MachineTester.receiving "§15.3.6: 205 of unknown length is not chunked" - |>.feed (mkGet "/") |>.step |>.assertIsWaitingMessage - |>.send { status := .resetContent } |>.setKnownSize .chunked |>.sendBytes "body".toUTF8 - |>.userClosedBody |>.step - |>.assertOutputContains "Content-Length: 0\r\n\r\n" "expected Content-Length: 0" - |>.assertOutputNotContains "Transfer-Encoding" "a 205 response is not chunked" - |>.assertOutputNotContains "body" "a 205 response carries no content" |>.run - - -- RFC 9110 §8.6: no Content-Length on a request without content whose method anticipates none - MachineTester.sending "§8.6: bodyless GET request carries no Content-Length" - |>.send minimalGetRequest |>.userClosedBody |>.step - |>.assertOutputStartsWith "GET / HTTP/1.1\r\n" "expected the request line" - |>.assertOutputNotContains "Content-Length" "a bodyless GET must not carry Content-Length" |>.run - - MachineTester.sending "§8.6: bodyless POST request still carries Content-Length: 0" - |>.send { minimalGetRequest with method := .post } |>.userClosedBody |>.step - |>.assertOutputContains "Content-Length: 0\r\n" "a bodyless POST keeps Content-Length: 0" |>.run - - MachineTester.sending "§8.6: a GET whose caller set Content-Length: 0 keeps it" - |>.send { minimalGetRequest with headers := minimalGetRequest.headers.insert! "Content-Length" "0" } - |>.userClosedBody |>.step - |>.assertOutputContains "Content-Length: 0\r\n" "an explicit framing field is kept" |>.run - -#eval runGroup "RFC 9112 §9.3: connection persistence" do - -- §9.3: HTTP/1.1 connections are persistent by default - MachineTester.receiving "§9.3: HTTP/1.1 default keep-alive = true" - |>.feed (mkGet "/") |>.step |>.assertNoError |>.assertKeepAlive |>.run - - -- §9.3: HTTP/1.0 connections are not persistent by default - MachineTester.receiving "§9.3: HTTP/1.0 default keep-alive = false" - |>.feed (mkGet10 "/") |>.step |>.assertNoError |>.assertNotKeepAlive |>.run - - -- §9.3: explicit (redundant) Connection: keep-alive MUST NOT suppress default keep-alive - MachineTester.receiving "§9.3: HTTP/1.1 explicit Connection:keep-alive → keepAlive = true" - |>.feed "GET / HTTP/1.1\r\nHost: example.com\r\nConnection: keep-alive\r\n\r\n" - |>.step |>.assertNoError |>.assertKeepAlive |>.run - - -- §9.3: after completing first request, machine resets and parses second (pipelining) - let req1 := mkGet "/" - let req2 := mkGet "/second" - MachineTester.receiving "§9.3: pipelining — two requests on one connection" - |>.feed (req1 ++ req2) |>.step |>.assertHasEndHeaders |>.assertKeepAlive - |>.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody - |>.drainBody |>.step |>.assertHasNext - |>.step |>.assertHasEndHeaders |>.run - - -- §9.3: pipelining after CL:0 body — second request parses correctly - let post1 := "POST /a HTTP/1.1\r\nHost: example.com\r\nContent-Length: 0\r\n\r\n" - let get2 := "GET /b HTTP/1.1\r\nHost: example.com\r\n\r\n" - MachineTester.receiving "§9.3: pipelining after CL:0 body — second request path correct" - |>.feed (post1 ++ get2) |>.step |>.assertHasEndHeaders - |>.drainBody |>.assertPulledBody .empty - |>.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody - |>.step |>.assertHasNext - |>.step |>.assertHasEndHeaders - |>.onEndHeaders (fun t head => - let path := toString head.uri.path - if path == "/b" then t - else t.addError s!"expected second request path /b, got {path}") - |>.run - - -- §9.3: resetForNextMessage must preserve the noMoreInput flag so the machine - -- halts after the pipeline is exhausted and the socket has closed - let req1 := mkGet "/first" - let req2 := mkGet "/second" - MachineTester.receiving "§9.3: resetForNextMessage preserves noMoreInput after pipeline exhausted" - |>.feed (req1 ++ req2) |>.noMoreInput - |>.step |>.assertHasEndHeaders - |>.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody - |>.drainBody |>.step |>.assertHasNext - |>.step |>.assertHasEndHeaders - |>.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody - |>.drainBody |>.step - |>.assertHasEvent (fun | .close => true | _ => false) - "expected .close after pipeline exhausted on closed socket" - |>.step |>.assertHalted |>.run - -#eval runGroup "RFC 9112 §9.6: connection close" do - -- §9.6: Connection: close in request → keep-alive = false - MachineTester.receiving "§9.6: HTTP/1.1 Connection:close → keep-alive = false" - |>.feed "GET / HTTP/1.1\r\nHost: example.com\r\nConnection: close\r\n\r\n" - |>.step |>.assertNoError |>.assertNotKeepAlive |>.run - - -- §9.6: Connection: close injected into response when keep-alive is false - MachineTester.receiving "§9.6: Connection:close injected into response when not keep-alive" - |>.feed "GET / HTTP/1.1\r\nHost: example.com\r\nConnection: close\r\n\r\n" - |>.step |>.assertNotKeepAlive - |>.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody |>.step - |>.assertOutputContains "Connection: close" "expected Connection: close in response" |>.run - - -- §9.6: a `Connection: close` response header set by the handler ends a keep-alive connection - MachineTester.receiving "§9.6: handler Connection:close on keep-alive request → connection closed" - |>.feed (mkGet "/first" ++ mkGet "/second") |>.step |>.assertHasEndHeaders |>.assertKeepAlive - |>.send { status := .ok, headers := Headers.empty.insert .connection (.mk "close") } - |>.setKnownSize (.fixed 0) |>.userClosedBody |>.step - |>.assertNotKeepAlive - |>.assertOutputContains "Connection: close" "expected Connection: close in response" - |>.assertHasEvent (fun | .close => true | _ => false) "expected .close after the response" - |>.assertNoEvent (fun | .next => true | _ => false) "expected the pipelined request to be dropped" - |>.step |>.assertHalted |>.run - - -- §9.6: the error responses of `closeWithError` end a keep-alive connection - for status in #[Status.internalServerError, .requestTimeout, .serviceUnavailable] do - MachineTester.receiving s!"§9.6: closeWithError {status.toCode} on keep-alive request → connection closed" - |>.feed (mkGet "/first" ++ mkGet "/second") |>.step |>.assertHasEndHeaders |>.assertKeepAlive - |>.closeWithError status |>.step - |>.assertNotKeepAlive - |>.assertOutputStartsWith s!"HTTP/1.1 {status.toCode} " "expected the error status line" - |>.assertOutputContains "Connection: close" "expected Connection: close in the error response" - |>.assertHasEvent (fun | .close => true | _ => false) "expected .close after the error response" - |>.assertNoEvent (fun | .next => true | _ => false) "expected the pipelined request to be dropped" - |>.run - - -- §9.6: HTTP/1.1 response with Connection: close → keep-alive disabled - MachineTester.sending "§9.6: HTTP/1.1 response Connection:close → keep-alive = false" - |>.send minimalGetRequest |>.step - |>.feed "HTTP/1.1 200 OK\r\nConnection: close\r\nContent-Length: 0\r\n\r\n" - |>.step |>.assertNoError |>.assertNotKeepAlive |>.run - - -- RFC 9110 §7.6.1, §7.8: the handler's connection options are kept, with the machine's `close` - let upgrade (connection : String) : Response.Head := - { status := .upgradeRequired, - headers := Headers.empty |>.insert! "Upgrade" "TLS/1.2" |>.insert! "Connection" connection } - MachineTester.receiving "§7.8: 426 keeps Connection: upgrade and appends close" - |>.feed "GET / HTTP/1.1\r\nHost: example.com\r\nConnection: close\r\n\r\n" - |>.step |>.assertIsWaitingMessage - |>.send (upgrade "Upgrade") - |>.setKnownSize (.fixed 0) |>.userClosedBody |>.step - |>.assertOutputContains "Connection: upgrade, close\r\n" "expected the handler's upgrade option and close" - |>.assertOutputContains "Upgrade: TLS/1.2\r\n" "expected the Upgrade field" |>.run - - MachineTester.receiving "§7.8: keep-alive response keeps the handler's Connection: upgrade" - |>.feed (mkGet "/") |>.step |>.assertKeepAlive - |>.send (upgrade "upgrade, keep-alive") - |>.setKnownSize (.fixed 0) |>.userClosedBody |>.step |>.assertKeepAlive - |>.assertOutputContains "Connection: upgrade\r\n" "expected only the upgrade option" |>.run - - -- RFC 9110 §7.8: a client that sends `Upgrade` also sends the `upgrade` connection option - MachineTester.sending "§7.8: client keeps the caller's Connection: upgrade" - |>.send { minimalGetRequest with - headers := minimalGetRequest.headers - |>.insert! "Connection" "Upgrade" |>.insert! "Upgrade" "websocket" } - |>.userClosedBody |>.step - |>.assertOutputContains "Connection: upgrade\r\n" "expected the caller's upgrade option" - |>.assertOutputContains "Upgrade: websocket\r\n" "expected the Upgrade field" |>.run - - MachineTester.sending "§7.8: client appends close to the caller's connection options" - |>.send { minimalGetRequest with - headers := minimalGetRequest.headers - |>.insert! "Connection" "upgrade, close" |>.insert! "Upgrade" "websocket" } - |>.userClosedBody |>.step |>.assertNotKeepAlive - |>.assertOutputContains "Connection: upgrade, close\r\n" "expected the upgrade option, then close" - |>.run - -#eval runGroup "RFC 9110 §6–§7: header handling" do - -- §6.3: custom application headers are preserved in the parsed head - MachineTester.receiving "§6.3: custom headers preserved" - |>.feed "GET / HTTP/1.1\r\nHost: example.com\r\nX-Custom: my-value\r\nAuthorization: Bearer tok\r\n\r\n" - |>.step |>.assertNoError - |>.onEndHeaders (fun t head => - let custom := (head.headers.get? (.ofString! "X-Custom")).map (·.value) - if custom != some "my-value" then t.addError s!"X-Custom mismatch: {repr custom}" - else t) - |>.run - - -- §7.2: empty Host header is valid for origin-form in HTTP/1.1 - MachineTester.receiving "§7.2: HTTP/1.1 empty Host valid for origin-form" - |>.feed "GET / HTTP/1.1\r\nHost: \r\n\r\n" - |>.step |>.assertNoError |>.assertHasEndHeaders |>.run - -#eval runGroup "RFC 9110 §15.5.14: Expect: 100-continue" do - -- accepted: body becomes readable after canContinue .continue - let body := "hello".toUTF8 - MachineTester.receiving "§15.5.14: Expect:100-continue accepted → body readable" - |>.feed (mkPostHead "/upload" body.size "Expect: 100-continue\r\n") - |>.step |>.assertHasEndHeaders |>.assertHasContinue - |>.canContinue .«continue» - |>.feedBytes body |>.step |>.assertCanPullBodyNow - |>.drainBody |>.assertPulledBody body |>.run - - -- rejected: reader closed, body not delivered - MachineTester.receiving "§15.5.14: Expect:100-continue rejected → reader closed" - |>.feed (mkPostHead "/upload" 5 "Expect: 100-continue\r\n") - |>.step |>.assertHasContinue - |>.canContinue .expectationFailed - |>.assertReaderClosed - |>.assert (fun m => !m.canPullBody) "body must not be pullable after rejection" |>.run - - -- CL:0 + Expect:100-continue → empty body after acceptance - MachineTester.receiving "§10.1.1: Expect:100-continue + Content-Length:0 → empty body after acceptance" - |>.feed "POST / HTTP/1.1\r\nHost: example.com\r\nContent-Length: 0\r\nExpect: 100-continue\r\n\r\n" - |>.step |>.assertHasEndHeaders |>.assertHasContinue - |>.canContinue .«continue» - |>.pullBody |>.assertPulledBody .empty |>.assertLastChunkFinal |>.run - - -- §15.5.14: writer completing a non-1xx response while reader is in .continue state - -- must force-close the reader (body will never arrive after rejection) - MachineTester.receiving "§15.5.14: non-final send while reader awaits canContinue → .close emitted" - |>.feed (mkPostHead "/upload" 5 "Expect: 100-continue\r\n") - |>.step |>.assertHasContinue - |>.send { status := .expectationFailed } |>.setKnownSize (.fixed 0) |>.userClosedBody - |>.step - |>.assertHasEvent (fun | .close => true | _ => false) - "expected .close: writer completed after rejecting Expect: 100-continue, body will never arrive" - |>.run - -#eval runGroup "RFC 9110 §15.2: informational responses" do - -- §15.2: multiple 1xx responses before the real response are all skipped - MachineTester.sending "§15.2: multiple 1xx responses all skipped" - |>.send minimalGetRequest |>.step - |>.feed "HTTP/1.1 100 Continue\r\n\r\n" |>.step - |>.feed "HTTP/1.1 102 Processing\r\n\r\n" |>.step - |>.feed "HTTP/1.1 200 OK\r\nContent-Length: 0\r\n\r\n" |>.step - |>.assertNoError - |>.onEndHeaders (fun t head => - if head.status != .ok then - t.addError s!"expected 200 OK after 1xx chain, got {repr head.status}" - else t) - |>.run - - -- §15.2: 1xx responses are valid while awaiting canContinue; writer must remain open - MachineTester.receiving "§15.2: 1xx interim response while reader awaits canContinue → writer stays open" - |>.feed (mkPostHead "/upload" 5 "Expect: 100-continue\r\n") - |>.step |>.assertHasContinue - |>.send { status := .processing } |>.step - |>.assertIsWaitingMessage |>.run - - -- §15.2: an interim response has no body of its own, so it must not end the response body - MachineTester.sending "§15.2: 103 Early Hints → no closeBody until the final response" - |>.send minimalGetRequest |>.step - |>.feed "HTTP/1.1 103 Early Hints\r\nLink: </style.css>; rel=preload\r\n\r\n" |>.step - |>.assertNoError - |>.assertNoEvent (fun | .closeBody => true | _ => false) - "an interim response must not emit closeBody" - |>.feed "HTTP/1.1 200 OK\r\nContent-Length: 2\r\n\r\nok" |>.step - |>.drainBody |>.assertNoError |>.assertPulledBody "ok".toUTF8 - |>.assertHasCloseBody |>.run - - -- §15.2.2: after 101 the connection speaks the new protocol, so no final response follows and the - -- bytes after the head are not read as HTTP - MachineTester.sending "§15.2.2: 101 Switching Protocols ends the exchange" - |>.send { minimalGetRequest with - headers := minimalGetRequest.headers - |>.insert! "Connection" "upgrade" |>.insert! "Upgrade" "websocket" } - |>.step - |>.feed "HTTP/1.1 101 Switching Protocols\r\nUpgrade: websocket\r\nConnection: Upgrade\r\n\r\n" - |>.feedBytes (ByteArray.mk #[0x81, 0x02, 0x68, 0x69]) - |>.step - |>.assertNoError |>.assertHasEndHeaders |>.assertNotKeepAlive - |>.assertReaderClosed |>.run - -#eval runGroup "RFC 7231 §4.3.2: HEAD request handling" do - -- body bytes suppressed; Content-Length metadata still emitted so client knows size - let body := "hello".toUTF8 - MachineTester.receiving "§4.3.2: HEAD response — body bytes suppressed, Content-Length preserved" - |>.feed "HEAD / HTTP/1.1\r\nHost: example.com\r\n\r\n" - |>.step |>.assertIsWaitingMessage - |>.send { status := .ok, headers := Headers.empty.insert! "Content-Length" "5" } - |>.sendBytes body |>.userClosedBody |>.step |>.step - |>.assertOutputContains "HTTP/1.1 200" "expected 200 OK status line" - |>.assertOutputContains "Content-Length: 5" "expected Content-Length metadata preserved" - |>.assertOutputNotContains "hello" "HEAD response must not contain body bytes on the wire" - |>.run - - -- RFC 9110 §9.3.2, §8.6: with no known length a HEAD response has GET's framing; a - -- `Content-Length: 0` would claim the GET response is empty - MachineTester.receiving "§9.3.2: HEAD response of unknown length has no Content-Length: 0" - |>.feed ("HEAD / HTTP/1.1\r\nHost: example.com\r\n\r\n" ++ mkGet "/next") - |>.step |>.assertIsWaitingMessage - |>.send { status := .ok } |>.userClosedBody |>.step - |>.assertOutputNotContains "Content-Length" "unknown length must not be sent as Content-Length: 0" - |>.assertOutputContains "Transfer-Encoding: chunked\r\n" "expected the framing GET would have" - |>.assertOutputNotContains "0\r\n\r\n" "a HEAD response carries no body, not even a last chunk" - |>.assertHasNext |>.run - -#eval runGroup "RFC 2616: HTTP/1.0 compatibility" do - -- RFC 2068 §19.4.6: HTTP/1.0 does not define chunked transfer encoding - MachineTester.receiving "§19.4.6: chunked TE on HTTP/1.0 → badMessage" - |>.feed "POST / HTTP/1.0\r\nTransfer-Encoding: chunked\r\n\r\n" - |>.step |>.assertFailedWith .badMessage |>.run - - -- RFC 2616 §8.1: HTTP/1.0 does not default to persistent connections - MachineTester.sending "§8.1: client receives HTTP/1.0 response → keepAlive = false" - |>.send minimalGetRequest |>.step - |>.feed "HTTP/1.0 200 OK\r\nContent-Length: 0\r\n\r\n" - |>.step |>.assertNoError |>.assertNotKeepAlive |>.run - - -- RFC 2616 §14.23: Host header is optional in HTTP/1.0 - MachineTester.receiving "§14.23: HTTP/1.0 without Host → valid" - |>.feed "GET / HTTP/1.0\r\n\r\n" - |>.step |>.assertNoError |>.assertHasEndHeaders |>.run - - MachineTester.receiving "§14.23: HTTP/1.0 single Host → valid" - |>.feed "GET / HTTP/1.0\r\nHost: example.com\r\n\r\n" - |>.step |>.assertNoError |>.assertHasEndHeaders |>.run - - MachineTester.receiving "§14.23: HTTP/1.0 duplicate Host → badMessage (To avoid exploits)" - |>.feed "GET / HTTP/1.0\r\nHost: a.com\r\nHost: b.com\r\n\r\n" - |>.step |>.assertFailedWith .badMessage |>.run - - -- RFC 2616 §19.7.1: HTTP/1.0 + Connection: keep-alive → keep-alive enabled - MachineTester.receiving "§19.7.1: HTTP/1.0 Connection:keep-alive → keep-alive = true" - |>.feed "GET / HTTP/1.0\r\nConnection: keep-alive\r\n\r\n" - |>.step |>.assertNoError |>.assertKeepAlive |>.run - - -- §19.7.1: HTTP/1.0 keep-alive allows a second request on the same connection - let http10req1 := "GET / HTTP/1.0\r\nConnection: keep-alive\r\n\r\n" - let http10req2 := "GET /second HTTP/1.0\r\n\r\n" - MachineTester.receiving "§19.7.1: HTTP/1.0 keep-alive pipelining — second request parsed" - |>.feed (http10req1 ++ http10req2) |>.step |>.assertHasEndHeaders |>.assertKeepAlive - |>.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody - |>.drainBody |>.step |>.assertHasNext - |>.step |>.assertHasEndHeaders |>.run - - -- §19.7.1: client side — response Connection:keep-alive → keepAlive = true - MachineTester.sending "§19.7.1: client receives HTTP/1.0 + Connection:keep-alive → keepAlive = true" - |>.send minimalGetRequest |>.step - |>.feed "HTTP/1.0 200 OK\r\nConnection: keep-alive\r\nContent-Length: 0\r\n\r\n" - |>.step |>.assertNoError |>.assertKeepAlive |>.run - - -- §19.7.1: when serving an HTTP/1.0 keep-alive connection, the response must include - -- Connection: keep-alive so the client knows to reuse the connection - MachineTester.receiving "§19.7.1: HTTP/1.0 keep-alive → Connection: keep-alive injected in response" - |>.feed "GET / HTTP/1.0\r\nConnection: keep-alive\r\n\r\n" - |>.step |>.assertKeepAlive - |>.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody - |>.step |>.step - |>.assertOutputContains "Connection: keep-alive" - "RFC 2616 §19.7.1: HTTP/1.0 keep-alive response must include Connection: keep-alive" |>.run - - -- RFC 9110 §15.2: a server must not send a 1xx response to an HTTP/1.0 client - MachineTester.receiving "§15.2: 103 Early Hints is not sent to an HTTP/1.0 client" - |>.feed (mkGet10 "/") |>.step |>.assertIsWaitingMessage - |>.send { status := .earlyHints, headers := Headers.empty.insert! "Link" "</a.css>; rel=preload" } - |>.step |>.assertIsWaitingMessage - |>.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody |>.step - |>.assertOutputNotContains "103" "a 1xx response must not reach an HTTP/1.0 client" - |>.assertOutputStartsWith "HTTP/1.1 200" "expected the final response first" |>.run - - -- RFC 9110 §6.2: a server sends the highest version it conforms to whose major version is at most - -- the request's, so an HTTP/1.0 request gets an HTTP/1.1 status line with HTTP/1.0 framing - MachineTester.receiving "§6.2: HTTP/1.0 request → HTTP/1.1 status line, connection-close framing" - |>.feed (mkGet10 "/") |>.step - |>.send { status := .ok } |>.sendBytes "hello".toUTF8 |>.userClosedBody - |>.step |>.step - |>.assertOutputStartsWith "HTTP/1.1 200 OK\r\n" "expected an HTTP/1.1 status line" - |>.assertOutputContains "Connection: close\r\n" "an HTTP/1.0 connection without keep-alive closes" - |>.assertOutputNotContains "Transfer-Encoding" "HTTP/1.0 has no chunked framing" |>.run - - MachineTester.receiving "§6.2: HTTP/1.0 keep-alive request → HTTP/1.1 status line, keep-alive echoed" - |>.feed "GET / HTTP/1.0\r\nConnection: keep-alive\r\n\r\n" |>.step - |>.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody - |>.step |>.step - |>.assertOutputStartsWith "HTTP/1.1 200 OK\r\n" "expected an HTTP/1.1 status line" - |>.assertOutputContains "Connection: keep-alive\r\n" "expected the HTTP/1.0 keep-alive echo" - |>.assertKeepAlive |>.run - - -- RFC 9112 §6.3: a HEAD response ends at its header block, so a length the server does not know - -- does not cost an HTTP/1.0 client its keep-alive connection - MachineTester.receiving "§6.3: HTTP/1.0 HEAD of unknown length keeps the connection alive" - |>.feed ("HEAD / HTTP/1.0\r\nConnection: keep-alive\r\n\r\n" ++ - "GET /second HTTP/1.0\r\nConnection: keep-alive\r\n\r\n") - |>.step |>.assertIsWaitingMessage - |>.send { status := .ok } |>.userClosedBody |>.step - |>.assertOutputContains "Connection: keep-alive\r\n" "expected the HTTP/1.0 keep-alive echo" - |>.assertOutputNotContains "Content-Length" "unknown length must not be sent as Content-Length: 0" - |>.assertOutputNotContains "close" "a HEAD response has no body to delimit by closing" - |>.assertHasNext - |>.step |>.assertHasEndHeaders |>.assertKeepAlive |>.run - -#eval runGroup "RFC 9110 §6.6.1: Date" do - let date : Header.Value := .mk "Mon, 01 Jan 2024 00:00:00 GMT" - let withDate (t : MachineTester .receiving) : MachineTester .receiving := - { t with machine := { t.machine with date := some date } } - - MachineTester.receiving "§6.6.1: the machine's date goes into a response without Date" - |> withDate - |>.feed (mkGet "/") |>.step - |>.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody |>.step - |>.assertOutputStartsWith "HTTP/1.1 200 OK\r\nDate: Mon, 01 Jan 2024 00:00:00 GMT\r\nContent-Length: 0\r\n" - "expected the machine's Date after the handler's fields" |>.run - - MachineTester.receiving "§6.6.1: the handler's own Date is kept and not duplicated" - |> withDate - |>.feed (mkGet "/") |>.step - |>.send { status := .ok, headers := Headers.empty.insert! "Date" "Tue, 02 Jan 2024 00:00:00 GMT" } - |>.setKnownSize (.fixed 0) |>.userClosedBody |>.step - |>.assertOutputContains "Date: Tue, 02 Jan 2024 00:00:00 GMT\r\n" "expected the handler's Date" - |>.assertOutputNotContains "Mon, 01 Jan 2024" "the machine's Date must not be added too" |>.run - - MachineTester.receiving "§6.6.1: a 400 the machine writes itself carries Date" - |> withDate - |>.feed "GET / HTTP/1.1\r\n\r\n" |>.step |>.step - |>.assertOutputStartsWith - "HTTP/1.1 400 Bad Request\r\nContent-Type: text/plain; charset=utf-8\r\nDate: Mon, 01 Jan 2024 00:00:00 GMT\r\n" - "expected Date on the machine's 400" |>.run - - MachineTester.receiving "§6.6.1: a 408 from closeWithError carries Date" - |> withDate - |>.feed (mkPostHead "/" 5) |>.step - |>.closeWithError .requestTimeout |>.step - |>.assertOutputStartsWith - "HTTP/1.1 408 Request Timeout\r\nContent-Type: text/plain; charset=utf-8\r\nDate: Mon, 01 Jan 2024 00:00:00 GMT\r\n" - "expected Date on the 408" |>.run - - MachineTester.receiving "§6.6.1: the 500 for a rejected head carries Date and an explanation" - |> withDate - |>.feed (mkGet "/") |>.step - |>.setKnownSize (.fixed 0) - |>.send { status := .ok, headers := Headers.empty.insert! "Content-Length" "4" } |>.step - |>.assertOutputStartsWith - ("HTTP/1.1 500 Internal Server Error\r\nContent-Type: text/plain; charset=utf-8\r\n" ++ - "Date: Mon, 01 Jan 2024 00:00:00 GMT\r\nConnection: close\r\nContent-Length: 22\r\n\r\n" ++ - "Internal Server Error\n") - "expected Date and the explanation on the 500" |>.run - - MachineTester.receiving "§6.6.1: without a date the machine adds no Date" - |>.feed "GET / HTTP/1.1\r\n\r\n" |>.step |>.step - |>.assertOutputNotContains "Date" "no Date without a date value" |>.run - -#eval runGroup "RFC 9110 §15.5, §15.6: content of the error responses the server writes" do - -- §15.5, §15.6: except for a response to HEAD, a 4xx or 5xx response should explain the error - MachineTester.receiving "§15.5: a 400 the machine writes explains itself" - |>.feed "GET / HTTP/1.1\r\n\r\n" |>.step |>.step - |>.assertOutputStartsWith - ("HTTP/1.1 400 Bad Request\r\nContent-Type: text/plain; charset=utf-8\r\n" ++ - "Connection: close\r\nContent-Length: 12\r\n\r\nBad Request\n") - "expected a text/plain explanation" |>.run - - -- §15.6.6: a 505 says which versions the server supports - MachineTester.receiving "§15.6.6: a 505 names the supported versions" - |>.feed "GET / HTTP/2.0\r\nHost: example.com\r\n\r\n" |>.step |>.step - |>.assertOutputStartsWith "HTTP/1.1 505 HTTP Version Not Supported\r\n" "expected 505" - |>.assertOutputContains "\r\n\r\nHTTP Version Not Supported: this server supports HTTP/1.0 and HTTP/1.1\n" - "expected the supported versions" |>.run - - -- §9.3.2: a response to HEAD has no content, but keeps the Content-Length GET would have - MachineTester.receiving "§9.3.2: a 400 to HEAD keeps Content-Length and omits the content" - |>.feed "HEAD / HTTP/1.1\r\n\r\n" |>.step |>.step - |>.assertOutputStartsWith "HTTP/1.1 400 Bad Request\r\n" "expected 400" - |>.assertOutputContains "Content-Length: 12\r\n\r\n" "expected the content's length" - |>.assertOutputNotContains "\r\n\r\nBad Request" "a HEAD response carries no content" |>.run - - MachineTester.receiving "§15.5: a 408 from closeWithError explains itself" - |>.feed (mkPostHead "/" 5) |>.step - |>.closeWithError .requestTimeout |>.step - |>.assertOutputStartsWith "HTTP/1.1 408 Request Timeout\r\n" "expected 408" - |>.assertOutputContains "Connection: close\r\n" "expected Connection: close" - |>.assertOutputContains "Content-Length: 16\r\n\r\nRequest Timeout\n" "expected an explanation" - |>.assertNotKeepAlive |>.run - - MachineTester.receiving "§15.5: a 417 from canContinue explains itself" - |>.feed (mkPostHead "/" 5 "Expect: 100-continue\r\n") |>.step |>.assertHasContinue - |>.canContinue .expectationFailed |>.step - |>.assertOutputStartsWith "HTTP/1.1 417 Expectation Failed\r\n" "expected 417" - |>.assertOutputContains "Content-Length: 19\r\n\r\nExpectation Failed\n" "expected an explanation" - |>.assertNotKeepAlive |>.run - - -- A final response sent before the rejection keeps its length and body; the rejection only stops - -- the request body and the connection - MachineTester.receiving "§15.5: canContinue after a final response leaves that response intact" - |>.feed (mkPostHead "/" 5 "Expect: 100-continue\r\n") |>.step |>.assertHasContinue - |>.setKnownSize (.fixed 5) |>.send { status := .ok } |>.sendBytes "hello".toUTF8 |>.userClosedBody - |>.canContinue .expectationFailed |>.step |>.step - |>.assertOutputStartsWith "HTTP/1.1 200 OK\r\nConnection: close\r\nContent-Length: 5\r\n\r\nhello" - "expected the 200 with its own length and body" - |>.assertOutputNotContains "Expectation Failed" "no 417 content after a final response" - |>.assertNoError |>.assertNotKeepAlive |>.run - -#eval runGroup "RFC 9110 §8.6 / §6.3: client-side bodyless response framing" do - -- §8.6: a HEAD response has no body regardless of framing headers. The client reader must treat - -- it as zero-length and finish without blocking, even though Content-Length advertises bytes that - -- never arrive on the wire. - MachineTester.sending "§8.6: client HEAD response — body suppressed despite Content-Length" - |>.send { minimalGetRequest with method := .head } |>.step - |>.feed "HTTP/1.1 200 OK\r\nContent-Length: 100\r\n\r\n" - |>.step - |>.assertNoError - |>.assert (fun m => !m.canPullBody) - "HEAD response must expose no body to pull (reader must not block on absent body bytes)" - |>.assertReaderComplete |>.run - - -- §6.3: a client response with a known zero-length body (e.g. 204) must auto-complete; otherwise - -- the connection would stall waiting for a `pullBody` that never produces bytes. - MachineTester.sending "§6.3: client zero-length response auto-completes without pullBody" - |>.send minimalGetRequest |>.step - |>.feed "HTTP/1.1 204 No Content\r\nContent-Length: 0\r\n\r\n" - |>.step - |>.assertNoError - |>.assert (fun m => !m.canPullBody) - "zero-length response body must not require a caller pullBody to advance" - |>.assertReaderComplete |>.run
diff --git a/tests/async/elab/async_http_h1_short_fixed_body.lean b/tests/async/elab/async_http_h1_short_fixed_body.lean deleted file mode 100644 index 89dbfe8..0000000 --- a/tests/async/elab/async_http_h1_short_fixed_body.lean +++ /dev/null
@@ -1,46 +0,0 @@ -module - -import Std.Http - -/-! -Tests that the HTTP/1.1 machine reports an outgoing body that ends short of its `Content-Length` in -the step that writes its last bytes. A connection loop steps the machine again only on an external -event, so a shortfall left for a later step can go unreported until a timeout. --/ - -open Std Http Protocol H1 - -/-- Steps `machine` until a step writes `needle`, and reports whether that step also closed. -/ -private def closesWhenWriting (machine : Machine dir) (needle : String) : IO Bool := do - let mut machine := machine - for _ in [0:8] do - let (next, step) := machine.step - machine := next - let wrote := String.fromUTF8! (step.output.data.foldl (· ++ ·) .empty) - if wrote.contains needle then - return step.events.any (· matches .close) && machine.error == some .badMessage - throw <| IO.userError s!"{needle.quote} was never written" - -/-- A request head that declares a 10-byte body. -/ -private def putHead : Request.Head := - (Request.new |>.method .put |>.uri! "/upload" |>.header! "Host" "example.com" - |>.header! "Content-Length" "10").line - --- Client side: the request body ends after 5 of its 10 declared bytes. -#eval show IO Unit from do - let machine : Machine .sending := { config := {} } - let machine := machine.send putHead - |>.sendData #[Chunk.ofByteArray "12345".toUTF8] |>.userClosedBody - unless ← closesWhenWriting machine "12345" do - throw <| IO.userError "a request body 5 bytes short was not reported in the step that wrote it" - --- Control: the whole declared body completes the message without an error. -#eval show IO Unit from do - let machine : Machine .sending := { config := {} } - let mut machine := machine.send putHead - |>.sendData #[Chunk.ofByteArray "0123456789".toUTF8] |>.userClosedBody - for _ in [0:8] do - let (next, _) := machine.step - machine := next - if machine.error.isSome then - throw <| IO.userError s!"a complete body failed with {machine.error.map toString}"
diff --git a/tests/async/elab/async_http_h1_split_reads.lean b/tests/async/elab/async_http_h1_split_reads.lean new file mode 100644 index 0000000..e82d596 --- /dev/null +++ b/tests/async/elab/async_http_h1_split_reads.lean
@@ -0,0 +1,382 @@ +module + +import Std.Http.Test.Helpers +import Std.Http.Test.Machine + +/-! +# HTTP/1.1 split reads + +A request reads the same however its bytes are split into reads: every method, bodies, chunk +extensions and trailers, an overlong target, and random splits through `serveConnection`. RFC 9112 +§3, §6.3, §7.1. Regressions: #15841, #16080, #16111. +-/ + +open Std Http +open Std.Async +open Std.Http.Protocol.H1 +open Std.Http.Internal.Test + +private def mkContentLengthRequest (path : String) (body : ByteArray) : ByteArray := + s!"POST {path} HTTP/1.1\r\nHost: example.com\r\nContent-Length: {body.size}\r\nConnection: keep-alive\r\n\r\n".toUTF8 ++ body + +private def mkChunkedRequest (path : String) (chunkedPayload : ByteArray) : ByteArray := + s!"POST {path} HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: chunked\r\nConnection: keep-alive\r\n\r\n".toUTF8 ++ chunkedPayload + +private def mkChunkedHead (path : String) : ByteArray := + s!"POST {path} HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: chunked\r\nConnection: keep-alive\r\n\r\n".toUTF8 + +private def randIn (g : Rng) (low high : Nat) : Nat × Rng := + if high < low then (low, g) else + let (n, g) := g.below (high - low + 1) + (low + n, g) + +/-- Lowercase letters, digits, `-` and `_`. -/ +private def randomAsciiBytes (g : Rng) (len : Nat) : ByteArray × Rng := Id.run do + let mut g := g + let mut out := ByteArray.empty + for _ in [0:len] do + let (r, g') := g.below 38 + g := g' + let code := if r < 26 then 97 + r else if r < 36 then 48 + (r - 26) else if r = 36 then 45 else 95 + out := out.push (UInt8.ofNat code) + (out, g) + +private def randomSplit (g : Rng) (data : ByteArray) (maxPart : Nat) : Array ByteArray × Rng := Id.run do + let mut g := g + let mut out : Array ByteArray := #[] + let mut i := 0 + while i < data.size do + let (partLen, g') := randIn g 1 (Nat.min maxPart (data.size - i)) + g := g' + out := out.push (data.extract i (i + partLen)) + i := i + partLen + (out, g) + +private def randomChunkedPayload (g : Rng) (body : ByteArray) : ByteArray × Rng := Id.run do + let mut g := g + let mut out := ByteArray.empty + let mut i := 0 + while i < body.size do + let (chunkLen, g') := randIn g 1 (Nat.min 9 (body.size - i)) + g := g' + out := out ++ s!"{chunkLen}\r\n".toUTF8 ++ body.extract i (i + chunkLen) ++ "\r\n".toUTF8 + i := i + chunkLen + (out ++ "0\r\n\r\n".toUTF8, g) + +/-- What the pull-only cases checked: the head was read, the body is `want`, and its last chunk is final. -/ +private def expectPullOnly (t : Trace) (want : ByteArray) : IO Unit := do + ensure (t.events.any (· matches .endHeaders _)) s!"missing endHeaders event:\n{repr t.events}" + ensure (t.body == want) + s!"body mismatch:\nexpected={(String.fromUTF8? want).getD "<binary>" |>.quote}\nactual={(String.fromUTF8? t.body).getD "<binary>" |>.quote}" + ensure ((t.pulled.back?.map (·.final)).getD false) "expected last pulled chunk to be final" + +/-- Sends `parts` one at a time to `serveConnection`, then EOF, and returns what it wrote. -/ +private def serveParts (parts : Array ByteArray) (handler : TestHandler) : IO ByteArray := do + let (client, server) ← Internal.Mock.new + Async.block do + let serverTask ← async (t := AsyncTask) do + Server.serveConnection server handler testConfig |>.run + for part in parts do + client.send part + client.getSendChan.close + await serverTask + return (← client.recv?).getD .empty + +/-- The first response's content, as the echo handler wrote it. -/ +private def responseBody (response : ByteArray) : String := + match ((String.fromUTF8! response).splitOn "\x0d\n\x0d\n").drop 1 with + | [] => "" + | body :: _ => body + +/-! ## Methods (RFC 9112 §3) -/ + +-- The method is read whole before it is matched, so the outcome does not depend on where a read +-- ends inside it (#16111: `UPDATE` must not match the start of `UPDATEREDIRECTREF`). +#eval checkCases "methods across split reads" #[ + ("every method, split after each byte", do + for expected in Method.all do + let name := toString expected + unless Method.ofString? name == some expected do + throw <| IO.userError s!"Method.ofString? {name.quote} is not {repr expected}" + let (target, host) := if name == "CONNECT" then ("example.com:443", "example.com:443") else ("/", "example.com") + let request := s!"{name} {target} HTTP/1.1\r\nHost: {host}\r\n\r\n".toUTF8 + for i in [1:name.length + 2] do + MachineTester.receiving s!"§3: {name} split after byte {i}" + |>.feedBytes (request.extract 0 i) |>.step |>.assertNoError + |>.feedBytes (request.extract i request.size) |>.step |>.assertNoError + |>.onEndHeaders (fun t head => + if head.method == expected then t else t.addError s!"expected {name}, got {repr head.method}") + |>.run), + ("unrecognized methods split after each byte → unsupportedMethod (#16111)", do + for method in ["LEAN", "GETX", "UPDATEX", "UPDATEREDIRECTREFS"] do + let request := s!"{method} / HTTP/1.1\r\nHost: example.com\r\n\r\n".toUTF8 + for i in [1:method.length + 1] do + MachineTester.receiving s!"§3: unrecognized {method} split after byte {i} → unsupportedMethod" + |>.feedBytes (request.extract 0 i) |>.step |>.assertNoError + |>.feedBytes (request.extract i request.size) |>.step + |>.assertFailedWith .unsupportedMethod |>.run) + ] (·.2) + +/-! ## Bodies (RFC 9112 §6.3, §7.1) -/ + +-- The same request reads the same at every single split point, one byte per read, and with the +-- pull-only driver (the head stepped once, then the body fed and pulled without stepping). +#eval checkCases "Content-Length body across reads (#15841)" #[ + ("CL one-byte incremental parse", do + let body := "hello".toUTF8 + expectBody (feedEachByte (mkContentLengthRequest "/inc-every-byte" body)) body), + ("CL split at every offset", do + let body := "hello".toUTF8 + let request := mkContentLengthRequest "/inc-every-split" body + for i in [1:request.size] do + try expectBody (feedSplit request i) body (needMoreData := false) + catch e => throw <| IO.userError s!"split at {i}: {e}"), + ("§6.3: fixed-length body assembled across incremental feeds (pull only), every body split", do + let head := "POST / HTTP/1.1\r\nHost: example.com\r\nContent-Length: 5\r\n\r\n".toUTF8 + let body := "hello".toUTF8 + for i in [1:body.size] do + try expectPullOnly (feedPullOnly #[head, body.extract 0 i, body.extract i body.size] (drainLast := true)) body + catch e => throw <| IO.userError s!"body split at {i}: {e}") + ] (·.2) + +#eval checkCases "chunked body across reads" #[ + ("Chunked parse at every split point", do + let request := mkChunkedRequest "/inc-chunked" "3\r\nabc\r\n3\r\nXYZ\r\n0\r\n\r\n".toUTF8 + for i in [1:request.size] do + try expectBody (feedSplit request i) "abcXYZ".toUTF8 (needMoreData := false) + catch e => throw <| IO.userError s!"split at {i}: {e}"), + ("Chunked one-byte incremental parse", do + let request := mkChunkedRequest "/inc-chunked" "3\r\nabc\r\n3\r\nXYZ\r\n0\r\n\r\n".toUTF8 + expectBody (feedEachByte request) "abcXYZ".toUTF8), + ("§7.1: chunked body assembled across incremental feeds (pull only), every body split", do + let head := "POST / HTTP/1.1\r\nHost: example.com\r\nTransfer-Encoding: chunked\r\n\r\n".toUTF8 + let chunked := "5\r\nhello\r\n0\r\n\r\n".toUTF8 + for i in [1:chunked.size] do + try expectPullOnly (feedPullOnly #[head, chunked.extract 0 i, chunked.extract i chunked.size] (drainLast := true)) "hello".toUTF8 + catch e => throw <| IO.userError s!"body split at {i}: {e}") + ] (·.2) + +-- Calling `pullBody` in chunked mode before any chunk-size byte arrives must request more data +-- rather than failing the machine. +#eval checkCases "Chunked pull on empty input" #[ + ("Chunked pull on empty input", do + let machine0 : Machine .receiving := { config := {} } + let (machine1, step1) := (machine0.feed (mkChunkedHead "/wait-for-chunk-size")).step + ensure (!machine1.failed) s!"unexpected setup failure events:\n{repr step1.events}" + ensure (step1.events.any (· matches .endHeaders _)) "expected endHeaders in setup" + ensure machine1.canPullBodyNow "expected body state to be pullable" + let (machine2, pulled?) := machine1.pullBody + let (machine2, pullEvents) := machine2.takeEvents + ensure pulled?.isNone "expected no pulled body chunk" + ensure (!machine2.failed) s!"unexpected machine failure:\n{repr pullEvents}" + ensure (pullEvents.any (· matches .needMoreData _)) s!"expected needMoreData after empty pull:\n{repr pullEvents}") + ] (·.2) + +#eval checkCases "Property-style: random bodies and random split boundaries" #[ + ("Property CL", do + let mut g : Rng := ⟨0x21436587⟩ + for i in [0:120] do + let (bodyLen, g1) := randIn g 0 128 + let (body, g2) := randomAsciiBytes g1 bodyLen + let (parts, g3) := randomSplit g2 (mkContentLengthRequest s!"/prop-cl-{i}" body) 11 + g := g3 + try expectBody (feedParts parts) body (needMoreData := parts.size > 1) + catch e => throw <| IO.userError s!"Property CL #{i}: {e}"), + ("Property chunked", do + let mut g : Rng := ⟨0x89abcdef⟩ + for i in [0:120] do + let (bodyLen, g1) := randIn g 0 128 + let (body, g2) := randomAsciiBytes g1 bodyLen + let (payload, g3) := randomChunkedPayload g2 body + let (parts, g4) := randomSplit g3 (mkChunkedRequest s!"/prop-chunked-{i}" payload) 9 + g := g4 + try expectBody (feedParts parts) body (needMoreData := parts.size > 1) + catch e => throw <| IO.userError s!"Property chunked #{i}: {e}") + ] (·.2) + + +private def clientGet : Request.Head := + { method := .get, version := .v11, uri := RequestTarget.originForm! "/", + headers := Headers.empty.insert! "Host" "example.com" } + +/-- A client machine that sent a GET, then read `parts` one per step, pulling the body as it came. -/ +private def clientReads (parts : Array ByteArray) : Machine .sending × Array (Event .sending) × ByteArray := Id.run do + let mut m : Machine .sending := { config := {} } + m := (m.send clientGet |>.userClosedBody).step.1 + let mut events : Array (Event .sending) := #[] + let mut body := ByteArray.empty + for part in parts ++ #[ByteArray.empty] do + m := m.feed part + let (m', r) := m.step + m := m' + events := events ++ r.events + let mut fuel := 64 + while fuel > 0 && m.canPullBodyNow do + fuel := fuel - 1 + let (m', c?) := m.pullBody + let (m', evs) := m'.takeEvents + m := m' + events := events ++ evs + if let some c := c? then body := body ++ c.chunk.data + return (m, events, body) + +-- RFC 9112 §4: a client reads a response the same way whatever its read boundaries. +#eval checkCases "Client: incomplete responses fed one byte at a time" #[ + "HTTP/1.1", "HTTP/1.1 200", "HTTP/1.1 200 OK\x0d\nContent-Length: 2\x0d\n" + ] fun raw => do + let (m, events, _) := clientReads (eachByte raw.toUTF8) + ensure (!m.failed && !events.any (· matches .failed _)) s!"failed: {repr events}" + ensure (!events.any (· matches .endHeaders _)) s!"a head was read: {repr events}" + ensure (events.any (· matches .needMoreData _)) s!"no needMoreData: {repr events}" + +#eval checkCases "Client: a chunked response with trailers, one byte at a time" #[ + ("same result as one read", do + let raw := "HTTP/1.1 200 OK\x0d\nTransfer-Encoding: chunked\x0d\n\x0d\n5\x0d\nhello\x0d\n6\x0d\n world\x0d\n0\x0d\nX-T: v\x0d\n\x0d\n".toUTF8 + let (m1, e1, b1) := clientReads #[raw] + let (m2, e2, b2) := clientReads (eachByte raw) + for (m, events, body, how) in [(m1, e1, b1, "one read"), (m2, e2, b2, "byte by byte")] do + ensure (!m.failed && !events.any (· matches .failed _)) s!"{how}: failed: {repr events}" + ensure (events.any (· matches .endHeaders _)) s!"{how}: no endHeaders: {repr events}" + ensure (body == "hello world".toUTF8) s!"{how}: body {(String.fromUTF8! body).quote}" + ensure (m.reader.isComplete || events.any (· matches .closeBody)) s!"{how}: not complete: {repr events}" + ensure (e2.any (· matches .needMoreData _)) s!"byte by byte: no needMoreData: {repr e2}") + ] (·.2) + +/-! ## Chunk extensions and trailers (RFC 9112 §7.1.1, §7.1.2) -/ + +-- A read boundary inside a chunk extension or a trailer field must not fail a valid request (#15841). +#eval checkCases "Chunk extension one-byte incremental parse (#15841)" #[ + "5;a=b\r\nhello\r\n0\r\n\r\n", "5 ; a = b\r\nhello\r\n0\r\n\r\n", "5;a=\"b c\"\r\nhello\r\n0\r\n\r\n", + "5\r\nhello\r\n0;a\r\n\r\n" + ] fun payload => expectBody (feedEachByte (mkChunkedRequest "/inc-chunk-ext" payload.toUTF8)) "hello".toUTF8 + +#eval checkCases "Trailers across reads" #[ + ("Trailer one-byte incremental parse (#15841)", do + let request := mkChunkedRequest "/inc-trailer" "5\r\nhello\r\n0\r\nX-T: a\r\nY: b\r\n\r\n".toUTF8 + expectBody (feedEachByte request) "hello".toUTF8), + -- After a read that ends inside the second field, only that field is still buffered, so the + -- next read does not parse the first one again. + ("Trailer fields consumed one at a time", do + let input := "5\r\nhello\r\n0\r\nX-A: 1\r\nX-B: 2" + let trace := feedParts #[mkChunkedRequest "/inc-trailer-fields" input.toUTF8] + ensure (!trace.machine.failed) s!"machine ended failed with events:\n{repr trace.events}" + ensure (trace.machine.reader.state matches .readBody (.trailers _ 1)) + s!"unexpected reader state {repr trace.machine.reader.state}" + ensure (trace.machine.reader.input.remainingBytes == "X-B: 2".length) + s!"expected only the incomplete field buffered, got {trace.machine.reader.input.remainingBytes} bytes"), + ("Trailers at the count limit, one byte per read", do + let atLimit := mkChunkedRequest "/inc-trailer-limit" "5\r\nhello\r\n0\r\nA: 1\r\nB: 2\r\n\r\n".toUTF8 + expectBody (feedEachByte atLimit { maxTrailerHeaders := 2 }) "hello".toUTF8), + ("Trailers over the count limit, one byte per read", do + let overLimit := mkChunkedRequest "/inc-trailer-limit" "5\r\nhello\r\n0\r\nA: 1\r\nB: 2\r\nC: 3\r\n\r\n".toUTF8 + let trace := feedEachByte overLimit { maxTrailerHeaders := 2 } + ensure (trace.machine.error == some .badMessage) s!"expected badMessage, got {repr trace.machine.error}"), + ("Forbidden trailer field, one byte per read", do + let forbidden := mkChunkedRequest "/inc-trailer-forbidden" "5\r\nhello\r\n0\r\nA: 1\r\nContent-Length: 5\r\n\r\n".toUTF8 + let trace := feedEachByte forbidden + ensure (trace.machine.error == some .badMessage) s!"expected badMessage, got {repr trace.machine.error}") + ] (·.2) + +/-! ## Target limit (RFC 9112 §3) -/ + +-- A request-target longer than `maxUriLength` gets `uriTooLong` however the request line is split +-- into reads, including reads that end between `maxStartLineLength` bytes and the parser's +-- `maxUriLength` check (#16080). +#eval checkCases "Overlong request-target (#16080)" #[ + ("unsplit", 0), ("split at 8191", 8191), ("split at 8192", 8192), ("split at 8193", 8193), + ("split at 8194", 8194), ("split at 8195", 8195), ("split at 8196", 8196), ("split at 8197", 8197) + ] fun (label, k) => do + let request := s!"GET /{String.ofList (List.replicate 8193 'a')} HTTP/1.1\r\nHost: a\r\n\r\n".toUTF8 + let parts := if k == 0 then #[request] else #[request.extract 0 k, request.extract k request.size] + let trace := feedParts parts + ensure (trace.machine.error == some .uriTooLong) s!"{label}: expected uriTooLong, got {repr trace.machine.error}" + +/-! ## Pipelined streams (RFC 9112 §9.3.2) -/ + +-- `Reader.feed` keeps the unread bytes, drops the read ones and appends the new data. +#eval checkCases "`Reader.feed` keeps unread bytes" #[ + ("every position and data", do + for pos in [0:7] do + for data in ["", "x", "ghij"] do + let reader : Reader .receiving := { input := ⟨"abcdef".toUTF8, pos⟩ } + let fed := reader.feed data.toUTF8 + let expected := ("abcdef".toUTF8.extract pos 6) ++ data.toUTF8 + let got := fed.input.array.extract fed.input.pos fed.input.array.size + ensure (got == expected) s!"feed at {pos} with {data}: got {String.fromUTF8! got}, expected {String.fromUTF8! expected}") + ] (·.2) + + +private def requestLine : TestHandler := fun req => do + let body : String ← req.body.readAll + Response.ok |>.text s!"{req.line.method} {toString req.line.uri} {body}" + +/-- The server machine's view of `parts`: each request's method, target and body, in order. A 200 +with an empty body answers each request once its body is read. -/ +private def machineReads (parts : Array ByteArray) : Array String × Bool := Id.run do + let mut m : Machine .receiving := { config := {} } + let mut seen : Array String := #[] + let mut current : Option (String × ByteArray) := none + for part in parts ++ Array.replicate 8 ByteArray.empty do + m := m.feed part + let (m', r) := m.step + m := m' + for e in r.events do + if let .endHeaders head := e then + current := some (s!"{head.method} {toString head.uri}", .empty) + let mut fuel := 64 + while fuel > 0 && m.canPullBodyNow do + fuel := fuel - 1 + let (m', c?) := m.pullBody + m := m'.takeEvents.1 + if let (some c, some (line, body)) := (c?, current) then + current := some (line, body ++ c.chunk.data) + if let some (line, body) := current then + if m.reader.isComplete then + seen := seen.push s!"{line} {String.fromUTF8! body}" + current := none + m := m.send { status := .ok } |>.setKnownSize (.fixed 0) |>.userClosedBody + return (seen, m.failed) + +-- RFC 9112 §9.3.2: a read boundary inside the *next* request does not change either request. +#eval checkCases "A CL POST then a GET, split at every offset" #[ + ("machine", do + let raw := "POST /a HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 5\x0d\n\x0d\nhelloGET /b HTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n".toUTF8 + for i in [0:raw.size + 1] do + let (seen, failed) := machineReads (splitAt raw i) + ensure (!failed && seen == #["POST /a hello", "GET /b "]) s!"split at {i}: {repr seen} failed={failed}"), + ("serveConnection", do + let raw := "POST /a HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 5\x0d\n\x0d\nhelloGET /b HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 + for i in [0:raw.size + 1] do + let text := String.fromUTF8! (← serveParts (splitAt raw i) requestLine) + let bodies := (text.splitOn "HTTP/1.1 200 OK").drop 1 |>.map fun r => ((r.splitOn "\x0d\n\x0d\n").drop 1).headD "" + ensure (bodies == ["POST /a hello", "GET /b "]) s!"split at {i}: {text.quote}") + ] (·.2) + +/-! ## Through serveConnection (RFC 9112 §6.3, §7.1) -/ + +#eval checkCases "Random bodies through serveConnection" #[ + ("Content-Length body, head whole, body in random 1–17-byte reads", do + let mut g : Rng := ⟨0x00C0FFEE⟩ + for i in [0:40] do + let (len, g1) := randIn g 0 128 + let (body, g2) := randomAsciiBytes g1 len + let head := s!"POST /fuzz-cl-{i} HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: {body.size}\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 + let (bodyParts, g3) := randomSplit g2 body 17 + g := g3 + let response ← serveParts (#[head] ++ bodyParts) echoHandler + ensure ((String.fromUTF8! response).startsWith "HTTP/1.1 200") s!"fuzz_content_length_echo case={i}: status" + ensure (responseBody response == String.fromUTF8! body) s!"fuzz_content_length_echo case={i}: body"), + ("chunked body in random 1–9-byte chunks, sent in random 1–17-byte reads", do + let mut g : Rng := ⟨0x00123456⟩ + for i in [0:40] do + let (len, g1) := randIn g 0 128 + let (body, g2) := randomAsciiBytes g1 len + let (chunked, g3) := randomChunkedPayload g2 body + g := g3 + let head := s!"POST /fuzz-chunked-{i} HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 + let (parts, g4) := randomSplit g (head ++ chunked) 17 + g := g4 + let response ← serveParts parts echoHandler + ensure ((String.fromUTF8! response).startsWith "HTTP/1.1 200") s!"fuzz_chunked_echo case={i}: status" + ensure (responseBody response == String.fromUTF8! body) s!"fuzz_chunked_echo case={i}: body") + ] (·.2)
diff --git a/tests/async/elab/async_http_h1_v10_framing.lean b/tests/async/elab/async_http_h1_v10_framing.lean deleted file mode 100644 index a5f46fd..0000000 --- a/tests/async/elab/async_http_h1_v10_framing.lean +++ /dev/null
@@ -1,68 +0,0 @@ -import Std.Http -import Std.Http.Test.Helpers - -open Std Http -open Std.Http.Internal.Test -open Std.Http.Protocol.H1 - -/-! -Tests that no HTTP/1.0 message is framed with a transfer coding, which HTTP/1.0 does not define -(RFC 9112 §6.1). A client's HTTP/1.0 request of unknown length is held until its body ends and goes -out with `Content-Length`. A server answers `500` when a handler's response to an HTTP/1.0 request -carries a transfer coding, instead of sending the coded bytes as an identity body. --/ - -def run (machine : Machine dir) (n : Nat := 4) : Machine dir × String := Id.run do - let mut machine := machine - let mut out := ByteArray.empty - for _ in [0:n] do - let (next, step) := machine.step - machine := next - out := out ++ step.output.toByteArray - return (machine, String.fromUTF8! out) - -def expect (cond : Bool) (msg : String) : IO Unit := - unless cond do throw (IO.userError msg) - -def post (version : Version) : Request.Head := - { method := .post, version, uri := RequestTarget.parse! "/", - headers := Headers.empty.insert Header.Name.host (.mk "a") } - -/-- Sends a POST whose body arrives in a later step than its head, and returns the wire bytes. -/ -def sendLateBody (version : Version) : Machine .sending × String := - let m : Machine .sending := { config := {} } - let (m, first) := run (m.send (post version) |>.sendData #[Chunk.ofByteArray "hello".toUTF8]) 2 - let (m, rest) := run m.userClosedBody 3 - (m, first ++ rest) - -#eval show IO Unit from do - let (_, out) := sendLateBody .v10 - expect (!out.contains "Transfer-Encoding" && out.contains "Content-Length: 5\x0d\n" - && out.endsWith "\x0d\n\x0d\nhello") - s!"client HTTP/1.0 POST of unknown length: {out.quote}" - -- Control: an HTTP/1.1 request of unknown length streams chunked. - let (_, out) := sendLateBody .v11 - expect (out.contains "Transfer-Encoding: chunked") s!"client HTTP/1.1 POST of unknown length: {out.quote}" - --- A length set as `chunked` cannot be sent over HTTP/1.0: the exchange ends with nothing written. -#eval show IO Unit from do - let m : Machine .sending := { config := {} } - let (m, out) := run (m.setKnownSize .chunked |>.send (post .v10) - |>.sendData #[Chunk.ofByteArray "hello".toUTF8] |>.userClosedBody) - expect (out.isEmpty && m.error.isSome) - s!"client HTTP/1.0 POST set as chunked: expected nothing written and an error, got {out.quote}" - -def codedHandler : TestHandler := fun _ => - Response.ok - |>.header! "Transfer-Encoding" "gzip, chunked" - |>.stream fun out => out.send (Chunk.ofByteArray "GZIPPED".toUTF8) - -#eval runGroup "transfer coding to an HTTP/1.0 client" do - check "HTTP/1.0 GET" "GET / HTTP/1.0\x0d\nHost: a\x0d\n\x0d\n" codedHandler fun r => do - assertStatus r "HTTP/1.1 500" - assertAbsent r "GZIPPED" - -- Control: an HTTP/1.1 client gets the coding and the coded bytes. - check "HTTP/1.1 GET" (mkGetClose "/") codedHandler fun r => do - assertStatus r "HTTP/1.1 200" - assertContains r "Transfer-Encoding: gzip, chunked" - assertContains r "GZIPPED"
diff --git a/tests/async/elab/async_http_hang_regressions.lean b/tests/async/elab/async_http_hang_regressions.lean index fe72c90..96da791 100644 --- a/tests/async/elab/async_http_hang_regressions.lean +++ b/tests/async/elab/async_http_hang_regressions.lean
@@ -1,4 +1,5 @@ import Std.Http +import Std.Http.Test.Helpers import Std.Async import Std.Async.Timer @@ -201,32 +202,6 @@ assertStatusPrefix "09_incomplete_send_collapse" response "HTTP/1.1 200" assertContains response "hello world" --- 10: Pipeline fixed-body POST then GET. -#eval runWithTimeout "10_pipeline_fixed_then_get" 2000 do - let raw := ("POST /one HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 5\x0d\n\x0d\nhello" ++ - "GET /two HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n").toUTF8 - let response ← sendRawTimed "10_pipeline_fixed_then_get/send" raw uriHandler - assertStatusCount "10_pipeline_fixed_then_get" response 2 - assertContains response "/one" - assertContains response "/two" - --- 11: Pipeline chunked-body POST then GET. -#eval runWithTimeout "11_pipeline_chunked_then_get" 2000 do - let raw := ("POST /chunk HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n" ++ - "GET /two HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n").toUTF8 - let response ← sendRawTimed "11_pipeline_chunked_then_get/send" raw uriHandler - assertStatusCount "11_pipeline_chunked_then_get" response 2 - assertContains response "/chunk" - assertContains response "/two" - --- 12: Malformed first request should not loop into second. -#eval runWithTimeout "12_malformed_closes_connection" 2000 do - let raw := ("GET / HTTP/1.1\x0d\nHost: example.com\x0d\nBadHeader value\x0d\n\x0d\n" ++ - "GET /second HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n").toUTF8 - let response ← sendRawTimed "12_malformed_closes_connection/send" raw uriHandler - assertStatusPrefix "12_malformed_closes_connection" response "HTTP/1.1 400" - assertStatusCount "12_malformed_closes_connection" response 1 - -- 13: Client closes while server is streaming response. #eval runWithTimeout "13_client_close_while_streaming" 2000 do let raw := "GET /close-stream HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 @@ -272,27 +247,6 @@ assertContains response "x0," assertContains response "x119," --- 19: Pipeline with large unread first body still processes second request. -#eval runWithTimeout "19_pipeline_large_unread_then_get" 2000 do - let body := String.ofList (List.replicate 5000 'b') - let raw := (s!"POST /big HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 5000\x0d\n\x0d\n{body}" ++ - "GET /after HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n").toUTF8 - let response ← sendRawTimed "19_pipeline_large_unread_then_get/send" raw uriHandler - assertStatusCount "19_pipeline_large_unread_then_get" response 2 - assertContains response "/big" - assertContains response "/after" - --- 20: Triple pipeline mixed body styles. -#eval runWithTimeout "20_triple_pipeline_mixed" 2000 do - let raw := ("POST /a HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 4\x0d\n\x0d\ndata" ++ - "POST /b HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\n\x0d\n3\x0d\nhey\x0d\n0\x0d\n\x0d\n" ++ - "GET /c HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n").toUTF8 - let response ← sendRawTimed "20_triple_pipeline_mixed/send" raw uriHandler - assertStatusCount "20_triple_pipeline_mixed" response 3 - assertContains response "/a" - assertContains response "/b" - assertContains response "/c" - -- 21: Slow/incomplete active body transfer must time out (no connection pinning). #eval runWithTimeout "21_incomplete_slow_post_times_out" 2000 do let raw := "POST /slow HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 100\x0d\nConnection: close\x0d\n\x0d\nabcde".toUTF8
diff --git a/tests/async/elab/async_http_headers.lean b/tests/async/elab/async_http_headers.lean index e0ec116..79f7d0c 100644 --- a/tests/async/elab/async_http_headers.lean +++ b/tests/async/elab/async_http_headers.lean
@@ -370,41 +370,10 @@ let (name, value) := Header.Connection.serialize c return (name.value, value.value) -/-! ## Aggregate header byte limit (maxHeaderBytes) -/ - -section HeaderByteLimit -open Std.Http.Protocol.H1 - --- Helper: feed all bytes at once and run one step, return the machine state. -private def runMachine (raw : String) (cfg : Config) : Machine .receiving := - let machine : Machine .receiving := { config := cfg } - (machine.feed raw.toUTF8).step.1 - --- With a tight limit (35 bytes), two headers whose combined byte count exceeds --- the limit should cause the machine to fail. --- "host" (4) + "example.com" (11) + 4 = 19 bytes for the first header. --- "x-a" (3) + "somevalue1" (10) + 4 = 17 bytes for the second → total 36 > 35. -#guard - let raw := "GET / HTTP/1.1\r\nhost: example.com\r\nx-a: somevalue1\r\n\r\n" - let cfg : Config := { maxHeaderBytes := 35 } - (runMachine raw cfg).failed - --- With a generous limit the same request succeeds (machine is not failed). -#guard - let raw := "GET / HTTP/1.1\r\nhost: example.com\r\nx-a: somevalue1\r\n\r\n" - let cfg : Config := { maxHeaderBytes := 100 } - !(runMachine raw cfg).failed - --- Exactly at the boundary: 19 bytes for host header alone, limit = 19 → ok. -#guard - let raw := "GET / HTTP/1.1\r\nhost: example.com\r\n\r\n" - let cfg : Config := { maxHeaderBytes := 19 } - !(runMachine raw cfg).failed - --- One byte under the two-header total → second header pushes it over. -#guard - let raw := "GET / HTTP/1.1\r\nhost: example.com\r\nx-a: somevalue1\r\n\r\n" - let cfg : Config := { maxHeaderBytes := 19 } - (runMachine raw cfg).failed - -end HeaderByteLimit +-- Empty elements of a `Connection` list are skipped. +#eval show IO Unit from do + for (value, tokens) in [("keep-alive, ", #["keep-alive"]), (", upgrade,, close", #["upgrade", "close"]), + ("", #[])] do + let got := (Header.Connection.parse (.ofString! value)).map (·.tokens) + unless got == some tokens do + throw (IO.userError s!"Connection.parse {value.quote}: expected {tokens}, got {got}")
diff --git a/tests/async/elab/async_http_keepalive.lean b/tests/async/elab/async_http_keepalive.lean deleted file mode 100644 index e30ed36..0000000 --- a/tests/async/elab/async_http_keepalive.lean +++ /dev/null
@@ -1,150 +0,0 @@ -import Std.Http.Test.Helpers - -open Std.Async -open Std Http Internal Test - --- Helper: run pipelined raw request string, closing the client after send. --- Returns (response bytes, list of URIs seen by the handler). -private def runPipelined - (raw : String) - (readBody : Bool := true) - (config : Config := defaultConfig) : IO (ByteArray × Array String) := Async.block do - let (client, server) ← Mock.new - let seenRef ← IO.mkRef (#[] : Array String) - - let handler : TestHandler := fun req => do - seenRef.modify (·.push (toString req.line.uri)) - let body ← - if readBody then req.body.readAll - else pure "<ignored>" - Response.ok |>.text s!"{toString req.line.uri}:{body}" - - client.send raw.toUTF8 - client.getSendChan.close - Std.Http.Server.serveConnection server handler config |>.run - - let response ← client.recv? - let seen ← seenRef.get - pure (response.getD .empty, seen) - -private def assertSeenCount (seen : Array String) (expected : Nat) : IO Unit := do - unless seen.size == expected do - throw <| IO.userError s!"expected {expected} handler calls, got {seen.size}: {seen}" - --- HTTP/1.1 keep-alive behavior - -#eval runGroup "Keep-alive: basic" do - check "two sequential keep-alive requests → 2 responses" - (raw := - "GET /first HTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n" ++ - "GET /second HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := fun req => Response.ok |>.text (toString req.line.uri)) - (expect := fun r => - assertResponseCount r 2 *> - assertContains r "/first" *> - assertContains r "/second") - - check "Connection: close on first request blocks pipelined second" - (raw := - "GET /first HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n" ++ - "GET /second HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := fun req => Response.ok |>.text (toString req.line.uri)) - (expect := fun r => - assertResponseCount r 1 *> - assertContains r "/first" *> - assertAbsent r "/second") - - check "enableKeepAlive: false → one response only" - (raw := - "GET /1 HTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n" ++ - "GET /2 HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := fun req => Response.ok |>.text (toString req.line.uri)) - (config := { defaultConfig with enableKeepAlive := false, lingeringTimeout := 3000 }) - (expect := fun r => - assertResponseCount r 1 *> - assertContains r "/1" *> - assertAbsent r "/2") - - check "maxRequests: 2 caps third request" - (raw := - "GET /0 HTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n" ++ - "GET /1 HTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n" ++ - "GET /2 HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := fun req => Response.ok |>.text (toString req.line.uri)) - (config := { defaultConfig with maxRequests := 2, lingeringTimeout := 3000 }) - (expect := fun r => - assertResponseCount r 2 *> - assertContains r "/0" *> - assertContains r "/1" *> - assertAbsent r "/2") - --- Body draining between keep-alive requests - -#eval runGroup "Keep-alive: unread body draining" do - check "handler ignores fixed-size body → next keep-alive works" - (raw := - "POST /ignore HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 5\x0d\n\x0d\nhello" ++ - "GET /after HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := fun req => Response.ok |>.text (toString req.line.uri)) - (config := { defaultConfig with lingeringTimeout := 3000 }) - (expect := fun r => - assertResponseCount r 2 *> - assertContains r "/ignore" *> - assertContains r "/after") - - check "handler ignores chunked body → next keep-alive works" - (raw := - "POST /chunked HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n" ++ - "GET /next HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := fun req => Response.ok |>.text (toString req.line.uri)) - (config := { defaultConfig with lingeringTimeout := 3000 }) - (expect := fun r => - assertResponseCount r 2 *> - assertContains r "/chunked" *> - assertContains r "/next") - --- Pipelining after exact Content-Length - -#eval runGroup "Keep-alive: pipelined requests after exact CL" do - let (response, seen) ← runPipelined - ("POST /first HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 3\x0d\n\x0d\nabc" ++ - "GET /second HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - - assertResponseCount response 2 - assertContains response "/first" - assertContains response "/second" - assertSeenCount seen 2 - -#eval runGroup "Keep-alive: incomplete body blocks pipelining" do - let (response1, seen1) ← runPipelined - ("POST /first HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 10\x0d\n\x0d\nabc" ++ - "GET /second HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - - assertContains response1 "/first" - assertAbsent response1 "/second" - assertSeenCount seen1 1 - - let (response2, _) ← runPipelined - ("POST /chunked-first HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\n\x0d\nF\x0d\nhel" ++ - "GET /second HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - - assertAbsent response2 "/second" - -#eval runGroup "Keep-alive: CL=0 and complete chunked allow immediate next" do - let (resp1, seen1) ← runPipelined - ("POST /empty HTTP/1.1\x0d\nHost: example.com\x0d\nContent-Length: 0\x0d\n\x0d\n" ++ - "GET /tail HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - - assertResponseCount resp1 2 - assertContains resp1 "/empty" - assertContains resp1 "/tail" - assertSeenCount seen1 2 - - let (resp2, seen2) ← runPipelined - ("POST /chunked HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n" ++ - "GET /tail HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - - assertResponseCount resp2 2 - assertContains resp2 "/chunked" - assertContains resp2 "/tail" - assertSeenCount seen2 2
diff --git a/tests/async/elab/async_http_query_names.lean b/tests/async/elab/async_http_query_names.lean deleted file mode 100644 index 55f6e8b..0000000 --- a/tests/async/elab/async_http_query_names.lean +++ /dev/null
@@ -1,42 +0,0 @@ -import Std.Http - -open Std Http - -/-! -Tests `URI.Query.names`: the unique parameter names in order of first occurrence, at a cost linear in -the number of parameters, since a request-target may carry up to `maxUriLength` of them. Also tests -that `String`-keyed lookups match a name exactly when it decodes to the key. --/ - -def expect (cond : Bool) (msg : String) : IO Unit := - unless cond do throw (IO.userError msg) - -#eval show IO Unit from do - let names := (RequestTarget.parse! "/?b=1&a&b=2&c=&a=3&%61").query.names.map toString - expect (names == #["b", "a", "c", "%61"]) s!"names {names}" - --- A quadratic deduplication takes seconds here; a linear one, milliseconds. -#eval show IO Unit from do - let n := 40000 - let query := (List.range n).foldl (fun q i => q.insert s!"k{i}" "v") URI.Query.empty - let start ← IO.monoMsNow - let names ← IO.lazyPure fun _ => query.names - -- Checked before the clock is read again, so the names are computed in between. - expect (names.size == n) s!"{names.size} names" - let elapsed := (← IO.monoMsNow) - start - expect (elapsed < 2000) s!"Query.names took {elapsed} ms for {n} distinct names" - --- `String`-keyed lookups compare a name as it decodes, byte by byte without decoding it into a new --- string; this must agree with decoding and comparing. -#eval show IO Unit from do - let cases : List (String × String) := [ - ("a%3Ab", "a:b"), ("a%3ab", "a:b"), ("a+b", "a b"), ("a%2Bb", "a+b"), ("a+b", "a+b"), - ("abc", "abc"), ("abc", "ab"), ("ab", "abc"), ("%41", "A"), ("%41", "a"), - ("r%C3%A9sum%C3%A9", "résumé"), ("%E9", "é"), ("%C3", "Ã"), ("", ""), ("x", "")] - for (enc, key) in cases do - let some name := URI.EncodedQueryParam.ofByteArray? enc.toUTF8 - | throw (IO.userError s!"{enc} is not a valid query name") - let query := (RequestTarget.parse! s!"/?{enc}=v").query - let expected := name.decode == some key - expect (query.contains key == expected) s!"contains {key.quote} on {enc}: expected {expected}" - expect ((query.get key).isSome == expected) s!"get {key.quote} on {enc}: expected {expected}"
diff --git a/tests/async/elab/async_http_redirect.lean b/tests/async/elab/async_http_redirect.lean index b4b772f..1b133cd 100644 --- a/tests/async/elab/async_http_redirect.lean +++ b/tests/async/elab/async_http_redirect.lean
@@ -1,22 +1,19 @@ -/- -Copyright (c) 2026 Lean FRO, LLC. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Sofia Rodrigues --/ -import Std.Http.Protocol.H1 +module -open Std.Http -open Std.Http.Protocol.H1 +import Std.Http.Test.Helpers /-! -# Redirect planning tests +# Redirect decisions -Exercises the pure redirect-decision logic in `Std.Http.Protocol.H1.decideRedirect` -(PR #13901). Each `#guard` asserts an observable outcome of `decideRedirect` against -the RFC 9110 §15.4 / RFC 9112 §3.2 rules: when a redirect is followed vs. terminal, -how the method is chosen, how the target is rewritten, and how headers are scrubbed. +`Std.Http.Protocol.H1.decideRedirect`: when a redirect is followed or terminal, how the method and +body are chosen, how the target is rewritten, and how fields are scrubbed. RFC 9110 §15.4, §7.6.1, +§9.3.6; RFC 9112 §3.2; RFC 3986 §5.2.2. Regressions: #16036. -/ +open Std Http +open Std.Http.Protocol.H1 +open Std.Http.Internal.Test + /-- Base origin all tests redirect away from: `http://example.com/a/b` (port 80). -/ private def base : URI := URI.parse! "http://example.com/a/b" @@ -45,10 +42,6 @@ | .done => true | .follow _ => false -private def plan? : RedirectOutcome → Option RedirectPlan - | .follow p => some p - | .done => none - private def isEmptyBody : RedirectBodyAction → Bool | .empty => true | .replay => false @@ -57,235 +50,126 @@ | .replay => true | .empty => false -/-! ## Terminal responses (`.done`) -/ - --- A non-3xx status is never a redirect. -#guard isDone (decideRedirect origin (mkReq .get) false .ok (withLocation "/x")) - --- A 3xx status with no `Location` header cannot be followed. -#guard isDone (decideRedirect origin (mkReq .get) false .found Headers.empty) - --- SSRF guard: a `Location` resolving to a non-http(s) scheme is rejected. -#guard isDone (decideRedirect origin (mkReq .get) false .found (withLocation "file:///etc/passwd")) - --- 305 Use Proxy / 306 Unused / 304 Not Modified / 300 Multiple Choices are terminal. -#guard isDone (decideRedirect origin (mkReq .get) false .useProxy (withLocation "/x")) -#guard isDone (decideRedirect origin (mkReq .get) false .unused (withLocation "/x")) -#guard isDone (decideRedirect origin (mkReq .get) false .notModified (withLocation "/x")) -#guard isDone (decideRedirect origin (mkReq .get) false .multipleChoices (withLocation "/x")) - --- 301/302 keep every method but POST (RFC 9110 §15.4.2), so a PUT whose body cannot be replayed --- is terminal. -#guard isDone (decideRedirect origin (mkReq .put) false .movedPermanently (withLocation "/x")) -#guard isDone (decideRedirect origin (mkReq .patch) false .found (withLocation "/x")) - --- 307/308 preserve the method, so a non-GET/HEAD request with a non-replayable body is terminal. -#guard isDone (decideRedirect origin (mkReq .post) false .temporaryRedirect (withLocation "/x")) - --- A CONNECT target is the authority to tunnel to (RFC 9110 §9.3.6), which no redirected target can --- express, so no 3xx is followed, whether it keeps the method or changes it. -private def connectReq : Request.Head := - { method := .connect, version := .v11, uri := RequestTarget.parse! "example.com:443" } - -#guard [Status.movedPermanently, .found, .seeOther, .temporaryRedirect, .permanentRedirect].all - fun status => isDone (decideRedirect origin connectReq true status (withLocation "/x")) -#guard isDone (decideRedirect origin connectReq true .found (withLocation "http://other.com:443")) - -/-! ## Followed redirects: method selection -/ - --- Same-origin 302 on GET: method preserved, target rewritten to origin-form, empty body. -#guard match plan? (decideRedirect origin (mkReq .get) false .found (withLocation "/next")) with - | some p => p.method == .get && !p.isCrossOrigin && toString p.target == "/next" && isEmptyBody p.bodyAction - | none => false - --- 303 See Other downgrades to GET with an empty body. -#guard match plan? (decideRedirect origin (mkReq .post) false .seeOther (withLocation "/next")) with - | some p => p.method == .get && isEmptyBody p.bodyAction - | none => false - --- 301/302 on POST downgrade to GET and drop the body, whatever the HTTP version: keeping POST --- would replay the body, credentials included, to the redirect target. -#guard match plan? (decideRedirect origin (mkReq .post) false .movedPermanently (withLocation "/x")) with - | some p => p.method == .get && isEmptyBody p.bodyAction - | none => false - -#guard match plan? (decideRedirect origin (mkReq .post (version := .v10)) true .found - (withLocation "http://other.example/login")) with - | some p => p.method == .get && isEmptyBody p.bodyAction && p.isCrossOrigin - | none => false - --- 307 preserves POST and replays the body when replayable. -#guard match plan? (decideRedirect origin (mkReq .post) true .temporaryRedirect (withLocation "/x")) with - | some p => p.method == .post && isReplayBody p.bodyAction - | none => false - --- 301/302 on PUT/PATCH/DELETE keep the method and replay a replayable body, like 307/308. -#guard match plan? (decideRedirect origin (mkReq .put) true .movedPermanently (withLocation "/x")) with - | some p => p.method == .put && isReplayBody p.bodyAction - | none => false - -#guard match plan? (decideRedirect origin (mkReq .patch) true .found (withLocation "/x")) with - | some p => p.method == .patch && isReplayBody p.bodyAction - | none => false - -#guard match plan? (decideRedirect origin (mkReq .delete) true .found (withLocation "/x")) with - | some p => p.method == .delete && isReplayBody p.bodyAction - | none => false - --- 308 keeps PUT and replays a replayable body. -#guard match plan? (decideRedirect origin (mkReq .put) true .permanentRedirect (withLocation "/x")) with - | some p => p.method == .put && isReplayBody p.bodyAction - | none => false - --- 307 on GET is followed with the method preserved. -#guard match plan? (decideRedirect origin (mkReq .get) false .temporaryRedirect (withLocation "/x")) with - | some p => p.method == .get - | none => false - --- 303 See Other preserves HEAD (RFC 9110 §15.4.4: 303 may be retrieved with GET or HEAD), so a --- HEAD request must not be downgraded to GET. -#guard match plan? (decideRedirect origin (mkReq .head) false .seeOther (withLocation "/next")) with - | some p => p.method == .head && isEmptyBody p.bodyAction - | none => false - -/-! ## Target rewriting -/ - --- Absolute-path `Location` replaces the path. -#guard match plan? (decideRedirect origin (mkReq .get) false .found (withLocation "/x")) with - | some p => toString p.target == "/x" - | none => false - --- Relative-path `Location` is merged against the base path (`/a/b` + `c` → `/a/c`). -#guard match plan? (decideRedirect origin (mkReq .get) false .found (withLocation "c")) with - | some p => toString p.target == "/a/c" - | none => false - --- Cross-origin absolute `Location` keeps absolute-form on the wire. -#guard match plan? (decideRedirect origin (mkReq .get credHeaders) false .found (withLocation "http://other.com/x")) with - | some p => p.isCrossOrigin && toString p.target == "http://other.com/x" - | none => false - --- The fragment of an absolute `Location` is never placed on the wire (RFC 9112 §3.2). -#guard match plan? (decideRedirect origin (mkReq .get) false .found (withLocation "http://other.com/x#frag")) with - | some p => toString p.target == "http://other.com/x" - | none => false - -/-! ## Header scrubbing -/ - --- Cross-origin hop strips credential headers and rewrites Host to the new origin. -#guard match plan? (decideRedirect origin (mkReq .get credHeaders) false .found (withLocation "http://other.com/x")) with - | some p => - !p.headers.contains .authorization - && !p.headers.contains .cookie - && (p.headers.get? .host).map (·.value) == some "other.com" - | none => false - --- Same-origin hop keeps credential headers. -#guard match plan? (decideRedirect origin (mkReq .get credHeaders) false .found (withLocation "/next")) with - | some p => p.headers.contains .authorization && p.headers.contains .cookie && !p.isCrossOrigin - | none => false - --- Changing the method to GET strips resource-specific content headers. -#guard match plan? (decideRedirect origin (mkReq .post contentHeaders) false .seeOther (withLocation "/next")) with - | some p => p.method == .get && !p.headers.contains .contentType && !p.headers.contains .contentLength - | none => false - --- A cross-origin hop on a request that carried no `Host` header leaves the plan without one: --- `rewriteHostHeader` only rewrites an existing `Host`, so supplying it is the caller's job. -#guard match plan? (decideRedirect origin (mkReq .get) false .found (withLocation "http://other.com/x")) with - | some p => p.isCrossOrigin && !p.headers.contains .host - | none => false - -/-! ## Blocking redirect invariants -/ - --- A protocol-relative redirect to the current origin is still same-origin, so the request target --- must be origin-form rather than proxy-style absolute-form. - -/-- -info: "crossorigin: false, target: /next" --/ -#guard_msgs in -#eval - match plan? (decideRedirect origin (mkReq .get) false .found (withLocation "//example.com/next")) with - | some p => s!"crossorigin: {p.isCrossOrigin}, target: {toString p.target}" - | none => "no plan" - -private def baseWithQuery : URI := URI.parse! "http://example.com/a/b?old=1" - -private def queryReq : Request.Head := - { method := .get, version := .v11, uri := baseWithQuery.originTarget, headers := .empty } - --- A fragment-only reference inherits the current request target's query. - -/-- -info: "target: /a/b?old=1" --/ -#guard_msgs in -#eval - match plan? (decideRedirect origin queryReq false .found (withLocation "#frag")) with - | some p => s!"target: {toString p.target}" - | none => "no plan" - --- An explicit empty query clears the current request target's query instead of inheriting it. - -/-- -info: "target: /a/b?a=2" --/ -#guard_msgs in -#eval - match plan? (decideRedirect origin queryReq false .found (withLocation "?a=2")) with - | some p => s!"target: {toString p.target}" - | none => "no plan" +/-- Fails unless `outcome` is a followed plan that satisfies `ok`. -/ +private def expectPlan (outcome : RedirectOutcome) (ok : RedirectPlan → Bool) : IO Unit := + match outcome with + | .follow p => ensure (ok p) s!"unexpected plan: method {p.method}, target {toString p.target}, crossOrigin {p.isCrossOrigin}" + | .done => throw <| IO.userError "the redirect was not followed" private def targetFor (requestTarget location : String) : String := let req : Request.Head := { method := .get, version := .v11, uri := RequestTarget.parse! requestTarget } - match plan? (decideRedirect origin req false .found (withLocation location)) with - | some p => toString p.target - | none => "no plan" + match decideRedirect origin req false .found (withLocation location) with + | .follow p => toString p.target + | .done => "no plan" --- #16036: `/` parses to an absolute path with no segments, but it is not the empty reference, so it --- resolves to `/` and drops the base query (RFC 3986 §5.2.2). The last case is the empty reference. +/-- A CONNECT target is the authority to tunnel to (RFC 9110 §9.3.6). -/ +private def connectReq : Request.Head := + { method := .connect, version := .v11, uri := RequestTarget.parse! "example.com:443" } -/-- -info: ["/", "/", "/?y", "/", "/a/b?old=1"] --/ -#guard_msgs in -#eval [ - targetFor "/login?next=%2Fhome" "/", - targetFor "/a/b?old=1" "/", - targetFor "/a/b?old=1" "/?y", - targetFor "/a/b?old=1" "/#f", - targetFor "/a/b?old=1" ""] +/-! ## Terminal responses (RFC 9110 §15.4) -/ --- Dot segments are removed whatever form the `Location` takes (RFC 3986 §5.2.2). The bare path and --- the same-origin protocol-relative reference (first and fourth) are controls: those branches --- already removed them. -/-- -info: ["/etc/passwd", "/etc/passwd", "http://other.example/y", "/y", "http://other.example/y"] --/ -#guard_msgs in -#eval [ - targetFor "/start" "/a/../../etc/passwd", - targetFor "/start" "http://example.com/a/../../etc/passwd", - targetFor "/start" "http://other.example/x/../../y", - targetFor "/start" "//example.com/x/../y", - targetFor "/start" "//other.example/x/./../y"] +#eval checkCases "Terminal responses (`.done`)" #[ + ("A non-3xx status is never a redirect", mkReq .get, false, Status.ok, withLocation "/x"), + ("A 3xx status with no `Location` header cannot be followed", mkReq .get, false, .found, Headers.empty), + ("SSRF guard: a `Location` resolving to a non-http(s) scheme is rejected", mkReq .get, false, .found, + withLocation "file:///etc/passwd"), + ("305 Use Proxy", mkReq .get, false, .useProxy, withLocation "/x"), + ("306 Unused", mkReq .get, false, .unused, withLocation "/x"), + ("304 Not Modified", mkReq .get, false, .notModified, withLocation "/x"), + ("300 Multiple Choices", mkReq .get, false, .multipleChoices, withLocation "/x"), + ("301 PUT whose body cannot be replayed", mkReq .put, false, .movedPermanently, withLocation "/x"), + ("302 PATCH whose body cannot be replayed", mkReq .patch, false, .found, withLocation "/x"), + ("307 POST with a non-replayable body", mkReq .post, false, .temporaryRedirect, withLocation "/x"), + ("CONNECT, 301", connectReq, true, .movedPermanently, withLocation "/x"), + ("CONNECT, 302", connectReq, true, .found, withLocation "/x"), + ("CONNECT, 303", connectReq, true, .seeOther, withLocation "/x"), + ("CONNECT, 307", connectReq, true, .temporaryRedirect, withLocation "/x"), + ("CONNECT, 308", connectReq, true, .permanentRedirect, withLocation "/x"), + ("CONNECT, 302 to another authority", connectReq, true, .found, withLocation "http://other.com:443") + ] fun (label, req, replayable, status, headers) => + ensure (isDone (decideRedirect origin req replayable status headers)) s!"{label}: the redirect was followed" + +/-! ## Method and body (RFC 9110 §15.4.2–§15.4.9) -/ + +#eval checkCases "Followed redirects: method selection" #[ + ("Same-origin 302 on GET: method preserved, target rewritten to origin-form, empty body", + expectPlan (decideRedirect origin (mkReq .get) false .found (withLocation "/next")) fun p => + p.method == .get && !p.isCrossOrigin && toString p.target == "/next" && isEmptyBody p.bodyAction), + ("303 See Other downgrades POST to GET with an empty body", + expectPlan (decideRedirect origin (mkReq .post) false .seeOther (withLocation "/next")) fun p => + p.method == .get && isEmptyBody p.bodyAction), + ("303 PUT → GET", expectPlan (decideRedirect origin (mkReq .put) false .seeOther (withLocation "/x")) fun p => + p.method == .get && isEmptyBody p.bodyAction), + ("303 DELETE → GET", expectPlan (decideRedirect origin (mkReq .delete) false .seeOther (withLocation "/x")) fun p => + p.method == .get && isEmptyBody p.bodyAction), + ("303 PATCH → GET", expectPlan (decideRedirect origin (mkReq .patch) false .seeOther (withLocation "/x")) fun p => + p.method == .get && isEmptyBody p.bodyAction), + ("303 See Other preserves HEAD", + expectPlan (decideRedirect origin (mkReq .head) false .seeOther (withLocation "/next")) fun p => + p.method == .head && isEmptyBody p.bodyAction), + ("301 on POST downgrades to GET and drops the body", + expectPlan (decideRedirect origin (mkReq .post) false .movedPermanently (withLocation "/x")) fun p => + p.method == .get && isEmptyBody p.bodyAction), + ("302 on an HTTP/1.0 POST downgrades to GET and drops the body", + expectPlan (decideRedirect origin (mkReq .post (version := .v10)) true .found + (withLocation "http://other.example/login")) fun p => + p.method == .get && isEmptyBody p.bodyAction && p.isCrossOrigin), + ("307 preserves POST and replays the body when replayable", + expectPlan (decideRedirect origin (mkReq .post) true .temporaryRedirect (withLocation "/x")) fun p => + p.method == .post && isReplayBody p.bodyAction), + ("308 keeps PUT and replays a replayable body", + expectPlan (decideRedirect origin (mkReq .put) true .permanentRedirect (withLocation "/x")) fun p => + p.method == .put && isReplayBody p.bodyAction), + ("301 on PUT keeps the method and replays a replayable body", + expectPlan (decideRedirect origin (mkReq .put) true .movedPermanently (withLocation "/x")) fun p => + p.method == .put && isReplayBody p.bodyAction), + ("302 on PATCH keeps the method and replays a replayable body", + expectPlan (decideRedirect origin (mkReq .patch) true .found (withLocation "/x")) fun p => + p.method == .patch && isReplayBody p.bodyAction), + ("302 on DELETE keeps the method and replays a replayable body", + expectPlan (decideRedirect origin (mkReq .delete) true .found (withLocation "/x")) fun p => + p.method == .delete && isReplayBody p.bodyAction), + ("307 on GET is followed with the method preserved", + expectPlan (decideRedirect origin (mkReq .get) false .temporaryRedirect (withLocation "/x")) fun p => + p.method == .get) + ] (·.2) + +/-! ## Target (RFC 9112 §3.2, RFC 3986 §5.2.2) -/ + +#eval checkCases "Target rewriting" #[ + ("Cross-origin absolute `Location` keeps absolute-form on the wire", + expectPlan (decideRedirect origin (mkReq .get credHeaders) false .found (withLocation "http://other.com/x")) + fun p => p.isCrossOrigin && toString p.target == "http://other.com/x"), + ("A protocol-relative redirect to the current origin is still same-origin", + expectPlan (decideRedirect origin (mkReq .get) false .found (withLocation "//example.com/next")) fun p => + !p.isCrossOrigin && toString p.target == "/next") + ] (·.2) + +-- `/` parses to an absolute path with no segments, but it is not the empty reference, so it resolves +-- to `/` and drops the base query (RFC 3986 §5.2.2). The last case is the empty reference. +#eval checkCases "`/` versus the empty reference (#16036)" #[ + ("/ from /login?next=%2Fhome", "/login?next=%2Fhome", "/", "/"), + ("/ drops the base query", "/a/b?old=1", "/", "/"), + ("/?y", "/a/b?old=1", "/?y", "/?y"), + ("/#f", "/a/b?old=1", "/#f", "/"), + ("the empty reference", "/a/b?old=1", "", "/a/b?old=1") + ] fun (label, from_, location, want) => expectEq label (targetFor from_ location) want + +-- The bare path and the same-origin protocol-relative reference (first and fourth) are controls: +-- those branches already removed them. +#eval checkCases "Dot segments are removed whatever form the `Location` takes" #[ + ("bare path", "/a/../../etc/passwd", "/etc/passwd"), + ("same-origin absolute", "http://example.com/a/../../etc/passwd", "/etc/passwd"), + ("cross-origin absolute", "http://other.example/x/../../y", "http://other.example/y"), + ("same-origin protocol-relative", "//example.com/x/../y", "/y"), + ("cross-origin protocol-relative", "//other.example/x/./../y", "http://other.example/y") + ] fun (label, location, want) => expectEq label (targetFor "/start" location) want + +/-! ## Header scrubbing (RFC 9110 §15.4, §7.6.1) -/ private def sameOriginHopHeaders : Headers := Headers.empty.insert .transferEncoding (Header.Value.ofString! "chunked") --- Hop-by-hop headers are scoped to one connection and must be stripped even on same-origin --- redirects, including when the redirect changes POST to GET and drops the body. - -/-- -info: "methodIsGet: true, transferEncoding: false" --/ -#guard_msgs in -#eval - match plan? (decideRedirect origin (mkReq .post sameOriginHopHeaders) false .seeOther (withLocation "/next")) with - | some p => s!"methodIsGet: {p.method == Method.get}, transferEncoding: {p.headers.contains .transferEncoding}" - | none => "no plan" - private def xHop : Header.Name := Header.Name.ofString! "x-hop" private def connectionNominatedHeaders : Headers := @@ -293,37 +177,24 @@ |>.insert .connection (Header.Value.ofString! "x-hop") |>.insert xHop (Header.Value.ofString! "secret") --- `Connection` can nominate extension hop-by-hop fields; those fields must be removed together --- with the `Connection` header itself when planning the next request. -/-- -info: "connection: false, x-hop: false" --/ -#guard_msgs in -#eval - match plan? (decideRedirect origin (mkReq .get connectionNominatedHeaders) false .found (withLocation "/next")) with - | some p => s!"connection: {p.headers.contains .connection}, x-hop: {p.headers.contains xHop}" - | none => "no plan" - -/-! ## 303 with unsafe non-GET/HEAD methods -/ - --- RFC 9110 §15.4.4: 303 applies to any method, retrieved with GET, so --- a PUT/DELETE/PATCH receiving 303 is followed and rewritten to GET with an empty body. -#guard match plan? (decideRedirect origin (mkReq .put) false .seeOther (withLocation "/x")) with - | some p => p.method == .get && isEmptyBody p.bodyAction - | none => false - -#guard match plan? (decideRedirect origin (mkReq .delete) false .seeOther (withLocation "/x")) with - | some p => p.method == .get && isEmptyBody p.bodyAction - | none => false - -#guard match plan? (decideRedirect origin (mkReq .patch) false .seeOther (withLocation "/x")) with - | some p => p.method == .get && isEmptyBody p.bodyAction - | none => false - -/-! ## `Status.isRedirection` boundaries -/ - --- `isRedirection` is true exactly on the 3xx range and false on the 2xx/4xx boundaries. -#guard Status.isRedirection .multipleChoices -#guard Status.isRedirection .permanentRedirect -#guard !Status.isRedirection .ok -#guard !Status.isRedirection .badRequest +#eval checkCases "Header scrubbing" #[ + ("Cross-origin hop strips credential headers and rewrites Host to the new origin", + expectPlan (decideRedirect origin (mkReq .get credHeaders) false .found (withLocation "http://other.com/x")) + fun p => !p.headers.contains .authorization && !p.headers.contains .cookie && + (p.headers.get? .host).map (·.value) == some "other.com"), + ("Same-origin hop keeps credential headers", + expectPlan (decideRedirect origin (mkReq .get credHeaders) false .found (withLocation "/next")) fun p => + p.headers.contains .authorization && p.headers.contains .cookie && !p.isCrossOrigin), + ("Changing the method to GET strips resource-specific content headers", + expectPlan (decideRedirect origin (mkReq .post contentHeaders) false .seeOther (withLocation "/next")) + fun p => p.method == .get && !p.headers.contains .contentType && !p.headers.contains .contentLength), + ("A cross-origin hop on a request that carried no `Host` header leaves the plan without one", + expectPlan (decideRedirect origin (mkReq .get) false .found (withLocation "http://other.com/x")) fun p => + p.isCrossOrigin && !p.headers.contains .host), + ("Hop-by-hop headers are stripped even on same-origin redirects", + expectPlan (decideRedirect origin (mkReq .post sameOriginHopHeaders) false .seeOther (withLocation "/next")) + fun p => p.method == Method.get && !p.headers.contains .transferEncoding), + ("`Connection` and the fields it nominates are removed", + expectPlan (decideRedirect origin (mkReq .get connectionNominatedHeaders) false .found (withLocation "/next")) + fun p => !p.headers.contains .connection && !p.headers.contains xHop) + ] (·.2)
diff --git a/tests/async/elab/async_http_redirect_rfc3986.lean b/tests/async/elab/async_http_redirect_rfc3986.lean index 6161bde..c4a8c4e 100644 --- a/tests/async/elab/async_http_redirect_rfc3986.lean +++ b/tests/async/elab/async_http_redirect_rfc3986.lean
@@ -1,5 +1,6 @@ module +import Std.Http.Test.Helpers import Std.Http.Protocol.H1 open Std.Http @@ -12,11 +13,11 @@ wire. -/ -/-! ## RFC 3986 §5.2 reference resolution -/ +-- RFC 3986 §5.2 reference resolution -abbrev Str := List Char +private abbrev Str := List Char -structure Ref where +private structure Ref where scheme? : Option Str authority? : Option Str path : Str @@ -24,7 +25,7 @@ fragment? : Option Str /-- Appendix B: `^(([^:/?#]+):)?(//([^/?#]*))?([^?#]*)(\?([^#]*))?(#(.*))?` -/ -def splitRef (s : Str) : Ref := +private def splitRef (s : Str) : Ref := let (pre, rest) := s.span (fun c => c != ':' && c != '/' && c != '?' && c != '#') let (scheme?, s) := if rest.head? == some ':' && !pre.isEmpty then (some pre, rest.tail) else (none, s) @@ -45,7 +46,7 @@ { scheme?, authority?, path, query?, fragment? } /-- §5.2.4. The output buffer is a reversed list of the pieces rule E moved. -/ -partial def removeDotSegmentsLoop : Str → List Str → List Str +private partial def removeDotSegmentsLoop : Str → List Str → List Str | [], out => out | '.' :: '.' :: '/' :: r, out => removeDotSegmentsLoop r out | '.' :: '/' :: r, out => removeDotSegmentsLoop r out @@ -63,16 +64,16 @@ let (seg, rest) := (c :: r).span (· != '/') removeDotSegmentsLoop rest (seg :: out) -def removeDotSegments (p : Str) : Str := +private def removeDotSegments (p : Str) : Str := (removeDotSegmentsLoop p []).reverse.flatten /-- §5.2.3 -/ -def merge (baseHasAuthority : Bool) (basePath refPath : Str) : Str := +private def merge (baseHasAuthority : Bool) (basePath refPath : Str) : Str := if baseHasAuthority && basePath.isEmpty then '/' :: refPath else (basePath.reverse.dropWhile (· != '/')).reverse ++ refPath /-- §5.2.2, strict: a reference's scheme is never ignored. -/ -def resolve (base r : Ref) : Ref := +private def resolve (base r : Ref) : Ref := if r.scheme?.isSome then { r with path := removeDotSegments r.path } else if r.authority?.isSome then @@ -88,7 +89,7 @@ path := removeDotSegments (merge base.authority?.isSome base.path r.path) } /-- §5.3 -/ -def recompose (t : Ref) : String := +private def recompose (t : Ref) : String := (t.scheme?.map (String.ofList · ++ ":")).getD "" ++ (t.authority?.map ("//" ++ String.ofList ·)).getD "" ++ String.ofList t.path @@ -96,7 +97,7 @@ ++ (t.fragment?.map ("#" ++ String.ofList ·)).getD "" /-- The resolver reproduces every example of RFC 3986 §5.4 (base `http://a/b/c/d;p?q`). -/ -def rfcTable : List (String × String) := [ +private def rfcTable : List (String × String) := [ ("g:h", "g:h"), ("g", "http://a/b/c/g"), ("./g", "http://a/b/c/g"), ("g/", "http://a/b/c/g/"), ("/g", "http://a/g"), ("//g", "http://g"), ("?y", "http://a/b/c/d;p?y"), ("g?y", "http://a/b/c/g?y"), ("#s", "http://a/b/c/d;p?q#s"), ("g#s", "http://a/b/c/g#s"), @@ -113,32 +114,27 @@ ("g?y/../x", "http://a/b/c/g?y/../x"), ("g#s/./x", "http://a/b/c/g#s/./x"), ("g#s/../x", "http://a/b/c/g#s/../x"), ("http:g", "http:g")] -/-- info: [] -/ -#guard_msgs in -#eval rfcTable.filter fun (r, want) => - recompose (resolve (splitRef "http://a/b/c/d;p?q".toList) (splitRef r.toList)) != want +-- RFC 3986 syntax -/-! ## RFC 3986 syntax -/ - -def hexVal? (c : Char) : Option Nat := +private def hexVal? (c : Char) : Option Nat := if c.isDigit then some (c.toNat - '0'.toNat) else if 'a' ≤ c.toLower && c.toLower ≤ 'f' then some (c.toLower.toNat - 'a'.toNat + 10) else none -def isUnreserved (c : Char) : Bool := +private def isUnreserved (c : Char) : Bool := c.isAlphanum || c == '-' || c == '.' || c == '_' || c == '~' -def isPchar (c : Char) : Bool := +private def isPchar (c : Char) : Bool := isUnreserved c || "!$&'()*+,;=:@".contains c -partial def wellFormedPercent : Str → Bool +private partial def wellFormedPercent : Str → Bool | '%' :: a :: b :: r => (hexVal? a).isSome && (hexVal? b).isSome && wellFormedPercent r | '%' :: _ => false | _ :: r => wellFormedPercent r | [] => true /-- `URI-reference`, checked per component of the Appendix B split. -/ -def isValidReference (s : String) : Bool := +private def isValidReference (s : String) : Bool := let r := splitRef s.toList let ok (extra : String) (cs : Str) := cs.all (fun c => isPchar c || c == '%' || extra.contains c) && wellFormedPercent cs @@ -171,7 +167,7 @@ /-- RFC 9112 §3.2: `absolute-path [ "?" query ]`, or for absolute-form `scheme "://" authority absolute-path [ "?" query ]` without userinfo or fragment. -/ -def wellFormedTarget (target : String) : Bool := +private def wellFormedTarget (target : String) : Bool := let originForm (s : Str) : Bool := let (path, q) := s.span (· != '?') path.head? == some '/' && path.all (fun c => isPchar c || c == '/' || c == '%') @@ -189,12 +185,12 @@ && originForm (if pq.head? == some '/' then pq else '/' :: pq) | _ => false -/-! ## Expected and planned outcomes -/ +-- Expected and planned outcomes -def lower (s : Str) : Str := s.map Char.toLower +private def lower (s : Str) : Str := s.map Char.toLower /-- §6.2.2.1–2: uppercase percent-encoding hex digits and decode unreserved characters. -/ -partial def normalizePercent : Str → Str +private partial def normalizePercent : Str → Str | '%' :: a :: b :: r => match hexVal? a, hexVal? b with | some x, some y => @@ -208,7 +204,7 @@ /-- A registered name for DNS lookup (RFC 3986 §3.2.2, RFC 1034 §3.5): non-empty labels of at most 63 alphanumerics and `-` that do not start or end with `-`, and an optional trailing `.`. `_` is also accepted, as the client does. -/ -def isDnsName (host : Str) : Bool := +private def isDnsName (host : Str) : Bool := let labels := (String.ofList (if host.getLast? == some '.' then host.dropLast else host)).splitOn "." host.length ≤ 255 && labels.all fun l => let cs := l.toList @@ -218,7 +214,7 @@ /-- `(host, port)` of an authority, with the host normalized as in §6.2.2.1–2, or `none` when it names no usable host: it is empty (RFC 9110 §4.2.1), a registered name that is not a DNS name, or has an invalid port. -/ -def hostPort? (scheme authority : Str) : Option (Str × Nat) := +private def hostPort? (scheme authority : Str) : Option (Str × Nat) := let hostPort := match authority.reverse.span (· != '@') with | (_, []) => authority | (hp, _) => hp.reverse @@ -239,10 +235,10 @@ if n < 65536 then some (host, n) else none else none -def notFollowed : String := "<not followed>" +private def notFollowed : String := "<not followed>" /-- The RFC 3986 outcome as `form scheme://host:port path?query`, from origin `http://example.com`. -/ -def expected (baseTarget location : String) : String := +private def expected (baseTarget location : String) : String := let b := splitRef baseTarget.toList let base := { b with scheme? := some "http".toList, authority? := some "example.com".toList } let t := resolve base (splitRef location.toList) @@ -258,12 +254,12 @@ let query := (t.query?.map ("?" ++ String.ofList ·)).getD "" s!"{form} {String.ofList scheme}://{String.ofList host}:{port} {path}{query}" -def current : URI.Origin := +private def current : URI.Origin := { scheme := URI.Scheme.ofString! "http", host := (URI.parse! "http://example.com/").host?.get!, port := 80 } /-- The plan in the form of `expected`, and the request-target exactly as it goes on the wire. -/ -def planned (baseTarget : String) (location : Header.Value) : String × String := +private def planned (baseTarget : String) (location : Header.Value) : String × String := let request : Request.Head := { method := .get, version := .v11, uri := RequestTarget.parse! baseTarget } match decideRedirect current request false .found (Headers.empty.insert .location location) with @@ -278,7 +274,7 @@ toString p.target) /-- Splits `form origin path?query`. -/ -def parts (s : String) : String × String × Str × Option Str := +private def parts (s : String) : String × String × Str × Option Str := match s.splitOn " " with | [form, origin, pq] => let (path, q) := pq.toList.span (· != '?') @@ -286,7 +282,7 @@ | _ => (s, "", [], none) /-- A reference shape RFC 3986 forbids that `URIReference.parse?` still returns. -/ -def parserViolation? (location : String) : Option String := +private def parserViolation? (location : String) : Option String := match URIReference.parse? location with | some (.relative { authority := none, path, .. }) => let p := toString path @@ -298,7 +294,7 @@ | _ => none /-- A query parameter whose value contains `=` (#16021). -/ -def hasEqualsInValue (location : String) : Bool := +private def hasEqualsInValue (location : String) : Bool := let query := ((location.splitOn "#").head!.splitOn "?").drop 1 query.any fun q => (q.splitOn "&").any fun kv => (kv.splitOn "=").length > 2 @@ -306,7 +302,7 @@ compared up to percent-encoding normalization (§6.2.2.1–2). The planned path must have no dot segments, while the expected one keeps those of the base path when the reference is empty, so only the expected path has them removed (§6.2.2.3). -/ -def check (location want got wire : String) : Option String := +private def check (location want got wire : String) : Option String := if got != notFollowed && !wellFormedTarget wire then some "malformed request-target on the wire" else if !isValidReference location then @@ -329,64 +325,59 @@ some "path differs" else none --- A planned path that kept its dot segments is reported, and so is one with an encoded dot segment --- removed, since `%2E%2E` is not a dot segment (§5.2.4 works on the path as written). -#guard check "/x/../y" "origin-form http://example.com:80 /y" - "origin-form http://example.com:80 /x/../y" "/x/../y" == some "path differs" -#guard check "/x/%2E%2E/y" "origin-form http://example.com:80 /x/%2E%2E/y" - "origin-form http://example.com:80 /y" "/y" == some "path differs" +-- Corpus -/-! ## Corpus -/ +private def rfcExamples : List String := + rfcTable.map (·.1) ++ ["?", "/", "/?y", "/#f", "///g", "//", "//?y", "http://", "http:///g", + "../../f/g/", "/../../f/g/", ".#frag"] -def rfcExamples : List String := - rfcTable.map (·.1) ++ ["/", "/?y", "/#f", "///g", "//", "//?y", "http://", "http:///g"] - -def baseTargets : List String := [ +private def baseTargets : List String := [ "/b/c/d;p?q", "/", "/a", "/a/", "/a/b/", "/a//b", "/a/b?x=1&y=2", "/x/y/z?", "/%7Euser/doc", - "/a%2Fb/c", "/.well-known/x", "/a/b/c/d/e/f", "http://example.com/b/c/d;p?q", "/a/./b/../c"] + "/a%2Fb/c", "/.well-known/x", "/a/b/c/d/e/f", "http://example.com/b/c/d;p?q", "/a/./b/../c", + "/b/c/d/e/", "/b/c/d/e", "/b/", "http://example.com"] -def segments : Array String := #[ +private def segments : Array String := #[ "g", "h", "x", "", "", ".", ".", "..", "..", "g.", ".g", "..g", "g..", "...", "%2E", "%2e", "%2E%2E", ".%2E", "a;b", "a=b", "a:b", "@", "!$&'()*+,;=", "%7E", "~", "%41", "%2F", "%25", "%3F", "%23", "a%20b", "-_.~", "%C3%A9", "%E9", "*", "a+b", "%2f", "%3A"] -def queries : Array String := #[ +private def queries : Array String := #[ "", "y", "a=b", "a=b=c", "a&b", "a&&b", "&", "=", "a=", "=b", "/./x", "../x", "?", "a+b", "%2B", "a%3Db", "%20", "q=%41", "a;b", ":@", "!$'()*,", "%26=%3D", "a=b&a=c", "%7e", "caf%E9"] -def fragments : Array String := #["", "s", "s/../x", "?y", "%C3%A9", "caf%E9"] +private def fragments : Array String := #["", "s", "s/../x", "?y", "%C3%A9", "caf%E9"] -def authorities : Array String := #[ +private def authorities : Array String := #[ "example.com", "EXAMPLE.com", "example.com:80", "example.com:", "example.com:8080", "example.com:443", "other.com", "user:pw@example.com", "user@other.com:81", "127.0.0.1", "[::1]", "[::1]:8080", "a.b-c.example", "example.com:65536", "", ":80", "example.com.", "a_b.example", "ex%41mple.com"] -def schemes : Array String := #["http", "HTTP", "https", "HtTpS", "ftp", "file", "mailto"] +private def schemes : Array String := #["http", "HTTP", "https", "HtTpS", "ftp", "file", "mailto"] /-- Pieces that make a reference invalid in most positions. -/ -def invalidPieces : Array String := #[ +private def invalidPieces : Array String := #[ " ", "<", ">", "\"", "{", "}", "|", "\\", "^", "`", "%", "%G1", "%2", "é", "[", "]", "a b", "%%", "#", "?#", "//", ":", "@", "%00", "%0D%0A"] -structure Rng where +private structure Rng where state : UInt64 -def Rng.next (g : Rng) : Nat × Rng := +private def Rng.next (g : Rng) : Nat × Rng := let s := g.state * 6364136223846793005 + 1442695040888963407 ((s >>> 33).toNat, ⟨s⟩) -def Rng.below (g : Rng) (n : Nat) : Nat × Rng := +private def Rng.below (g : Rng) (n : Nat) : Nat × Rng := let (m, g) := g.next (m % n, g) -def Rng.pick (g : Rng) (xs : Array String) : String × Rng := +private def Rng.pick (g : Rng) (xs : Array String) : String × Rng := let (n, g) := g.below xs.size (xs[n]!, g) /-- `/`-separated segments. A relative path whose first segment is empty or has a `:` gets a `./` prefix, and an absolute one a `.` segment so it cannot start with `//` (RFC 3986 §4.2). -/ -def genPath (g : Rng) (absolute : Bool) : String × Rng := Id.run do +private def genPath (g : Rng) (absolute : Bool) : String × Rng := Id.run do let (n, g) := g.below 5 let mut g := g let mut segs : Array String := #[] @@ -402,7 +393,7 @@ else return (body, g) -def genReference (g : Rng) : String × Rng := Id.run do +private def genReference (g : Rng) : String × Rng := Id.run do let (kind, g) := g.below 10 let mut g := g let mut out := "" @@ -445,7 +436,7 @@ out := out ++ "#" ++ f return (out, g) -def corpus (count : Nat) : Array String := Id.run do +private def corpus (count : Nat) : Array String := Id.run do let mut g : Rng := ⟨20261029⟩ let mut out := rfcExamples.toArray for i in [0:count] do @@ -461,11 +452,26 @@ out := out.push r return out -/-! ## Run -/ +/-! ## Oracle self-checks (RFC 3986 §5.4, §5.2.4) -/ + +-- The resolver reproduces every example of RFC 3986 §5.4. +/-- info: [] -/ +#guard_msgs in +#eval rfcTable.filter fun (r, want) => + recompose (resolve (splitRef "http://a/b/c/d;p?q".toList) (splitRef r.toList)) != want + +-- A planned path that kept its dot segments is reported, and so is one with an encoded dot segment +-- removed, since `%2E%2E` is not a dot segment (§5.2.4 works on the path as written). +#guard check "/x/../y" "origin-form http://example.com:80 /y" + "origin-form http://example.com:80 /x/../y" "/x/../y" == some "path differs" +#guard check "/x/%2E%2E/y" "origin-form http://example.com:80 /x/%2E%2E/y" + "origin-form http://example.com:80 /y" "/y" == some "path differs" + +/-! ## Differential (RFC 3986 §5.2, RFC 9112 §3.2) -/ /-- Checks every base against every reference and reports each failure category with its count and a few samples. -/ -def run (count : Nat) (samplesPerCategory : Nat := 3) : IO Unit := do +private def run (count : Nat) (samplesPerCategory : Nat := 3) : IO Unit := do let refs := corpus count let mut checked := 0 let mut failures : Array (String × Nat × Array String) := #[] @@ -493,6 +499,6 @@ IO.println s!"{n} × {category}" for s in samples do IO.println s -/-- info: 42280 redirects agree with RFC 3986 -/ +/-- info: 54432 redirects agree with RFC 3986 -/ #guard_msgs in #eval run 3000
diff --git a/tests/async/elab/async_http_request_body_end.lean b/tests/async/elab/async_http_request_body_end.lean index 9863344..09714d5 100644 --- a/tests/async/elab/async_http_request_body_end.lean +++ b/tests/async/elab/async_http_request_body_end.lean
@@ -190,3 +190,10 @@ let text := String.fromUTF8! response unless text.startsWith "HTTP/1.1 200 OK" do throw (IO.userError s!"run {i}: unexpected response {text.quote}") + +-- A chunked body whose terminal zero-size chunk never arrives before EOF is a bad message. +#eval runGroup "RFC 9112 §6: chunked parse errors" do + checkClose "missing terminal 0-chunk at EOF → 400" + (raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n") + (handler := echoHandler) + (expect := (assertExact · r400))
diff --git a/tests/async/elab/async_http_request_headers.lean b/tests/async/elab/async_http_request_headers.lean deleted file mode 100644 index d538112..0000000 --- a/tests/async/elab/async_http_request_headers.lean +++ /dev/null
@@ -1,128 +0,0 @@ -import Std.Http.Test.Helpers - -open Std.Async -open Std Http Internal Test - --- Shared fixtures - -private def ok200 : String := - "HTTP/1.1 200 OK\x0d\nContent-Type: text/plain; charset=utf-8\x0d\nServer: LeanHTTP/1.1\x0d\nConnection: close\x0d\nContent-Length: 2\x0d\n\x0d\nok" - --- RFC 9112 §5: Header fields — syntax and byte-level validation - -#eval runGroup "RFC 9112 §5: header field syntax" do - check "header without colon → 400" - (raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nBadHeader value\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r400) - - check "leading whitespace (obs-fold) → 400" - (raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\n X-Bad: folded\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r400) - - check "space in header name → 400" - (raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nBad Header: value\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r400) - - check "bare LF line endings → 400" - (raw := "GET / HTTP/1.1\nHost: example.com\nConnection: close\n\n") - (handler := okHandler) - (expect := fun r => assertExact r r400) - - check "tab in header value → accepted" - (raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nX-Tab: value\twith\ttabs\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r ok200) - - check "additional colon in header value stays in value" - (raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nBad:Name: value\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r ok200) - - check "CRLF in header value parsed as two separate headers → 200" - (raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nX-Inject: value\x0d\nEvil: injected\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r ok200) - --- Critical: NUL and control chars in header names/values - -#eval runGroup "RFC 9110 §5.5: invalid bytes in header fields (Critical)" do - check "NUL in header name → 400" - (raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nX-Bad\x00Header: value\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r400) - - check "NUL in header value → 400" - (raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nX-Header: bad\x00value\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r400) - - check "control char (0x01) in header value → 400" - (raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nX-Header: bad\x01value\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r400) - --- RFC 9112 §6.3 / §9110 §8.6: header size limits - -#eval runGroup "Header size limits" do - check "header name > 256 bytes → 400" - (raw := - let longName := String.ofList (List.replicate 257 'X') - s!"GET / HTTP/1.1\x0d\nHost: example.com\x0d\n{longName}: value\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r400) - - check "header value too long → 400" - (raw := - let longVal := String.ofList (List.replicate 9000 'x') - s!"GET / HTTP/1.1\x0d\nHost: example.com\x0d\nX-Long: {longVal}\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r400) - - check "too many headers (101) → 431" - (raw := Id.run do - let mut raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n" - for i in [0:101] do - raw := raw ++ s!"X-Header-{i}: value{i}\x0d\n" - return raw ++ "\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r431) - - check "total header bytes too large → 431" - (raw := Id.run do - let mut raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n" - let v := String.ofList (List.replicate 200 'a') - for i in [0:200] do - raw := raw ++ s!"X-Header-{i}: {v}\x0d\n" - return raw ++ "\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r431) - - -- The method and version are bounded, so a line over the limit is over it because of its target. - check "request-line too long → 414" - (raw := - let longUri := "/" ++ String.ofList (List.replicate 2000 'a') - s!"GET {longUri} HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (config := { defaultConfig with maxStartLineLength := 1000 }) - (expect := fun r => assertStatus r "HTTP/1.1 414") - -#eval runGroup "maxStartLineLength config" do - let cfg : Config := { defaultConfig with maxStartLineLength := 16384 } - - let segment := String.ofList (List.replicate 255 'a') - let maxUri := "/" ++ String.intercalate "/" (List.replicate 32 segment) - - check "URI at maxStartLineLength limit → 200" - (raw := s!"GET {maxUri} HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (config := cfg) - (expect := fun r => assertExact r ok200) - - check "URI one byte over limit → 414" - (raw := s!"GET {maxUri}/x HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (config := cfg) - (expect := fun r => assertStatus r "HTTP/1.1 414")
diff --git a/tests/async/elab/async_http_request_line.lean b/tests/async/elab/async_http_request_line.lean deleted file mode 100644 index 0b3b91d..0000000 --- a/tests/async/elab/async_http_request_line.lean +++ /dev/null
@@ -1,176 +0,0 @@ -import Std.Http.Test.Helpers - -open Std.Async -open Std Http Internal Test - --- Shared fixtures - -private def ok200 : String := - "HTTP/1.1 200 OK\x0d\nContent-Type: text/plain; charset=utf-8\x0d\nServer: LeanHTTP/1.1\x0d\nConnection: close\x0d\nContent-Length: 2\x0d\n\x0d\nok" - --- RFC 9112 §3: Request Line - -#eval runGroup "RFC 9112 §3: request-line parse failures" do - check "missing version → 400" - (raw := "GET /\x0d\nHost: example.com\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r400) - - check "missing URI (double space) → 400" - (raw := "GET HTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r400) - - check "extra spaces in request-line → 400" - (raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r400) - - check "whitespace-only request-line → 400" - (raw := " \x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r400) - - check "no spaces in request-line → 400" - (raw := "GETHTTP/1.1\x0d\nHost: example.com\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r400) - - check "garbage after request-line version → 400" - (raw := "GET / HTTP/1.1 xxxxxx\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r400) - - -- Empty connection: no bytes → silent close, no response - checkClose "empty connection → silent close" - (raw := "") - (handler := okHandler) - (expect := fun r => assertExact r "") - -#eval runGroup "RFC 9112 §2.2: leading CRLF before request-line" do - check "single leading CRLF accepted" - (raw := "\x0d\nGET / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r ok200) - --- RFC 9112 §9: HTTP version - -#eval runGroup "RFC 9112 §9: HTTP version" do - check "HTTP/2.0 → 505" - (raw := "GET / HTTP/2.0\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r505) - --- RFC 9110 §9: Methods - -#eval runGroup "RFC 9110 §9: method validation" do - -- RFC 9110 §9.1: a method the server does not recognize is answered with 501; methods are - -- case-sensitive, so `get` is one of them - check "unknown method FOOBAR → 501" - (raw := "FOOBAR / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r501) - - check "lowercase method → 501" - (raw := "get / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r501) - - check "non-ASCII method → 400" - (raw := "GÉT / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r400) - - -- RFC 9112 §3: so is a method longer than any the server implements - check "very long unrecognized method → 501" - (raw := - let m := String.ofList (List.replicate 100 'G') - s!"{m} / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r501) - - check "token method with hyphen (X-CUSTOM) → 501" - (raw := "X-CUSTOM / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r501) - - check "method that starts with a known one (GETX) → 501" - (raw := "GETX / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r501) - --- RFC 9112 §3.2: Request target forms - -#eval runGroup "RFC 9112 §3.2: request target forms" do - check "GET authority-form → 400" - (raw := "GET example.com:443 HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r400) - - -- A 2xx to CONNECT starts a tunnel, so it has no framing fields or content (RFC 9110 §9.3.6). - check "CONNECT authority-form accepted" - (raw := "CONNECT example.com:443 HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r - "HTTP/1.1 200 OK\x0d\nContent-Type: text/plain; charset=utf-8\x0d\nServer: LeanHTTP/1.1\x0d\nConnection: close\x0d\n\x0d\n") - - check "CONNECT authority-form port mismatch → 400" - (raw := "CONNECT example.com:444 HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r400) - - check "GET asterisk-form → 400" - (raw := "GET * HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r400) - - check "OPTIONS * accepted" - (raw := "OPTIONS * HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r ok200) - - check "absolute-form URI accepted" - (raw := "GET http://example.com/path HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r ok200) - --- RFC 9112 §3.3: Early invalid bytes - -#eval runGroup "RFC 9112 §3: early invalid bytes" do - checkClose "NUL byte → 400" - (raw := "\x00") - (handler := okHandler) - (expect := fun r => assertExact r r400) - - checkClose "SP byte → 400" - (raw := "\x20") - (handler := okHandler) - (expect := fun r => assertExact r r400) - - checkClose "TLS client-hello prefix → 400" - (raw := "\x16\x03\x01\x00\xa5") - (handler := okHandler) - (expect := fun r => assertExact r r400) - --- RFC 7230 §5.4: Host header - -#eval runGroup "RFC 7230 §5.4: Host header" do - check "missing Host header → 400" - (raw := "GET / HTTP/1.1\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r400) - - check "empty Host allowed for origin-form" - (raw := "GET / HTTP/1.1\x0d\nHost: \x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r ok200) - - check "multiple Host headers → 400" - (raw := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nHost: other.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r r400) - - check "absolute-form: URI authority takes precedence over Host" - (raw := "GET http://good.example/path HTTP/1.1\x0d\nHost: good.example\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r ok200)
diff --git a/tests/async/elab/async_http_request_target_limits.lean b/tests/async/elab/async_http_request_target_limits.lean deleted file mode 100644 index 8f4def1..0000000 --- a/tests/async/elab/async_http_request_target_limits.lean +++ /dev/null
@@ -1,50 +0,0 @@ -import Std.Http -import Std.Http.Test.Helpers - -open Std Http -open Std.Http.Internal.Test - -/-! -Tests the limits on request-targets and URIs. A target is bounded as a whole by `maxUriLength`, and a -target refused as too long gets `414`, never `400` (RFC 9112 §3), whatever its segments, segment -count or query parameters. `URI.parse?`, which `decideRedirect` uses on `Location`, has no -per-component limit tighter than the whole URI's. --/ - -def expect (cond : Bool) (msg : String) : IO Unit := - unless cond do throw (IO.userError msg) - -def repeatStr (s : String) (n : Nat) : String := String.join (List.replicate n s) - -#eval runGroup "valid targets under maxUriLength" do - for (label, target) in [ - ("257-byte segment", "/" ++ repeatStr "a" 257), - ("600-byte segment", "/" ++ repeatStr "a" 600), - ("129 segments", repeatStr "/a" 129), - ("101 query parameters", "/?" ++ "&".intercalate (List.replicate 101 "a=1"))] do - check label (mkGetClose target) uriHandler fun r => assertStatus r "HTTP/1.1 200" - --- The status code grows monotonically with the target's length: 200 up to the limit, 414 beyond it. -#eval runGroup "start-line limit" do - -- `GET ` and ` HTTP/1.1\r\n` add 15 bytes, so a 8177-byte target makes a 8192-byte line. - check "8177-byte target" (mkGetClose ("/" ++ repeatStr "a" 8176)) uriHandler fun r => - assertStatus r "HTTP/1.1 200" - for length in [8178, 8192, 8193] do - check s!"{length}-byte target" (mkGetClose ("/" ++ repeatStr "a" (length - 1))) uriHandler fun r => - assertStatus r "HTTP/1.1 414" - --- A small `maxUriLength` still answers 414. -#eval runGroup "configured maxUriLength" do - check "400-byte target, maxUriLength 300" (mkGetClose ("/" ++ repeatStr "a" 399)) uriHandler - (fun r => assertStatus r "HTTP/1.1 414") - (config := { defaultConfig with maxUriLength := 300 }) - --- `URI.parse?` accepts what a `Location` field may carry. -#eval show IO Unit from do - for (label, uri) in [ - ("257-byte segment", "http://example.com/" ++ repeatStr "a" 257), - ("129 segments", "http://example.com" ++ repeatStr "/a" 129), - ("101 query parameters", "http://example.com/?" ++ "&".intercalate (List.replicate 101 "a=1")), - ("1100-byte fragment", "http://example.com/#" ++ repeatStr "f" 1100), - ("16-character scheme", "chrome-extension://abcdef/x")] do - expect (URI.parse? uri).isSome s!"URI.parse? rejected a URI with a {label}"
diff --git a/tests/async/elab/async_http_response_framing.lean b/tests/async/elab/async_http_response_framing.lean deleted file mode 100644 index 218e7b7..0000000 --- a/tests/async/elab/async_http_response_framing.lean +++ /dev/null
@@ -1,197 +0,0 @@ -import Std.Http.Test.Helpers - -open Std.Async -open Std Http Internal Test - --- Shared fixtures - -private def ok200Head : String := - "HTTP/1.1 200 OK\x0d\nContent-Type: text/plain; charset=utf-8\x0d\nServer: LeanHTTP/1.1\x0d\nConnection: close\x0d\nContent-Length: 2\x0d\n\x0d\n" - --- RFC 9110 §9.3.2: HEAD - -#eval runGroup "RFC 9110 §9.3.2: HEAD response framing" do - check "HEAD omits body bytes, preserves headers" - (raw := "HEAD / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := okHandler) - (expect := fun r => assertExact r ok200Head) - - check "GET and HEAD produce identical header sections" - (raw := "GET /frame HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n") - (handler := fun _ => Response.ok |>.text "hello") - (expect := fun getResp => do - -- Run HEAD against the same handler - let (client2, server2) ← Mock.new - let headResp ← Async.block do - client2.send "HEAD /frame HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 - Std.Http.Server.serveConnection server2 (show TestHandler from fun _ => Response.ok |>.text "hello") defaultConfig |>.run - return (← client2.recv?).getD .empty - - let getHeaders := (String.fromUTF8! getResp).splitOn "\x0d\n\x0d\n" |>.headD "" - let headHeaders := (String.fromUTF8! headResp).splitOn "\x0d\n\x0d\n" |>.headD "" - unless getHeaders == headHeaders do - throw <| IO.userError s!"headers differ:\nGET: {getHeaders.quote}\nHEAD: {headHeaders.quote}" - assertContains getResp "hello" *> - assertAbsent headResp "hello") - --- RFC 9110 §15.4: 304 and 204 response framing - -#eval runGroup "RFC 9110 §15.4: 304 Not Modified strips framing headers" do - -- Direct machine test: write a 304 head with Content-Length: 5 and verify it is stripped. - -- RFC 9110 §8.6 permits Content-Length in 304 as optional metadata, but we strip it to - -- avoid forwarding a stale or wrong value from a handler that did not intend to advertise - -- a body size. - let request := "GET /cache HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 - let machine0 : Protocol.H1.Machine .receiving := { config := {} } - let (machine1, _) := (machine0.feed request).step - let headers304 := Headers.empty.insert Header.Name.contentLength (Header.Value.ofString! "5") - let (_, step304) := (machine1.send ({ status := .notModified, headers := headers304 } : Response.Head)).step - let text304 := String.fromUTF8! step304.output.toByteArray - unless text304.contains "HTTP/1.1 304 Not Modified" do - throw <| IO.userError s!"expected 304 status in output:\n{text304.quote}" - if text304.contains "Content-Length:" || text304.contains "Transfer-Encoding:" then - throw <| IO.userError s!"unexpected framing headers in 304:\n{text304.quote}" - -#eval runGroup "RFC 9110 §15.3.5: 204 No Content strips framing headers" do - let request := "GET /empty HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 - let machine0 : Protocol.H1.Machine .receiving := { config := {} } - let (machine1, _) := (machine0.feed request).step - let headers204 := Headers.empty.insert Header.Name.contentLength (Header.Value.ofString! "9") - let (_, step204) := (machine1.send ({ status := .noContent, headers := headers204 } : Response.Head)).step - let text204 := String.fromUTF8! step204.output.toByteArray - unless step204.output.size > 0 do - throw <| IO.userError "expected serialized response output" - unless text204.contains "HTTP/1.1 204 No Content" do - throw <| IO.userError s!"expected 204 status:\n{text204.quote}" - if text204.contains "Content-Length:" || text204.contains "Transfer-Encoding:" then - throw <| IO.userError s!"unexpected framing headers in 204:\n{text204.quote}" - --- RFC 9112 §9.6: Client-mode — parsing responses - -#eval runGroup "RFC 9112 §9.6: client-mode response parsing" do - -- Parse a 200 response with headers - let machineA : Protocol.H1.Machine .sending := { config := {}, reader := { state := .needStartLine } } - let rawA := "HTTP/1.1 200 OK\x0d\nContent-Length: 0\x0d\nConnection: close\x0d\n\x0d\n" - let (machineA', stepA) := (machineA.feed rawA.toUTF8).step - if stepA.events.any (fun | .failed _ => true | _ => false) then - throw <| IO.userError s!"unexpected failure parsing 200 response: {repr stepA.events}" - unless stepA.events.any (fun | .endHeaders _ => true | _ => false) do - throw <| IO.userError s!"missing endHeaders event: {repr stepA.events}" - unless machineA'.reader.messageHead.status == .ok do - throw <| IO.userError s!"unexpected status: {repr machineA'.reader.messageHead.status}" - unless machineA'.reader.messageHead.headers.hasEntry Header.Name.contentLength (Header.Value.ofString! "0") do - throw <| IO.userError "missing Content-Length header in parsed response" - - -- Parse headerless 204 - let machineB : Protocol.H1.Machine .sending := { config := {}, reader := { state := .needStartLine } } - let rawB := "HTTP/1.1 204 No Content\x0d\n\x0d\n" - let (_, stepB) := (machineB.feed rawB.toUTF8).step - if stepB.events.any (fun | .failed _ => true | _ => false) then - throw <| IO.userError s!"unexpected failure parsing 204: {repr stepB.events}" - if stepB.events.any (fun | .needMoreData _ => true | _ => false) then - throw <| IO.userError s!"unexpected needMoreData for 204: {repr stepB.events}" - unless stepB.events.any (fun | .endHeaders _ => true | _ => false) do - throw <| IO.userError s!"missing endHeaders for 204: {repr stepB.events}" - - -- 204 with Content-Length in response: body framing should be ignored - let machineC : Protocol.H1.Machine .sending := { config := {}, reader := { state := .needStartLine } } - let rawC := "HTTP/1.1 204 No Content\x0d\nContent-Length: 5\x0d\n\x0d\nHELLO" - let (machineC', stepC) := (machineC.feed rawC.toUTF8).step - if stepC.events.any (fun | .failed _ => true | _ => false) then - throw <| IO.userError s!"unexpected failure for 204 with framing: {repr stepC.events}" - -- The 5 bytes of "HELLO" should remain unread - unless machineC'.reader.input.remainingBytes == 5 do - throw <| IO.userError s!"expected 5 unread bytes, got {machineC'.reader.input.remainingBytes}" - --- RFC 9110 §15.2: 1xx informational responses MUST NOT carry framing headers - -#eval runGroup "RFC 9110 §15.2: 1xx informational responses strip framing headers" do - let request := "GET / HTTP/1.1\x0d\nHost: example.com\x0d\nConnection: close\x0d\n\x0d\n".toUTF8 - let machine0 : Protocol.H1.Machine .receiving := { config := {} } - let (machine1, _) := (machine0.feed request).step - - -- 100 Continue: handler-set Content-Length must be stripped - let headers100 := Headers.empty - |>.insert Header.Name.contentLength (Header.Value.ofString! "5") - let (machine2, step100) := (machine1.send ({ status := .«continue», headers := headers100 } : Response.Head)).step - let text100 := String.fromUTF8! step100.output.toByteArray - unless text100.contains "HTTP/1.1 100 Continue" do - throw <| IO.userError s!"expected 100 status in output:\n{text100.quote}" - if text100.contains "Content-Length:" then - throw <| IO.userError s!"Content-Length must not appear in 1xx output:\n{text100.quote}" - - -- 103 Early Hints: both Content-Length and Transfer-Encoding must be stripped - let headers103 := Headers.empty - |>.insert Header.Name.contentLength (Header.Value.ofString! "42") - |>.insert Header.Name.transferEncoding (Header.Value.ofString! "chunked") - let (machine3, step103) := (machine2.send ({ status := .earlyHints, headers := headers103 } : Response.Head)).step - let text103 := String.fromUTF8! step103.output.toByteArray - unless text103.contains "HTTP/1.1 103 Early Hints" do - throw <| IO.userError s!"expected 103 status in output:\n{text103.quote}" - if text103.contains "Content-Length:" || text103.contains "Transfer-Encoding:" then - throw <| IO.userError s!"framing headers must not appear in 1xx output:\n{text103.quote}" - - -- Machine must remain in waitingHeaders after sending 1xx (interim does not advance writer) - unless machine3.writer.state == .waitingHeaders do - throw <| IO.userError s!"writer must stay in waitingHeaders after 1xx, got: {repr machine3.writer.state}" - - -- Final 200 OK still works after chained 1xx responses - let headers200 := Headers.empty - |>.insert Header.Name.contentLength (Header.Value.ofString! "0") - let (_, step200) := (machine3.send ({ status := .ok, headers := headers200 } : Response.Head)).step - let text200 := String.fromUTF8! step200.output.toByteArray - unless text200.contains "HTTP/1.1 200 OK" do - throw <| IO.userError s!"expected 200 after 1xx chain:\n{text200.quote}" - unless text200.contains "Content-Length: 0" do - throw <| IO.userError s!"Content-Length must be preserved in final response:\n{text200.quote}" - --- RFC 7230 §3.3.1 / RFC 9112 §6.1: HTTP/1.0 connection-close framing. --- When the handler does not set Content-Length for an HTTP/1.0 request the machine --- must not emit Transfer-Encoding or Content-Length; it writes raw bytes and closes. - -#eval runGroup "RFC 7230 §3.3.1: HTTP/1.0 connection-close — headers" do - let request10 := "GET / HTTP/1.0\x0d\nHost: example.com\x0d\n\x0d\n".toUTF8 - let machine0 : Protocol.H1.Machine .receiving := { config := {} } - let (machine1, _) := (machine0.feed request10).step - let (_, stepA) := (machine1.send ({ status := .ok, headers := .empty } : Response.Head)).step - let textA := String.fromUTF8! stepA.output.toByteArray - unless textA.contains "200 OK" do - throw <| IO.userError s!"expected 200 status line:\n{textA.quote}" - if textA.contains "Transfer-Encoding:" then - throw <| IO.userError s!"Transfer-Encoding must not appear in HTTP/1.0 response:\n{textA.quote}" - if textA.contains "Content-Length:" then - throw <| IO.userError s!"Content-Length must not appear when body length is unknown:\n{textA.quote}" - -#eval runGroup "RFC 7230 §3.3.1: HTTP/1.0 connection-close — body framing" do - let request10 := "GET / HTTP/1.0\x0d\nHost: example.com\x0d\n\x0d\n".toUTF8 - let machine0 : Protocol.H1.Machine .receiving := { config := {} } - let (machine1, _) := (machine0.feed request10).step - - -- Non-empty body: raw bytes must appear in output without chunk framing. - let body := "hello world".toUTF8 - let machine2 := - machine1 - |>.send ({ status := .ok, headers := .empty } : Response.Head) - |>.sendData #[{ data := body, extensions := #[] }] - |>.userClosedBody - let (machine3, step2) := machine2.step - let output2 := String.fromUTF8! step2.output.toByteArray - unless output2.contains "hello world" do - throw <| IO.userError s!"body bytes must appear in output:\n{output2.quote}" - -- Chunk framing would look like "b\r\nhello world\r\n0\r\n\r\n" - if output2.contains "0\x0d\x0a\x0d\x0a" then - throw <| IO.userError s!"body must not be chunk-framed (found final-chunk terminator):\n{output2.quote}" - unless step2.events.any (fun | .close => true | _ => false) do - throw <| IO.userError s!"expected .close event after connection-close body:\n{repr step2.events}" - unless !machine3.keepAlive do - throw <| IO.userError "keepAlive must be false for HTTP/1.0 connection-close response" - - -- Empty body: userClosedBody with no data must still emit .close. - let (machine1b, _) := (machine0.feed request10).step - let machine4 := - machine1b - |>.send ({ status := .ok, headers := .empty } : Response.Head) - |>.userClosedBody - let (_, step3) := machine4.step - unless step3.events.any (fun | .close => true | _ => false) do - throw <| IO.userError s!"expected .close event for empty HTTP/1.0 body:\n{repr step3.events}"
diff --git a/tests/async/elab/async_http_trailers.lean b/tests/async/elab/async_http_trailers.lean deleted file mode 100644 index 3330b3b..0000000 --- a/tests/async/elab/async_http_trailers.lean +++ /dev/null
@@ -1,247 +0,0 @@ -import Std.Http -import Std.Async - -open Std.Async -open Std Http Internal Test -open Std.Http.Internal - -def sendRaw - (client : Mock.Client) - (server : Mock.Server) - (raw : ByteArray) - (handler : TestHandler) - (config : Config := { lingeringTimeout := 3000, generateDate := false }) : IO ByteArray := Async.block do - client.send raw - Std.Http.Server.serveConnection server handler config - |>.run - let res ← client.recv? - pure <| res.getD .empty - -def sendRawAndClose - (client : Mock.Client) - (server : Mock.Server) - (raw : ByteArray) - (handler : TestHandler) - (config : Config := { lingeringTimeout := 1000, generateDate := false }) : IO ByteArray := Async.block do - client.send raw - client.close - Std.Http.Server.serveConnection server handler config - |>.run - let res ← client.recv? - pure <| res.getD .empty - -def bodyHandler : TestHandler := - fun req => do - let body : String ← req.body.readAll - Response.ok |>.text body - -def bad400 : String := r400 - --- Chunked body without trailers. -#eval show IO _ from do - let (client, server) ← Mock.new - let raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\n\x0d\n".toUTF8 - let response ← sendRaw client server raw bodyHandler - assertStatus response "HTTP/1.1 200" - assertContains response "hello" - --- Single trailer header. -#eval show IO _ from do - let (client, server) ← Mock.new - let raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\nChecksum: abc123\x0d\n\x0d\n".toUTF8 - let response ← sendRaw client server raw bodyHandler - assertStatus response "HTTP/1.1 200" - assertContains response "hello" - --- Multiple trailer headers. -#eval show IO _ from do - let (client, server) ← Mock.new - let raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\nChecksum: abc123\x0d\nExpires: Thu, 01 Dec 1994 16:00:00 GMT\x0d\nX-Custom: value\x0d\n\x0d\n".toUTF8 - let response ← sendRaw client server raw bodyHandler - assertStatus response "HTTP/1.1 200" - assertContains response "hello" - --- Terminal chunk extensions can precede trailers. -#eval show IO _ from do - let (client, server) ← Mock.new - let raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0;ext=val\x0d\nX-Trailer: yes\x0d\n\x0d\n".toUTF8 - let response ← sendRaw client server raw bodyHandler - assertStatus response "HTTP/1.1 200" - assertContains response "hello" - --- Trailer name and value limits. -#eval show IO _ from do - let exactName := String.ofList (List.replicate 256 'X') - let longName := String.ofList (List.replicate 257 'X') - let exactValue := String.ofList (List.replicate 8192 'v') - let longValue := String.ofList (List.replicate 8193 'v') - - let (clientA, serverA) ← Mock.new - let rawA := s!"POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n3\x0d\nabc\x0d\n0\x0d\n{exactName}: value\x0d\n\x0d\n".toUTF8 - let responseA ← sendRaw clientA serverA rawA bodyHandler - assertStatus responseA "HTTP/1.1 200" - - let (clientB, serverB) ← Mock.new - let rawB := s!"POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n3\x0d\nabc\x0d\n0\x0d\n{longName}: value\x0d\n\x0d\n".toUTF8 - let responseB ← sendRaw clientB serverB rawB bodyHandler - assertExact responseB bad400 - - let (clientC, serverC) ← Mock.new - let rawC := s!"POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n3\x0d\nabc\x0d\n0\x0d\nX-Exact: {exactValue}\x0d\n\x0d\n".toUTF8 - let responseC ← sendRaw clientC serverC rawC bodyHandler - assertStatus responseC "HTTP/1.1 200" - - let (clientD, serverD) ← Mock.new - let rawD := s!"POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n3\x0d\nabc\x0d\n0\x0d\nX-Too-Long: {longValue}\x0d\n\x0d\n".toUTF8 - let responseD ← sendRaw clientD serverD rawD bodyHandler - assertExact responseD bad400 - --- maxTrailerHeaders enforcement. -#eval show IO _ from do - let config2 : Config := { lingeringTimeout := 3000, maxTrailerHeaders := 2, generateDate := false } - - let (clientA, serverA) ← Mock.new - let okRaw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n3\x0d\nabc\x0d\n0\x0d\nT1: a\x0d\nT2: b\x0d\n\x0d\n".toUTF8 - let okResponse ← sendRaw clientA serverA okRaw bodyHandler (config := config2) - assertStatus okResponse "HTTP/1.1 200" - - let (clientB, serverB) ← Mock.new - let badRaw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n3\x0d\nabc\x0d\n0\x0d\nT1: a\x0d\nT2: b\x0d\nT3: c\x0d\n\x0d\n".toUTF8 - let badResponse ← sendRaw clientB serverB badRaw bodyHandler (config := config2) - assertExact badResponse bad400 - - let config0 : Config := { lingeringTimeout := 3000, maxTrailerHeaders := 0, generateDate := false } - - let (clientC, serverC) ← Mock.new - let rejectAny := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n3\x0d\nabc\x0d\n0\x0d\nX-Trailer: rejected\x0d\n\x0d\n".toUTF8 - let responseC ← sendRaw clientC serverC rejectAny bodyHandler (config := config0) - assertExact responseC bad400 - - let (clientD, serverD) ← Mock.new - let noTrailer := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n3\x0d\nabc\x0d\n0\x0d\n\x0d\n".toUTF8 - let responseD ← sendRaw clientD serverD noTrailer bodyHandler (config := config0) - assertStatus responseD "HTTP/1.1 200" - --- Trailer syntax validation. -#eval show IO _ from do - let (clientA, serverA) ← Mock.new - let noColon := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n3\x0d\nabc\x0d\n0\x0d\nBadTrailer value\x0d\n\x0d\n".toUTF8 - let responseA ← sendRaw clientA serverA noColon bodyHandler - assertExact responseA bad400 - - let (clientB, serverB) ← Mock.new - let leadingWS := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n3\x0d\nabc\x0d\n0\x0d\n X-Bad: folded\x0d\n\x0d\n".toUTF8 - let responseB ← sendRaw clientB serverB leadingWS bodyHandler - assertExact responseB bad400 - - let (clientC, serverC) ← Mock.new - let spaceName := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n3\x0d\nabc\x0d\n0\x0d\nBad Name: value\x0d\n\x0d\n".toUTF8 - let responseC ← sendRaw clientC serverC spaceName bodyHandler - assertExact responseC bad400 - --- Trailer byte-level validation. -#eval show IO _ from do - let (clientA, serverA) ← Mock.new - let beforeName := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n3\x0d\nabc\x0d\n0\x0d\nX-Bad".toUTF8 - let afterName := "Name: value\x0d\n\x0d\n".toUTF8 - let responseA ← sendRaw clientA serverA (beforeName ++ ByteArray.mk #[0] ++ afterName) bodyHandler - assertExact responseA bad400 - - let (clientB, serverB) ← Mock.new - let beforeValue := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n3\x0d\nabc\x0d\n0\x0d\nX-Header: bad".toUTF8 - let afterValue := "value\x0d\n\x0d\n".toUTF8 - let responseB ← sendRaw clientB serverB (beforeValue ++ ByteArray.mk #[0] ++ afterValue) bodyHandler - assertExact responseB bad400 - - let (clientC, serverC) ← Mock.new - let responseC ← sendRaw clientC serverC (beforeValue ++ ByteArray.mk #[0x01] ++ afterValue) bodyHandler - assertExact responseC bad400 - --- Incomplete trailer section with client close yields no response bytes. -#eval show IO _ from do - let (client, server) ← Mock.new - let raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n3\x0d\nabc\x0d\n0\x0d\nX-Trailer: value\x0d\n".toUTF8 - let response ← sendRawAndClose client server raw bodyHandler - assert! response.size == 0 - --- Trailer encoding emits terminal chunk plus trailer headers. -#eval show IO _ from Async.block do - let trailer := Trailer.empty - |>.insert (.mk "checksum") (.mk "abc123") - |>.insert (.mk "expires") (.mk "Thu, 01 Dec 1994") - let encoded := Encode.encode (v := .v11) ByteArray.empty trailer - let text := String.fromUTF8! encoded - assert! text.contains "0\x0d\n" - assert! text.contains "Checksum: abc123\x0d\n" - assert! text.contains "Expires: Thu, 01 Dec 1994\x0d\n" - --- Empty trailer encoding is exactly terminal chunk CRLF CRLF. -#eval show IO _ from Async.block do - let encoded := Encode.encode (v := .v11) ByteArray.empty Trailer.empty - let text := String.fromUTF8! encoded - assert! text == "0\x0d\n\x0d\n" - --- Trailer injection: forbidden field names must be rejected (RFC 9112 §6.5). --- A client injecting framing or routing fields via trailers could confuse proxies. -#eval show IO _ from do - -- content-length in trailer must be rejected - let (clientA, serverA) ← Mock.new - let rawA := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\nContent-Length: 1000\x0d\n\x0d\n".toUTF8 - let responseA ← sendRaw clientA serverA rawA bodyHandler - assertExact responseA bad400 - - -- transfer-encoding in trailer must be rejected - let (clientB, serverB) ← Mock.new - let rawB := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\nTransfer-Encoding: chunked\x0d\n\x0d\n".toUTF8 - let responseB ← sendRaw clientB serverB rawB bodyHandler - assertExact responseB bad400 - - -- host in trailer must be rejected - let (clientC, serverC) ← Mock.new - let rawC := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\nHost: evil.example\x0d\n\x0d\n".toUTF8 - let responseC ← sendRaw clientC serverC rawC bodyHandler - assertExact responseC bad400 - - -- connection in trailer must be rejected - let (clientD, serverD) ← Mock.new - let rawD := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\nConnection: keep-alive\x0d\n\x0d\n".toUTF8 - let responseD ← sendRaw clientD serverD rawD bodyHandler - assertExact responseD bad400 - - -- authorization in trailer must be rejected - let (clientE, serverE) ← Mock.new - let rawE := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\nAuthorization: Bearer token\x0d\n\x0d\n".toUTF8 - let responseE ← sendRaw clientE serverE rawE bodyHandler - assertExact responseE bad400 - - -- cache-control in trailer must be rejected - let (clientF, serverF) ← Mock.new - let rawF := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\nCache-Control: no-cache\x0d\n\x0d\n".toUTF8 - let responseF ← sendRaw clientF serverF rawF bodyHandler - assertExact responseF bad400 - - -- te in trailer must be rejected - let (clientG, serverG) ← Mock.new - let rawG := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\nTE: trailers\x0d\n\x0d\n".toUTF8 - let responseG ← sendRaw clientG serverG rawG bodyHandler - assertExact responseG bad400 - --- Forbidden trailer field names are rejected regardless of case. -#eval show IO _ from do - let (clientA, serverA) ← Mock.new - let rawA := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\nCONTENT-LENGTH: 0\x0d\n\x0d\n".toUTF8 - let responseA ← sendRaw clientA serverA rawA bodyHandler - assertExact responseA bad400 - - let (clientB, serverB) ← Mock.new - let rawB := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\nContent-Length: 0\x0d\nChecksum: abc\x0d\n\x0d\n".toUTF8 - let responseB ← sendRaw clientB serverB rawB bodyHandler - assertExact responseB bad400 - --- Non-forbidden custom trailers are still allowed after the fix. -#eval show IO _ from do - let (client, server) ← Mock.new - let raw := "POST / HTTP/1.1\x0d\nHost: example.com\x0d\nTransfer-Encoding: chunked\x0d\nConnection: close\x0d\n\x0d\n5\x0d\nhello\x0d\n0\x0d\nChecksum: deadbeef\x0d\nX-Timing: 12ms\x0d\n\x0d\n".toUTF8 - let response ← sendRaw client server raw bodyHandler - assertStatus response "HTTP/1.1 200" - assertContains response "hello"
diff --git a/tests/async/elab/async_http_uri.lean b/tests/async/elab/async_http_uri.lean deleted file mode 100644 index 6e94610..0000000 --- a/tests/async/elab/async_http_uri.lean +++ /dev/null
@@ -1,1334 +0,0 @@ -/- -Copyright (c) 2025 Lean FRO, LLC. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Sofia Rodrigues --/ -import Std.Http.Data.URI -import Std.Http.Data.URI.Encoding - -open Std.Http -open Std.Http.URI -open Std.Http.URI.Parser - -/-! -# URI Tests - -Comprehensive tests for URI parsing, encoding, normalization, and manipulation. -This file consolidates tests from multiple URI-related test files. --/ - --- ============================================================================ --- Helper Functions --- ============================================================================ - -def runParser (parser : Std.Internal.Parsec.ByteArray.Parser α) (s : String) : IO α := - IO.ofExcept ((parser <* Std.Internal.Parsec.eof).run s.toUTF8) - -def parseCheck (s : String) (exact : String := s) : IO Unit := do - let result ← runParser parseRequestTarget s - if toString result = exact then - pure () - else - throw (.userError s!"expect {exact.quote} but got {(toString result).quote}") - -def parseCheckFail (s : String) : IO Unit := do - match (parseRequestTarget <* Std.Internal.Parsec.eof).run s.toUTF8 with - | .ok r => - throw <| .userError - s!"expected parse failure, but succeeded with {(repr r)}" - | .error _ => - pure () - --- ============================================================================ --- Percent Encoding Tests (EncodedString) --- ============================================================================ - --- Valid percent encoding validation -/-- -info: some "abc" --/ -#guard_msgs in -#eval IO.println (repr (EncodedSegment.ofByteArray? "abc".toUTF8)) - -/-- -info: some "%20" --/ -#guard_msgs in -#eval IO.println (repr (EncodedSegment.ofByteArray? "%20".toUTF8)) - -/-- -info: some "hello%20world" --/ -#guard_msgs in -#eval IO.println (repr (EncodedSegment.ofByteArray? "hello%20world".toUTF8)) - -/-- -info: some "%FF" --/ -#guard_msgs in -#eval IO.println (repr (EncodedSegment.ofByteArray? "%FF".toUTF8)) - -/-- -info: some "%00" --/ -#guard_msgs in -#eval IO.println (repr (EncodedSegment.ofByteArray? "%00".toUTF8)) - --- Invalid percent encoding: incomplete -/-- -info: none --/ -#guard_msgs in -#eval IO.println (repr (EncodedSegment.ofByteArray? "%".toUTF8)) - -/-- -info: none --/ -#guard_msgs in -#eval IO.println (repr (EncodedSegment.ofByteArray? "hello%".toUTF8)) - -/-- -info: none --/ -#guard_msgs in -#eval IO.println (repr (EncodedSegment.ofByteArray? "%2".toUTF8)) - -/-- -info: none --/ -#guard_msgs in -#eval IO.println (repr (EncodedSegment.ofByteArray? "%A".toUTF8)) - --- Invalid percent encoding: non-hex characters -/-- -info: none --/ -#guard_msgs in -#eval IO.println (repr (EncodedSegment.ofByteArray? "%GG".toUTF8)) - -/-- -info: none --/ -#guard_msgs in -#eval IO.println (repr (EncodedSegment.ofByteArray? "%2G".toUTF8)) - -/-- -info: none --/ -#guard_msgs in -#eval IO.println (repr (EncodedSegment.ofByteArray? "%G2".toUTF8)) - --- ============================================================================ --- Percent Encoding Decode Tests --- ============================================================================ - -/-- -info: some "abc" --/ -#guard_msgs in -#eval IO.println (repr <| EncodedSegment.decode =<< (EncodedSegment.ofByteArray? "abc".toUTF8)) - -/-- -info: some " " --/ -#guard_msgs in -#eval IO.println (repr <| EncodedSegment.decode =<< (EncodedSegment.ofByteArray? "%20".toUTF8)) - -/-- -info: some "hello world" --/ -#guard_msgs in -#eval IO.println (repr <| EncodedSegment.decode =<< (EncodedSegment.ofByteArray? "hello%20world".toUTF8)) - -/-- -info: some " !" --/ -#guard_msgs in -#eval IO.println (repr <| EncodedSegment.decode =<< (EncodedSegment.ofByteArray? "%20%21".toUTF8)) - -/-- -info: none --/ -#guard_msgs in -#eval IO.println (repr <| EncodedSegment.decode =<< (EncodedSegment.ofByteArray? "%FF".toUTF8)) - -/-- -info: some "\x00" --/ -#guard_msgs in -#eval IO.println (repr <| EncodedSegment.decode =<< (EncodedSegment.ofByteArray? "%00".toUTF8)) - --- ============================================================================ --- Query String Encoding Tests --- ============================================================================ - -/-- -info: some "hello+world" --/ -#guard_msgs in -#eval IO.println (repr (EncodedQueryString.ofByteArray? "hello+world".toUTF8)) - -/-- -info: none --/ -#guard_msgs in -#eval IO.println (repr (EncodedQueryString.ofByteArray? "%".toUTF8)) - -/-- -info: some "hello world" --/ -#guard_msgs in -#eval IO.println (repr <| EncodedQueryString.decode =<< (EncodedQueryString.ofByteArray? "hello+world".toUTF8)) - -/-- -info: some " " --/ -#guard_msgs in -#eval IO.println (repr <| EncodedQueryString.decode =<< (EncodedQueryString.ofByteArray? "%20".toUTF8)) - --- ============================================================================ --- Request Target Parsing - Basic Tests --- ============================================================================ - -#eval parseCheck "///path/with/encoded%20space" -#eval parseCheck "/path/with/encoded%20space" -#eval parseCheck "/path/with/encoded%20space/" -#eval parseCheck "*" -#eval parseCheck "/api/search?q=hello%20world&category=tech%2Bgames" -#eval parseCheck "/" -#eval parseCheck "/api/v1/users/123/posts/456/comments/789" -#eval parseCheck "/files/../etc/passwd" -#eval parseCheck "example.com:8080" -#eval parseCheck "https://example.com:8080/ata" -#eval parseCheck "https://example.com:8080////./ata" -#eval parseCheck "192.168.1.1:3000" -#eval parseCheck "[::1]:8080" -#eval parseCheck "http://example.com/path/to/resource?query=value" -#eval parseCheck "https://api.example.com:443/v1/users?limit=10" -#eval parseCheck "http://[2001:db8::1]:8080/path" -#eval parseCheck "https://xn--nxasmq6b.xn--o3cw4h/path" -#eval parseCheck "http://exa_mple.com/path" -#eval parseCheck "localhost:65535" -#eval parseCheck "http:80" --- A request-target is printed without userinfo (RFC 9110 §4.2.4). -#eval parseCheck "https://user:pass@secure.example.com/private" "https://secure.example.com/private" -#eval parseCheck "/double//slash//path" -#eval parseCheck "http://user%40example:pass%3Aword@host.com" "http://host.com" -#eval parseCheck "http://[::ffff:192.168.1.1]/path" -#eval parseCheck "http://example.com:/" -#eval parseCheck "http://example.com:/?q=1" -#eval parseCheck "///////" - --- `&` in a key must be percent-encoded so toRawString round-trips correctly. -#guard - let query := URI.Query.empty.insert "a&b" "1" - query.toRawString == "a%26b=1" - --- `=` in a key must be percent-encoded so re-parsing preserves the key. -#guard - let query := URI.Query.empty.insert "a=b" "1" - query.toRawString == "a%3Db=1" - --- `&` in a value must be percent-encoded. -#guard - let query := URI.Query.empty.insert "key" "a&b" - query.toRawString == "key=a%26b" - --- `=` in a value is technically safe (parser uses first `=`), but encoding it --- is still correct and keeps representation unambiguous. -#guard - let query := URI.Query.empty.insert "key" "a=b" - query.toRawString == "key=a%3Db" - --- Round-trip: insert → toRawString → re-parse should preserve the parameter. -#guard - let original := URI.Query.empty.insert "a&b" "c=d" - let raw := original.toRawString - -- Parse via a synthetic origin-form request target - match (URI.Parser.parseRequestTarget <* Std.Internal.Parsec.eof).run - s!"/path?{raw}".toUTF8 with - | .ok result => - (result.query.get "a&b" == some "c=d") - | .error _ => false - -#guard - match (parseRequestTarget <* Std.Internal.Parsec.eof).run "http:80".toUTF8 with - | .ok (.authorityForm _) => true - | _ => false - --- Parse failure tests -#eval parseCheckFail "/path with space" -#eval parseCheckFail "/path/%" -#eval parseCheckFail "/path/%2" -#eval parseCheckFail "/path/%ZZ" -#eval parseCheckFail "" -#eval parseCheckFail "[::1" -#eval parseCheckFail "[:::1]:80" -#eval parseCheckFail "http://-example.com/path" -#eval parseCheckFail "http://[fe80::1%25eth0]/path" -#eval parseCheckFail "#frag" -#eval parseCheckFail "/path/\n" -#eval parseCheckFail "/path/\u0000" -#eval parseCheckFail "/page#section" -#eval parseCheckFail "/api/v1/users/[id]:action" - --- maxPathSegments should apply to trailing empty segments as well. -#guard - match (parseURI { maxPathSegments := 1 } <* Std.Internal.Parsec.eof).run - "http://example.com/a/".toUTF8 with - | .error _ => true - | .ok _ => false - --- ============================================================================ --- Request Target Parsing - Detailed Output Tests --- ============================================================================ - -/-- -info: Std.Http.RequestTarget.originForm { segments := #["path", "with", "encoded%20space"], absolute := true } none --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "/path/with/encoded%20space" - IO.println (repr result) - -/-- -info: Std.Http.RequestTarget.originForm { segments := #["", "", "path", "with", "encoded%20space"], absolute := true } none --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "///path/with/encoded%20space" - IO.println (repr result) - -/-- -info: Std.Http.RequestTarget.asteriskForm --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "*" - IO.println (repr result) - -/-- -info: #[("q", some "hello%20world"), ("category", some "tech%2Bgames")] --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "/api/search?q=hello%20world&category=tech%2Bgames" - IO.println (repr result.query) - -/-- -info: Std.Http.RequestTarget.originForm { segments := #[], absolute := true } none --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "/" - IO.println (repr result) - -/-- -info: Std.Http.RequestTarget.authorityForm - { userInfo := none, host := Std.Http.URI.Host.name "example.com", port := Std.Http.URI.Port.value 8080 } --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "example.com:8080" - IO.println (repr result) - -/-- -info: Std.Http.RequestTarget.authorityForm - { userInfo := none, host := Std.Http.URI.Host.ipv4 192.168.1.1, port := Std.Http.URI.Port.value 3000 } --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "192.168.1.1:3000" - IO.println (repr result) - --- A host that begins with an IPv4 address and goes on is a name. -/-- -info: Std.Http.RequestTarget.authorityForm - { userInfo := none, host := Std.Http.URI.Host.name "1.2.3.4-x.example", port := Std.Http.URI.Port.value 443 } --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "1.2.3.4-x.example:443" - IO.println (repr result) - -#guard - match (parseRequestTarget <* Std.Internal.Parsec.eof).run "http://1.2.3.4x.example/".toUTF8 with - | .ok (.absoluteForm uri) => uri.authority.any fun a => toString a.host == "1.2.3.4x.example" - | _ => false - -#guard - match (parseHostHeader <* Std.Internal.Parsec.eof).run "1.2.3.4-x.example:8080".toUTF8 with - | .ok (host, port) => toString host == "1.2.3.4-x.example" && port == .value 8080 - | .error _ => false - -#guard - match (parseHostHeader <* Std.Internal.Parsec.eof).run "1.2.3.4".toUTF8 with - | .ok (.ipv4 _, .omitted) => true - | _ => false - -/-- -info: Std.Http.RequestTarget.authorityForm - { userInfo := none, host := Std.Http.URI.Host.ipv6 ::1, port := Std.Http.URI.Port.value 8080 } --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "[::1]:8080" - IO.println (repr result) - -/-- -info: Std.Http.RequestTarget.absoluteForm - { scheme := "https", - authority := some { userInfo := none, - host := Std.Http.URI.Host.name "example.com", - port := Std.Http.URI.Port.value 8080 }, - path := { segments := #["ata"], absolute := true }, - query := none, - fragment := none } --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "https://example.com:8080/ata" - IO.println (repr result) - -/-- -info: Std.Http.RequestTarget.absoluteForm - { scheme := "http", - authority := some { userInfo := none, - host := Std.Http.URI.Host.ipv6 2001:db8::1, - port := Std.Http.URI.Port.value 8080 }, - path := { segments := #["path"], absolute := true }, - query := none, - fragment := none } --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "http://[2001:db8::1]:8080/path" - IO.println (repr result) - -/-- -info: Std.Http.RequestTarget.absoluteForm - { scheme := "https", - authority := some { userInfo := some { username := "user%20b", password := some "pass" }, - host := Std.Http.URI.Host.name "secure.example.com", - port := Std.Http.URI.Port.omitted }, - path := { segments := #["private"], absolute := true }, - query := none, - fragment := none } --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "https://user%20b:pass@secure.example.com/private" - IO.println (repr result) - --- ============================================================================ --- IPv6 Host Tests --- ============================================================================ - -/-- -info: Std.Http.URI.Host.ipv6 ::1 --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "[::1]:8080" - match result.authority? with - | some auth => IO.println (repr auth.host) - | none => IO.println "no authority" - -/-- -info: Std.Http.URI.Host.ipv6 2001:db8::8a2e:370:7334 --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "http://[2001:db8::8a2e:370:7334]:8080/api" - match result.authority? with - | some auth => IO.println (repr auth.host) - | none => IO.println "no authority" - -/-- -info: Std.Http.URI.Host.ipv6 :: --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "http://[::]/path" - match result.authority? with - | some auth => IO.println (repr auth.host) - | none => IO.println "no authority" - --- ============================================================================ --- UserInfo Tests --- ============================================================================ - -/-- -info: some { username := "user", password := some "pass" } --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "https://user:pass@example.com/private" - match result.authority? with - | some auth => IO.println (repr auth.userInfo) - | none => IO.println "no authority" - -/-- -info: some { username := "user%20only", password := none } --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "https://user%20only@example.com/path" - match result.authority? with - | some auth => IO.println (repr auth.userInfo) - | none => IO.println "no authority" - -/-- -info: some { username := "", password := some "pass" } --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "https://:pass@example.com/path" - match result.authority? with - | some auth => IO.println (repr auth.userInfo) - | none => IO.println "no authority" - -/-- -info: some { username := "user", password := some "p%40ss%3Aw0rd" } --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "https://user:p%40ss%3Aw0rd@example.com/" - match result.authority? with - | some auth => IO.println (repr auth.userInfo) - | none => IO.println "no authority" - --- ============================================================================ --- Path.normalize Tests (RFC 3986 Section 5.2.4) --- ============================================================================ - -/-- -info: /a/b --/ -#guard_msgs in -#eval IO.println <| toString (URI.parse! "http://example.com/a/./b").path.normalize - --- RFC 3986 §5.2.4 step 2B replaces a trailing `/..` with `/`, so the result still names a --- collection. -/-- -info: /a/ --/ -#guard_msgs in -#eval IO.println (URI.parse! "http://example.com/a/b/..").path.normalize - -/-- -info: /a/g --/ -#guard_msgs in -#eval IO.println (URI.parse! "http://example.com/a/b/c/./../../g").path.normalize - -/-- -info: /g --/ -#guard_msgs in -#eval IO.println (URI.parse! "http://example.com/../../../g").path.normalize - -/-- -info: /a/c --/ -#guard_msgs in -#eval IO.println (URI.parse! "http://example.com/a/b/../c").path.normalize - -/-- -info: /a/ --/ -#guard_msgs in -#eval IO.println (URI.parse! "http://example.com/a/b/c/../.././").path.normalize - -/-- -info: / --/ -#guard_msgs in -#eval IO.println (URI.parse! "http://example.com/a/b/../../..").path.normalize - -/-- -info: / --/ -#guard_msgs in -#eval IO.println (URI.parse! "http://example.com/../../../").path.normalize - --- Likewise for a trailing `/.` (RFC 3986 §5.2.4 step 2C). -/-- -info: /a/b/c/ --/ -#guard_msgs in -#eval IO.println (URI.parse! "http://example.com/./a/./b/./c/.").path.normalize - -/-- -info: /c --/ -#guard_msgs in -#eval IO.println (URI.parse! "http://example.com/a/../b/../c").path.normalize - --- ============================================================================ --- Path.parent Tests --- ============================================================================ - -/-- -info: /a/b --/ -#guard_msgs in -#eval IO.println (URI.parse! "http://example.com/a/b/c").path.parent - -/-- -info: /a --/ -#guard_msgs in -#eval IO.println (URI.parse! "http://example.com/a/b").path.parent - -/-- -info: / --/ -#guard_msgs in -#eval IO.println (URI.parse! "http://example.com/a").path.parent - -/-- -info: / --/ -#guard_msgs in -#eval IO.println (URI.parse! "http://example.com/").path.parent - --- ============================================================================ --- Path.join Tests --- ============================================================================ - -/-- -info: /a/b/c/d --/ -#guard_msgs in -#eval do - let p1 := (URI.parse! "http://example.com/a/b").path - let p2 : URI.Path := { segments := #[URI.EncodedString.encode "c", URI.EncodedString.encode "d"], absolute := false } - IO.println (p1.join p2) - -/-- -info: /x/y --/ -#guard_msgs in -#eval do - let p1 := (URI.parse! "http://example.com/a/b").path - let p2 : URI.Path := { segments := #[URI.EncodedString.encode "x", URI.EncodedString.encode "y"], absolute := true } - IO.println (p1.join p2) - --- ============================================================================ --- Path.isEmpty Tests --- ============================================================================ - -#guard (URI.parse! "http://example.com").path.isEmpty = true -#guard (URI.parse! "http://example.com/").path.absolute = true -#guard (URI.parse! "http://example.com/a").path.isEmpty = false -#guard (URI.parse! "http://example.com/a").path.absolute = true - --- ============================================================================ --- URI Modification Helpers --- ============================================================================ - -#guard ((URI.parse! "http://example.com").withScheme! "htTps" |>.scheme) == "https" -#guard ((URI.parse! "http://example.com").withScheme! "ftP" |>.scheme) == "ftp" - -/-- -info: http://example.com/#section1 --/ -#guard_msgs in -#eval IO.println ((URI.parse! "http://example.com/").withFragment (some (toString (URI.EncodedString.encode "section1" : URI.EncodedFragment)))) - -/-- -info: http://example.com/?key=value --/ -#guard_msgs in -#eval do - let uri := URI.parse! "http://example.com/" - let query := URI.Query.empty.insert "key" "value" - IO.println (uri.withQuery query) - -/-- -info: http://example.com/new/path --/ -#guard_msgs in -#eval do - let uri := URI.parse! "http://example.com/old/path" - let newPath : URI.Path := { segments := #[URI.EncodedString.encode "new", URI.EncodedString.encode "path"], absolute := true } - IO.println (uri.withPath newPath) - --- ============================================================================ --- URI.normalize Tests (RFC 3986 Section 6) --- ============================================================================ - -#guard (URI.parse! "HTTP://example.com").normalize.scheme == "http" -#guard (URI.parse! "HtTpS://example.com").normalize.scheme == "https" - -/-- -info: http://example.com/ --/ -#guard_msgs in -#eval IO.println (URI.parse! "http://EXAMPLE.COM/").normalize - -/-- -info: http://example.com/ --/ -#guard_msgs in -#eval IO.println (URI.parse! "HTTP://Example.COM/").normalize - -/-- -info: http://example.com/a/c --/ -#guard_msgs in -#eval IO.println (URI.parse! "http://example.com/a/b/../c").normalize - -/-- -info: http://example.com/a/g --/ -#guard_msgs in -#eval IO.println (URI.parse! "HTTP://EXAMPLE.COM/a/b/c/./../../g").normalize - -/-- -info: https://www.example.com/PATH --/ -#guard_msgs in -#eval IO.println (URI.parse! "HTTPS://WWW.EXAMPLE.COM/PATH").normalize - --- ============================================================================ --- Query Parameter Tests --- ============================================================================ - --- Query with duplicate keys -/-- -info: 3 --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "/search?tag=a&tag=b&tag=c" - let all := result.query.findAll "tag" - IO.println all.size - -/-- -info: #[some "a", some "b", some "c"] --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "/search?tag=a&tag=b&tag=c" - let all := result.query.findAll "tag" - IO.println (repr all) - -/-- -info: some (some "a") --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "/search?key=a&key=b&key=c" - IO.println (repr (result.query.find? "key")) - --- Empty value vs no value -/-- -info: some (some "") --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "/api?key=" - IO.println (repr (result.query.find? "key")) - -/-- -info: some none --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "/api?key" - IO.println (repr (result.query.find? "key")) - -/-- -info: some (some "value") --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "/api?key=value" - IO.println (repr (result.query.find? "key")) - --- `String`-keyed lookups match every spelling of a name; `*Encoded` lookups match exact bytes. -#guard - match (parseRequestTarget <* Std.Internal.Parsec.eof).run "/api?%61=1&a=2".toUTF8 with - | .ok result => - let encodedA? := EncodedQueryParam.fromString? "%61" - ((result.query.find? "a" |>.bind id |>.bind EncodedQueryParam.decode) == some "1") && - (result.query.findAll "a").size == 2 && - (result.query.find? "%61").isNone && - result.query.contains "a" && - !result.query.contains "%61" && - (match encodedA? with - | some encodedA => - ((result.query.findEncoded? encodedA |>.bind id |>.bind EncodedQueryParam.decode) == some "1") && - result.query.containsEncoded encodedA - | none => false) - | .error _ => false - -#guard - match (parseRequestTarget <* Std.Internal.Parsec.eof).run "/api?%61=1&a=2".toUTF8 with - | .ok result => - match EncodedQueryParam.fromString? "%61" with - | some encodedA => - let erasedRaw := result.query.erase "a" - let erasedEncoded := result.query.eraseEncoded encodedA - !erasedRaw.contains "a" && - !erasedRaw.containsEncoded encodedA && - !erasedEncoded.containsEncoded encodedA && - erasedEncoded.contains "a" - | none => false - | .error _ => false - --- ============================================================================ --- Query Operations --- ============================================================================ - --- #14934: a name a browser percent-encodes is found by its decoded spelling. -def browserQuery : URI.Query := - match EncodedQueryParam.fromString? "a%3Ab", EncodedQueryParam.fromString? "on" with - | some k, some v => URI.Query.empty.insertEncoded k (some v) - | _, _ => URI.Query.empty - -#guard browserQuery.get "a:b" == some "on" -#guard browserQuery.getD "a:b" "off" == "on" -#guard browserQuery.contains "a:b" -#guard (browserQuery.findAll "a:b").size == 1 -#guard !browserQuery.contains "a%3Ab" -#guard (browserQuery.erase "a:b").isEmpty -#guard toString (browserQuery.set "a:b" "off") == "?a:b=off" -#guard - match (parseRequestTarget <* Std.Internal.Parsec.eof).run "/consent?a%3Ab=on".toUTF8 with - | .ok result => result.query.get "a:b" == some "on" - | .error _ => false -#guard (URI.parse? "https://example.com/consent?a%3Ab=on").bind (·.query.bind (·.get "a:b")) == some "on" - -#guard (URI.Query.empty.insert "a" "1" |>.contains "a") = true -#guard (URI.Query.empty.contains "nonexistent") = false - -/-- -info: a=1&b=2 --/ -#guard_msgs in -#eval do - let query := URI.Query.empty - |>.insert "a" "1" - |>.insert "b" "2" - IO.println query.toRawString - -/-- -info: b=2 --/ -#guard_msgs in -#eval do - let query := URI.Query.empty - |>.insert "a" "1" - |>.insert "b" "2" - |>.erase "a" - IO.println query.toRawString - -/-- -info: key=new --/ -#guard_msgs in -#eval do - let query := URI.Query.empty - |>.insert "key" "old" - |>.set "key" "new" - IO.println query.toRawString - --- ============================================================================ --- URI Builder Tests --- ============================================================================ - --- Domain names longer than 255 characters are rejected. -#guard - let label := String.ofList (List.replicate 63 'a') - let longDomain := s!"{label}.{label}.{label}.{label}." - (URI.DomainName.ofString? longDomain).isNone - -#guard - let label := String.ofList (List.replicate 63 'a') - let longDomain := s!"{label}.{label}.{label}.{label}." - (URI.Builder.empty.setHost? longDomain).isNone - -/-- -info: https://example.com/api/users?page=1 --/ -#guard_msgs in -#eval do - let uri := URI.Builder.empty - |>.setScheme! "https" - |>.setHost! "example.com" - |>.appendPathSegment "api" - |>.appendPathSegment "users" - |>.addQueryParam "page" "1" - |>.build - IO.println uri - -/-- -info: http://localhost:8080/ --/ -#guard_msgs in -#eval do - let uri := URI.Builder.empty - |>.setScheme! "http" - |>.setHost! "localhost" - |>.setPort 8080 - |>.build - IO.println uri - -/-- -info: https://user:pass@secure.example.com/private --/ -#guard_msgs in -#eval do - let uri := URI.Builder.empty - |>.setScheme! "https" - |>.setUserInfo "user" (some "pass") - |>.setHost! "secure.example.com" - |>.appendPathSegment "private" - |>.build - IO.println uri - --- ============================================================================ --- Encoded Path Segment Tests --- ============================================================================ - -/-- -info: Std.Http.RequestTarget.originForm { segments := #["path%2Fwith%2Fslashes"], absolute := true } none --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "/path%2Fwith%2Fslashes" - IO.println (repr result) - -/-- -info: Std.Http.RequestTarget.originForm { segments := #["file%20name.txt"], absolute := true } none --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "/file%20name.txt" - IO.println (repr result) - -/-- -info: Std.Http.RequestTarget.originForm { segments := #["caf%C3%A9"], absolute := true } none --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "/caf%C3%A9" - IO.println (repr result) - --- ============================================================================ --- Authority Form Tests --- ============================================================================ - -/-- -info: Std.Http.RequestTarget.authorityForm - { userInfo := none, host := Std.Http.URI.Host.name "proxy.example.com", port := Std.Http.URI.Port.value 3128 } --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "proxy.example.com:3128" - IO.println (repr result) - -/-- -info: Std.Http.RequestTarget.authorityForm - { userInfo := none, host := Std.Http.URI.Host.ipv4 127.0.0.1, port := Std.Http.URI.Port.value 8080 } --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "127.0.0.1:8080" - IO.println (repr result) - -/-- -info: Std.Http.RequestTarget.authorityForm - { userInfo := none, host := Std.Http.URI.Host.name "1example.com", port := Std.Http.URI.Port.value 8080 } --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "1example.com:8080" - IO.println (repr result) - -/-- -info: Std.Http.RequestTarget.absoluteForm - { scheme := "http", - authority := some { userInfo := none, - host := Std.Http.URI.Host.name "1example.com", - port := Std.Http.URI.Port.omitted }, - path := { segments := #["path"], absolute := true }, - query := none, - fragment := none } --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "http://1example.com/path" - IO.println (repr result) - -/-- -info: Std.Http.RequestTarget.absoluteForm - { scheme := "http", - authority := some { userInfo := none, - host := Std.Http.URI.Host.name "123abc.example.com", - port := Std.Http.URI.Port.omitted }, - path := { segments := #["page"], absolute := true }, - query := none, - fragment := none } --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "http://123abc.example.com/page" - IO.println (repr result) - --- parseScheme: first byte uses `satisfy isAlphaByte` (not `takeWhile1AtMost`). --- Schemes that start with a non-alpha byte must be rejected. -#eval parseCheckFail "1http://example.com/path" -#eval parseCheckFail "+http://example.com/path" -#eval parseCheckFail "-http://example.com/path" -#eval parseCheckFail ".http://example.com/path" - --- Scheme body allows '+', '-', '.'. -#eval parseCheck "coap+tcp://example.com/path" -#eval parseCheck "svn+ssh://example.com/path" -#eval parseCheck "my.scheme://example.com/path" -#eval parseCheck "a-b://example.com/path" - --- Single-letter scheme is valid. -#eval parseCheck "a://example.com/path" - --- parsePortNumber now uses `takeWhileAtMost` (succeeds at EOF) instead of --- `takeWhileUpTo1` (would fail with .eof). Verify a port at the very end of --- the input still parses correctly. -#guard - match (parseRequestTarget <* Std.Internal.Parsec.eof).run "example.com:8080".toUTF8 with - | .ok (.authorityForm auth) => auth.port == .value 8080 - | _ => false - --- Port 0 is technically valid (toNat? succeeds). -#guard - match (parseRequestTarget <* Std.Internal.Parsec.eof).run "example.com:0".toUTF8 with - | .ok (.authorityForm auth) => auth.port == .value 0 - | _ => false - --- Port > 65535 must be rejected. Use an unambiguous authority URL so the --- number is definitely parsed as a port, not as a path segment. -#eval parseCheckFail "http://example.com:65536/path" -#eval parseCheckFail "http://example.com:99999/path" - --- parseQuery now uses `split '&'` instead of `splitOn "&"`. --- A trailing `&` is accepted and produces an empty-key entry; it is not a --- parse failure. -#guard - match (parseRequestTarget <* Std.Internal.Parsec.eof).run "/path?key=val&".toUTF8 with - | .ok result => result.query.size == 2 - | .error _ => false - --- A value may contain an unencoded `=`: the name ends at the first `=` (#16021). -/-- -info: some (some "a=b") --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "/path?key=a=b" - IO.println (repr (result.query.find? "key")) - --- A percent-encoded `=` in the value is fine; `%3D` is preserved as-is in --- the EncodedQueryParam. -/-- -info: some (some "a%3Db") --/ -#guard_msgs in -#eval show IO _ from do - let result ← runParser parseRequestTarget "/path?key=a%3Db" - IO.println (repr (result.query.find? "key")) - --- IPv4/IPv6 parsing now uses `takeWhile1AtMost` (still requires ≥1 byte). --- Both types continue to work at the very end of the input. -#guard - match (parseRequestTarget <* Std.Internal.Parsec.eof).run "192.168.0.1:80".toUTF8 with - | .ok (.authorityForm auth) => toString auth.host == "192.168.0.1" - | _ => false - -#guard - match (parseRequestTarget <* Std.Internal.Parsec.eof).run "http://[::1]/".toUTF8 with - | .ok (.absoluteForm uri) => uri.authority.any fun a => match a.host with | .ipv6 _ => true | _ => false - | _ => false - --- RFC 3986 §3.2 allows an empty reg-name, so `file:///path` (empty authority) --- must parse as an absolute URI, not fall back to a relative reference. --- This ensures the non-http(s) scheme guard in redirect logic fires correctly. -#guard - match URIReference.parse? "file:///etc/passwd" with - | some (.absolute af) => af.scheme.val == "file" && af.authority.isNone - | _ => false - --- `none` means no query delimiter, while `some .empty` means an explicit empty query. -#guard (URI.parse! "http://example.com/path").query.isNone - -#guard - match (URI.parse! "http://example.com/path?").query with - | some q => q.isEmpty && toString (URI.parse! "http://example.com/path?") == "http://example.com/path?" - | none => false - -#guard - match RequestTarget.parse? "/path?" with - | some (.originForm _ (some q)) => q.isEmpty && toString (RequestTarget.parse! "/path?") == "/path?" - | _ => false - -#guard - match URIReference.parse? "?" with - | some (.relative ref) => ref.query.isSome && toString (URIReference.parse! "?") == "?" - | _ => false - -#guard - match URIReference.parse? "#frag" with - | some (.relative ref) => ref.query.isNone && toString (URIReference.parse! "#frag") == "#frag" - | _ => false - --- ============================================================================ --- Hosts --- ============================================================================ - -private def hostOf (s : String) : Option URI.Host := - (URI.parse? s).bind (·.host?) - --- A percent-encoded registered name is decoded (RFC 3986 §3.2.2, §6.2.2.2). -#guard (hostOf "http://ex%41mple.com/").map toString == some "example.com" - --- The host is an IPv4 address only when the whole decoded host is one, so a percent-encoded address --- is that address, and printing it and parsing it again gives the same host. -#guard - match hostOf "http://127.0.0.%31/" with - | some (.ipv4 addr) => toString addr == "127.0.0.1" - | _ => false - -#guard - match URI.parse? "http://%31%32%37.0.0.1/" with - | some u => (URI.parse? (toString u)).bind (·.host?) == u.host? - | none => false - --- `_` is a reg-name character; container service names use it. A dotted quad followed by `_svc` is --- a name, not an address with trailing bytes. -#guard (hostOf "http://_svc.local/").map toString == some "_svc.local" -#guard - match hostOf "http://10.0.0.1_svc/" with - | some (.name n) => toString n == "10.0.0.1_svc" - | _ => false - --- A fully qualified name ends in a single `.`, which adds no label. -#guard (URI.DomainName.ofString? "example.com.").isSome -#guard (hostOf "http://example.com./").map toString == some "example.com." -#guard (URI.DomainName.ofString? "example.com..").isNone - --- The system resolver reads a name whose last label is a number as an IPv4 address in shorthand --- (`127.1` is `127.0.0.1`), so such a name is not a domain name. -#eval show IO Unit from do - for host in ["127.1", "2130706433", "0x7f.0.0.1", "1.2.3", "example.0x1F", "127.1."] do - if let some u := URI.parse? s!"http://{host}/" then - throw <| IO.userError s!"http://{host}/ parsed with host {repr u.host?}" - if (URI.DomainName.ofString? host).isSome then - throw <| IO.userError s!"{host} is accepted as a domain name" - for host in ["1.example", "example.com1", "a.b1c", "0x1g"] do - unless hostOf s!"http://{host}/" matches some (.name _) do - throw <| IO.userError s!"http://{host}/ does not parse with a domain name host" - --- ============================================================================ --- Request targets and references --- ============================================================================ - --- RFC 9112 §3.2.1: an origin-form target is never empty, even for a URI with no path. -#guard toString (URI.parse! "http://example.com").originTarget == "/" -#guard toString (URI.parse! "http://example.com?q=1").originTarget == "/?q=1" - --- A name containing `=` is percent-encoded, so it still reads back as the name. -#guard toString (URI.EncodedQueryParam.encode "a=b") == "a%3Db" -#guard - let uri := URI.Builder.empty - |>.setScheme! "http" |>.setHost! "example.com" |>.addQueryParam "k=1" "v=2" |>.build - ((URI.parse? (toString uri)).bind (·.query)).bind (·.get "k=1") == some "v=2" - --- `http:////evil.com/x` has an empty authority and so names no host. Without an authority a path --- cannot begin with `//` (RFC 3986 §3.3), so the path is printed behind a `/.` segment instead of as --- `http://evil.com/x`, which names another host. -#guard - match URI.parse? "http:////evil.com/x" with - | some u => u.host?.isNone && toString u == "http:/.//evil.com/x" && - (URI.parse? (toString u)).any (·.host?.isNone) - | none => false - --- RFC 9110 §4.2.1: an http(s) request target with an empty host is rejected. -#eval parseCheckFail "http:///x" -#eval parseCheckFail "https:///x?q" -#eval parseCheckFail "http:////evil.com/x" -#guard (RequestTarget.parse? "file:///etc/passwd").isSome - --- A reference that starts with `//` has an authority; it is never read as a path when the --- authority does not parse. -#guard (URIReference.parse? "//a:b/x").isNone -#guard (URIReference.parse? "//a:1/x").isSome - --- RFC 3986 §4.2: the first segment of a relative path cannot contain `:`, or it would read as a --- scheme. -#guard (URIReference.parse? "1:b").isNone -#guard (URIReference.parse? "./1:b").isSome -#guard (URIReference.parse? "a/1:b").isSome - --- A fragment whose decoded bytes are not UTF-8 is kept, with U+FFFD for the invalid bytes. -#guard (URI.parse? "http://example.com/#caf%E9").bind (·.fragment) == some "caf�" -#guard - match URIReference.parse? "/x#caf%E9" with - | some (.relative ref) => ref.fragment == some "caf�" - | _ => false -#guard - match URIReference.parse? "http://example.com/#caf%E9" with - | some (.absolute uri) => uri.fragment == some "caf�" - | _ => false - --- ============================================================================ --- Percent-encoded hosts in request targets and `Host` --- ============================================================================ - --- A request target and a `Host` header take the RFC 3986 `host` (RFC 9110 §7.2, RFC 9112 §3.2), so a --- percent-encoded name is decoded there as in any URI or reference. -#eval parseCheck "http://ex%41mple.com/x" "http://example.com/x" -#eval parseCheck "ex%41mple.com:443" "example.com:443" -#guard - match (parseHostHeader <* Std.Internal.Parsec.eof).run "ex%41mple.com:8080".toUTF8 with - | .ok (host, port) => toString host == "example.com" && port == .value 8080 - | .error _ => false --- Decoding does not let through what the name itself could not hold. -#eval parseCheckFail "http://exa%2Fmple.com/x" -#guard ((parseHostHeader <* Std.Internal.Parsec.eof).run "exa%00mple.com".toUTF8).toOption.isNone -#guard - match URIReference.parse? "//ex%41mple.com/x" with - | some (.relative r) => r.authority.map (toString ·.host) == some "example.com" - | _ => false - --- ============================================================================ --- Query names containing `=` --- ============================================================================ - --- A name's `=` is printed escaped, or it would end the name when the query is read back. A value --- keeps its `=` as is. -#guard - match URI.EncodedQueryParam.fromString? "a=b", URI.EncodedQueryParam.fromString? "c=d" with - | some key, some value => - let printed := toString (URI.Query.empty.insertEncoded key (some value)) - printed == "?a%3Db=c=d" && - (RequestTarget.parse? ("/p" ++ printed)).map (·.query.get "a=b") == some (some "c=d") - | _, _ => false - -#guard - match URI.EncodedQueryParam.ofByteArray? "=".toUTF8 with - | some key => - let printed := toString (URI.Query.empty.insertEncoded key none) - printed == "?%3D" && (RequestTarget.parse? ("/p" ++ printed)).map (·.query.contains "=") == some true - | none => false - --- ============================================================================ --- Builder hosts --- ============================================================================ - --- `setHost?` takes a dotted-quad IPv4 address as that address, as a parsed URI does, and still --- refuses a name that ends in a number. -#guard - match URI.Builder.empty.setScheme! "http" |>.setHost? "127.0.0.1" with - | some b => - let u := b.build - toString u == "http://127.0.0.1/" && u.host? == (URI.parse! "http://127.0.0.1/").host? - | none => false -#guard (URI.Builder.empty.setHost? "127.1").isNone -#guard (URI.Builder.empty.setHost? "1.2.3.4.5").isNone -#guard - match (URI.Builder.empty.setHost? "localhost").bind (·.build.host?) with - | some (.name n) => toString n == "localhost" - | _ => false - --- ============================================================================ --- Printing reads back as the same components --- ============================================================================ - -private def relRef? (s : String) : Option URI.RelativeRef := - match URIReference.parse? s with - | some (.relative r) => some r - | _ => none - -private def mkPath (segments : List String) (absolute : Bool) : URI.Path := - { segments := (segments.map URI.EncodedSegment.encode).toArray, absolute } - --- Removing dot segments can leave a path that begins with `//` and no authority, and so can a --- builder with no host. -#guard - let u := (URI.parse! "http:/.//evil.com/x").normalize - toString u == "http:/.//evil.com/x" && (URI.parse? (toString u)).any (·.host?.isNone) -#guard - let u := URI.Builder.empty |>.setScheme! "http" |>.setPath #["", "evil.com"] |>.build - (URI.parse? (toString u)).any (·.host?.isNone) - --- An empty authority before such a path (`file:////host/share`, RFC 8089 Appendix E.3.2) parses. -#guard - match URI.parse? "file:////host/share" with - | some u => u.host?.isNone && toString u == "file:/.//host/share" && - (URI.parse? (toString u)).map (·.path.normalize) == some u.path - | none => false - --- The same holds for a reference, where `//` would read as an authority. -#guard - match relRef? "/.//evil.com/x" with - | some r => - let r := { r with path := r.path.normalize } - toString r == "/.//evil.com/x" && (relRef? (toString r)).any (·.authority.isNone) - | none => false - --- RFC 3986 §4.2: in a reference, a first segment with `:` would read as a scheme, so it is printed --- behind a `./` segment. -#guard - match relRef? "./a:b" with - | some r => - let r := { r with path := r.path.normalize } - toString r == "./a:b" && (relRef? (toString r)).isSome - | none => false - --- A relative path that begins with an empty segment would print as an absolute path. -#guard - let r : URI.RelativeRef := { authority := none, path := mkPath ["", "x"] false, fragment := none } - toString r == ".//x" && (relRef? (toString r)).any (·.path.normalize == r.path) - --- After an authority, and in origin-form, a non-empty path begins with `/`, or it would extend the --- host. -#guard - let u := (URI.parse! "http://example.com").withPath (mkPath ["evil"] false) - toString u == "http://example.com/evil" && (URI.parse? (toString u)).bind (·.host?) == u.host? -#guard toString (RequestTarget.originForm (mkPath ["x"] false) none) == "/x" - --- Every path over a few segment shapes, in a URI and in a reference, with and without an authority, --- prints as a string that reads back with the same authority and, once dot segments are removed, --- the same path. -private def segmentLists (shapes : List String) : Nat → List (List String) - | 0 => [[]] - | n + 1 => [] :: shapes.flatMap fun s => (segmentLists shapes n).map (s :: ·) - -#eval show IO Unit from do - let authorities : List (Option URI.Authority) := - [none, (URI.parse! "foo://host").authority] - let render (path : URI.Path) (authority : Option URI.Authority) (scheme : Bool) : String := - path.normalize.render authority.isSome scheme - for segments in segmentLists ["", ".", "..", "a", "a:b"] 3 do - for absolute in [false, true] do - let path := mkPath segments absolute - for authority in authorities do - -- After an authority a non-empty path can only be absolute. - let meant := - if authority.isSome && !(toString path).isEmpty then { path with absolute := true } else path - let uri : URI := - { scheme := URI.Scheme.ofString! "foo", authority, path, query := none, fragment := none } - match URI.parse? (toString uri) with - | some back => - unless back.authority == authority && render back.path authority true == render meant authority true do - throw <| IO.userError s!"URI {repr path} printed as {toString uri} reads back as {repr back}" - | none => throw <| IO.userError s!"URI {repr path} printed as {toString uri} does not parse" - let ref : URI.RelativeRef := { authority, path, fragment := none } - match relRef? (toString ref) with - | some back => - unless back.authority == authority && render back.path authority false == render meant authority false do - throw <| IO.userError s!"reference {repr path} printed as {toString ref} reads back as {repr back}" - | none => throw <| IO.userError s!"reference {repr path} printed as {toString ref} does not parse"
diff --git a/tests/async/elab/async_http_uri.lean.no_test b/tests/async/elab/async_http_uri.lean.no_test deleted file mode 100644 index 4eaa371..0000000 --- a/tests/async/elab/async_http_uri.lean.no_test +++ /dev/null
@@ -1 +0,0 @@ -Times out under tsanitize CI, see run 42773151421
diff --git a/tests/async/elab/async_http_uri_parse.lean b/tests/async/elab/async_http_uri_parse.lean new file mode 100644 index 0000000..284b6bf --- /dev/null +++ b/tests/async/elab/async_http_uri_parse.lean
@@ -0,0 +1,559 @@ +module + +import Std.Http.Test.Helpers +import Std.Http.Data.URI.Encoding + +/-! +# URI parsing + +How `Std.Http.URI` reads percent-encoded components, request-targets, schemes, userinfo, ports, hosts +and URI references, and which inputs it rejects. RFC 3986 §2–§4, RFC 9112 §3.2, RFC 9110 §4.2.1, +RFC 1034/1035/1123 for host names. Regressions: #16079. +-/ + +open Std Http +open Std.Http.URI +open Std.Http.URI.Parser +open Std.Http.Internal.Test + +private def target? (s : String) : Option RequestTarget := + ((parseRequestTarget <* Std.Internal.Parsec.eof).run s.toUTF8).toOption + +private def hostHeader? (s : String) : Option (URI.Host × URI.Port) := + ((parseHostHeader <* Std.Internal.Parsec.eof).run s.toUTF8).toOption + +private def hostOf (s : String) : Option URI.Host := + (URI.parse? s).bind (·.host?) + +/-- Fails unless `s` parses as a request-target whose `repr` is `want`. -/ +private def expectTarget (s want : String) : IO Unit := + match target? s with + | some t => expectEq s (reprLine t) want + | none => throw <| IO.userError s!"{s.quote} did not parse" + +/-- Fails unless `s` parses as a request-target that prints as `exact`. -/ +private def expectPrints (s : String) (exact : String := s) : IO Unit := + match target? s with + | some t => expectEq s (toString t) exact + | none => throw <| IO.userError s!"{s.quote} did not parse" + +private def expectRejected (s : String) : IO Unit := + match target? s with + | some t => throw <| IO.userError s!"expected parse failure, but succeeded with {reprLine t}" + | none => pure () + +private def repeatStr (s : String) (n : Nat) : String := String.join (List.replicate n s) + +/-! ## Percent-encoded components (RFC 3986 §2.1) -/ + +#eval checkCases "Valid percent encoding validation" #[ + ("abc", "abc", "some \"abc\""), + ("%20", "%20", "some \"%20\""), + ("hello%20world", "hello%20world", "some \"hello%20world\""), + ("%FF", "%FF", "some \"%FF\""), + ("%00", "%00", "some \"%00\"") + ] fun (label, s, want) => expectEq label (reprLine (EncodedSegment.ofByteArray? s.toUTF8)) want + +#eval checkCases "Invalid percent encoding: incomplete or non-hex escape" #[ + ("incomplete: %", "%"), + ("incomplete: hello%", "hello%"), + ("incomplete: %2", "%2"), + ("incomplete: %A", "%A"), + ("non-hex: %GG", "%GG"), + ("non-hex: %2G", "%2G"), + ("non-hex: %G2", "%G2") + ] fun (label, s) => expectEq label (reprLine (EncodedSegment.ofByteArray? s.toUTF8)) "none" + +#eval checkCases "Percent Encoding Decode Tests" #[ + ("abc", "abc", "some \"abc\""), + ("%20", "%20", "some \" \""), + ("hello%20world", "hello%20world", "some \"hello world\""), + ("%20%21", "%20%21", "some \" !\""), + ("%FF is not UTF-8 once decoded", "%FF", "none"), + ("%00 decodes to NUL", "%00", "some \"\\x00\"") + ] fun (label, s, want) => + expectEq label (reprLine (EncodedSegment.decode =<< EncodedSegment.ofByteArray? s.toUTF8)) want + +#eval checkCases "A fragment whose decoded bytes are not UTF-8 is kept, with U+FFFD for the invalid bytes" #[ + ("URI.parse?", ensure ((URI.parse? "http://example.com/#caf%E9").bind (·.fragment) == some "caf�") + "URI.parse? fragment"), + ("relative reference", ensure (match URIReference.parse? "/x#caf%E9" with + | some (.relative ref) => ref.fragment == some "caf�" + | _ => false) "relative reference fragment"), + ("absolute reference", ensure (match URIReference.parse? "http://example.com/#caf%E9" with + | some (.absolute uri) => uri.fragment == some "caf�" + | _ => false) "absolute reference fragment") + ] (·.2) + +#eval checkCases "Non-query components retain literal pluses (#15246)" #[ + ("EncodedSegment.encode", expectEq "segment" (toString (EncodedSegment.encode "+")) "+"), + ("EncodedSegment.decode", expectEq "segment" (EncodedSegment.encode "+").decode (some "+")), + ("EncodedFragment.encode", expectEq "fragment" (toString (EncodedFragment.encode "+")) "+"), + ("EncodedUserInfo.encode", expectEq "userinfo" (toString (EncodedUserInfo.encode "+")) "+") + ] (·.2) + + +private def isPchar (c : Char) : Bool := + c.isAlphanum || "-._~!$&'()*+,;=:@".contains c + +private def pctHex (n : Nat) : String := + let d := Nat.toDigits 16 n |>.map Char.toUpper + "%" ++ String.ofList (if d.length < 2 then '0' :: d else d) + +#eval checkCases "`EncodedSegment.encode` keeps exactly the pchars (RFC 3986 §3.3)" #[ + ("every ASCII byte", do + for n in List.range 128 do + let s := String.singleton (Char.ofNat n) + expectEq s!"encode byte {n}" (toString (EncodedSegment.encode s)) + (if isPchar (Char.ofNat n) then s else pctHex n) + expectEq s!"decode byte {n}" (EncodedSegment.encode s).decode (some s)), + ("/ → %2F", expectEq "encode" (toString (EncodedSegment.encode "/")) "%2F"), + ("% → %25", expectEq "encode" (toString (EncodedSegment.encode "%")) "%25"), + ("SP → %20", expectEq "encode" (toString (EncodedSegment.encode " ")) "%20"), + ("every byte of a non-ASCII character", do + expectEq "encode" (toString (EncodedSegment.encode "é✓")) "%C3%A9%E2%9C%93" + expectEq "decode" (EncodedSegment.encode "é✓").decode (some "é✓")) + ] (·.2) + +#eval checkCases "`Path.toDecodedSegments` (RFC 3986 §2.1, §2.2)" #[ + ("a%20b", "/a%20b", #["a b"]), + ("an encoded `/` stays inside its segment", "/c%2Fd", #["c/d"]), + ("UTF-8", "/%E2%9C%93.txt", #["✓.txt"]) + ] fun (label, path, want) => expectEq label (URI.parse! s!"http://example.com{path}").path.toDecodedSegments want + +/-! ## Request-target forms (RFC 9112 §3.2) -/ + +#eval checkCases "Request Target Parsing - Detailed Output Tests" #[ + ("/path/with/encoded%20space", "/path/with/encoded%20space", + "Std.Http.RequestTarget.originForm { segments := #[\"path\", \"with\", \"encoded%20space\"], absolute := true } none"), + ("///path/with/encoded%20space", "///path/with/encoded%20space", + "Std.Http.RequestTarget.originForm { segments := #[\"\", \"\", \"path\", \"with\", \"encoded%20space\"], absolute := true } none"), + ("*", "*", "Std.Http.RequestTarget.asteriskForm"), + ("query values stay encoded", "/api/search?q=hello%20world&category=tech%2Bgames", + "Std.Http.RequestTarget.originForm { segments := #[\"api\", \"search\"], absolute := true } (some #[(\"q\", some \"hello%20world\"), (\"category\", some \"tech%2Bgames\")])"), + ("/", "/", "Std.Http.RequestTarget.originForm { segments := #[], absolute := true } none"), + ("example.com:8080", "example.com:8080", + "Std.Http.RequestTarget.authorityForm { userInfo := none, host := Std.Http.URI.Host.name \"example.com\", port := Std.Http.URI.Port.value 8080 }"), + ("192.168.1.1:3000", "192.168.1.1:3000", + "Std.Http.RequestTarget.authorityForm { userInfo := none, host := Std.Http.URI.Host.ipv4 192.168.1.1, port := Std.Http.URI.Port.value 3000 }"), + ("http:80 is authority-form", "http:80", + "Std.Http.RequestTarget.authorityForm { userInfo := none, host := Std.Http.URI.Host.name \"http\", port := Std.Http.URI.Port.value 80 }"), + ("[::1]:8080", "[::1]:8080", + "Std.Http.RequestTarget.authorityForm { userInfo := none, host := Std.Http.URI.Host.ipv6 ::1, port := Std.Http.URI.Port.value 8080 }"), + ("https://example.com:8080/ata", "https://example.com:8080/ata", + "Std.Http.RequestTarget.absoluteForm { scheme := \"https\", authority := some { userInfo := none, host := Std.Http.URI.Host.name \"example.com\", port := Std.Http.URI.Port.value 8080 }, path := { segments := #[\"ata\"], absolute := true }, query := none, fragment := none }"), + ("http://[2001:db8::1]:8080/path", "http://[2001:db8::1]:8080/path", + "Std.Http.RequestTarget.absoluteForm { scheme := \"http\", authority := some { userInfo := none, host := Std.Http.URI.Host.ipv6 2001:db8::1, port := Std.Http.URI.Port.value 8080 }, path := { segments := #[\"path\"], absolute := true }, query := none, fragment := none }"), + ("userinfo stays encoded", "https://user%20b:pass@secure.example.com/private", + "Std.Http.RequestTarget.absoluteForm { scheme := \"https\", authority := some { userInfo := some { username := \"user%20b\", password := some \"pass\" }, host := Std.Http.URI.Host.name \"secure.example.com\", port := Std.Http.URI.Port.omitted }, path := { segments := #[\"private\"], absolute := true }, query := none, fragment := none }") + ] fun (_, s, want) => expectTarget s want + +#eval checkCases "Encoded Path Segment Tests" #[ + ("/path%2Fwith%2Fslashes", "/path%2Fwith%2Fslashes", + "Std.Http.RequestTarget.originForm { segments := #[\"path%2Fwith%2Fslashes\"], absolute := true } none"), + ("/file%20name.txt", "/file%20name.txt", + "Std.Http.RequestTarget.originForm { segments := #[\"file%20name.txt\"], absolute := true } none"), + ("/caf%C3%A9", "/caf%C3%A9", + "Std.Http.RequestTarget.originForm { segments := #[\"caf%C3%A9\"], absolute := true } none") + ] fun (_, s, want) => expectTarget s want + +#eval checkCases "authority-form needs at least one port digit" #[ + ("authority-form with an empty port was accepted", + ensure (!(RequestTarget.parse? "example.com:").any (· matches .authorityForm _)) "example.com:"), + ("file:///etc/passwd", ensure ((RequestTarget.parse? "file:///etc/passwd").any (· matches .absoluteForm _)) + "file:///etc/passwd did not parse as absolute-form"), + ("ws://example.com/", ensure ((RequestTarget.parse? "ws://example.com/").any (· matches .absoluteForm _)) + "ws://example.com/ did not parse as absolute-form"), + ("urn:isbn:0451450523", ensure ((RequestTarget.parse? "urn:isbn:0451450523").any (· matches .absoluteForm _)) + "urn:isbn:0451450523 did not parse as absolute-form"), + ("mailto:a@example.com", ensure ((RequestTarget.parse? "mailto:a@example.com").any (· matches .absoluteForm _)) + "mailto:a@example.com did not parse as absolute-form"), + ("example.com:0080", ensure ((RequestTarget.parse? "example.com:0080").any (· matches .authorityForm _)) + "example.com:0080 did not parse as authority-form") + ] (·.2) + + +#eval checkCases "Request-target forms of other schemes (RFC 9112 §3.2.2–§3.2.3)" #[ + ("ietf:rfc:2648 is absolute-form", ensure ((RequestTarget.parse? "ietf:rfc:2648").any (· matches .absoluteForm _)) + "ietf:rfc:2648 did not parse as absolute-form"), + ("example.com:0080 is authority-form with port 80", ensure (match RequestTarget.parse? "example.com:0080" with + | some (.authorityForm auth) => auth.port == .value 80 + | _ => false) "example.com:0080") + ] (·.2) + +/-! ## Rejected request-targets (RFC 9112 §3.2, RFC 9110 §4.2.1) -/ + +#eval checkCases "Parse failure tests" #[ + "/path with space", + "/path/%", + "/path/%2", + "/path/%ZZ", + "", + "[::1", + "[:::1]:80", + "http://-example.com/path", + "http://[fe80::1%25eth0]/path", + "#frag", + "/path/\n", + "/path/\u0000", + "/page#section", + "/api/v1/users/[id]:action" + ] expectRejected + +#eval checkCases "RFC 9110 §4.2.1: an http(s) request target with an empty host is rejected" #[ + ("http:///x", expectRejected "http:///x"), + ("https:///x?q", expectRejected "https:///x?q"), + ("http:////evil.com/x", expectRejected "http:////evil.com/x"), + ("file:///etc/passwd is accepted", ensure (RequestTarget.parse? "file:///etc/passwd").isSome + "file:///etc/passwd was rejected") + ] (·.2) + + +#eval checkCases "`URI.parse?` rejects control bytes and spaces (RFC 3986 §2, §3)" #[ + ("LF in the query", "http://example.com/?q\n"), + ("CR in the scheme", "ht\rtp://example.com/"), + ("DEL in the host", "http://exa\x7fmple.com/"), + ("NUL in the path", "http://example.com/a\x00b"), + ("TAB in the path", "http://example.com/a\tb"), + ("%zz", "http://example.com/%zz"), + (": alone", ":"), + ("a leading SP", " http://example.com/"), + ("SP in the scheme", "ht tp://example.com/"), + ("SP in the host", "http://a b.com/"), + ("an encoded SP after an empty IP literal", "http://[]%20%48%54%54%50/"), + ("brackets and parentheses in the host", "hxxp://x[.]y(.)com:9059"), + ("LF inside the URI", "http://example.com/a\nb"), + ("a C0 control before the URI", "\x01http://example.com/"), + ("a C0 control after the URI", "http://example.com/\x01"), + ("SP after the URI", "http://example.com/ ") + ] fun (label, s) => ensure (URI.parse? s).isNone s!"{label}: {s.quote} parsed" + +/-! ## Scheme, userinfo and port (RFC 3986 §3.1, §3.2.1, §3.2.3) -/ + +#eval checkCases "UserInfo Tests" #[ + ("user:pass", "https://user:pass@example.com/private", + "some { username := \"user\", password := some \"pass\" }"), + ("user%20only", "https://user%20only@example.com/path", + "some { username := \"user%20only\", password := none }"), + (":pass", "https://:pass@example.com/path", "some { username := \"\", password := some \"pass\" }"), + ("encoded password", "https://user:p%40ss%3Aw0rd@example.com/", + "some { username := \"user\", password := some \"p%40ss%3Aw0rd\" }") + ] fun (label, s, want) => + match (target? s).bind (·.authority?) with + | some auth => expectEq label (reprLine auth.userInfo) want + | none => throw <| IO.userError "no authority" + +#eval checkCases "parseScheme: a scheme starts with ALPHA, and its body allows '+', '-', '.'" #[ + ("1http", expectRejected "1http://example.com/path"), + ("+http", expectRejected "+http://example.com/path"), + ("-http", expectRejected "-http://example.com/path"), + (".http", expectRejected ".http://example.com/path"), + ("coap+tcp", expectPrints "coap+tcp://example.com/path"), + ("svn+ssh", expectPrints "svn+ssh://example.com/path"), + ("my.scheme", expectPrints "my.scheme://example.com/path"), + ("a-b", expectPrints "a-b://example.com/path"), + ("Single-letter scheme is valid", expectPrints "a://example.com/path") + ] (·.2) + +#eval checkCases "Ports" #[ + ("a port at the very end of the input", ensure (match target? "example.com:8080" with + | some (.authorityForm auth) => auth.port == .value 8080 + | _ => false) "example.com:8080"), + ("Port 0 is technically valid", ensure (match target? "example.com:0" with + | some (.authorityForm auth) => auth.port == .value 0 + | _ => false) "example.com:0"), + ("Port > 65535 must be rejected: 65536", expectRejected "http://example.com:65536/path"), + ("Port > 65535 must be rejected: 99999", expectRejected "http://example.com:99999/path"), + ("Host example.com:000080", expectEq "Host example.com:000080" + ((Header.Host.parse (.mk "example.com:000080")).map (·.port)) (some (.value 80))), + ("URI with port 0000000000080", expectEq "port 0000000000080" + ((URI.parse? "http://example.com:0000000000080/").bind (·.authority) |>.map (·.port)) + (some (.value 80))), + ("port 00065536 was accepted", ensure (URI.parse? "http://example.com:00065536/").isNone + "port 00065536 was accepted") + ] (·.2) + + +#eval checkCases "Ports that are not `*DIGIT` up to 65535 are rejected (RFC 3986 §3.2.3)" #[ + ":namedport", ":%38%30", ":80:", ":foo", ":1.5", ":-1", ":0x10", ":-0", ":1_1", ": 1", ":1 ", ":६", + ":65536" + ] fun port => ensure (URI.parse? s!"http://example.com{port}/").isNone s!"port {port.quote} was accepted" + +#eval checkCases "Port values" #[ + ("080 → 80", expectEq "port" ((URI.parse? "http://example.com:080/").map (·.authority.map (·.port))) + (some (some (.value 80)))), + ("an empty port before a path", expectEq "port" ((URI.parse? "http://192.168.0.2:/foo").map (·.authority.map (·.port))) + (some (some .empty))), + ("an empty port at the end", expectEq "port" ((URI.parse? "http://[::1]:").map (·.authority.map (·.port))) + (some (some .empty))), + ("an empty port is not an omitted one", do + let some u := URI.parse? "http://[::1]:/foo/" | throw <| IO.userError "http://[::1]:/foo/ did not parse" + ensure (u.authority.map (·.port) == some .empty && u.authority.map (·.port) != some .omitted) + s!"port {reprLine (u.authority.map (·.port))}") + ] (·.2) + +#eval checkCases "Userinfo (RFC 3986 §3.2.1, §6.2.2.1)" #[ + ("a raw `@` in the password", ensure (URI.parse? "http://j@ne:p@ssword@host/").isNone + "http://j@ne:p@ssword@host/ parsed"), + ("a raw `@` in the username", ensure (URI.parse? "http://User@example.com:Pass@host/").isNone + "http://User@example.com:Pass@host/ parsed"), + ("a raw `^`", ensure (URI.parse? "http://us^er@host/").isNone "http://us^er@host/ parsed"), + ("%3F and %40 stay encoded", ensure (match (URI.parse? "http://us%3Fer:p%40ss@host/").bind (·.authority) |>.bind (·.userInfo) with + | some ui => toString ui.username == "us%3Fer" && ui.password.map toString == some "p%40ss" + | none => false) "userinfo of http://us%3Fer:p%40ss@host/"), + ("HTTP://User:Pass@HOST:080/", do + let some u := URI.parse? "HTTP://User:Pass@HOST:080/" | throw <| IO.userError "did not parse" + let ui := u.authority.bind (·.userInfo) + ensure (ui.bind (·.username?) == some "User" && ui.bind (·.password?) == some "Pass") "userinfo split" + ensure (u.authority.map (·.port) == some (.value 80)) "port 80" + ensure (u.host?.map toString == some "host") "host lowercased" + expectEq "normalized scheme" u.normalize.scheme.val "http") + ] (·.2) + +/-! ## Hosts (RFC 3986 §3.2.2, RFC 1034 §3.1, RFC 1123 §2.1) -/ + +#eval checkCases "A host that begins with an IPv4 address and goes on is a name (#16079)" #[ + ("1.2.3.4-x.example:443", expectTarget "1.2.3.4-x.example:443" + "Std.Http.RequestTarget.authorityForm { userInfo := none, host := Std.Http.URI.Host.name \"1.2.3.4-x.example\", port := Std.Http.URI.Port.value 443 }"), + ("http://1.2.3.4x.example/", ensure (match target? "http://1.2.3.4x.example/" with + | some (.absoluteForm uri) => uri.authority.any fun a => toString a.host == "1.2.3.4x.example" + | _ => false) "http://1.2.3.4x.example/"), + ("Host 1.2.3.4-x.example:8080", ensure (match hostHeader? "1.2.3.4-x.example:8080" with + | some (host, port) => toString host == "1.2.3.4-x.example" && port == .value 8080 + | none => false) "parseHostHeader 1.2.3.4-x.example:8080"), + ("Host 1.2.3.4", ensure (match hostHeader? "1.2.3.4" with + | some (.ipv4 _, .omitted) => true + | _ => false) "parseHostHeader 1.2.3.4") + ] (·.2) + +#eval checkCases "IPv6 Host Tests" #[ + ("[::1]:8080", "[::1]:8080", "Std.Http.URI.Host.ipv6 ::1"), + ("compressed", "http://[2001:db8::8a2e:370:7334]:8080/api", "Std.Http.URI.Host.ipv6 2001:db8::8a2e:370:7334"), + ("[::]", "http://[::]/path", "Std.Http.URI.Host.ipv6 ::") + ] fun (label, s, want) => + match (target? s).bind (·.authority?) with + | some auth => expectEq label (reprLine auth.host) want + | none => throw <| IO.userError "no authority" + +#eval checkCases "Authority Form Tests" #[ + ("proxy.example.com:3128", "proxy.example.com:3128", + "Std.Http.RequestTarget.authorityForm { userInfo := none, host := Std.Http.URI.Host.name \"proxy.example.com\", port := Std.Http.URI.Port.value 3128 }"), + ("127.0.0.1:8080", "127.0.0.1:8080", + "Std.Http.RequestTarget.authorityForm { userInfo := none, host := Std.Http.URI.Host.ipv4 127.0.0.1, port := Std.Http.URI.Port.value 8080 }"), + ("1example.com:8080", "1example.com:8080", + "Std.Http.RequestTarget.authorityForm { userInfo := none, host := Std.Http.URI.Host.name \"1example.com\", port := Std.Http.URI.Port.value 8080 }"), + ("http://1example.com/path", "http://1example.com/path", + "Std.Http.RequestTarget.absoluteForm { scheme := \"http\", authority := some { userInfo := none, host := Std.Http.URI.Host.name \"1example.com\", port := Std.Http.URI.Port.omitted }, path := { segments := #[\"path\"], absolute := true }, query := none, fragment := none }"), + ("http://123abc.example.com/page", "http://123abc.example.com/page", + "Std.Http.RequestTarget.absoluteForm { scheme := \"http\", authority := some { userInfo := none, host := Std.Http.URI.Host.name \"123abc.example.com\", port := Std.Http.URI.Port.omitted }, path := { segments := #[\"page\"], absolute := true }, query := none, fragment := none }") + ] fun (_, s, want) => expectTarget s want + +#eval checkCases "IPv4/IPv6 hosts at the very end of the input" #[ + ("192.168.0.1:80", "192.168.0.1:80", + "Std.Http.RequestTarget.authorityForm { userInfo := none, host := Std.Http.URI.Host.ipv4 192.168.0.1, port := Std.Http.URI.Port.value 80 }"), + ("http://[::1]/", "http://[::1]/", + "Std.Http.RequestTarget.absoluteForm { scheme := \"http\", authority := some { userInfo := none, host := Std.Http.URI.Host.ipv6 ::1, port := Std.Http.URI.Port.omitted }, path := { segments := #[], absolute := true }, query := none, fragment := none }") + ] fun (_, s, want) => expectTarget s want + +#eval checkCases "A percent-encoded registered name is decoded (RFC 3986 §3.2.2, §6.2.2.2)" #[ + ("http://ex%41mple.com/", expectEq "host" ((hostOf "http://ex%41mple.com/").map toString) + (some "example.com")), + ("a percent-encoded address is that address", ensure (match hostOf "http://127.0.0.%31/" with + | some (.ipv4 addr) => toString addr == "127.0.0.1" + | _ => false) "http://127.0.0.%31/"), + ("printing it and parsing it again gives the same host", ensure (match URI.parse? "http://%31%32%37.0.0.1/" with + | some u => (URI.parse? (toString u)).bind (·.host?) == u.host? + | none => false) "http://%31%32%37.0.0.1/") + ] (·.2) + +#eval checkCases "`_` is a reg-name character (#16079)" #[ + ("http://_svc.local/", expectEq "host" ((hostOf "http://_svc.local/").map toString) (some "_svc.local")), + ("A dotted quad followed by `_svc` is a name", ensure (match hostOf "http://10.0.0.1_svc/" with + | some (.name n) => toString n == "10.0.0.1_svc" + | _ => false) "http://10.0.0.1_svc/") + ] (·.2) + +#eval checkCases "A fully qualified name ends in a single `.`, which adds no label" #[ + ("example.com.", ensure (URI.DomainName.ofString? "example.com.").isSome "example.com."), + ("http://example.com./", expectEq "host" ((hostOf "http://example.com./").map toString) + (some "example.com.")), + ("example.com..", ensure (URI.DomainName.ofString? "example.com..").isNone "example.com..") + ] (·.2) + +private inductive HostKind where + | notAHost + | name + | ipv4 + deriving BEq + +/-- +`parsed`: what `URI.parse?` (and, for `notAHost`, `DomainName.ofString?`) make of `host`; +`built`: what `Builder.setHost?` makes of it. +-/ +private def expectHost (host : String) (parsed built : Option HostKind) : IO Unit := do + match parsed with + | some .notAHost => + if let some u := URI.parse? s!"http://{host}/" then + throw <| IO.userError s!"http://{host}/ parsed with host {repr u.host?}" + if (URI.DomainName.ofString? host).isSome then + throw <| IO.userError s!"{host} is accepted as a domain name" + | some .name => + unless hostOf s!"http://{host}/" matches some (.name _) do + throw <| IO.userError s!"http://{host}/ does not parse with a domain name host" + | some .ipv4 | none => pure () + match built with + | some .notAHost => ensure (URI.Builder.empty.setHost? host).isNone s!"setHost? {host} was accepted" + | some .name => ensure (match (URI.Builder.empty.setHost? host).bind (·.build.host?) with + | some (.name n) => toString n == host + | _ => false) s!"setHost? {host} is not a name" + | some .ipv4 => ensure (match URI.Builder.empty.setScheme! "http" |>.setHost? host with + | some b => + let u := b.build + toString u == s!"http://{host}/" && u.host? == (URI.parse! s!"http://{host}/").host? + | none => false) s!"setHost? {host} is not that address" + | none => pure () + +-- The system resolver reads a name whose last label is a number as an IPv4 address in shorthand +-- (`127.1` is `127.0.0.1`), so such a name is not a domain name. +#eval checkCases "A name whose last label is a number is not a domain name" #[ + ("127.1", "127.1", some .notAHost, some .notAHost), + ("2130706433", "2130706433", some .notAHost, none), + ("0x7f.0.0.1", "0x7f.0.0.1", some .notAHost, none), + ("1.2.3", "1.2.3", some .notAHost, none), + ("example.0x1F", "example.0x1F", some .notAHost, none), + ("127.1.", "127.1.", some .notAHost, none), + ("1.example", "1.example", some .name, none), + ("example.com1", "example.com1", some .name, none), + ("a.b1c", "a.b1c", some .name, none), + ("0x1g", "0x1g", some .name, none), + ("setHost? takes a dotted-quad IPv4 address", "127.0.0.1", none, some .ipv4), + ("setHost? 1.2.3.4.5", "1.2.3.4.5", none, some .notAHost), + ("setHost? localhost", "localhost", none, some .name) + ] fun (_, host, parsed, built) => expectHost host parsed built + +-- A request target and a `Host` header take the RFC 3986 `host` (RFC 9110 §7.2, RFC 9112 §3.2), so a +-- percent-encoded name is decoded there as in any URI or reference. +#eval checkCases "Percent-encoded hosts in request targets and `Host`" #[ + ("absolute-form", expectPrints "http://ex%41mple.com/x" "http://example.com/x"), + ("authority-form", expectPrints "ex%41mple.com:443" "example.com:443"), + ("Host header", ensure (match hostHeader? "ex%41mple.com:8080" with + | some (host, port) => toString host == "example.com" && port == .value 8080 + | none => false) "parseHostHeader ex%41mple.com:8080"), + ("Decoding does not let through what the name itself could not hold: %2F", + expectRejected "http://exa%2Fmple.com/x"), + ("Decoding does not let through what the name itself could not hold: %00", + ensure (hostHeader? "exa%00mple.com").isNone "parseHostHeader exa%00mple.com"), + ("reference", ensure (match URIReference.parse? "//ex%41mple.com/x" with + | some (.relative r) => r.authority.map (toString ·.host) == some "example.com" + | _ => false) "//ex%41mple.com/x") + ] (·.2) + +private def longLabels : String := repeatStr "a" 63 + +private def name253 : String := + ".".intercalate [repeatStr "a" 63, repeatStr "b" 63, repeatStr "c" 63, repeatStr "d" 61] + +#eval checkCases "Host-name length (RFC 1035 §2.3.4)" #[ + ("Domain names longer than 255 characters are rejected: DomainName.ofString?", + ensure (URI.DomainName.ofString? s!"{longLabels}.{longLabels}.{longLabels}.{longLabels}.").isNone + "256-character DomainName accepted"), + ("Domain names longer than 255 characters are rejected: Builder.setHost?", + ensure (URI.Builder.empty.setHost? s!"{longLabels}.{longLabels}.{longLabels}.{longLabels}.").isNone + "256-character setHost? accepted"), + ("URI with a 253-character host", ensure (URI.parse? s!"http://{name253}/").isSome + "URI with a 253-character host was rejected"), + ("Host of 253 characters", ensure (Header.Host.parse (.ofString! name253)).isSome + "Host of 253 characters was rejected"), + ("DomainName.ofString? of 253 characters", ensure (URI.DomainName.ofString? name253).isSome + "DomainName.ofString? rejected 253 characters"), + ("URI with a 254-character host ending in the root `.`", ensure (URI.parse? s!"http://{name253}./").isSome + "URI with a 254-character host was rejected"), + ("Host of 254 characters ending in the root `.`", ensure (Header.Host.parse (.ofString! (name253 ++ "."))).isSome + "Host of 254 characters was rejected"), + ("DomainName.ofString? of 254 characters ending in the root `.`", + ensure (URI.DomainName.ofString? (name253 ++ ".")).isSome "DomainName.ofString? rejected 254 characters"), + ("Control: 254 characters without the dot are too long", ensure (URI.parse? s!"http://e{name253}/").isNone + "URI with a 254-character host was accepted") + ] (·.2) + + +#eval checkCases "IP literals that parse are IPv6 addresses, printed in lowercase (RFC 3986 §3.2.2)" #[ + "[::ffff:192.168.0.1]", "[::ffff:c0a8:1]", "[1:2:3:4:5:6:7:8]", "[::12.34.56.78]", + "[dead:beef:cafe:5417:affe:8FA3:deaf:feed]" + ] fun lit => match hostOf s!"http://{lit}/" with + | some h@(.ipv6 _) => ensure (toString h == (toString h).toLower) s!"{lit} printed as {toString h}" + | other => throw <| IO.userError s!"{lit} gave host {reprLine other}" + +#eval checkCases "Malformed IP literals and brackets are rejected (RFC 3986 §3.2.2)" #[ + "[::ffff:192.168.0.1000]", "[1:2:3:4:5:6:7:8:9]", "[1::1::1]", "[0439:23af::2309::fae7:1234]", "[1:2:3:]", + "[192.168.0.1]", "[test.com]", "[important.com:8000]", "[not-an-ip]", + "[::1]a", "[::1]%23", "fe80::1]", "::12.34.56.78]", "example.com[::1]", ".[::1]", "]v6a.ip[", "[::1/foo/", + "1:2:3:4:5:6:7:8" + ] fun host => ensure (URI.parse? s!"http://{host}/").isNone s!"http://{host}/ parsed" + +/-! ## URI references (RFC 3986 §3.2, §4.2) -/ + +#eval checkCases "URI references" #[ + ("`file:///path` (empty authority) is an absolute URI", ensure (match URIReference.parse? "file:///etc/passwd" with + | some (.absolute af) => af.scheme.val == "file" && af.authority.isNone + | _ => false) "file:///etc/passwd"), + ("//a:b/x: an authority that does not parse is never read as a path", + ensure (URIReference.parse? "//a:b/x").isNone "//a:b/x"), + ("//a:1/x", ensure (URIReference.parse? "//a:1/x").isSome "//a:1/x"), + ("1:b: the first segment of a relative path cannot contain `:`", + ensure (URIReference.parse? "1:b").isNone "1:b"), + ("./1:b", ensure (URIReference.parse? "./1:b").isSome "./1:b"), + ("a/1:b", ensure (URIReference.parse? "a/1:b").isSome "a/1:b") + ] (·.2) + + +#eval checkCases "Absolute URIs with a rootless or empty path round-trip (RFC 3986 §3)" #[ + "mailto:webmaster@example.org", "magnet:?xt=urn:btih:c12fe1&dn", "mailto:?subject=hi", + "sip:alice@atlanta.com;maddr=239.255.255.1;ttl=15", "tel:+31-641044153", "path:80" + ] fun s => match URIReference.parse? s with + | some r@(.absolute u) => do + ensure u.authority.isNone s!"{s} has an authority" + expectEq "printed" (toString r) s + | other => throw <| IO.userError s!"{s} gave {reprLine (other.map toString)}" + +#eval checkCases "Any scheme takes an authority" #[ + "s3://foo.com/stuff", "x-newscheme://foo.com/stuff?query#fragment" + ] fun s => match URIReference.parse? s with + | some r@(.absolute u) => do + ensure (u.authority.map (toString ·.host) == some "foo.com") s!"{s}: authority" + expectEq "printed" (toString r) s + | other => throw <| IO.userError s!"{s} gave {reprLine (other.map toString)}" + +#eval checkCases "`_` is not a scheme character (RFC 3986 §3.1, §4.2)" #[ + ("cache_object://foo", ensure (URIReference.parse? "cache_object://foo").isNone "cache_object://foo parsed"), + ("cache_object:foo", ensure (URIReference.parse? "cache_object:foo").isNone "cache_object:foo parsed"), + ("cache_object/:foo/bar is a relative reference", + ensure (URIReference.parse? "cache_object/:foo/bar" matches some (.relative _)) "cache_object/:foo/bar") + ] (·.2) + +#eval checkCases "A fragment may hold `@ : / ?` (RFC 3986 §3.5)" #[ + ("//abc#@frag:80", ensure (match URIReference.parse? "//abc#@frag:80" with + | some (.relative r) => + r.fragment == some "@frag:80" && r.authority.map (toString ·.host) == some "abc" && + r.authority.map (·.port) == some .omitted + | _ => false) "//abc#@frag:80") + ] (·.2) + +/-! ## Limits -/ + +#eval checkCases "Limits" #[ + ("maxPathSegments should apply to trailing empty segments as well", ensure + (((parseURI { maxPathSegments := 1 } <* Std.Internal.Parsec.eof).run + "http://example.com/a/".toUTF8).toOption.isNone) "http://example.com/a/ parsed"), + ("257-byte segment", ensure (URI.parse? ("http://example.com/" ++ repeatStr "a" 257)).isSome + "URI.parse? rejected a URI with a 257-byte segment"), + ("129 segments", ensure (URI.parse? ("http://example.com" ++ repeatStr "/a" 129)).isSome + "URI.parse? rejected a URI with 129 segments"), + ("101 query parameters", ensure + (URI.parse? ("http://example.com/?" ++ "&".intercalate (List.replicate 101 "a=1"))).isSome + "URI.parse? rejected a URI with 101 query parameters"), + ("1100-byte fragment", ensure (URI.parse? ("http://example.com/#" ++ repeatStr "f" 1100)).isSome + "URI.parse? rejected a URI with a 1100-byte fragment"), + ("16-character scheme", ensure (URI.parse? "chrome-extension://abcdef/x").isSome + "URI.parse? rejected a URI with a 16-character scheme") + ] (·.2)
diff --git a/tests/async/elab/async_http_uri_print.lean b/tests/async/elab/async_http_uri_print.lean new file mode 100644 index 0000000..d3ce798 --- /dev/null +++ b/tests/async/elab/async_http_uri_print.lean
@@ -0,0 +1,282 @@ +module + +import Std.Http.Test.Helpers +import Std.Http.Data.URI.Encoding + +/-! +# URI printing + +How URIs, request-targets and references print: round trips, the forms put on the wire, path +operations, updates and normalization, the builder, and printing that never turns a path into an +authority. RFC 3986 §3.3, §4.2, §5.2.4, §6.2.2; RFC 9112 §3.2; RFC 9110 §4.2.4; RFC 8089. +Regressions: #15246. +-/ + +open Std Http +open Std.Http.URI +open Std.Http.URI.Parser +open Std.Http.Internal.Test + +private def target? (s : String) : Option RequestTarget := + ((parseRequestTarget <* Std.Internal.Parsec.eof).run s.toUTF8).toOption + +/-- Fails unless `s` parses as a request-target that prints as `exact`. -/ +private def expectPrints (s : String) (exact : String := s) : IO Unit := + match target? s with + | some t => expectEq s (toString t) exact + | none => throw <| IO.userError s!"{s.quote} did not parse" + +private def relRef? (s : String) : Option URI.RelativeRef := + match URIReference.parse? s with + | some (.relative r) => some r + | _ => none + +private def mkPath (segments : List String) (absolute : Bool) : URI.Path := + { segments := (segments.map URI.EncodedSegment.encode).toArray, absolute } + +/-! ## Round trips (RFC 9112 §3.2) -/ + +#eval checkCases "Request Target Parsing - Basic Tests" #[ + ("///path/with/encoded%20space", "///path/with/encoded%20space", none), + ("/path/with/encoded%20space", "/path/with/encoded%20space", none), + ("/path/with/encoded%20space/", "/path/with/encoded%20space/", none), + ("*", "*", none), + ("/api/search?q=hello%20world&category=tech%2Bgames", "/api/search?q=hello%20world&category=tech%2Bgames", none), + ("/", "/", none), + ("/api/v1/users/123/posts/456/comments/789", "/api/v1/users/123/posts/456/comments/789", none), + ("/files/../etc/passwd: dot segments kept", "/files/../etc/passwd", none), + ("example.com:8080", "example.com:8080", none), + ("https://example.com:8080/ata", "https://example.com:8080/ata", none), + ("https://example.com:8080////./ata", "https://example.com:8080////./ata", none), + ("192.168.1.1:3000", "192.168.1.1:3000", none), + ("[::1]:8080", "[::1]:8080", none), + ("http://example.com/path/to/resource?query=value", "http://example.com/path/to/resource?query=value", none), + ("https://api.example.com:443/v1/users?limit=10", "https://api.example.com:443/v1/users?limit=10", none), + ("http://[2001:db8::1]:8080/path", "http://[2001:db8::1]:8080/path", none), + ("https://xn--nxasmq6b.xn--o3cw4h/path", "https://xn--nxasmq6b.xn--o3cw4h/path", none), + ("http://exa_mple.com/path", "http://exa_mple.com/path", none), + ("localhost:65535", "localhost:65535", none), + ("http:80", "http:80", none), + ("A request-target is printed without userinfo (RFC 9110 §4.2.4)", + "https://user:pass@secure.example.com/private", some "https://secure.example.com/private"), + ("/double//slash//path", "/double//slash//path", none), + ("http://user%40example:pass%3Aword@host.com", "http://user%40example:pass%3Aword@host.com", + some "http://host.com"), + ("http://[::ffff:192.168.1.1]/path", "http://[::ffff:192.168.1.1]/path", none), + ("http://example.com:/", "http://example.com:/", none), + ("http://example.com:/?q=1", "http://example.com:/?q=1", none), + ("///////", "///////", none) + ] fun (_, s, exact) => expectPrints s (exact.getD s) + + +#eval checkCases "An empty path before a query or fragment (RFC 3986 §3.3)" #[ + "http://example.com?q=/foo", "http://example.com#abc" + ] fun s => do + let some u := URI.parse? s | throw <| IO.userError s!"{s} did not parse" + ensure u.path.isEmpty s!"{s}: path {toString u.path}" + expectEq "printed" (toString u) s + + +-- RFC 3986 §5.3: an empty authority is still an authority, so its `//` is printed. +#eval checkCases "An empty authority round-trips" #[ + "file:///tmp/junk.txt", "itms-services://?action=download-manifest", "x://y", "x:/y", "x:/" + ] fun s => match URI.parse? s with + | some u => expectEq s (toString u) s + | none => throw <| IO.userError s!"{s.quote} did not parse" + +/-! ## Wire forms (RFC 9112 §3.2.1–§3.2.3) -/ + +#eval checkCases "Request targets on the wire" #[ + ("RFC 9112 §3.2.1: an origin-form target is never empty", + expectEq "originTarget" (toString (URI.parse! "http://example.com").originTarget) "/"), + ("origin-form keeps the query", + expectEq "originTarget" (toString (URI.parse! "http://example.com?q=1").originTarget) "/?q=1"), + ("After an authority a non-empty path begins with `/`, or it would extend the host", do + let u := (URI.parse! "http://example.com").withPath (mkPath ["evil"] false) + ensure (toString u == "http://example.com/evil" && (URI.parse? (toString u)).bind (·.host?) == u.host?) + s!"printed {toString u}"), + ("in origin-form a non-empty path begins with `/`", + expectEq "originForm" (toString (RequestTarget.originForm (mkPath ["x"] false) none)) "/x"), + ("absolute-form printed without userinfo or fragment", do + let absolute := RequestTarget.absoluteForm (URI.parse! "http://user:secret@example.com/x?q#frag") + expectEq "absolute-form" (toString absolute) "http://example.com/x?q"), + ("authority-form printed without userinfo", do + let some authority := (URI.parse! "http://u:p@example.com:443/").authority + | throw (IO.userError "no authority") + expectEq "authority-form" (toString (RequestTarget.authorityForm authority)) "example.com:443") + ] (·.2) + + +#eval checkCases "Origin-form from components (RFC 9112 §3.2.1)" #[ + ("a `?` in a segment", expectEq "printed" (toString (RequestTarget.originForm (mkPath ["a?b"] true) none)) "/a%3Fb"), + ("a space in a segment", expectEq "printed" (toString (RequestTarget.originForm (mkPath ["a b"] true) none)) "/a%20b"), + ("a path that starts with `//` reads back as the same path", do + let t := RequestTarget.originForm (mkPath ["", "evil.com", "x"] true) none + match RequestTarget.parse? (toString t) with + | some (.originForm path _) => expectEq "segments" (path.segments.map toString) #["", "evil.com", "x"] + | other => throw <| IO.userError s!"{toString t} read back as {reprLine other}") + ] (·.2) + +/-! ## Path operations (RFC 3986 §5.2.4) -/ + +#eval checkCases "Path.normalize Tests (RFC 3986 Section 5.2.4)" #[ + ("/a/./b", "http://example.com/a/./b", "/a/b"), + ("a trailing `/..` leaves a `/` (step 2B)", "http://example.com/a/b/..", "/a/"), + ("/a/b/c/./../../g", "http://example.com/a/b/c/./../../g", "/a/g"), + ("/../../../g", "http://example.com/../../../g", "/g"), + ("/a/b/../c", "http://example.com/a/b/../c", "/a/c"), + ("/a/b/c/../.././", "http://example.com/a/b/c/../.././", "/a/"), + ("/a/b/../../..", "http://example.com/a/b/../../..", "/"), + ("/../../../", "http://example.com/../../../", "/"), + ("Likewise for a trailing `/.` (step 2C)", "http://example.com/./a/./b/./c/.", "/a/b/c/"), + ("/a/../b/../c", "http://example.com/a/../b/../c", "/c") + ] fun (label, s, want) => expectEq label (toString (URI.parse! s).path.normalize) want + +#eval checkCases "Path.parent Tests" #[ + ("/a/b/c", "http://example.com/a/b/c", "/a/b"), + ("/a/b", "http://example.com/a/b", "/a"), + ("/a", "http://example.com/a", "/"), + ("/", "http://example.com/", "/") + ] fun (label, s, want) => expectEq label (toString (URI.parse! s).path.parent) want + +#eval checkCases "Path.join Tests" #[ + ("relative", false, "/a/b/c/d"), + ("absolute replaces", true, "/x/y") + ] fun (label, absolute, want) => do + let p1 := (URI.parse! "http://example.com/a/b").path + let segs := if absolute then #["x", "y"] else #["c", "d"] + let p2 : URI.Path := { segments := segs.map URI.EncodedString.encode, absolute } + expectEq label (toString (p1.join p2)) want + +#eval checkCases "Path.isEmpty Tests" #[ + ("http://example.com: isEmpty", ensure (URI.parse! "http://example.com").path.isEmpty "isEmpty"), + ("http://example.com/: absolute", ensure (URI.parse! "http://example.com/").path.absolute "absolute"), + ("http://example.com/a: not isEmpty", ensure (!(URI.parse! "http://example.com/a").path.isEmpty) "isEmpty"), + ("http://example.com/a: absolute", ensure (URI.parse! "http://example.com/a").path.absolute "absolute") + ] (·.2) + + +#eval checkCases "Segments that only look like dot segments are kept (RFC 3986 §5.2.4)" #[ + ("/%2e.bar", "/%2e.bar", "/%2e.bar"), + ("/foo/..bar", "/foo/..bar", "/foo/..bar"), + ("/.foo", "/.foo", "/.foo"), + ("/...", "/...", "/..."), + ("%2E%2E is not ..", "/a/%2E%2E/b", "/a/%2E%2E/b") + ] fun (label, path, want) => + expectEq label (toString (URI.parse! s!"http://example.com{path}").path.normalize) want + +/-! ## Updates and normalization (RFC 3986 §6.2.2) -/ + +#eval checkCases "URI Modification Helpers" #[ + ("withScheme! htTps", expectEq "scheme" ((URI.parse! "http://example.com").withScheme! "htTps" |>.scheme).val + "https"), + ("withScheme! ftP", expectEq "scheme" ((URI.parse! "http://example.com").withScheme! "ftP" |>.scheme).val "ftp"), + ("withFragment", expectEq "withFragment" + (toString ((URI.parse! "http://example.com/").withFragment + (some (toString (URI.EncodedString.encode "section1" : URI.EncodedFragment))))) + "http://example.com/#section1"), + ("withQuery", expectEq "withQuery" + (toString ((URI.parse! "http://example.com/").withQuery (URI.Query.empty.insert "key" "value"))) + "http://example.com/?key=value"), + ("withPath", do + let newPath : URI.Path := + { segments := #[URI.EncodedString.encode "new", URI.EncodedString.encode "path"], absolute := true } + expectEq "withPath" (toString ((URI.parse! "http://example.com/old/path").withPath newPath)) + "http://example.com/new/path") + ] (·.2) + +#eval checkCases "URI.normalize Tests (RFC 3986 Section 6)" #[ + ("scheme HTTP", expectEq "scheme" (URI.parse! "HTTP://example.com").normalize.scheme.val "http"), + ("scheme HtTpS", expectEq "scheme" (URI.parse! "HtTpS://example.com").normalize.scheme.val "https"), + ("host EXAMPLE.COM", expectEq "normalize" (toString (URI.parse! "http://EXAMPLE.COM/").normalize) + "http://example.com/"), + ("host Example.COM", expectEq "normalize" (toString (URI.parse! "HTTP://Example.COM/").normalize) + "http://example.com/"), + ("dot segments", expectEq "normalize" (toString (URI.parse! "http://example.com/a/b/../c").normalize) + "http://example.com/a/c"), + ("dot segments and case", expectEq "normalize" + (toString (URI.parse! "HTTP://EXAMPLE.COM/a/b/c/./../../g").normalize) "http://example.com/a/g"), + ("path case is kept", expectEq "normalize" (toString (URI.parse! "HTTPS://WWW.EXAMPLE.COM/PATH").normalize) + "https://www.example.com/PATH") + ] (·.2) + +/-! ## Builder -/ + +#eval checkCases "URI Builder Tests" #[ + ("path and query", expectEq "build" (toString (URI.Builder.empty + |>.setScheme! "https" + |>.setHost! "example.com" + |>.appendPathSegment "api" + |>.appendPathSegment "users" + |>.addQueryParam "page" "1" + |>.build)) "https://example.com/api/users?page=1"), + ("port and no path", expectEq "build" (toString (URI.Builder.empty + |>.setScheme! "http" + |>.setHost! "localhost" + |>.setPort 8080 + |>.build)) "http://localhost:8080/"), + ("userinfo", expectEq "build" (toString (URI.Builder.empty + |>.setScheme! "https" + |>.setUserInfo "user" (some "pass") + |>.setHost! "secure.example.com" + |>.appendPathSegment "private" + |>.build)) "https://user:pass@secure.example.com/private"), + ("A `:` in a username: printed", do + let uri := URI.Builder.empty |>.setScheme! "http" |>.setHost! "example.com" + |>.setUserInfo "a:b" (some "pw") |>.build + expectEq "printed" (toString uri) "http://a%3Ab:pw@example.com/"), + ("A `:` in a username: read back", do + let uri := URI.Builder.empty |>.setScheme! "http" |>.setHost! "example.com" + |>.setUserInfo "a:b" (some "pw") |>.build + let userInfo := (URI.parse! (toString uri)).authority.bind (·.userInfo) + ensure (userInfo.bind (·.username?) == some "a:b" && userInfo.bind (·.password?) == some "pw") + s!"read back as username {userInfo.bind (·.username?)}, password {userInfo.bind (·.password?)}"), + ("literal pluses, and https by default (#15246)", do + let uri := Builder.empty + |>.setHost! "example.com" + |>.appendPathSegment "a+b" + |>.addQueryParam "a+b" "x+y" + |>.addQueryParam "a b" "x y" + |>.addQueryFlag "+" + |>.build + ensure (toString uri == "https://example.com/a+b?a%2Bb=x%2By&a+b=x+y&%2B" && + (uri.query.bind (·.get "a+b")) == some "x+y" && (uri.query.bind (·.get "+")) == some "") + s!"built {toString uri}") + ] (·.2) + +/-! ## Authority-safe printing (RFC 3986 §3.3, §4.2) -/ + +-- Without an authority a path cannot begin with `//` (RFC 3986 §3.3), so such a path is printed +-- behind a `/.` segment instead of as `//host`, which names a host. +#eval checkCases "A path that begins with `//` never prints as an authority" #[ + ("`http:////evil.com/x` has an empty authority and so names no host", ensure (match URI.parse? "http:////evil.com/x" with + | some u => u.host?.isNone && toString u == "http:/.//evil.com/x" && + (URI.parse? (toString u)).any (·.host?.isNone) + | none => false) "http:////evil.com/x"), + ("Removing dot segments can leave a path that begins with `//` and no authority", do + let u := (URI.parse! "http:/.//evil.com/x").normalize + ensure (toString u == "http:/.//evil.com/x" && (URI.parse? (toString u)).any (·.host?.isNone)) + s!"printed {toString u}"), + ("so can a builder with no host", do + let u := URI.Builder.empty |>.setScheme! "http" |>.setPath #["", "evil.com"] |>.build + ensure ((URI.parse? (toString u)).any (·.host?.isNone)) s!"printed {toString u}"), + ("An empty authority before such a path (`file:////host/share`, RFC 8089 Appendix E.3.2) parses", + ensure (match URI.parse? "file:////host/share" with + | some u => u.host?.isNone && toString u == "file:/.//host/share" && + (URI.parse? (toString u)).map (·.path.normalize) == some u.path + | none => false) "file:////host/share"), + ("The same holds for a reference, where `//` would read as an authority", ensure (match relRef? "/.//evil.com/x" with + | some r => + let r := { r with path := r.path.normalize } + toString r == "/.//evil.com/x" && (relRef? (toString r)).any (·.authority.isNone) + | none => false) "/.//evil.com/x"), + ("RFC 3986 §4.2: a first segment with `:` is printed behind a `./` segment", ensure (match relRef? "./a:b" with + | some r => + let r := { r with path := r.path.normalize } + toString r == "./a:b" && (relRef? (toString r)).isSome + | none => false) "./a:b"), + ("A relative path that begins with an empty segment would print as an absolute path", do + let r : URI.RelativeRef := { authority := none, path := mkPath ["", "x"] false, fragment := none } + ensure (toString r == ".//x" && (relRef? (toString r)).any (·.path.normalize == r.path)) + s!"printed {toString r}") + ] (·.2)
diff --git a/tests/async/elab/async_http_uri_props.lean b/tests/async/elab/async_http_uri_props.lean new file mode 100644 index 0000000..8ee9deb --- /dev/null +++ b/tests/async/elab/async_http_uri_props.lean
@@ -0,0 +1,58 @@ +module + +import Std.Http.Test.Helpers + +/-! +# URI printing properties + +Generated checks that printing a URI or a reference and parsing it again keeps its authority and, +once dot segments are removed, its path. RFC 3986 §3.3, §4.2. +-/ + +open Std Http +open Std.Http.Internal.Test + +private def relRef? (s : String) : Option URI.RelativeRef := + match URIReference.parse? s with + | some (.relative r) => some r + | _ => none + +private def mkPath (segments : List String) (absolute : Bool) : URI.Path := + { segments := (segments.map URI.EncodedSegment.encode).toArray, absolute } + +private def segmentLists (shapes : List String) : Nat → List (List String) + | 0 => [[]] + | n + 1 => [] :: shapes.flatMap fun s => (segmentLists shapes n).map (s :: ·) + +/-! ## Print-parse round-trip property -/ + +-- Every path over a few segment shapes, in a URI and in a reference, with and without an authority, +-- prints as a string that reads back with the same authority and, once dot segments are removed, +-- the same path. +#eval checkCases "Printing reads back as the same components" #[ + ("segments over \"\", \".\", \"..\", \"a\", \"a:b\" up to depth 3", do + let authorities : List (Option URI.Authority) := + [none, (URI.parse! "foo://host").authority] + let render (path : URI.Path) (authority : Option URI.Authority) (scheme : Bool) : String := + path.normalize.render authority.isSome scheme + for segments in segmentLists ["", ".", "..", "a", "a:b"] 3 do + for absolute in [false, true] do + let path := mkPath segments absolute + for authority in authorities do + -- After an authority a non-empty path can only be absolute. + let meant := + if authority.isSome && !(toString path).isEmpty then { path with absolute := true } else path + let uri : URI := + { scheme := URI.Scheme.ofString! "foo", authority, path, query := none, fragment := none } + match URI.parse? (toString uri) with + | some back => + unless back.authority == authority && render back.path authority true == render meant authority true do + throw <| IO.userError s!"URI {repr path} printed as {toString uri} reads back as {repr back}" + | none => throw <| IO.userError s!"URI {repr path} printed as {toString uri} does not parse" + let ref : URI.RelativeRef := { authority, path, fragment := none } + match relRef? (toString ref) with + | some back => + unless back.authority == authority && render back.path authority false == render meant authority false do + throw <| IO.userError s!"reference {repr path} printed as {toString ref} reads back as {repr back}" + | none => throw <| IO.userError s!"reference {repr path} printed as {toString ref} does not parse") + ] (·.2)
diff --git a/tests/async/elab/async_http_uri_query.lean b/tests/async/elab/async_http_uri_query.lean new file mode 100644 index 0000000..5aa72f8 --- /dev/null +++ b/tests/async/elab/async_http_uri_query.lean
@@ -0,0 +1,316 @@ +module + +import Std.Http.Test.Helpers +import Std.Http.Data.URI.Encoding + +/-! +# URI queries + +Form encoding of query strings (a literal `+` versus a space), and how `URI.Query` looks names up, +updates, prints and splits a query. RFC 3986 §3.4. Regressions: #14934, #15246, #15892, #16021. +-/ + +open Std Http +open Std.Http.URI +open Std.Http.URI.Parser +open Std.Http.Internal.Test + +private def target? (s : String) : Option RequestTarget := + ((parseRequestTarget <* Std.Internal.Parsec.eof).run s.toUTF8).toOption + +/-- The query of the origin-form target `s`; fails if `s` does not parse. -/ +private def queryOf (s : String) : IO URI.Query := + match target? s with + | some t => pure t.query + | none => throw <| IO.userError s!"{s.quote} did not parse" + +private def sampleQuery : Query := + Query.empty + |>.insert "a+b" "x+y" + |>.insert "a b" "x y" + |>.insert "a%2Bb" "%2B" + +/-! ## Form encoding (#15246) -/ + +#eval checkCases "Query String Encoding Tests" #[ + ("ofByteArray? hello+world", expectEq "ofByteArray?" + (reprLine (EncodedQueryString.ofByteArray? "hello+world".toUTF8)) "some \"hello+world\""), + ("ofByteArray? %", expectEq "ofByteArray?" (reprLine (EncodedQueryString.ofByteArray? "%".toUTF8)) "none"), + ("decode hello+world", expectEq "decode" + (reprLine (EncodedQueryString.decode =<< EncodedQueryString.ofByteArray? "hello+world".toUTF8)) + "some \"hello world\""), + ("decode %20", expectEq "decode" + (reprLine (EncodedQueryString.decode =<< EncodedQueryString.ofByteArray? "%20".toUTF8)) "some \" \""), + ("EncodedQueryString.encode \"+ +\"", expectEq "encode" (toString (EncodedQueryString.encode "+ +")) "%2B+%2B"), + ("EncodedQueryParam.encode \"+ +\"", expectEq "encode" (toString (EncodedQueryParam.encode "+ +")) "%2B+%2B"), + ("encode \"+\" with an always-true predicate", + expectEq "encode" (toString (EncodedQueryString.encode "+" (fun _ => true))) "%2B"), + ("encode \"+\" with an always-false predicate", + expectEq "encode" (toString (EncodedQueryString.encode "+" (fun _ => false))) "%2B") + ] (·.2) + +#eval checkCases "encode then decode returns the input, for both query types" #[ + "", + "+", + " ", + "a+b", + "a b", + "%2B", + "++ +%&=", + "中文+é 🙂" + ] fun s => do + expectEq "EncodedQueryString" (EncodedQueryString.encode s).decode (some s) + expectEq "EncodedQueryParam" (EncodedQueryParam.encode s).decode (some s) + +#eval checkCases "Already encoded input retains form decoding" #[ + ("c ++ \"+\" ++ c round-trips for every ASCII c", do + for n in List.range 128 do + let c := String.singleton (Char.ofNat n) + let s := c ++ "+" ++ c + expectEq "EncodedQueryString" (EncodedQueryString.encode s).decode (some s) + expectEq "EncodedQueryParam" (EncodedQueryParam.encode s).decode (some s)), + ("fromString? +", expectEq "decode" ((EncodedQueryParam.fromString? "+").bind EncodedQueryParam.decode) + (some " ")), + ("fromString? %2B%2b", expectEq "decode" + ((EncodedQueryParam.fromString? "%2B%2b").bind EncodedQueryParam.decode) (some "++")) + ] (·.2) + +/-! ## Lookups -/ + +private def browserQuery : URI.Query := + match EncodedQueryParam.fromString? "a%3Ab", EncodedQueryParam.fromString? "on" with + | some k, some v => URI.Query.empty.insertEncoded k (some v) + | _, _ => URI.Query.empty + +private def encodedA : IO EncodedQueryParam := + match EncodedQueryParam.fromString? "%61" with + | some a => pure a + | none => throw <| IO.userError "%61 is not a valid query name" + +#eval checkCases "Query Parameter Tests" #[ + ("Query with duplicate keys: findAll size", do + expectEq "findAll" ((← queryOf "/search?tag=a&tag=b&tag=c").findAll "tag").size 3), + ("Query with duplicate keys: findAll values", do + expectEq "findAll" (reprLine ((← queryOf "/search?tag=a&tag=b&tag=c").findAll "tag")) + "#[some \"a\", some \"b\", some \"c\"]"), + ("Query with duplicate keys: find? is the first", do + expectEq "find?" (reprLine ((← queryOf "/search?key=a&key=b&key=c").find? "key")) "some (some \"a\")"), + ("Empty value vs no value: key=", do + expectEq "find?" (reprLine ((← queryOf "/api?key=").find? "key")) "some (some \"\")"), + ("Empty value vs no value: key", do + expectEq "find?" (reprLine ((← queryOf "/api?key").find? "key")) "some none"), + ("Empty value vs no value: key=value", do + expectEq "find?" (reprLine ((← queryOf "/api?key=value").find? "key")) "some (some \"value\")") + ] (·.2) + +-- `String`-keyed lookups match every spelling of a name; `*Encoded` lookups match exact bytes. +#eval checkCases "`String`-keyed and `*Encoded` lookups (#15892)" #[ + ("find? decodes", do + let q ← queryOf "/api?%61=1&a=2" + expectEq "find? a" ((q.find? "a").bind id |>.bind EncodedQueryParam.decode) (some "1")), + ("findAll matches both spellings", do + expectEq "findAll a" ((← queryOf "/api?%61=1&a=2").findAll "a").size 2), + ("find? by the encoded spelling", do + ensure ((← queryOf "/api?%61=1&a=2").find? "%61").isNone "find? %61"), + ("contains", do ensure ((← queryOf "/api?%61=1&a=2").contains "a") "contains a"), + ("contains by the encoded spelling", do + ensure (!(← queryOf "/api?%61=1&a=2").contains "%61") "contains %61"), + ("findEncoded?", do + let q ← queryOf "/api?%61=1&a=2" + expectEq "findEncoded? %61" ((q.findEncoded? (← encodedA)).bind id |>.bind EncodedQueryParam.decode) + (some "1")), + ("containsEncoded", do + ensure ((← queryOf "/api?%61=1&a=2").containsEncoded (← encodedA)) "containsEncoded %61"), + ("erase removes both spellings", do + let erased := (← queryOf "/api?%61=1&a=2").erase "a" + ensure (!erased.contains "a") "erase a: contains a" + ensure (!erased.containsEncoded (← encodedA)) "erase a: containsEncoded %61"), + ("eraseEncoded removes only the exact bytes", do + let erased := (← queryOf "/api?%61=1&a=2").eraseEncoded (← encodedA) + ensure (!erased.containsEncoded (← encodedA)) "eraseEncoded %61: containsEncoded %61" + ensure (erased.contains "a") "eraseEncoded %61: contains a") + ] (·.2) + +-- #14934: a name a browser percent-encodes is found by its decoded spelling. +#eval checkCases "Query Operations (#14934)" #[ + ("get", expectEq "get" (browserQuery.get "a:b") (some "on")), + ("getD", expectEq "getD" (browserQuery.getD "a:b" "off") "on"), + ("contains", ensure (browserQuery.contains "a:b") "contains a:b"), + ("findAll", expectEq "findAll" (browserQuery.findAll "a:b").size 1), + ("contains by the encoded spelling", ensure (!browserQuery.contains "a%3Ab") "contains a%3Ab"), + ("erase", ensure (browserQuery.erase "a:b").isEmpty "erase a:b"), + ("set", expectEq "set" (toString (browserQuery.set "a:b" "off")) "?a:b=off"), + ("parseRequestTarget", do + expectEq "get" ((← queryOf "/consent?a%3Ab=on").get "a:b") (some "on")), + ("URI.parse?", expectEq "get" + ((URI.parse? "https://example.com/consent?a%3Ab=on").bind (·.query.bind (·.get "a:b"))) (some "on")) + ] (·.2) + +#eval checkCases "Lookups by decoded name (#15246)" #[ + ("get a+b", expectEq "get" (sampleQuery.get "a+b") (some "x+y")), + ("get a b", expectEq "get" (sampleQuery.get "a b") (some "x y")), + ("get a%2Bb", expectEq "get" (sampleQuery.get "a%2Bb") (some "%2B")), + ("a+b is not a b", ensure (!(Query.empty.insert "a+b" "value").contains "a b") "contains a b"), + ("findAll after inserting a+b again", expectEq "findAll" + (((sampleQuery.insert "a+b" "+").findAll "a+b").map (·.bind EncodedQueryParam.decode)) + #[some "x+y", some "+"]), + ("received a%2Bb and a+b", do + let q ← queryOf "/path?a%2Bb=x%2By&a+b=x+y" + ensure (q.get "a+b" == some "x+y" && q.get "a b" == some "x y") "get"), + ("A raw plus in a received query name denotes a space, not a literal plus", do + let q ← queryOf "/path?a+b=1" + ensure (q.get "a b" == some "1" && q.get "a+b" == none) "get") + ] (·.2) + +#eval checkCases "`URI.Query.names`" #[ + ("unique names in order of first occurrence", do + let names := (RequestTarget.parse! "/?b=1&a&b=2&c=&a=3&%61").query.names.map toString + ensure (names == #["b", "a", "c", "%61"]) s!"names {names}"), + -- A quadratic deduplication takes seconds here; a linear one, milliseconds. + ("40000 distinct names", do + let n := 40000 + let query := (List.range n).foldl (fun q i => q.insert s!"k{i}" "v") URI.Query.empty + let start ← IO.monoMsNow + let names ← IO.lazyPure fun _ => query.names + -- Checked before the clock is read again, so the names are computed in between. + ensure (names.size == n) s!"{names.size} names" + let elapsed := (← IO.monoMsNow) - start + ensure (elapsed < 2000) s!"Query.names took {elapsed} ms for {n} distinct names") + ] (·.2) + +-- `String`-keyed lookups compare a name as it decodes, byte by byte without decoding it into a new +-- string; this must agree with decoding and comparing. +#eval checkCases "`String`-keyed lookups agree with decoding and comparing" #[ + ("a%3Ab", "a%3Ab", "a:b"), + ("a%3ab", "a%3ab", "a:b"), + ("a+b as a b", "a+b", "a b"), + ("a%2Bb", "a%2Bb", "a+b"), + ("a+b as a+b", "a+b", "a+b"), + ("abc", "abc", "abc"), + ("abc as ab", "abc", "ab"), + ("ab as abc", "ab", "abc"), + ("%41 as A", "%41", "A"), + ("%41 as a", "%41", "a"), + ("r%C3%A9sum%C3%A9", "r%C3%A9sum%C3%A9", "résumé"), + ("%E9", "%E9", "é"), + ("%C3", "%C3", "Ã"), + ("empty", "", ""), + ("x as empty", "x", "") + ] fun (_, enc, key) => do + let some name := URI.EncodedQueryParam.ofByteArray? enc.toUTF8 + | throw (IO.userError s!"{enc} is not a valid query name") + let query := (RequestTarget.parse! s!"/?{enc}=v").query + let expected := name.decode == some key + ensure (query.contains key == expected) s!"contains {key.quote} on {enc}: expected {expected}" + ensure ((query.get key).isSome == expected) s!"get {key.quote} on {enc}: expected {expected}" + +/-! ## Updates and printing -/ + +#eval checkCases "`&` and `=` in a name or value are percent-encoded" #[ + ("`&` in a key", expectEq "toRawString" (URI.Query.empty.insert "a&b" "1").toRawString "a%26b=1"), + ("`=` in a key", expectEq "toRawString" (URI.Query.empty.insert "a=b" "1").toRawString "a%3Db=1"), + ("`&` in a value", expectEq "toRawString" (URI.Query.empty.insert "key" "a&b").toRawString "key=a%26b"), + ("`=` in a value", expectEq "toRawString" (URI.Query.empty.insert "key" "a=b").toRawString "key=a%3Db"), + ("EncodedQueryParam.encode a=b", expectEq "encode" (toString (URI.EncodedQueryParam.encode "a=b")) "a%3Db") + ] (·.2) + +#eval checkCases "Print, then parse again" #[ + ("Round-trip: insert → toRawString → re-parse should preserve the parameter", do + let raw := (URI.Query.empty.insert "a&b" "c=d").toRawString + expectEq "get" ((← queryOf s!"/path?{raw}").get "a&b") (some "c=d")), + ("sampleQuery", do + let q ← queryOf s!"/path?{sampleQuery.toRawString}" + ensure (q == sampleQuery && q.get "a+b" == some "x+y") "reparsed sampleQuery"), + ("A name containing `=` is percent-encoded, so it still reads back as the name", do + let uri := URI.Builder.empty + |>.setScheme! "http" |>.setHost! "example.com" |>.addQueryParam "k=1" "v=2" |>.build + expectEq "get" (((URI.parse? (toString uri)).bind (·.query)).bind (·.get "k=1")) (some "v=2")) + ] (·.2) + +#eval checkCases "Query Operations" #[ + ("insert then contains", ensure (URI.Query.empty.insert "a" "1" |>.contains "a") "contains a"), + ("empty contains nothing", ensure (!URI.Query.empty.contains "nonexistent") "contains nonexistent"), + ("insert a, b", expectEq "toRawString" (URI.Query.empty |>.insert "a" "1" |>.insert "b" "2").toRawString + "a=1&b=2"), + ("erase a", expectEq "toRawString" + (URI.Query.empty |>.insert "a" "1" |>.insert "b" "2" |>.erase "a").toRawString "b=2"), + ("set replaces", expectEq "toRawString" + (URI.Query.empty |>.insert "key" "old" |>.set "key" "new").toRawString "key=new") + ] (·.2) + +-- A name's `=` is printed escaped, or it would end the name when the query is read back. A value +-- keeps its `=` as is. +#eval checkCases "Query names containing `=` (#16021)" #[ + ("a=b with value c=d", ensure (match URI.EncodedQueryParam.fromString? "a=b", URI.EncodedQueryParam.fromString? "c=d" with + | some key, some value => + let printed := toString (URI.Query.empty.insertEncoded key (some value)) + printed == "?a%3Db=c=d" && + (RequestTarget.parse? ("/p" ++ printed)).map (·.query.get "a=b") == some (some "c=d") + | _, _ => false) "?a%3Db=c=d"), + ("= as a flag", ensure (match URI.EncodedQueryParam.ofByteArray? "=".toUTF8 with + | some key => + let printed := toString (URI.Query.empty.insertEncoded key none) + printed == "?%3D" && (RequestTarget.parse? ("/p" ++ printed)).map (·.query.contains "=") == some true + | none => false) "?%3D") + ] (·.2) + +#eval checkCases "Updates keep the other spellings of a name (#15246)" #[ + ("toRawString re-escapes a literal %", expectEq "toRawString" sampleQuery.toRawString + "a%2Bb=x%2By&a+b=x+y&a%252Bb=%252B"), + ("erase", do + let erased := sampleQuery.erase "a+b" + ensure (!erased.contains "a+b" && erased.get "a b" == some "x y" && erased.get "a%2Bb" == some "%2B") + "erase a+b"), + ("set", do + let updated := sampleQuery.set "a+b" "+" + ensure (updated.get "a+b" == some "+" && updated.get "a b" == some "x y" && + updated.get "a%2Bb" == some "%2B" && (updated.findAll "a+b").size == 1) "set a+b") + ] (·.2) + +/-! ## Query syntax (RFC 3986 §3.4) -/ + +#eval checkCases "Query syntax" #[ + ("A trailing `&` is accepted and produces an empty-key entry", do + expectEq "size" (← queryOf "/path?key=val&").size 2), + ("A value may contain an unencoded `=`: the name ends at the first `=` (#16021)", do + expectEq "find?" (reprLine ((← queryOf "/path?key=a=b").find? "key")) "some (some \"a=b\")"), + ("A percent-encoded `=` in the value is preserved as-is", do + expectEq "find?" (reprLine ((← queryOf "/path?key=a%3Db").find? "key")) "some (some \"a%3Db\")"), + ("`none` means no query delimiter", ensure (URI.parse! "http://example.com/path").query.isNone + "query of http://example.com/path"), + ("`some .empty` means an explicit empty query", ensure (match (URI.parse! "http://example.com/path?").query with + | some q => q.isEmpty && toString (URI.parse! "http://example.com/path?") == "http://example.com/path?" + | none => false) "http://example.com/path?"), + ("RequestTarget /path?", ensure (match RequestTarget.parse? "/path?" with + | some (.originForm _ (some q)) => q.isEmpty && toString (RequestTarget.parse! "/path?") == "/path?" + | _ => false) "/path?"), + ("URIReference ?", ensure (match URIReference.parse? "?" with + | some (.relative ref) => ref.query.isSome && toString (URIReference.parse! "?") == "?" + | _ => false) "?"), + ("URIReference #frag", ensure (match URIReference.parse? "#frag" with + | some (.relative ref) => ref.query.isNone && toString (URIReference.parse! "#frag") == "#frag" + | _ => false) "#frag") + ] (·.2) + + +#eval checkCases "Names and values of a query (RFC 3986 §3.4)" #[ + ("=: an empty name and an empty value", "=", #[("", some "")]), + ("=a: an empty name", "=a", #[("", some "a")]), + ("a: a name with no value", "a", #[("a", none)]), + ("a=: an empty value", "a=", #[("a", some "")]), + ("a=1&a=2: repeated names are kept, in order", "a=1&a=2", #[("a", some "1"), ("a", some "2")]), + (";a=b: `;` is not a separator", ";a=b", #[(";a", some "b")]), + ("a=1;b=2: one parameter", "a=1;b=2", #[("a", some "1;b=2")]), + ("a=a+b;b=b+c: `+` decodes to a space", "a=a+b;b=b+c", #[("a", some "a b;b=b c")]) + ] fun (label, q, want) => do + let query ← queryOf s!"/p?{q}" + let got := Array.map (fun (k, v) => (k.decode.getD (toString k), v.map fun v => v.decode.getD (toString v))) query + expectEq label got want + +#eval checkCases "`?`, `/` and `:` stay in the query (RFC 3986 §3.4)" #[ + ("?foo=bar?", expectEq "foo" ((URI.parse! "http://example.com/p?foo=bar?").query.bind (·.get "foo")) (some "bar?")), + ("?query=http://bad", do + let some t := RequestTarget.parse? "/p?query=http://bad" | throw <| IO.userError "did not parse" + ensure (t matches .originForm _ _) "not origin-form" + expectEq "query" (t.query.get "query") (some "http://bad")) + ] (·.2)
diff --git a/tests/async/elab/async_http_uri_rendering.lean b/tests/async/elab/async_http_uri_rendering.lean deleted file mode 100644 index 71fd32e..0000000 --- a/tests/async/elab/async_http_uri_rendering.lean +++ /dev/null
@@ -1,101 +0,0 @@ -import Std.Http -import Std.Http.Test.Helpers - -open Std Http -open Std.Http.Internal.Test -open Std.Http.Protocol.H1 - -/-! -Tests how URIs, request-targets, ports, host names and status codes are read and written: -- a `:` in a username is escaped, since the first `:` separates it from the password (RFC 3986 - §3.2.1); -- absolute-form and authority-form targets carry no userinfo or fragment (RFC 9110 §4.2.4, - RFC 9112 §3.2.2–3.2.3); -- a port may have leading zeros (`port = *DIGIT`, RFC 3986 §3.2.3), and an authority-form target - needs at least one port digit, so `file:///x` stays absolute-form; -- a host name of the maximal 253 characters may end with the root `.`; -- a status code of 600–999 counts as a server error (RFC 9110 §15). --/ - -def expect (cond : Bool) (msg : String) : IO Unit := - unless cond do throw (IO.userError msg) - -def run (machine : Machine dir) (n : Nat := 4) : Machine dir × String := Id.run do - let mut machine := machine - let mut out := ByteArray.empty - for _ in [0:n] do - let (next, step) := machine.step - machine := next - out := out ++ step.output.toByteArray - return (machine, String.fromUTF8! out) - --- A `:` in a username. -#eval show IO Unit from do - let uri := URI.Builder.empty |>.setScheme! "http" |>.setHost! "example.com" - |>.setUserInfo "a:b" (some "pw") |>.build - expect (toString uri == "http://a%3Ab:pw@example.com/") s!"printed {toString uri}" - let back := URI.parse! (toString uri) - let userInfo := back.authority.bind (·.userInfo) - expect (userInfo.bind (·.username?) == some "a:b" && userInfo.bind (·.password?) == some "pw") - s!"read back as username {userInfo.bind (·.username?)}, password {userInfo.bind (·.password?)}" - --- Request-targets. -#eval show IO Unit from do - let absolute := RequestTarget.absoluteForm (URI.parse! "http://user:secret@example.com/x?q#frag") - expect (toString absolute == "http://example.com/x?q") s!"absolute-form printed as {toString absolute}" - let some authority := (URI.parse! "http://u:p@example.com:443/").authority - | throw (IO.userError "no authority") - let target := RequestTarget.authorityForm authority - expect (toString target == "example.com:443") s!"authority-form printed as {toString target}" - -- On the wire, the target reads back as a request-target. - let headers := Headers.empty.insert Header.Name.host (.mk "example.com") - let head : Request.Head := { method := .get, version := .v11, uri := absolute, headers } - let m : Machine .sending := { config := {} } - let (_, out) := run (m.setKnownSize (.fixed 0) |>.send head |>.userClosedBody) - expect (out.startsWith "GET http://example.com/x?q HTTP/1.1\x0d\n") s!"request line {out.quote}" - --- Ports with leading zeros. -#eval show IO Unit from do - let port := (Header.Host.parse (.mk "example.com:000080")).map (·.port) - expect (port == some (.value 80)) s!"Host example.com:000080 gave port {repr port}" - let port := (URI.parse? "http://example.com:0000000000080/").bind (·.authority) |>.map (·.port) - expect (port == some (.value 80)) s!"URI with port 0000000000080 gave {repr port}" - expect (URI.parse? "http://example.com:00065536/").isNone "port 00065536 was accepted" - -- authority-form needs a port; without digits the target is read as absolute-form (an - -- `example.com` scheme). - expect (!(RequestTarget.parse? "example.com:").any (· matches .authorityForm _)) - "authority-form with an empty port was accepted" - for target in ["file:///etc/passwd", "ws://example.com/", "urn:isbn:0451450523", "mailto:a@example.com"] do - expect ((RequestTarget.parse? target).any (· matches .absoluteForm _)) - s!"{target} did not parse as absolute-form" - expect ((RequestTarget.parse? "example.com:0080").any (· matches .authorityForm _)) - "example.com:0080 did not parse as authority-form" - -#eval runGroup "Host with a padded port" do - check "Host: example.com:000080" "GET / HTTP/1.1\x0d\nHost: example.com:000080\x0d\nConnection: close\x0d\n\x0d\n" - okHandler fun r => assertStatus r "HTTP/1.1 200" - check "CONNECT with an empty port" - "CONNECT example.com: HTTP/1.1\x0d\nHost: example.com:\x0d\nConnection: close\x0d\n\x0d\n" - okHandler fun r => assertStatus r "HTTP/1.1 400" - --- A maximal host name with its trailing dot. -#eval show IO Unit from do - let name := ".".intercalate [String.join (List.replicate 63 "a"), String.join (List.replicate 63 "b"), - String.join (List.replicate 63 "c"), String.join (List.replicate 61 "d")] - expect (name.length == 253) "test setup" - for host in [name, name ++ "."] do - expect (URI.parse? s!"http://{host}/").isSome s!"URI with a {host.length}-character host was rejected" - expect (Header.Host.parse (.ofString! host)).isSome s!"Host of {host.length} characters was rejected" - expect (URI.DomainName.ofString? host).isSome s!"DomainName.ofString? rejected {host.length} characters" - -- Control: 254 characters without the dot are too long. - expect (URI.parse? s!"http://e{name}/").isNone "URI with a 254-character host was accepted" - --- Status codes 600–999. -#eval show IO Unit from do - for code in [600, 700, 999] do - let some status := Status.ofCode none code | throw (IO.userError s!"ofCode {code}") - expect (status.isServerError && status.isError) s!"status {code} is not a server error" - let some status := Status.ofCode none 599 | throw (IO.userError "ofCode 599") - expect status.isServerError "599 is not a server error" - let some status := Status.ofCode none 499 | throw (IO.userError "ofCode 499") - expect (!status.isServerError && status.isClientError) "499 is not a client error"
diff --git a/tests/elab/async_http_query_encoding.lean b/tests/elab/async_http_query_encoding.lean deleted file mode 100644 index 6e12553..0000000 --- a/tests/elab/async_http_query_encoding.lean +++ /dev/null
@@ -1,86 +0,0 @@ -module -meta import Std.Http.Data.URI - -/-! -Regression tests for #15246: literal `+` characters in form-encoded query keys and values. -Encoding must distinguish a literal plus from a space, including through query updates and URI builders. --/ - -open Std.Http URI - -#guard toString (EncodedQueryString.encode "+ +") == "%2B+%2B" -#guard toString (EncodedQueryParam.encode "+ +") == "%2B+%2B" -#guard toString (EncodedQueryString.encode "+" (fun _ => true)) == "%2B" -#guard toString (EncodedQueryString.encode "+" (fun _ => false)) == "%2B" - -#guard (["", "+", " ", "a+b", "a b", "%2B", "++ +%&=", "中文+é 🙂"] : List String).all fun s => - (EncodedQueryString.encode s).decode == some s && - (EncodedQueryParam.encode s).decode == some s - -#guard (List.range 128).all fun n => - let c := String.singleton (Char.ofNat n) - let s := c ++ "+" ++ c - (EncodedQueryString.encode s).decode == some s && - (EncodedQueryParam.encode s).decode == some s - --- Already encoded input retains form decoding, while non-query components retain literal pluses. -#guard (EncodedQueryParam.fromString? "+").bind EncodedQueryParam.decode == some " " -#guard (EncodedQueryParam.fromString? "%2B%2b").bind EncodedQueryParam.decode == some "++" -#guard toString (EncodedSegment.encode "+") == "+" -#guard (EncodedSegment.encode "+").decode == some "+" -#guard toString (EncodedFragment.encode "+") == "+" -#guard toString (EncodedUserInfo.encode "+") == "+" - -private meta def sampleQuery : Query := - Query.empty - |>.insert "a+b" "x+y" - |>.insert "a b" "x y" - |>.insert "a%2Bb" "%2B" - -#guard sampleQuery.toRawString == "a%2Bb=x%2By&a+b=x+y&a%252Bb=%252B" -#guard sampleQuery.get "a+b" == some "x+y" -#guard sampleQuery.get "a b" == some "x y" -#guard sampleQuery.get "a%2Bb" == some "%2B" -#guard !(Query.empty.insert "a+b" "value").contains "a b" -#guard ((sampleQuery.insert "a+b" "+").findAll "a+b").map (·.bind EncodedQueryParam.decode) == - #[some "x+y", some "+"] - -#guard - let erased := sampleQuery.erase "a+b" - !erased.contains "a+b" && erased.get "a b" == some "x y" && - erased.get "a%2Bb" == some "%2B" - -#guard - let updated := sampleQuery.set "a+b" "+" - updated.get "a+b" == some "+" && updated.get "a b" == some "x y" && - updated.get "a%2Bb" == some "%2B" && (updated.findAll "a+b").size == 1 - -#guard - match (Parser.parseRequestTarget <* Std.Internal.Parsec.eof).run - s!"/path?{sampleQuery.toRawString}".toUTF8 with - | .ok target => target.query == sampleQuery && target.query.get "a+b" == some "x+y" - | .error _ => false - -#guard - match (Parser.parseRequestTarget <* Std.Internal.Parsec.eof).run - "/path?a%2Bb=x%2By&a+b=x+y".toUTF8 with - | .ok target => target.query.get "a+b" == some "x+y" && target.query.get "a b" == some "x y" - | .error _ => false - --- A raw plus in a received query name denotes a space, not a literal plus. -#guard - match (Parser.parseRequestTarget <* Std.Internal.Parsec.eof).run "/path?a+b=1".toUTF8 with - | .ok target => target.query.get "a b" == some "1" && target.query.get "a+b" == none - | .error _ => false - -#guard - let uri := Builder.empty - |>.setHost! "example.com" - |>.appendPathSegment "a+b" - |>.addQueryParam "a+b" "x+y" - |>.addQueryParam "a b" "x y" - |>.addQueryFlag "+" - |>.build - toString uri == "https://example.com/a+b?a%2Bb=x%2By&a+b=x+y&%2B" && - (uri.query.bind (·.get "a+b")) == some "x+y" && - (uri.query.bind (·.get "+")) == some ""