diff --git a/.github/workflows/gh-pages.yml b/.github/workflows/gh-pages.yml index 51187fd9..29ef55e1 100644 --- a/.github/workflows/gh-pages.yml +++ b/.github/workflows/gh-pages.yml @@ -20,10 +20,10 @@ jobs: allow-prerelease-opam: true - name: Deps - run: opam install odig tiny_httpd tiny_httpd_camlzip + run: opam install odig tiny_httpd tiny_httpd_camlzip tiny_httpd_eio - name: Build - run: opam exec -- odig odoc --cache-dir=_doc/ tiny_httpd tiny_httpd_camlzip + run: opam exec -- odig odoc --cache-dir=_doc/ tiny_httpd tiny_httpd_camlzip tiny_httpd_eio - name: Deploy uses: peaceiris/actions-gh-pages@v3 diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 712f1fca..a5d9a22e 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -38,7 +38,7 @@ jobs: - run: opam install ./tiny_httpd.opam ./tiny_httpd_camlzip.opam --deps-only --with-test - - run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip + - run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip,tiny_httpd_eio - run: opam exec -- dune build @src/runtest @examples/runtest @tests/runtest -p tiny_httpd if: ${{ matrix.os == 'ubuntu-latest' }} @@ -50,4 +50,4 @@ jobs: - run: opam install logs magic-mime -y - - run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip + - run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip,tiny_httpd_eio diff --git a/dune-project b/dune-project index 6446bd94..0582156a 100644 --- a/dune-project +++ b/dune-project @@ -39,3 +39,12 @@ (iostream-camlzip (>= 0.2.1)) (logs :with-test) (odoc :with-doc))) + +(package + (name tiny_httpd_eio) + (synopsis "Use eio for tiny_httpd") + (depends + (tiny_httpd (= :version)) + (eio (and (>= 1.0) (< 2.0))) + (logs :with-test) + (odoc :with-doc))) diff --git a/echo_eio.sh b/echo_eio.sh new file mode 100755 index 00000000..5621bddc --- /dev/null +++ b/echo_eio.sh @@ -0,0 +1,2 @@ +#!/bin/sh +exec dune exec --display=quiet --profile=release "examples/echo_eio.exe" -- $@ diff --git a/examples/dune b/examples/dune index 08d06886..78350f9a 100644 --- a/examples/dune +++ b/examples/dune @@ -11,8 +11,29 @@ (executable (name echo) (flags :standard -warn-error -a+8) - (modules echo vfs) - (libraries tiny_httpd logs tiny_httpd_camlzip tiny_httpd.multipart-form-data)) + (modules echo) + (libraries + tiny_httpd + logs + echo_vfs + tiny_httpd_camlzip + tiny_httpd.multipart-form-data)) + +(executable + (name echo_eio) + (flags :standard -warn-error -a+8) + (modules echo_eio) + (libraries + tiny_httpd + tiny_httpd_eio + eio + eio_main + logs + echo_vfs + trace.core + trace-tef + tiny_httpd_camlzip + tiny_httpd.multipart-form-data)) (executable (name writer) @@ -51,6 +72,12 @@ ; produce an embedded FS +(library + (name echo_vfs) + (modules vfs) + (wrapped false) + (libraries tiny_httpd)) + (rule (targets vfs.ml) (deps diff --git a/examples/echo.ml b/examples/echo.ml index 0ce3cb6e..49ce9c17 100644 --- a/examples/echo.ml +++ b/examples/echo.ml @@ -142,12 +142,14 @@ let () = "-p", Arg.Set_int port_, " set port"; "--debug", Arg.Unit setup_logging, " enable debug"; "-j", Arg.Set_int j, " maximum number of connections"; - "--addr", Arg.Set_string addr, " binding address"; + "--addr", Arg.Set_string addr, " binding address"; ]) (fun _ -> raise (Arg.Bad "")) "echo [option]*"; - let server = Tiny_httpd.create ~addr:!addr ~port:!port_ ~max_connections:!j () in + let server = + Tiny_httpd.create ~addr:!addr ~port:!port_ ~max_connections:!j () + in Tiny_httpd_camlzip.setup ~compress_above:1024 ~buf_size:(16 * 1024) server; let m_stats, get_stats = middleware_stat () in diff --git a/examples/echo_eio.ml b/examples/echo_eio.ml new file mode 100644 index 00000000..5905fe57 --- /dev/null +++ b/examples/echo_eio.ml @@ -0,0 +1,412 @@ +open Tiny_httpd_core +module Trace = Trace_core +module Log = Tiny_httpd.Log +module MFD = Tiny_httpd_multipart_form_data + +let ( let@ ) = ( @@ ) +let now_ = Unix.gettimeofday + +let alice_text = + "CHAPTER I. Down the Rabbit-Hole Alice was beginning to get very tired of \ + sitting by her sister on the bank, and of having nothing to do: once or \ + twice she had peeped into the book her sister was reading, but it had no \ + pictures or conversations in it, thought \ + Alice So she was considering in her \ + own mind (as well as she could, for the hot day made her feel very sleepy \ + and stupid), whether the pleasure of making a daisy-chain would be worth \ + the trouble of getting up and picking the daisies, when suddenly a White \ + Rabbit with pink eyes ran close by her. There was nothing so very \ + remarkable in that; nor did Alice think it so very much out of the way to \ + hear the Rabbit say to itself, (when \ + she thought it over afterwards, it occurred to her that she ought to have \ + wondered at this, but at the time it all seemed quite natural); but when \ + the Rabbit actually took a watch out of its waistcoat-pocket, and looked at \ + it, and then hurried on, Alice started to her feet, for it flashed across \ + her mind that she had never before seen a rabbit with either a \ + waistcoat-pocket, or a watch to take out of it, and burning with curiosity, \ + she ran across the field after it, and fortunately was just in time to see \ + it pop down a large rabbit-hole under the hedge. In another moment down \ + went Alice after it, never once considering how in the world she was to get \ + out again. The rabbit-hole went straight on like a tunnel for some way, and \ + then dipped suddenly down, so suddenly that Alice had not a moment to think \ + about stopping herself before she found herself falling down a very deep \ + well. Either the well was very deep, or she fell very slowly, for she had \ + plenty of time as she went down to look about her and to wonder what was \ + going to happen next. First, she tried to look down and make out what she \ + was coming to, but it was too dark to see anything; then she looked at the \ + sides of the well, and noticed that they were filled with cupboards......" + +(* util: a little middleware collecting statistics *) +let middleware_stat () : Server.Middleware.t * (unit -> string) = + let n_req = ref 0 in + let total_time_ = ref 0. in + let parse_time_ = ref 0. in + let build_time_ = ref 0. in + let write_time_ = ref 0. in + + let m h req ~resp = + incr n_req; + let t1 = Request.start_time req in + let t2 = now_ () in + h req ~resp:(fun response -> + let t3 = now_ () in + resp response; + let t4 = now_ () in + total_time_ := !total_time_ +. (t4 -. t1); + parse_time_ := !parse_time_ +. (t2 -. t1); + build_time_ := !build_time_ +. (t3 -. t2); + 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) + in + m, get_stat + +let middleware_trace : Server.Middleware.t = + fun (h : Server.Middleware.handler) req ~resp -> + let _sp = + Trace.enter_manual_toplevel_span ~__FILE__ ~__LINE__ "http.handle" + in + let new_resp (r : Response.t) = + Trace.add_data_to_manual_span _sp [ "http.code", `Int r.code ]; + Trace.exit_manual_span _sp; + resp r + in + h req ~resp:new_resp + +(* ugly AF *) +let base64 x = + let ic, oc = Unix.open_process "base64" in + output_string oc x; + flush oc; + close_out oc; + let r = input_line ic in + ignore (Unix.close_process (ic, oc)); + r + +let setup_logging () = + Logs.set_reporter @@ Logs.format_reporter (); + Logs.set_level ~all:true (Some Logs.Debug) + +let setup_upload server : unit = + Server.add_route_handler_stream ~meth:`POST server + Route.(exact "upload" @/ return) + (fun req -> + let (`boundary boundary) = + match MFD.parse_content_type req.headers with + | Some b -> b + | None -> Response.fail_raise ~code:400 "no boundary found" + in + + let st = MFD.create ~boundary req.body in + let tbl = Hashtbl.create 16 in + let cur = ref "" in + let cur_kind = ref "" in + let buf = Buffer.create 16 in + let rec loop () = + match MFD.next st with + | End_of_input -> + if !cur <> "" then + Hashtbl.add tbl !cur (!cur_kind, Buffer.contents buf) + | Part headers -> + if !cur <> "" then + Hashtbl.add tbl !cur (!cur_kind, Buffer.contents buf); + (match MFD.Content_disposition.parse headers with + | Some { kind; name = Some name; filename = _ } -> + cur := name; + cur_kind := kind; + Buffer.clear buf; + loop () + | _ -> Response.fail_raise ~code:400 "content disposition missing") + | Read sl -> + Buffer.add_subbytes buf sl.bytes sl.off sl.len; + loop () + in + loop (); + + let open Tiny_httpd_html in + let data = + Hashtbl.fold + (fun name (kind, data) acc -> + Printf.sprintf "%S (kind: %S): %S" name kind data :: acc) + tbl [] + in + let html = + body [] + [ + pre [] + [ txt (Printf.sprintf "{\n%s\n}" @@ String.concat "\n" data) ]; + ] + in + Response.make_string ~code:201 @@ Ok (to_string_top html)) + +let () = + let@ () = Trace_tef.with_setup () in + let port_ = ref 8080 in + let max_conns = ref 16_000 in + let pool_buf_size = ref None in + let buf_size = ref 4096 in + let unix_sock = ref "" in + let addr = ref "127.0.0.1" in + Arg.parse + (Arg.align + [ + "--port", Arg.Set_int port_, " set port"; + "-p", Arg.Set_int port_, " set port"; + "--unix", Arg.Set_string unix_sock, " set unix socket"; + "--debug", Arg.Unit setup_logging, " enable debug"; + ( "--max-buf-pool-size", + Arg.Int (fun i -> pool_buf_size := Some i), + " maximum buffer pool size" ); + "--buf-size", Arg.Set_int buf_size, " buffer size"; + "--max-conns", Arg.Set_int max_conns, " maximum number of connections"; + "--addr", Arg.Set_string addr, " binding address"; + ]) + (fun _ -> raise (Arg.Bad "")) + "echo [option]*"; + + let@ stdenv = Eio_main.run in + let@ sw = Eio.Switch.run ~name:"main" in + let server = + Tiny_httpd_eio.create ~addr:!addr ~port:!port_ ~max_connections:!max_conns + ~buf_size:!buf_size ?max_buf_pool_size:!pool_buf_size ~stdenv ~sw () + in + + if Trace.enabled () then ( + Tiny_httpd.Server.add_middleware server ~stage:(`Stage 1) middleware_trace; + + (* fiber that emits metrics *) + Eio.Fiber.fork_daemon ~sw (fun () -> + while Eio.Switch.get_error sw |> Option.is_none do + Trace.counter_int "http.active-conns" + (Server.active_connections server); + Eio_unix.sleep 0.5 + done; + `Stop_daemon) + ); + + Tiny_httpd_camlzip.setup ~compress_above:1024 ~buf_size:(16 * 1024) server; + let m_stats, get_stats = middleware_stat () in + Server.add_middleware server ~stage:(`Stage 1) m_stats; + + (* say hello *) + Server.add_route_handler ~meth:`GET server + Route.(exact "hello" @/ string @/ return) + (fun name _req -> Response.make_string (Ok ("hello " ^ name ^ "!\n"))); + + (* compressed file access *) + Server.add_route_handler ~meth:`GET server + Route.(exact "zcat" @/ string_urlencoded @/ return) + (fun path _req -> + let ic = open_in path in + let str = IO.Input.of_in_channel ic in + let mime_type = + 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 + Response.make_stream ~headers:mime_type (Ok str)); + + (* echo request *) + Server.add_route_handler server + Route.(exact "echo" @/ return) + (fun req -> + let q = + Request.query req + |> List.map (fun (k, v) -> Printf.sprintf "%S = %S" k v) + |> String.concat ";" + in + Response.make_string + (Ok (Format.asprintf "echo:@ %a@ (query: %s)@." Request.pp req q))); + + (* file upload *) + Server.add_route_handler_stream ~meth:`PUT server + Route.(exact "upload" @/ string @/ return) + (fun path req -> + Log.debug (fun k -> + k "start upload %S, headers:\n%s\n\n%!" path + (Format.asprintf "%a" Headers.pp (Request.headers req))); + try + let oc = open_out @@ "/tmp/" ^ path in + IO.Input.to_chan oc req.Request.body; + flush oc; + Response.make_string (Ok "uploaded file") + with e -> + Response.fail ~code:500 "couldn't upload file: %s" + (Printexc.to_string e)); + + (* protected by login *) + Server.add_route_handler server + Route.(exact "protected" @/ return) + (fun req -> + let ok = + match Request.get_header req "authorization" with + | Some v -> + Log.debug (fun k -> k "authenticate with %S" v); + v = "Basic " ^ base64 "user:foobar" + | None -> false + in + if ok then ( + (* FIXME: a logout link *) + let s = + "

hello, this is super secret!

log out" + in + Response.make_string (Ok s) + ) else ( + let headers = + Headers.(empty |> set "www-authenticate" "basic realm=\"echo\"") + in + Response.fail ~code:401 ~headers "invalid" + )); + + (* logout *) + Server.add_route_handler server + Route.(exact "logout" @/ return) + (fun _req -> Response.fail ~code:401 "logged out"); + + (* stats *) + Server.add_route_handler server + Route.(exact "stats" @/ return) + (fun _req -> + let stats = get_stats () in + Response.make_string @@ Ok stats); + + Server.add_route_handler server + Route.(exact "alice" @/ return) + (fun _req -> Response.make_string (Ok alice_text)); + + Server.add_route_handler ~meth:`HEAD server + Route.(exact "head" @/ return) + (fun _req -> + Response.make_void ~code:200 ~headers:[ "x-hello", "world" ] ()); + + (* VFS *) + Tiny_httpd.Dir.add_vfs server + ~config: + (Tiny_httpd.Dir.config ~download:true + ~dir_behavior:Tiny_httpd.Dir.Index_or_lists ()) + ~vfs:Vfs.vfs ~prefix:"vfs"; + + setup_upload server; + + (* main page *) + Server.add_route_handler server + 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"; + ]; + ]; + li [] + [ + pre [] + [ + a [ A.href "/protected" ] [ txt "/protected" ]; + txt + " (GET) to see a protected page (login: user, \ + password: foobar)"; + ]; + ]; + li [] + [ + pre [] + [ + a [ A.href "/logout" ] [ txt "/logout" ]; + txt " (POST) to log out"; + ]; + ]; + li [] + [ + form + [ + A.action "/upload"; + A.enctype "multipart/form-data"; + A.target "_self"; + A.method_ "POST"; + ] + [ + label [] [ txt "my beautiful form" ]; + input [ A.type_ "file"; A.name "file1" ]; + input [ A.type_ "file"; A.name "file2" ]; + input + [ + A.type_ "text"; + A.name "a"; + A.placeholder "text A"; + ]; + input + [ + A.type_ "text"; + A.name "b"; + A.placeholder "text B"; + ]; + input [ A.type_ "submit" ]; + ]; + ]; + ]; + ]; + ] + in + let s = to_string_top h in + Response.make_string ~headers:[ "content-type", "text/html" ] @@ Ok s); + + Printf.printf "listening on http://%s:%d\n%!" (Server.addr server) + (Server.port server); + match Server.run server with + | Ok () -> () + | Error e -> raise e diff --git a/examples/echo_ws.ml b/examples/echo_ws.ml index ccbe4695..9372669e 100644 --- a/examples/echo_ws.ml +++ b/examples/echo_ws.ml @@ -6,9 +6,9 @@ let setup_logging ~debug () = Logs.set_level ~all:true @@ Some (if debug then - Logs.Debug - else - Logs.Info) + Logs.Debug + else + Logs.Info) let handle_ws (req : unit Request.t) ic oc = Log.info (fun k -> diff --git a/examples/sse_server.ml b/examples/sse_server.ml index c458026a..06c31506 100644 --- a/examples/sse_server.ml +++ b/examples/sse_server.ml @@ -36,9 +36,9 @@ let () = EV.send_event ~event: (if !tick then - "tick" - else - "tock") + "tick" + else + "tock") ~data:(Ptime.to_rfc3339 now) (); tick := not !tick; diff --git a/src/Tiny_httpd.mli b/src/Tiny_httpd.mli index 668eeb12..0d5af2ac 100644 --- a/src/Tiny_httpd.mli +++ b/src/Tiny_httpd.mli @@ -1,8 +1,8 @@ (** Tiny Http Server This library implements a very simple, basic HTTP/1.1 server using blocking - IOs and threads. Basic routing based is provided for convenience, - so that several handlers can be registered. + IOs and threads. Basic routing based is provided for convenience, so that + several handlers can be registered. It is possible to use a thread pool, see {!create}'s argument [new_thread]. @@ -10,74 +10,71 @@ features by declaring a few endpoints, including one for uploading files: {[ -module S = Tiny_httpd - -let () = - let server = S.create () in - - (* 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"))); - - (* echo request *) - S.add_route_handler server - S.Route.(exact "echo" @/ return) - (fun req -> S.Response.make_string - (Ok (Format.asprintf "echo:@ %a@." S.Request.pp req))); - - (* file upload *) - S.add_route_handler ~meth:`PUT server - S.Route.(exact "upload" @/ string_urlencoded @/ return) - (fun path req -> - try - let oc = open_out @@ "/tmp/" ^ path in - output_string 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) - ); - - (* run the server *) - Printf.printf "listening on http://%s:%d\n%!" (S.addr server) (S.port server); - match S.run server with - | Ok () -> () - | Error e -> raise e + module S = Tiny_httpd + + let () = + let server = S.create () in + + (* 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"))); + + (* echo request *) + S.add_route_handler server + S.Route.(exact "echo" @/ return) + (fun req -> + S.Response.make_string + (Ok (Format.asprintf "echo:@ %a@." S.Request.pp req))); + + (* file upload *) + S.add_route_handler ~meth:`PUT server + S.Route.(exact "upload" @/ string_urlencoded @/ return) + (fun path req -> + try + let oc = open_out @@ "/tmp/" ^ path in + output_string 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)); + + (* run the server *) + Printf.printf "listening on http://%s:%d\n%!" (S.addr server) + (S.port server); + match S.run server with + | Ok () -> () + | Error e -> raise e ]} It is then possible to query it using curl: {[ -$ dune exec src/examples/echo.exe & -listening on http://127.0.0.1:8080 - -# the path "hello/name" greets you. -$ curl -X GET http://localhost:8080/hello/quadrarotaphile -hello quadrarotaphile! - -# the path "echo" just prints the request. -$ curl -X GET http://localhost:8080/echo --data "howdy y'all" -echo: -{meth=GET; - headers=Host: localhost:8080 - User-Agent: curl/7.66.0 - Accept: */* - Content-Length: 10 - Content-Type: application/x-www-form-urlencoded; - path="/echo"; body="howdy y'all"} - - - ]} - -*) + $ dune exec src/examples/echo.exe & + listening on http://127.0.0.1:8080 + + # the path "hello/name" greets you. + $ curl -X GET http://localhost:8080/hello/quadrarotaphile + hello quadrarotaphile! + + # the path "echo" just prints the request. + $ curl -X GET http://localhost:8080/echo --data "howdy y'all" + echo: + {meth=GET; + headers=Host: localhost:8080 + User-Agent: curl/7.66.0 + Accept: */* + Content-Length: 10 + Content-Type: application/x-www-form-urlencoded; + path="/echo"; body="howdy y'all"} + ]} *) (** {2 Tiny buffer implementation} These buffers are used to avoid allocating too many byte arrays when - processing streams and parsing requests. -*) + processing streams and parsing requests. *) module Buf = Buf @@ -141,37 +138,42 @@ val create : t (** Create a new webserver using UNIX abstractions. - The server will not do anything until {!run} is called on it. - Before starting the server, one can use {!add_path_handler} and - {!set_top_handler} to specify how to handle incoming requests. + The server will not do anything until {!run} is called on it. Before + starting the server, one can use {!add_path_handler} and {!set_top_handler} + to specify how to handle incoming requests. - @param masksigpipe if true, block the signal {!Sys.sigpipe} which otherwise - tends to kill client threads when they try to write on broken sockets. - Default: [true] except when on Windows, which defaults to [false]. + @param masksigpipe + if true, block the signal {!Sys.sigpipe} which otherwise tends to kill + client threads when they try to write on broken sockets. Default: [true] + except when on Windows, which defaults to [false]. @param buf_size size for buffers (since 0.11) - @param new_thread a function used to spawn a new thread to handle a - new client connection. By default it is {!Thread.create} but one - could use a thread pool instead. - See for example {{: https://github.com/c-cube/tiny-httpd-moonpool-bench/blob/0dcbbffb4fe34ea4ad79d46343ad0cebb69ca69f/examples/t1.ml#L31} - this use of moonpool}. + @param new_thread + a function used to spawn a new thread to handle a new client connection. + By default it is {!Thread.create} but one could use a thread pool instead. + See for example + {{:https://github.com/c-cube/tiny-httpd-moonpool-bench/blob/0dcbbffb4fe34ea4ad79d46343ad0cebb69ca69f/examples/t1.ml#L31} + this use of moonpool}. @param middlewares see {!add_middleware} for more details. @param max_connections maximum number of simultaneous connections. - @param timeout connection is closed if the socket does not do read or - write for the amount of second. Default: 0.0 which means no timeout. - timeout is not recommended when using proxy. + @param timeout + connection is closed if the socket does not do read or write for the + amount of second. Default: 0.0 which means no timeout. timeout is not + recommended when using proxy. @param addr address (IPv4 or IPv6) to listen on. Default ["127.0.0.1"]. @param port to listen on. Default [8080]. - @param sock an existing socket given to the server to listen on, e.g. by - systemd on Linux (or launchd on macOS). If passed in, this socket will be - used instead of the [addr] and [port]. If not passed in, those will be - used. This parameter exists since 0.10. - @param enable_logging if true and [Logs] is installed, log requests. Default true. - This parameter exists since 0.18. Does not affect debug-level logs. - - @param get_time_s obtain the current timestamp in seconds. - This parameter exists since 0.11. + @param sock + an existing socket given to the server to listen on, e.g. by systemd on + Linux (or launchd on macOS). If passed in, this socket will be used + instead of the [addr] and [port]. If not passed in, those will be used. + This parameter exists since 0.10. + @param enable_logging + if true and [Logs] is installed, log requests. Default true. This + parameter exists since 0.18. Does not affect debug-level logs. + + @param get_time_s + obtain the current timestamp in seconds. This parameter exists since 0.11. *) diff --git a/src/bin/curly.ml b/src/bin/curly.ml index b7dabde1..a42b4b3c 100644 --- a/src/bin/curly.ml +++ b/src/bin/curly.ml @@ -1,8 +1,8 @@ module Result = struct include Result - let ( >>= ) : - type a b e. (a, e) result -> (a -> (b, e) result) -> (b, e) 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 @@ -121,9 +121,9 @@ module Request = struct Header.to_cmd t.headers; [ t.url ]; (if has_body t then - [ "--data-binary"; "@-" ] - else - []); + [ "--data-binary"; "@-" ] + else + []); ] let pp fmt t = diff --git a/src/camlzip/Tiny_httpd_camlzip.mli b/src/camlzip/Tiny_httpd_camlzip.mli index f098e6da..c3cb9a28 100644 --- a/src/camlzip/Tiny_httpd_camlzip.mli +++ b/src/camlzip/Tiny_httpd_camlzip.mli @@ -1,22 +1,22 @@ (** Middleware for compression. - This uses camlzip to provide deflate compression/decompression. - If installed, the middleware will compress responses' bodies - when they are streams or fixed-size above a given limit - (but it will not compress small, fixed-size bodies). - *) + This uses camlzip to provide deflate compression/decompression. If + installed, the middleware will compress responses' bodies when they are + streams or fixed-size above a given limit (but it will not compress small, + fixed-size bodies). *) val middleware : ?compress_above:int -> ?buf_size:int -> unit -> Server.Middleware.t (** Middleware responsible for deflate compression/decompression. - @param compress_above threshold, in bytes, above which a response body - that has a known content-length is compressed. Stream bodies - are always compressed. + @param compress_above + threshold, in bytes, above which a response body that has a known + content-length is compressed. Stream bodies are always compressed. @param buf_size size of the underlying buffer for compression/decompression @since 0.11 *) val setup : ?compress_above:int -> ?buf_size:int -> Server.t -> unit -(** Install middleware for tiny_httpd to be able to encode/decode - compressed streams +(** Install middleware for tiny_httpd to be able to encode/decode compressed + streams @param compress_above threshold above with string responses are compressed - @param buf_size size of the underlying buffer for compression/decompression *) + @param buf_size size of the underlying buffer for compression/decompression +*) diff --git a/src/core/IO.ml b/src/core/IO.ml index 4014e8fc..e2a85770 100644 --- a/src/core/IO.ml +++ b/src/core/IO.ml @@ -1,12 +1,11 @@ (** IO abstraction. - We abstract IO so we can support classic unix blocking IOs - with threads, and modern async IO with Eio. + We abstract IO so we can support classic unix blocking IOs with threads, and + modern async IO with Eio. {b NOTE}: experimental. - @since 0.14 -*) + @since 0.14 *) open Common_ module Buf = Buf @@ -17,7 +16,8 @@ module Output = struct include Iostream.Out_buf class of_unix_fd ?(close_noerr = false) ~closed ~(buf : Slice.t) - (fd : Unix.file_descr) : t = + (fd : Unix.file_descr) : + t = object inherit t_from_output ~bytes:buf.bytes () @@ -62,10 +62,10 @@ module Output = struct (** [chunk_encoding oc] makes a new channel that outputs its content into [oc] in chunk encoding form. @param close_rec if true, closing the result will also close [oc] - @param buf a buffer used to accumulate data into chunks. - Chunks are emitted when [buf]'s size gets over a certain threshold, - or when [flush] is called. - *) + @param buf + a buffer used to accumulate data into chunks. Chunks are emitted when + [buf]'s size gets over a certain threshold, or when [flush] is called. + *) let chunk_encoding ?(buf = Buf.create ()) ~close_rec (oc : #t) : t = (* write content of [buf] as a chunk if it's big enough. If [force=true] then write content of [buf] if it's simply non empty. *) @@ -301,14 +301,14 @@ module Input = struct end (** new stream with maximum size [max_size]. - @param close_rec if true, closing this will also close the input stream *) + @param close_rec if true, closing this will also close the input stream *) let limit_size_to ~close_rec ~max_size ~bytes (arg : t) : t = reading_exactly_ ~size:max_size ~skip_on_close:false ~bytes ~close_rec arg - (** New stream that consumes exactly [size] bytes from the input. - If fewer bytes are read before [close] is called, we read and discard - the remaining quota of bytes before [close] returns. - @param close_rec if true, closing this will also close the input stream *) + (** New stream that consumes exactly [size] bytes from the input. If fewer + bytes are read before [close] is called, we read and discard the remaining + quota of bytes before [close] returns. + @param close_rec if true, closing this will also close the input stream *) let reading_exactly ~close_rec ~size ~bytes (arg : t) : t = reading_exactly_ ~size ~close_rec ~skip_on_close:true ~bytes arg @@ -394,16 +394,15 @@ module Writer = struct type t = { write: Output.t -> unit } [@@unboxed] (** Writer. - A writer is a push-based stream of bytes. - Give it an output channel and it will write the bytes in it. + A writer is a push-based stream of bytes. Give it an output channel and it + will write the bytes in it. - This is useful for responses: an http endpoint can return a writer - as its response's body; the writer is given access to the connection - to the client and can write into it as if it were a regular - [out_channel], including controlling calls to [flush]. - Tiny_httpd will convert these writes into valid HTTP chunks. - @since 0.14 - *) + This is useful for responses: an http endpoint can return a writer as its + response's body; the writer is given access to the connection to the + client and can write into it as if it were a regular [out_channel], + including controlling calls to [flush]. Tiny_httpd will convert these + writes into valid HTTP chunks. + @since 0.14 *) let[@inline] make ~write () : t = { write } @@ -432,32 +431,32 @@ module TCP_server = struct type t = { endpoint: unit -> string * int; - (** Endpoint we listen on. This can only be called from within [serve]. *) + (** Endpoint we listen on. This can only be called from within [serve]. + *) active_connections: unit -> int; (** Number of connections currently active *) running: unit -> bool; (** Is the server currently running? *) stop: unit -> unit; - (** Ask the server to stop. This might not take effect immediately, - and is idempotent. After this [server.running()] must return [false]. *) + (** Ask the server to stop. This might not take effect immediately, and + is idempotent. After this [server.running()] must return [false]. *) } (** A running TCP server. - This contains some functions that provide information about the running - server, including whether it's active (as opposed to stopped), a function - to stop it, and statistics about the number of connections. *) + This contains some functions that provide information about the running + server, including whether it's active (as opposed to stopped), a function + to stop it, and statistics about the number of connections. *) type builder = { serve: after_init:(t -> unit) -> handle:conn_handler -> unit -> unit; (** Blocking call to listen for incoming connections and handle them. Uses the connection handler [handle] to handle individual client connections in individual threads/fibers/tasks. - @param after_init is called once with the server after the server - has started. *) + @param after_init + is called once with the server after the server has started. *) } (** A TCP server builder implementation. Calling [builder.serve ~after_init ~handle ()] starts a new TCP server on - an unspecified endpoint - (most likely coming from the function returning this builder) - and returns the running server. *) + an unspecified endpoint (most likely coming from the function returning + this builder) and returns the running server. *) end diff --git a/src/core/buf.mli b/src/core/buf.mli index dbbbb7ca..16092d13 100644 --- a/src/core/buf.mli +++ b/src/core/buf.mli @@ -3,8 +3,7 @@ These buffers are used to avoid allocating too many byte arrays when processing streams and parsing requests. - @since 0.12 -*) + @since 0.12 *) type t diff --git a/src/core/gen/mkshims.ml b/src/core/gen/mkshims.ml index 954a4e40..84a5529d 100644 --- a/src/core/gen/mkshims.ml +++ b/src/core/gen/mkshims.ml @@ -30,7 +30,7 @@ let () = let version = Scanf.sscanf Sys.ocaml_version "%d.%d.%s" (fun x y _ -> x, y) in print_endline (if version >= (4, 12) then - atomic_after_412 - else - atomic_before_412); + atomic_after_412 + else + atomic_before_412); () diff --git a/src/core/headers.mli b/src/core/headers.mli index 8a1dfab5..2ea25216 100644 --- a/src/core/headers.mli +++ b/src/core/headers.mli @@ -5,23 +5,23 @@ type t = (string * string) list (** The header files of a request or response. - Neither the key nor the value can contain ['\r'] or ['\n']. - See https://tools.ietf.org/html/rfc7230#section-3.2 *) + Neither the key nor the value can contain ['\r'] or ['\n']. See + https://tools.ietf.org/html/rfc7230#section-3.2 *) val empty : t (** Empty list of headers. - @since 0.5 *) + @since 0.5 *) 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. *) + @param f if provided, will transform the value before it is returned. *) val get_exn : ?f:(string -> string) -> string -> t -> string (** @raise Not_found *) val set : string -> string -> t -> t -(** [set k v headers] sets the key [k] to value [v]. - It erases any previous entry for [k] *) +(** [set k v headers] sets the key [k] to value [v]. It erases any previous + entry for [k] *) val remove : string -> t -> t (** Remove the key from the headers, if present. *) diff --git a/src/core/log.mli b/src/core/log.mli index 176f8cc2..45f3377f 100644 --- a/src/core/log.mli +++ b/src/core/log.mli @@ -5,13 +5,13 @@ val debug : ((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) -> unit val error : ((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) -> unit val setup : debug:bool -> unit -> unit -(** Setup and enable logging. This should only ever be used in executables, - not libraries. +(** Setup and enable logging. This should only ever be used in executables, not + libraries. @param debug if true, set logging to debug (otherwise info) *) val dummy : bool val fully_disable : unit -> unit -(** Totally silence logs for tiny_httpd. With [Logs] installed this means setting - the level of the tiny_httpd source to [None]. - @since 0.18 *) +(** Totally silence logs for tiny_httpd. With [Logs] installed this means + setting the level of the tiny_httpd source to [None]. + @since 0.18 *) diff --git a/src/core/meth.mli b/src/core/meth.mli index 76b2c942..9436f47d 100644 --- a/src/core/meth.mli +++ b/src/core/meth.mli @@ -1,10 +1,9 @@ (** HTTP Methods *) type t = [ `GET | `PUT | `POST | `HEAD | `DELETE | `OPTIONS ] -(** A HTTP method. - For now we only handle a subset of these. +(** A HTTP method. For now we only handle a subset of these. - See https://tools.ietf.org/html/rfc7231#section-4 *) + See https://tools.ietf.org/html/rfc7231#section-4 *) val pp : Format.formatter -> t -> unit val to_string : t -> string diff --git a/src/core/pool.mli b/src/core/pool.mli index dcb8fd6c..cc67fc78 100644 --- a/src/core/pool.mli +++ b/src/core/pool.mli @@ -1,9 +1,9 @@ (** Resource pool. - This pool is used for buffers. It can be used for other resources - but do note that it assumes resources are still reasonably - cheap to produce and discard, and will never block waiting for - a resource — it's not a good pool for DB connections. + This pool is used for buffers. It can be used for other resources but do + note that it assumes resources are still reasonably cheap to produce and + discard, and will never block waiting for a resource — it's not a good pool + for DB connections. @since 0.14. *) @@ -14,20 +14,18 @@ val create : ?clear:('a -> unit) -> mk_item:(unit -> 'a) -> ?max_size:int -> unit -> 'a t (** Create a new pool. @param mk_item produce a new item in case the pool is empty - @param max_size maximum number of item in the pool before we start - dropping resources on the floor. This controls resource consumption. - @param clear a function called on items before recycling them. - *) + @param max_size + maximum number of item in the pool before we start dropping resources on + the floor. This controls resource consumption. + @param clear a function called on items before recycling them. *) val with_resource : 'a t -> ('a -> 'b) -> 'b -(** [with_resource pool f] runs [f x] with [x] a resource; - when [f] fails or returns, [x] is returned to the pool for - future reuse. *) +(** [with_resource pool f] runs [f x] with [x] a resource; when [f] fails or + returns, [x] is returned to the pool for future reuse. *) -(** Low level control over the pool. - This is easier to get wrong (e.g. releasing the same resource twice) - so use with caution. - @since 0.18 *) +(** Low level control over the pool. This is easier to get wrong (e.g. releasing + the same resource twice) so use with caution. + @since 0.18 *) module Raw : sig val acquire : 'a t -> 'a val release : 'a t -> 'a -> unit diff --git a/src/core/request.mli b/src/core/request.mli index 601d9615..c16bff6a 100644 --- a/src/core/request.mli +++ b/src/core/request.mli @@ -1,7 +1,7 @@ (** Requests - Requests are sent by a client, e.g. a web browser or cURL. - From the point of view of the server, they're inputs. *) + Requests are sent by a client, e.g. a web browser or cURL. From the point of + view of the server, they're inputs. *) open Common_ @@ -21,33 +21,32 @@ type 'body t = private { body: 'body; (** Body of the request. *) start_time: float; (** Obtained via [get_time_s] in {!create} - @since 0.11 *) + @since 0.11 *) } (** A request with method, path, host, headers, and a body, sent by a client. - The body is polymorphic because the request goes through - several transformations. First it has no body, as only the request - and headers are read; then it has a stream body; then the body might be - entirely read as a string via {!read_body_full}. + The body is polymorphic because the request goes through several + transformations. First it has no body, as only the request and headers are + read; then it has a stream body; then the body might be entirely read as a + string via {!read_body_full}. - @since 0.6 The field [query] was added and contains the query parameters in ["?foo=bar,x=y"] - @since 0.6 The field [path_components] is the part of the path that precedes [query] and is split on ["/"]. - @since 0.11 the type is a private alias - @since 0.11 the field [start_time] was added - *) + @since 0.6 The field [query] was added and contains the query parameters in ["?foo=bar,x=y"] + @since 0.6 The field [path_components] is the part of the path that precedes [query] and is split on ["/"]. + @since 0.11 the type is a private alias + @since 0.11 the field [start_time] was added *) val add_meta : _ t -> 'a Hmap.key -> 'a -> unit (** Add metadata - @since 0.17 *) + @since 0.17 *) val get_meta : _ t -> 'a Hmap.key -> 'a option (** Get metadata - @since 0.17 *) + @since 0.17 *) val get_meta_exn : _ t -> 'a Hmap.key -> 'a (** Like {!get_meta} but can fail @raise Invalid_argument if not present - @since 0.17 *) + @since 0.17 *) val pp_with : ?mask_header:(string -> bool) -> @@ -71,20 +70,20 @@ val pp_with : which works even for stream bodies) *) val pp : Format.formatter -> string t -> unit -(** Pretty print the request and its body. The exact format of this printing - is not specified. *) +(** Pretty print the request and its body. The exact format of this printing is + not specified. *) val pp_ : Format.formatter -> _ t -> unit (** Pretty print the request without its body. The exact format of this printing - is not specified. *) + is not specified. *) val headers : _ t -> Headers.t (** List of headers of the request, including ["Host"]. *) val get_header : ?f:(string -> string) -> _ t -> string -> string option (** [get_header req h] looks up header [h] in [req]. It returns [None] if the - header is not present. This is case insensitive and should be used - rather than looking up [h] verbatim in [headers]. *) + header is not present. This is case insensitive and should be used rather + than looking up [h] verbatim in [headers]. *) val get_header_int : _ t -> string -> int option (** Same as {!get_header} but also performs a string to integer conversion. *) @@ -94,22 +93,22 @@ val set_header : string -> string -> 'a t -> 'a t val remove_header : string -> 'a t -> 'a t (** Remove one instance of this header. - @since 0.17 *) + @since 0.17 *) val update_headers : (Headers.t -> Headers.t) -> 'a t -> 'a t (** Modify headers using the given function. - @since 0.11 *) + @since 0.11 *) val set_body : 'a -> _ t -> 'a t (** [set_body b req] returns a new query whose body is [b]. - @since 0.11 *) + @since 0.11 *) val host : _ t -> string (** Host field of the request. It also appears in the headers. *) val client_addr : _ t -> Unix.sockaddr (** Client address of the request. - @since 0.16 *) + @since 0.16 *) val meth : _ t -> Meth.t (** Method for the request. *) @@ -119,28 +118,26 @@ val path : _ t -> string val query : _ t -> (string * string) list (** Decode the query part of the {!path} field. - @since 0.4 *) + @since 0.4 *) val body : 'b t -> 'b (** Request body, possibly empty. *) val start_time : _ t -> float -(** time stamp (from {!Unix.gettimeofday}) after parsing the first line of the request - @since 0.11 *) +(** time stamp (from {!Unix.gettimeofday}) after parsing the first line of the + request + @since 0.11 *) val limit_body_size : max_size:int -> bytes:bytes -> IO.Input.t t -> IO.Input.t t -(** Limit the body size to [max_size] bytes, or return - a [413] error. - @since 0.3 - *) +(** Limit the body size to [max_size] bytes, or return a [413] error. + @since 0.3 *) val read_body_full : ?bytes:bytes -> ?buf_size:int -> IO.Input.t t -> string t (** Read the whole body into a string. Potentially blocking. @param buf_size initial size of underlying buffer (since 0.11) - @param bytes the initial buffer (since 0.14) - *) + @param bytes the initial buffer (since 0.14) *) (**/**) diff --git a/src/core/response.mli b/src/core/response.mli index 43d8fb6e..beb99e8a 100644 --- a/src/core/response.mli +++ b/src/core/response.mli @@ -1,65 +1,66 @@ (** Responses - Responses are what a http server, such as {!Tiny_httpd}, send back to - the client to answer a {!Request.t}*) + Responses are what a http server, such as {!Tiny_httpd}, send back to the + client to answer a {!Request.t}*) type body = [ `String of string | `Stream of IO.Input.t | `Writer of IO.Writer.t | `Void ] -(** Body of a response, either as a simple string, - or a stream of bytes, or nothing (for server-sent events notably). +(** Body of a response, either as a simple string, or a stream of bytes, or + nothing (for server-sent events notably). - - [`String str] replies with a body set to this string, and a known content-length. - - [`Stream str] replies with a body made from this string, using chunked encoding. - - [`Void] replies with no body. - - [`Writer w] replies with a body created by the writer [w], using - a chunked encoding. - It is available since 0.14. - *) + - [`String str] replies with a body set to this string, and a known + content-length. + - [`Stream str] replies with a body made from this string, using chunked + encoding. + - [`Void] replies with no body. + - [`Writer w] replies with a body created by the writer [w], using a chunked + encoding. It is available since 0.14. *) 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. *) + (** 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. *) val set_body : body -> t -> t (** Set the body of the response. - @since 0.11 *) + @since 0.11 *) val set_header : string -> string -> t -> t (** Set a header. - @since 0.11 *) + @since 0.11 *) val update_headers : (Headers.t -> Headers.t) -> t -> t (** Modify headers. - @since 0.11 *) + @since 0.11 *) val remove_header : string -> t -> t (** Remove one instance of this header. - @since 0.17 *) + @since 0.17 *) val set_headers : Headers.t -> t -> t (** Set all headers. - @since 0.11 *) + @since 0.11 *) val set_code : Response_code.t -> t -> t (** Set the response code. - @since 0.11 *) + @since 0.11 *) 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. *) +(** 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 -> IO.Input.t -> t -(** Same as {!make_raw} but with a stream body. The body will be sent with - the chunked transfer-encoding. *) +(** Same as {!make_raw} but with a stream body. The body will be sent with the + chunked transfer-encoding. *) val make_void : ?headers:Headers.t -> code:int -> unit -> t (** Return a response without a body at all. - @since 0.13 *) + @since 0.13 *) val make : ?headers:Headers.t -> @@ -68,10 +69,9 @@ val make : t (** [make r] turns a result into a response. - - [make (Ok body)] replies with [200] and the body. - - [make (Error (code,msg))] replies with the given error code - and message as body. - *) + - [make (Ok body)] replies with [200] and the body. + - [make (Error (code,msg))] replies with the given error code and message as + body. *) val make_string : ?headers:Headers.t -> @@ -95,19 +95,17 @@ val make_stream : (** Same as {!make} but with a stream body. *) 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"]. - *) +(** Make the current request fail with the given code and message. Example: + [fail ~code:404 "oh noes, %s not found" "waldo"]. *) exception Bad_req of int * string (** Exception raised by {!fail_raise} with the HTTP code and body *) val fail_raise : code:int -> ('a, unit, string, 'b) format4 -> 'a (** Similar to {!fail} but raises an exception that exits the current handler. - This should not be used outside of a (path) handler. - Example: [fail_raise ~code:404 "oh noes, %s not found" "waldo"; never_executed()] - @raise Bad_req always - *) + This should not be used outside of a (path) handler. Example: + [fail_raise ~code:404 "oh noes, %s not found" "waldo"; never_executed()] + @raise Bad_req always *) val pp_with : ?mask_header:(string -> bool) -> @@ -117,15 +115,16 @@ val pp_with : Format.formatter -> t -> unit -(** Pretty print the response. The exact format of this printing - is not specified. - @param mask_header function which is given each header name. If it - returns [true], the header's value is masked. The presence of - the header is still printed. Default [fun _ -> false]. - @param headers_to_mask a list of headers masked by default. - Default is ["set-cookie"]. - @param pp_body body printer - (default fully prints String bodies, but omits stream bodies) +(** Pretty print the response. The exact format of this printing is not + specified. + @param mask_header + function which is given each header name. If it returns [true], the + header's value is masked. The presence of the header is still printed. + Default [fun _ -> false]. + @param headers_to_mask + a list of headers masked by default. Default is ["set-cookie"]. + @param pp_body + body printer (default fully prints String bodies, but omits stream bodies) @since 0.18 *) val pp : Format.formatter -> t -> unit diff --git a/src/core/response_code.mli b/src/core/response_code.mli index 3755fcee..8023f313 100644 --- a/src/core/response_code.mli +++ b/src/core/response_code.mli @@ -3,7 +3,7 @@ type t = int (** A standard HTTP code. - https://tools.ietf.org/html/rfc7231#section-6 *) + https://tools.ietf.org/html/rfc7231#section-6 *) val ok : t (** The code [200] *) @@ -12,9 +12,9 @@ val not_found : t (** The code [404] *) val descr : t -> string -(** A description of some of the error codes. - NOTE: this is not complete (yet). *) +(** A description of some of the error codes. NOTE: this is not complete (yet). +*) val is_success : t -> bool (** [is_success code] is true iff [code] is in the [2xx] or [3xx] range. - @since 0.17 *) + @since 0.17 *) diff --git a/src/core/server.ml b/src/core/server.ml index 6c293a14..cf080a78 100644 --- a/src/core/server.ml +++ b/src/core/server.ml @@ -49,8 +49,8 @@ module type UPGRADE_HANDLER = sig Unix.sockaddr -> unit Request.t -> (Headers.t * handshake_state, string) result - (** Perform the handshake and upgrade the connection. The returned - code is [101] alongside these headers. *) + (** Perform the handshake and upgrade the connection. The returned code is + [101] alongside these headers. *) val handle_connection : handshake_state -> IO.Input.t -> IO.Output.t -> unit (** Take control of the connection and take it from there *) @@ -68,7 +68,7 @@ module type IO_BACKEND = sig (** obtain the current timestamp in seconds. *) val tcp_server : unit -> IO.TCP_server.builder - (** Server that can listen on a port and handle clients. *) + (** Server that can listen on a port and handle clients. *) end type handler_result = diff --git a/src/core/server.mli b/src/core/server.mli index 91318348..7e552258 100644 --- a/src/core/server.mli +++ b/src/core/server.mli @@ -5,33 +5,28 @@ It is possible to use a thread pool, see {!create}'s argument [new_thread]. - @since 0.13 -*) + @since 0.13 *) exception Bad_req of int * string (** Exception raised to exit request handlers with a code+error message *) (** {2 Middlewares} - A middleware can be inserted in a handler to modify or observe - its behavior. + A middleware can be inserted in a handler to modify or observe its behavior. - @since 0.11 -*) + @since 0.11 *) module Middleware : sig type handler = IO.Input.t Request.t -> resp:(Response.t -> unit) -> unit - (** Handlers are functions returning a response to a request. - The response can be delayed, hence the use of a continuation - as the [resp] parameter. *) + (** Handlers are functions returning a response to a request. The response can + be delayed, hence the use of a continuation as the [resp] parameter. *) type t = handler -> handler (** A middleware is a handler transformation. - It takes the existing handler [h], - and returns a new one which, given a query, modify it or log it - before passing it to [h], or fail. It can also log or modify or drop - the response. *) + It takes the existing handler [h], and returns a new one which, given a + query, modify it or log it before passing it to [h], or fail. It can also + log or modify or drop the response. *) val nil : t (** Trivial middleware that does nothing. *) @@ -39,14 +34,14 @@ end (** A middleware that only considers the request's head+headers. - These middlewares are simpler than full {!Middleware.t} and - work in more contexts. + These middlewares are simpler than full {!Middleware.t} and work in more + contexts. @since 0.17 *) module Head_middleware : sig type t = { handle: 'a. 'a Request.t -> 'a Request.t } - (** A handler that takes the request, without its body, - and possibly modifies it. - @since 0.17 *) + (** A handler that takes the request, without its body, and possibly modifies + it. + @since 0.17 *) val trivial : t (** Pass through *) @@ -62,9 +57,9 @@ type t (** A backend that provides IO operations, network operations, etc. This is used to decouple tiny_httpd from the scheduler/IO library used to - actually open a TCP server and talk to clients. The classic way is - based on {!Unix} and blocking IOs, but it's also possible to - use an OCaml 5 library using effects and non blocking IOs. *) + actually open a TCP server and talk to clients. The classic way is based on + {!Unix} and blocking IOs, but it's also possible to use an OCaml 5 library + using effects and non blocking IOs. *) module type IO_BACKEND = sig val init_addr : unit -> string (** Initial TCP address *) @@ -76,8 +71,8 @@ module type IO_BACKEND = sig (** Obtain the current timestamp in seconds. *) val tcp_server : unit -> IO.TCP_server.builder - (** TCP server builder, to create servers that can listen - on a port and handle clients. *) + (** TCP server builder, to create servers that can listen on a port and handle + clients. *) end val create_from : @@ -90,31 +85,31 @@ val create_from : t (** Create a new webserver using provided backend. - The server will not do anything until {!run} is called on it. - Before starting the server, one can use {!add_path_handler} and - {!set_top_handler} to specify how to handle incoming requests. + The server will not do anything until {!run} is called on it. Before + starting the server, one can use {!add_path_handler} and {!set_top_handler} + to specify how to handle incoming requests. @param buf_size size for buffers (since 0.11) @param head_middlewares see {!add_head_middleware} for details (since 0.18) @param middlewares see {!add_middleware} for more details. - @param enable_logging if true and [Logs] is installed, - emit logs via Logs (since 0.18). - Default [true]. + @param enable_logging + if true and [Logs] is installed, emit logs via Logs (since 0.18). Default + [true]. - @since 0.14 -*) + @since 0.14 *) val addr : t -> string (** Address on which the server listens. *) val is_ipv6 : t -> bool -(** [is_ipv6 server] returns [true] iff the address of the server is an IPv6 address. +(** [is_ipv6 server] returns [true] iff the address of the server is an IPv6 + address. @since 0.3 *) val port : t -> int -(** Port on which the server listens. Note that this might be different than - the port initially given if the port was [0] (meaning that the OS picks a - port for us). *) +(** Port on which the server listens. Note that this might be different than the + port initially given if the port was [0] (meaning that the OS picks a port + for us). *) val active_connections : t -> int (** Number of currently active connections. *) @@ -124,40 +119,35 @@ val add_decode_request_cb : (unit Request.t -> (unit Request.t * (IO.Input.t -> IO.Input.t)) 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). - A possible use is to handle decompression by looking for a [Transfer-Encoding] - header and returning a stream transformer that decompresses on the fly. +(** Add a callback for every request. The callback can provide a stream + transformer and a new request (with modified headers, typically). A possible + use is to handle decompression by looking for a [Transfer-Encoding] header + and returning a stream transformer that decompresses on the fly. - @deprecated use {!add_middleware} instead -*) + @deprecated use {!add_middleware} instead *) val add_encode_response_cb : t -> (unit Request.t -> Response.t -> Response.t option) -> unit [@@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. - The callback is given the query with only its headers, - as well as the current response. +(** 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. The callback is given the query with only its + headers, as well as the current response. - @deprecated use {!add_middleware} instead -*) + @deprecated use {!add_middleware} instead *) val add_middleware : 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. + @param stage + specify when middleware applies. Encoding comes first (outermost layer), + then stages in increasing order. @raise Invalid_argument if stage is [`Stage n] where [n < 1] - @since 0.11 -*) + @since 0.11 *) val add_head_middleware : t -> Head_middleware.t -> unit -(** Add a request-header only {!Head_middleware.t}. - This is called on requests, to modify them, and returns a new request - immediately. +(** Add a request-header only {!Head_middleware.t}. This is called on requests, + to modify them, and returns a new request immediately. @since 0.18 *) (** {2 Request handlers} *) @@ -166,13 +156,12 @@ val set_top_handler : t -> (IO.Input.t Request.t -> Response.t) -> unit (** Setup a handler called by default. This handler is called with any request not accepted by any handler - installed via {!add_path_handler}. - If no top handler is installed, unhandled paths will return a [404] not found + installed via {!add_path_handler}. If no top handler is installed, unhandled + paths will return a [404] not found - This used to take a [string Request.t] but it now takes a [byte_stream Request.t] - since 0.14 . Use {!Request.read_body_full} to read the body into - a string if needed. -*) + This used to take a [string Request.t] but it now takes a + [byte_stream Request.t] since 0.14 . Use {!Request.read_body_full} to read + the body into a string if needed. *) val add_route_handler : ?accept:(unit Request.t -> (unit, Response_code.t * string) result) -> @@ -183,23 +172,24 @@ val add_route_handler : '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/" - is received. - - Note that the handlers are called in the reverse order of their addition, - so the last registered handler can override previously registered ones. - - @param meth if provided, only accept requests with the given method. - Typically one could react to [`GET] or [`PUT]. - @param accept should return [Ok()] if the given request (before its body - is read) should be accepted, [Error (code,message)] if it's to be rejected (e.g. because - its content is too big, or for some permission error). - See the {!http_of_dir} program for an example of how to use [accept] to - filter uploads that are too large before the upload even starts. - The default always returns [Ok()], i.e. it accepts all requests. - - @since 0.6 -*) + calls [f "foo" 42 request] when a [request] with path "path/foo/42/" is + received. + + Note that the handlers are called in the reverse order of their addition, so + the last registered handler can override previously registered ones. + + @param meth + if provided, only accept requests with the given method. Typically one + could react to [`GET] or [`PUT]. + @param accept + should return [Ok()] if the given request (before its body is read) should + be accepted, [Error (code,message)] if it's to be rejected (e.g. because + its content is too big, or for some permission error). See the + {!http_of_dir} program for an example of how to use [accept] to filter + uploads that are too large before the upload even starts. The default + always returns [Ok()], i.e. it accepts all requests. + + @since 0.6 *) val add_route_handler_stream : ?accept:(unit Request.t -> (unit, Response_code.t * string) result) -> @@ -209,10 +199,10 @@ val add_route_handler_stream : ('a, IO.Input.t 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. - This is useful when one wants to stream the body directly into a parser, - json decoder (such as [Jsonm]) or into a file. +(** Similar to {!add_route_handler}, but where the body of the request is a + stream of bytes that has not been read yet. This is useful when one wants to + stream the body directly into a parser, json decoder (such as [Jsonm]) or + into a file. @since 0.6 *) (** {2 Server-sent events} @@ -221,23 +211,23 @@ val add_route_handler_stream : (** A server-side function to generate of Server-sent events. - See {{: https://html.spec.whatwg.org/multipage/server-sent-events.html} the w3c page} - and {{: https://jvns.ca/blog/2021/01/12/day-36--server-sent-events-are-cool--and-a-fun-bug/} - this blog post}. + See + {{:https://html.spec.whatwg.org/multipage/server-sent-events.html} the w3c + page} and + {{:https://jvns.ca/blog/2021/01/12/day-36--server-sent-events-are-cool--and-a-fun-bug/} + this blog post}. - @since 0.9 - *) + @since 0.9 *) module type SERVER_SENT_GENERATOR = sig val set_headers : Headers.t -> unit - (** Set headers of the response. - This is not mandatory but if used at all, it must be called before - any call to {!send_event} (once events are sent the response is - already sent too). *) + (** Set headers of the response. This is not mandatory but if used at all, it + must be called before any call to {!send_event} (once events are sent the + response is already sent too). *) val send_event : ?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. *) + (** Send an event from the server. If data is a multiline string, it will be + sent on separate "data:" lines. *) val close : unit -> unit (** Close connection. @@ -245,8 +235,8 @@ module type SERVER_SENT_GENERATOR = sig end type server_sent_generator = (module SERVER_SENT_GENERATOR) -(** Server-sent event generator. This generates events that are forwarded to - the client (e.g. the browser). +(** Server-sent event generator. This generates events that are forwarded to the + client (e.g. the browser). @since 0.9 *) val add_route_server_sent_handler : @@ -258,12 +248,11 @@ val add_route_server_sent_handler : unit (** Add a handler on an endpoint, that serves server-sent events. - The callback is given a generator that can be used to send events - as it pleases. The connection is always closed by the client, - and the accepted method is always [GET]. - This will set the header "content-type" to "text/event-stream" automatically - and reply with a 200 immediately. - See {!server_sent_generator} for more details. + The callback is given a generator that can be used to send events as it + pleases. The connection is always closed by the client, and the accepted + method is always [GET]. This will set the header "content-type" to + "text/event-stream" automatically and reply with a 200 immediately. See + {!server_sent_generator} for more details. This handler stays on the original thread (it is synchronous). @@ -275,7 +264,7 @@ val add_route_server_sent_handler : @since 0.17 *) (** Handler that upgrades to another protocol. - @since 0.17 *) + @since 0.17 *) module type UPGRADE_HANDLER = sig type handshake_state (** Some specific state returned after handshake *) @@ -288,11 +277,11 @@ module type UPGRADE_HANDLER = sig unit Request.t -> (Headers.t * handshake_state, string) result (** Perform the handshake and upgrade the connection. This returns either - [Ok (resp_headers, state)] in case of success, in which case the - server sends a [101] response with [resp_headers]; - or it returns [Error log_msg] if the the handshake fails, in which case - the connection is closed without further ado and [log_msg] is logged - locally (but not returned to the client). *) + [Ok (resp_headers, state)] in case of success, in which case the server + sends a [101] response with [resp_headers]; or it returns [Error log_msg] + if the the handshake fails, in which case the connection is closed without + further ado and [log_msg] is logged locally (but not returned to the + client). *) val handle_connection : handshake_state -> IO.Input.t -> IO.Output.t -> unit (** Take control of the connection and take it from ther.e *) @@ -316,16 +305,16 @@ val running : t -> bool @since 0.14 *) val stop : t -> unit -(** Ask the server to stop. This might not have an immediate effect - as {!run} might currently be waiting on IO. *) +(** Ask the server to stop. This might not have an immediate effect as {!run} + might currently be waiting on IO. *) val run : ?after_init:(unit -> unit) -> t -> (unit, exn) result -(** Run the main loop of the server, listening on a socket - described at the server's creation time, using [new_thread] to - start a thread for each new client. +(** Run the main loop of the server, listening on a socket described at the + server's creation time, using [new_thread] to start a thread for each new + client. - This returns [Ok ()] if the server exits gracefully, or [Error e] if - it exits with an error. + This returns [Ok ()] if the server exits gracefully, or [Error e] if it + exits with an error. @param after_init is called after the server starts listening. since 0.13 . *) diff --git a/src/core/util.mli b/src/core/util.mli index 1971b5a5..61c58e19 100644 --- a/src/core/util.mli +++ b/src/core/util.mli @@ -1,17 +1,16 @@ (** {1 Some utils for writing web servers} - @since 0.2 -*) + @since 0.2 *) val percent_encode : ?skip:(char -> bool) -> string -> string (** Encode the string into a valid path following https://tools.ietf.org/html/rfc3986#section-2.1 - @param skip if provided, allows to preserve some characters, e.g. '/' in a path. -*) + @param skip + if provided, allows to preserve some characters, e.g. '/' in a path. *) val percent_decode : string -> string option -(** Inverse operation of {!percent_encode}. - Can fail since some strings are not valid percent encodings. *) +(** Inverse operation of {!percent_encode}. Can fail since some strings are not + valid percent encodings. *) val split_query : string -> string * string (** Split a path between the path and the query @@ -30,10 +29,9 @@ val get_query : string -> string @since 0.4 *) 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 -*) +(** Parse a query as a list of ['&'] or [';'] separated [key=value] pairs. The + order might not be preserved. + @since 0.3 *) val show_sockaddr : Unix.sockaddr -> string (** Simple printer for socket addresses. diff --git a/src/eio/dune b/src/eio/dune new file mode 100644 index 00000000..37431aba --- /dev/null +++ b/src/eio/dune @@ -0,0 +1,8 @@ + +(library + (name tiny_httpd_eio) + (public_name tiny_httpd_eio) + (synopsis "An EIO-based backend for Tiny_httpd") + (flags :standard -safe-string -warn-error -a+8) + (libraries tiny_httpd eio eio.unix)) + diff --git a/src/eio/tiny_httpd_eio.ml b/src/eio/tiny_httpd_eio.ml new file mode 100644 index 00000000..e58d1b6b --- /dev/null +++ b/src/eio/tiny_httpd_eio.ml @@ -0,0 +1,207 @@ +module IO = Tiny_httpd.IO +module H = Tiny_httpd.Server +module Pool = Tiny_httpd.Pool +module Slice = IO.Slice +module Log = Tiny_httpd.Log + +let ( let@ ) = ( @@ ) + +type 'a with_args = + ?addr:string -> + ?port:int -> + ?unix_sock:string -> + ?max_connections:int -> + ?max_buf_pool_size:int -> + stdenv:Eio_unix.Stdenv.base -> + sw:Eio.Switch.t -> + 'a + +let get_max_connection_ ?(max_connections = 64) () : int = + let max_connections = max 4 max_connections in + max_connections + +let buf_size = 16 * 1024 + +let eio_ipaddr_to_unix (a : _ Eio.Net.Ipaddr.t) : Unix.inet_addr = + (* TODO: for ipv4 we really could do it faster via sprintf 🙄 *) + Unix.inet_addr_of_string (Format.asprintf "%a" Eio.Net.Ipaddr.pp a) + +let eio_sock_addr_to_unix (a : Eio.Net.Sockaddr.stream) : Unix.sockaddr = + match a with + | `Tcp (h, p) -> Unix.ADDR_INET (eio_ipaddr_to_unix h, p) + | `Unix s -> Unix.ADDR_UNIX s + +let ic_of_flow ~buf_pool:ic_pool (flow : _ Eio.Net.stream_socket) : IO.Input.t = + let cstruct = Pool.Raw.acquire ic_pool in + + object + inherit Iostream.In_buf.t_from_refill () + + method private refill (sl : Slice.t) = + assert (sl.len = 0); + let cap = min (Bytes.length sl.bytes) (Cstruct.length cstruct) in + + match Eio.Flow.single_read flow (Cstruct.sub cstruct 0 cap) with + | exception End_of_file -> + Log.debug (fun k -> k "read: eof"); + () + | n -> + Log.debug (fun k -> k "read %d bytes..." n); + Cstruct.blit_to_bytes cstruct 0 sl.bytes 0 n; + sl.off <- 0; + sl.len <- n + + method close () = + Pool.Raw.release ic_pool cstruct; + Eio.Flow.shutdown flow `Receive + end + +let oc_of_flow ~buf_pool:oc_pool (flow : _ Eio.Net.stream_socket) : IO.Output.t + = + (* write buffer *) + let wbuf : Cstruct.t = Pool.Raw.acquire oc_pool in + let offset = ref 0 in + + object (self) + method flush () : unit = + if !offset > 0 then ( + Eio.Flow.write flow [ Cstruct.sub wbuf 0 !offset ]; + offset := 0 + ) + + method output buf i len = + let i = ref i in + let len = ref len in + + while !len > 0 do + let available = Cstruct.length wbuf - !offset in + let n = min !len available in + Cstruct.blit_from_bytes buf !i wbuf !offset n; + offset := !offset + n; + i := !i + n; + len := !len - n; + + if !offset = Cstruct.length wbuf then self#flush () + done + + method output_char c = + if !offset = Cstruct.length wbuf then self#flush (); + Cstruct.set_char wbuf !offset c; + incr offset; + if !offset = Cstruct.length wbuf then self#flush () + + method close () = + Pool.Raw.release oc_pool wbuf; + Eio.Flow.shutdown flow `Send + end + +let io_backend ?addr ?port ?unix_sock ?max_connections ?max_buf_pool_size + ~(stdenv : Eio_unix.Stdenv.base) ~(sw : Eio.Switch.t) () : + (module H.IO_BACKEND) = + let addr, port, (sockaddr : Eio.Net.Sockaddr.stream) = + match addr, port, unix_sock with + | _, _, Some s -> Printf.sprintf "unix:%s" s, 0, `Unix s + | addr, port, None -> + let addr = Option.value ~default:"127.0.0.1" addr in + let sockaddr, port = + match Eio.Net.getaddrinfo stdenv#net addr, port with + | `Tcp (h, _) :: _, None -> + let p = 8080 in + `Tcp (h, p), p + | `Tcp (h, _) :: _, Some p -> `Tcp (h, p), p + | _ -> + failwith @@ Printf.sprintf "Could not parse TCP address from %S" addr + in + addr, port, sockaddr + in + + let module M = struct + let init_addr () = addr + let init_port () = port + let get_time_s () = Unix.gettimeofday () + let max_connections = get_max_connection_ ?max_connections () + + let pool_size = + match max_buf_pool_size with + | Some n -> n + | None -> min 4096 (max_connections * 2) + + let cstruct_pool = + Pool.create ~max_size:max_connections + ~mk_item:(fun () -> Cstruct.create buf_size) + () + + let tcp_server () : IO.TCP_server.builder = + { + IO.TCP_server.serve = + (fun ~after_init ~handle () : unit -> + let running = Atomic.make true in + let active_conns = Atomic.make 0 in + + Eio.Switch.on_release sw (fun () -> Atomic.set running false); + let net = Eio.Stdenv.net stdenv in + + (* main server socket *) + let sock = + let backlog = max_connections in + Eio.Net.listen ~reuse_addr:true ~reuse_port:true ~backlog ~sw net + sockaddr + in + + let tcp_server : IO.TCP_server.t = + { + running = (fun () -> Atomic.get running); + stop = + (fun () -> + Atomic.set running false; + Eio.Switch.fail sw Exit); + endpoint = + (fun () -> + (* TODO: find the real port *) + addr, port); + active_connections = (fun () -> Atomic.get active_conns); + } + in + + after_init tcp_server; + + while Atomic.get running do + Eio.Net.accept_fork ~sw + ~on_error:(fun exn -> + Log.error (fun k -> + k "error in client handler: %s" (Printexc.to_string exn))) + sock + (fun flow client_addr -> + Atomic.incr active_conns; + let@ () = + Fun.protect ~finally:(fun () -> + Log.debug (fun k -> + k "Tiny_httpd_eio: client handler returned"); + Atomic.decr active_conns) + in + let ic = ic_of_flow ~buf_pool:cstruct_pool flow in + let oc = oc_of_flow ~buf_pool:cstruct_pool flow in + + Log.debug (fun k -> + k "handling client on %a…" Eio.Net.Sockaddr.pp client_addr); + let client_addr_unix = eio_sock_addr_to_unix client_addr in + try handle.handle ~client_addr:client_addr_unix ic oc + with exn -> + let bt = Printexc.get_raw_backtrace () in + Log.error (fun k -> + k "Client handler for %a failed with %s\n%s" + Eio.Net.Sockaddr.pp client_addr + (Printexc.to_string exn) + (Printexc.raw_backtrace_to_string bt))) + done); + } + end in + (module M) + +let create ?addr ?port ?unix_sock ?max_connections ?max_buf_pool_size ~stdenv + ~sw ?buf_size ?middlewares () : H.t = + let backend = + io_backend ?addr ?port ?unix_sock ?max_buf_pool_size ?max_connections + ~stdenv ~sw () + in + H.create_from ?buf_size ?middlewares ~backend () diff --git a/src/eio/tiny_httpd_eio.mli b/src/eio/tiny_httpd_eio.mli new file mode 100644 index 00000000..3183ef49 --- /dev/null +++ b/src/eio/tiny_httpd_eio.mli @@ -0,0 +1,31 @@ +(** Tiny httpd EIO backend. + + This replaces the threads + Unix blocking syscalls of {!Tiny_httpd_server} + with an Eio-based cooperative system. + + {b NOTE}: this is very experimental and will absolutely change over time, + especially since Eio itself is also subject to change. + @since NEXT_RELEASE *) + +(* TODO: pass in a switch *) + +type 'a with_args = + ?addr:string -> + ?port:int -> + ?unix_sock:string -> + ?max_connections:int -> + ?max_buf_pool_size:int -> + stdenv:Eio_unix.Stdenv.base -> + sw:Eio.Switch.t -> + 'a + +val io_backend : (unit -> (module Tiny_httpd.Server.IO_BACKEND)) with_args +(** Create a server *) + +val create : + (?buf_size:int -> + ?middlewares:([ `Encoding | `Stage of int ] * Tiny_httpd.Middleware.t) list -> + unit -> + Tiny_httpd.Server.t) + with_args +(** Create a server *) diff --git a/src/html/Tiny_httpd_html.ml b/src/html/Tiny_httpd_html.ml index af9cf45d..4dacfc8a 100644 --- a/src/html/Tiny_httpd_html.ml +++ b/src/html/Tiny_httpd_html.ml @@ -1,19 +1,18 @@ (** HTML combinators. - This module provides combinators to produce html. It doesn't enforce - the well-formedness of the html, unlike Tyxml, but it's simple and should - be reasonably efficient. - @since 0.12 -*) + This module provides combinators to produce html. It doesn't enforce the + well-formedness of the html, unlike Tyxml, but it's simple and should be + reasonably efficient. + @since 0.12 *) include Html_ (** @inline *) (** Write an HTML element to this output. - @param top if true, add DOCTYPE at the beginning. The top element should then - be a "html" tag. - @since 0.14 - *) + @param top + if true, add DOCTYPE at the beginning. The top element should then be a + "html" tag. + @since 0.14 *) let to_output ?(top = false) (self : elt) (out : #IO.Output.t) : unit = let out = Out.create_of_out out in if top then Out.add_string out "\n"; @@ -22,18 +21,18 @@ let to_output ?(top = false) (self : elt) (out : #IO.Output.t) : unit = Out.flush out (** 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. *) + @param top + if true, add DOCTYPE at the beginning. The top element should then be a + "html" tag. *) let to_string ?top (self : elt) : string = let buf = Buffer.create 64 in let out = IO.Output.of_buffer buf in to_output ?top self out; Buffer.contents buf -(** Convert a list of HTML elements to a 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. *) +(** Convert a list of HTML elements to a 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 buf = Buffer.create 64 in let out = Out.create_of_buffer buf in @@ -57,7 +56,7 @@ let to_writer ?top (self : elt) : IO.Writer.t = let write (oc : #IO.Output.t) = to_output ?top self oc in IO.Writer.make ~write () -(** Convert a HTML element to a stream. This might just convert - it to a string first, do not assume it to be more efficient. *) +(** 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[@inline] to_stream (self : elt) : IO.Input.t = IO.Input.of_string @@ to_string self diff --git a/src/prometheus/tiny_httpd_prometheus.mli b/src/prometheus/tiny_httpd_prometheus.mli index 60083b76..06d6ca2e 100644 --- a/src/prometheus/tiny_httpd_prometheus.mli +++ b/src/prometheus/tiny_httpd_prometheus.mli @@ -1,11 +1,10 @@ (** Expose metrics over HTTP in the prometheus format. - This sub-library [tiny_httpd.prometheus] provides definitions - for counters, gauges, and histogram, and endpoints to expose - them for {{: https://prometheus.io/} Prometheus} to scrape them. + This sub-library [tiny_httpd.prometheus] provides definitions for counters, + gauges, and histogram, and endpoints to expose them for + {{:https://prometheus.io/} Prometheus} to scrape them. - @since 0.16 - *) + @since 0.16 *) type tags = (string * string) list @@ -17,13 +16,13 @@ module Registry : sig val create : unit -> t val on_will_emit : t -> (unit -> unit) -> unit - (** [on_will_emit registry f] calls [f()] every time - [emit buf registry] is called (before the metrics start being emitted). This - is useful to update some metrics on demand. *) + (** [on_will_emit registry f] calls [f()] every time [emit buf registry] is + called (before the metrics start being emitted). This is useful to update + some metrics on demand. *) val emit : Buffer.t -> t -> unit - (** Write metrics into the given buffer. The buffer will be - cleared first thing. *) + (** Write metrics into the given buffer. The buffer will be cleared first + thing. *) val emit_str : t -> string end @@ -40,8 +39,8 @@ module Counter : sig val incr_by : t -> int -> unit val incr_to : t -> int -> unit - (** Increment to the given number. If it's lower than the current - value this does nothing *) + (** Increment to the given number. If it's lower than the current value this + does nothing *) end (** Gauges *) @@ -88,7 +87,7 @@ module GC_metrics : sig val update : t -> unit val create_and_update_before_emit : Registry.t -> unit - (** [create_and_update_before_emit reg] creates new GC metrics, - adds them to the registry, and uses {!Registry.on_will_emit} - to {!update} the metrics every time the registry is polled. *) + (** [create_and_update_before_emit reg] creates new GC metrics, adds them to + the registry, and uses {!Registry.on_will_emit} to {!update} the metrics + every time the registry is polled. *) end diff --git a/src/unix/dir.ml b/src/unix/dir.ml index 6303b5a9..0cbb5021 100644 --- a/src/unix/dir.ml +++ b/src/unix/dir.ml @@ -151,9 +151,9 @@ let html_list_dir (module VFS : VFS) ~prefix ~parent d : Html.elt = [ 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 "[dir]" + else + sub_empty); sub_e @@ txt size; ]) ) @@ -176,21 +176,21 @@ let html_list_dir (module VFS : VFS) ~prefix ~parent d : Html.elt = @@ 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_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 -> diff --git a/src/unix/dir.mli b/src/unix/dir.mli index b07029f9..56a45758 100644 --- a/src/unix/dir.mli +++ b/src/unix/dir.mli @@ -1,29 +1,30 @@ (** Serving static content from directories - This module provides the same functionality as the "http_of_dir" tool. - It exposes a directory (and its subdirectories), with the optional ability - to delete or upload files. + This module provides the same functionality as the "http_of_dir" tool. It + exposes a directory (and its subdirectories), with the optional ability to + delete or upload files. @since 0.11 *) (** behavior of static directory. - This controls what happens when the user requests the path to - a directory rather than a file. *) + 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. *) | Lists (** Lists content of directory. Be careful of security implications. *) | Index_or_lists - (** 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 *) + (** 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 used to prevent users from building a config directly. Use + {!default_config} or {!config} instead. *) type config = { mutable download: bool; (** Is downloading files allowed? *) @@ -32,21 +33,17 @@ type config = { 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. *) + (** 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. *) +(** configuration for static file handlers. This might get more fields over + time. *) val default_config : unit -> config -(** default configuration: [ - { download=true - ; dir_behavior=Forbidden - ; delete=false - ; upload=false - ; max_upload_size = 10 * 1024 * 1024 - }] *) +(** default configuration: + [ { download=true ; dir_behavior=Forbidden ; delete=false ; upload=false ; + max_upload_size = 10 * 1024 * 1024 }] *) val config : ?download:bool -> @@ -61,16 +58,15 @@ val config : val add_dir_path : config:config -> dir:string -> prefix:string -> 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]. *) +(** [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]. *) (** Virtual file system. This is used to emulate a file system from pure OCaml functions and data, e.g. for resources bundled inside the web server. - @since 0.12 -*) + @since 0.12 *) module type VFS = sig val descr : string (** Description of the VFS *) @@ -78,12 +74,12 @@ module type VFS = sig val is_directory : string -> bool val contains : string -> bool - (** [file_exists vfs path] returns [true] if [path] points to a file - or directory inside [vfs]. *) + (** [file_exists vfs path] returns [true] if [path] points to a file or + directory inside [vfs]. *) val list_dir : string -> string array - (** List directory. This only returns basenames, the files need - to be put in the directory path using {!Filename.concat}. *) + (** List directory. This only returns basenames, the files need to be put in + the directory path using {!Filename.concat}. *) val delete : string -> unit (** Delete path *) @@ -102,23 +98,19 @@ module type VFS = sig end val vfs_of_dir : string -> (module VFS) -(** [vfs_of_dir dir] makes a virtual file system that reads from the - disk. - @since 0.12 -*) +(** [vfs_of_dir dir] makes a virtual file system that reads from the disk. + @since 0.12 *) val add_vfs : config:config -> vfs:(module VFS) -> prefix:string -> Server.t -> unit (** Similar to {!add_dir_path} but using a virtual file system instead. - @since 0.12 -*) + @since 0.12 *) -(** An embedded file system, as a list of files with (relative) paths. - This is useful in combination with the "tiny-httpd-mkfs" tool, - which embeds the files it's given into a OCaml module. +(** An embedded file system, as a list of files with (relative) paths. This is + useful in combination with the "tiny-httpd-mkfs" tool, which embeds the + files it's given into a OCaml module. - @since 0.12 -*) + @since 0.12 *) module Embedded_fs : sig type t (** The pseudo-filesystem *) @@ -127,8 +119,9 @@ module Embedded_fs : sig val add_file : ?mtime:float -> t -> path:string -> string -> unit (** Add file to the virtual file system. - @raise Invalid_argument if the path contains '..' or if it tries to - make a directory out of an existing path that is a file. *) + @raise Invalid_argument + if the path contains '..' or if it tries to make a directory out of an + existing path that is a file. *) val to_vfs : t -> (module VFS) end diff --git a/src/unix/tiny_httpd_unix.ml b/src/unix/tiny_httpd_unix.ml index 21ec2dff..1b400263 100644 --- a/src/unix/tiny_httpd_unix.ml +++ b/src/unix/tiny_httpd_unix.ml @@ -43,9 +43,9 @@ module Unix_tcp_server_ = struct | None -> ( Unix.socket (if Util.is_ipv6_str self.addr then - Unix.PF_INET6 - else - Unix.PF_INET) + Unix.PF_INET6 + else + Unix.PF_INET) Unix.SOCK_STREAM 0, true (* Because we're creating the socket ourselves *) ) in diff --git a/src/ws/dune b/src/ws/dune index b7702b7f..36e984dd 100644 --- a/src/ws/dune +++ b/src/ws/dune @@ -1,27 +1,50 @@ ; Set BUILD_TINY_HTTPD_OPTLEVEL to the -O level. ; Defaults to 2, which means -O2 is the default C optimization flag. ; Use -1 to remove the -O flag entirely. + (rule - (enabled_if (>= %{env:BUILD_TINY_HTTPD_OPTLEVEL=2} 0)) + (enabled_if + (>= %{env:BUILD_TINY_HTTPD_OPTLEVEL=2} 0)) (target optlevel.string) - (deps (env_var BUILD_TINY_HTTPD_OPTLEVEL)) - (action (with-stdout-to %{target} (echo "-O%{env:BUILD_TINY_HTTPD_OPTLEVEL=2}")))) + (deps + (env_var BUILD_TINY_HTTPD_OPTLEVEL)) + (action + (with-stdout-to + %{target} + (echo "-O%{env:BUILD_TINY_HTTPD_OPTLEVEL=2}")))) + (rule - (enabled_if (< %{env:BUILD_TINY_HTTPD_OPTLEVEL=2} 0)) + (enabled_if + (< %{env:BUILD_TINY_HTTPD_OPTLEVEL=2} 0)) (target optlevel.string) - (deps (env_var BUILD_TINY_HTTPD_OPTLEVEL)) - (action (with-stdout-to %{target} (echo "")))) + (deps + (env_var BUILD_TINY_HTTPD_OPTLEVEL)) + (action + (with-stdout-to + %{target} + (echo "")))) ; All compilers will include the optimization level. ; Non-MSVC compilers will include `-std=c99 -fPIC`. + (rule - (enabled_if (= %{ocaml-config:ccomp_type} msvc)) + (enabled_if + (= %{ocaml-config:ccomp_type} msvc)) (target cflags.sexp) - (action (with-stdout-to %{target} (echo "(%{read:optlevel.string})")))) + (action + (with-stdout-to + %{target} + (echo "(%{read:optlevel.string})")))) + (rule - (enabled_if (not (= %{ocaml-config:ccomp_type} msvc))) + (enabled_if + (not + (= %{ocaml-config:ccomp_type} msvc))) (target cflags.sexp) - (action (with-stdout-to %{target} (echo "(-std=c99 -fPIC %{read:optlevel.string})")))) + (action + (with-stdout-to + %{target} + (echo "(-std=c99 -fPIC %{read:optlevel.string})")))) (library (name tiny_httpd_ws) @@ -32,7 +55,9 @@ (foreign_stubs (language c) (names tiny_httpd_ws_stubs) - (flags :standard (:include cflags.sexp))) + (flags + :standard + (:include cflags.sexp))) (libraries (re_export tiny_httpd.core) threads)) diff --git a/src/ws/tiny_httpd_ws.ml b/src/ws/tiny_httpd_ws.ml index 41a8cc67..a7212df2 100644 --- a/src/ws/tiny_httpd_ws.ml +++ b/src/ws/tiny_httpd_ws.ml @@ -187,8 +187,8 @@ module Reader = struct type state = | Begin (** At the beginning of a frame *) | Reading_frame of { mutable remaining_bytes: int; mutable num_read: int } - (** Currently reading the payload of a frame with [remaining_bytes] - left to read from the underlying [ic] *) + (** Currently reading the payload of a frame with [remaining_bytes] left + to read from the underlying [ic] *) | Close type t = { @@ -266,7 +266,7 @@ module Reader = struct external apply_masking_ : key:bytes -> key_offset:int -> buf:bytes -> int -> int -> unit = "tiny_httpd_ws_apply_masking" - [@@noalloc] + [@@noalloc] (** Apply masking to the parsed data *) let[@inline] apply_masking ~mask_key ~mask_offset (buf : bytes) off len : unit @@ -414,7 +414,8 @@ let upgrade ic oc : _ * _ = in ws_ic, ws_oc -(** Turn a regular connection handler (provided by the user) into a websocket upgrade handler *) +(** Turn a regular connection handler (provided by the user) into a websocket + upgrade handler *) module Make_upgrade_handler (X : sig val accept_ws_protocol : string -> bool val handler : handler diff --git a/src/ws/tiny_httpd_ws.mli b/src/ws/tiny_httpd_ws.mli index 10ce1fee..7a6ccf4e 100644 --- a/src/ws/tiny_httpd_ws.mli +++ b/src/ws/tiny_httpd_ws.mli @@ -1,8 +1,7 @@ (** Websockets for Tiny_httpd. - This sub-library ([tiny_httpd.ws]) exports a small implementation - for a websocket server. It has no additional dependencies. - *) + This sub-library ([tiny_httpd.ws]) exports a small implementation for a + websocket server. It has no additional dependencies. *) type handler = unit Request.t -> IO.Input.t -> IO.Output.t -> unit (** Websocket handler *) @@ -11,8 +10,8 @@ val upgrade : IO.Input.t -> IO.Output.t -> IO.Input.t * IO.Output.t (** Upgrade a byte stream to the websocket framing protocol. *) exception Close_connection -(** Exception that can be raised from IOs inside the handler, - when the connection is closed from underneath. *) +(** Exception that can be raised from IOs inside the handler, when the + connection is closed from underneath. *) val add_route_handler : ?accept:(unit Request.t -> (unit, int * string) result) -> @@ -23,8 +22,9 @@ val add_route_handler : handler -> unit (** Add a route handler for a websocket endpoint. - @param accept_ws_protocol decides whether this endpoint accepts the websocket protocol - sent by the client. Default accepts everything. *) + @param accept_ws_protocol + decides whether this endpoint accepts the websocket protocol sent by the + client. Default accepts everything. *) (**/**) diff --git a/tiny_httpd_eio.opam b/tiny_httpd_eio.opam new file mode 100644 index 00000000..15b2a090 --- /dev/null +++ b/tiny_httpd_eio.opam @@ -0,0 +1,31 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "0.19" +synopsis: "Use eio for tiny_httpd" +maintainer: ["c-cube"] +authors: ["c-cube"] +license: "MIT" +homepage: "https://github.com/c-cube/tiny_httpd/" +bug-reports: "https://github.com/c-cube/tiny_httpd/issues" +depends: [ + "dune" {>= "3.2"} + "tiny_httpd" {= version} + "eio" {>= "1.0" & < "2.0"} + "logs" {with-test} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/c-cube/tiny_httpd.git"