202 lines
8.3 KiB
Text
202 lines
8.3 KiB
Text
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"
|