.

mirage · Sep 16, 2024 · 9b783fa · 9b783fa
1 parent 2635c3f
commit 9b783fa
Show file tree

Hide file tree

Showing 33 changed files with 405 additions and 556 deletions.
diff --git a/.ocamlformat b/.ocamlformat
@@ -1,4 +1,4 @@
-version=0.26.1
+version=0.26.2
 module-item-spacing=compact
 break-struct=natural
 break-infix=fit-or-vertical
@@ -15,7 +15,6 @@ space-around-arrays=false
 break-cases=fit
 break-fun-decl=smart
 cases-exp-indent=2
-sequence-style=before
 if-then-else=compact
 field-space=tight
 indent-after-in=0

diff --git a/bin/adduser.ml b/bin/adduser.ml
@@ -121,7 +121,7 @@ let renderer =
 
 let reporter ppf =
   let report src level ~over k msgf =
-    let k _ = over () ; k () in
+    let k _ = over (); k () in
     let with_metadata header _tags k ppf fmt =
       Fmt.kpf k ppf
         ("%a[%a]: " ^^ fmt ^^ "\n%!")
@@ -132,10 +132,10 @@ let reporter ppf =
   {Logs.report}
 
 let setup_logs style_renderer level =
-  Fmt_tty.setup_std_outputs ?style_renderer ()
-  ; Logs.set_level level
-  ; Logs.set_reporter (reporter Fmt.stderr)
-  ; Option.is_none level
+  Fmt_tty.setup_std_outputs ?style_renderer ();
+  Logs.set_level level;
+  Logs.set_reporter (reporter Fmt.stderr);
+  Option.is_none level
 
 let setup_logs = Term.(const setup_logs $ renderer $ verbosity)
 

diff --git a/bin/lipap.ml b/bin/lipap.ml
@@ -9,15 +9,6 @@ let () = Logs.set_reporter reporter
 let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna)
 let ( <.> ) f g x = f (g x)
 
-module Random = struct
-  type g = unit
-
-  let generate ?g:_ len =
-    let ic = open_in "/dev/urandom" in
-    let rs = Bytes.create len in
-    really_input ic rs 0 len ; close_in ic ; Cstruct.of_bytes rs
-end
-
 open Rresult
 
 module Resolver = struct
@@ -39,13 +30,9 @@ module Resolver = struct
 end
 
 module Server =
-  Lipap.Make (Random) (Time) (Mclock) (Pclock) (Resolver)
-    (Tcpip_stack_socket.V4V6)
+  Lipap.Make (Time) (Mclock) (Pclock) (Resolver) (Tcpip_stack_socket.V4V6)
 
-let load_file filename =
-  let open Rresult in
-  Bos.OS.File.read filename >>= fun contents ->
-  R.ok (Cstruct.of_string contents)
+let load_file filename = Bos.OS.File.read filename
 
 let cert =
   let open Rresult in
@@ -75,7 +62,7 @@ let fiber ~domain locals =
       ~certificates:(`Single ([cert], private_key))
       ~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None)
       () in
-
+  let tls = Rresult.R.failwith_error_msg tls in
   TCP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None
   >>= fun tcpv4v6 ->
   let info =
@@ -86,11 +73,12 @@ let fiber ~domain locals =
     ; Ptt.SMTP.zone= Mrmime.Date.Zone.GMT
     ; Ptt.SMTP.size= 0x1000000L
     } in
-  let resolver = Dns_client_lwt.create () in
+  let he = Happy_eyeballs_lwt.create () in
+  let resolver = Dns_client_lwt.create he in
   let tls =
     let authenticator = R.failwith_error_msg (Ca_certs.authenticator ()) in
     Tls.Config.client ~authenticator () in
-
+  let tls = Rresult.R.failwith_error_msg tls in
   Server.fiber ~port:4242 ~locals ~tls tcpv4v6 resolver None Digestif.BLAKE2B
     info authenticator [Ptt.Mechanism.PLAIN]
 

diff --git a/bin/mti_gf.ml b/bin/mti_gf.ml
@@ -9,15 +9,6 @@ let () = Logs.set_reporter reporter
 let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna)
 let ( <.> ) f g x = f (g x)
 
-module Random = struct
-  type g = unit
-
-  let generate ?g:_ len =
-    let ic = open_in "/dev/urandom" in
-    let rs = Bytes.create len in
-    really_input ic rs 0 len ; close_in ic ; Cstruct.of_bytes rs
-end
-
 open Rresult
 
 module Resolver = struct
@@ -39,13 +30,9 @@ module Resolver = struct
 end
 
 module Server =
-  Mti_gf.Make (Random) (Time) (Mclock) (Pclock) (Resolver)
-    (Tcpip_stack_socket.V4V6)
+  Mti_gf.Make (Time) (Mclock) (Pclock) (Resolver) (Tcpip_stack_socket.V4V6)
 
-let load_file filename =
-  let open Rresult in
-  Bos.OS.File.read filename >>= fun contents ->
-  R.ok (Cstruct.of_string contents)
+let load_file filename = Bos.OS.File.read filename
 
 let cert =
   let open Rresult in
@@ -61,7 +48,7 @@ let private_key = Rresult.R.get_ok private_key
 
 let tls =
   let authenticator = R.failwith_error_msg (Ca_certs.authenticator ()) in
-  Tls.Config.client ~authenticator ()
+  R.failwith_error_msg (Tls.Config.client ~authenticator ())
 
 let fiber ~domain locals =
   let open Lwt.Infix in
@@ -77,7 +64,8 @@ let fiber ~domain locals =
     ; Ptt.SMTP.zone= Mrmime.Date.Zone.GMT
     ; Ptt.SMTP.size= 0x1000000L
     } in
-  let resolver = Dns_client_lwt.create () in
+  let he = Happy_eyeballs_lwt.create () in
+  let resolver = Dns_client_lwt.create he in
   Server.fiber ~port:4242 ~locals ~tls tcpv4v6 resolver info
 
 let romain_calascibetta =

diff --git a/bin/sSH.ml b/bin/sSH.ml
@@ -45,7 +45,7 @@ let read t =
 
 let write t cs =
   let str = Cstruct.to_string cs in
-  try output_string t.oc str ; flush t.oc ; Lwt.return_ok ()
+  try output_string t.oc str; flush t.oc; Lwt.return_ok ()
   with Unix.Unix_error (err, f, v) -> Lwt.return_error (`Error (err, f, v))
 
 let writev t css =
@@ -57,4 +57,4 @@ let writev t css =
       | Error _ as err -> Lwt.return err) in
   go t css
 
-let close t = close_in t.ic ; close_out t.oc ; Lwt.return_unit
+let close t = close_in t.ic; close_out t.oc; Lwt.return_unit
diff --git a/bin/spf.ml b/bin/spf.ml
@@ -17,7 +17,8 @@ let ns_check ~domain spf =
     let getrrecord dns key domain_name =
       Dns_client_lwt.get_resource_record dns key domain_name
   end in
-  let dns = Dns_client_lwt.create () in
+  let he = Happy_eyeballs_lwt.create () in
+  let dns = Dns_client_lwt.create he in
   Uspf_lwt.get ~domain dns (module DNS) >>= function
   | Ok spf' when Uspf.Term.equal spf spf' -> Lwt.return `Already_registered
   | Ok _ -> Lwt.return `Must_be_updated

diff --git a/lib/authentication.ml b/lib/authentication.ml
@@ -15,8 +15,8 @@ let is_zero = ( = ) '\000'
 let authenticate {return; bind} hash username password t =
   let ( >>= ) = bind in
   let p = Digestif.digest_string hash password in
-  Bytes.fill (Bytes.unsafe_of_string password) 0 (String.length password) '\000'
-  ; t username p >>= fun v -> return (R.ok v)
+  Bytes.fill (Bytes.unsafe_of_string password) 0 (String.length password) '\000';
+  t username p >>= fun v -> return (R.ok v)
 
 let decode_plain_authentication ({return; _} as scheduler) hash ?stamp t v =
   let parser =

diff --git a/lib/common.ml b/lib/common.ml
@@ -11,8 +11,7 @@ module Make
     (Scheduler : SCHEDULER)
     (IO : IO with type 'a t = 'a Scheduler.s)
     (Flow : FLOW with type 'a io = 'a IO.t)
-    (Resolver : RESOLVER with type 'a io = 'a IO.t)
-    (Random : RANDOM with type 'a io = 'a IO.t) =
+    (Resolver : RESOLVER with type 'a io = 'a IO.t) =
 struct
   type 'w resolver = {
       gethostbyname:
@@ -29,7 +28,7 @@ struct
         'a. 'w -> string -> string -> (Ipaddr.t, ([> R.msg ] as 'a)) result IO.t
   }
 
-  type 'g random = ?g:'g -> bytes -> unit IO.t
+  type 'g random = ?g:'g -> bytes -> ?off:int -> int -> unit
   type 'a consumer = 'a option -> unit IO.t
 
   let resolver =
@@ -43,13 +42,11 @@ struct
   let ( >>? ) x f =
     x >>= function Ok x -> f x | Error err -> return (Error err)
 
-  let generate ?g buf =
-    let open Random in
-    generate ?g buf >>= fun () ->
+  let generate ?g buf ?off len =
+    Mirage_crypto_rng.generate_into ?g buf ?off len;
     for i = 0 to Bytes.length buf - 1 do
       if Bytes.get buf i = '\000' then Bytes.set buf i '\001'
     done
-    ; return ()
 
   let scheduler =
     let open Scheduler in
@@ -97,21 +94,17 @@ struct
     let fold m {Dns.Mx.mail_exchange; Dns.Mx.preference} =
       Log.debug (fun m ->
           m "Try to resolve %a (MX) as a SMTP recipients box." Domain_name.pp
-            mail_exchange)
-      ; resolver.gethostbyname w mail_exchange >>= function
-        | Ok mx_ipaddr ->
-          IO.return
-            (Mxs.add
-               {
-                 Mxs.preference
-               ; Mxs.mx_ipaddr
-               ; Mxs.mx_domain= Some mail_exchange
-               }
-               m)
-        | Error (`Msg err) ->
-          Log.err (fun m ->
-              m "Impossible to resolve %a: %s" Domain_name.pp mail_exchange err)
-          ; IO.return m in
+            mail_exchange);
+      resolver.gethostbyname w mail_exchange >>= function
+      | Ok mx_ipaddr ->
+        IO.return
+          (Mxs.add
+             {Mxs.preference; Mxs.mx_ipaddr; Mxs.mx_domain= Some mail_exchange}
+             m)
+      | Error (`Msg err) ->
+        Log.err (fun m ->
+            m "Impossible to resolve %a: %s" Domain_name.pp mail_exchange err);
+        IO.return m in
     let rec go acc = function
       | [] -> IO.return acc
       | Forward_path.Postmaster :: r ->
@@ -121,21 +114,19 @@ struct
         try
           let domain = Domain_name.(host_exn <.> of_strings_exn) v in
           Log.debug (fun m ->
-              m "Try to resolve %a as a recipients box." Domain_name.pp domain)
-          ; resolver.getmxbyname w domain >>= function
-            | Ok m ->
-              Log.debug (fun pf ->
-                  pf "Got %d SMTP recipients box from %a."
-                    (Dns.Rr_map.Mx_set.cardinal m)
-                    Domain_name.pp domain)
-              ; list_fold_left_s ~f:fold Mxs.empty
-                  (Dns.Rr_map.Mx_set.elements m)
-                >>= fun s -> go (s :: acc) r
-            | Error (`Msg err) ->
-              Log.warn (fun m ->
-                  m "Impossible to resolve MX of %a: %s" Domain_name.pp domain
-                    err)
-              ; go acc r
+              m "Try to resolve %a as a recipients box." Domain_name.pp domain);
+          resolver.getmxbyname w domain >>= function
+          | Ok m ->
+            Log.debug (fun pf ->
+                pf "Got %d SMTP recipients box from %a."
+                  (Dns.Rr_map.Mx_set.cardinal m)
+                  Domain_name.pp domain);
+            list_fold_left_s ~f:fold Mxs.empty (Dns.Rr_map.Mx_set.elements m)
+            >>= fun s -> go (s :: acc) r
+          | Error (`Msg err) ->
+            Log.warn (fun m ->
+                m "Impossible to resolve MX of %a: %s" Domain_name.pp domain err);
+            go acc r
         with _exn -> go (Mxs.empty :: acc) r)
       | Forward_path.Forward_path {Path.domain= Domain.IPv4 mx_ipaddr; _} :: r
       | Forward_path.Domain (Domain.IPv4 mx_ipaddr) :: r ->
@@ -207,8 +198,8 @@ struct
       | Error (`Msg _err) ->
         Log.err (fun m ->
             m "%a is unreachable (no MX information)." (pp_recipients ~domain)
-              recipients)
-        ; IO.return resolved
+              recipients);
+        IO.return resolved
       | Ok mxs -> (
         let fold mxs {Dns.Mx.mail_exchange; Dns.Mx.preference} =
           resolver.gethostbyname w mail_exchange >>= function
@@ -220,8 +211,8 @@ struct
           | Error (`Msg _err) ->
             Log.err (fun m ->
                 m "%a as the SMTP service is unreachable." Domain_name.pp
-                  mail_exchange)
-            ; IO.return mxs in
+                  mail_exchange);
+            IO.return mxs in
         list_fold_left_s ~f:fold Mxs.empty (Dns.Rr_map.Mx_set.elements mxs)
         >>= fun mxs ->
         if Mxs.is_empty mxs then IO.return resolved

diff --git a/lib/common.mli b/lib/common.mli
@@ -5,10 +5,9 @@ module Make
     (Scheduler : SCHEDULER)
     (IO : IO with type 'a t = 'a Scheduler.s)
     (Flow : FLOW with type 'a io = 'a IO.t)
-    (Resolver : RESOLVER with type 'a io = 'a IO.t)
-    (Random : RANDOM with type 'a io = 'a IO.t) : sig
+    (Resolver : RESOLVER with type 'a io = 'a IO.t) : sig
   type 'w resolver
-  type 'g random = ?g:'g -> bytes -> unit IO.t
+  type 'g random = ?g:'g -> bytes -> ?off:int -> int -> unit
   type 'a consumer = 'a option -> unit IO.t
 
   val ( >>= ) : 'a IO.t -> ('a -> 'b IO.t) -> 'b IO.t
@@ -19,7 +18,7 @@ module Make
     -> ('b, 'err) result IO.t
 
   val resolver : Resolver.t resolver
-  val generate : Random.g random
+  val generate : Mirage_crypto_rng.g random
   val scheduler : Scheduler.t Colombe.Sigs.impl
   val rdwr : (Flow.t, Scheduler.t) Colombe.Sigs.rdwr