Skip to content

Commit

Permalink
New, simpler API
Browse files Browse the repository at this point in the history
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
  • Loading branch information
eXenon committed Jun 7, 2019
1 parent c313b23 commit fdc803f
Show file tree
Hide file tree
Showing 11 changed files with 462 additions and 455 deletions.
92 changes: 63 additions & 29 deletions lib/multipart_form_data.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 () =
Expand All @@ -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
Expand All @@ -61,15 +98,12 @@ 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 =
Expand Down
10 changes: 3 additions & 7 deletions lib/multipart_form_data.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down
46 changes: 7 additions & 39 deletions lib/reader.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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 ->
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down
30 changes: 0 additions & 30 deletions lib/reader.mli.old

This file was deleted.

Loading

0 comments on commit fdc803f

Please sign in to comment.