From 86f1b9025dad397685131b1018144dac24aa0bd9 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 23 Jan 2024 16:00:52 -0500 Subject: [PATCH] add optional dependency on `logs` --- dune-project | 1 + examples/dune | 6 ++-- examples/echo.ml | 11 ++++-- examples/sse_server.ml | 7 ++-- src/Tiny_httpd.ml | 1 + src/Tiny_httpd.mli | 4 +++ src/Tiny_httpd_dir.ml | 17 +++++----- src/Tiny_httpd_log.default.ml | 6 ++++ src/Tiny_httpd_log.logs.ml | 16 +++++++++ src/Tiny_httpd_log.mli | 10 ++++++ src/Tiny_httpd_server.ml | 56 +++++++++++++++---------------- src/Tiny_httpd_server.mli | 12 +------ src/bin/http_of_dir.ml | 3 +- src/camlzip/Tiny_httpd_camlzip.ml | 17 +++++----- src/dune | 11 +++--- tiny_httpd.opam | 1 + 16 files changed, 106 insertions(+), 73 deletions(-) create mode 100644 src/Tiny_httpd_log.default.ml create mode 100644 src/Tiny_httpd_log.logs.ml create mode 100644 src/Tiny_httpd_log.mli diff --git a/dune-project b/dune-project index 435b7f75..f228c31d 100644 --- a/dune-project +++ b/dune-project @@ -14,6 +14,7 @@ (synopsis "Minimal HTTP server using threads") (tags (http thread server tiny_httpd http_of_dir simplehttpserver)) (depopts + logs (mtime (>= 2.0))) (depends seq diff --git a/examples/dune b/examples/dune index 9f5603b2..b6f4728a 100644 --- a/examples/dune +++ b/examples/dune @@ -1,7 +1,7 @@ (executable (name sse_server) (modules sse_server) - (libraries tiny_httpd unix ptime ptime.clock.os)) + (libraries tiny_httpd logs unix ptime ptime.clock.os)) (executable (name sse_client) @@ -12,13 +12,13 @@ (name echo) (flags :standard -warn-error -a+8) (modules echo vfs) - (libraries tiny_httpd tiny_httpd_camlzip)) + (libraries tiny_httpd logs tiny_httpd_camlzip)) (executable (name writer) (flags :standard -warn-error -a+8) (modules writer) - (libraries tiny_httpd)) + (libraries tiny_httpd logs)) (rule (targets test_output.txt) diff --git a/examples/echo.ml b/examples/echo.ml index fb06586a..a8b1b232 100644 --- a/examples/echo.ml +++ b/examples/echo.ml @@ -1,4 +1,5 @@ module S = Tiny_httpd +module Log = Tiny_httpd.Log let now_ = Unix.gettimeofday @@ -73,6 +74,10 @@ let base64 x = 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 () = let port_ = ref 8080 in let j = ref 32 in @@ -81,7 +86,7 @@ let () = [ "--port", Arg.Set_int port_, " set port"; "-p", Arg.Set_int port_, " set port"; - "--debug", Arg.Unit (fun () -> S._enable_debug true), " enable debug"; + "--debug", Arg.Unit setup_logging, " enable debug"; "-j", Arg.Set_int j, " maximum number of connections"; ]) (fun _ -> raise (Arg.Bad "")) @@ -134,7 +139,7 @@ let () = S.add_route_handler_stream ~meth:`PUT server S.Route.(exact "upload" @/ string @/ return) (fun path req -> - S._debug (fun k -> + Log.debug (fun k -> k "start upload %S, headers:\n%s\n\n%!" path (Format.asprintf "%a" S.Headers.pp (S.Request.headers req))); try @@ -153,7 +158,7 @@ let () = let ok = match S.Request.get_header req "authorization" with | Some v -> - S._debug (fun k -> k "authenticate with %S" v); + Log.debug (fun k -> k "authenticate with %S" v); v = "Basic " ^ base64 "user:foobar" | None -> false in diff --git a/examples/sse_server.ml b/examples/sse_server.ml index a12ad290..650c05cd 100644 --- a/examples/sse_server.ml +++ b/examples/sse_server.ml @@ -1,6 +1,7 @@ (* serves some streams of events *) module S = Tiny_httpd +module Log = Tiny_httpd_log let port = ref 8080 @@ -9,7 +10,7 @@ let () = (Arg.align [ "-p", Arg.Set_int port, " port to listen on"; - "--debug", Arg.Bool S._enable_debug, " toggle debug"; + "--debug", Arg.Unit (Log.setup ~debug:true), " enable debug"; ]) (fun _ -> ()) "sse_clock [opt*]"; @@ -26,12 +27,12 @@ let () = S.add_route_server_sent_handler server S.Route.(exact "clock" @/ return) (fun _req (module EV : S.SERVER_SENT_GENERATOR) -> - S._debug (fun k -> k "new connection"); + Log.debug (fun k -> k "new SSE connection"); EV.set_headers extra_headers; let tick = ref true in while true do let now = Ptime_clock.now () in - S._debug (fun k -> + Log.debug (fun k -> k "send clock ev %s" (Format.asprintf "%a" Ptime.pp now)); EV.send_event ~event: diff --git a/src/Tiny_httpd.ml b/src/Tiny_httpd.ml index cddbc0db..dfdd3b46 100644 --- a/src/Tiny_httpd.ml +++ b/src/Tiny_httpd.ml @@ -6,3 +6,4 @@ module Dir = Tiny_httpd_dir module Html = Tiny_httpd_html module IO = Tiny_httpd_io module Pool = Tiny_httpd_pool +module Log = Tiny_httpd_log diff --git a/src/Tiny_httpd.mli b/src/Tiny_httpd.mli index 1ab90cc5..4634edc8 100644 --- a/src/Tiny_httpd.mli +++ b/src/Tiny_httpd.mli @@ -89,6 +89,10 @@ module Byte_stream = Tiny_httpd_stream module IO = Tiny_httpd_io +(** {2 Logging *) + +module Log = Tiny_httpd_log + (** {2 Main Server Type} *) (** @inline *) diff --git a/src/Tiny_httpd_dir.ml b/src/Tiny_httpd_dir.ml index e8d575f4..b3fb6fb7 100644 --- a/src/Tiny_httpd_dir.ml +++ b/src/Tiny_httpd_dir.ml @@ -1,6 +1,7 @@ module S = Tiny_httpd_server module U = Tiny_httpd_util module Html = Tiny_httpd_html +module Log = Tiny_httpd_log type dir_behavior = Index | Lists | Index_or_lists | Forbidden type hidden = unit @@ -250,7 +251,7 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server in Tiny_httpd_stream.iter write req.S.Request.body; close (); - S._debug (fun k -> k "done uploading"); + Log.debug (fun k -> k "dir: done uploading file to %S" path); S.Response.make_raw ~code:201 "upload successful") else S.add_route_handler server ~meth:`PUT (route ()) (fun _ _ -> @@ -258,7 +259,7 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server if config.download then S.add_route_handler server ~meth:`GET (route ()) (fun path req -> - S._debug (fun k -> k "path=%S" path); + Log.debug (fun k -> k "dir: download path=%S" path); let mtime = lazy (match VFS.file_mtime path with @@ -272,11 +273,11 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server else if S.Request.get_header req "If-None-Match" = Some (Lazy.force mtime) then ( - S._debug (fun k -> - k "cached object %S (etag: %S)" path (Lazy.force mtime)); + Log.debug (fun k -> + k "dir: cached object %S (etag: %S)" path (Lazy.force mtime)); S.Response.make_raw ~code:304 "" ) else if VFS.is_directory path then ( - S._debug (fun k -> k "list dir %S (topdir %S)" path VFS.descr); + Log.debug (fun k -> k "dir: list dir %S (topdir %S)" path VFS.descr); let parent = Filename.(dirname path) in let parent = if Filename.basename path <> "." then @@ -288,7 +289,7 @@ let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS : VFS) as vfs) ~prefix server | (Index | Index_or_lists) when VFS.contains (path // "index.html") -> (* redirect using path, not full path *) let new_path = "/" // prefix // path // "index.html" in - S._debug (fun k -> k "redirect to `%s`" new_path); + Log.debug (fun k -> k "dir: redirect to `%s`" new_path); S.Response.make_void ~code:301 () ~headers:S.Headers.(empty |> set "location" new_path) | Lists | Index_or_lists -> @@ -425,7 +426,7 @@ module Embedded_fs = struct | _ -> None let contains p = - S._debug (fun k -> k "contains %S" p); + Log.debug (fun k -> k "vfs: contains %S" p); match find_ self p with | Some _ -> true | None -> false @@ -441,7 +442,7 @@ module Embedded_fs = struct | _ -> failwith (Printf.sprintf "no such file: %S" p) let list_dir p = - S._debug (fun k -> k "list dir %S" p); + Log.debug (fun k -> k "vfs: list dir %S" p); match find_ self p with | Some (Dir sub) -> Str_map.fold (fun sub _ acc -> sub :: acc) sub.entries [] diff --git a/src/Tiny_httpd_log.default.ml b/src/Tiny_httpd_log.default.ml new file mode 100644 index 00000000..bf801521 --- /dev/null +++ b/src/Tiny_httpd_log.default.ml @@ -0,0 +1,6 @@ +(* default: no logging *) + +let info _ = () +let debug _ = () +let error _ = () +let enable ~debug:_ () = () diff --git a/src/Tiny_httpd_log.logs.ml b/src/Tiny_httpd_log.logs.ml new file mode 100644 index 00000000..e55082ba --- /dev/null +++ b/src/Tiny_httpd_log.logs.ml @@ -0,0 +1,16 @@ +(* Use Logs *) + +module Log = (val Logs.(src_log @@ Src.create "tiny_httpd")) + +let info k = Log.info (fun fmt -> k (fun x -> fmt ?header:None ?tags:None x)) +let debug k = Log.debug (fun fmt -> k (fun x -> fmt ?header:None ?tags:None x)) +let error k = Log.err (fun fmt -> k (fun x -> fmt ?header:None ?tags:None x)) + +let setup ~debug () = + Logs.set_reporter @@ Logs.format_reporter (); + Logs.set_level ~all:true + (Some + (if debug then + Logs.Debug + else + Logs.Info)) diff --git a/src/Tiny_httpd_log.mli b/src/Tiny_httpd_log.mli new file mode 100644 index 00000000..d610c817 --- /dev/null +++ b/src/Tiny_httpd_log.mli @@ -0,0 +1,10 @@ +(** Logging for tiny_httpd *) + +val info : ((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) -> unit +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. + @param debug if true, set logging to debug (otherwise info) *) diff --git a/src/Tiny_httpd_server.ml b/src/Tiny_httpd_server.ml index 564181c5..95ed73f9 100644 --- a/src/Tiny_httpd_server.ml +++ b/src/Tiny_httpd_server.ml @@ -1,25 +1,11 @@ type buf = Tiny_httpd_buf.t type byte_stream = Tiny_httpd_stream.t -let _debug_on = - ref - (match String.trim @@ Sys.getenv "HTTP_DBG" with - | "" -> false - | _ -> true - | exception _ -> false) - -let _enable_debug b = _debug_on := b - -let _debug k = - if !_debug_on then - k (fun fmt -> - Printf.fprintf stdout "[http.thread %d]: " Thread.(id @@ self ()); - Printf.kfprintf (fun oc -> Printf.fprintf oc "\n%!") stdout fmt) - module Buf = Tiny_httpd_buf module Byte_stream = Tiny_httpd_stream module IO = Tiny_httpd_io module Pool = Tiny_httpd_pool +module Log = Tiny_httpd_log exception Bad_req of int * string @@ -137,7 +123,7 @@ module Headers = struct let parse_ ~buf (bs : byte_stream) : t = let rec loop acc = let line = Byte_stream.read_line ~buf bs in - _debug (fun k -> k "parsed header line %S" line); + Log.debug (fun k -> k "parsed header line %S" line); if line = "\r" then acc else ( @@ -225,11 +211,11 @@ module Request = struct (* decode a "chunked" stream into a normal stream *) let read_stream_chunked_ ?buf (bs : byte_stream) : byte_stream = - _debug (fun k -> k "body: start reading chunked stream..."); + Log.debug (fun k -> k "body: start reading chunked stream..."); Byte_stream.read_chunked ?buf ~fail:(fun s -> Bad_req (400, s)) bs let limit_body_size_ ~max_size (bs : byte_stream) : byte_stream = - _debug (fun k -> k "limit size of body to max-size=%d" max_size); + Log.debug (fun k -> k "limit size of body to max-size=%d" max_size); Byte_stream.limit_size_to ~max_size ~close_rec:false bs ~too_big:(fun size -> (* read too much *) @@ -242,7 +228,7 @@ module Request = struct (* read exactly [size] bytes from the stream *) let read_exactly ~size (bs : byte_stream) : byte_stream = - _debug (fun k -> k "body: must read exactly %d bytes" size); + Log.debug (fun k -> k "body: must read exactly %d bytes" size); Byte_stream.read_exactly bs ~close_rec:false ~size ~too_short:(fun size -> bad_reqf 400 "body is too short by %d bytes" size) @@ -260,11 +246,11 @@ module Request = struct if version != 0 && version != 1 then raise Exit; meth, path, version with _ -> - _debug (fun k -> k "invalid request line: `%s`" line); + Log.error (fun k -> k "invalid request line: `%s`" line); raise (Bad_req (400, "Invalid request line")) in let meth = Meth.of_string meth in - _debug (fun k -> k "got meth: %s, path %S" (Meth.to_string meth) path); + Log.debug (fun k -> k "got meth: %s, path %S" (Meth.to_string meth) path); let headers = Headers.parse_ ~buf bs in let host = match Headers.get "Host" headers with @@ -463,7 +449,7 @@ module Response = struct self.headers in let self = { self with headers; body } in - _debug (fun k -> + Log.debug (fun k -> k "output response: %s" (Format.asprintf "%a" pp { self with body = `String "<...>" })); @@ -872,6 +858,11 @@ module Unix_tcp_server_ = struct mutable running: bool; (* TODO: use an atomic? *) } + let str_of_sockaddr = function + | Unix.ADDR_UNIX f -> f + | Unix.ADDR_INET (inet, port) -> + Printf.sprintf "%s:%d" (Unix.string_of_inet_addr inet) port + let to_tcp_server (self : t) : IO.TCP_server.builder = { IO.TCP_server.serve = @@ -923,6 +914,8 @@ module Unix_tcp_server_ = struct (* how to handle a single client *) let handle_client_unix_ (client_sock : Unix.file_descr) (client_addr : Unix.sockaddr) : unit = + Log.info (fun k -> + k "serving new client on %s" (str_of_sockaddr client_addr)); Unix.(setsockopt_float client_sock SO_RCVTIMEO self.timeout); Unix.(setsockopt_float client_sock SO_SNDTIMEO self.timeout); let oc = @@ -930,11 +923,15 @@ module Unix_tcp_server_ = struct in let ic = IO.Input.of_unix_fd client_sock in handle.handle ~client_addr ic oc; - _debug (fun k -> k "done with client, exiting"); + Log.info (fun k -> + k "done with client on %s, exiting" + @@ str_of_sockaddr client_addr); (try Unix.close client_sock with e -> - _debug (fun k -> - k "error when closing sock: %s" (Printexc.to_string e))); + Log.error (fun k -> + k "error when closing sock for client %s: %s" + (str_of_sockaddr client_addr) + (Printexc.to_string e))); () in @@ -963,7 +960,7 @@ module Unix_tcp_server_ = struct -> () | exception e -> - _debug (fun k -> + Log.error (fun k -> k "Unix.accept or Thread.create raised an exception: %s" (Printexc.to_string e)) done; @@ -1030,7 +1027,7 @@ let client_handle_for (self : t) ~client_addr ic oc : unit = let is = Byte_stream.of_input ~buf_size:self.buf_size ic in let continue = ref true in while !continue && running self do - _debug (fun k -> k "read next request"); + Log.debug (fun k -> k "read next request"); let (module B) = self.backend in match Request.parse_req_start ~client_addr ~get_time_s:B.get_time_s ~buf is @@ -1042,7 +1039,8 @@ let client_handle_for (self : t) ~client_addr ic oc : unit = (try Response.output_ ~buf:buf_res oc res with Sys_error _ -> ()); continue := false | Ok (Some req) -> - _debug (fun k -> k "req: %s" (Format.asprintf "@[%a@]" Request.pp_ req)); + Log.debug (fun k -> + k "parsed request: %s" (Format.asprintf "@[%a@]" Request.pp_ req)); if Request.close_after_req req then continue := false; @@ -1057,7 +1055,7 @@ let client_handle_for (self : t) ~client_addr ic oc : unit = (* handle expect/continue *) (match Request.get_header ~f:String.trim req "Expect" with | Some "100-continue" -> - _debug (fun k -> k "send back: 100 CONTINUE"); + Log.debug (fun k -> k "send back: 100 CONTINUE"); Response.output_ ~buf:buf_res oc (Response.make_raw ~code:100 "") | Some s -> bad_reqf 417 "unknown expectation %s" s | None -> ()); diff --git a/src/Tiny_httpd_server.mli b/src/Tiny_httpd_server.mli index 621f6ed9..5859778b 100644 --- a/src/Tiny_httpd_server.mli +++ b/src/Tiny_httpd_server.mli @@ -67,8 +67,7 @@ module Request : sig meth: Meth.t; (** HTTP method for this request. *) host: string; (** Host header, mandatory. It can also be found in {!headers}. *) - client_addr: Unix.sockaddr; - (** Client address. Available since 0.14. *) + client_addr: Unix.sockaddr; (** Client address. Available since 0.14. *) headers: Headers.t; (** List of headers. *) http_version: int * int; (** HTTP version. This should be either [1, 0] or [1, 1]. *) @@ -667,12 +666,3 @@ val run_exn : ?after_init:(unit -> unit) -> t -> unit (** [run_exn s] is like [run s] but re-raises an exception if the server exits with an error. @since 0.14 *) - -(**/**) - -val _debug : - ((('a, out_channel, unit, unit, unit, unit) format6 -> 'a) -> unit) -> unit - -val _enable_debug : bool -> unit - -(**/**) diff --git a/src/bin/http_of_dir.ml b/src/bin/http_of_dir.ml index 87a96811..77953d7b 100644 --- a/src/bin/http_of_dir.ml +++ b/src/bin/http_of_dir.ml @@ -2,6 +2,7 @@ module S = Tiny_httpd module U = Tiny_httpd_util module D = Tiny_httpd_dir module Pf = Printf +module Log = Tiny_httpd.Log let serve ~config (dir : string) addr port j : _ result = let server = S.create ~max_connections:j ~addr ~port () in @@ -39,7 +40,7 @@ let main () = "--port", Set_int port, " port to listen on"; "-p", Set_int port, " alias to --port"; "--dir", Set_string dir_, " directory to serve (default: \".\")"; - "--debug", Unit (fun () -> S._enable_debug true), " debug mode"; + "--debug", Unit (Log.setup ~debug:true), " debug mode"; ( "--upload", Unit (fun () -> config.upload <- true), " enable file uploading" ); diff --git a/src/camlzip/Tiny_httpd_camlzip.ml b/src/camlzip/Tiny_httpd_camlzip.ml index 65833d20..e815641d 100644 --- a/src/camlzip/Tiny_httpd_camlzip.ml +++ b/src/camlzip/Tiny_httpd_camlzip.ml @@ -2,9 +2,10 @@ module S = Tiny_httpd_server module BS = Tiny_httpd_stream module W = Tiny_httpd_io.Writer module Out = Tiny_httpd_io.Output +module Log = Tiny_httpd.Log let decode_deflate_stream_ ~buf_size (is : S.byte_stream) : S.byte_stream = - S._debug (fun k -> k "wrap stream with deflate.decode"); + Log.debug (fun k -> k "wrap stream with deflate.decode"); let zlib_str = Zlib.inflate_init false in let is_done = ref false in BS.make ~bs:(Bytes.create buf_size) @@ -31,19 +32,19 @@ let decode_deflate_stream_ ~buf_size (is : S.byte_stream) : S.byte_stream = self.off <- 0; self.len <- used_out; if finished then is_done := true; - S._debug (fun k -> + Log.debug (fun k -> k "decode %d bytes as %d bytes from inflate (finished: %b)" used_in used_out finished) with Zlib.Error (e1, e2) -> S.Response.fail_raise ~code:400 "inflate: error during decompression:\n%s %s" e1 e2); - S._debug (fun k -> + Log.debug (fun k -> k "inflate: refill %d bytes into internal buf" self.len) )) () let encode_deflate_writer_ ~buf_size (w : W.t) : W.t = - S._debug (fun k -> k "wrap writer with deflate.encode"); + Log.debug (fun k -> k "wrap writer with deflate.encode"); let zlib_str = Zlib.deflate_init 4 false in let o_buf = Bytes.create buf_size in @@ -170,7 +171,7 @@ let compress_resp_stream_ ~compress_above ~buf_size (req : _ S.Request.t) match resp.body with | `String s when String.length s > compress_above -> (* big string, we compress *) - S._debug (fun k -> + Log.debug (fun k -> k "encode str response with deflate (size %d, threshold %d)" (String.length s) compress_above); let body = encode_deflate_writer_ ~buf_size @@ W.of_string s in @@ -178,13 +179,13 @@ let compress_resp_stream_ ~compress_above ~buf_size (req : _ S.Request.t) |> S.Response.update_headers update_headers |> S.Response.set_body (`Writer body) | `Stream str -> - S._debug (fun k -> k "encode stream response with deflate"); + Log.debug (fun k -> k "encode stream response with deflate"); let w = BS.to_writer str in resp |> S.Response.update_headers update_headers |> S.Response.set_body (`Writer (encode_deflate_writer_ ~buf_size w)) | `Writer w -> - S._debug (fun k -> k "encode writer response with deflate"); + Log.debug (fun k -> k "encode writer response with deflate"); resp |> S.Response.update_headers update_headers |> S.Response.set_body (`Writer (encode_deflate_writer_ ~buf_size w)) @@ -202,5 +203,5 @@ let middleware ?(compress_above = 16 * 1024) ?(buf_size = 16 * 1_024) () : let setup ?compress_above ?buf_size server = let m = middleware ?compress_above ?buf_size () in - S._debug (fun k -> k "setup gzip support"); + Log.info (fun k -> k "setup gzip middleware"); S.add_middleware ~stage:`Encoding server m diff --git a/src/dune b/src/dune index 680ebc43..b20bb974 100644 --- a/src/dune +++ b/src/dune @@ -1,13 +1,10 @@ - -(env - (_ - (flags :standard -warn-error -a+8 -w +a-4-32-40-42-44-48-70 -color always -safe-string - -strict-sequence))) - (library (name tiny_httpd) (public_name tiny_httpd) - (libraries threads seq unix) + (libraries threads seq unix + (select Tiny_httpd_log.ml from + (logs -> Tiny_httpd_log.logs.ml) + (-> Tiny_httpd_log.default.ml))) (wrapped false)) (rule diff --git a/tiny_httpd.opam b/tiny_httpd.opam index 955a14fe..eb19a982 100644 --- a/tiny_httpd.opam +++ b/tiny_httpd.opam @@ -22,6 +22,7 @@ depends: [ "qcheck-core" {>= "0.9" & with-test} ] depopts: [ + "logs" "mtime" {>= "2.0"} ] build: [