Add buggy unittests

[WARNING : may break your compiler]

lib/dune

@@ -2,6 +2,7 @@
   (name multipart_form_data)
   (public_name multipart-form-data)
   (libraries
+    containers
     lwt
     lwt.unix
     stringext

lib/multipart_form_data.ml

@@ -0,0 +1,94 @@
+module Request = struct
+  type t =
+    { headers : (string * string) list
+    ; body : string Lwt_stream.t
+    }
+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
+    }
+end
+
+(**
+ * Read multipart streams
+ **)
+
+let variable_callback_factory ~callback ~name ~value =
+  callback {Part.name = name; value = Variable value}
+
+let file_callback_factory ~callback =
+  let cache = (ref []: (string list) ref) in
+  let finished = (ref false) in
+  let generator () =
+    match (!cache, !finished) with
+    | ([], true) -> None
+    | ([], false) -> Some ""
+    | (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}
+      }
+  in
+  file_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 read ~request ~handle_part =
+  let {Request.headers; body} = request in
+  part_parser handle_part headers body
+
+(**
+ * Write multipart requests
+ **)
+
+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}}
+    ->
+    failwith "File length is required when writing a multipart request body"
+
+
+let write_with_separator ~separator ~request =
+  let open CCResult.Infix in
+  let multipart_request =
+    Seq.fold_left
+      add_part_to_multipart_request
+      (Writer.init separator)
+      request
+  in
+  Writer.r_headers multipart_request
+  >>= fun headers -> Writer.r_body multipart_request
+  >|= fun body ->
+  { Request.headers = headers
+  ; body = body
+  }
+
+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

lib/multipart_form_data.mli

@@ -0,0 +1,33 @@
+module Request : sig
+  type t =
+    { headers : (string * string) list
+    ; body : string Lwt_stream.t
+    }
+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
+    }
+end
+
+val read :
+  request:Request.t
+  -> handle_part:(Part.t -> unit Lwt.t)
+  -> (unit, string) result
+
+val write_with_separator :
+  separator:string
+  -> request:Part.t Seq.t
+  -> (Request.t, string) result
+
+val write :
+  request:Part.t Seq.t
+  -> (Request.t, string) result

lib/reader.ml

@@ -295,7 +295,7 @@ module Reader = struct
 end
 
 let read_inital_comments boundary reader =
- let rec go comments =
+  let rec go comments =
     let%lwt line = Reader.read_line reader in
     print_endline ("Comment line : " ^ line);
     if line = boundary ^ "\r\n" then
@@ -347,14 +347,19 @@ let rec compute_case reader boundary =
         end
     end
 
+(**
+ * Read file part
+ * We construct a progressive stream that
+ * gets passed to the callback.
+ **)
 let iter_part reader boundary callback =
   let fin = ref false in
   let last () =
     fin := true;
     Lwt.return_unit
   in
   let handle ~send ~unread ~finish =
-    let%lwt () = callback send in
+    let%lwt () = callback send false in
     Reader.unread reader unread;
     if finish then
       last ()
@@ -364,22 +369,66 @@ let iter_part reader boundary callback =
   while%lwt not !fin do
     let%lwt res = compute_case reader boundary in
     match res with
-    | `Empty -> last ()
-    | `Boundary (pre, post) -> handle ~send:pre ~unread:post ~finish:true
-    | `May_end_with_boundary (unambiguous, ambiguous) -> handle ~send:unambiguous ~unread:ambiguous ~finish:false
-    | `App_data line -> callback line
+    | `Empty
+      ->
+      last ()
+    | `Boundary (pre, post)
+      ->
+      handle ~send:pre ~unread:post ~finish:true
+    | `May_end_with_boundary (unambiguous, ambiguous)
+      ->
+      handle ~send:unambiguous ~unread:ambiguous ~finish:false
+    | `App_data line
+      ->
+      callback line false
   done
 
 let read_file_part reader boundary callback =
   iter_part reader boundary callback
 
+(**
+ * Read string part
+ * We construct a buffer that will contain the entirety of
+ * the value before being passed to the callback.
+ **)
+let iter_string_part reader boundary callback =
+  let fin = ref false in
+  let last () =
+    fin := true;
+    Lwt.return_unit
+  in
+  let handle ~send ~unread ~finish =
+    let%lwt () = callback send in
+    Reader.unread reader unread;
+    if finish then
+      last ()
+    else
+      Lwt.return_unit
+  in
+  while%lwt not !fin do
+    let%lwt res = compute_case reader boundary in
+    match res with
+    | `Empty
+      ->
+      last ()
+    | `Boundary (pre, post)
+      ->
+      handle ~send:pre ~unread:post ~finish:true
+    | `May_end_with_boundary (unambiguous, ambiguous)
+      ->
+      handle ~send:unambiguous ~unread:ambiguous ~finish:false
+    | `App_data line
+      ->
+      callback line
+  done
+
 let read_string_part reader boundary =
   let value = Buffer.create 0 in
   let append_to_value line = Lwt.return (Buffer.add_string value line) in
-  let%lwt () = iter_part reader boundary append_to_value in
+  let%lwt () = iter_string_part reader boundary append_to_value in
   Lwt.return (Buffer.contents value)
 
-let read_part reader boundary callback fields =
+let read_part reader boundary variable_callback file_callback =
   let%lwt headers = read_headers reader in
   let content_disposition = List.assoc "Content-Disposition" headers in
   let name =
@@ -388,32 +437,34 @@ let read_part reader boundary callback fields =
     | None -> invalid_arg "handle_multipart"
   in
   match parse_filename content_disposition with
-  | Some filename -> read_file_part reader boundary (callback ~name ~filename)
+  | Some filename -> read_file_part reader boundary (file_callback ~name ~filename)
   | None ->
     let%lwt value = read_string_part reader boundary in
-    fields := (name, value)::!fields;
-    Lwt.return_unit
+    variable_callback ~name ~value
 
-let handle_multipart reader boundary callback =
-  let fields = (ref [] : (string * string) list ref) in
-  let%lwt () =
+let handle_multipart reader boundary variable_callback file_callback =
+  let%lwt read_multipart =
     let%lwt _comments = read_inital_comments boundary reader in
-    print_endline ("Comments : " ^ _comments);
     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 callback fields
+        read_part reader boundary variable_callback file_callback
     done
   in
-  Lwt.return (!fields)
+  Lwt.return read_multipart
 
-let parse ~stream ~content_type ~callback =
+let parse ~stream ~content_type ~variable_callback ~file_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
-  handle_multipart reader boundary callback
+  try
+    handle_multipart reader boundary variable_callback file_callback
+    |> Lwt_main.run
+    |> fun _ -> Ok ()
+  with
+  | Invalid_argument e -> Error e

lib/reader.mli.old

@@ -0,0 +1,30 @@
+module Request : sig
+    type t =
+        { headers : (string * string) list
+        ; body : string Lwt_stream.t
+        }
+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
+    }
+end
+
+val read :
+  request:Request.t
+  -> handle_part:(Part.t -> unit Lwt.t)
+  -> (unit, string) result
+
+
+val write :
+    request:Part.t Seq.t
+    -> (Request.t, string) result