Skip to content

Commit

Permalink
Continue renaming for Mirage version
Browse files Browse the repository at this point in the history
  • Loading branch information
aantron committed Mar 13, 2023
1 parent c8d2db0 commit c394615
Show file tree
Hide file tree
Showing 6 changed files with 51 additions and 44 deletions.
3 changes: 3 additions & 0 deletions src/mirage/adapt.ml
Original file line number Diff line number Diff line change
Expand Up @@ -6,6 +6,9 @@
XXX(dinosaure): same as [src/http/adapt.ml] without [address_to_string] - which
depends on [Unix]. *)

module Httpaf = Dream_httpaf_.Httpaf
module H2 = Dream_h2.H2

module Dream = Dream_pure
module Stream = Dream_pure.Stream

Expand Down
8 changes: 4 additions & 4 deletions src/mirage/dune
Original file line number Diff line number Diff line change
Expand Up @@ -9,12 +9,12 @@
dream.server
dream.certificate
dream-pure
dream-httpaf.h2
dream-httpaf.dream-h2
lwt
tcpip
dream-mirage.paf
dream-mirage.paf.alpn
dream-mirage.paf.mirage
dream-mirage.dream-paf
dream-mirage.dream-paf.alpn
dream-mirage.dream-paf.mirage
)
(preprocess (pps lwt_ppx))
(instrumentation (backend bisect_ppx)))
55 changes: 28 additions & 27 deletions src/mirage/error_handler.ml
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
module Httpaf = Dream_httpaf_.Httpaf

module Catch = Dream__server.Catch
module Error_template = Dream__server.Error_template
Expand All @@ -21,26 +22,26 @@ let select_log = function
let dump (error : Catch.error) =
let buffer = Buffer.create 4096 in
let p format = Printf.bprintf buffer format in

begin match error.condition with
| `Response response ->
let status = Message.status response in
p "%i %s\n" (Status.status_to_int status) (Status.status_to_string status)

| `String "" ->
p "(Library error without description payload)\n"

| `String string ->
p "%s\n" string

| `Exn exn ->
let backtrace = Printexc.get_backtrace () in
p "%s\n" (Printexc.to_string exn);
backtrace |> Log.iter_backtrace (p "%s\n")
end;

p "\n";

let layer =
match error.layer with
| `TLS -> "TLS library"
Expand All @@ -49,40 +50,40 @@ let select_log = function
| `WebSocket -> "WebSocket library"
| `App -> "Application"
in

let blame =
match error.caused_by with
| `Server -> "Server"
| `Client -> "Client"
in

let severity =
match error.severity with
| `Error -> "Error"
| `Warning -> "Warning"
| `Info -> "Info"
| `Debug -> "Debug"
in

p "From: %s\n" layer;
p "Blame: %s\n" blame;
p "Severity: %s" severity;

begin match error.client with
| None -> ()
| Some client -> p "\n\nClient: %s" client
end;

begin match error.request with
| None -> ()
| Some request ->
p "\n\n%s %s"
(Method.method_to_string (Message.method_ request))
(Message.target request);

Message.all_headers request
|> List.iter (fun (name, value) -> p "\n%s: %s" name value);

Message.fold_fields (fun name value first ->
if first then
p "\n";
Expand All @@ -92,23 +93,23 @@ let select_log = function
request
|> ignore
end;

Buffer.contents buffer

let customize template (error : Catch.error) =

(* First, log the error. *)

begin match error.condition with
| `Response _ -> ()
| `String _ | `Exn _ as condition ->

let client =
match error.client with
| None -> ""
| Some client -> " (" ^ client ^ ")"
in

let layer =
match error.layer with
| `TLS -> ["TLS" ^ client]
Expand All @@ -117,34 +118,34 @@ let select_log = function
| `WebSocket -> ["WebSocket" ^ client]
| `App -> []
in

let description, backtrace =
match condition with
| `String string -> string, ""
| `Exn exn ->
let backtrace = Printexc.get_backtrace () in
Printexc.to_string exn, backtrace
in

let message = String.concat ": " (layer @ [description]) in

select_log error.severity (fun log ->
log ?request:error.request "%s" message);
backtrace |> Log.iter_backtrace (fun line ->
select_log error.severity (fun log ->
log ?request:error.request "%s" line))
end;

(* If Dream will not send a response for this error, we are done after
logging. Otherwise, if debugging is enabled, gather a bunch of information.
Then, call the template, and return the response. *)

if not error.will_send_response then
Lwt.return_none

else
let debug_dump = dump error in

let response =
match error.condition with
| `Response response -> response
Expand All @@ -156,7 +157,7 @@ let select_log = function
in
Message.response ~status Stream.empty Stream.null
in

(* No need to catch errors when calling the template, because every call
site of the error handler already has error handlers for catching double
faults. *)
Expand All @@ -168,7 +169,7 @@ let select_log = function
Message.response ~status:`Internal_Server_Error Stream.empty Stream.null
| `Client ->
Message.response ~status:`Bad_Request Stream.empty Stream.null

let default_template _error _debug_dump response =
Lwt.return response

Expand Down Expand Up @@ -241,7 +242,7 @@ let respond_with_option f =
(fun () ->
Message.response ~status:`Internal_Server_Error Stream.empty Stream.null
|> Lwt.return)


let app user's_error_handler = fun error ->
respond_with_option (fun () -> user's_error_handler error)
4 changes: 4 additions & 0 deletions src/mirage/mirage.ml
Original file line number Diff line number Diff line change
@@ -1,3 +1,7 @@
module Httpaf = Dream_httpaf_.Httpaf
module Paf_mirage = Dream_paf_mirage.Paf_mirage
module Alpn = Dream_alpn.Alpn

module Catch = Dream__server.Catch
module Error_template = Dream__server.Error_template
module Method = Dream_pure.Method
Expand Down
23 changes: 11 additions & 12 deletions src/vendor/dune
Original file line number Diff line number Diff line change
Expand Up @@ -4,32 +4,31 @@

(subdir paf/lib
(library
(name paf)
(public_name dream-mirage.paf)
(name dream_paf)
(public_name dream-mirage.dream-paf)
(modules paf)
(libraries faraday bigstringaf ke mimic)))

(subdir paf/lib
(library
(name alpn)
(public_name dream-mirage.paf.alpn)
(name dream_alpn)
(public_name dream-mirage.dream-paf.alpn)
(modules alpn)
(libraries dream-mirage.paf dream-httpaf.httpaf dream-httpaf.h2)))
(libraries dream-mirage.dream-paf dream-httpaf.dream-httpaf_ dream-httpaf.dream-h2)))

(subdir paf/lib
(library
(name paf_mirage)
(public_name dream-mirage.paf.mirage)
(name dream_paf_mirage)
(public_name dream-mirage.dream-paf.mirage)
(modules paf_mirage)
(libraries tcpip dream-mirage.paf tls-mirage mirage-time dream-mirage.paf.alpn)))
(libraries tcpip dream-mirage.dream-paf tls-mirage mirage-time dream-mirage.dream-paf.alpn)))

(subdir paf/lib
(library
(name le)
(wrapped false)
(public_name dream-mirage.paf.le)
(name dream_le)
(public_name dream-mirage.dream-paf.le)
(modules lE)
(libraries tcpip dream-httpaf.httpaf dream-mirage.paf mirage-time duration tls-mirage emile
(libraries tcpip dream-httpaf.httpaf dream-mirage.dream-paf mirage-time duration tls-mirage emile
letsencrypt)))


Expand Down
2 changes: 1 addition & 1 deletion src/vendor/paf

0 comments on commit c394615

Please sign in to comment.