diff --git a/ReWeb/Filter.ml b/ReWeb/Filter.ml index 02df8d50..cd99e8f8 100644 --- a/ReWeb/Filter.ml +++ b/ReWeb/Filter.ml @@ -69,6 +69,8 @@ module type S = sig decoding and failure works in the same way as for [body_form]. *) end +module H = Httpaf + module Make(R : Request.S) : S with type ('fd, 'io) Service.Request.Reqd.t = ('fd, 'io) R.Reqd.t and type 'ctx Service.Request.t = 'ctx R.t = struct @@ -158,6 +160,9 @@ module Make(R : Request.S) : S let multipart_ct_length = 30 + let chunk_to_string { H.IOVec.buffer; off; len } = + Bigstringaf.substring buffer ~off ~len + (* Complex because we need to keep track of files being uploaded *) let multipart_form ?(typ=Obj.magic Form.empty) path next request = match Request.meth request, Request.header "content-type" request with @@ -166,21 +171,18 @@ module Make(R : Request.S) : S && String.sub content_type 0 multipart_ct_length = "multipart/form-data; boundary=" -> let stream = request |> Request.body - |> Body.to_piaf - |> Piaf.Body.to_string_stream + |> Body.to_stream + |> Lwt_stream.map chunk_to_string in - (*let files = Hashtbl.create ~random:true 5 in*) + let files = Hashtbl.create ~random:true 5 in let open Let.Lwt in - (* let close _ file prev = - let* () = Lwt_io.printf "Closing file\n" in let* () = prev in Lwt_unix.close file in let callback ~name ~filename string = let filename = path ~filename name in let write file = - let* () = Lwt_io.printf "Will write to file\n" in let f () = string |> String.length |> Lwt_unix.write_string file string 0 @@ -190,25 +192,15 @@ module Make(R : Request.S) : S exn |> Printexc.to_string |> Lwt_io.printf "ERROR: %s\n" in match Hashtbl.find_opt files filename with - | Some file -> - let* () = Lwt_io.printf "Will write to existing file\n" in - let* () = write file in - Lwt_io.printf "Wrote file\n" + | Some file -> write file | None -> - let* () = Lwt_io.printf "Will create new file\n" in let* file = Lwt_unix.openfile filename Unix.[O_CREAT; O_TRUNC; O_WRONLY; O_NONBLOCK] 0o600 in - let* () = Lwt_io.printf "Created new file\n" in Hashtbl.add files filename file; - let* () = write file in - Lwt_io.printf "Wrote file\n%!" - in - *) - let callback ~name ~filename _string = Lwt.return_unit - (*Lwt_io.printf "name: %s, filename: %s\n%!" name filename*) + write file in let f () = Multipart_form_data.parse ~stream ~content_type ~callback @@ -217,11 +209,7 @@ module Make(R : Request.S) : S let+ () = exn |> Printexc.to_string |> Lwt_io.printf "ERROR: %s" in [] in - let* () = Lwt_io.printf "Parsed form\n" in - (* let* () = Hashtbl.fold close files Lwt.return_unit in - let* () = Lwt_io.printf "Closed files\n" in - *) let fields = List.map (fun (k, v) -> k, [v]) fields in begin match Form.decode typ fields with | Ok obj -> diff --git a/ReWeb/Request.ml b/ReWeb/Request.ml index edcfaa3d..aba6fdb5 100644 --- a/ReWeb/Request.ml +++ b/ReWeb/Request.ml @@ -87,7 +87,11 @@ module Make(B : BODY)(R : REQD with type 'rw Body.t = 'rw B.t) = struct let stream, push_to_stream = Lwt_stream.create () in let on_eof () = push_to_stream None in let rec on_read buffer ~off ~len = - push_to_stream (Some { H.IOVec.off; len; buffer }); + push_to_stream (Some { + H.IOVec.off; + len; + buffer = Bigstringaf.copy buffer ~off ~len + }); B.schedule_read request_body ~on_eof ~on_read in B.schedule_read request_body ~on_eof ~on_read;