Skip to content

Instantly share code, notes, and snippets.

@dinosaure

dinosaure/app.ml

Created Apr 19, 2021
Embed
What would you like to do?
`multipart_form` example
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/
*)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment