add optional dependency on logs

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

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)

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

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:

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

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 *)

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 []

src/Tiny_httpd_log.default.ml

@@ -0,0 +1,6 @@
+(* default: no logging *)
+
+let info _ = ()
+let debug _ = ()
+let error _ = ()
+let enable ~debug:_ () = ()

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))

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) *)

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 -> ());

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
-
-(**/**)

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" );

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

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

tiny_httpd.opam

@@ -22,6 +22,7 @@ depends: [
   "qcheck-core" {>= "0.9" & with-test}
 ]
 depopts: [
+  "logs"
   "mtime" {>= "2.0"}
 ]
 build: [