Merge b87226d1be into 8a8aadfbb0

.gitignore

@@ -3,3 +3,4 @@ _build
 _opam
 *.install
 .merlin
+todo.md

src/core/headers.ml

@@ -83,8 +83,13 @@ let parse_line_ (line : string) : _ result =
     Ok (k, v)
   with Failure msg -> Error msg
 
-let parse_ ~(buf : Buf.t) (bs : IO.Input.t) : t =
-  let rec loop acc =
+let parse_ ~(buf : Buf.t) ?(max_headers = 100) ?(max_header_size = 16384)
+    ?(max_total_size = 262144) (bs : IO.Input.t) : t =
+  let rec loop acc count total_size =
+    if count >= max_headers then
+      bad_reqf 431 "too many headers (max: %d)" max_headers;
+    if total_size >= max_total_size then
+      bad_reqf 431 "headers too large (max: %d bytes)" max_total_size;
     match IO.Input.read_line_using_opt ~buf bs with
     | None -> raise End_of_file
     | Some "" -> assert false
@@ -92,12 +97,15 @@ let parse_ ~(buf : Buf.t) (bs : IO.Input.t) : t =
     | Some line when line.[String.length line - 1] <> '\r' ->
       bad_reqf 400 "bad header line, not ended in CRLF"
     | Some line ->
+      let line_len = String.length line in
+      if line_len > max_header_size then
+        bad_reqf 431 "header too large (max: %d bytes)" max_header_size;
       let k, v =
         match parse_line_ line with
         | Ok r -> r
         | Error msg ->
           bad_reqf 400 "invalid header line: %s\nline is: %S" msg line
       in
-      loop ((k, v) :: acc)
+      loop ((k, v) :: acc) (count + 1) (total_size + line_len)
   in
-  loop []
+  loop [] 0 0

src/core/headers.mli

@@ -34,7 +34,13 @@ val pp : Format.formatter -> t -> unit
 
 (**/*)
 
-val parse_ : buf:Buf.t -> IO.Input.t -> t
+val parse_ :
+  buf:Buf.t ->
+  ?max_headers:int ->
+  ?max_header_size:int ->
+  ?max_total_size:int ->
+  IO.Input.t ->
+  t
 val parse_line_ : string -> (string * string, string) result
 
 (**/*)

src/core/response_code.ml

@@ -25,6 +25,7 @@ let descr = function
   | 411 -> "Length required"
   | 413 -> "Payload too large"
   | 417 -> "Expectation failed"
+  | 431 -> "Request Header Fields Too Large"
   | 500 -> "Internal server error"
   | 501 -> "Not implemented"
   | 503 -> "Service unavailable"

src/core/route.mli

@@ -54,9 +54,11 @@ val to_string : _ t -> string
     @since 0.7 *)
 
 val to_url : ('a, string) t -> 'a
+
 (** [to_url route args] takes a route, and turns it into a URL path.
     @since NEXT_RELEASE *)
 
+
 module Private_ : sig
   val eval : string list -> ('a, 'b) t -> 'a -> 'b option
 end

src/unix/dir.ml

@@ -43,6 +43,28 @@ let contains_dot_dot s =
     false
   with Exit -> true
 
+(* Check if string [s] starts with prefix [pre] *)
+let string_prefix ~pre s =
+  let len_pre = String.length pre in
+  String.length s >= len_pre &&
+  String.sub s 0 len_pre = pre
+
+(* Check if a path is safe (doesn't escape root directory).
+   Only needed for real filesystem access. *)
+let is_path_safe ~root_canonical ~path =
+  try
+    let full_path = Filename.concat root_canonical path in
+    let path_canonical = Unix.realpath full_path in
+    string_prefix ~pre:root_canonical path_canonical
+  with Unix.Unix_error _ ->
+    (* If realpath fails (e.g., file doesn't exist for uploads),
+       check parent directory *)
+    try
+      let parent = Filename.dirname (Filename.concat root_canonical path) in
+      let parent_canonical = Unix.realpath parent in
+      string_prefix ~pre:root_canonical parent_canonical
+    with Unix.Unix_error _ -> false
+
 (* Human readable size *)
 let human_size (x : int) : string =
   if x >= 1_000_000_000 then
@@ -206,6 +228,12 @@ let html_list_dir (module VFS : VFS) ~prefix ~parent d : Html.elt =
 (* @param on_fs: if true, we assume the file exists on the FS *)
 let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
     : unit =
+  let root_canonical = if on_fs then try Some (Unix.realpath top) with _ -> None else None in
+  let check_path path =
+    match root_canonical with
+    | Some root -> is_path_safe ~root_canonical:root ~path
+    | None -> not (contains_dot_dot path)
+  in
   let route () =
     if prefix = "" then
       Route.rest_of_path_urlencoded
@@ -214,7 +242,7 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
   in
   if config.delete then
     S.add_route_handler server ~meth:`DELETE (route ()) (fun path _req ->
-        if contains_dot_dot path then
+        if not (check_path path) then
           Response.fail_raise ~code:403 "invalid path in delete"
         else
           Response.make_string
@@ -233,7 +261,7 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
         | Some n when n > config.max_upload_size ->
           Error
             (403, "max upload size is " ^ string_of_int config.max_upload_size)
-        | Some _ when contains_dot_dot req.Request.path ->
+        | Some _ when not (check_path req.Request.path) ->
           Error (403, "invalid path (contains '..')")
         | _ -> Ok ())
       (fun path req ->
@@ -264,7 +292,7 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server
             | None -> Response.fail_raise ~code:403 "Cannot access file"
             | Some t -> Printf.sprintf "mtime: %.4f" t)
         in
-        if contains_dot_dot path then
+        if not (check_path path) then
           Response.fail ~code:403 "Path is forbidden"
         else if not (VFS.contains path) then
           Response.fail ~code:404 "File not found"

tests/unit/dune

@@ -1,4 +1,4 @@
 (tests
- (names t_util t_buf t_server t_io t_response)
+ (names t_util t_buf t_server t_io t_response t_headers)
  (package tiny_httpd)
  (libraries tiny_httpd.core qcheck-core qcheck-core.runner test_util))

tests/unit/t_headers.ml

@@ -0,0 +1,24 @@
+open Tiny_httpd_core
+
+(* Test that header size limits are enforced *)
+let test_header_too_large () =
+  (* Create a header that's larger than 16KB *)
+  let large_value = String.make 20000 'x' in
+  let q =
+    "GET / HTTP/1.1\r\n\
+     Host: example.com\r\n\
+     X-Large: " ^ large_value ^ "\r\n\
+     \r\n"
+  in
+  let str = IO.Input.of_string q in
+  let client_addr = Unix.(ADDR_INET (inet_addr_loopback, 1024)) in
+  let buf = Buf.create () in
+  try
+    let _ = Request.Private_.parse_req_start_exn ~client_addr ~buf
+      ~get_time_s:(fun _ -> 0.) str in
+    failwith "should have failed with 431"
+  with Common_.Bad_req (431, _) ->
+    () (* expected *)
+
+let () =
+  test_header_too_large ()