Improve low-level error handler

src/dream.mli

@@ -95,24 +95,6 @@ type ('a, 'b) log =
 
 module Log :
 sig
-  (* val log : middleware *)
-
-  (* type ('a, 'b) log =
-    ((?request:request ->
-    ('a, Stdlib.Format.formatter, unit, 'b) Stdlib.format4 -> 'a) -> 'b) ->
-      unit *)
-
-  (* TODO Provide Lwt-friendly logs. *)
-  (* TODO Try to turn this into a record, because first-class modules are a
-     major downer. *)
-  (* module type LOG =
-  sig
-    val error : ('a, unit) log
-    val warn : ('a, unit) log
-    val info : ('a, unit) log
-    val debug : ('a, unit) log
-  end *)
-
   type source = {
     error : 'a. ('a, unit) log;
     warning : 'a. ('a, unit) log;
@@ -120,17 +102,8 @@ sig
     debug : 'a. ('a, unit) log;
   }
 
-  (* val foo : unit -> foo *)
-
-  (* val create : string -> (module LOG) *)
   val source : string -> source
 
-  (* TODO Hide this from the API and just provide some function to set the
-     logger; also call it by default; also clear it. *)
-  (* val reporter : unit -> Logs.reporter *)
-
-  (* val request_id : Opium.Request.t -> int *)
-
   type level = [
     | `Error
     | `Warning
@@ -139,6 +112,8 @@ sig
   ]
 
   val initialize : ?backtraces:bool -> ?level:level -> enable:bool -> unit
+
+  val iter_backtrace : (string -> unit) -> string -> unit
 end
 
 (* TODO Try to unwrap this module. *)

src/httpaf/dream_httpaf.ml

@@ -1,5 +1,9 @@
-(* TODO Request contexts. *)
-(* TODO Application contexts. *)
+let address_to_string : Unix.sockaddr -> string = function
+  | ADDR_UNIX path -> path
+  | ADDR_INET (address, port) ->
+    Printf.sprintf "%s:%i" (Unix.string_of_inet_addr address) port
+
+
 
 (* Wraps the user's Dream handler in the kind of handler expected by http/af.
    The scheme is simple: wait for http/af "Reqd.t"s (partially parsed
@@ -11,11 +15,7 @@
    passed to http/af to end up in the error handler. This is a low-level handler
    that ordinarily shouldn't be relied on by the user - this is just our last
    chance to tell the user that something is wrong with their app. *)
-let wrap_handler (user's_dream_handler : Dream.handler) =
-
-  (* One Dream application context for all the requests. *)
-  let app =
-    Dream.new_app () in
+let wrap_handler app (user's_dream_handler : Dream.handler) =
 
   let httpaf_request_handler = fun client_address (conn : Httpaf.Reqd.t) ->
 
@@ -24,12 +24,7 @@ let wrap_handler (user's_dream_handler : Dream.handler) =
       Httpaf.Reqd.request conn in
 
     let client =
-      match (client_address : Unix.sockaddr) with
-      | ADDR_UNIX path -> path
-      | ADDR_INET (address, port) ->
-        Printf.sprintf "%s:%i" (Unix.string_of_inet_addr address) port
-    in
-
+      address_to_string client_address in
     let method_ =
       httpaf_request.meth in
     let target =
@@ -57,7 +52,6 @@ let wrap_handler (user's_dream_handler : Dream.handler) =
        exceptions, and the error callback that gets leaked exceptions is also
        customizable. *)
     Lwt.async begin fun () ->
-
       Lwt.catch begin fun () ->
         let open Lwt.Infix in
 
@@ -82,46 +76,70 @@ let wrap_handler (user's_dream_handler : Dream.handler) =
       @@ fun exn ->
         Httpaf.Reqd.report_exn conn exn;
         Lwt.return_unit
-
     end
-
   in
 
   httpaf_request_handler
 
 
-(* TODO Just log framework exceptions somewhere. Probably here, so we can also
-   log bad requests. *)
-
-
 
 type error_handler =
   Unix.sockaddr ->
   [ `Bad_request | `Bad_gateway | `Internal_server_error | `Exn of exn ] ->
     Dream.response Lwt.t
 
-(* TODO Log errors. *)
-let default_error_handler _client_address _error =
-  (* TODO But do set the Content-length to 0. *)
-  Lwt.return @@ Dream.response ()
+let log =
+  Dream.Log.source "dream.httpaf"
+
+let default_error_handler client_address error =
+  begin match error with
+  | `Bad_request ->
+    log.warning (fun m ->
+      m "Bad request from %s" (address_to_string client_address))
+
+  | `Bad_gateway | `Internal_server_error ->
+    log.error (fun m -> m "Content-Length missing when required, or negative")
+
+  | `Exn exn ->
+    log.error (fun m -> m "Application leaked %s" (Printexc.to_string exn));
+    Printexc.get_backtrace ()
+    |> Dream.Log.iter_backtrace (fun line -> log.error (fun m -> m "%s" line));
+  end;
+
+  Lwt.return @@ Dream.response ~headers:["Content-Length", "0"] ()
 
 
 
 let wrap_error_handler (user's_error_handler : error_handler) =
-  let open Lwt.Infix in
 
   let httpaf_error_handler = fun client_address ?request error start_response ->
     ignore request;
-    (* TODO In case of exception or rejection in the error handler, don't do
-       anything. *)
 
     Lwt.async begin fun () ->
-      user's_error_handler client_address error
-      >>= fun _response ->
-      (* TODO Take the headers and body from the actual response. *)
-      let response_body = start_response Httpaf.Headers.empty in
-      Httpaf.Body.write_string response_body "";
-      Lwt.return_unit
+      Lwt.catch begin fun () ->
+        let open Lwt.Infix in
+
+        user's_error_handler client_address error
+        >>= fun response ->
+
+        let headers =
+          Httpaf.Headers.of_list (Dream.headers response) in
+        let response_body = start_response headers in
+        (* TODO Read the body. *)
+
+        Httpaf.Body.write_string response_body "";
+
+        Lwt.return_unit
+      end
+      @@ fun exn ->
+        log.error (fun m ->
+          m "Double fault: error handler raised %s" (Printexc.to_string exn));
+
+        Printexc.get_backtrace ()
+        |> Dream.Log.iter_backtrace (fun line ->
+          log.error (fun m -> m "%s" line));
+
+        Lwt.return_unit
     end
   in
 
@@ -133,14 +151,16 @@ let serve =
   let never = fst (Lwt.wait ()) in
 
   fun
-    ?(interface = "localhost") ?(port = 8080) ?(stop = never)
+    ?(interface = "localhost") ?(port = 8080)
+    ?(stop = never)
+    ?(app = Dream.new_app ())
     ?(error_handler = default_error_handler)
     user's_dream_handler ->
 
   (* Create the wrapped Httpaf handler from the user's Dream handler. *)
   let httpaf_connection_handler =
     Httpaf_lwt_unix.Server.create_connection_handler
-      ~request_handler:(wrap_handler user's_dream_handler)
+      ~request_handler:(wrap_handler app user's_dream_handler)
       ~error_handler:(wrap_error_handler error_handler)
   in
 
@@ -153,7 +173,6 @@ let serve =
   >>= fun addresses ->
   match addresses with
   | [] ->
-    (* TODO Also log here once there is a working logger. *)
     Printf.ksprintf failwith "Dream_httpaf.serve: no interface with address %s"
       interface
   | address::_ ->
@@ -175,6 +194,6 @@ let serve =
 
 
 
-let run ?interface ?port ?stop ?error_handler user's_dream_handler =
+let run ?interface ?port ?stop ?app ?error_handler user's_dream_handler =
   Lwt_main.run
-    (serve ?interface ?port ?stop ?error_handler user's_dream_handler)
+    (serve ?interface ?port ?stop ?app ?error_handler user's_dream_handler)

src/httpaf/dream_httpaf.mli

@@ -33,6 +33,7 @@ val serve :
   ?interface:string ->
   ?port:int ->
   ?stop:unit Lwt.t ->
+  ?app:Dream.app ->
   ?error_handler:error_handler ->
   Dream.handler ->
     unit Lwt.t
@@ -41,6 +42,7 @@ val run :
   ?interface:string ->
   ?port:int ->
   ?stop:unit Lwt.t ->
+  ?app:Dream.app ->
   ?error_handler:error_handler ->
   Dream.handler ->
     unit

src/log.ml

@@ -262,6 +262,15 @@ let source name =
 
 
 
+(* A helper used in several places. *)
+let iter_backtrace f backtrace =
+  backtrace
+  |> String.split_on_char '\n'
+  |> List.filter (fun line -> line <> "")
+  |> List.iter f
+
+
+
 (* Use the above function to create a log source for Log's own middleware, the
    same way any other middleware would. *)
 let log = source "dream.log"
@@ -314,11 +323,8 @@ let log_traffic next_handler request =
     (fun exn ->
       (* In case of exception, log the exception and the backtrace. *)
       log.error (fun m -> m ~request "Aborted by %s" (Printexc.to_string exn));
-
       Printexc.get_backtrace ()
-      |> String.split_on_char '\n'
-      |> List.filter (fun s -> s <> "")
-      |> List.iter (fun s -> log.error (fun m -> m ~request "%s" s));
+      |> iter_backtrace (fun line -> log.error (fun m -> m ~request "%s" line));
 
       Lwt.fail exn)