`multipart_form` example

app.ml

open Rresult
open Opium
open Lwt.Infix

let always x _ = x

let index =
  let open Tyxml.Html in
  html
    (head (title (txt "Index")) [])
    (body
     [ form ~a:[ a_action "/"; a_method `Post; a_enctype "multipart/form-data" ]
       ([ input ~a:[ a_input_type `File; a_name "file"; a_id "file" ] ()
        ; input ~a:[ a_input_type `Submit; a_value "Upload!"; ] () ]) ])

let index =
  App.get "/" @@ fun _req -> Lwt.return (Response.of_html index)

let get_content_type req =
  let open Rresult in
  Request.header "content-type" req
  |> R.of_option ~none:(always @@ R.error_msgf "Content-Type not found")
  >>| (fun str -> str ^ "\r\n")
  >>= Multipart_form.Content_type.of_string

let rec save tracer collect stream =
  Lwt_stream.get stream >>= function
  | None -> Memtrace.stop_tracing tracer ; Lwt.return_unit
  | Some (id, _hdr, contents) ->
    part collect ~id contents >>= fun () ->
    save tracer collect stream
and part collect ~id contents =
  Lwt_io.open_file ~flags:Unix.[ O_CREAT; O_TRUNC; O_WRONLY ] ~perm:0o600 ~mode:Output
    ("file-" ^ string_of_int id) >>= fun oc ->
  collect := oc :: !collect;
  Lwt_stream.iter_s (Lwt_io.write oc) contents

let identify = fun () ->
  let v = ref (-1) in
  fun _ -> incr v ; !v

let trace =
  let v = ref (-1) in
  fun () -> incr v ; Fmt.str "trace-%06x.ctf" !v

let form =
  App.post "/" @@ begin fun req ->
    let stream = Body.to_stream req.Request.body in
    let open_files = ref [] in
    get_content_type req |> Lwt.return >>= function
    | Error _ ->
      Lwt.return (Response.of_plain_text ~status:`Bad_request "Content-Type not found.")
    | Ok content_type ->
      let identify = identify () in
      let collect = ref [] in
      let tracer = Memtrace.start_tracing ~context:None ~sampling_rate:1e-6 ~filename:(trace ()) in
      let save = save tracer collect in
      let `Parse th, stream = Multipart_form_lwt.stream ~identify stream content_type in
      Lwt.both th (save stream) >>= fun (_res, ()) ->
      Lwt_list.iter_p Lwt_io.close !open_files >|= fun () ->
      Response.redirect_to "/"
  end

let app = App.empty |> index |> form
let () = App.run_command app

(*
   dune:
   (executable
     (name app)
     (libraries opium multipart_form.lwt lwt.unix memtrace))

   $ dune exec ./app.exe
   > go to http://localhost:3000/
   > upload something
   $ memtrace-viewer trace-000000.ctf
   > go to http://localhost:8080/
*)