Fix dream mirage

.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

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"

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"}

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
   ]

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!"

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
 
 

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)
@@ -80,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)

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

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

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
@@ -150,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 =
@@ -167,10 +162,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) (Time : Mirage_time.S) (Stack : Tcpip
   let info = default_log.info
   let debug = default_log.debug
 
-  module Session = struct
-    include Dream__server.Session
-    include Dream__server.Session.Make (Pclock)
-  end
+  module Session = Dream__server.Session
   module Flash = Dream__server.Flash
 
 
@@ -335,7 +327,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
@@ -405,13 +397,13 @@ module Make (Pclock : Mirage_clock.PCLOCK) (Time : Mirage_time.S) (Stack : Tcpip
 
   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 =

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.

src/server/dune

@@ -11,7 +11,7 @@
   lwt
   magic-mime
   markup
-  mirage-clock
+  mirage-ptime
   multipart_form
   multipart_form-lwt
   ptime

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
 
 
 

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)