From 1b7939c17a03c4f8388d6030070fc5a38ab3c009 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?St=C3=A9phane=20Lavergne?= Date: Mon, 7 Aug 2023 16:09:04 -0400 Subject: [PATCH 1/6] Pass code to response makers Error codes still override it. --- src/Tiny_httpd_server.ml | 22 +++++++++++----------- src/Tiny_httpd_server.mli | 17 ++++++++++++++--- 2 files changed, 25 insertions(+), 14 deletions(-) diff --git a/src/Tiny_httpd_server.ml b/src/Tiny_httpd_server.ml index f1879bde..a3e36057 100644 --- a/src/Tiny_httpd_server.ml +++ b/src/Tiny_httpd_server.ml @@ -405,27 +405,27 @@ module Response = struct else make_raw ~headers ~code "" (* invalid to not have a body *) - let make_string ?headers r = + let make_string ?headers ?(code=200) r = match r with - | Ok body -> make_raw ?headers ~code:200 body + | Ok body -> make_raw ?headers ~code body | Error (code, msg) -> make_raw ?headers ~code msg - let make_stream ?headers r = + let make_stream ?headers ?(code=200) r = match r with - | Ok body -> make_raw_stream ?headers ~code:200 body + | Ok body -> make_raw_stream ?headers ~code body | Error (code, msg) -> make_raw ?headers ~code msg - let make_writer ?headers r : t = + let make_writer ?headers ?(code=200) r : t = match r with - | Ok body -> make_raw_writer ?headers ~code:200 body + | Ok body -> make_raw_writer ?headers ~code body | Error (code, msg) -> make_raw ?headers ~code msg - let make ?headers r : t = + let make ?headers ?(code=200) 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 () - | Ok (`Writer f) -> make_raw_writer ?headers ~code:200 f + | Ok (`String body) -> make_raw ?headers ~code body + | Ok (`Stream body) -> make_raw_stream ?headers ~code body + | Ok `Void -> make_void ?headers ~code () + | Ok (`Writer f) -> make_raw_writer ?headers ~code f | Error (code, msg) -> make_raw ?headers ~code msg let fail ?headers ~code fmt = diff --git a/src/Tiny_httpd_server.mli b/src/Tiny_httpd_server.mli index ea391cef..d9c8950e 100644 --- a/src/Tiny_httpd_server.mli +++ b/src/Tiny_httpd_server.mli @@ -251,7 +251,11 @@ module Response : sig (** Return a response without a body at all. @since 0.13 *) - val make : ?headers:Headers.t -> (body, Response_code.t * string) result -> t + val make : + ?headers:Headers.t -> + ?code:int -> + (body, Response_code.t * string) result -> + t (** [make r] turns a result into a response. - [make (Ok body)] replies with [200] and the body. @@ -260,17 +264,24 @@ module Response : sig *) val make_string : - ?headers:Headers.t -> (string, Response_code.t * string) result -> t + ?headers:Headers.t -> + ?code:int -> + (string, Response_code.t * string) result -> + t (** Same as {!make} but with a string body. *) val make_writer : ?headers:Headers.t -> + ?code:int -> (Tiny_httpd_io.Writer.t, Response_code.t * string) result -> t (** Same as {!make} but with a writer body. *) val make_stream : - ?headers:Headers.t -> (byte_stream, Response_code.t * string) result -> t + ?headers:Headers.t -> + ?code:int -> + (byte_stream, Response_code.t * string) result -> + t (** Same as {!make} but with a stream body. *) val fail : From a3f5dde2f185a7589f9fc576081ff43e12309b88 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 8 Aug 2023 12:37:19 -0400 Subject: [PATCH 2/6] format --- src/Tiny_httpd_server.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Tiny_httpd_server.ml b/src/Tiny_httpd_server.ml index a3e36057..c8cc7a3e 100644 --- a/src/Tiny_httpd_server.ml +++ b/src/Tiny_httpd_server.ml @@ -405,22 +405,22 @@ module Response = struct else make_raw ~headers ~code "" (* invalid to not have a body *) - let make_string ?headers ?(code=200) r = + let make_string ?headers ?(code = 200) r = match r with | Ok body -> make_raw ?headers ~code body | Error (code, msg) -> make_raw ?headers ~code msg - let make_stream ?headers ?(code=200) r = + let make_stream ?headers ?(code = 200) r = match r with | Ok body -> make_raw_stream ?headers ~code body | Error (code, msg) -> make_raw ?headers ~code msg - let make_writer ?headers ?(code=200) r : t = + let make_writer ?headers ?(code = 200) r : t = match r with | Ok body -> make_raw_writer ?headers ~code body | Error (code, msg) -> make_raw ?headers ~code msg - let make ?headers ?(code=200) r : t = + let make ?headers ?(code = 200) r : t = match r with | Ok (`String body) -> make_raw ?headers ~code body | Ok (`Stream body) -> make_raw_stream ?headers ~code body From 51b5b140a9b45a30295322b8564a0d1a906e238b Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 8 Aug 2023 12:38:59 -0400 Subject: [PATCH 3/6] disable warning 48 --- src/dune | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/dune b/src/dune index d2d9e3db..89ba2327 100644 --- a/src/dune +++ b/src/dune @@ -1,7 +1,7 @@ (env (_ - (flags :standard -warn-error -a+8 -w +a-4-32-40-42-44-70 -color always -safe-string + (flags :standard -warn-error -a+8 -w +a-4-32-40-42-44-48-70 -color always -safe-string -strict-sequence))) (library From 3802aad11f4b3d330dadd4ed9e3c39d0f3d492a9 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 8 Aug 2023 12:39:07 -0400 Subject: [PATCH 4/6] remove eio stuff. it doesn't really bring anything to the table for now. Let's wait until it becomes actually useful. --- echo_eio.sh | 2 - examples/dune | 7 -- examples/echo_eio.ml | 246 ------------------------------------- src/eio/dune | 8 -- src/eio/tiny_httpd_eio.ml | 178 --------------------------- src/eio/tiny_httpd_eio.mli | 30 ----- tiny_httpd_eio.opam | 22 ---- 7 files changed, 493 deletions(-) delete mode 100755 echo_eio.sh delete mode 100644 examples/echo_eio.ml delete mode 100644 src/eio/dune delete mode 100644 src/eio/tiny_httpd_eio.ml delete mode 100644 src/eio/tiny_httpd_eio.mli delete mode 100644 tiny_httpd_eio.opam diff --git a/echo_eio.sh b/echo_eio.sh deleted file mode 100755 index 5621bddc..00000000 --- a/echo_eio.sh +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/sh -exec dune exec --display=quiet --profile=release "examples/echo_eio.exe" -- $@ diff --git a/examples/dune b/examples/dune index dd8e19a3..9f5603b2 100644 --- a/examples/dune +++ b/examples/dune @@ -14,13 +14,6 @@ (modules echo vfs) (libraries tiny_httpd tiny_httpd_camlzip)) -(executable - (name echo_eio) - (flags :standard -warn-error -a+8) - (modules echo_eio) - (libraries tiny_httpd tiny_httpd_camlzip - tiny_httpd_eio eio eio_posix)) - (executable (name writer) (flags :standard -warn-error -a+8) diff --git a/examples/echo_eio.ml b/examples/echo_eio.ml deleted file mode 100644 index 39244a93..00000000 --- a/examples/echo_eio.ml +++ /dev/null @@ -1,246 +0,0 @@ -module S = Tiny_httpd -module S_eio = Tiny_httpd_eio - -let now_ = Unix.gettimeofday -let ( let@ ) = ( @@ ) - -(* util: a little middleware collecting statistics *) -let middleware_stat () : S.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 = S.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 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......" - -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]*"; - - (* use eio *) - let@ stdenv = Eio_posix.run in - let@ sw = Eio.Switch.run in - - (* create server *) - let server : S.t = - S_eio.create ~port:!port_ ~max_connections:!j - ~stdenv:(stdenv :> Eio_unix.Stdenv.base) - ~sw () - in - - 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; - - (* 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"))); - - (* 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 = - 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)); - - (* 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))); - - (* 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)); - - (* stats *) - S.add_route_handler server - S.Route.(exact "stats" @/ return) - (fun _req -> - let stats = get_stats () in - S.Response.make_string @@ Ok stats); - - S.add_route_handler server ~meth:`POST - S.Route.(exact "quit" @/ return) - (fun _req -> - S.stop server; - S.Response.make_string (Ok "quitting")); - - S.add_route_handler server - S.Route.(exact "alice" @/ return) - (fun _req -> S.Response.make_string (Ok alice_text)); - - (* main page *) - 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"; - ]; - ]; - li [] - [ - pre - [ A.style "display: inline" ] - [ - a [ A.href "/quit" ] [ txt "/quit" ]; - txt " (POST) to stop server"; - ]; - form - [ - A.style "display: inline"; - A.action "/quit"; - A.method_ "POST"; - ] - [ button [ A.type_ "submit" ] [ txt "quit" ] ]; - ]; - ]; - ]; - ] - 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); - let res = S.run server in - Gc.print_stat stdout; - match res with - | Ok () -> () - | Error e -> raise e diff --git a/src/eio/dune b/src/eio/dune deleted file mode 100644 index 37431aba..00000000 --- a/src/eio/dune +++ /dev/null @@ -1,8 +0,0 @@ - -(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 deleted file mode 100644 index 47bf3727..00000000 --- a/src/eio/tiny_httpd_eio.ml +++ /dev/null @@ -1,178 +0,0 @@ -module IO = Tiny_httpd_io -module H = Tiny_httpd_server -module Pool = Tiny_httpd_pool - -let ( let@ ) = ( @@ ) - -type 'a with_args = - ?addr:string -> - ?port:int -> - ?max_connections: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 ic_of_flow ~buf_pool:ic_pool (flow : Eio.Net.stream_socket) : - IO.In_channel.t = - Pool.with_resource ic_pool @@ fun cstruct -> - let len_slice = ref 0 in - let offset = ref 0 in - - let input buf i len = - if len = 0 then - 0 - else ( - let available = ref (!len_slice - !offset) in - if !available = 0 then ( - let n = flow#read_into cstruct in - offset := 0; - len_slice := n; - available := n - ); - - let n = min !available len in - if n > 0 then ( - Cstruct.blit_to_bytes cstruct !offset buf i n; - offset := !offset + n; - n - ) else - 0 - ) - in - let close () = flow#shutdown `Receive in - { IO.In_channel.input; close } - -let oc_of_flow ~buf_pool:oc_pool (flow : Eio.Net.stream_socket) : - IO.Out_channel.t = - (* write buffer *) - Pool.with_resource oc_pool @@ fun wbuf -> - let offset = ref 0 in - - let flush () = - if !offset > 0 then ( - let i = ref 0 in - let len = ref !offset in - - let src = - object - inherit Eio.Flow.source - - method read_into (cstruct : Cstruct.t) : int = - if !len = 0 then raise End_of_file; - let n = min !len (Cstruct.length cstruct) in - Cstruct.blit_from_bytes wbuf !i cstruct 0 n; - i := !i + n; - len := !len - n; - n - end - in - - flow#copy src; - offset := 0 - ) - in - - let output buf i len = - let i = ref i in - let len = ref len in - - while !len > 0 do - let available = Bytes.length wbuf - !offset in - let n = min !len available in - Bytes.blit buf !i wbuf !offset n; - offset := !offset + n; - i := !i + n; - len := !len - n; - - if !offset = Bytes.length wbuf then flush () - done - in - - let output_char c = - if !offset = Bytes.length wbuf then flush (); - Bytes.set wbuf !offset c; - incr offset; - if !offset = Bytes.length wbuf then flush () - in - - let close () = flow#shutdown `Send in - { IO.Out_channel.close; flush; output; output_char } - -let io_backend ?(addr = "127.0.0.1") ?(port = 8080) ?max_connections - ~(stdenv : Eio_unix.Stdenv.base) ~(sw : Eio.Switch.t) () : - (module H.IO_BACKEND) = - let module M = struct - let init_addr () = addr - let init_port () = port - let get_time_s () = Unix.gettimeofday () - let ic_pool = Pool.create ~mk_item:(fun () -> Cstruct.create buf_size) () - let oc_pool = Pool.create ~mk_item:(fun () -> Bytes.create buf_size) () - - let tcp_server () : IO.TCP_server.builder = - { - IO.TCP_server.serve = - (fun ~after_init ~handle () : unit -> - (* FIXME: parse *) - let ip_addr = Eio.Net.Ipaddr.V4.any in - 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 = get_max_connection_ ?max_connections () in - Eio.Net.listen ~reuse_addr:true ~reuse_port:true ~backlog ~sw net - (`Tcp (ip_addr, port)) - 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 -> - H._debug (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 () -> - H._debug (fun k -> - k "Tiny_httpd_eio: client handler returned"); - Atomic.decr active_conns) - in - let ic = ic_of_flow ~buf_pool:ic_pool flow in - let oc = oc_of_flow ~buf_pool:oc_pool flow in - handle.handle ic oc) - done); - } - end in - (module M) - -let create ?addr ?port ?max_connections ~stdenv ~sw ?buf_size ?middlewares () : - H.t = - let backend = io_backend ?addr ?port ?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 deleted file mode 100644 index 251f9508..00000000 --- a/src/eio/tiny_httpd_eio.mli +++ /dev/null @@ -1,30 +0,0 @@ -(** 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 -> - ?max_connections: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_server.Middleware.t) list -> - unit -> - Tiny_httpd_server.t) - with_args -(** Create a server *) diff --git a/tiny_httpd_eio.opam b/tiny_httpd_eio.opam deleted file mode 100644 index 8edeb893..00000000 --- a/tiny_httpd_eio.opam +++ /dev/null @@ -1,22 +0,0 @@ -opam-version: "2.0" -version: "0.13" -authors: ["Simon Cruanes"] -maintainer: "simon.cruanes.2007@m4x.org" -license: "MIT" -synopsis: "Run tiny_httpd on Eio" -build: [ - ["dune" "build" "@install" "-p" name "-j" jobs] - ["dune" "build" "@doc" "-p" name] {with-doc} - ["dune" "runtest" "-p" name] {with-test} -] -depends: [ - "dune" { >= "2.0" } - "eio" {>= "0.9"} - "tiny_httpd" { = version } - "odoc" {with-doc} -] -tags: [ "http" "server" "eio" ] -homepage: "https://github.com/c-cube/tiny_httpd/" -doc: "https://c-cube.github.io/tiny_httpd/" -bug-reports: "https://github.com/c-cube/tiny_httpd/issues" -dev-repo: "git+https://github.com/c-cube/tiny_httpd.git" From 25eb8b765aa49e55a31e4b423f4b35903a5c3078 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 8 Aug 2023 12:41:42 -0400 Subject: [PATCH 5/6] rename `IO.{In,Out}_channel` to avoid confusion these are not the standard in/out_channels so we should just use different names. --- src/Tiny_httpd_html.ml | 4 ++-- src/Tiny_httpd_io.ml | 15 +++++++------- src/Tiny_httpd_server.ml | 33 +++++++++++++++---------------- src/Tiny_httpd_stream.ml | 22 ++++++++++----------- src/Tiny_httpd_stream.mli | 6 +++--- src/camlzip/Tiny_httpd_camlzip.ml | 2 +- src/gen/gentags.ml | 12 +++++------ 7 files changed, 45 insertions(+), 49 deletions(-) diff --git a/src/Tiny_httpd_html.ml b/src/Tiny_httpd_html.ml index 1872707d..28fe8fa1 100644 --- a/src/Tiny_httpd_html.ml +++ b/src/Tiny_httpd_html.ml @@ -16,7 +16,7 @@ include Tiny_httpd_html_ be a "html" tag. @since NEXT_RELEASE *) -let to_out_channel ?(top = false) (self : elt) (out : IO.Out_channel.t) : unit = +let to_out_channel ?(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"; self out; @@ -28,7 +28,7 @@ let to_out_channel ?(top = false) (self : elt) (out : IO.Out_channel.t) : unit = be a "html" tag. *) let to_string ?top (self : elt) : string = let buf = Buffer.create 64 in - let out = IO.Out_channel.of_buffer buf in + let out = IO.Output.of_buffer buf in to_out_channel ?top self out; Buffer.contents buf diff --git a/src/Tiny_httpd_io.ml b/src/Tiny_httpd_io.ml index 815bd8de..64e376bf 100644 --- a/src/Tiny_httpd_io.ml +++ b/src/Tiny_httpd_io.ml @@ -11,7 +11,7 @@ module Buf = Tiny_httpd_buf (** Input channel (byte source) *) -module In_channel = struct +module Input = struct type t = { input: bytes -> int -> int -> int; (** Read into the slice. Returns [0] only if the @@ -54,7 +54,7 @@ module In_channel = struct end (** Output channel (byte sink) *) -module Out_channel = struct +module Output = struct type t = { output_char: char -> unit; (** Output a single char *) output: bytes -> int -> int -> unit; (** Output slice *) @@ -65,7 +65,7 @@ module Out_channel = struct This can be a [Buffer.t], an [out_channel], a [Unix.file_descr], etc. *) - (** [of_out_channel oc] wraps the channel into a {!Out_channel.t}. + (** [of_out_channel oc] wraps the channel into a {!Output.t}. @param close_noerr if true, then closing the result uses [close_out_noerr] instead of [close_out] to close [oc] *) let of_out_channel ?(close_noerr = false) (oc : out_channel) : t = @@ -158,7 +158,7 @@ end (** A writer abstraction. *) module Writer = struct - type t = { write: Out_channel.t -> unit } [@@unboxed] + type t = { write: Output.t -> unit } [@@unboxed] (** Writer. A writer is a push-based stream of bytes. @@ -173,22 +173,21 @@ module Writer = struct let[@inline] make ~write () : t = { write } (** Write into the channel. *) - let[@inline] write (oc : Out_channel.t) (self : t) : unit = self.write oc + let[@inline] write (oc : Output.t) (self : t) : unit = self.write oc (** Empty writer, will output 0 bytes. *) let empty : t = { write = ignore } (** A writer that just emits the bytes from the given string. *) let[@inline] of_string (str : string) : t = - let write oc = Out_channel.output_string oc str in + let write oc = Output.output_string oc str in { write } end (** A TCP server abstraction. *) module TCP_server = struct type conn_handler = { - handle: In_channel.t -> Out_channel.t -> unit; - (** Handle client connection *) + handle: Input.t -> Output.t -> unit; (** Handle client connection *) } type t = { diff --git a/src/Tiny_httpd_server.ml b/src/Tiny_httpd_server.ml index c8cc7a3e..e59fa360 100644 --- a/src/Tiny_httpd_server.ml +++ b/src/Tiny_httpd_server.ml @@ -444,7 +444,7 @@ module Response = struct Format.fprintf out "{@[code=%d;@ headers=[@[%a@]];@ body=%a@]}" self.code Headers.pp self.headers pp_body self.body - let output_ ~buf (oc : IO.Out_channel.t) (self : t) : unit = + let output_ ~buf (oc : IO.Output.t) (self : t) : unit = (* double indirection: - print into [buffer] using [bprintf] - transfer to [buf_] so we can output from there *) @@ -488,21 +488,21 @@ module Response = struct Buffer.clear tmp_buffer) headers; - IO.Out_channel.output_buf oc buf; - IO.Out_channel.output_string oc "\r\n"; + IO.Output.output_buf oc buf; + IO.Output.output_string oc "\r\n"; Buf.clear buf; (match body with | `String "" | `Void -> () - | `String s -> IO.Out_channel.output_string oc s + | `String s -> IO.Output.output_string oc s | `Writer w -> (* use buffer to chunk encode [w] *) - let oc' = IO.Out_channel.chunk_encoding ~buf ~close_rec:false oc in + let oc' = IO.Output.chunk_encoding ~buf ~close_rec:false oc in (try IO.Writer.write oc' w; - IO.Out_channel.close oc' + IO.Output.close oc' with e -> - IO.Out_channel.close oc'; + IO.Output.close oc'; raise e) | `Stream str -> (try @@ -511,7 +511,7 @@ module Response = struct with e -> Byte_stream.close str; raise e)); - IO.Out_channel.flush oc + IO.Output.flush oc end (* semaphore, for limiting concurrency. *) @@ -645,7 +645,7 @@ module Middleware = struct end (* a request handler. handles a single request. *) -type cb_path_handler = IO.Out_channel.t -> Middleware.handler +type cb_path_handler = IO.Output.t -> Middleware.handler module type SERVER_SENT_GENERATOR = sig val set_headers : Headers.t -> unit @@ -793,7 +793,7 @@ let[@inline] _opt_iter ~f o = exception Exit_SSE let add_route_server_sent_handler ?accept self route f = - let tr_req (oc : IO.Out_channel.t) req ~resp f = + let tr_req (oc : IO.Output.t) req ~resp f = let req = Pool.with_resource self.buf_pool @@ fun buf -> Request.read_body_full ~buf req @@ -816,7 +816,7 @@ let add_route_server_sent_handler ?accept self route f = in let[@inline] writef fmt = - Printf.ksprintf (IO.Out_channel.output_string oc) fmt + Printf.ksprintf (IO.Output.output_string oc) fmt in let send_event ?event ?id ?retry ~data () : unit = @@ -826,9 +826,9 @@ let add_route_server_sent_handler ?accept self route f = _opt_iter retry ~f:(fun e -> writef "retry: %s\n" e); let l = String.split_on_char '\n' data in List.iter (fun s -> writef "data: %s\n" s) l; - IO.Out_channel.output_string oc "\n"; + IO.Output.output_string oc "\n"; (* finish group *) - IO.Out_channel.flush oc + IO.Output.flush oc in let module SSG = struct let set_headers h = @@ -841,7 +841,7 @@ let add_route_server_sent_handler ?accept self route f = let close () = raise Exit_SSE end in try f req (module SSG : SERVER_SENT_GENERATOR) - with Exit_SSE -> IO.Out_channel.close oc + with Exit_SSE -> IO.Output.close oc in add_route_handler_ self ?accept ~meth:`GET route ~tr_req f @@ -938,10 +938,9 @@ module Unix_tcp_server_ = struct Unix.(setsockopt_float client_sock SO_RCVTIMEO self.timeout); Unix.(setsockopt_float client_sock SO_SNDTIMEO self.timeout); let oc = - IO.Out_channel.of_out_channel - @@ Unix.out_channel_of_descr client_sock + IO.Output.of_out_channel @@ Unix.out_channel_of_descr client_sock in - let ic = IO.In_channel.of_unix_fd client_sock in + let ic = IO.Input.of_unix_fd client_sock in handle.handle ic oc; _debug (fun k -> k "done with client, exiting"); (try Unix.close client_sock diff --git a/src/Tiny_httpd_stream.ml b/src/Tiny_httpd_stream.ml index cdaad2e2..5f8cf0a7 100644 --- a/src/Tiny_httpd_stream.ml +++ b/src/Tiny_httpd_stream.ml @@ -46,28 +46,28 @@ let make ?(bs = Bytes.create @@ (16 * 1024)) ?(close = ignore) ~consume ~fill () in self -let of_input ?(buf_size = 16 * 1024) (ic : IO.In_channel.t) : t = +let of_input ?(buf_size = 16 * 1024) (ic : IO.Input.t) : t = make ~bs:(Bytes.create buf_size) - ~close:(fun _ -> IO.In_channel.close ic) + ~close:(fun _ -> IO.Input.close ic) ~consume:(fun self 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 <- IO.In_channel.input ic self.bs 0 (Bytes.length self.bs) + self.len <- IO.Input.input ic self.bs 0 (Bytes.length self.bs) )) () let of_chan_ ?buf_size ic ~close_noerr : t = - let inc = IO.In_channel.of_in_channel ~close_noerr ic in + let inc = IO.Input.of_in_channel ~close_noerr ic in of_input ?buf_size inc let of_chan ?buf_size ic = of_chan_ ?buf_size ic ~close_noerr:false let of_chan_close_noerr ?buf_size ic = of_chan_ ?buf_size ic ~close_noerr:true let of_fd_ ?buf_size ~close_noerr ic : t = - let inc = IO.In_channel.of_unix_fd ~close_noerr ic in + let inc = IO.Input.of_unix_fd ~close_noerr ic in of_input ?buf_size inc let of_fd ?buf_size fd : t = of_fd_ ?buf_size ~close_noerr:false fd @@ -84,9 +84,7 @@ let rec iter f (self : t) : unit = ) let to_chan (oc : out_channel) (self : t) = iter (output oc) self - -let to_chan' (oc : IO.Out_channel.t) (self : t) = - iter (IO.Out_channel.output oc) self +let to_chan' (oc : IO.Output.t) (self : t) = iter (IO.Output.output oc) self let to_writer (self : t) : Tiny_httpd_io.Writer.t = { write = (fun oc -> to_chan' oc self) } @@ -299,11 +297,11 @@ let read_chunked ?(buf = Buf.create ()) ~fail (bs : t) : t = refill := false) () -let output_chunked' ?buf (oc : IO.Out_channel.t) (self : t) : unit = - let oc' = IO.Out_channel.chunk_encoding ?buf oc ~close_rec:false in +let output_chunked' ?buf (oc : IO.Output.t) (self : t) : unit = + let oc' = IO.Output.chunk_encoding ?buf oc ~close_rec:false in to_chan' oc' self; - IO.Out_channel.close oc' + IO.Output.close oc' (* print a stream as a series of chunks *) let output_chunked ?buf (oc : out_channel) (self : t) : unit = - output_chunked' ?buf (IO.Out_channel.of_out_channel oc) self + output_chunked' ?buf (IO.Output.of_out_channel oc) self diff --git a/src/Tiny_httpd_stream.mli b/src/Tiny_httpd_stream.mli index 7f8b38b8..5d75380c 100644 --- a/src/Tiny_httpd_stream.mli +++ b/src/Tiny_httpd_stream.mli @@ -64,7 +64,7 @@ val close : t -> unit val empty : t (** Stream with 0 bytes inside *) -val of_input : ?buf_size:int -> Tiny_httpd_io.In_channel.t -> t +val of_input : ?buf_size:int -> Tiny_httpd_io.Input.t -> t (** Make a buffered stream from the given channel. @since NEXT_RELEASE *) @@ -94,7 +94,7 @@ val to_chan : out_channel -> t -> unit (** Write the stream to the channel. @since 0.3 *) -val to_chan' : Tiny_httpd_io.Out_channel.t -> t -> unit +val to_chan' : Tiny_httpd_io.Output.t -> t -> unit (** Write to the IO channel. @since NEXT_RELEASE *) @@ -154,6 +154,6 @@ val output_chunked : ?buf:Tiny_httpd_buf.t -> out_channel -> t -> unit @param buf optional buffer for chunking (since NEXT_RELEASE) *) val output_chunked' : - ?buf:Tiny_httpd_buf.t -> Tiny_httpd_io.Out_channel.t -> t -> unit + ?buf:Tiny_httpd_buf.t -> Tiny_httpd_io.Output.t -> t -> unit (** Write the stream into the channel, using the chunked encoding. @since NEXT_RELEASE *) diff --git a/src/camlzip/Tiny_httpd_camlzip.ml b/src/camlzip/Tiny_httpd_camlzip.ml index 5d3cbe6c..65833d20 100644 --- a/src/camlzip/Tiny_httpd_camlzip.ml +++ b/src/camlzip/Tiny_httpd_camlzip.ml @@ -1,7 +1,7 @@ module S = Tiny_httpd_server module BS = Tiny_httpd_stream module W = Tiny_httpd_io.Writer -module Out = Tiny_httpd_io.Out_channel +module Out = Tiny_httpd_io.Output let decode_deflate_stream_ ~buf_size (is : S.byte_stream) : S.byte_stream = S._debug (fun k -> k "wrap stream with deflate.decode"); diff --git a/src/gen/gentags.ml b/src/gen/gentags.ml index d956f14d..c23bcfbc 100644 --- a/src/gen/gentags.ml +++ b/src/gen/gentags.ml @@ -294,7 +294,7 @@ let prelude = module Out : sig type t val create_of_buffer : Buffer.t -> t - val create_of_out: Tiny_httpd_io.Out_channel.t -> t + val create_of_out: Tiny_httpd_io.Output.t -> t val flush : t -> unit val add_char : t -> char -> unit val add_string : t -> string -> unit @@ -303,14 +303,14 @@ module Out : sig end = struct module IO = Tiny_httpd_io type t = { - out: IO.Out_channel.t; + out: IO.Output.t; mutable fmt_nl: bool; (* if true, we print [\n] around tags to format the html *) } let create_of_out out = {out; fmt_nl=true} - let create_of_buffer buf : t = create_of_out (IO.Out_channel.of_buffer buf) - let[@inline] flush self : unit = IO.Out_channel.flush self.out - let[@inline] add_char self c = IO.Out_channel.output_char self.out c - let[@inline] add_string self s = IO.Out_channel.output_string self.out s + let create_of_buffer buf : t = create_of_out (IO.Output.of_buffer buf) + let[@inline] flush self : unit = IO.Output.flush self.out + let[@inline] add_char self c = IO.Output.output_char self.out c + let[@inline] add_string self s = IO.Output.output_string self.out s let[@inline] add_format_nl self = if self.fmt_nl then add_char self '\n' let with_no_format_nl self f = if self.fmt_nl then ( From 5c1530f81622bdb64dc6b663080cd29ffb785d85 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 8 Aug 2023 12:49:15 -0400 Subject: [PATCH 6/6] github CI --- .github/workflows/main5.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/main5.yml b/.github/workflows/main5.yml index c2632371..fa249248 100644 --- a/.github/workflows/main5.yml +++ b/.github/workflows/main5.yml @@ -33,7 +33,7 @@ jobs: - run: opam install . --deps-only --with-test - - run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip,tiny_httpd_eio + - run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip - run: opam exec -- dune build @src/runtest @examples/runtest @tests/runtest -p tiny_httpd if: ${{ matrix.os == 'ubuntu-latest' }}