library for multipart form data handling

examples/dune

@@ -12,7 +12,7 @@
  (name echo)
  (flags :standard -warn-error -a+8)
  (modules echo vfs)
- (libraries tiny_httpd logs tiny_httpd_camlzip))
+ (libraries tiny_httpd logs tiny_httpd_camlzip tiny_httpd.multipart-form-data))
 
 (executable
  (name writer)

examples/echo.ml

@@ -1,5 +1,6 @@
 open Tiny_httpd_core
 module Log = Tiny_httpd.Log
+module MFD = Tiny_httpd_multipart_form_data
 
 let now_ = Unix.gettimeofday
 
@@ -78,6 +79,58 @@ let setup_logging () =
   Logs.set_reporter @@ Logs.format_reporter ();
   Logs.set_level ~all:true (Some Logs.Debug)
 
+let setup_upload server : unit =
+  Server.add_route_handler_stream ~meth:`POST server
+    Route.(exact "upload" @/ return)
+    (fun req ->
+      let (`boundary boundary) =
+        match MFD.parse_content_type req.headers with
+        | Some b -> b
+        | None -> Response.fail_raise ~code:400 "no boundary found"
+      in
+
+      let st = MFD.create ~boundary req.body in
+      let tbl = Hashtbl.create 16 in
+      let cur = ref "" in
+      let cur_kind = ref "" in
+      let buf = Buffer.create 16 in
+      let rec loop () =
+        match MFD.next st with
+        | End_of_input ->
+          if !cur <> "" then
+            Hashtbl.add tbl !cur (!cur_kind, Buffer.contents buf)
+        | Part headers ->
+          if !cur <> "" then
+            Hashtbl.add tbl !cur (!cur_kind, Buffer.contents buf);
+          (match MFD.Content_disposition.parse headers with
+          | Some { kind; name = Some name; filename = _ } ->
+            cur := name;
+            cur_kind := kind;
+            Buffer.clear buf;
+            loop ()
+          | _ -> Response.fail_raise ~code:400 "content disposition missing")
+        | Read sl ->
+          Buffer.add_subbytes buf sl.bytes sl.off sl.len;
+          loop ()
+      in
+      loop ();
+
+      let open Tiny_httpd_html in
+      let data =
+        Hashtbl.fold
+          (fun name (kind, data) acc ->
+            Printf.sprintf "%S (kind: %S): %S" name kind data :: acc)
+          tbl []
+      in
+      let html =
+        body []
+          [
+            pre []
+              [ txt (Printf.sprintf "{\n%s\n}" @@ String.concat "\n" data) ];
+          ]
+      in
+      Response.make_string ~code:201 @@ Ok (to_string_top html))
+
 let () =
   let port_ = ref 8080 in
   let j = ref 32 in
@@ -198,6 +251,8 @@ let () =
          ~dir_behavior:Tiny_httpd.Dir.Index_or_lists ())
     ~vfs:Vfs.vfs ~prefix:"vfs";
 
+  setup_upload server;
+
   (* main page *)
   Server.add_route_handler server
     Route.(return)
@@ -267,6 +322,34 @@ let () =
                             txt " (POST) to log out";
                           ];
                       ];
+                    li []
+                      [
+                        form
+                          [
+                            A.action "/upload";
+                            A.enctype "multipart/form-data";
+                            A.target "_self";
+                            A.method_ "POST";
+                          ]
+                          [
+                            label [] [ txt "my beautiful form" ];
+                            input [ A.type_ "file"; A.name "file1" ];
+                            input [ A.type_ "file"; A.name "file2" ];
+                            input
+                              [
+                                A.type_ "text";
+                                A.name "a";
+                                A.placeholder "text A";
+                              ];
+                            input
+                              [
+                                A.type_ "text";
+                                A.name "b";
+                                A.placeholder "text B";
+                              ];
+                            input [ A.type_ "submit" ];
+                          ];
+                      ];
                   ];
               ];
           ]

src/core/headers.ml

@@ -46,6 +46,21 @@ let for_all pred s =
     true
   with Exit -> false
 
+let parse_line_ (line : string) : _ result =
+  try
+    let i =
+      try String.index line ':'
+      with Not_found -> failwith "invalid header, missing ':'"
+    in
+    let k = String.sub line 0 i in
+    if not (for_all is_tchar k) then
+      failwith (Printf.sprintf "Invalid header key: %S" k);
+    let v =
+      String.sub line (i + 1) (String.length line - i - 1) |> String.trim
+    in
+    Ok (k, v)
+  with Failure msg -> Error msg
+
 let parse_ ~(buf : Buf.t) (bs : IO.Input.t) : t =
   let rec loop acc =
     match IO.Input.read_line_using_opt ~buf bs with
@@ -56,16 +71,10 @@ let parse_ ~(buf : Buf.t) (bs : IO.Input.t) : t =
       bad_reqf 400 "bad header line, not ended in CRLF"
     | Some line ->
       let k, v =
-        try
-          let i = String.index line ':' in
-          let k = String.sub line 0 i in
-          if not (for_all is_tchar k) then
-            invalid_arg (Printf.sprintf "Invalid header key: %S" k);
-          let v =
-            String.sub line (i + 1) (String.length line - i - 1) |> String.trim
-          in
-          k, v
-        with _ -> bad_reqf 400 "invalid header line: %S" line
+        match parse_line_ line with
+        | Ok r -> r
+        | Error msg ->
+          bad_reqf 400 "invalid header line: %s\nline is: %S" msg line
       in
       loop ((String.lowercase_ascii k, v) :: acc)
   in

src/core/headers.mli

@@ -33,3 +33,7 @@ val pp : Format.formatter -> t -> unit
 (** Pretty print the headers. *)
 
 val parse_ : buf:Buf.t -> IO.Input.t -> t
+(**/*)
+
+val parse_line_ : string -> (string * string, string) result
+(**/*)

src/multipart_form/content_disposition.ml

@@ -0,0 +1,31 @@
+open Utils_
+
+type t = { kind: string; name: string option; filename: string option }
+
+(** Simple display *)
+let to_string (self : t) =
+  let stropt = function
+    | None -> "None"
+    | Some s -> spf "%S" s
+  in
+  spf "{kind=%S; name=%s; filename=%s}" self.kind (stropt self.name)
+    (stropt self.filename)
+
+let parse (hs : Tiny_httpd.Headers.t) : t option =
+  match Tiny_httpd.Headers.get "content-disposition" hs with
+  | None -> None
+  | Some s ->
+    (match String.split_on_char ';' s with
+    | [] ->
+      failwith (Printf.sprintf "multipart: invalid content-disposition %S" s)
+    | kind :: tl ->
+      let name = ref None in
+      let filename = ref None in
+      List.iter
+        (fun s ->
+          match Utils_.split1_on ~c:'=' @@ String.trim s with
+          | Some ("name", v) -> name := Some (Utils_.remove_quotes v)
+          | Some ("filename", v) -> filename := Some (Utils_.remove_quotes v)
+          | _ -> ())
+        tl;
+      Some { kind; name = !name; filename = !filename })

src/multipart_form/dune

@@ -0,0 +1,5 @@
+(library
+ (name tiny_httpd_multipart_form_data)
+ (public_name tiny_httpd.multipart-form-data)
+ (synopsis "Port of multipart-form-data for tiny_httpd")
+ (libraries iostream tiny_httpd))