From 0908d71e19eeb830b9693ae47c105f26af22d23e Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 23 May 2023 17:40:18 -0400 Subject: [PATCH] ocamlformat --- .ocamlformat | 14 + examples/dune | 97 ++-- examples/echo.ml | 185 ++++--- examples/sse_client.ml | 22 +- examples/sse_server.ml | 94 ++-- src/Tiny_httpd.ml | 6 - src/Tiny_httpd.mli | 6 +- src/Tiny_httpd_buf.ml | 27 +- src/Tiny_httpd_buf.mli | 3 +- src/Tiny_httpd_dir.ml | 518 ++++++++++-------- src/Tiny_httpd_dir.mli | 53 +- src/Tiny_httpd_html.ml | 15 +- src/Tiny_httpd_server.ml | 842 +++++++++++++++-------------- src/Tiny_httpd_server.mli | 102 ++-- src/Tiny_httpd_stream.ml | 338 ++++++------ src/Tiny_httpd_stream.mli | 43 +- src/Tiny_httpd_util.ml | 81 +-- src/Tiny_httpd_util.mli | 2 +- src/bin/curly.ml | 167 +++--- src/bin/curly.mli | 103 ++-- src/bin/dune | 27 +- src/bin/http.mli | 6 +- src/bin/http_of_dir.ml | 91 ++-- src/bin/vfs_pack.ml | 119 ++-- src/camlzip/Tiny_httpd_camlzip.ml | 273 +++++----- src/camlzip/Tiny_httpd_camlzip.mli | 9 +- src/camlzip/dune | 11 +- src/dune | 21 +- src/gen/dune | 4 +- src/gen/gentags.ml | 559 +++++++++---------- src/qtest/dune | 24 +- tests/dune | 124 +++-- tests/html/dune | 35 +- tests/html/makehtml.ml | 65 ++- 34 files changed, 2103 insertions(+), 1983 deletions(-) create mode 100644 .ocamlformat diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 00000000..f820496c --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,14 @@ +version = 0.24.1 +profile=conventional +margin=80 +if-then-else=k-r +parens-ite=true +parens-tuple=multi-line-only +sequence-style=terminator +type-decl=compact +break-cases=toplevel +cases-exp-indent=2 +field-space=tight-decl +leading-nested-match-parens=true +module-item-spacing=compact +quiet=true diff --git a/examples/dune b/examples/dune index be6aa799..da1cd96d 100644 --- a/examples/dune +++ b/examples/dune @@ -1,53 +1,68 @@ +(executable + (name sse_server) + (modules sse_server) + (libraries tiny_httpd unix ptime ptime.clock.os)) (executable - (name sse_server) - (modules sse_server) - (libraries tiny_httpd unix ptime ptime.clock.os)) + (name sse_client) + (modules sse_client) + (libraries unix)) (executable - (name sse_client) - (modules sse_client) - (libraries unix)) - -(executable - (name echo) - (flags :standard -warn-error -a+8) - (modules echo vfs) - (libraries tiny_httpd tiny_httpd_camlzip)) + (name echo) + (flags :standard -warn-error -a+8) + (modules echo vfs) + (libraries tiny_httpd tiny_httpd_camlzip)) (rule - (targets test_output.txt) - (deps (:script ./run_test.sh) ./sse_client.exe ./sse_server.exe) - (enabled_if (= %{system} "linux")) - (package tiny_httpd) - (action - (with-stdout-to %{targets} (run %{script})))) + (targets test_output.txt) + (deps + (:script ./run_test.sh) + ./sse_client.exe + ./sse_server.exe) + (enabled_if + (= %{system} "linux")) + (package tiny_httpd) + (action + (with-stdout-to + %{targets} + (run %{script})))) (rule - (alias runtest) - (package tiny_httpd) - (enabled_if (= %{system} "linux")) - (deps test_output.txt) - (action - (diff test_output.txt.expected test_output.txt))) + (alias runtest) + (package tiny_httpd) + (enabled_if + (= %{system} "linux")) + (deps test_output.txt) + (action + (diff test_output.txt.expected test_output.txt))) ; produce an embedded FS -(rule - (targets vfs.ml) - (deps (source_tree files) (:out test_output.txt.expected)) - (enabled_if (= %{system} "linux")) - (action (run %{bin:tiny-httpd-vfs-pack} -o %{targets} - --mirror=files/ - --file=test_out.txt,%{out} - ; --url=example_dot_com,http://example.com ; this breaks tests in opam sandbox 😢 - ))) (rule - (targets vfs.ml) - (enabled_if (<> %{system} "linux")) - (action - (with-stdout-to - %{targets} - (progn - (echo "let embedded_fs = Tiny_httpd_dir.Embedded_fs.create ~mtime:0. ()") - (echo "let vfs = Tiny_httpd_dir.Embedded_fs.to_vfs embedded_fs"))))) + (targets vfs.ml) + (deps + (source_tree files) + (:out test_output.txt.expected)) + (enabled_if + (= %{system} "linux")) + (action + (run + %{bin:tiny-httpd-vfs-pack} + -o + %{targets} + --mirror=files/ + --file=test_out.txt,%{out} + ; --url=example_dot_com,http://example.com ; this breaks tests in opam sandbox 😢 + ))) + +(rule + (targets vfs.ml) + (enabled_if + (<> %{system} "linux")) + (action + (with-stdout-to + %{targets} + (progn + (echo "let embedded_fs = Tiny_httpd_dir.Embedded_fs.create ~mtime:0. ()") + (echo "let vfs = Tiny_httpd_dir.Embedded_fs.to_vfs embedded_fs"))))) diff --git a/examples/echo.ml b/examples/echo.ml index bc1607e7..b0d152c0 100644 --- a/examples/echo.ml +++ b/examples/echo.ml @@ -1,4 +1,3 @@ - module S = Tiny_httpd let now_ = Unix.gettimeofday @@ -22,30 +21,34 @@ let middleware_stat () : S.Middleware.t * (unit -> string) = total_time_ := !total_time_ +. (t4 -. t1); parse_time_ := !parse_time_ +. (t2 -. t1); build_time_ := !build_time_ +. (t3 -. t2); - write_time_ := !write_time_ +. (t4 -. t3); - ) + write_time_ := !write_time_ +. (t4 -. t3)) and get_stat () = - Printf.sprintf "%d requests (average response time: %.3fms = %.3fms + %.3fms + %.3fms)" - !n_req (!total_time_ /. float !n_req *. 1e3) - (!parse_time_ /. float !n_req *. 1e3) - (!build_time_ /. float !n_req *. 1e3) - (!write_time_ /. float !n_req *. 1e3) + Printf.sprintf + "%d requests (average response time: %.3fms = %.3fms + %.3fms + %.3fms)" + !n_req + (!total_time_ /. float !n_req *. 1e3) + (!parse_time_ /. float !n_req *. 1e3) + (!build_time_ /. float !n_req *. 1e3) + (!write_time_ /. float !n_req *. 1e3) in m, get_stat - let () = let port_ = ref 8080 in let j = ref 32 in - Arg.parse (Arg.align [ - "--port", Arg.Set_int port_, " set port"; - "-p", Arg.Set_int port_, " set port"; - "--debug", Arg.Unit (fun () -> S._enable_debug true), " enable debug"; - "-j", Arg.Set_int j, " maximum number of connections"; - ]) (fun _ -> raise (Arg.Bad "")) "echo [option]*"; + Arg.parse + (Arg.align + [ + "--port", Arg.Set_int port_, " set port"; + "-p", Arg.Set_int port_, " set port"; + "--debug", Arg.Unit (fun () -> S._enable_debug true), " enable debug"; + "-j", Arg.Set_int j, " maximum number of connections"; + ]) + (fun _ -> raise (Arg.Bad "")) + "echo [option]*"; let server = S.create ~port:!port_ ~max_connections:!j () in - Tiny_httpd_camlzip.setup ~compress_above:1024 ~buf_size:(16*1024) server; + Tiny_httpd_camlzip.setup ~compress_above:1024 ~buf_size:(16 * 1024) server; let m_stats, get_stats = middleware_stat () in S.add_middleware server ~stage:(`Stage 1) m_stats; @@ -53,87 +56,127 @@ let () = (* say hello *) S.add_route_handler ~meth:`GET server S.Route.(exact "hello" @/ string @/ return) - (fun name _req -> S.Response.make_string (Ok ("hello " ^name ^"!\n"))); + (fun name _req -> S.Response.make_string (Ok ("hello " ^ name ^ "!\n"))); (* compressed file access *) S.add_route_handler ~meth:`GET server S.Route.(exact "zcat" @/ string_urlencoded @/ return) (fun path _req -> - let ic = open_in path in - let str = S.Byte_stream.of_chan ic in - let mime_type = + let ic = open_in path in + let str = S.Byte_stream.of_chan ic in + let mime_type = + try + let p = Unix.open_process_in (Printf.sprintf "file -i -b %S" path) in try - let p = Unix.open_process_in (Printf.sprintf "file -i -b %S" path) in - try - let s = ["Content-Type", String.trim (input_line p)] in - ignore @@ Unix.close_process_in p; - s - with _ -> ignore @@ Unix.close_process_in p; [] - with _ -> [] - in - S.Response.make_stream ~headers:mime_type (Ok str) - ); + let s = [ "Content-Type", String.trim (input_line p) ] in + ignore @@ Unix.close_process_in p; + s + with _ -> + ignore @@ Unix.close_process_in p; + [] + with _ -> [] + in + S.Response.make_stream ~headers:mime_type (Ok str)); (* echo request *) S.add_route_handler server S.Route.(exact "echo" @/ return) (fun req -> - let q = - S.Request.query req |> List.map (fun (k,v) -> Printf.sprintf "%S = %S" k v) - |> String.concat ";" - in - S.Response.make_string - (Ok (Format.asprintf "echo:@ %a@ (query: %s)@." S.Request.pp req q))); + let q = + S.Request.query req + |> List.map (fun (k, v) -> Printf.sprintf "%S = %S" k v) + |> String.concat ";" + in + S.Response.make_string + (Ok (Format.asprintf "echo:@ %a@ (query: %s)@." S.Request.pp req q))); (* file upload *) S.add_route_handler_stream ~meth:`PUT server S.Route.(exact "upload" @/ string @/ return) (fun path req -> - S._debug (fun k->k "start upload %S, headers:\n%s\n\n%!" path - (Format.asprintf "%a" S.Headers.pp (S.Request.headers req))); - try - let oc = open_out @@ "/tmp/" ^ path in - S.Byte_stream.to_chan oc req.S.Request.body; - flush oc; - S.Response.make_string (Ok "uploaded file") - with e -> - S.Response.fail ~code:500 "couldn't upload file: %s" (Printexc.to_string e) - ); + S._debug (fun k -> + k "start upload %S, headers:\n%s\n\n%!" path + (Format.asprintf "%a" S.Headers.pp (S.Request.headers req))); + try + let oc = open_out @@ "/tmp/" ^ path in + S.Byte_stream.to_chan oc req.S.Request.body; + flush oc; + S.Response.make_string (Ok "uploaded file") + with e -> + S.Response.fail ~code:500 "couldn't upload file: %s" + (Printexc.to_string e)); (* stats *) - S.add_route_handler server S.Route.(exact "stats" @/ return) + S.add_route_handler server + S.Route.(exact "stats" @/ return) (fun _req -> - let stats = get_stats() in - S.Response.make_string @@ Ok stats - ); + let stats = get_stats () in + S.Response.make_string @@ Ok stats); (* VFS *) Tiny_httpd_dir.add_vfs server - ~config:(Tiny_httpd_dir.config ~download:true - ~dir_behavior:Tiny_httpd_dir.Index_or_lists ()) + ~config: + (Tiny_httpd_dir.config ~download:true + ~dir_behavior:Tiny_httpd_dir.Index_or_lists ()) ~vfs:Vfs.vfs ~prefix:"vfs"; (* main page *) - S.add_route_handler server S.Route.(return) + S.add_route_handler server + S.Route.(return) (fun _req -> - let open Tiny_httpd_html in - let h = html [] [ - head[][title[][txt "index of echo"]]; - body[][ - h3[] [txt "welcome!"]; - p[] [b[] [txt "endpoints are:"]]; - ul[] [ - li[][pre[][txt "/hello/:name (GET)"]]; - li[][pre[][a[A.href "/echo/"][txt "echo"]; txt " echo back query"]]; - li[][pre[][txt "/upload/:path (PUT) to upload a file"]]; - li[][pre[][txt "/zcat/:path (GET) to download a file (deflate transfer-encoding)"]]; - li[][pre[][a[A.href "/stats/"][txt"/stats/"]; txt" (GET) to access statistics"]]; - li[][pre[][a[A.href "/vfs/"][txt"/vfs"]; txt" (GET) to access a VFS embedded in the binary"]]; - ] - ] - ] in - let s = to_string_top h in - S.Response.make_string ~headers:["content-type", "text/html"] @@ Ok s); + let open Tiny_httpd_html in + let h = + html [] + [ + head [] [ title [] [ txt "index of echo" ] ]; + body [] + [ + h3 [] [ txt "welcome!" ]; + p [] [ b [] [ txt "endpoints are:" ] ]; + ul [] + [ + li [] [ pre [] [ txt "/hello/:name (GET)" ] ]; + li [] + [ + pre [] + [ + a [ A.href "/echo/" ] [ txt "echo" ]; + txt " echo back query"; + ]; + ]; + li [] + [ pre [] [ txt "/upload/:path (PUT) to upload a file" ] ]; + li [] + [ + pre [] + [ + txt + "/zcat/:path (GET) to download a file (deflate \ + transfer-encoding)"; + ]; + ]; + li [] + [ + pre [] + [ + a [ A.href "/stats/" ] [ txt "/stats/" ]; + txt " (GET) to access statistics"; + ]; + ]; + li [] + [ + pre [] + [ + a [ A.href "/vfs/" ] [ txt "/vfs" ]; + txt " (GET) to access a VFS embedded in the binary"; + ]; + ]; + ]; + ]; + ] + in + let s = to_string_top h in + S.Response.make_string ~headers:[ "content-type", "text/html" ] @@ Ok s); Printf.printf "listening on http://%s:%d\n%!" (S.addr server) (S.port server); match S.run server with diff --git a/examples/sse_client.ml b/examples/sse_client.ml index 9ba011e4..afe4191f 100644 --- a/examples/sse_client.ml +++ b/examples/sse_client.ml @@ -1,15 +1,20 @@ let addr = ref "127.0.0.1" let port = ref 8080 let path = ref "/clock" - let bufsize = 1024 let () = - Arg.parse (Arg.align [ - "-h", Arg.Set_string addr, " address to connect to"; - "-p", Arg.Set_int port, " port to connect to"; - "--alarm", Arg.Int (fun i->Unix.alarm i|>ignore), " set alarm (in seconds)"; - ]) (fun s -> path := s) "sse_client [opt]* path?"; + Arg.parse + (Arg.align + [ + "-h", Arg.Set_string addr, " address to connect to"; + "-p", Arg.Set_int port, " port to connect to"; + ( "--alarm", + Arg.Int (fun i -> Unix.alarm i |> ignore), + " set alarm (in seconds)" ); + ]) + (fun s -> path := s) + "sse_client [opt]* path?"; Format.printf "connect to %s:%d@." !addr !port; let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in @@ -25,7 +30,8 @@ let () = let buf = Bytes.create bufsize in while !continue do let n = input ic buf 0 bufsize in - if n=0 then continue := false; - output stdout buf 0 n; flush stdout + if n = 0 then continue := false; + output stdout buf 0 n; + flush stdout done; Format.printf "exit!@." diff --git a/examples/sse_server.ml b/examples/sse_server.ml index fb1ede07..a12ad290 100644 --- a/examples/sse_server.ml +++ b/examples/sse_server.ml @@ -1,4 +1,3 @@ - (* serves some streams of events *) module S = Tiny_httpd @@ -6,57 +5,68 @@ module S = Tiny_httpd let port = ref 8080 let () = - Arg.parse (Arg.align [ - "-p", Arg.Set_int port, " port to listen on"; - "--debug", Arg.Bool S._enable_debug, " toggle debug"; - ]) (fun _ -> ()) "sse_clock [opt*]"; + Arg.parse + (Arg.align + [ + "-p", Arg.Set_int port, " port to listen on"; + "--debug", Arg.Bool S._enable_debug, " toggle debug"; + ]) + (fun _ -> ()) + "sse_clock [opt*]"; let server = S.create ~port:!port () in - let extra_headers = [ - "Access-Control-Allow-Origin", "*"; - "Access-Control-Allow-Methods", "POST, GET, OPTIONS"; - ] in + let extra_headers = + [ + "Access-Control-Allow-Origin", "*"; + "Access-Control-Allow-Methods", "POST, GET, OPTIONS"; + ] + in (* tick/tock goes the clock *) - S.add_route_server_sent_handler server S.Route.(exact "clock" @/ return) + S.add_route_server_sent_handler server + S.Route.(exact "clock" @/ return) (fun _req (module EV : S.SERVER_SENT_GENERATOR) -> - S._debug (fun k->k"new connection"); - EV.set_headers extra_headers; - let tick = ref true in - while true do - let now = Ptime_clock.now() in - S._debug (fun k->k"send clock ev %s" (Format.asprintf "%a" Ptime.pp now)); - EV.send_event ~event:(if !tick then "tick" else "tock") - ~data:(Ptime.to_rfc3339 now) (); - tick := not !tick; + S._debug (fun k -> k "new connection"); + EV.set_headers extra_headers; + let tick = ref true in + while true do + let now = Ptime_clock.now () in + S._debug (fun k -> + k "send clock ev %s" (Format.asprintf "%a" Ptime.pp now)); + EV.send_event + ~event: + (if !tick then + "tick" + else + "tock") + ~data:(Ptime.to_rfc3339 now) (); + tick := not !tick; - Unix.sleepf 1.0; - done; - ); + Unix.sleepf 1.0 + done); (* just count *) - S.add_route_server_sent_handler server S.Route.(exact "count" @/ return) - (fun _req (module EV : S.SERVER_SENT_GENERATOR) -> - let n = ref 0 in - while true do - EV.send_event ~data:(string_of_int !n) (); - incr n; - Unix.sleepf 0.1; - done; - ); - S.add_route_server_sent_handler server S.Route.(exact "count" @/ int @/ return) - (fun n _req (module EV : S.SERVER_SENT_GENERATOR) -> - for i=0 to n do - EV.send_event ~data:(string_of_int i) (); - Unix.sleepf 0.1; - done; - EV.close(); - ); + S.add_route_server_sent_handler server + S.Route.(exact "count" @/ return) + (fun _req (module EV : S.SERVER_SENT_GENERATOR) -> + let n = ref 0 in + while true do + EV.send_event ~data:(string_of_int !n) (); + incr n; + Unix.sleepf 0.1 + done); + S.add_route_server_sent_handler server + S.Route.(exact "count" @/ int @/ return) + (fun n _req (module EV : S.SERVER_SENT_GENERATOR) -> + for i = 0 to n do + EV.send_event ~data:(string_of_int i) (); + Unix.sleepf 0.1 + done; + EV.close ()); Printf.printf "listening on http://localhost:%d/\n%!" (S.port server); match S.run server with | Ok () -> () | Error e -> - Printf.eprintf "error: %s\n%!" (Printexc.to_string e); exit 1 - - + Printf.eprintf "error: %s\n%!" (Printexc.to_string e); + exit 1 diff --git a/src/Tiny_httpd.ml b/src/Tiny_httpd.ml index dab6d09a..784f7de7 100644 --- a/src/Tiny_httpd.ml +++ b/src/Tiny_httpd.ml @@ -1,4 +1,3 @@ - (** Tiny Httpd. A small HTTP/1.1 server, in pure OCaml, along with some utilities @@ -8,13 +7,8 @@ *) module Buf = Tiny_httpd_buf - module Byte_stream = Tiny_httpd_stream - include Tiny_httpd_server - module Util = Tiny_httpd_util - module Dir = Tiny_httpd_dir - module Html = Tiny_httpd_html diff --git a/src/Tiny_httpd.mli b/src/Tiny_httpd.mli index a337ec60..c38e4665 100644 --- a/src/Tiny_httpd.mli +++ b/src/Tiny_httpd.mli @@ -1,4 +1,3 @@ - (** {1 Tiny Http Server} This library implements a very simple, basic HTTP/1.1 server using blocking @@ -74,7 +73,6 @@ echo: *) - (** {2 Tiny buffer implementation} These buffers are used to avoid allocating too many byte arrays when @@ -93,7 +91,9 @@ module Byte_stream = Tiny_httpd_stream (** {2 Main Server Type} *) (** @inline *) -include module type of struct include Tiny_httpd_server end +include module type of struct + include Tiny_httpd_server +end (** {2 Utils} *) diff --git a/src/Tiny_httpd_buf.ml b/src/Tiny_httpd_buf.ml index dda9b653..2c706180 100644 --- a/src/Tiny_httpd_buf.ml +++ b/src/Tiny_httpd_buf.ml @@ -1,18 +1,12 @@ +type t = { mutable bytes: bytes; mutable i: int } -type t = { - mutable bytes: bytes; - mutable i: int; -} - -let create ?(size=4_096) () : t = - { bytes=Bytes.make size ' '; i=0 } - +let create ?(size = 4_096) () : t = { bytes = Bytes.make size ' '; i = 0 } let size self = self.i let bytes_slice self = self.bytes + let clear self : unit = - if Bytes.length self.bytes > 4_096 * 1_024 then ( - self.bytes <- Bytes.make 4096 ' '; (* free big buffer *) - ); + if Bytes.length self.bytes > 4_096 * 1_024 then + self.bytes <- Bytes.make 4096 ' ' (* free big buffer *); self.i <- 0 let resize self new_size : unit = @@ -20,16 +14,15 @@ let resize self new_size : unit = Bytes.blit self.bytes 0 new_buf 0 self.i; self.bytes <- new_buf -let add_bytes (self:t) s i len : unit = - if self.i + len >= Bytes.length self.bytes then ( - resize self (self.i + self.i / 2 + len + 10); - ); +let add_bytes (self : t) s i len : unit = + if self.i + len >= Bytes.length self.bytes then + resize self (self.i + (self.i / 2) + len + 10); Bytes.blit s i self.bytes self.i len; self.i <- self.i + len -let contents (self:t) : string = Bytes.sub_string self.bytes 0 self.i +let contents (self : t) : string = Bytes.sub_string self.bytes 0 self.i -let contents_and_clear (self:t) : string = +let contents_and_clear (self : t) : string = let x = contents self in clear self; x diff --git a/src/Tiny_httpd_buf.mli b/src/Tiny_httpd_buf.mli index aa93551f..b500ccaf 100644 --- a/src/Tiny_httpd_buf.mli +++ b/src/Tiny_httpd_buf.mli @@ -1,4 +1,3 @@ - (** Simple buffer. These buffers are used to avoid allocating too many byte arrays when @@ -8,6 +7,7 @@ *) type t + val size : t -> int val clear : t -> unit val create : ?size:int -> unit -> t @@ -24,4 +24,3 @@ val contents_and_clear : t -> string val add_bytes : t -> bytes -> int -> int -> unit (** Append given bytes slice to the buffer. @since 0.5 *) - diff --git a/src/Tiny_httpd_dir.ml b/src/Tiny_httpd_dir.ml index 34a5ca03..88754835 100644 --- a/src/Tiny_httpd_dir.ml +++ b/src/Tiny_httpd_dir.ml @@ -3,62 +3,73 @@ module U = Tiny_httpd_util module Html = Tiny_httpd_html module Pf = Printf -type dir_behavior = - | Index | Lists | Index_or_lists | Forbidden - +type dir_behavior = Index | Lists | Index_or_lists | Forbidden type hidden = unit + type config = { mutable download: bool; mutable dir_behavior: dir_behavior; mutable delete: bool; mutable upload: bool; mutable max_upload_size: int; - _rest: hidden + _rest: hidden; } let default_config_ : config = - { download=true; - dir_behavior=Forbidden; - delete=false; - upload=false; + { + download = true; + dir_behavior = Forbidden; + delete = false; + upload = false; max_upload_size = 10 * 1024 * 1024; - _rest=(); + _rest = (); } let default_config () = default_config_ -let config - ?(download=default_config_.download) - ?(dir_behavior=default_config_.dir_behavior) - ?(delete=default_config_.delete) - ?(upload=default_config_.upload) - ?(max_upload_size=default_config_.max_upload_size) - () : config = - { download; dir_behavior; delete; upload; max_upload_size; - _rest=()} + +let config ?(download = default_config_.download) + ?(dir_behavior = default_config_.dir_behavior) + ?(delete = default_config_.delete) ?(upload = default_config_.upload) + ?(max_upload_size = default_config_.max_upload_size) () : config = + { download; dir_behavior; delete; upload; max_upload_size; _rest = () } let contains_dot_dot s = try String.iteri (fun i c -> - if c='.' && i+1 < String.length s && String.get s (i+1) = '.' then raise Exit) + if c = '.' && i + 1 < String.length s && String.get s (i + 1) = '.' then + raise Exit) s; false with Exit -> true (* Human readable size *) -let human_size (x:int) : string = - if x >= 1_000_000_000 then Printf.sprintf "%d.%dG" (x / 1_000_000_000) ((x/1_000_000) mod 1_000_000) - else if x >= 1_000_000 then Printf.sprintf "%d.%dM" (x / 1_000_000) ((x/1000) mod 1_000) - else if x >= 1_000 then Printf.sprintf "%d.%dk" (x/1000) ((x/100) mod 100) - else Printf.sprintf "%db" x +let human_size (x : int) : string = + if x >= 1_000_000_000 then + Printf.sprintf "%d.%dG" (x / 1_000_000_000) (x / 1_000_000 mod 1_000_000) + else if x >= 1_000_000 then + Printf.sprintf "%d.%dM" (x / 1_000_000) (x / 1000 mod 1_000) + else if x >= 1_000 then + Printf.sprintf "%d.%dk" (x / 1000) (x / 100 mod 100) + else + Printf.sprintf "%db" x let header_html = "Content-Type", "text/html" -let (//) = Filename.concat +let ( // ) = Filename.concat -let encode_path s = U.percent_encode ~skip:(function '/' -> true|_->false) s -let _decode_path s = match U.percent_decode s with Some s->s | None -> s +let encode_path s = + U.percent_encode + ~skip:(function + | '/' -> true + | _ -> false) + s -let is_hidden s = String.length s>0 && s.[0] = '.' +let _decode_path s = + match U.percent_decode s with + | Some s -> s + | None -> s + +let is_hidden s = String.length s > 0 && s.[0] = '.' module type VFS = sig val descr : string @@ -74,42 +85,46 @@ end type vfs = (module VFS) -let vfs_of_dir (top:string) : vfs = +let vfs_of_dir (top : string) : vfs = let module M = struct let descr = top - let (//) = Filename.concat + let ( // ) = Filename.concat let is_directory f = Sys.is_directory (top // f) let contains f = Sys.file_exists (top // f) let list_dir f = Sys.readdir (top // f) + let read_file_content f = - let ic = Unix.(openfile (top // f) [O_RDONLY] 0) in + let ic = Unix.(openfile (top // f) [ O_RDONLY ] 0) in Tiny_httpd_stream.of_fd ic + let create f = let oc = open_out_bin (top // f) in let write = output oc in - let close() = close_out oc in + let close () = close_out oc in write, close + let delete f = Sys.remove (top // f) + let file_size f = - try Some (Unix.stat (top // f)).Unix.st_size - with _ -> None + try Some (Unix.stat (top // f)).Unix.st_size with _ -> None + let file_mtime f = - try Some (Unix.stat (top // f)).Unix.st_mtime - with _ -> None + try Some (Unix.stat (top // f)).Unix.st_mtime with _ -> None end in (module M) -let html_list_dir (module VFS:VFS) ~prefix ~parent d : Html.elt = +let html_list_dir (module VFS : VFS) ~prefix ~parent d : Html.elt = let entries = VFS.list_dir d in Array.sort String.compare entries; let open Html in - (* TODO: breadcrumbs for the path, each element a link to the given ancestor dir *) let head = - head[][ - title[][txtf "list directory %S" VFS.descr]; - meta[A.charset "utf-8"]; - ] in + head [] + [ + title [] [ txtf "list directory %S" VFS.descr ]; + meta [ A.charset "utf-8" ]; + ] + in let n_hidden = ref 0 in Array.iter (fun f -> if is_hidden f then incr n_hidden) entries; @@ -117,51 +132,70 @@ let html_list_dir (module VFS:VFS) ~prefix ~parent d : Html.elt = let file_to_elt f : elt option = if not @@ contains_dot_dot (d // f) then ( let fpath = d // f in - if not @@ VFS.contains fpath then ( - Some (li[][txtf "%s [invalid file]" f]) - ) else ( + if not @@ VFS.contains fpath then + Some (li [] [ txtf "%s [invalid file]" f ]) + else ( let size = match VFS.file_size fpath with | Some f -> Printf.sprintf " (%s)" @@ human_size f | None -> "" in - Some (li'[] [ - sub_e @@ a[A.href ("/" // prefix // fpath)][txt f]; - (if VFS.is_directory fpath then sub_e @@ txt "[dir]" else sub_empty); - sub_e @@ txt size; - ]) + Some + (li' [] + [ + sub_e @@ a [ A.href ("/" // prefix // fpath) ] [ txt f ]; + (if VFS.is_directory fpath then + sub_e @@ txt "[dir]" + else + sub_empty); + sub_e @@ txt size; + ]) ) - ) else None + ) else + None in - let body = body'[] [ - sub_e @@ h2[][txtf "Index of %S" d]; - begin match parent with - | None -> sub_empty - | Some p -> - sub_e @@ - a[A.href (encode_path ("/" // prefix // p))][txt"(parent directory)"] - end; - - sub_e @@ ul' [] [ - if !n_hidden>0 then - sub_e @@ details'[][ - sub_e @@ summary[][txtf "(%d hidden files)" !n_hidden]; - sub_seq ( - seq_of_array entries - |> Seq.filter_map - (fun f -> if is_hidden f then file_to_elt f else None) - ); - ] else sub_empty; - sub_seq ( - seq_of_array entries - |> Seq.filter_map (fun f -> - if not (is_hidden f) then file_to_elt f else None) - ) - ]; - ] + let body = + body' [] + [ + sub_e @@ h2 [] [ txtf "Index of %S" d ]; + (match parent with + | None -> sub_empty + | Some p -> + sub_e + @@ a + [ A.href (encode_path ("/" // prefix // p)) ] + [ txt "(parent directory)" ]); + sub_e + @@ ul' [] + [ + (if !n_hidden > 0 then + sub_e + @@ details' [] + [ + sub_e + @@ summary [] [ txtf "(%d hidden files)" !n_hidden ]; + sub_seq + (seq_of_array entries + |> Seq.filter_map (fun f -> + if is_hidden f then + file_to_elt f + else + None)); + ] + else + sub_empty); + sub_seq + (seq_of_array entries + |> Seq.filter_map (fun f -> + if not (is_hidden f) then + file_to_elt f + else + None)); + ]; + ] in - html [][head; body] + html [] [ head; body ] let finally_ ~h x f = try @@ -173,120 +207,135 @@ let finally_ ~h x f = raise e (* @param on_fs: if true, we assume the file exists on the FS *) -let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS:VFS) as vfs) ~prefix server : unit= - +let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server + : unit = let route () = - if prefix="" then S.Route.rest_of_path_urlencoded - else S.Route.exact_path prefix S.Route.rest_of_path_urlencoded + if prefix = "" then + S.Route.rest_of_path_urlencoded + else + S.Route.exact_path prefix S.Route.rest_of_path_urlencoded in - if config.delete then ( - S.add_route_handler server ~meth:`DELETE (route()) - (fun path _req -> - if contains_dot_dot path then ( - S.Response.fail_raise ~code:403 "invalid path in delete" - ) else ( - S.Response.make_string - (try - VFS.delete path; Ok "file deleted successfully" - with e -> Error (500, Printexc.to_string e)) - ) - ); - ) else ( - S.add_route_handler server ~meth:`DELETE (route()) - (fun _ _ -> S.Response.make_raw ~code:405 "delete not allowed"); - ); + if config.delete then + S.add_route_handler server ~meth:`DELETE (route ()) (fun path _req -> + if contains_dot_dot path then + S.Response.fail_raise ~code:403 "invalid path in delete" + else + S.Response.make_string + (try + VFS.delete path; + Ok "file deleted successfully" + with e -> Error (500, Printexc.to_string e))) + else + S.add_route_handler server ~meth:`DELETE (route ()) (fun _ _ -> + S.Response.make_raw ~code:405 "delete not allowed"); - if config.upload then ( - S.add_route_handler_stream server ~meth:`PUT (route()) + if config.upload then + S.add_route_handler_stream server ~meth:`PUT (route ()) ~accept:(fun req -> - match S.Request.get_header_int req "Content-Length" with - | Some n when n > config.max_upload_size -> - Error (403, "max upload size is " ^ string_of_int config.max_upload_size) - | Some _ when contains_dot_dot req.S.Request.path -> - Error (403, "invalid path (contains '..')") - | _ -> Ok () - ) + match S.Request.get_header_int req "Content-Length" with + | Some n when n > config.max_upload_size -> + Error + (403, "max upload size is " ^ string_of_int config.max_upload_size) + | Some _ when contains_dot_dot req.S.Request.path -> + Error (403, "invalid path (contains '..')") + | _ -> Ok ()) (fun path req -> - let write, close = - try VFS.create path - with e -> - S.Response.fail_raise ~code:403 "cannot upload to %S: %s" - path (Printexc.to_string e) - in - let req = S.Request.limit_body_size ~max_size:config.max_upload_size req in - Tiny_httpd_stream.iter write req.S.Request.body; - close (); - S._debug (fun k->k "done uploading"); - S.Response.make_raw ~code:201 "upload successful" - ) - ) else ( - S.add_route_handler server ~meth:`PUT (route()) - (fun _ _ -> S.Response.make_raw ~code:405 "upload not allowed"); - ); + let write, close = + try VFS.create path + with e -> + S.Response.fail_raise ~code:403 "cannot upload to %S: %s" path + (Printexc.to_string e) + in + let req = + S.Request.limit_body_size ~max_size:config.max_upload_size req + in + Tiny_httpd_stream.iter write req.S.Request.body; + close (); + S._debug (fun k -> k "done uploading"); + S.Response.make_raw ~code:201 "upload successful") + else + S.add_route_handler server ~meth:`PUT (route ()) (fun _ _ -> + S.Response.make_raw ~code:405 "upload not allowed"); - if config.download then ( - S.add_route_handler server ~meth:`GET (route()) - (fun path req -> - S._debug (fun k->k "path=%S" path); - let mtime = lazy ( - match VFS.file_mtime path with - | None -> S.Response.fail_raise ~code:403 "Cannot access file" - | Some t -> Printf.sprintf "mtime: %.4f" t - ) in - if contains_dot_dot path then ( - S.Response.fail ~code:403 "Path is forbidden"; - ) else if not (VFS.contains path) then ( - S.Response.fail ~code:404 "File not found"; - ) else if S.Request.get_header req "If-None-Match" = Some (Lazy.force mtime) then ( - S._debug (fun k->k "cached object %S (etag: %S)" path (Lazy.force mtime)); - S.Response.make_raw ~code:304 "" - ) else if VFS.is_directory path then ( - S._debug (fun k->k "list dir %S (topdir %S)" path VFS.descr); - let parent = Filename.(dirname path) in - let parent = if Filename.basename path <> "." then Some parent else None in - match config.dir_behavior with - | Index | Index_or_lists when VFS.contains (path // "index.html") -> - (* redirect using path, not full path *) - let new_path = "/" // prefix // path // "index.html" in - S._debug (fun k->k "redirect to `%s`" new_path); - S.Response.make_void ~code:301 () - ~headers:S.Headers.(empty |> set "location" new_path) - | Lists | Index_or_lists -> - let body = html_list_dir ~prefix vfs path ~parent |> Html.to_string_top in - S.Response.make_string - ~headers:[header_html; "ETag", Lazy.force mtime] - (Ok body) - | Forbidden | Index -> - S.Response.make_raw ~code:405 "listing dir not allowed" - ) else ( - try - let mime_type = - if Filename.extension path = ".css" then ( - ["Content-Type", "text/css"] - ) else if Filename.extension path = ".js" then ( - ["Content-Type", "text/javascript"] - ) else if on_fs then ( - (* call "file" util *) - try - let p = Unix.open_process_in (Printf.sprintf "file -i -b %S" (top // path)) in - finally_ ~h:(fun p->ignore @@ Unix.close_process_in p) p - (fun p -> - try ["Content-Type", String.trim (input_line p)] - with _ -> []) - with _ -> [] - ) else [] - in - let stream = VFS.read_file_content path in - S.Response.make_raw_stream - ~headers:(mime_type@["Etag", Lazy.force mtime]) - ~code:200 stream - with e -> - S.Response.fail ~code:500 "error while reading file: %s" (Printexc.to_string e)) - ) - ) else ( - S.add_route_handler server ~meth:`GET (route()) - (fun _ _ -> S.Response.make_raw ~code:405 "download not allowed"); - ); + if config.download then + S.add_route_handler server ~meth:`GET (route ()) (fun path req -> + S._debug (fun k -> k "path=%S" path); + let mtime = + lazy + (match VFS.file_mtime path with + | None -> S.Response.fail_raise ~code:403 "Cannot access file" + | Some t -> Printf.sprintf "mtime: %.4f" t) + in + if contains_dot_dot path then + S.Response.fail ~code:403 "Path is forbidden" + else if not (VFS.contains path) then + S.Response.fail ~code:404 "File not found" + else if + S.Request.get_header req "If-None-Match" = Some (Lazy.force mtime) + then ( + S._debug (fun k -> + k "cached object %S (etag: %S)" path (Lazy.force mtime)); + S.Response.make_raw ~code:304 "" + ) else if VFS.is_directory path then ( + S._debug (fun k -> k "list dir %S (topdir %S)" path VFS.descr); + let parent = Filename.(dirname path) in + let parent = + if Filename.basename path <> "." then + Some parent + else + None + in + match config.dir_behavior with + | (Index | Index_or_lists) when VFS.contains (path // "index.html") -> + (* redirect using path, not full path *) + let new_path = "/" // prefix // path // "index.html" in + S._debug (fun k -> k "redirect to `%s`" new_path); + S.Response.make_void ~code:301 () + ~headers:S.Headers.(empty |> set "location" new_path) + | Lists | Index_or_lists -> + let body = + html_list_dir ~prefix vfs path ~parent |> Html.to_string_top + in + S.Response.make_string + ~headers:[ header_html; "ETag", Lazy.force mtime ] + (Ok body) + | Forbidden | Index -> + S.Response.make_raw ~code:405 "listing dir not allowed" + ) else ( + try + let mime_type = + if Filename.extension path = ".css" then + [ "Content-Type", "text/css" ] + else if Filename.extension path = ".js" then + [ "Content-Type", "text/javascript" ] + else if on_fs then ( + (* call "file" util *) + try + let p = + Unix.open_process_in + (Printf.sprintf "file -i -b %S" (top // path)) + in + finally_ + ~h:(fun p -> ignore @@ Unix.close_process_in p) + p + (fun p -> + try [ "Content-Type", String.trim (input_line p) ] + with _ -> []) + with _ -> [] + ) else + [] + in + let stream = VFS.read_file_content path in + S.Response.make_raw_stream + ~headers:(mime_type @ [ "Etag", Lazy.force mtime ]) + ~code:200 stream + with e -> + S.Response.fail ~code:500 "error while reading file: %s" + (Printexc.to_string e) + )) + else + S.add_route_handler server ~meth:`GET (route ()) (fun _ _ -> + S.Response.make_raw ~code:405 "download not allowed"); () let add_vfs ~config ~vfs ~prefix server : unit = @@ -296,43 +345,38 @@ let add_dir_path ~config ~dir ~prefix server : unit = add_vfs_ ~on_fs:true ~top:dir ~config ~prefix ~vfs:(vfs_of_dir dir) server module Embedded_fs = struct - module Str_map = Map.Make(String) + module Str_map = Map.Make (String) - type t = { - mtime: float; - mutable entries: entry Str_map.t - } + type t = { mtime: float; mutable entries: entry Str_map.t } + and entry = File of { content: string; mtime: float } | Dir of t - and entry = - | File of { - content: string; - mtime: float; - } - | Dir of t + let create ?(mtime = Unix.gettimeofday ()) () : t = + { mtime; entries = Str_map.empty } - let create ?(mtime=Unix.gettimeofday()) () : t = { - mtime; - entries=Str_map.empty; - } - - let split_path_ (path:string) : string list * string = + let split_path_ (path : string) : string list * string = let basename = Filename.basename path in let dirname = - Filename.dirname path - |> String.split_on_char '/' - |> List.filter (function "" | "." -> false | _ -> true) in + Filename.dirname path |> String.split_on_char '/' + |> List.filter (function + | "" | "." -> false + | _ -> true) + in dirname, basename - let add_file ?mtime (self:t) ~path content : unit = - let mtime = match mtime with Some t -> t | None -> self.mtime in + let add_file ?mtime (self : t) ~path content : unit = + let mtime = + match mtime with + | Some t -> t + | None -> self.mtime + in let dir_path, basename = split_path_ path in - if List.mem ".." dir_path then ( - invalid_arg "add_file: '..' is not allowed"; - ); + if List.mem ".." dir_path then invalid_arg "add_file: '..' is not allowed"; - let rec loop self dir = match dir with + let rec loop self dir = + match dir with | [] -> - self.entries <- Str_map.add basename (File {mtime; content}) self.entries + self.entries <- + Str_map.add basename (File { mtime; content }) self.entries | d :: ds -> let sub = match Str_map.find d self.entries with @@ -352,49 +396,61 @@ module Embedded_fs = struct (* find entry *) let find_ self path : entry option = let dir_path, basename = split_path_ path in - let rec loop self dir_name = match dir_name with + let rec loop self dir_name = + match dir_name with | [] -> (try Some (Str_map.find basename self.entries) with _ -> None) | d :: ds -> - match Str_map.find d self.entries with + (match Str_map.find d self.entries with | exception Not_found -> None | File _ -> None - | Dir sub -> loop sub ds + | Dir sub -> loop sub ds) in - if path="" then Some (Dir self) - else loop self dir_path + if path = "" then + Some (Dir self) + else + loop self dir_path let to_vfs self : vfs = let module M = struct let descr = "Embedded_fs" - let file_mtime p = match find_ self p with - | Some (File {mtime;_}) -> Some mtime + + let file_mtime p = + match find_ self p with + | Some (File { mtime; _ }) -> Some mtime | Some (Dir _) -> Some self.mtime | _ -> None - let file_size p = match find_ self p with - | Some (File {content;_}) -> Some (String.length content) + let file_size p = + match find_ self p with + | Some (File { content; _ }) -> Some (String.length content) | _ -> None - let contains p = S._debug (fun k->k "contains %S" p); match find_ self p with + let contains p = + S._debug (fun k -> k "contains %S" p); + match find_ self p with | Some _ -> true | None -> false - let is_directory p = match find_ self p with + let is_directory p = + match find_ self p with | Some (Dir _) -> true | _ -> false - let read_file_content p = match find_ self p with - | Some (File {content;_}) -> Tiny_httpd_stream.of_string content + let read_file_content p = + match find_ self p with + | Some (File { content; _ }) -> Tiny_httpd_stream.of_string content | _ -> failwith (Printf.sprintf "no such file: %S" p) - let list_dir p = S._debug (fun k->k "list dir %S" p); match find_ self p with + let list_dir p = + S._debug (fun k -> k "list dir %S" p); + match find_ self p with | Some (Dir sub) -> - Str_map.fold (fun sub _ acc -> sub::acc) sub.entries [] |> Array.of_list + Str_map.fold (fun sub _ acc -> sub :: acc) sub.entries [] + |> Array.of_list | _ -> failwith (Printf.sprintf "no such directory: %S" p) let create _ = failwith "Embedded_fs is read-only" let delete _ = failwith "Embedded_fs is read-only" - - end in (module M) - + end in + (module M) end diff --git a/src/Tiny_httpd_dir.mli b/src/Tiny_httpd_dir.mli index 34e622fd..9590bd60 100644 --- a/src/Tiny_httpd_dir.mli +++ b/src/Tiny_httpd_dir.mli @@ -1,4 +1,3 @@ - (** Serving static content from directories This module provides the same functionality as the "http_of_dir" tool. @@ -12,44 +11,35 @@ This controls what happens when the user requests the path to a directory rather than a file. *) type dir_behavior = - | Index - (** Redirect to index.html if present, else fails. *) + | Index (** Redirect to index.html if present, else fails. *) | Lists - (** Lists content of directory. Be careful of security implications. *) + (** Lists content of directory. Be careful of security implications. *) | Index_or_lists - (** Redirect to index.html if present and lists content otherwise. + (** Redirect to index.html if present and lists content otherwise. This is useful for tilde ("~") directories and other per-user behavior, but be mindful of security implications *) | Forbidden - (** Forbid access to directory. This is suited for serving assets, for example. *) + (** Forbid access to directory. This is suited for serving assets, for example. *) type hidden (** Type used to prevent users from building a config directly. Use {!default_config} or {!config} instead. *) +type config = { + mutable download: bool; (** Is downloading files allowed? *) + mutable dir_behavior: dir_behavior; + (** Behavior when serving a directory and not a file *) + mutable delete: bool; (** Is deleting a file allowed? (with method DELETE) *) + mutable upload: bool; (** Is uploading a file allowed? (with method PUT) *) + mutable max_upload_size: int; + (** If {!upload} is true, this is the maximum size in bytes for + uploaded files. *) + _rest: hidden; (** Just ignore this field. *) +} (** configuration for static file handlers. This might get more fields over time. *) -type config = { - mutable download: bool; - (** Is downloading files allowed? *) - - mutable dir_behavior: dir_behavior; - (** Behavior when serving a directory and not a file *) - - mutable delete: bool; - (** Is deleting a file allowed? (with method DELETE) *) - - mutable upload: bool; - (** Is uploading a file allowed? (with method PUT) *) - - mutable max_upload_size: int; - (** If {!upload} is true, this is the maximum size in bytes for - uploaded files. *) - - _rest: hidden; - (** Just ignore this field. *) -} +val default_config : unit -> config (** default configuration: [ { download=true ; dir_behavior=Forbidden @@ -57,7 +47,6 @@ type config = { ; upload=false ; max_upload_size = 10 * 1024 * 1024 }] *) -val default_config : unit -> config val config : ?download:bool -> @@ -70,14 +59,11 @@ val config : (** Build a config from {!default_config}. @since 0.12 *) +val add_dir_path : + config:config -> dir:string -> prefix:string -> Tiny_httpd_server.t -> unit (** [add_dirpath ~config ~dir ~prefix server] adds route handle to the [server] to serve static files in [dir] when url starts with [prefix], using the given configuration [config]. *) -val add_dir_path : - config:config -> - dir:string -> - prefix:string -> - Tiny_httpd_server.t -> unit (** Virtual file system. @@ -125,7 +111,8 @@ val add_vfs : config:config -> vfs:(module VFS) -> prefix:string -> - Tiny_httpd_server.t -> unit + Tiny_httpd_server.t -> + unit (** Similar to {!add_dir_path} but using a virtual file system instead. @since 0.12 *) diff --git a/src/Tiny_httpd_html.ml b/src/Tiny_httpd_html.ml index 987798d7..4a6532f2 100644 --- a/src/Tiny_httpd_html.ml +++ b/src/Tiny_httpd_html.ml @@ -1,4 +1,3 @@ - (** HTML combinators. This module provides combinators to produce html. It doesn't enforce @@ -7,13 +6,13 @@ @since 0.12 *) -(** @inline *) include Tiny_httpd_html_ +(** @inline *) (** Convert a HTML element to a string. @param top if true, add DOCTYPE at the beginning. The top element should then be a "html" tag. *) -let to_string ?(top=false) (self:elt) : string = +let to_string ?(top = false) (self : elt) : string = let out = Out.create () in if top then Out.add_string out "\n"; self out; @@ -23,14 +22,18 @@ let to_string ?(top=false) (self:elt) : string = This is designed for fragments of HTML that are to be injected inside a bigger context, as it's invalid to have multiple elements at the toplevel of a HTML document. *) -let to_string_l (l:elt list) = +let to_string_l (l : elt list) = let out = Out.create () in - List.iter (fun f -> f out; Out.add_format_nl out) l; + List.iter + (fun f -> + f out; + Out.add_format_nl out) + l; Out.to_string out let to_string_top = to_string ~top:true (** Convert a HTML element to a stream. This might just convert it to a string first, do not assume it to be more efficient. *) -let to_stream (self:elt) : Tiny_httpd_stream.t = +let to_stream (self : elt) : Tiny_httpd_stream.t = Tiny_httpd_stream.of_string @@ to_string self diff --git a/src/Tiny_httpd_server.ml b/src/Tiny_httpd_server.ml index 20608a4a..43b7cfd5 100644 --- a/src/Tiny_httpd_server.ml +++ b/src/Tiny_httpd_server.ml @@ -1,31 +1,34 @@ - type buf = Tiny_httpd_buf.t type byte_stream = Tiny_httpd_stream.t -let _debug_on = ref ( - match String.trim @@ Sys.getenv "HTTP_DBG" with - | "" -> false | _ -> true | exception _ -> false -) +let _debug_on = + ref + (match String.trim @@ Sys.getenv "HTTP_DBG" with + | "" -> false + | _ -> true + | exception _ -> false) + let _enable_debug b = _debug_on := b + let _debug k = - if !_debug_on then ( - k (fun fmt-> - Printf.fprintf stdout "[http.thread %d]: " Thread.(id @@ self()); - Printf.kfprintf (fun oc -> Printf.fprintf oc "\n%!") stdout fmt) - ) + if !_debug_on then + k (fun fmt -> + Printf.fprintf stdout "[http.thread %d]: " Thread.(id @@ self ()); + Printf.kfprintf (fun oc -> Printf.fprintf oc "\n%!") stdout fmt) module Buf = Tiny_httpd_buf - module Byte_stream = Tiny_httpd_stream exception Bad_req of int * string -let bad_reqf c fmt = Printf.ksprintf (fun s ->raise (Bad_req (c,s))) fmt + +let bad_reqf c fmt = Printf.ksprintf (fun s -> raise (Bad_req (c, s))) fmt module Response_code = struct type t = int let ok = 200 let not_found = 404 + let descr = function | 100 -> "Continue" | 200 -> "OK" @@ -53,19 +56,13 @@ module Response_code = struct end type 'a resp_result = ('a, Response_code.t * string) result + let unwrap_resp_result = function | Ok x -> x - | Error (c,s) -> raise (Bad_req (c,s)) + | Error (c, s) -> raise (Bad_req (c, s)) module Meth = struct - type t = [ - | `GET - | `PUT - | `POST - | `HEAD - | `DELETE - | `OPTIONS - ] + type t = [ `GET | `PUT | `POST | `HEAD | `DELETE | `OPTIONS ] let to_string = function | `GET -> "GET" @@ -74,6 +71,7 @@ module Meth = struct | `POST -> "POST" | `DELETE -> "DELETE" | `OPTIONS -> "OPTIONS" + let pp out s = Format.pp_print_string out (to_string s) let of_string = function @@ -88,57 +86,72 @@ end module Headers = struct type t = (string * string) list + let empty = [] + let contains name headers = let name' = String.lowercase_ascii name in - List.exists (fun (n, _) -> name'=n) headers - let get_exn ?(f=fun x->x) x h = + List.exists (fun (n, _) -> name' = n) headers + + let get_exn ?(f = fun x -> x) x h = let x' = String.lowercase_ascii x in List.assoc x' h |> f - let get ?(f=fun x -> x) x h = + + let get ?(f = fun x -> x) x h = try Some (get_exn ~f x h) with Not_found -> None + let remove x h = let x' = String.lowercase_ascii x in - List.filter (fun (k,_) -> k<>x') h + List.filter (fun (k, _) -> k <> x') h + let set x y h = let x' = String.lowercase_ascii x in - (x',y) :: List.filter (fun (k,_) -> k<>x') h + (x', y) :: List.filter (fun (k, _) -> k <> x') h + let pp out l = - let pp_pair out (k,v) = Format.fprintf out "@[%s: %s@]" k v in + let pp_pair out (k, v) = Format.fprintf out "@[%s: %s@]" k v in Format.fprintf out "@[%a@]" (Format.pp_print_list pp_pair) l - (* token = 1*tchar - tchar = "!" / "#" / "$" / "%" / "&" / "'" / "*" / "+" / "-" / "." / "^" / "_" - / "`" / "|" / "~" / DIGIT / ALPHA ; any VCHAR, except delimiters - Reference: https://datatracker.ietf.org/doc/html/rfc7230#section-3.2 *) + (* token = 1*tchar + tchar = "!" / "#" / "$" / "%" / "&" / "'" / "*" / "+" / "-" / "." / "^" / "_" + / "`" / "|" / "~" / DIGIT / ALPHA ; any VCHAR, except delimiters + Reference: https://datatracker.ietf.org/doc/html/rfc7230#section-3.2 *) let is_tchar = function - | '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' - | '!' | '#' | '$' | '%' | '&' | '\'' | '*' | '+' | '-' | '.' | '^' - | '_' | '`' | '|' | '~' -> true + | '0' .. '9' + | 'a' .. 'z' + | 'A' .. 'Z' + | '!' | '#' | '$' | '%' | '&' | '\'' | '*' | '+' | '-' | '.' | '^' | '_' + | '`' | '|' | '~' -> + true | _ -> false let for_all pred s = - try String.iter (fun c->if not (pred c) then raise Exit) s; true + try + String.iter (fun c -> if not (pred c) then raise Exit) s; + true with Exit -> false - let parse_ ~buf (bs:byte_stream) : t = + let parse_ ~buf (bs : byte_stream) : t = let rec loop acc = let line = Byte_stream.read_line ~buf bs in - _debug (fun k->k "parsed header line %S" line); - if line = "\r" then ( + _debug (fun k -> k "parsed header line %S" line); + if line = "\r" then acc - ) else ( - let k,v = + else ( + let k, v = try let i = String.index line ':' in let k = String.sub line 0 i in - if not (for_all is_tchar k) then ( - invalid_arg (Printf.sprintf "Invalid header key: %S" k)); - let v = String.sub line (i+1) (String.length line-i-1) |> String.trim in - k,v + if not (for_all is_tchar k) then + invalid_arg (Printf.sprintf "Invalid header key: %S" k); + let v = + String.sub line (i + 1) (String.length line - i - 1) + |> String.trim + in + k, v with _ -> bad_reqf 400 "invalid header line: %S" line in - loop ((String.lowercase_ascii k,v)::acc) + loop ((String.lowercase_ascii k, v) :: acc) ) in loop [] @@ -149,10 +162,10 @@ module Request = struct meth: Meth.t; host: string; headers: Headers.t; - http_version: int*int; + http_version: int * int; path: string; path_components: string list; - query: (string*string) list; + query: (string * string) list; body: 'body; start_time: float; } @@ -163,85 +176,90 @@ module Request = struct let path self = self.path let body self = self.body let start_time self = self.start_time - let query self = self.query let get_header ?f self h = Headers.get ?f h self.headers - let get_header_int self h = match get_header self h with + + let get_header_int self h = + match get_header self h with | Some x -> (try Some (int_of_string x) with _ -> None) | None -> None - let set_header k v self = {self with headers=Headers.set k v self.headers} - let update_headers f self = {self with headers=f self.headers} - let set_body b self = {self with body=b} + + let set_header k v self = { self with headers = Headers.set k v self.headers } + let update_headers f self = { self with headers = f self.headers } + let set_body b self = { self with body = b } (** Should we close the connection after this request? *) - let close_after_req (self:_ t) : bool = + let close_after_req (self : _ t) : bool = match self.http_version with - | 1, 1 -> get_header self "connection" =Some"close" - | 1, 0 -> not (get_header self "connection"=Some"keep-alive") + | 1, 1 -> get_header self "connection" = Some "close" + | 1, 0 -> not (get_header self "connection" = Some "keep-alive") | _ -> false let pp_comp_ out comp = Format.fprintf out "[%s]" (String.concat ";" @@ List.map (Printf.sprintf "%S") comp) + let pp_query out q = Format.fprintf out "[%s]" - (String.concat ";" @@ - List.map (fun (a,b) -> Printf.sprintf "%S,%S" a b) q) + (String.concat ";" + @@ List.map (fun (a, b) -> Printf.sprintf "%S,%S" a b) q) + let pp_ out self : unit = - Format.fprintf out "{@[meth=%s;@ host=%s;@ headers=[@[%a@]];@ \ - path=%S;@ body=?;@ path_components=%a;@ query=%a@]}" + Format.fprintf out + "{@[meth=%s;@ host=%s;@ headers=[@[%a@]];@ path=%S;@ body=?;@ \ + path_components=%a;@ query=%a@]}" (Meth.to_string self.meth) self.host Headers.pp self.headers self.path pp_comp_ self.path_components pp_query self.query + let pp out self : unit = - Format.fprintf out "{@[meth=%s;@ host=%s;@ headers=[@[%a@]];@ path=%S;@ \ - body=%S;@ path_components=%a;@ query=%a@]}" - (Meth.to_string self.meth) self.host Headers.pp self.headers - self.path self.body pp_comp_ self.path_components pp_query self.query + Format.fprintf out + "{@[meth=%s;@ host=%s;@ headers=[@[%a@]];@ path=%S;@ body=%S;@ \ + path_components=%a;@ query=%a@]}" + (Meth.to_string self.meth) self.host Headers.pp self.headers self.path + self.body pp_comp_ self.path_components pp_query self.query (* decode a "chunked" stream into a normal stream *) - let read_stream_chunked_ ?buf (bs:byte_stream) : byte_stream = - _debug (fun k->k "body: start reading chunked stream..."); - Byte_stream.read_chunked ?buf - ~fail:(fun s -> Bad_req (400, s)) - bs + let read_stream_chunked_ ?buf (bs : byte_stream) : byte_stream = + _debug (fun k -> k "body: start reading chunked stream..."); + Byte_stream.read_chunked ?buf ~fail:(fun s -> Bad_req (400, s)) bs - let limit_body_size_ ~max_size (bs:byte_stream) : byte_stream = - _debug (fun k->k "limit size of body to max-size=%d" max_size); + let limit_body_size_ ~max_size (bs : byte_stream) : byte_stream = + _debug (fun k -> k "limit size of body to max-size=%d" max_size); Byte_stream.limit_size_to ~max_size ~close_rec:false bs ~too_big:(fun size -> - (* read too much *) - bad_reqf 413 - "body size was supposed to be %d, but at least %d bytes received" - max_size size - ) + (* read too much *) + bad_reqf 413 + "body size was supposed to be %d, but at least %d bytes received" + max_size size) - let limit_body_size ~max_size (req:byte_stream t) : byte_stream t = - { req with body=limit_body_size_ ~max_size req.body } + let limit_body_size ~max_size (req : byte_stream t) : byte_stream t = + { req with body = limit_body_size_ ~max_size req.body } (* read exactly [size] bytes from the stream *) - let read_exactly ~size (bs:byte_stream) : byte_stream = - _debug (fun k->k "body: must read exactly %d bytes" size); - Byte_stream.read_exactly bs ~close_rec:false - ~size ~too_short:(fun size -> - bad_reqf 400 "body is too short by %d bytes" size - ) + let read_exactly ~size (bs : byte_stream) : byte_stream = + _debug (fun k -> k "body: must read exactly %d bytes" size); + Byte_stream.read_exactly bs ~close_rec:false ~size ~too_short:(fun size -> + bad_reqf 400 "body is too short by %d bytes" size) (* parse request, but not body (yet) *) - let parse_req_start ~get_time_s ~buf (bs:byte_stream) : unit t option resp_result = + let parse_req_start ~get_time_s ~buf (bs : byte_stream) : + unit t option resp_result = try let line = Byte_stream.read_line ~buf bs in - let start_time = get_time_s() in + let start_time = get_time_s () in let meth, path, version = try - let meth, path, version = Scanf.sscanf line "%s %s HTTP/1.%d\r" (fun x y z->x,y,z) in + let meth, path, version = + Scanf.sscanf line "%s %s HTTP/1.%d\r" (fun x y z -> x, y, z) + in if version != 0 && version != 1 then raise Exit; meth, path, version with _ -> - _debug (fun k->k "invalid request line: `%s`" line); + _debug (fun k -> k "invalid request line: `%s`" line); raise (Bad_req (400, "Invalid request line")) in let meth = Meth.of_string meth in - _debug (fun k->k "got meth: %s, path %S" (Meth.to_string meth) path); + _debug (fun k -> k "got meth: %s, path %S" (Meth.to_string meth) path); let headers = Headers.parse_ ~buf bs in let host = match Headers.get "Host" headers with @@ -255,20 +273,29 @@ module Request = struct | Ok l -> l | Error e -> bad_reqf 400 "invalid query: %s" e in - let req = { - meth; query; host; path; path_components; - headers; http_version=(1, version); body=(); start_time; - } in + let req = + { + meth; + query; + host; + path; + path_components; + headers; + http_version = 1, version; + body = (); + start_time; + } + in Ok (Some req) with | End_of_file | Sys_error _ | Unix.Unix_error _ -> Ok None - | Bad_req (c,s) -> Error (c,s) - | e -> - Error (400, Printexc.to_string e) + | Bad_req (c, s) -> Error (c, s) + | e -> Error (400, Printexc.to_string e) (* parse body, given the headers. @param tr_stream a transformation of the input stream. *) - let parse_body_ ~tr_stream ~buf (req:byte_stream t) : byte_stream t resp_result = + let parse_body_ ~tr_stream ~buf (req : byte_stream t) : + byte_stream t resp_result = try let size = match Headers.get_exn "Content-Length" req.headers |> int_of_string with @@ -281,19 +308,22 @@ module Request = struct | None -> read_exactly ~size @@ tr_stream req.body | Some "chunked" -> let bs = - read_stream_chunked_ ~buf @@ tr_stream req.body (* body sent by chunks *) + read_stream_chunked_ ~buf + @@ tr_stream req.body (* body sent by chunks *) in - if size>0 then limit_body_size_ ~max_size:size bs else bs + if size > 0 then + limit_body_size_ ~max_size:size bs + else + bs | Some s -> bad_reqf 500 "cannot handle transfer encoding: %s" s in - Ok {req with body} + Ok { req with body } with | End_of_file -> Error (400, "unexpected end of file") - | Bad_req (c,s) -> Error (c,s) - | e -> - Error (400, Printexc.to_string e) + | Bad_req (c, s) -> Error (c, s) + | e -> Error (400, Printexc.to_string e) - let read_body_full ?buf_size (self:byte_stream t) : string t = + let read_body_full ?buf_size (self : byte_stream t) : string t = try let buf = Buf.create ?size:buf_size () in let body = Byte_stream.read_all ~buf self.body in @@ -303,11 +333,12 @@ module Request = struct | e -> bad_reqf 500 "failed to read body: %s" (Printexc.to_string e) module Internal_ = struct - let parse_req_start ?(buf=Buf.create()) ~get_time_s bs = + let parse_req_start ?(buf = Buf.create ()) ~get_time_s bs = parse_req_start ~get_time_s ~buf bs |> unwrap_resp_result - let parse_body ?(buf=Buf.create()) req bs : _ t = - parse_body_ ~tr_stream:(fun s->s) ~buf {req with body=bs} |> unwrap_resp_result + let parse_body ?(buf = Buf.create ()) req bs : _ t = + parse_body_ ~tr_stream:(fun s -> s) ~buf { req with body = bs } + |> unwrap_resp_result end end @@ -328,57 +359,59 @@ end *) module Response = struct - type body = [`String of string | `Stream of byte_stream | `Void] - type t = { - code: Response_code.t; - headers: Headers.t; - body: body; - } + type body = [ `String of string | `Stream of byte_stream | `Void ] + type t = { code: Response_code.t; headers: Headers.t; body: body } - let set_body body self = {self with body} - let set_headers headers self = {self with headers} - let update_headers f self = {self with headers=f self.headers} - let set_header k v self = {self with headers = Headers.set k v self.headers} - let set_code code self = {self with code} + let set_body body self = { self with body } + let set_headers headers self = { self with headers } + let update_headers f self = { self with headers = f self.headers } + let set_header k v self = { self with headers = Headers.set k v self.headers } + let set_code code self = { self with code } - let make_raw ?(headers=[]) ~code body : t = + let make_raw ?(headers = []) ~code body : t = (* add content length to response *) let headers = Headers.set "Content-Length" (string_of_int (String.length body)) headers in - { code; headers; body=`String body; } + { code; headers; body = `String body } - let make_raw_stream ?(headers=[]) ~code body : t = + let make_raw_stream ?(headers = []) ~code body : t = (* add content length to response *) let headers = Headers.set "Transfer-Encoding" "chunked" headers in - { code; headers; body=`Stream body; } + { code; headers; body = `Stream body } - let make_void_force_ ?(headers=[]) ~code () : t = - { code; headers; body=`Void; } + let make_void_force_ ?(headers = []) ~code () : t = + { code; headers; body = `Void } - let make_void ?(headers=[]) ~code () : t = + let make_void ?(headers = []) ~code () : t = let is_ok = code < 200 || code = 204 || code = 304 in - if is_ok then make_void_force_ ~headers ~code () - else make_raw ~headers ~code "" (* invalid to not have a body *) + if is_ok then + make_void_force_ ~headers ~code () + else + make_raw ~headers ~code "" (* invalid to not have a body *) - let make_string ?headers r = match r with + let make_string ?headers r = + match r with | Ok body -> make_raw ?headers ~code:200 body - | Error (code,msg) -> make_raw ?headers ~code msg + | Error (code, msg) -> make_raw ?headers ~code msg - let make_stream ?headers r = match r with + let make_stream ?headers r = + match r with | Ok body -> make_raw_stream ?headers ~code:200 body - | Error (code,msg) -> make_raw ?headers ~code msg + | Error (code, msg) -> make_raw ?headers ~code msg - let make ?headers r : t = match r with + let make ?headers r : t = + match r with | Ok (`String body) -> make_raw ?headers ~code:200 body | Ok (`Stream body) -> make_raw_stream ?headers ~code:200 body | Ok `Void -> make_void ?headers ~code:200 () - | Error (code,msg) -> make_raw ?headers ~code msg + | Error (code, msg) -> make_raw ?headers ~code msg let fail ?headers ~code fmt = Printf.ksprintf (fun msg -> make_raw ?headers ~code msg) fmt + let fail_raise ~code fmt = - Printf.ksprintf (fun msg -> raise (Bad_req (code,msg))) fmt + Printf.ksprintf (fun msg -> raise (Bad_req (code, msg))) fmt let pp out self : unit = let pp_body out = function @@ -386,12 +419,14 @@ module Response = struct | `Stream _ -> Format.pp_print_string out "" | `Void -> () in - Format.fprintf out "{@[code=%d;@ headers=[@[%a@]];@ body=%a@]}" - self.code Headers.pp self.headers pp_body self.body + Format.fprintf out "{@[code=%d;@ headers=[@[%a@]];@ body=%a@]}" self.code + Headers.pp self.headers pp_body self.body - let output_ (oc:out_channel) (self:t) : unit = - Printf.fprintf oc "HTTP/1.1 %d %s\r\n" self.code (Response_code.descr self.code); - let body, is_chunked = match self.body with + let output_ (oc : out_channel) (self : t) : unit = + Printf.fprintf oc "HTTP/1.1 %d %s\r\n" self.code + (Response_code.descr self.code); + let body, is_chunked = + match self.body with | `String s when String.length s > 1024 * 500 -> (* chunk-encode large bodies *) `Stream (Byte_stream.of_string s), true @@ -400,47 +435,44 @@ module Response = struct | `Void as b -> b, false in let headers = - if is_chunked then ( + if is_chunked then self.headers |> Headers.set "transfer-encoding" "chunked" |> Headers.remove "content-length" - ) else self.headers + else + self.headers in - let self = {self with headers; body} in - _debug (fun k->k "output response: %s" - (Format.asprintf "%a" pp {self with body=`String "<…>"})); - List.iter (fun (k,v) -> Printf.fprintf oc "%s: %s\r\n" k v) headers; + let self = { self with headers; body } in + _debug (fun k -> + k "output response: %s" + (Format.asprintf "%a" pp { self with body = `String "<…>" })); + List.iter (fun (k, v) -> Printf.fprintf oc "%s: %s\r\n" k v) headers; output_string oc "\r\n"; - begin match body with - | `String "" | `Void -> () - | `String s -> output_string oc s; - | `Stream str -> - try - Byte_stream.output_chunked oc str; - Byte_stream.close str - with - e -> Byte_stream.close str; raise e - end; + (match body with + | `String "" | `Void -> () + | `String s -> output_string oc s + | `Stream str -> + (try + Byte_stream.output_chunked oc str; + Byte_stream.close str + with e -> + Byte_stream.close str; + raise e)); flush oc end (* semaphore, for limiting concurrency. *) module Sem_ = struct - type t = { - mutable n : int; - max : int; - mutex : Mutex.t; - cond : Condition.t; - } + type t = { mutable n: int; max: int; mutex: Mutex.t; cond: Condition.t } let create n = if n <= 0 then invalid_arg "Semaphore.create"; - { n; max=n; mutex=Mutex.create(); cond=Condition.create(); } + { n; max = n; mutex = Mutex.create (); cond = Condition.create () } let acquire m t = Mutex.lock t.mutex; while t.n < m do - Condition.wait t.cond t.mutex; + Condition.wait t.cond t.mutex done; assert (t.n >= m); t.n <- t.n - m; @@ -467,83 +499,84 @@ module Route = struct type (_, _) t = | Fire : ('b, 'b) t - | Rest : { - url_encoded: bool; - } -> (string -> 'b, 'b) t - | Compose: ('a, 'b) comp * ('b, 'c) t -> ('a, 'c) t + | Rest : { url_encoded: bool } -> (string -> 'b, 'b) t + | Compose : ('a, 'b) comp * ('b, 'c) t -> ('a, 'c) t let return = Fire - let rest_of_path = Rest {url_encoded=false} - let rest_of_path_urlencoded = Rest {url_encoded=true} - let (@/) a b = Compose (a,b) + let rest_of_path = Rest { url_encoded = false } + let rest_of_path_urlencoded = Rest { url_encoded = true } + let ( @/ ) a b = Compose (a, b) let string = String let string_urlencoded = String_urlencoded let int = Int - let exact (s:string) = Exact s - let exact_path (s:string) tail = + let exact (s : string) = Exact s + + let exact_path (s : string) tail = let rec fn = function | [] -> tail - | ""::ls -> fn ls - | s::ls -> exact s @/ fn ls + | "" :: ls -> fn ls + | s :: ls -> exact s @/ fn ls in fn (String.split_on_char '/' s) - let rec eval : - type a b. path -> (a,b) t -> a -> b option = - fun path route f -> - begin match path, route with - | [], Fire -> Some f - | _, Fire -> None - | _, Rest {url_encoded} -> - let whole_path = String.concat "/" path in - begin match - if url_encoded - then match Tiny_httpd_util.percent_decode whole_path with - | Some s -> s - | None -> raise_notrace Exit - else whole_path - with - | whole_path -> - Some (f whole_path) - | exception Exit -> None - end - | (c1 :: path'), Compose (comp, route') -> - begin match comp with - | Int -> - begin match int_of_string c1 with - | i -> eval path' route' (f i) - | exception _ -> None - end - | String -> - eval path' route' (f c1) - | String_urlencoded -> - begin match Tiny_httpd_util.percent_decode c1 with - | None -> None - | Some s -> eval path' route' (f s) - end - | Exact s -> - if s = c1 then eval path' route' f else None - end - | [], Compose (String, Fire) -> Some (f "") (* trailing *) - | [], Compose (String_urlencoded, Fire) -> Some (f "") (* trailing *) - | [], Compose _ -> None - end + + let rec eval : type a b. path -> (a, b) t -> a -> b option = + fun path route f -> + match path, route with + | [], Fire -> Some f + | _, Fire -> None + | _, Rest { url_encoded } -> + let whole_path = String.concat "/" path in + (match + if url_encoded then ( + match Tiny_httpd_util.percent_decode whole_path with + | Some s -> s + | None -> raise_notrace Exit + ) else + whole_path + with + | whole_path -> Some (f whole_path) + | exception Exit -> None) + | c1 :: path', Compose (comp, route') -> + (match comp with + | Int -> + (match int_of_string c1 with + | i -> eval path' route' (f i) + | exception _ -> None) + | String -> eval path' route' (f c1) + | String_urlencoded -> + (match Tiny_httpd_util.percent_decode c1 with + | None -> None + | Some s -> eval path' route' (f s)) + | Exact s -> + if s = c1 then + eval path' route' f + else + None) + | [], Compose (String, Fire) -> Some (f "") (* trailing *) + | [], Compose (String_urlencoded, Fire) -> Some (f "") (* trailing *) + | [], Compose _ -> None let bpf = Printf.bprintf - let rec pp_ - : type a b. Buffer.t -> (a,b) t -> unit - = fun out -> function - | Fire -> bpf out "/" - | Rest {url_encoded} -> - bpf out "" (if url_encoded then "_urlencoded" else "") - | Compose (Exact s, tl) -> bpf out "%s/%a" s pp_ tl - | Compose (Int, tl) -> bpf out "/%a" pp_ tl - | Compose (String, tl) -> bpf out "/%a" pp_ tl - | Compose (String_urlencoded, tl) -> bpf out "/%a" pp_ tl + + let rec pp_ : type a b. Buffer.t -> (a, b) t -> unit = + fun out -> function + | Fire -> bpf out "/" + | Rest { url_encoded } -> + bpf out "" + (if url_encoded then + "_urlencoded" + else + "") + | Compose (Exact s, tl) -> bpf out "%s/%a" s pp_ tl + | Compose (Int, tl) -> bpf out "/%a" pp_ tl + | Compose (String, tl) -> bpf out "/%a" pp_ tl + | Compose (String_urlencoded, tl) -> bpf out "/%a" pp_ tl let to_string x = let b = Buffer.create 16 in pp_ b x; Buffer.contents b + let pp out x = Format.pp_print_string out (to_string x) end @@ -552,76 +585,58 @@ module Middleware = struct type t = handler -> handler (** Apply a list of middlewares to [h] *) - let apply_l (l:t list) (h:handler) : handler = + let apply_l (l : t list) (h : handler) : handler = List.fold_right (fun m h -> m h) l h let[@inline] nil : t = fun h -> h end (* a request handler. handles a single request. *) -type cb_path_handler = - out_channel -> - Middleware.handler +type cb_path_handler = out_channel -> Middleware.handler module type SERVER_SENT_GENERATOR = sig val set_headers : Headers.t -> unit + val send_event : - ?event:string -> - ?id:string -> - ?retry:string -> - data:string -> - unit -> unit + ?event:string -> ?id:string -> ?retry:string -> data:string -> unit -> unit + val close : unit -> unit end + type server_sent_generator = (module SERVER_SENT_GENERATOR) type t = { - addr: string; - (** Address at creation *) - - port: int; - (** Port at creation *) - - mutable sock: Unix.file_descr option; - (** Socket *) - + addr: string; (** Address at creation *) + port: int; (** Port at creation *) + mutable sock: Unix.file_descr option; (** Socket *) timeout: float; - sem_max_connections: Sem_.t; - (* semaphore to restrict the number of active concurrent connections *) - + (* semaphore to restrict the number of active concurrent connections *) new_thread: (unit -> unit) -> unit; - (* a function to run the given callback in a separate thread (or thread pool) *) - + (* a function to run the given callback in a separate thread (or thread pool) *) masksigpipe: bool; - buf_size: int; - - get_time_s : unit -> float; - - mutable handler: (string Request.t -> Response.t); - (** toplevel handler, if any *) - - mutable middlewares : (int * Middleware.t) list; - (** Global middlewares *) - - mutable middlewares_sorted : (int * Middleware.t) list lazy_t; - (** sorted version of {!middlewares} *) - - mutable path_handlers : (unit Request.t -> cb_path_handler resp_result option) list; - (** path handlers *) - + get_time_s: unit -> float; + mutable handler: string Request.t -> Response.t; + (** toplevel handler, if any *) + mutable middlewares: (int * Middleware.t) list; (** Global middlewares *) + mutable middlewares_sorted: (int * Middleware.t) list lazy_t; + (** sorted version of {!middlewares} *) + mutable path_handlers: + (unit Request.t -> cb_path_handler resp_result option) list; + (** path handlers *) mutable running: bool; - (** true while the server is running. no need to protect with a mutex, + (** true while the server is running. no need to protect with a mutex, writes should be atomic enough. *) } let get_addr_ sock = - match Unix.getsockname sock with - | Unix.ADDR_INET (addr, port) -> addr, port - | _ -> invalid_arg "httpd: address is not INET" + match Unix.getsockname sock with + | Unix.ADDR_INET (addr, port) -> addr, port + | _ -> invalid_arg "httpd: address is not INET" -let addr self = match self.sock with +let addr self = + match self.sock with | None -> self.addr | Some s -> Unix.string_of_inet_addr (fst @@ get_addr_ s) @@ -633,25 +648,26 @@ let port self = let active_connections self = Sem_.num_acquired self.sem_max_connections - 1 let add_middleware ~stage self m = - let stage = match stage with + let stage = + match stage with | `Encoding -> 0 | `Stage n when n < 1 -> invalid_arg "add_middleware: bad stage" | `Stage n -> n in - self.middlewares <- (stage,m) :: self.middlewares; - self.middlewares_sorted <- lazy ( - List.stable_sort (fun (s1,_) (s2,_) -> compare s1 s2) self.middlewares - ) + self.middlewares <- (stage, m) :: self.middlewares; + self.middlewares_sorted <- + lazy + (List.stable_sort (fun (s1, _) (s2, _) -> compare s1 s2) self.middlewares) let add_decode_request_cb self f = (* turn it into a middleware *) let m h req ~resp = (* see if [f] modifies the stream *) - let req0 = {req with Request.body=()} in + let req0 = { req with Request.body = () } in match f req0 with | None -> h req ~resp (* pass through *) | Some (req1, tr_stream) -> - let req = {req1 with Request.body=tr_stream req.Request.body} in + let req = { req1 with Request.body = tr_stream req.Request.body } in h req ~resp in add_middleware self ~stage:`Encoding m @@ -659,7 +675,7 @@ let add_decode_request_cb self f = let add_encode_response_cb self f = let m h req ~resp = h req ~resp:(fun r -> - let req0 = {req with Request.body=()} in + let req0 = { req with Request.body = () } in (* now transform [r] if we want to *) match f req0 r with | None -> resp r @@ -672,46 +688,49 @@ let set_top_handler self f = self.handler <- f (* route the given handler. @param tr_req wraps the actual concrete function returned by the route and makes it into a handler. *) -let add_route_handler_ - ?(accept=fun _req -> Ok ()) ?(middlewares=[]) - ?meth ~tr_req self (route:_ Route.t) f = +let add_route_handler_ ?(accept = fun _req -> Ok ()) ?(middlewares = []) ?meth + ~tr_req self (route : _ Route.t) f = let ph req : cb_path_handler resp_result option = match meth with | Some m when m <> req.Request.meth -> None (* ignore *) | _ -> - begin match Route.eval req.Request.path_components route f with - | Some handler -> - (* we have a handler, do we accept the request based on its headers? *) - begin match accept req with - | Ok () -> - Some (Ok (fun oc -> - Middleware.apply_l middlewares @@ - fun req ~resp -> tr_req oc req ~resp handler)) - | Error _ as e -> Some e - end - | None -> - None (* path didn't match *) - end + (match Route.eval req.Request.path_components route f with + | Some handler -> + (* we have a handler, do we accept the request based on its headers? *) + (match accept req with + | Ok () -> + Some + (Ok + (fun oc -> + Middleware.apply_l middlewares @@ fun req ~resp -> + tr_req oc req ~resp handler)) + | Error _ as e -> Some e) + | None -> None (* path didn't match *)) in self.path_handlers <- ph :: self.path_handlers -let add_route_handler (type a) ?accept ?middlewares ?meth - self (route:(a,_) Route.t) (f:_) : unit = - let tr_req _oc req ~resp f = resp (f (Request.read_body_full ~buf_size:self.buf_size req)) in +let add_route_handler (type a) ?accept ?middlewares ?meth self + (route : (a, _) Route.t) (f : _) : unit = + let tr_req _oc req ~resp f = + resp (f (Request.read_body_full ~buf_size:self.buf_size req)) + in add_route_handler_ ?accept ?middlewares ?meth self route ~tr_req f let add_route_handler_stream ?accept ?middlewares ?meth self route f = let tr_req _oc req ~resp f = resp (f req) in add_route_handler_ ?accept ?middlewares ?meth self route ~tr_req f -let[@inline] _opt_iter ~f o = match o with +let[@inline] _opt_iter ~f o = + match o with | None -> () | Some x -> f x let add_route_server_sent_handler ?accept self route f = let tr_req oc req ~resp f = let req = Request.read_body_full ~buf_size:self.buf_size req in - let headers = ref Headers.(empty |> set "content-type" "text/event-stream") in + let headers = + ref Headers.(empty |> set "content-type" "text/event-stream") + in (* send response once *) let resp_sent = ref false in @@ -719,54 +738,63 @@ let add_route_server_sent_handler ?accept self route f = if not !resp_sent then ( resp_sent := true; (* send 200 response now *) - let initial_resp = Response.make_void_force_ ~headers:!headers ~code:200 () in - resp initial_resp; + let initial_resp = + Response.make_void_force_ ~headers:!headers ~code:200 () + in + resp initial_resp ) in let send_event ?event ?id ?retry ~data () : unit = - send_response_idempotent_(); + send_response_idempotent_ (); _opt_iter event ~f:(fun e -> Printf.fprintf oc "event: %s\n" e); _opt_iter id ~f:(fun e -> Printf.fprintf oc "id: %s\n" e); _opt_iter retry ~f:(fun e -> Printf.fprintf oc "retry: %s\n" e); let l = String.split_on_char '\n' data in List.iter (fun s -> Printf.fprintf oc "data: %s\n" s) l; - output_string oc "\n"; (* finish group *) + output_string oc "\n"; + (* finish group *) flush oc in let module SSG = struct let set_headers h = if not !resp_sent then ( headers := List.rev_append h !headers; - send_response_idempotent_() + send_response_idempotent_ () ) + let send_event = send_event let close () = raise Exit end in - try f req (module SSG : SERVER_SENT_GENERATOR); - with Exit -> close_out oc + try f req (module SSG : SERVER_SENT_GENERATOR) with Exit -> close_out oc in add_route_handler_ self ?accept ~meth:`GET route ~tr_req f -let create - ?(masksigpipe=true) - ?(max_connections=32) - ?(timeout=0.0) - ?(buf_size=16 * 1_024) - ?(get_time_s=Unix.gettimeofday) - ?(new_thread=(fun f -> ignore (Thread.create f () : Thread.t))) - ?(addr="127.0.0.1") ?(port=8080) ?sock - ?(middlewares=[]) - () : t = +let create ?(masksigpipe = true) ?(max_connections = 32) ?(timeout = 0.0) + ?(buf_size = 16 * 1_024) ?(get_time_s = Unix.gettimeofday) + ?(new_thread = fun f -> ignore (Thread.create f () : Thread.t)) + ?(addr = "127.0.0.1") ?(port = 8080) ?sock ?(middlewares = []) () : t = let handler _req = Response.fail ~code:404 "no top handler" in let max_connections = max 4 max_connections in - let self = { - new_thread; addr; port; sock; masksigpipe; handler; buf_size; - running= true; sem_max_connections=Sem_.create max_connections; - path_handlers=[]; timeout; get_time_s; - middlewares=[]; middlewares_sorted=lazy []; - } in - List.iter (fun (stage,m) -> add_middleware self ~stage m) middlewares; + let self = + { + new_thread; + addr; + port; + sock; + masksigpipe; + handler; + buf_size; + running = true; + sem_max_connections = Sem_.create max_connections; + path_handlers = []; + timeout; + get_time_s; + middlewares = []; + middlewares_sorted = lazy []; + } + in + List.iter (fun (stage, m) -> add_middleware self ~stage m) middlewares; self let stop s = s.running <- false @@ -774,13 +802,14 @@ let stop s = s.running <- false let find_map f l = let rec aux f = function | [] -> None - | x::l' -> - match f x with - | Some _ as res -> res - | None -> aux f l' - in aux f l + | x :: l' -> + (match f x with + | Some _ as res -> res + | None -> aux f l') + in + aux f l -let handle_client_ (self:t) (client_sock:Unix.file_descr) : unit = +let handle_client_ (self : t) (client_sock : Unix.file_descr) : unit = Unix.(setsockopt_float client_sock SO_RCVTIMEO self.timeout); Unix.(setsockopt_float client_sock SO_SNDTIMEO self.timeout); let oc = Unix.out_channel_of_descr client_sock in @@ -788,133 +817,132 @@ let handle_client_ (self:t) (client_sock:Unix.file_descr) : unit = let is = Byte_stream.of_fd ~buf_size:self.buf_size client_sock in let continue = ref true in while !continue && self.running do - _debug (fun k->k "read next request"); + _debug (fun k -> k "read next request"); match Request.parse_req_start ~get_time_s:self.get_time_s ~buf is with - | Ok None -> - continue := false (* client is done *) - - | Error (c,s) -> + | Ok None -> continue := false (* client is done *) + | Error (c, s) -> (* connection error, close *) let res = Response.make_raw ~code:c s in - begin - try Response.output_ oc res - with Sys_error _ -> () - end; + (try Response.output_ oc res with Sys_error _ -> ()); continue := false - | Ok (Some req) -> - _debug (fun k->k "req: %s" (Format.asprintf "@[%a@]" Request.pp_ req)); + _debug (fun k -> k "req: %s" (Format.asprintf "@[%a@]" Request.pp_ req)); if Request.close_after_req req then continue := false; - try - (* is there a handler for this path? *) - let handler = - match find_map (fun ph -> ph req) self.path_handlers with - | Some f -> unwrap_resp_result f - | None -> - (fun _oc req ~resp -> - let body_str = Request.read_body_full ~buf_size:self.buf_size req in - resp (self.handler body_str)) - in + (try + (* is there a handler for this path? *) + let handler = + match find_map (fun ph -> ph req) self.path_handlers with + | Some f -> unwrap_resp_result f + | None -> + fun _oc req ~resp -> + let body_str = + Request.read_body_full ~buf_size:self.buf_size req + in + resp (self.handler body_str) + in - (* handle expect/continue *) - begin match Request.get_header ~f:String.trim req "Expect" with - | Some "100-continue" -> - _debug (fun k->k "send back: 100 CONTINUE"); - Response.output_ oc (Response.make_raw ~code:100 ""); - | Some s -> bad_reqf 417 "unknown expectation %s" s - | None -> () - end; + (* handle expect/continue *) + (match Request.get_header ~f:String.trim req "Expect" with + | Some "100-continue" -> + _debug (fun k -> k "send back: 100 CONTINUE"); + Response.output_ oc (Response.make_raw ~code:100 "") + | Some s -> bad_reqf 417 "unknown expectation %s" s + | None -> ()); - (* apply middlewares *) - let handler = - fun oc -> - List.fold_right (fun (_, m) h -> m h) - (Lazy.force self.middlewares_sorted) (handler oc) - in + (* apply middlewares *) + let handler oc = + List.fold_right + (fun (_, m) h -> m h) + (Lazy.force self.middlewares_sorted) + (handler oc) + in - (* now actually read request's body into a stream *) - let req = - Request.parse_body_ ~tr_stream:(fun s->s) ~buf {req with body=is} - |> unwrap_resp_result - in + (* now actually read request's body into a stream *) + let req = + Request.parse_body_ + ~tr_stream:(fun s -> s) + ~buf { req with body = is } + |> unwrap_resp_result + in - (* how to reply *) - let resp r = - try - if Headers.get "connection" r.Response.headers = Some"close" then - continue := false; - Response.output_ oc r - with Sys_error _ -> continue := false - in + (* how to reply *) + let resp r = + try + if Headers.get "connection" r.Response.headers = Some "close" then + continue := false; + Response.output_ oc r + with Sys_error _ -> continue := false + in - (* call handler *) - begin - try handler oc req ~resp - with Sys_error _ -> continue := false - end - with - | Sys_error _ -> - continue := false; (* connection broken somehow *) - | Bad_req (code,s) -> + (* call handler *) + try handler oc req ~resp with Sys_error _ -> continue := false + with + | Sys_error _ -> continue := false + (* connection broken somehow *) + | Bad_req (code, s) -> continue := false; Response.output_ oc @@ Response.make_raw ~code s | e -> continue := false; - Response.output_ oc @@ Response.fail ~code:500 "server error: %s" (Printexc.to_string e) + Response.output_ oc + @@ Response.fail ~code:500 "server error: %s" (Printexc.to_string e)) done; - _debug (fun k->k "done with client, exiting"); + _debug (fun k -> k "done with client, exiting"); (try Unix.close client_sock - with e -> _debug (fun k->k "error when closing sock: %s" (Printexc.to_string e))); + with e -> + _debug (fun k -> k "error when closing sock: %s" (Printexc.to_string e))); () let is_ipv6 self = String.contains self.addr ':' -let run (self:t) : (unit,_) result = +let run (self : t) : (unit, _) result = try - if self.masksigpipe then ( - ignore (Unix.sigprocmask Unix.SIG_BLOCK [Sys.sigpipe] : _ list); - ); - let sock, should_bind = match self.sock with + if self.masksigpipe then + ignore (Unix.sigprocmask Unix.SIG_BLOCK [ Sys.sigpipe ] : _ list); + let sock, should_bind = + match self.sock with | Some s -> - s, false (* Because we're getting a socket from the caller (e.g. systemd) *) + ( s, + false + (* Because we're getting a socket from the caller (e.g. systemd) *) ) | None -> - Unix.socket - (if is_ipv6 self then Unix.PF_INET6 else Unix.PF_INET) - Unix.SOCK_STREAM - 0, - true (* Because we're creating the socket ourselves *) + ( Unix.socket + (if is_ipv6 self then + Unix.PF_INET6 + else + Unix.PF_INET) + Unix.SOCK_STREAM 0, + true (* Because we're creating the socket ourselves *) ) in Unix.clear_nonblock sock; Unix.setsockopt_optint sock Unix.SO_LINGER None; - begin if should_bind then + if should_bind then ( let inet_addr = Unix.inet_addr_of_string self.addr in Unix.setsockopt sock Unix.SO_REUSEADDR true; Unix.bind sock (Unix.ADDR_INET (inet_addr, self.port)); Unix.listen sock (2 * self.sem_max_connections.Sem_.n) - end; + ); self.sock <- Some sock; while self.running do (* limit concurrency *) Sem_.acquire 1 self.sem_max_connections; try let client_sock, _ = Unix.accept sock in - self.new_thread - (fun () -> + self.new_thread (fun () -> try handle_client_ self client_sock; - Sem_.release 1 self.sem_max_connections; + Sem_.release 1 self.sem_max_connections with e -> (try Unix.close client_sock with _ -> ()); Sem_.release 1 self.sem_max_connections; - raise e - ); + raise e) with e -> Sem_.release 1 self.sem_max_connections; - _debug (fun k -> k - "Unix.accept or Thread.create raised an exception: %s" - (Printexc.to_string e)) + _debug (fun k -> + k "Unix.accept or Thread.create raised an exception: %s" + (Printexc.to_string e)) done; Ok () with e -> Error e diff --git a/src/Tiny_httpd_server.mli b/src/Tiny_httpd_server.mli index e4962b31..f4a41864 100644 --- a/src/Tiny_httpd_server.mli +++ b/src/Tiny_httpd_server.mli @@ -1,4 +1,3 @@ - (** HTTP server. This module implements a very simple, basic HTTP/1.1 server using blocking @@ -15,14 +14,7 @@ type byte_stream = Tiny_httpd_stream.t (** {2 Methods} *) module Meth : sig - type t = [ - | `GET - | `PUT - | `POST - | `HEAD - | `DELETE - | `OPTIONS - ] + type t = [ `GET | `PUT | `POST | `HEAD | `DELETE | `OPTIONS ] (** A HTTP method. For now we only handle a subset of these. @@ -47,7 +39,7 @@ module Headers : sig (** Empty list of headers @since 0.5 *) - val get : ?f:(string->string) -> string -> t -> string option + val get : ?f:(string -> string) -> string -> t -> string option (** [get k headers] looks for the header field with key [k]. @param f if provided, will transform the value before it is returned. *) @@ -74,13 +66,13 @@ module Request : sig meth: Meth.t; host: string; headers: Headers.t; - http_version: int*int; + http_version: int * int; path: string; path_components: string list; - query: (string*string) list; + query: (string * string) list; body: 'body; start_time: float; - (** Obtained via [get_time_s] in {!create} + (** Obtained via [get_time_s] in {!create} @since 0.11 *) } (** A request with method, path, host, headers, and a body, sent by a client. @@ -105,8 +97,7 @@ module Request : sig val headers : _ t -> Headers.t (** List of headers of the request, including ["Host"] *) - val get_header : ?f:(string->string) -> _ t -> string -> string option - + val get_header : ?f:(string -> string) -> _ t -> string -> string option val get_header_int : _ t -> string -> int option val set_header : string -> string -> 'a t -> 'a t @@ -129,7 +120,7 @@ module Request : sig val path : _ t -> string (** Request path. *) - val query : _ t -> (string*string) list + val query : _ t -> (string * string) list (** Decode the query part of the {!path} field @since 0.4 *) @@ -152,11 +143,15 @@ module Request : sig @param buf_size initial size of underlying buffer (since 0.11) *) (**/**) + (* for testing purpose, do not use *) module Internal_ : sig - val parse_req_start : ?buf:buf -> get_time_s:(unit -> float) -> byte_stream -> unit t option + val parse_req_start : + ?buf:buf -> get_time_s:(unit -> float) -> byte_stream -> unit t option + val parse_body : ?buf:buf -> unit t -> byte_stream -> byte_stream t end + (**/**) end @@ -185,14 +180,15 @@ end the client to answer a {!Request.t}*) module Response : sig - type body = [`String of string | `Stream of byte_stream | `Void] + type body = [ `String of string | `Stream of byte_stream | `Void ] (** Body of a response, either as a simple string, or a stream of bytes, or nothing (for server-sent events). *) type t = private { - code: Response_code.t; (** HTTP response code. See {!Response_code}. *) - headers: Headers.t; (** Headers of the reply. Some will be set by [Tiny_httpd] automatically. *) - body: body; (** Body of the response. Can be empty. *) + code: Response_code.t; (** HTTP response code. See {!Response_code}. *) + headers: Headers.t; + (** Headers of the reply. Some will be set by [Tiny_httpd] automatically. *) + body: body; (** Body of the response. Can be empty. *) } (** A response to send back to a client. *) @@ -216,19 +212,12 @@ module Response : sig (** Set the response code. @since 0.11 *) - val make_raw : - ?headers:Headers.t -> - code:Response_code.t -> - string -> - t + val make_raw : ?headers:Headers.t -> code:Response_code.t -> string -> t (** Make a response from its raw components, with a string body. Use [""] to not send a body at all. *) val make_raw_stream : - ?headers:Headers.t -> - code:Response_code.t -> - byte_stream -> - t + ?headers:Headers.t -> code:Response_code.t -> byte_stream -> t (** Same as {!make_raw} but with a stream body. The body will be sent with the chunked transfer-encoding. *) @@ -236,9 +225,7 @@ module Response : sig (** Return a response without a body at all. @since NEXT_RELEASE *) - val make : - ?headers:Headers.t -> - (body, Response_code.t * string) result -> t + val make : ?headers:Headers.t -> (body, Response_code.t * string) result -> t (** [make r] turns a result into a response. - [make (Ok body)] replies with [200] and the body. @@ -247,17 +234,15 @@ module Response : sig *) val make_string : - ?headers:Headers.t -> - (string, Response_code.t * string) result -> t + ?headers:Headers.t -> (string, Response_code.t * string) result -> t (** Same as {!make} but with a string body. *) val make_stream : - ?headers:Headers.t -> - (byte_stream, Response_code.t * string) result -> t + ?headers:Headers.t -> (byte_stream, Response_code.t * string) result -> t (** Same as {!make} but with a stream body. *) - val fail : ?headers:Headers.t -> code:int -> - ('a, unit, string, t) format4 -> 'a + val fail : + ?headers:Headers.t -> code:int -> ('a, unit, string, t) format4 -> 'a (** Make the current request fail with the given code and message. Example: [fail ~code:404 "oh noes, %s not found" "waldo"]. *) @@ -308,11 +293,11 @@ module Route : sig This will match the entirety of the remaining route. @since 0.7 *) - val (@/) : ('a, 'b) comp -> ('b, 'c) t -> ('a, 'c) t + val ( @/ ) : ('a, 'b) comp -> ('b, 'c) t -> ('a, 'c) t (** [comp / route] matches ["foo/bar/…"] iff [comp] matches ["foo"], and [route] matches ["bar/…"]. *) - val exact_path : string -> ('a,'b) t -> ('a,'b) t + val exact_path : string -> ('a, 'b) t -> ('a, 'b) t (** [exact_path "foo/bar/..." r] is equivalent to [exact "foo" @/ exact "bar" @/ ... @/ r] @since 0.11 **) @@ -366,7 +351,7 @@ val create : ?addr:string -> ?port:int -> ?sock:Unix.file_descr -> - ?middlewares:([`Encoding | `Stage of int] * Middleware.t) list -> + ?middlewares:([ `Encoding | `Stage of int ] * Middleware.t) list -> unit -> t (** Create a new webserver. @@ -416,8 +401,9 @@ val active_connections : t -> int val add_decode_request_cb : t -> - (unit Request.t -> (unit Request.t * (byte_stream -> byte_stream)) option) -> unit -[@@deprecated "use add_middleware"] + (unit Request.t -> (unit Request.t * (byte_stream -> byte_stream)) option) -> + unit + [@@deprecated "use add_middleware"] (** Add a callback for every request. The callback can provide a stream transformer and a new request (with modified headers, typically). @@ -427,9 +413,9 @@ val add_decode_request_cb : @deprecated use {!add_middleware} instead *) -val add_encode_response_cb: +val add_encode_response_cb : t -> (unit Request.t -> Response.t -> Response.t option) -> unit -[@@deprecated "use add_middleware"] + [@@deprecated "use add_middleware"] (** Add a callback for every request/response pair. Similarly to {!add_encode_response_cb} the callback can return a new response, for example to compress it. @@ -440,8 +426,7 @@ val add_encode_response_cb: *) val add_middleware : - stage:[`Encoding | `Stage of int] -> - t -> Middleware.t -> unit + stage:[ `Encoding | `Stage of int ] -> t -> Middleware.t -> unit (** Add a middleware to every request/response pair. @param stage specify when middleware applies. Encoding comes first (outermost layer), then stages in increasing order. @@ -463,7 +448,8 @@ val add_route_handler : ?middlewares:Middleware.t list -> ?meth:Meth.t -> t -> - ('a, string Request.t -> Response.t) Route.t -> 'a -> + ('a, string Request.t -> Response.t) Route.t -> + 'a -> unit (** [add_route_handler server Route.(exact "path" @/ string @/ int @/ return) f] calls [f "foo" 42 request] when a [request] with path "path/foo/42/" @@ -489,7 +475,8 @@ val add_route_handler_stream : ?middlewares:Middleware.t list -> ?meth:Meth.t -> t -> - ('a, byte_stream Request.t -> Response.t) Route.t -> 'a -> + ('a, byte_stream Request.t -> Response.t) Route.t -> + 'a -> unit (** Similar to {!add_route_handler}, but where the body of the request is a stream of bytes that has not been read yet. @@ -517,11 +504,7 @@ module type SERVER_SENT_GENERATOR = sig already sent too). *) val send_event : - ?event:string -> - ?id:string -> - ?retry:string -> - data:string -> - unit -> unit + ?event:string -> ?id:string -> ?retry:string -> data:string -> unit -> unit (** Send an event from the server. If data is a multiline string, it will be sent on separate "data:" lines. *) @@ -537,7 +520,8 @@ type server_sent_generator = (module SERVER_SENT_GENERATOR) val add_route_server_sent_handler : ?accept:(unit Request.t -> (unit, Response_code.t * string) result) -> t -> - ('a, string Request.t -> server_sent_generator -> unit) Route.t -> 'a -> + ('a, string Request.t -> server_sent_generator -> unit) Route.t -> + 'a -> unit (** Add a handler on an endpoint, that serves server-sent events. @@ -568,7 +552,9 @@ val run : t -> (unit, exn) result (**/**) -val _debug : ((('a, out_channel, unit, unit, unit, unit) format6 -> 'a) -> unit) -> unit -val _enable_debug: bool -> unit +val _debug : + ((('a, out_channel, unit, unit, unit, unit) format6 -> 'a) -> unit) -> unit + +val _enable_debug : bool -> unit (**/**) diff --git a/src/Tiny_httpd_stream.ml b/src/Tiny_httpd_stream.ml index f55b0b29..66ce7aa3 100644 --- a/src/Tiny_httpd_stream.ml +++ b/src/Tiny_httpd_stream.ml @@ -1,98 +1,96 @@ - module Buf = Tiny_httpd_buf let spf = Printf.sprintf type hidden = unit + type t = { mutable bs: bytes; - mutable off : int; - mutable len : int; + mutable off: int; + mutable len: int; fill_buf: unit -> unit; consume: int -> unit; close: unit -> unit; _rest: hidden; } -let[@inline] close self = self.close() +let[@inline] close self = self.close () -let empty = { - bs=Bytes.empty; - off=0; - len=0; - fill_buf=ignore; - consume=ignore; - close=ignore; - _rest=(); -} +let empty = + { + bs = Bytes.empty; + off = 0; + len = 0; + fill_buf = ignore; + consume = ignore; + close = ignore; + _rest = (); + } -let make ?(bs=Bytes.create @@ 16 * 1024) ?(close=ignore) ~consume ~fill () : t = - let rec self = { - bs; - off=0; - len=0; - close=(fun () -> close self); - fill_buf=(fun () -> - if self.len = 0 then fill self); - consume= - (fun n -> - assert (n <= self.len); - consume self n - ); - _rest=(); - } in +let make ?(bs = Bytes.create @@ (16 * 1024)) ?(close = ignore) ~consume ~fill () + : t = + let rec self = + { + bs; + off = 0; + len = 0; + close = (fun () -> close self); + fill_buf = (fun () -> if self.len = 0 then fill self); + consume = + (fun n -> + assert (n <= self.len); + consume self n); + _rest = (); + } + in self -let of_chan_ ?(buf_size=16 * 1024) ~close ic : t = - make - ~bs:(Bytes.create buf_size) +let of_chan_ ?(buf_size = 16 * 1024) ~close ic : t = + make ~bs:(Bytes.create buf_size) ~close:(fun _ -> close ic) ~consume:(fun self n -> - self.off <- self.off + n; - self.len <- self.len - n) + self.off <- self.off + n; + self.len <- self.len - n) ~fill:(fun self -> - if self.off >= self.len then ( - self.off <- 0; - self.len <- input ic self.bs 0 (Bytes.length self.bs); - ) - ) + if self.off >= self.len then ( + self.off <- 0; + self.len <- input ic self.bs 0 (Bytes.length self.bs) + )) () let of_chan = of_chan_ ~close:close_in let of_chan_close_noerr = of_chan_ ~close:close_in_noerr -let of_fd_ ?(buf_size=16 * 1024) ~close ic : t = - make - ~bs:(Bytes.create buf_size) +let of_fd_ ?(buf_size = 16 * 1024) ~close ic : t = + make ~bs:(Bytes.create buf_size) ~close:(fun _ -> close ic) ~consume:(fun self n -> - self.off <- self.off + n; - self.len <- self.len - n) + self.off <- self.off + n; + self.len <- self.len - n) ~fill:(fun self -> - if self.off >= self.len then ( - self.off <- 0; - self.len <- Unix.read ic self.bs 0 (Bytes.length self.bs); - ) - ) + if self.off >= self.len then ( + self.off <- 0; + self.len <- Unix.read ic self.bs 0 (Bytes.length self.bs) + )) () let of_fd = of_fd_ ~close:Unix.close let of_fd_close_noerr = of_fd_ ~close:(fun f -> try Unix.close f with _ -> ()) -let rec iter f (self:t) : unit = - self.fill_buf(); - if self.len=0 then ( - self.close(); - ) else ( +let rec iter f (self : t) : unit = + self.fill_buf (); + if self.len = 0 then + self.close () + else ( f self.bs self.off self.len; self.consume self.len; (iter [@tailcall]) f self ) -let to_chan (oc:out_channel) (self:t) = +let to_chan (oc : out_channel) (self : t) = iter (fun s i len -> output oc s i len) self -let of_bytes ?(i=0) ?len (bs:bytes) : t = +let of_bytes ?(i = 0) ?len (bs : bytes) : t = (* invariant: !i+!len is constant *) let len = match len with @@ -102,25 +100,22 @@ let of_bytes ?(i=0) ?len (bs:bytes) : t = | None -> Bytes.length bs - i in let self = - make - ~bs ~fill:ignore + make ~bs ~fill:ignore ~close:(fun self -> self.len <- 0) ~consume:(fun self n -> - assert (n>=0 && n<= self.len); - self.off <- n + self.off; - self.len <- self.len - n - ) + assert (n >= 0 && n <= self.len); + self.off <- n + self.off; + self.len <- self.len - n) () in self.off <- i; self.len <- len; self -let of_string s : t = - of_bytes (Bytes.unsafe_of_string s) +let of_string s : t = of_bytes (Bytes.unsafe_of_string s) let with_file ?buf_size file f = - let ic = Unix.(openfile file [O_RDONLY] 0) in + let ic = Unix.(openfile file [ O_RDONLY ] 0) in try let x = f (of_fd ?buf_size ic) in Unix.close ic; @@ -129,152 +124,148 @@ let with_file ?buf_size file f = Unix.close ic; raise e -let read_all ?(buf=Buf.create()) (self:t) : string = +let read_all ?(buf = Buf.create ()) (self : t) : string = let continue = ref true in while !continue do - self.fill_buf(); + self.fill_buf (); if self.len > 0 then ( Buf.add_bytes buf self.bs self.off self.len; - self.consume self.len; + self.consume self.len ); assert (self.len >= 0); - if self.len = 0 then ( - continue := false - ) + if self.len = 0 then continue := false done; Buf.contents_and_clear buf (* put [n] bytes from the input into bytes *) -let read_exactly_ ~too_short (self:t) (bytes:bytes) (n:int) : unit = +let read_exactly_ ~too_short (self : t) (bytes : bytes) (n : int) : unit = assert (Bytes.length bytes >= n); let offset = ref 0 in while !offset < n do - self.fill_buf(); + self.fill_buf (); let n_read = min self.len (n - !offset) in Bytes.blit self.bs self.off bytes !offset n_read; offset := !offset + n_read; self.consume n_read; - if n_read=0 then too_short(); + if n_read = 0 then too_short () done (* read a line into the buffer, after clearing it. *) -let read_line_into (self:t) ~buf : unit = +let read_line_into (self : t) ~buf : unit = Buf.clear buf; let continue = ref true in while !continue do - self.fill_buf(); - if self.len=0 then ( + self.fill_buf (); + if self.len = 0 then ( continue := false; - if Buf.size buf = 0 then raise End_of_file; + if Buf.size buf = 0 then raise End_of_file ); let j = ref self.off in while !j < self.off + self.len && Bytes.get self.bs !j <> '\n' do incr j done; - if !j-self.off < self.len then ( + if !j - self.off < self.len then ( assert (Bytes.get self.bs !j = '\n'); - Buf.add_bytes buf self.bs self.off (!j-self.off); (* without \n *) - self.consume (!j-self.off+1); (* remove \n *) + Buf.add_bytes buf self.bs self.off (!j - self.off); + (* without \n *) + self.consume (!j - self.off + 1); + (* remove \n *) continue := false ) else ( Buf.add_bytes buf self.bs self.off self.len; - self.consume self.len; + self.consume self.len ) done (* new stream with maximum size [max_size]. @param close_rec if true, closing this will also close the input stream @param too_big called with read size if the max size is reached *) -let limit_size_to ~close_rec ~max_size ~too_big (arg:t) : t = +let limit_size_to ~close_rec ~max_size ~too_big (arg : t) : t = let size = ref 0 in let continue = ref true in - make - ~bs:Bytes.empty - ~close:(fun _ -> - if close_rec then arg.close ()) + make ~bs:Bytes.empty + ~close:(fun _ -> if close_rec then arg.close ()) ~fill:(fun res -> - if res.len = 0 && !continue then ( - arg.fill_buf(); - res.bs <- arg.bs; - res.off <- arg.off; - res.len <- arg.len; - ) else ( - arg.bs <- Bytes.empty; - arg.off <- 0; - arg.len <- 0; - ) - ) + if res.len = 0 && !continue then ( + arg.fill_buf (); + res.bs <- arg.bs; + res.off <- arg.off; + res.len <- arg.len + ) else ( + arg.bs <- Bytes.empty; + arg.off <- 0; + arg.len <- 0 + )) ~consume:(fun res n -> - size := !size + n; - if !size > max_size then ( - continue := false; - too_big !size - ) else ( - arg.consume n; - res.off <- res.off + n; - res.len <- res.len - n; - )) + size := !size + n; + if !size > max_size then ( + continue := false; + too_big !size + ) else ( + arg.consume n; + res.off <- res.off + n; + res.len <- res.len - n + )) () (* read exactly [size] bytes from the stream *) -let read_exactly ~close_rec ~size ~too_short (arg:t) : t = - if size=0 then ( +let read_exactly ~close_rec ~size ~too_short (arg : t) : t = + if size = 0 then empty - ) else ( + else ( let size = ref size in make ~bs:Bytes.empty ~fill:(fun res -> - (* must not block on [arg] if we're done *) - if !size = 0 then ( - res.bs <- Bytes.empty; - res.off <- 0; - res.len <- 0; - ) else ( - arg.fill_buf(); - res.bs <- arg.bs; - res.off <- arg.off; - let len = min arg.len !size in - if len = 0 && !size > 0 then ( - too_short !size; - ); - res.len <- len; - )) + (* must not block on [arg] if we're done *) + if !size = 0 then ( + res.bs <- Bytes.empty; + res.off <- 0; + res.len <- 0 + ) else ( + arg.fill_buf (); + res.bs <- arg.bs; + res.off <- arg.off; + let len = min arg.len !size in + if len = 0 && !size > 0 then too_short !size; + res.len <- len + )) ~close:(fun _res -> - (* close underlying stream if [close_rec] *) - if close_rec then arg.close(); - size := 0 - ) + (* close underlying stream if [close_rec] *) + if close_rec then arg.close (); + size := 0) ~consume:(fun res n -> - let n = min n !size in - size := !size - n; - arg.consume n; - res.off <- res.off + n; - res.len <- res.len - n; - ) + let n = min n !size in + size := !size - n; + arg.consume n; + res.off <- res.off + n; + res.len <- res.len - n) () ) -let read_line ?(buf=Buf.create()) self : string = +let read_line ?(buf = Buf.create ()) self : string = read_line_into self ~buf; Buf.contents buf -let read_chunked ?(buf=Buf.create()) ~fail (bs:t) : t= +let read_chunked ?(buf = Buf.create ()) ~fail (bs : t) : t = let first = ref true in let read_next_chunk_len () : int = - if !first then ( + if !first then first := false - ) else ( + else ( let line = read_line ~buf bs in - if String.trim line <> "" then raise (fail "expected crlf between chunks";) + if String.trim line <> "" then raise (fail "expected crlf between chunks") ); let line = read_line ~buf bs in (* parse chunk length, ignore extensions *) - let chunk_size = ( - if String.trim line = "" then 0 - else + let chunk_size = + if String.trim line = "" then + 0 + else ( try Scanf.sscanf line "%x %s@\r" (fun n _ext -> n) - with _ -> raise (fail (spf "cannot read chunk size from line %S" line)) - ) in + with _ -> + raise (fail (spf "cannot read chunk size from line %S" line)) + ) + in chunk_size in let refill = ref true in @@ -282,50 +273,43 @@ let read_chunked ?(buf=Buf.create()) ~fail (bs:t) : t= make ~bs:(Bytes.create (16 * 4096)) ~fill:(fun self -> - (* do we need to refill? *) - if self.off >= self.len then ( - if !chunk_size = 0 && !refill then ( - chunk_size := read_next_chunk_len(); - ); - self.off <- 0; - self.len <- 0; - if !chunk_size > 0 then ( - (* read the whole chunk, or [Bytes.length bytes] of it *) - let to_read = min !chunk_size (Bytes.length self.bs) in - read_exactly_ - ~too_short:(fun () -> raise (fail "chunk is too short")) - bs self.bs to_read; - self.len <- to_read; - chunk_size := !chunk_size - to_read; - ) else ( - refill := false; (* stream is finished *) - ) - ); - ) - ~consume:(fun self n -> - self.off <- self.off + n; - self.len <- self.len - n) - ~close:(fun self -> - (* close this overlay, do not close underlying stream *) + (* do we need to refill? *) + if self.off >= self.len then ( + if !chunk_size = 0 && !refill then chunk_size := read_next_chunk_len (); + self.off <- 0; self.len <- 0; - refill:= false - ) + if !chunk_size > 0 then ( + (* read the whole chunk, or [Bytes.length bytes] of it *) + let to_read = min !chunk_size (Bytes.length self.bs) in + read_exactly_ + ~too_short:(fun () -> raise (fail "chunk is too short")) + bs self.bs to_read; + self.len <- to_read; + chunk_size := !chunk_size - to_read + ) else + refill := false (* stream is finished *) + )) + ~consume:(fun self n -> + self.off <- self.off + n; + self.len <- self.len - n) + ~close:(fun self -> + (* close this overlay, do not close underlying stream *) + self.len <- 0; + refill := false) () (* print a stream as a series of chunks *) -let output_chunked (oc:out_channel) (self:t) : unit = +let output_chunked (oc : out_channel) (self : t) : unit = let continue = ref true in while !continue do (* next chunk *) - self.fill_buf(); + self.fill_buf (); let n = self.len in Printf.fprintf oc "%x\r\n" n; output oc self.bs self.off n; self.consume n; - if n = 0 then ( - continue := false; - ); - output_string oc "\r\n"; + if n = 0 then continue := false; + output_string oc "\r\n" done; (* write another crlf after the stream (see #56) *) output_string oc "\r\n"; diff --git a/src/Tiny_httpd_stream.mli b/src/Tiny_httpd_stream.mli index 4a7cb4f9..5256d808 100644 --- a/src/Tiny_httpd_stream.mli +++ b/src/Tiny_httpd_stream.mli @@ -1,4 +1,3 @@ - (** Byte streams. These used to live in {!Tiny_httpd} but are now in their own module. @@ -8,31 +7,21 @@ type hidden (** Type used to make {!t} unbuildable via a record literal. Use {!make} instead. *) type t = { - mutable bs: bytes; - (** The bytes *) - - mutable off : int; - (** Beginning of valid slice in {!bs} *) - - mutable len : int; - (** Length of valid slice in {!bs}. If [len = 0] after + mutable bs: bytes; (** The bytes *) + mutable off: int; (** Beginning of valid slice in {!bs} *) + mutable len: int; + (** Length of valid slice in {!bs}. If [len = 0] after a call to {!fill}, then the stream is finished. *) - fill_buf: unit -> unit; - (** See the current slice of the internal buffer as [bytes, i, len], + (** See the current slice of the internal buffer as [bytes, i, len], where the slice is [bytes[i] .. [bytes[i+len-1]]]. Can block to refill the buffer if there is currently no content. If [len=0] then there is no more data. *) - consume: int -> unit; - (** Consume [n] bytes from the buffer. + (** Consume [n] bytes from the buffer. This should only be called with [n <= len]. *) - - close: unit -> unit; - (** Close the stream. *) - - _rest: hidden; - (** Use {!make} to build a stream. *) + close: unit -> unit; (** Close the stream. *) + _rest: hidden; (** Use {!make} to build a stream. *) } (** A buffered stream, with a view into the current buffer (or refill if empty), and a function to consume [n] bytes. @@ -75,7 +64,8 @@ val make : ?close:(t -> unit) -> consume:(t -> int -> unit) -> fill:(t -> unit) -> - unit -> t + unit -> + t (** [make ~fill ()] creates a byte stream. @param fill is used to refill the buffer, and is called initially. @param close optional closing. @@ -95,18 +85,12 @@ val read_all : ?buf:Tiny_httpd_buf.t -> t -> string @param buf a buffer to (re)use. Its content will be cleared. *) val limit_size_to : - close_rec:bool -> - max_size:int -> - too_big:(int -> unit) -> - t -> t + close_rec:bool -> max_size:int -> too_big:(int -> unit) -> t -> t (* New stream with maximum size [max_size]. @param close_rec if true, closing this will also close the input stream @param too_big called with read size if the max size is reached *) -val read_chunked : - ?buf:Tiny_httpd_buf.t -> - fail:(string -> exn) -> - t -> t +val read_chunked : ?buf:Tiny_httpd_buf.t -> fail:(string -> exn) -> t -> t (** Convert a stream into a stream of byte chunks using the chunked encoding. The size of chunks is not specified. @param buf buffer used for intermediate storage. @@ -114,8 +98,7 @@ val read_chunked : *) val read_exactly : - close_rec:bool -> size:int -> too_short:(int -> unit) -> - t -> t + close_rec:bool -> size:int -> too_short:(int -> unit) -> t -> t (** [read_exactly ~size bs] returns a new stream that reads exactly [size] bytes from [bs], and then closes. @param close_rec if true, closing the resulting stream also closes diff --git a/src/Tiny_httpd_util.ml b/src/Tiny_httpd_util.ml index 2e614c91..3d9fdcbc 100644 --- a/src/Tiny_httpd_util.ml +++ b/src/Tiny_httpd_util.ml @@ -1,4 +1,3 @@ - (* test utils *) (*$inject let pp_res f = function Ok x -> f x | Error e -> e @@ -9,17 +8,15 @@ let is_ascii_char c = Char.code c < 128 *) -let percent_encode ?(skip=fun _->false) s = +let percent_encode ?(skip = fun _ -> false) s = let buf = Buffer.create (String.length s) in String.iter (function | c when skip c -> Buffer.add_char buf c - | (' ' | '!' | '"' | '#' | '$' | '%' | '&' | '\'' | '(' | ')' | '*' | '+' - | ',' | '/' | ':' | ';' | '=' | '?' | '@' | '[' | ']' | '~') - as c -> - Printf.bprintf buf "%%%X" (Char.code c) - | c when Char.code c > 127 -> + | ( ' ' | '!' | '"' | '#' | '$' | '%' | '&' | '\'' | '(' | ')' | '*' | '+' + | ',' | '/' | ':' | ';' | '=' | '?' | '@' | '[' | ']' | '~' ) as c -> Printf.bprintf buf "%%%X" (Char.code c) + | c when Char.code c > 127 -> Printf.bprintf buf "%%%X" (Char.code c) | c -> Buffer.add_char buf c) s; Buffer.contents buf @@ -34,26 +31,28 @@ let percent_encode ?(skip=fun _->false) s = (Some "?") (percent_decode @@ percent_encode "?") *) -let hex_int (s:string) : int = Scanf.sscanf s "%x" (fun x->x) +let hex_int (s : string) : int = Scanf.sscanf s "%x" (fun x -> x) -let percent_decode (s:string) : _ option = +let percent_decode (s : string) : _ option = let buf = Buffer.create (String.length s) in let i = ref 0 in try while !i < String.length s do match String.get s !i with | '%' -> - if !i+2 < String.length s then ( - begin match hex_int @@ String.sub s (!i+1) 2 with - | n -> Buffer.add_char buf (Char.chr n) - | exception _ -> raise Exit - end; - i := !i + 3; - ) else ( + if !i + 2 < String.length s then ( + (match hex_int @@ String.sub s (!i + 1) 2 with + | n -> Buffer.add_char buf (Char.chr n) + | exception _ -> raise Exit); + i := !i + 3 + ) else raise Exit (* truncated *) - ) - | '+' -> Buffer.add_char buf ' '; incr i (* for query strings *) - | c -> Buffer.add_char buf c; incr i + | '+' -> + Buffer.add_char buf ' '; + incr i (* for query strings *) + | c -> + Buffer.add_char buf c; + incr i done; Some (Buffer.contents buf) with Exit -> None @@ -77,7 +76,7 @@ let get_non_query_path s = let get_query s : string = match find_q_index_ s with - | i -> String.sub s (i+1) (String.length s-i-1) + | i -> String.sub s (i + 1) (String.length s - i - 1) | exception Not_found -> "" let split_query s = get_non_query_path s, get_query s @@ -89,16 +88,11 @@ let split_on_slash s : _ list = while !i < n do match String.index_from s !i '/' with | exception Not_found -> - if !i < n then ( - (* last component *) - l := String.sub s !i (n - !i) :: !l; - ); + if !i < n then (* last component *) l := String.sub s !i (n - !i) :: !l; i := n (* done *) | j -> - if j > !i then ( - l := String.sub s !i (j - !i) :: !l; - ); - i := j+1; + if j > !i then l := String.sub s !i (j - !i) :: !l; + i := j + 1 done; List.rev !l @@ -112,31 +106,38 @@ let split_on_slash s : _ list = [] (split_on_slash "//") *) -let parse_query s : (_ list, string) result= +let parse_query s : (_ list, string) result = let pairs = ref [] in - let is_sep_ = function '&' | ';' -> true | _ -> false in + let is_sep_ = function + | '&' | ';' -> true + | _ -> false + in let i = ref 0 in let j = ref 0 in try let percent_decode s = - match percent_decode s with Some x -> x | None -> raise Invalid_query + match percent_decode s with + | Some x -> x + | None -> raise Invalid_query in let parse_pair () = let eq = String.index_from s !i '=' in - let k = percent_decode @@ String.sub s !i (eq- !i) in - let v = percent_decode @@ String.sub s (eq+1) (!j-eq-1) in - pairs := (k,v) :: !pairs; + let k = percent_decode @@ String.sub s !i (eq - !i) in + let v = percent_decode @@ String.sub s (eq + 1) (!j - eq - 1) in + pairs := (k, v) :: !pairs in while !i < String.length s do - while !j < String.length s && not (is_sep_ (String.get s !j)) do incr j done; + while !j < String.length s && not (is_sep_ (String.get s !j)) do + incr j + done; if !j < String.length s then ( assert (is_sep_ (String.get s !j)); - parse_pair(); - i := !j+1; - j := !i; + parse_pair (); + i := !j + 1; + j := !i ) else ( - parse_pair(); - i := String.length s; (* done *) + parse_pair (); + i := String.length s (* done *) ) done; Ok !pairs diff --git a/src/Tiny_httpd_util.mli b/src/Tiny_httpd_util.mli index 025d6519..f29209ce 100644 --- a/src/Tiny_httpd_util.mli +++ b/src/Tiny_httpd_util.mli @@ -29,7 +29,7 @@ val get_query : string -> string (** Obtain the query part of a path. @since 0.4 *) -val parse_query : string -> ((string*string) list, string) result +val parse_query : string -> ((string * string) list, string) result (** Parse a query as a list of ['&'] or [';'] separated [key=value] pairs. The order might not be preserved. @since 0.3 diff --git a/src/bin/curly.ml b/src/bin/curly.ml index 5b938544..b7dabde1 100644 --- a/src/bin/curly.ml +++ b/src/bin/curly.ml @@ -1,11 +1,12 @@ module Result = struct include Result - let (>>=) - : type a b e. (a, e) result -> (a -> (b, e) result) -> (b, e) result - = fun r f -> - match r with - | Ok x -> f x - | (Error _) as e -> e + + let ( >>= ) : + type a b e. (a, e) result -> (a -> (b, e) result) -> (b, e) result = + fun r f -> + match r with + | Ok x -> f x + | Error _ as e -> e end open Result @@ -21,8 +22,7 @@ module Meth = struct | `TRACE | `CONNECT | `PATCH - | `Other of string - ] + | `Other of string ] let to_string = function | `GET -> "GET" @@ -46,44 +46,31 @@ module Header = struct let to_cmd t = t - |> List.map (fun (k, v) -> ["-H"; Printf.sprintf "%s: %s" k v]) + |> List.map (fun (k, v) -> [ "-H"; Printf.sprintf "%s: %s" k v ]) |> List.concat let pp fmt t = - Format.pp_print_list - ~pp_sep:Format.pp_print_newline - (fun fmt (k ,v) -> Format.fprintf fmt "%s: %s\n" k v) + Format.pp_print_list ~pp_sep:Format.pp_print_newline + (fun fmt (k, v) -> Format.fprintf fmt "%s: %s\n" k v) fmt t end module Response = struct - type t = Http.response = - { code: int - ; headers: Header.t - ; body: string - } + type t = Http.response = { code: int; headers: Header.t; body: string } - let default = - { code = 0 - ; headers = [] - ; body = "" } + let default = { code = 0; headers = []; body = "" } let of_stdout s = let lexbuf = Lexing.from_string s in - try Ok (Http.response default lexbuf) - with e -> Error e + try Ok (Http.response default lexbuf) with e -> Error e let pp fmt t = - Format.fprintf fmt "{code=%d;@ headers=%a;@ body=\"%s\"}" - t.code Header.pp t.headers t.body + Format.fprintf fmt "{code=%d;@ headers=%a;@ body=\"%s\"}" t.code Header.pp + t.headers t.body end module Process_result = struct - type t = - { status: Unix.process_status - ; stderr: string - ; stdout: string - } + type t = { status: Unix.process_status; stderr: string; stdout: string } let pp_process_status fmt = function | Unix.WEXITED n -> Format.fprintf fmt "Exit code %d" n @@ -107,118 +94,102 @@ module Error = struct Format.fprintf fmt "Non 0 exit code %a@.%a" Process_result.pp_process_status p.Process_result.status Process_result.pp p - | Failed_to_read_response (e, _) -> + | Failed_to_read_response (e, _) -> Format.fprintf fmt "Couldn't read response:@ %s" (Printexc.to_string e) | Invalid_request r -> Format.fprintf fmt "Invalid request: %s" r | Exn e -> Format.fprintf fmt "Exception: %s" (Printexc.to_string e) end module Request = struct - type t = - { meth: Meth.t - ; url: string - ; headers: Header.t - ; body: string - } + type t = { meth: Meth.t; url: string; headers: Header.t; body: string } - let make ?(headers=Header.empty) ?(body="") ~url ~meth () = - { meth - ; url - ; headers - ; body } + let make ?(headers = Header.empty) ?(body = "") ~url ~meth () = + { meth; url; headers; body } let has_body t = String.length t.body > 0 let validate t = - if has_body t && List.mem t.meth [`GET; `HEAD] then + if has_body t && List.mem t.meth [ `GET; `HEAD ] then Error (Error.Invalid_request "No body is allowed with GET/HEAD methods") else Ok t let to_cmd_args t = List.concat - [ ["-X"; Meth.to_string t.meth] - ; Header.to_cmd t.headers - ; [t.url] - ; (if has_body t then - ["--data-binary"; "@-"] - else - []) + [ + [ "-X"; Meth.to_string t.meth ]; + Header.to_cmd t.headers; + [ t.url ]; + (if has_body t then + [ "--data-binary"; "@-" ] + else + []); ] let pp fmt t = Format.fprintf fmt - "{@ meth=%a;@ url=\"%s\";@ headers=\"%a\";@ body=\"%s\"@ }" - Meth.pp t.meth t.url Header.pp t.headers t.body + "{@ meth=%a;@ url=\"%s\";@ headers=\"%a\";@ body=\"%s\"@ }" Meth.pp t.meth + t.url Header.pp t.headers t.body end let result_of_process_result t = match t.Process_result.status with | Unix.WEXITED 0 -> Ok t - | _ -> Error (Error.Bad_exit t) + | _ -> Error (Error.Bad_exit t) let run prog args stdin_str = - let (stdout, stdin, stderr) = - let prog = - prog :: (List.map Filename.quote args) - |> String.concat " " in - Unix.open_process_full prog [||] in - if String.length stdin_str > 0 then ( - output_string stdin stdin_str - ); - begin - try close_out stdin; - with _ -> () - end; + let stdout, stdin, stderr = + let prog = prog :: List.map Filename.quote args |> String.concat " " in + Unix.open_process_full prog [||] + in + if String.length stdin_str > 0 then output_string stdin stdin_str; + (try close_out stdin with _ -> ()); let stdout_fd = Unix.descr_of_in_channel stdout in let stderr_fd = Unix.descr_of_in_channel stderr in - let (in_buf, err_buf) = Buffer.(create 128, create 128) in + let in_buf, err_buf = Buffer.(create 128, create 128) in let read_buf_len = 512 in let read_buf = Bytes.create read_buf_len in let input ch = match input ch read_buf 0 read_buf_len with | 0 -> Error `Eof - | s -> Ok s in + | s -> Ok s + in let rec loop = function | [] -> () | read_list -> let can_read, _, _ = Unix.select read_list [] [] 1.0 in let to_remove = - List.fold_left (fun to_remove fh -> - let (rr, buf) = - if fh = stderr_fd then ( - (input stderr, err_buf) - ) else ( - (input stdout, in_buf) - ) in - begin match rr with - | Ok len -> - Buffer.add_subbytes buf read_buf 0 len; - to_remove - | Error `Eof -> - fh :: to_remove - end - ) [] can_read in - read_list - |> List.filter (fun fh -> not (List.mem fh to_remove)) - |> loop + List.fold_left + (fun to_remove fh -> + let rr, buf = + if fh = stderr_fd then + input stderr, err_buf + else + input stdout, in_buf + in + match rr with + | Ok len -> + Buffer.add_subbytes buf read_buf 0 len; + to_remove + | Error `Eof -> fh :: to_remove) + [] can_read + in + read_list |> List.filter (fun fh -> not (List.mem fh to_remove)) |> loop in - ignore (loop [ stdout_fd ; stderr_fd ]); + ignore (loop [ stdout_fd; stderr_fd ]); let status = Unix.close_process_full (stdout, stdin, stderr) in - { Process_result. - status - ; stdout = Buffer.contents in_buf - ; stderr = Buffer.contents err_buf + { + Process_result.status; + stdout = Buffer.contents in_buf; + stderr = Buffer.contents err_buf; } -let run ?(exe="curl") ?(args=[]) req = +let run ?(exe = "curl") ?(args = []) req = Request.validate req >>= fun req -> - let args = "-si" :: (Request.to_cmd_args req) @ args in + let args = ("-si" :: Request.to_cmd_args req) @ args in let res = - try - result_of_process_result (run exe args req.Request.body) - with e -> - Error (Error.Exn e) + try result_of_process_result (run exe args req.Request.body) + with e -> Error (Error.Exn e) in res >>= fun res -> match Response.of_stdout res.Process_result.stdout with @@ -227,11 +198,15 @@ let run ?(exe="curl") ?(args=[]) req = let get ?exe ?args ?headers url = run ?exe ?args (Request.make ?headers ~url ~meth:`GET ()) + let head ?exe ?args ?headers url = run ?exe ?args (Request.make ?headers ~url ~meth:`HEAD ()) + let delete ?exe ?args ?headers url = run ?exe ?args (Request.make ?headers ~url ~meth:`DELETE ()) + let post ?exe ?args ?headers ?body url = run ?exe ?args (Request.make ?body ?headers ~url ~meth:`POST ()) + let put ?exe ?args ?headers ?body url = run ?exe ?args (Request.make ?body ?headers ~url ~meth:`PUT ()) diff --git a/src/bin/curly.mli b/src/bin/curly.mli index d3898a75..09e4f1f5 100644 --- a/src/bin/curly.mli +++ b/src/bin/curly.mli @@ -21,42 +21,23 @@ module Header : sig end module Response : sig - type t = - { code: int - ; headers: Header.t - ; body:string - } + type t = { code: int; headers: Header.t; body: string } val pp : Format.formatter -> t -> unit end module Request : sig - type t = - { meth: Meth.t - ; url:string - ; headers: Header.t - ; body:string - } + type t = { meth: Meth.t; url: string; headers: Header.t; body: string } - val make - : ?headers:Header.t - -> ?body:string - -> url:string - -> meth:Meth.t - -> unit - -> t + val make : + ?headers:Header.t -> ?body:string -> url:string -> meth:Meth.t -> unit -> t val to_cmd_args : t -> string list - val pp : Format.formatter -> t -> unit end module Process_result : sig - type t = - { status: Unix.process_status - ; stderr:string - ; stdout:string - } + type t = { status: Unix.process_status; stderr: string; stdout: string } val pp : Format.formatter -> t -> unit end @@ -71,55 +52,55 @@ module Error : sig val pp : Format.formatter -> t -> unit end -val run - : ?exe:string - -> ?args:string list - -> Request.t - -> (Response.t, Error.t) Result.result +val run : + ?exe:string -> + ?args:string list -> + Request.t -> + (Response.t, Error.t) Result.result -val get - : ?exe:string - -> ?args:string list - -> ?headers:Header.t - -> string - -> (Response.t, Error.t) Result.result +val get : + ?exe:string -> + ?args:string list -> + ?headers:Header.t -> + string -> + (Response.t, Error.t) Result.result (** Specialized version of {!run} for method [`GET] @since 0.2.0 *) -val head - : ?exe:string - -> ?args:string list - -> ?headers:Header.t - -> string - -> (Response.t, Error.t) Result.result +val head : + ?exe:string -> + ?args:string list -> + ?headers:Header.t -> + string -> + (Response.t, Error.t) Result.result (** Specialized version of {!run} for method [`HEAD] @since 0.2.0 *) -val delete - : ?exe:string - -> ?args:string list - -> ?headers:Header.t - -> string - -> (Response.t, Error.t) Result.result +val delete : + ?exe:string -> + ?args:string list -> + ?headers:Header.t -> + string -> + (Response.t, Error.t) Result.result (** Specialized version of {!run} for method [`DELETE] @since 0.2.0 *) -val post - : ?exe:string - -> ?args:string list - -> ?headers:Header.t - -> ?body:string - -> string - -> (Response.t, Error.t) Result.result +val post : + ?exe:string -> + ?args:string list -> + ?headers:Header.t -> + ?body:string -> + string -> + (Response.t, Error.t) Result.result (** Specialized version of {!run} for method [`POST] @since 0.2.0 *) -val put - : ?exe:string - -> ?args:string list - -> ?headers:Header.t - -> ?body:string - -> string - -> (Response.t, Error.t) Result.result +val put : + ?exe:string -> + ?args:string list -> + ?headers:Header.t -> + ?body:string -> + string -> + (Response.t, Error.t) Result.result (** Specialized version of {!run} for method [`PUT] @since 0.2.0 *) diff --git a/src/bin/dune b/src/bin/dune index 938770d9..241eb540 100644 --- a/src/bin/dune +++ b/src/bin/dune @@ -1,18 +1,17 @@ +(executable + (name http_of_dir) + (public_name http_of_dir) + (package tiny_httpd) + (modules http_of_dir) + (flags :standard -warn-error -3) + (libraries tiny_httpd)) (executable - (name http_of_dir) - (public_name http_of_dir) - (package tiny_httpd) - (modules http_of_dir) - (flags :standard -warn-error -3) - (libraries tiny_httpd)) - -(executable - (name vfs_pack) - (public_name tiny-httpd-vfs-pack) - (package tiny_httpd) - (modules vfs_pack curly http) - (libraries result unix) - (flags :standard -warn-error -3)) + (name vfs_pack) + (public_name tiny-httpd-vfs-pack) + (package tiny_httpd) + (modules vfs_pack curly http) + (libraries result unix) + (flags :standard -warn-error -3)) (ocamllex http) diff --git a/src/bin/http.mli b/src/bin/http.mli index 044d53a6..24913731 100644 --- a/src/bin/http.mli +++ b/src/bin/http.mli @@ -1,9 +1,5 @@ (* The purpose of this module isn't to be a full blown http parser but rather to only parse whatever curl otputs *) -type response = - { code: int - ; headers: (string * string) list - ; body: string - } +type response = { code: int; headers: (string * string) list; body: string } val response : response -> Lexing.lexbuf -> response diff --git a/src/bin/http_of_dir.ml b/src/bin/http_of_dir.ml index e532ac19..9d192fdf 100644 --- a/src/bin/http_of_dir.ml +++ b/src/bin/http_of_dir.ml @@ -3,10 +3,14 @@ module U = Tiny_httpd_util module D = Tiny_httpd_dir module Pf = Printf -let serve ~config (dir:string) addr port j : _ result = +let serve ~config (dir : string) addr port j : _ result = let server = S.create ~max_connections:j ~addr ~port () in - Printf.printf "serve directory %s on http://%(%s%):%d\n%!" - dir (if S.is_ipv6 server then "[%s]" else "%s") addr port; + Printf.printf "serve directory %s on http://%(%s%):%d\n%!" dir + (if S.is_ipv6 server then + "[%s]" + else + "%s") + addr port; D.add_dir_path ~config ~dir ~prefix:"" server; S.run server @@ -14,43 +18,62 @@ let serve ~config (dir:string) addr port j : _ result = let parse_size s : int = try Scanf.sscanf s "%dM" (fun n -> n * 1_024 * 1_024) with _ -> - try Scanf.sscanf s "%dk" (fun n -> n * 1_024) - with _ -> - try int_of_string s - with _ -> raise (Arg.Bad "invalid size (expected [kM]?)") + (try Scanf.sscanf s "%dk" (fun n -> n * 1_024) + with _ -> + (try int_of_string s + with _ -> raise (Arg.Bad "invalid size (expected [kM]?)"))) let main () = - let config = - D.config ~dir_behavior:Index_or_lists () - in + let config = D.config ~dir_behavior:Index_or_lists () in let dir_ = ref "." in let addr = ref "127.0.0.1" in let port = ref 8080 in - let j = ref 32 in - Arg.parse (Arg.align [ - "--addr", Set_string addr, " address to listen on"; - "-a", Set_string addr, " alias to --listen"; - "--port", Set_int port, " port to listen on"; - "-p", Set_int port, " alias to --port"; - "--dir", Set_string dir_, " directory to serve (default: \".\")"; - "--debug", Unit (fun () -> S._enable_debug true), " debug mode"; - "--upload", Unit (fun () -> config.upload <- true), " enable file uploading"; - "--no-upload", Unit (fun () -> config.upload <- false), " disable file uploading"; - "--download", Unit (fun () -> config.download <- true), " enable file downloading"; - "--no-download", Unit (fun () -> config.download <- false), " disable file downloading"; - "--max-upload", String (fun i -> config.max_upload_size <- parse_size i), - " maximum size of files that can be uploaded"; - "--auto-index", - Bool (fun b -> config.dir_behavior <- - (if b then Index_or_lists else Lists)), - " automatically redirect to index.html if present"; - "--delete", Unit (fun () -> config.delete <- true), " enable `delete` on files"; - "--no-delete", Unit (fun () -> config.delete <- false), " disable `delete` on files"; - "-j", Set_int j, " maximum number of simultaneous connections"; - ]) (fun s -> dir_ := s) "http_of_dir [options] [dir]"; + let j = ref 32 in + Arg.parse + (Arg.align + [ + "--addr", Set_string addr, " address to listen on"; + "-a", Set_string addr, " alias to --listen"; + "--port", Set_int port, " port to listen on"; + "-p", Set_int port, " alias to --port"; + "--dir", Set_string dir_, " directory to serve (default: \".\")"; + "--debug", Unit (fun () -> S._enable_debug true), " debug mode"; + ( "--upload", + Unit (fun () -> config.upload <- true), + " enable file uploading" ); + ( "--no-upload", + Unit (fun () -> config.upload <- false), + " disable file uploading" ); + ( "--download", + Unit (fun () -> config.download <- true), + " enable file downloading" ); + ( "--no-download", + Unit (fun () -> config.download <- false), + " disable file downloading" ); + ( "--max-upload", + String (fun i -> config.max_upload_size <- parse_size i), + " maximum size of files that can be uploaded" ); + ( "--auto-index", + Bool + (fun b -> + config.dir_behavior <- + (if b then + Index_or_lists + else + Lists)), + " automatically redirect to index.html if present" ); + ( "--delete", + Unit (fun () -> config.delete <- true), + " enable `delete` on files" ); + ( "--no-delete", + Unit (fun () -> config.delete <- false), + " disable `delete` on files" ); + "-j", Set_int j, " maximum number of simultaneous connections"; + ]) + (fun s -> dir_ := s) + "http_of_dir [options] [dir]"; match serve ~config !dir_ !addr !port !j with | Ok () -> () - | Error e -> - raise e + | Error e -> raise e let () = main () diff --git a/src/bin/vfs_pack.ml b/src/bin/vfs_pack.ml index c1242153..03a19d50 100644 --- a/src/bin/vfs_pack.ml +++ b/src/bin/vfs_pack.ml @@ -1,7 +1,6 @@ - let spf = Printf.sprintf let fpf = Printf.fprintf -let now_ = Unix.gettimeofday() +let now_ = Unix.gettimeofday () let verbose = ref false type entry = @@ -15,83 +14,85 @@ let read_file filename = let buf = Buffer.create 32 in let b = Bytes.create 1024 in while - let n=input ic b 0 (Bytes.length b) in + let n = input ic b 0 (Bytes.length b) in Buffer.add_subbytes buf b 0 n; n > 0 - do () done; + do + () + done; close_in ic; Buffer.contents buf -let split_comma s = Scanf.sscanf s "%s@,%s" (fun x y -> x,y) +let split_comma s = Scanf.sscanf s "%s@,%s" (fun x y -> x, y) let is_url s = let is_prefix pre s = - String.length s > String.length pre && - String.sub s 0 (String.length pre) = pre + String.length s > String.length pre + && String.sub s 0 (String.length pre) = pre in is_prefix "http://" s || is_prefix "https://" s -let emit oc (l:entry list) : unit = - fpf oc "let embedded_fs = Tiny_httpd_dir.Embedded_fs.create ~mtime:%f ()\n" now_; +let emit oc (l : entry list) : unit = + fpf oc "let embedded_fs = Tiny_httpd_dir.Embedded_fs.create ~mtime:%f ()\n" + now_; let add_vfs ~mtime vfs_path content = fpf oc - "let () = Tiny_httpd_dir.Embedded_fs.add_file embedded_fs \n \ - ~mtime:%h ~path:%S\n \ - %S\n" + "let () = Tiny_httpd_dir.Embedded_fs.add_file embedded_fs \n\ + \ ~mtime:%h ~path:%S\n\ + \ %S\n" mtime vfs_path content in let rec add_entry = function | File (vfs_path, actual_path) -> - if !verbose then Printf.eprintf "add file %S = %S\n%!" vfs_path actual_path; + if !verbose then + Printf.eprintf "add file %S = %S\n%!" vfs_path actual_path; let content = read_file actual_path in let mtime = (Unix.stat actual_path).Unix.st_mtime in add_vfs ~mtime vfs_path content - | Url (vfs_path, url) -> if !verbose then Printf.eprintf "add url %S = %S\n%!" vfs_path url; - begin match Curly.get ~args:["-L"] url with - | Ok b -> - let code = b.Curly.Response.code in - if code >= 200 && code < 300 then ( - add_vfs ~mtime:now_ vfs_path b.Curly.Response.body - ) else ( - failwith (Printf.sprintf "download of %S failed with code: %d" url code) - ) - | Error err -> - failwith (Format.asprintf "download of %S failed: %a" url Curly.Error.pp err) - end - + (match Curly.get ~args:[ "-L" ] url with + | Ok b -> + let code = b.Curly.Response.code in + if code >= 200 && code < 300 then + add_vfs ~mtime:now_ vfs_path b.Curly.Response.body + else + failwith + (Printf.sprintf "download of %S failed with code: %d" url code) + | Error err -> + failwith + (Format.asprintf "download of %S failed: %a" url Curly.Error.pp err)) | Mirror (vfs_path, dir) -> - if !verbose then Printf.eprintf "mirror directory %S as %S\n%!" dir vfs_path; + if !verbose then + Printf.eprintf "mirror directory %S as %S\n%!" dir vfs_path; let rec traverse rpath = let real_path = Filename.concat dir rpath in if Sys.is_directory real_path then ( let arr = Sys.readdir real_path in Array.iter (fun e -> traverse (Filename.concat rpath e)) arr - ) else ( + ) else add_entry (File (Filename.concat vfs_path rpath, real_path)) - ) in traverse "." - | Source_file f -> if !verbose then Printf.eprintf "read source file %S\n%!" f; let lines = - read_file f |> String.split_on_char '\n' - |> List.map String.trim - |> List.filter ((<>) "") + read_file f |> String.split_on_char '\n' |> List.map String.trim + |> List.filter (( <> ) "") in let process_line line = let vfs_path, path = split_comma line in - if is_url path then add_entry (Url(vfs_path, path)) - else add_entry (File (vfs_path, path)) + if is_url path then + add_entry (Url (vfs_path, path)) + else + add_entry (File (vfs_path, path)) in List.iter process_line lines @@ -101,8 +102,8 @@ let emit oc (l:entry list) : unit = fpf oc "let vfs = Tiny_httpd_dir.Embedded_fs.to_vfs embedded_fs\n"; () - -let help = {|vfs-pack [opt]+ +let help = + {|vfs-pack [opt]+ Builds an OCaml module containing a `Tiny_httpd_dir.Embedded_fs.t` virtual file system. This is useful to pack assets into an OCaml binary, @@ -121,7 +122,6 @@ and is processed as previously. If actual_path looks like an http(s) URL it is treated as such. |} - let () = let entries = ref [] in let out = ref "" in @@ -133,30 +133,45 @@ let () = add_entry (File (vfs_path, path)) and add_mirror s = let vfs_path, path = split_comma s in - let vfs_path, path = if path="" then "", vfs_path else vfs_path, path in + let vfs_path, path = + if path = "" then + "", vfs_path + else + vfs_path, path + in add_entry (Mirror (vfs_path, path)) and add_source f = add_entry (Source_file f) and add_url s = let vfs_path, path = split_comma s in - if is_url path then add_entry (Url(vfs_path, path)) - else invalid_arg (spf "--url: invalid URL %S" path) + if is_url path then + add_entry (Url (vfs_path, path)) + else + invalid_arg (spf "--url: invalid URL %S" path) in - let opts = [ - "-v", Arg.Set verbose, " verbose mode"; - "-o", Arg.Set_string out, " set output file"; - "--file", Arg.String add_file, " adds name=file to the VFS"; - "--url", Arg.String add_url, " adds name=url to the VFS"; - "--mirror", Arg.String add_mirror, " copies directory dir into the VFS under prefix"; - "-F", Arg.String add_source, " reads entries from the file, on per line"; - ] |> Arg.align in + let opts = + [ + "-v", Arg.Set verbose, " verbose mode"; + "-o", Arg.Set_string out, " set output file"; + "--file", Arg.String add_file, " adds name=file to the VFS"; + "--url", Arg.String add_url, " adds name=url to the VFS"; + ( "--mirror", + Arg.String add_mirror, + " copies directory dir into the VFS under prefix" ); + ( "-F", + Arg.String add_source, + " reads entries from the file, on per line" ); + ] + |> Arg.align + in Arg.parse opts (fun _ -> raise (Arg.Help "no positional arg")) help; let out, close = - if !out="" then stdout,ignore - else open_out !out, close_out + if !out = "" then + stdout, ignore + else + open_out !out, close_out in emit out !entries; close out; exit 0 - diff --git a/src/camlzip/Tiny_httpd_camlzip.ml b/src/camlzip/Tiny_httpd_camlzip.ml index e9ce0269..6fdb501a 100644 --- a/src/camlzip/Tiny_httpd_camlzip.ml +++ b/src/camlzip/Tiny_httpd_camlzip.ml @@ -1,171 +1,152 @@ - module S = Tiny_httpd_server module BS = Tiny_httpd_stream -let decode_deflate_stream_ ~buf_size (is:S.byte_stream) : S.byte_stream = - S._debug (fun k->k "wrap stream with deflate.decode"); +let decode_deflate_stream_ ~buf_size (is : S.byte_stream) : S.byte_stream = + S._debug (fun k -> k "wrap stream with deflate.decode"); let zlib_str = Zlib.inflate_init false in let is_done = ref false in - BS.make - ~bs:(Bytes.create buf_size) + BS.make ~bs:(Bytes.create buf_size) ~close:(fun _ -> - Zlib.inflate_end zlib_str; - BS.close is - ) + Zlib.inflate_end zlib_str; + BS.close is) ~consume:(fun self len -> - if len > self.len then ( - S.Response.fail_raise ~code:400 - "inflate: error during decompression: invalid consume len %d (max %d)" - len self.len - ); - self.off <- self.off + len; - self.len <- self.len - len; - ) + if len > self.len then + S.Response.fail_raise ~code:400 + "inflate: error during decompression: invalid consume len %d (max %d)" + len self.len; + self.off <- self.off + len; + self.len <- self.len - len) ~fill:(fun self -> - (* refill [buf] if needed *) - if self.len = 0 && not !is_done then ( - is.fill_buf(); - begin - try - let finished, used_in, used_out = - Zlib.inflate zlib_str - self.bs 0 (Bytes.length self.bs) - is.bs is.off is.len Zlib.Z_SYNC_FLUSH - in - is.consume used_in; - self.off <- 0; - self.len <- used_out; - if finished then is_done := true; - S._debug (fun k->k "decode %d bytes as %d bytes from inflate (finished: %b)" - used_in used_out finished); - with Zlib.Error (e1,e2) -> - S.Response.fail_raise ~code:400 - "inflate: error during decompression:\n%s %s" e1 e2 - end; - S._debug (fun k->k "inflate: refill %d bytes into internal buf" self.len); - ); - ) + (* refill [buf] if needed *) + if self.len = 0 && not !is_done then ( + is.fill_buf (); + (try + let finished, used_in, used_out = + Zlib.inflate zlib_str self.bs 0 (Bytes.length self.bs) is.bs is.off + is.len Zlib.Z_SYNC_FLUSH + in + is.consume used_in; + self.off <- 0; + self.len <- used_out; + if finished then is_done := true; + S._debug (fun k -> + k "decode %d bytes as %d bytes from inflate (finished: %b)" + used_in used_out finished) + with Zlib.Error (e1, e2) -> + S.Response.fail_raise ~code:400 + "inflate: error during decompression:\n%s %s" e1 e2); + S._debug (fun k -> + k "inflate: refill %d bytes into internal buf" self.len) + )) () -let encode_deflate_stream_ ~buf_size (is:S.byte_stream) : S.byte_stream = - S._debug (fun k->k "wrap stream with deflate.encode"); +let encode_deflate_stream_ ~buf_size (is : S.byte_stream) : S.byte_stream = + S._debug (fun k -> k "wrap stream with deflate.encode"); let refill = ref true in let zlib_str = Zlib.deflate_init 4 false in - BS.make - ~bs:(Bytes.create buf_size) + BS.make ~bs:(Bytes.create buf_size) ~close:(fun _self -> - S._debug (fun k->k "deflate: close"); - Zlib.deflate_end zlib_str; - BS.close is - ) + S._debug (fun k -> k "deflate: close"); + Zlib.deflate_end zlib_str; + BS.close is) ~consume:(fun self n -> - self.off <- self.off + n; - self.len <- self.len - n - ) + self.off <- self.off + n; + self.len <- self.len - n) ~fill:(fun self -> - let rec loop() = - S._debug (fun k->k "deflate.fill.iter out_off=%d out_len=%d" - self.off self.len); - if self.len > 0 then ( - () (* still the same slice, not consumed entirely by output *) - ) else if not !refill then ( - () (* empty slice, no refill *) + let rec loop () = + S._debug (fun k -> + k "deflate.fill.iter out_off=%d out_len=%d" self.off self.len); + if self.len > 0 then + () + (* still the same slice, not consumed entirely by output *) + else if not !refill then + () + (* empty slice, no refill *) + else ( + (* the output was entirely consumed, we need to do more work *) + is.BS.fill_buf (); + if is.len > 0 then ( + (* try to decompress from input buffer *) + let _finished, used_in, used_out = + Zlib.deflate zlib_str is.bs is.off is.len self.bs 0 + (Bytes.length self.bs) Zlib.Z_NO_FLUSH + in + self.off <- 0; + self.len <- used_out; + is.consume used_in; + S._debug (fun k -> + k "encode %d bytes as %d bytes using deflate (finished: %b)" + used_in used_out _finished); + if _finished then ( + S._debug (fun k -> k "deflate: finished"); + refill := false + ); + loop () ) else ( - (* the output was entirely consumed, we need to do more work *) - is.BS.fill_buf(); - if is.len > 0 then ( - (* try to decompress from input buffer *) - let _finished, used_in, used_out = - Zlib.deflate zlib_str - is.bs is.off is.len - self.bs 0 (Bytes.length self.bs) - Zlib.Z_NO_FLUSH - in - self.off <- 0; - self.len <- used_out; - is.consume used_in; - S._debug - (fun k->k "encode %d bytes as %d bytes using deflate (finished: %b)" - used_in used_out _finished); - if _finished then ( - S._debug (fun k->k "deflate: finished"); - refill := false; - ); - loop() - ) else ( - (* [is] is done, finish sending the data in current buffer *) - let _finished, used_in, used_out = - Zlib.deflate zlib_str - is.bs is.off is.len - self.bs 0 (Bytes.length self.bs) - Zlib.Z_FULL_FLUSH - in - assert (used_in = 0); - self.off <- 0; - self.len <- used_out; - if used_out = 0 then ( - refill := false; - ); - loop() - ) + (* [is] is done, finish sending the data in current buffer *) + let _finished, used_in, used_out = + Zlib.deflate zlib_str is.bs is.off is.len self.bs 0 + (Bytes.length self.bs) Zlib.Z_FULL_FLUSH + in + assert (used_in = 0); + self.off <- 0; + self.len <- used_out; + if used_out = 0 then refill := false; + loop () ) - in - try loop() - with Zlib.Error (e1,e2) -> - S.Response.fail_raise ~code:400 - "deflate: error during compression:\n%s %s" e1 e2 - ) + ) + in + try loop () + with Zlib.Error (e1, e2) -> + S.Response.fail_raise ~code:400 + "deflate: error during compression:\n%s %s" e1 e2) () -let split_on_char ?(f=fun x->x) c s : string list = +let split_on_char ?(f = fun x -> x) c s : string list = let rec loop acc i = match String.index_from s i c with | exception Not_found -> let acc = - if i=String.length s then acc - else f (String.sub s i (String.length s-i)) :: acc - in List.rev acc + if i = String.length s then + acc + else + f (String.sub s i (String.length s - i)) :: acc + in + List.rev acc | j -> - let acc = f (String.sub s i (j-i)) :: acc in - loop acc (j+1) + let acc = f (String.sub s i (j - i)) :: acc in + loop acc (j + 1) in loop [] 0 -let accept_deflate (req:_ S.Request.t) = - match - S.Request.get_header req "Accept-Encoding" - with +let accept_deflate (req : _ S.Request.t) = + match S.Request.get_header req "Accept-Encoding" with | Some s -> List.mem "deflate" @@ split_on_char ~f:String.trim ',' s | None -> false let has_deflate s = - try Scanf.sscanf s "deflate, %s" (fun _ -> true) - with _ -> false + try Scanf.sscanf s "deflate, %s" (fun _ -> true) with _ -> false (* decompress [req]'s body if needed *) -let decompress_req_stream_ ~buf_size (req:BS.t S.Request.t) : _ S.Request.t = +let decompress_req_stream_ ~buf_size (req : BS.t S.Request.t) : _ S.Request.t = match S.Request.get_header ~f:String.trim req "Transfer-Encoding" with (* TODO - | Some "gzip" -> - let req' = S.Request.set_header req "Transfer-Encoding" "chunked" in - Some (req', decode_gzip_stream_) + | Some "gzip" -> + let req' = S.Request.set_header req "Transfer-Encoding" "chunked" in + Some (req', decode_gzip_stream_) *) | Some s when has_deflate s -> - begin match Scanf.sscanf s "deflate, %s" (fun s -> s) with - | tr' -> - let body' = S.Request.body req |> decode_deflate_stream_ ~buf_size in - req - |> S.Request.set_header "Transfer-Encoding" tr' - |> S.Request.set_body body' - | exception _ -> req - end + (match Scanf.sscanf s "deflate, %s" (fun s -> s) with + | tr' -> + let body' = S.Request.body req |> decode_deflate_stream_ ~buf_size in + req + |> S.Request.set_header "Transfer-Encoding" tr' + |> S.Request.set_body body' + | exception _ -> req) | _ -> req -let compress_resp_stream_ - ~compress_above - ~buf_size - (req:_ S.Request.t) (resp:S.Response.t) : S.Response.t = - +let compress_resp_stream_ ~compress_above ~buf_size (req : _ S.Request.t) + (resp : S.Response.t) : S.Response.t = (* headers for compressed stream *) let update_headers h = h @@ -177,39 +158,31 @@ let compress_resp_stream_ match resp.body with | `String s when String.length s > compress_above -> (* big string, we compress *) - S._debug - (fun k->k "encode str response with deflate (size %d, threshold %d)" - (String.length s) compress_above); - let body = - encode_deflate_stream_ ~buf_size @@ BS.of_string s - in + S._debug (fun k -> + k "encode str response with deflate (size %d, threshold %d)" + (String.length s) compress_above); + let body = encode_deflate_stream_ ~buf_size @@ BS.of_string s in resp |> S.Response.update_headers update_headers |> S.Response.set_body (`Stream body) - | `Stream str -> - S._debug (fun k->k "encode stream response with deflate"); + S._debug (fun k -> k "encode stream response with deflate"); resp |> S.Response.update_headers update_headers |> S.Response.set_body (`Stream (encode_deflate_stream_ ~buf_size str)) - | `String _ | `Void -> resp - ) else resp + ) else + resp -let middleware - ?(compress_above=16 * 1024) - ?(buf_size=16 * 1_024) - () : S.Middleware.t = +let middleware ?(compress_above = 16 * 1024) ?(buf_size = 16 * 1_024) () : + S.Middleware.t = let buf_size = max buf_size 1_024 in fun h req ~resp -> let req = decompress_req_stream_ ~buf_size req in - h req - ~resp:(fun response -> - resp @@ compress_resp_stream_ ~buf_size ~compress_above req response) + h req ~resp:(fun response -> + resp @@ compress_resp_stream_ ~buf_size ~compress_above req response) -let setup - ?compress_above ?buf_size server = +let setup ?compress_above ?buf_size server = let m = middleware ?compress_above ?buf_size () in - S._debug (fun k->k "setup gzip support"); + S._debug (fun k -> k "setup gzip support"); S.add_middleware ~stage:`Encoding server m - diff --git a/src/camlzip/Tiny_httpd_camlzip.mli b/src/camlzip/Tiny_httpd_camlzip.mli index 52f17cd8..e61e1806 100644 --- a/src/camlzip/Tiny_httpd_camlzip.mli +++ b/src/camlzip/Tiny_httpd_camlzip.mli @@ -1,14 +1,9 @@ - val middleware : - ?compress_above:int -> - ?buf_size:int -> unit -> - Tiny_httpd_server.Middleware.t + ?compress_above:int -> ?buf_size:int -> unit -> Tiny_httpd_server.Middleware.t (** Middleware responsible for deflate compression/decompression. @since 0.11 *) -val setup : - ?compress_above:int -> - ?buf_size:int -> Tiny_httpd_server.t -> unit +val setup : ?compress_above:int -> ?buf_size:int -> Tiny_httpd_server.t -> unit (** Install middleware for tiny_httpd to be able to encode/decode compressed streams @param compress_above threshold above with string responses are compressed diff --git a/src/camlzip/dune b/src/camlzip/dune index b0e3ab5e..6ffc109f 100644 --- a/src/camlzip/dune +++ b/src/camlzip/dune @@ -1,7 +1,6 @@ - (library - (name tiny_httpd_camlzip) - (public_name tiny_httpd_camlzip) - (synopsis "A wrapper around camlzip to bring compression to Tiny_httpd") - (flags :standard -safe-string -warn-error -a+8) - (libraries tiny_httpd camlzip)) + (name tiny_httpd_camlzip) + (public_name tiny_httpd_camlzip) + (synopsis "A wrapper around camlzip to bring compression to Tiny_httpd") + (flags :standard -safe-string -warn-error -a+8) + (libraries tiny_httpd camlzip)) diff --git a/src/dune b/src/dune index 27ee21cd..dbad182e 100644 --- a/src/dune +++ b/src/dune @@ -1,12 +1,15 @@ - (library - (name tiny_httpd) - (public_name tiny_httpd) - (libraries threads seq) - (flags :standard -safe-string -warn-error -a+8) - (wrapped false)) + (name tiny_httpd) + (public_name tiny_httpd) + (libraries threads seq) + (flags :standard -safe-string -warn-error -a+8) + (wrapped false)) (rule - (targets Tiny_httpd_html_.ml) - (deps (:bin ./gen/gentags.exe)) - (action (with-stdout-to %{targets} (run %{bin})))) + (targets Tiny_httpd_html_.ml) + (deps + (:bin ./gen/gentags.exe)) + (action + (with-stdout-to + %{targets} + (run %{bin})))) diff --git a/src/gen/dune b/src/gen/dune index e8bf783e..c741e9af 100644 --- a/src/gen/dune +++ b/src/gen/dune @@ -1,4 +1,2 @@ (executable - (name gentags)) - - + (name gentags)) diff --git a/src/gen/gentags.ml b/src/gen/gentags.ml index 19ce5aaa..09ead697 100644 --- a/src/gen/gentags.ml +++ b/src/gen/gentags.ml @@ -1,146 +1,148 @@ - (* adapted from https://github.com/sindresorhus/html-tags (MIT licensed) *) let pf = Printf.printf let spf = Printf.sprintf -let void = [ - "area"; - "base"; - "br"; - "col"; - "embed"; - "hr"; - "img"; - "input"; - "link"; - "menuitem"; - "meta"; - "param"; - "source"; - "track"; - "wbr"; -] +let void = + [ + "area"; + "base"; + "br"; + "col"; + "embed"; + "hr"; + "img"; + "input"; + "link"; + "menuitem"; + "meta"; + "param"; + "source"; + "track"; + "wbr"; + ] -let normal = [ - "a"; - "abbr"; - "address"; - "area"; - "article"; - "aside"; - "audio"; - "b"; - "base"; - "bdi"; - "bdo"; - "blockquote"; - "body"; - "br"; - "button"; - "canvas"; - "caption"; - "cite"; - "code"; - "col"; - "colgroup"; - "data"; - "datalist"; - "dd"; - "del"; - "details"; - "dfn"; - "dialog"; - "div"; - "dl"; - "dt"; - "em"; - "embed"; - "fieldset"; - "figcaption"; - "figure"; - "footer"; - "form"; - "h1"; - "h2"; - "h3"; - "h4"; - "h5"; - "h6"; - "head"; - "header"; - "hgroup"; - "hr"; - "html"; - "i"; - "iframe"; - "img"; - "input"; - "ins"; - "kbd"; - "label"; - "legend"; - "li"; - "link"; - "main"; - "map"; - "mark"; - "math"; - "menu"; - "menuitem"; - "meta"; - "meter"; - "nav"; - "noscript"; - "object"; - "ol"; - "optgroup"; - "option"; - "output"; - "p"; - "param"; - "picture"; - "pre"; - "progress"; - "q"; - "rb"; - "rp"; - "rt"; - "rtc"; - "ruby"; - "s"; - "samp"; - "script"; - "section"; - "select"; - "slot"; - "small"; - "source"; - "span"; - "strong"; - "style"; - "sub"; - "summary"; - "sup"; - "svg"; - "table"; - "tbody"; - "td"; - "template"; - "textarea"; - "tfoot"; - "th"; - "thead"; - "time"; - "title"; - "tr"; - "track"; - "u"; - "ul"; - "var"; - "video"; - "wbr"; -] |> List.filter (fun s -> not (List.mem s void)) +let normal = + [ + "a"; + "abbr"; + "address"; + "area"; + "article"; + "aside"; + "audio"; + "b"; + "base"; + "bdi"; + "bdo"; + "blockquote"; + "body"; + "br"; + "button"; + "canvas"; + "caption"; + "cite"; + "code"; + "col"; + "colgroup"; + "data"; + "datalist"; + "dd"; + "del"; + "details"; + "dfn"; + "dialog"; + "div"; + "dl"; + "dt"; + "em"; + "embed"; + "fieldset"; + "figcaption"; + "figure"; + "footer"; + "form"; + "h1"; + "h2"; + "h3"; + "h4"; + "h5"; + "h6"; + "head"; + "header"; + "hgroup"; + "hr"; + "html"; + "i"; + "iframe"; + "img"; + "input"; + "ins"; + "kbd"; + "label"; + "legend"; + "li"; + "link"; + "main"; + "map"; + "mark"; + "math"; + "menu"; + "menuitem"; + "meta"; + "meter"; + "nav"; + "noscript"; + "object"; + "ol"; + "optgroup"; + "option"; + "output"; + "p"; + "param"; + "picture"; + "pre"; + "progress"; + "q"; + "rb"; + "rp"; + "rt"; + "rtc"; + "ruby"; + "s"; + "samp"; + "script"; + "section"; + "select"; + "slot"; + "small"; + "source"; + "span"; + "strong"; + "style"; + "sub"; + "summary"; + "sup"; + "svg"; + "table"; + "tbody"; + "td"; + "template"; + "textarea"; + "tfoot"; + "th"; + "thead"; + "time"; + "title"; + "tr"; + "track"; + "u"; + "ul"; + "var"; + "video"; + "wbr"; + ] + |> List.filter (fun s -> not (List.mem s void)) (* obtained via: {[ @@ -150,134 +152,136 @@ let normal = [ ]} on https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes *) -let attrs = [ - "accept"; - "accept-charset"; - "accesskey"; - "action"; - "align"; - "allow"; - "alt"; - "async"; - "autocapitalize"; - "autocomplete"; - "autofocus"; - "autoplay"; - "buffered"; - "capture"; - "challenge"; - "charset"; - "checked"; - "cite"; - "class"; - "code"; - "codebase"; - "cols"; - "colspan"; - "content"; - "contenteditable"; - "contextmenu"; - "controls"; - "coords"; - "crossorigin"; - "csp"; - "data"; - "data-*"; - "datetime"; - "decoding"; - "default"; - "defer"; - "dir"; - "dirname"; - "disabled"; - "download"; - "draggable"; - "enctype"; - "enterkeyhint"; - "for"; - "form"; - "formaction"; - "formenctype"; - "formmethod"; - "formnovalidate"; - "formtarget"; - "headers"; - "hidden"; - "high"; - "href"; - "hreflang"; - "http-equiv"; - "icon"; - "id"; - "importance"; - "integrity"; - "ismap"; - "itemprop"; - "keytype"; - "kind"; - "label"; - "lang"; - "language"; - "list"; - "loop"; - "low"; - "manifest"; - "max"; - "maxlength"; - "minlength"; - "media"; - "method"; - "min"; - "multiple"; - "muted"; - "name"; - "novalidate"; - "open"; - "optimum"; - "pattern"; - "ping"; - "placeholder"; - "poster"; - "preload"; - "radiogroup"; - "readonly"; - "referrerpolicy"; - "rel"; - "required"; - "reversed"; - "rows"; - "rowspan"; - "sandbox"; - "scope"; - "scoped"; - "selected"; - "shape"; - "size"; - "sizes"; - "slot"; - "span"; - "spellcheck"; - "src"; - "srcdoc"; - "srclang"; - "srcset"; - "start"; - "step"; - "style"; - "summary"; - "tabindex"; - "target"; - "title"; - "translate"; - "Text"; - "type"; - "usemap"; - "value"; - "width"; - "wrap"; -] +let attrs = + [ + "accept"; + "accept-charset"; + "accesskey"; + "action"; + "align"; + "allow"; + "alt"; + "async"; + "autocapitalize"; + "autocomplete"; + "autofocus"; + "autoplay"; + "buffered"; + "capture"; + "challenge"; + "charset"; + "checked"; + "cite"; + "class"; + "code"; + "codebase"; + "cols"; + "colspan"; + "content"; + "contenteditable"; + "contextmenu"; + "controls"; + "coords"; + "crossorigin"; + "csp"; + "data"; + "data-*"; + "datetime"; + "decoding"; + "default"; + "defer"; + "dir"; + "dirname"; + "disabled"; + "download"; + "draggable"; + "enctype"; + "enterkeyhint"; + "for"; + "form"; + "formaction"; + "formenctype"; + "formmethod"; + "formnovalidate"; + "formtarget"; + "headers"; + "hidden"; + "high"; + "href"; + "hreflang"; + "http-equiv"; + "icon"; + "id"; + "importance"; + "integrity"; + "ismap"; + "itemprop"; + "keytype"; + "kind"; + "label"; + "lang"; + "language"; + "list"; + "loop"; + "low"; + "manifest"; + "max"; + "maxlength"; + "minlength"; + "media"; + "method"; + "min"; + "multiple"; + "muted"; + "name"; + "novalidate"; + "open"; + "optimum"; + "pattern"; + "ping"; + "placeholder"; + "poster"; + "preload"; + "radiogroup"; + "readonly"; + "referrerpolicy"; + "rel"; + "required"; + "reversed"; + "rows"; + "rowspan"; + "sandbox"; + "scope"; + "scoped"; + "selected"; + "shape"; + "size"; + "sizes"; + "slot"; + "span"; + "spellcheck"; + "src"; + "srcdoc"; + "srclang"; + "srcset"; + "start"; + "step"; + "style"; + "summary"; + "tabindex"; + "target"; + "title"; + "translate"; + "Text"; + "type"; + "usemap"; + "value"; + "width"; + "wrap"; + ] -let prelude = {| +let prelude = + {| (** Output for HTML combinators. This output type is used to produce a string reasonably efficiently from @@ -431,11 +435,17 @@ let oname = function | "Text" -> "text" | "type" -> "type_" | name -> - String.map (function '-' -> '_' | c -> c) name + String.map + (function + | '-' -> '_' + | c -> c) + name let emit_void name = let oname = oname name in - pf "(** tag %S, see {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n" + pf + "(** tag %S, see \ + {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n" name name; pf "let %s : void = fun ?(if_=true) attrs out ->\n" oname; pf " if if_ then (\n"; @@ -447,12 +457,14 @@ let emit_void name = let emit_normal name = let oname = oname name in - pf "(** tag %S, see {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n" + pf + "(** tag %S, see \ + {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n" name name; pf "let %s : nary = fun ?(if_=true) attrs sub out ->\n" oname; pf " if if_ then (\n"; (* for 
, newlines actually matter *)
-  if name="pre" then pf "  Out.with_no_format_nl out @@ fun () ->\n";
+  if name = "pre" then pf "  Out.with_no_format_nl out @@ fun () ->\n";
   pf "    _write_tag_attrs ~void:false out %S attrs;\n" name;
   pf "    List.iter (fun sub -> Out.add_format_nl out; sub out) sub;\n";
   pf "    if sub <> [] then Out.add_format_nl out;\n";
@@ -461,21 +473,23 @@ let emit_normal name =
 
   (* block version *)
   let oname = oname ^ "'" in
-  pf "(** tag %S, see {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n"
+  pf
+    "(** tag %S, see \
+     {{:https://developer.mozilla.org/en-US/docs/Web/HTML/Element/%s} mdn} *)\n"
     name name;
   pf "let %s : nary' = fun ?(if_=true) attrs l out ->\n" oname;
   pf "  if if_ then (\n";
-  if name="pre" then pf "  Out.with_no_format_nl out @@ fun () ->\n";
+  if name = "pre" then pf "  Out.with_no_format_nl out @@ fun () ->\n";
   pf "    _write_tag_attrs ~void:false out %S attrs;\n" name;
   pf "    let has_sub = _write_subs out l in\n";
   pf "    if has_sub then Out.add_format_nl out;\n";
   pf "    Out.add_string out \"\")" name;
   pf "\n\n";
 
-
   ()
 
-let doc_attrs = {|Attributes.
+let doc_attrs =
+  {|Attributes.
 
 This module contains combinator for the standard attributes.
 One can also just use a pair of strings. |}
@@ -498,4 +512,3 @@ let () =
   List.iter emit_attr attrs;
   pf "end\n";
   ()
-
diff --git a/src/qtest/dune b/src/qtest/dune
index 77184904..b9f81fcf 100644
--- a/src/qtest/dune
+++ b/src/qtest/dune
@@ -1,18 +1,18 @@
-
 (executable
-  (name qtest)
-  (modes native)
-  (flags :standard -warn-error -a+8 -w -33)
-  (libraries qcheck-core qcheck ounit2
-             threads threads.posix tiny_httpd))
+ (name qtest)
+ (modes native)
+ (flags :standard -warn-error -a+8 -w -33)
+ (libraries qcheck-core qcheck ounit2 threads threads.posix tiny_httpd))
 
 (rule
- (deps (glob_files ../*.ml{,i}))
+ (deps
+  (glob_files ../*.ml{,i}))
  (targets qtest.ml)
- (action (run qtest extract --quiet %{deps} -o %{targets})))
+ (action
+  (run qtest extract --quiet %{deps} -o %{targets})))
 
 (rule
-  (alias runtest)
-  (package tiny_httpd)
-  (action (run ./qtest.exe)))
-
+ (alias runtest)
+ (package tiny_httpd)
+ (action
+  (run ./qtest.exe)))
diff --git a/tests/dune b/tests/dune
index 53bf6ea5..4725b595 100644
--- a/tests/dune
+++ b/tests/dune
@@ -1,64 +1,92 @@
+(rule
+ (targets echo1.out)
+ (deps
+  (:bin ../examples/echo.exe))
+ (locks /port)
+ (enabled_if
+  (= %{system} "linux"))
+ (package tiny_httpd_camlzip)
+ (action
+  (with-stdout-to
+   %{targets}
+   (run ./echo1.sh %{bin}))))
 
 (rule
-  (targets echo1.out)
-  (deps (:bin ../examples/echo.exe))
-  (locks /port)
-  (enabled_if (= %{system} "linux"))
-  (package tiny_httpd_camlzip)
-  (action (with-stdout-to %{targets} (run ./echo1.sh %{bin}))))
+ (alias runtest)
+ (package tiny_httpd_camlzip)
+ (enabled_if
+  (= %{system} "linux"))
+ (action
+  (diff echo1.expect echo1.out)))
 
 (rule
-  (alias runtest)
-  (package tiny_httpd_camlzip)
-  (enabled_if (= %{system} "linux"))
-  (action (diff echo1.expect echo1.out)))
+ (targets sse_count.out)
+ (deps
+  (:bin ../examples/sse_server.exe))
+ (locks /port)
+ (enabled_if
+  (= %{system} "linux"))
+ (package tiny_httpd)
+ (action
+  (with-stdout-to
+   %{targets}
+   (run ./sse_count.sh %{bin}))))
 
 (rule
-  (targets sse_count.out)
-  (deps (:bin ../examples/sse_server.exe))
-  (locks /port)
-  (enabled_if (= %{system} "linux"))
-  (package tiny_httpd)
-  (action (with-stdout-to %{targets} (run ./sse_count.sh %{bin}))))
+ (alias runtest)
+ (package tiny_httpd)
+ (enabled_if
+  (= %{system} "linux"))
+ (action
+  (diff sse_count.expect sse_count.out)))
 
 (rule
-  (alias runtest)
-  (package tiny_httpd)
-  (enabled_if (= %{system} "linux"))
-  (action (diff sse_count.expect sse_count.out)))
+ (targets upload-out)
+ (deps
+  (:bin ../src/bin/http_of_dir.exe)
+  foo_50)
+ (locks /port)
+ (package tiny_httpd)
+ (enabled_if
+  (= %{system} "linux"))
+ (action
+  (with-stdout-to
+   %{targets}
+   (run ./upload_chunked.sh %{bin}))))
 
 (rule
-  (targets upload-out)
-  (deps (:bin ../src/bin/http_of_dir.exe) foo_50)
-  (locks /port)
-  (package tiny_httpd)
-  (enabled_if (= %{system} "linux"))
-  (action (with-stdout-to %{targets}
-                          (run ./upload_chunked.sh %{bin}))))
+ (alias runtest)
+ (package tiny_httpd)
+ (enabled_if
+  (= %{system} "linux"))
+ (action
+  (diff upload-out.expect upload-out)))
 
 (rule
-  (alias runtest)
-  (package tiny_httpd)
-  (enabled_if (= %{system} "linux"))
-  (action (diff upload-out.expect upload-out)))
+ (targets dl-out)
+ (deps
+  (:bin ../src/bin/http_of_dir.exe)
+  foo_50)
+ (locks /port)
+ (package tiny_httpd)
+ (enabled_if
+  (= %{system} "linux"))
+ (action
+  (with-stdout-to
+   %{targets}
+   (run ./download_chunked.sh %{bin}))))
 
 (rule
-  (targets dl-out)
-  (deps (:bin ../src/bin/http_of_dir.exe) foo_50)
-  (locks /port)
-  (package tiny_httpd)
-  (enabled_if (= %{system} "linux"))
-  (action (with-stdout-to %{targets}
-                          (run ./download_chunked.sh %{bin}))))
+ (alias runtest)
+ (package tiny_httpd)
+ (enabled_if
+  (= %{system} "linux"))
+ (action
+  (diff dl-out.expect dl-out)))
 
 (rule
-  (alias runtest)
-  (package tiny_httpd)
-  (enabled_if (= %{system} "linux"))
-  (action (diff dl-out.expect dl-out)))
-
-(rule
-  (targets foo_50)
-  (enabled_if (= %{system} "linux"))
-  (action
-    (bash "dd if=/dev/zero of=%{targets} bs=1M count=50")))
+ (targets foo_50)
+ (enabled_if
+  (= %{system} "linux"))
+ (action
+  (bash "dd if=/dev/zero of=%{targets} bs=1M count=50")))
diff --git a/tests/html/dune b/tests/html/dune
index 59edea52..ab567ef6 100644
--- a/tests/html/dune
+++ b/tests/html/dune
@@ -1,22 +1,31 @@
-
 (executable
-  (libraries tiny_httpd)
-  (name makehtml))
+ (libraries tiny_httpd)
+ (name makehtml))
 
 (rule
-  (targets t1.out.html)
-  (deps (:bin ./makehtml.exe))
-  (action (with-stdout-to %{targets} (run %{bin} 1))))
+ (targets t1.out.html)
+ (deps
+  (:bin ./makehtml.exe))
+ (action
+  (with-stdout-to
+   %{targets}
+   (run %{bin} 1))))
 
 (rule
-  (alias runtest)
-  (action (diff t1.expected.html t1.out.html)))
+ (alias runtest)
+ (action
+  (diff t1.expected.html t1.out.html)))
 
 (rule
-  (targets t2.out.html)
-  (deps (:bin ./makehtml.exe))
-  (action (with-stdout-to %{targets} (run %{bin} 2))))
+ (targets t2.out.html)
+ (deps
+  (:bin ./makehtml.exe))
+ (action
+  (with-stdout-to
+   %{targets}
+   (run %{bin} 2))))
 
 (rule
-  (alias runtest)
-  (action (diff t2.expected.html t2.out.html)))
+ (alias runtest)
+ (action
+  (diff t2.expected.html t2.out.html)))
diff --git a/tests/html/makehtml.ml b/tests/html/makehtml.ml
index aaace271..993cc187 100644
--- a/tests/html/makehtml.ml
+++ b/tests/html/makehtml.ml
@@ -1,41 +1,52 @@
 open Tiny_httpd_html
+
 let spf = Printf.sprintf
 
 let list_init n f =
   let rec loop i =
-    if i=n then []
-    else f i :: loop (i+1)
-  in loop 0
+    if i = n then
+      []
+    else
+      f i :: loop (i + 1)
+  in
+  loop 0
 
-let t1() =
-  html [] [
-    head [] [];
-    body [] [
-      ul [A.style "list-style: circle"] (
-        li[][pre [] [txt "a"; pre[][txt "c"; txt"d"]; txt "b"]] ::
-        list_init 100 (fun i -> li [A.id (spf "l%d" i)] [txt (spf "item %d" i)])
-      )
+let t1 () =
+  html []
+    [
+      head [] [];
+      body []
+        [
+          ul
+            [ A.style "list-style: circle" ]
+            (li [] [ pre [] [ txt "a"; pre [] [ txt "c"; txt "d" ]; txt "b" ] ]
+            :: list_init 100 (fun i ->
+                   li [ A.id (spf "l%d" i) ] [ txt (spf "item %d" i) ]));
+        ];
     ]
-  ]
 
-
-let t2() =
-  html [] [
-    head [] [];
-    pre [] [txt "a"; txt "b"];
-    body [] [
-      ul' [A.style "list-style: circle"] [
-        sub_l @@ list_init 100 @@ fun i ->
-        li ~if_:(i<> 42) [A.id (spf "l%d" i)] [txt (spf "item %d" i)]
-      ]
+let t2 () =
+  html []
+    [
+      head [] [];
+      pre [] [ txt "a"; txt "b" ];
+      body []
+        [
+          ul'
+            [ A.style "list-style: circle" ]
+            [
+              (sub_l @@ list_init 100
+              @@ fun i ->
+              li ~if_:(i <> 42) [ A.id (spf "l%d" i) ] [ txt (spf "item %d" i) ]
+              );
+            ];
+        ];
     ]
-  ]
 
-let render t =
-  print_endline @@ to_string_top @@ t
+let render t = print_endline @@ to_string_top @@ t
 
 let () =
   match Sys.argv.(1) with
-  | "1" -> render @@ t1()
-  | "2" -> render @@ t2()
+  | "1" -> render @@ t1 ()
+  | "2" -> render @@ t2 ()
   | _ -> failwith "unknown cmd"