From 254852fe7e36be30023715a560ab82b1324cd073 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Thu, 15 May 2025 10:52:44 +0100 Subject: [PATCH 1/6] Replace vendored dream-{httpaf,paf} by h1, h2, paf --- dream-mirage.opam | 1 + src/mirage/adapt.ml | 13 +++++-------- src/mirage/dune | 8 ++++---- src/mirage/error_handler.ml | 4 +--- src/mirage/mirage.ml | 30 +++++++++++++----------------- 5 files changed, 24 insertions(+), 32 deletions(-) diff --git a/dream-mirage.opam b/dream-mirage.opam index 4f78340c..5b273304 100644 --- a/dream-mirage.opam +++ b/dream-mirage.opam @@ -59,6 +59,7 @@ depends: [ "ke" {>= "0.4"} # paf. "letsencrypt" {>= "0.3.0"} "lwt" + "paf" "lwt_ppx" {>= "1.2.2"} "mimic" {>= "0.0.5"} "mirage-time" diff --git a/src/mirage/adapt.ml b/src/mirage/adapt.ml index 32060e3d..a6ffe92a 100644 --- a/src/mirage/adapt.ml +++ b/src/mirage/adapt.ml @@ -6,9 +6,6 @@ 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 @@ -63,14 +60,14 @@ let forward_body_general let forward_body (response : Dream.Message.response) - (body : Httpaf.Body.Writer.t) = + (body : H1.Body.Writer.t) = forward_body_general response - (Httpaf.Body.Writer.write_string body) - (Httpaf.Body.Writer.write_bigstring body) - (Httpaf.Body.Writer.flush body) - (fun _code -> Httpaf.Body.Writer.close body) + (H1.Body.Writer.write_string body) + (H1.Body.Writer.write_bigstring body) + (H1.Body.Writer.flush body) + (fun _code -> H1.Body.Writer.close body) let forward_body_h2 (response : Dream.Message.response) diff --git a/src/mirage/dune b/src/mirage/dune index 242a8676..e820fbee 100644 --- a/src/mirage/dune +++ b/src/mirage/dune @@ -9,13 +9,13 @@ dream.server dream.certificate dream-pure - dream-httpaf.dream-h2 + h2 lwt rresult tcpip - dream-mirage.dream-paf - dream-mirage.dream-paf.alpn - dream-mirage.dream-paf.mirage + paf + paf.alpn + 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 958a01a8..9f25a8b0 100644 --- a/src/mirage/error_handler.ml +++ b/src/mirage/error_handler.ml @@ -1,5 +1,3 @@ -module Httpaf = Dream_httpaf_.Httpaf - module Catch = Dream__server.Catch module Error_template = Dream__server.Error_template module Method = Dream_pure.Method @@ -222,7 +220,7 @@ let httpaf user's_error_handler = fun client_address ?request:_ error start_resp let response = match response with | Some response -> response | None -> default_response caused_by in - let headers = Httpaf.Headers.of_list (Message.all_headers response) in + let headers = H1.Headers.of_list (Message.all_headers response) in let body = start_response headers in Adapt.forward_body response body; Lwt.return_unit diff --git a/src/mirage/mirage.ml b/src/mirage/mirage.ml index 86af0c20..e8ec05f0 100644 --- a/src/mirage/mirage.ml +++ b/src/mirage/mirage.ml @@ -1,7 +1,3 @@ -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 @@ -20,29 +16,29 @@ module Tag = Dream__server.Tag open Rresult open Lwt.Infix -let to_dream_method meth = Httpaf.Method.to_string meth |> Method.string_to_method -let to_httpaf_status status = Status.status_to_int status |> Httpaf.Status.of_code +let to_dream_method meth = H1.Method.to_string meth |> Method.string_to_method +let to_httpaf_status status = Status.status_to_int status |> H1.Status.of_code let ( >>? ) = Lwt_result.bind let wrap_handler_httpaf _user's_error_handler user's_dream_handler = let httpaf_request_handler = fun _ reqd -> - let httpaf_request = Httpaf.Reqd.request reqd in + let httpaf_request = H1.Reqd.request reqd in let method_ = to_dream_method httpaf_request.meth in let target = httpaf_request.target in let _version = (httpaf_request.version.major, httpaf_request.version.minor) in - let headers = Httpaf.Headers.to_list httpaf_request.headers in - let body = Httpaf.Reqd.request_body reqd in + let headers = H1.Headers.to_list httpaf_request.headers in + let body = H1.Reqd.request_body reqd in let read ~data ~flush:_ ~ping:_ ~pong:_ ~close ~exn:_ = - Httpaf.Body.Reader.schedule_read + H1.Body.Reader.schedule_read body ~on_eof:(fun () -> close 1000) ~on_read:(fun buffer ~off ~len -> data buffer off len true false) in let close _close = - Httpaf.Body.Reader.close body in + H1.Body.Reader.close body in let abort _close = - Httpaf.Body.Reader.close body in + H1.Body.Reader.close body in let body = Stream.reader ~read ~close ~abort in @@ -79,7 +75,7 @@ let wrap_handler_httpaf _user's_error_handler user's_dream_handler = Message.set_content_length_headers response; let headers = - Httpaf.Headers.of_list (Message.all_headers response) in + H1.Headers.of_list (Message.all_headers response) in (* let version = match Dream.version_override response with @@ -92,9 +88,9 @@ let wrap_handler_httpaf _user's_error_handler user's_dream_handler = Dream.reason_override response in *) let httpaf_response = - Httpaf.Response.create ~headers status in + H1.Response.create ~headers status in let body = - Httpaf.Reqd.respond_with_streaming reqd httpaf_response in + H1.Reqd.respond_with_streaming reqd httpaf_response in Adapt.forward_body response body; @@ -106,7 +102,7 @@ let wrap_handler_httpaf _user's_error_handler user's_dream_handler = @@ fun exn -> (* TODO LATER There was something in the fork changelogs about not requiring report_exn. Is it relevant to this? *) - Httpaf.Reqd.report_exn reqd exn; + H1.Reqd.report_exn reqd exn; Lwt.return_unit end in @@ -135,7 +131,7 @@ let error_handler fun client protocol ?request error respond -> match protocol with | Alpn.HTTP_1_1 _ -> - let start_response hdrs : Httpaf.Body.Writer.t = + let start_response hdrs : H1.Body.Writer.t = respond hdrs in Error_handler.httpaf user's_error_handler client ?request:(Some request) error start_response From 882422a6241e7ea15a1f83a5f8f9da4752de87dc Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Thu, 15 May 2025 11:03:55 +0100 Subject: [PATCH 2/6] Remove time/pclock modules --- dream.opam | 2 +- example/w-mirage/config.ml | 4 +--- example/w-mirage/unikernel.ml | 6 ++---- src/dream.ml | 4 +--- src/mirage/mirage.ml | 6 ++---- src/mirage/mirage.mli | 2 -- src/server/dune | 2 +- src/server/log.ml | 5 +---- src/server/session.ml | 4 +--- 9 files changed, 10 insertions(+), 25 deletions(-) diff --git a/dream.opam b/dream.opam index e1d8e2e9..ec60b061 100644 --- a/dream.opam +++ b/dream.opam @@ -68,7 +68,7 @@ depends: [ "logs" {>= "0.5.0"} "magic-mime" "markup" {>= "1.0.2"} - "mirage-clock" {>= "3.0.0"} # now_d_ps : unit -> int * int64. + "mirage-ptime" {>= "5.0.0"} # now_d_ps : unit -> int * int64. "mirage-crypto" {>= "1.2.0"} "mirage-crypto-rng" {>= "1.2.0"} "multipart_form" {>= "0.4.0"} diff --git a/example/w-mirage/config.ml b/example/w-mirage/config.ml index 20cc6d28..a42a15af 100644 --- a/example/w-mirage/config.ml +++ b/example/w-mirage/config.ml @@ -4,12 +4,10 @@ let main = main ~packages:[package "dream-mirage"] "Unikernel.Hello_world" - (pclock @-> time @-> stackv4v6 @-> job) + (stackv4v6 @-> job) let () = register "hello" [ main - $ default_posix_clock - $ default_time $ generic_stackv4v6 default_network ] diff --git a/example/w-mirage/unikernel.ml b/example/w-mirage/unikernel.ml index ec9be8eb..2b8cf075 100644 --- a/example/w-mirage/unikernel.ml +++ b/example/w-mirage/unikernel.ml @@ -1,12 +1,10 @@ module Hello_world - (Pclock : Mirage_clock.PCLOCK) - (Time : Mirage_time.S) (Stack : Tcpip.Stack.V4V6) = struct module Dream = - Dream__mirage.Mirage.Make (Pclock) (Time) (Stack) + Dream__mirage.Mirage.Make (Stack) - let start _pclock _time stack = + let start stack = Dream.http ~port:8080 (Stack.tcp stack) @@ Dream.logger @@ fun _ -> Dream.html "Good morning, world!" diff --git a/src/dream.ml b/src/dream.ml index 0485e807..31c62009 100644 --- a/src/dream.ml +++ b/src/dream.ml @@ -42,7 +42,6 @@ module Upload = Dream__server.Upload module Log = struct include Dream__server.Log - include Dream__server.Log.Make (Ptime_clock) end let default_log = @@ -52,7 +51,7 @@ let () = Log.initialize ~setup_outputs:Fmt_tty.setup_std_outputs let now () = - Ptime.to_float_s (Ptime.v (Ptime_clock.now_d_ps ())) + Ptime.to_float_s (Ptime.v (Mirage_ptime.now_d_ps ())) let () = Random.initialize (fun () -> @@ -61,7 +60,6 @@ let () = module Session = struct include Dream__server.Session - include Dream__server.Session.Make (Ptime_clock) end diff --git a/src/mirage/mirage.ml b/src/mirage/mirage.ml index e8ec05f0..74c410be 100644 --- a/src/mirage/mirage.ml +++ b/src/mirage/mirage.ml @@ -146,13 +146,12 @@ let handler user_err user_resp = } -module Make (Pclock : Mirage_clock.PCLOCK) (Time : Mirage_time.S) (Stack : Tcpip.Stack.V4V6) = struct +module Make (Stack : Tcpip.Stack.V4V6) = struct include Dream_pure include Method include Status include Log - include Log.Make (Pclock) include Dream__server.Echo let default_log = @@ -165,7 +164,6 @@ module Make (Pclock : Mirage_clock.PCLOCK) (Time : Mirage_time.S) (Stack : Tcpip module Session = struct include Dream__server.Session - include Dream__server.Session.Make (Pclock) end module Flash = Dream__server.Flash @@ -331,7 +329,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) (Time : Mirage_time.S) (Stack : Tcpip Log.convenience_log - let now () = Ptime.to_float_s (Ptime.v (Pclock.now_d_ps ())) + let now () = Ptime.to_float_s (Ptime.v (Mirage_ptime.now_d_ps ())) let form = form ~now let multipart = multipart ~now diff --git a/src/mirage/mirage.mli b/src/mirage/mirage.mli index 2fe428b6..e690e64f 100644 --- a/src/mirage/mirage.mli +++ b/src/mirage/mirage.mli @@ -7,8 +7,6 @@ type handler = request -> response Lwt.t type middleware = handler -> handler module Make - (Pclock : Mirage_clock.PCLOCK) - (Time : Mirage_time.S) (Stack : Tcpip.Stack.V4V6) : sig (* This file is part of Dream, released under the MIT license. See LICENSE.md for details, or visit https://github.com/camlworks/dream. diff --git a/src/server/dune b/src/server/dune index 4e5125e6..a9a83ecf 100644 --- a/src/server/dune +++ b/src/server/dune @@ -11,7 +11,7 @@ lwt magic-mime markup - mirage-clock + mirage-ptime multipart_form multipart_form-lwt ptime diff --git a/src/server/log.ml b/src/server/log.ml index efbeae97..99311e11 100644 --- a/src/server/log.ml +++ b/src/server/log.ml @@ -429,10 +429,8 @@ let set_log_level name level = let fd_field : int Message.field = Message.new_field ~name:"dream.fd" ~show_value:string_of_int () -module Make (Pclock : Mirage_clock.PCLOCK) = -struct let now () = - Ptime.to_float_s (Ptime.v (Pclock.now_d_ps ())) + Ptime.to_float_s (Ptime.v (Mirage_ptime.now_d_ps ())) let initializer_ ~setup_outputs = lazy begin if !enable then begin @@ -559,7 +557,6 @@ struct |> iter_backtrace (fun line -> log.warning (fun log -> log "%s" line)); Lwt.fail exn) -end diff --git a/src/server/session.ml b/src/server/session.ml index a969fc49..1d63a37f 100644 --- a/src/server/session.ml +++ b/src/server/session.ml @@ -338,8 +338,7 @@ let {middleware; getter} = let two_weeks = 60. *. 60. *. 24. *. 7. *. 2. -module Make (Pclock : Mirage_clock.PCLOCK) = struct - let now () = Ptime.to_float_s (Ptime.v (Pclock.now_d_ps ())) + let now () = Ptime.to_float_s (Ptime.v (Mirage_ptime.now_d_ps ())) let memory_sessions ?(lifetime = two_weeks) = (* "Memory.back_end" returns a record that has a state (a hash table). If we @@ -351,7 +350,6 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct let cookie_sessions ?(lifetime = two_weeks) = middleware (Cookie.back_end ~now lifetime) -end let session name request = List.assoc_opt name (!(snd (getter request)).payload) From c43a464646e43b5007f3920d645bef8788cda8cf Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Thu, 15 May 2025 11:36:11 +0100 Subject: [PATCH 3/6] Pass x509 certificate directly as string --- src/mirage/mirage.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/mirage/mirage.ml b/src/mirage/mirage.ml index 74c410be..1e753f84 100644 --- a/src/mirage/mirage.ml +++ b/src/mirage/mirage.ml @@ -399,13 +399,13 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct let localhost_certificate = let crts = Rresult.R.failwith_error_msg - (X509.Certificate.decode_pem_multiple (Cstruct.of_string Dream__certificate.localhost_certificate)) in + (X509.Certificate.decode_pem_multiple Dream__certificate.localhost_certificate) in let key = Rresult.R.failwith_error_msg - (X509.Private_key.decode_pem (Cstruct.of_string Dream__certificate.localhost_certificate_key)) in + (X509.Private_key.decode_pem Dream__certificate.localhost_certificate_key) in `Single (crts, key) let https ?stop ~port ?(prefix= "") stack - ?(cfg= Tls.Config.server ~certificates:localhost_certificate ()) + ?(cfg= Tls.Config.server ~certificates:localhost_certificate () |> Result.get_ok) ?error_handler:(user's_error_handler : error_handler = Error_handler.default) (user's_dream_handler : Message.handler) = initialize ~setup_outputs:ignore ; let connect flow = From 4c31a6d4571fb59395be0bced987b0db99622314 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Fri, 5 Sep 2025 19:25:42 +0200 Subject: [PATCH 4/6] Refactor mirage.ml --- src/mirage/mirage.ml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/mirage/mirage.ml b/src/mirage/mirage.ml index 1e753f84..25babee0 100644 --- a/src/mirage/mirage.ml +++ b/src/mirage/mirage.ml @@ -162,9 +162,7 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct let info = default_log.info let debug = default_log.debug - module Session = struct - include Dream__server.Session - end + module Session = Dream__server.Session module Flash = Dream__server.Flash From 02c5d96d168088376ce78ca86bbf0aafeac4b69c Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 17 May 2025 17:32:26 +0200 Subject: [PATCH 5/6] Fix pipeline mirage build minor opam fixes, get rid of mirage-clock Enable test workflow remove psq in the test as well Update pipeline --- .github/workflows/test.yml | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 93307b30..822ce6f6 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -134,7 +134,6 @@ jobs: fi mirage: - if: false runs-on: ubuntu-22.04 steps: - uses: actions/checkout@v4 @@ -147,16 +146,15 @@ jobs: ocaml-compiler: 4.14.x dune-cache: true - run: opam install --yes --deps-only ./dream-pure.opam ./dream-httpaf.opam ./dream.opam ./dream-mirage.opam - - run: opam install --yes mirage mirage-clock-unix mirage-crypto-rng-mirage + - run: opam install --yes mirage mirage-ptime mirage-crypto-rng-mirage - run: cd example/w-mirage && mv config.ml config.ml.backup - run: cd example/w-mirage && sed -e 's/package "dream-mirage"//' < config.ml.backup > config.ml - run: cd example/w-mirage && opam exec -- mirage configure -t unix - run: cd example/w-mirage && opam exec -- make depends - run: cd example/w-mirage && ls duniverse - run: cp -r ../repo-copy example/w-mirage/duniverse/dream - - run: cd example/w-mirage/duniverse && rm -rf ocaml-cstruct logs ke fmt lwt bytes seq mirage-flow sexplib0 ptime tls domain-name ocaml-ipaddr mirage-clock ocplib-endian digestif eqaf mirage-crypto mirage-runtime + - run: cd example/w-mirage/duniverse && rm -rf ocaml-cstruct logs fmt lwt bytes seq mirage-flow ptime domain-name ocaml-ipaddr mirage-ptime ocplib-endian digestif eqaf mirage-crypto psq mirage-tcpip duration mirage cmdliner randomconv mirage-mtime mtime lru arp ethernet mirage-net mirage-sleep - run: cd example/w-mirage && mv config.ml.backup config.ml - - run: cd example/w-mirage && sed -e 's/(libraries/(libraries dream-mirage/' < dune.build > dune.build.2 - - run: cd example/w-mirage && mv dune.build.2 dune.build + - run: cd example/w-mirage && sed -i -e 's/(libraries/(libraries dream-mirage/' dune.build - run: cd example/w-mirage && opam exec -- dune build - run: file example/w-mirage/_build/default/main.exe From faf8dedbd370011d7dab6affd12ad3230c50f977 Mon Sep 17 00:00:00 2001 From: Sebastian Willenbrink Date: Fri, 6 Feb 2026 11:29:18 +0100 Subject: [PATCH 6/6] Support h2.0.13.0 in dream-mirage --- src/mirage/adapt.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/mirage/adapt.ml b/src/mirage/adapt.ml index a6ffe92a..d7048e49 100644 --- a/src/mirage/adapt.ml +++ b/src/mirage/adapt.ml @@ -77,5 +77,5 @@ let forward_body_h2 response (H2.Body.Writer.write_string body) (H2.Body.Writer.write_bigstring body) - (H2.Body.Writer.flush body) + (fun f -> H2.Body.Writer.flush body (fun _ -> f ())) (fun _code -> H2.Body.Writer.close body)