New, simpler API

Fix bug where the all the files would end up in the same stream
Add test with multiple «files»
Add test/utils.mli
Removed old files and unused functions

lib/multipart_form_data.ml

@@ -6,26 +6,32 @@ module Request = struct
 end
 
 module Part = struct
-  module Value = struct
-    type t =
-      | Variable of string
-      | File of {filename : string; content : string Lwt_stream.t; length : int64 option}
-  end
-
   type t =
     { name: string
-    ; value: Value.t
+    ; filename: string option
+    ; content_length: int64 option
+    ; content: string Lwt_stream.t
     }
 end
 
+(**
+ * Utils
+ **)
+let rec lowercase_first = function
+  | (h, v)::t -> ((String.lowercase_ascii h), v)::(lowercase_first t)
+  | [] -> []
+
 (**
  * Read multipart streams
  **)
 
-let variable_callback_factory ~callback ~name ~value =
-  callback {Part.name = name; value = Variable value}
+type content_part_struct =
+  { cache: (string list) ref
+  ; finished: bool ref
+  ; stream: string Lwt_stream.t
+  }
 
-let file_callback_factory ~callback =
+let stream_factory () =
   let cache = (ref []: (string list) ref) in
   let finished = (ref false) in
   let generator () =
@@ -35,21 +41,52 @@ let file_callback_factory ~callback =
     | (h::t, _) -> cache := t; Some h
   in
   let stream = Lwt_stream.from_direct generator in
-  let file_callback ~name ~filename line is_finished =
-    cache := line::!cache;
-    finished := is_finished;
-    callback
-      { Part.name = name
-      ; value = File {filename = filename; content = stream; length = None}
-      }
+  { cache = cache
+  ; finished = finished
+  ; stream = stream
+  }
+
+let callback_factory ~callback =
+  let current_part = ref (stream_factory ()) in
+  let generate_new_stream = ref true in
+  let caching_callback ~name ~filename line is_finished =
+    if !generate_new_stream then
+      (* We finished the previous part and start a new one *)
+      let _ =
+        current_part := stream_factory ();
+        (* Add line to the stream *)
+        !current_part.cache := line::!(!current_part.cache);
+        !current_part.finished := is_finished;
+      in
+      generate_new_stream := is_finished;
+      (* Call the callback with the stream that we just generated *)
+      callback
+        { Part.name = name
+        ; filename = filename
+        ; content_length = None
+        ; content = !current_part.stream
+        }
+    else
+      (* Continuation of the last part *)
+      let _ =
+        !current_part.cache := line::!(!current_part.cache);
+        !current_part.finished := is_finished;
+      in
+      (* If the current part is finished, we need to put the next
+       * incoming line into a new stream.
+      *)
+      generate_new_stream := is_finished;
+      Lwt.return ()
   in
-  file_callback
+  caching_callback
 
 let part_parser callback headers body =
-  let file_callback = file_callback_factory ~callback in
-  let variable_callback = variable_callback_factory ~callback in
-  let content_type = List.assoc "Content-Type" headers in
-  Reader.parse ~stream:body ~content_type ~variable_callback ~file_callback
+  let callback = callback_factory ~callback in
+  let lowercased_headers = lowercase_first headers in
+  let content_type = List.assoc "content-type" lowercased_headers in
+  print_endline content_type;
+  try (Reader.parse ~stream:body ~content_type ~callback) with
+  | _ -> print_endline "EXCEPTION"; Ok ()
 
 let read ~request ~handle_part =
   let {Request.headers; body} = request in
@@ -61,23 +98,20 @@ let read ~request ~handle_part =
 
 let add_part_to_multipart_request multipart_request part =
   match part with
-  | {Part.name=name; value=Variable value}
-    ->
-    Writer.add_form_element ~name ~value multipart_request
-  | {name=name; value=(File {filename=filename; content=content; length=Some content_length})}
-    ->
-    Writer.add_file_from_stream ~name ~filename ~content ~content_length multipart_request
-  | {name=_; value=File {filename=_; content=_; length=None}}
+  | {Part.name = _; filename = _; content_length = None; content = _}
     ->
     failwith "File length is required when writing a multipart request body"
+  | {name = name; filename = filename; content_length = Some content_length; content = content}
+    ->
+    Writer.add_from_stream ~name ~filename ~content ~content_length multipart_request
 
 
-let write_with_separator ~separator ~request =
+let write_with_boundary ~boundary ~request =
   let open CCResult.Infix in
   let multipart_request =
     Seq.fold_left
       add_part_to_multipart_request
-      (Writer.init separator)
+      (Writer.init boundary)
       request
   in
   Writer.r_headers multipart_request
@@ -90,5 +124,5 @@ let write_with_separator ~separator ~request =
 let write ~request =
   Random.self_init ();
   (* It does not matter if the random numbers are not safe here *)
-  let separator = "-----------------" ^ (string_of_int (Random.int 536870912)) in
-  write_with_separator ~separator ~request
+  let boundary = "-----------------" ^ (string_of_int (Random.int 536870912)) in
+  write_with_boundary ~boundary ~request

lib/multipart_form_data.mli

@@ -6,15 +6,11 @@ module Request : sig
 end
 
 module Part : sig
-  module Value : sig
-    type t =
-      | Variable of string
-      | File of {filename : string; content : string Lwt_stream.t; length : int64 option}
-  end
-
   type t =
     { name: string
-    ; value: Value.t
+    ; filename: string option
+    ; content_length: int64 option
+    ; content: string Lwt_stream.t
     }
 end
 
@@ -23,8 +19,8 @@ val read :
   -> handle_part:(Part.t -> unit Lwt.t)
   -> (unit, string) result
 
-val write_with_separator :
-  separator:string
+val write_with_boundary :
+  boundary:string
   -> request:Part.t Seq.t
   -> (Request.t, string) result
 

lib/reader.ml

@@ -156,25 +156,6 @@ type stream_part =
   ; body : string Lwt_stream.t
   }
 
-let parse_part chunk_stream =
-  let lines = align chunk_stream "\r\n" in
-  match%lwt get_headers lines with
-  | [] -> Lwt.return_none
-  | headers ->
-    let body = Lwt_stream.concat @@ Lwt_stream.clone lines in
-    Lwt.return_some { headers ; body }
-
-let parse_stream ~stream ~content_type =
-  match extract_boundary content_type with
-  | None -> Lwt.fail_with "Cannot parse content-type"
-  | Some boundary ->
-    begin
-      let actual_boundary = ("--" ^ boundary) in
-      Lwt.return @@ Lwt_stream.filter_map_s parse_part @@ align stream actual_boundary
-    end
-
-let s_part_body {body; _} = body
-
 let s_part_name {headers; _} =
   match
     parse_name @@ List.assoc "Content-Disposition" headers
@@ -198,14 +179,6 @@ let parse_filename s =
 let s_part_filename {headers; _} =
   parse_filename @@ List.assoc "Content-Disposition" headers
 
-type file = stream_part
-
-let file_stream = s_part_body
-let file_name = s_part_name
-
-let file_content_type {headers; _} =
-  List.assoc "Content-Type" headers
-
 let as_part part =
   match s_part_filename part with
   | Some _filename ->
@@ -297,7 +270,6 @@ end
 let read_inital_comments boundary reader =
   let rec go comments =
     let%lwt line = Reader.read_line reader in
-    print_endline ("Comment line : " ^ line);
     if line = boundary ^ "\r\n" then
       Lwt.return comments
     else
@@ -309,7 +281,6 @@ let read_inital_comments boundary reader =
 let read_headers reader =
   let rec go headers =
     let%lwt line = Reader.read_line reader in
-    print_endline ("Header line : " ^ line);
     if line = "\r\n" then
       Lwt.return headers
     else
@@ -428,42 +399,39 @@ let read_string_part reader boundary =
   let%lwt () = iter_string_part reader boundary append_to_value in
   Lwt.return (Buffer.contents value)
 
-let read_part reader boundary variable_callback file_callback =
+let read_part reader boundary callback =
   let%lwt headers = read_headers reader in
   let content_disposition = List.assoc "Content-Disposition" headers in
   let name =
     match parse_name content_disposition with
     | Some x -> x
     | None -> invalid_arg "handle_multipart"
   in
-  match parse_filename content_disposition with
-  | Some filename -> read_file_part reader boundary (file_callback ~name ~filename)
-  | None ->
-    let%lwt value = read_string_part reader boundary in
-    variable_callback ~name ~value
+  let filename = parse_filename content_disposition in
+  read_file_part reader boundary (callback ~name ~filename)
 
-let handle_multipart reader boundary variable_callback file_callback =
+let handle_multipart reader boundary callback =
   let%lwt read_multipart =
     let%lwt _comments = read_inital_comments boundary reader in
     let fin = ref false in
     while%lwt not !fin do
       if%lwt Reader.empty reader then
         Lwt.return (fin := true)
       else
-        read_part reader boundary variable_callback file_callback
+        read_part reader boundary callback
     done
   in
   Lwt.return read_multipart
 
-let parse ~stream ~content_type ~variable_callback ~file_callback =
+let parse ~stream ~content_type ~callback =
   let reader = Reader.make stream in
   let boundary =
     match extract_boundary content_type with
     | Some s -> "--" ^ s
     | None -> invalid_arg ("Could not extract boundary from Content-Type : " ^ content_type)
   in
   try
-    handle_multipart reader boundary variable_callback file_callback
+    handle_multipart reader boundary callback
     |> Lwt_main.run
     |> fun _ -> Ok ()
   with