From c39461529350bbf975f34dd1ea5eb7866ed5c15b Mon Sep 17 00:00:00 2001 From: Anton Bachin Date: Mon, 13 Mar 2023 15:39:50 +0300 Subject: [PATCH] Continue renaming for Mirage version --- src/mirage/adapt.ml | 3 ++ src/mirage/dune | 8 +++--- src/mirage/error_handler.ml | 55 +++++++++++++++++++------------------ src/mirage/mirage.ml | 4 +++ src/vendor/dune | 23 ++++++++-------- src/vendor/paf | 2 +- 6 files changed, 51 insertions(+), 44 deletions(-) diff --git a/src/mirage/adapt.ml b/src/mirage/adapt.ml index 499a9d59..36ef4fee 100644 --- a/src/mirage/adapt.ml +++ b/src/mirage/adapt.ml @@ -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 diff --git a/src/mirage/dune b/src/mirage/dune index 61f5ee3d..4cc14e8f 100644 --- a/src/mirage/dune +++ b/src/mirage/dune @@ -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))) diff --git a/src/mirage/error_handler.ml b/src/mirage/error_handler.ml index e8da12ec..958a01a8 100644 --- a/src/mirage/error_handler.ml +++ b/src/mirage/error_handler.ml @@ -1,3 +1,4 @@ +module Httpaf = Dream_httpaf_.Httpaf module Catch = Dream__server.Catch module Error_template = Dream__server.Error_template @@ -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" @@ -49,13 +50,13 @@ 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" @@ -63,26 +64,26 @@ let select_log = function | `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"; @@ -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] @@ -117,7 +118,7 @@ let select_log = function | `WebSocket -> ["WebSocket" ^ client] | `App -> [] in - + let description, backtrace = match condition with | `String string -> string, "" @@ -125,26 +126,26 @@ let select_log = function 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 @@ -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. *) @@ -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 @@ -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) diff --git a/src/mirage/mirage.ml b/src/mirage/mirage.ml index f2c6bb9b..6f5f5a09 100644 --- a/src/mirage/mirage.ml +++ b/src/mirage/mirage.ml @@ -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 diff --git a/src/vendor/dune b/src/vendor/dune index cae56083..97aba743 100644 --- a/src/vendor/dune +++ b/src/vendor/dune @@ -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))) diff --git a/src/vendor/paf b/src/vendor/paf index 873e7b3b..14059ba8 160000 --- a/src/vendor/paf +++ b/src/vendor/paf @@ -1 +1 @@ -Subproject commit 873e7b3b00d60ac6d6b1a59c3e867f27f357369b +Subproject commit 14059ba85f886cf6babe9b8ce5a53a5b1f1bf3e8