Merge pull request #46 from mirage/upgrade

Upgrade

.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

Dockerfile.relay

@@ -1,6 +1,6 @@
 FROM ocaml/opam:ubuntu-20.04-ocaml-4.14
 RUN sudo ln -f /usr/bin/opam-2.1 /usr/bin/opam
-RUN cd ~/opam-repository && git pull origin master && git reset --hard cd449b28e1149a5bafa7f1c6262879ce509b7eea && opam update
+RUN cd ~/opam-repository && git pull origin master && git reset --hard 164c8ecdbe88cb6ee4c0b137997c2e7f3763577e && opam update
 RUN opam depext -ui mirage
 RUN mkdir -p /home/opam/src
 WORKDIR /home/opam/src
@@ -13,4 +13,4 @@ COPY --chown=opam:root unikernel/relay/ /home/opam/src
 RUN opam pin add ptt -ny git+https://github.com/dinosaure/ptt.git#$BRANCH
 RUN opam depext -ui ptt
 RUN opam config exec -- make depends
-RUN opam config exec -- mirage build
+RUN opam config exec -- make build

Dockerfile.signer

@@ -1,6 +1,6 @@
 FROM ocaml/opam:ubuntu-20.04-ocaml-4.14
 RUN sudo ln -f /usr/bin/opam-2.1 /usr/bin/opam
-RUN cd ~/opam-repository && git pull origin master && git reset --hard cd449b28e1149a5bafa7f1c6262879ce509b7eea && opam update
+RUN cd ~/opam-repository && git pull origin master && git reset --hard 164c8ecdbe88cb6ee4c0b137997c2e7f3763577e && opam update
 RUN opam depext -ui mirage
 RUN mkdir -p /home/opam/src
 WORKDIR /home/opam/src
@@ -13,4 +13,4 @@ COPY --chown=opam:root unikernel/signer/ /home/opam/src
 RUN opam pin add ptt -ny git+https://github.com/dinosaure/ptt.git#$BRANCH
 RUN opam depext -ui ptt
 RUN opam config exec -- make depends
-RUN opam config exec -- mirage build
+RUN opam config exec -- make build

Dockerfile.spamfilter

@@ -1,6 +1,6 @@
 FROM ocaml/opam:ubuntu-20.04-ocaml-4.14
 RUN sudo ln -f /usr/bin/opam-2.1 /usr/bin/opam
-RUN cd ~/opam-repository && git pull origin master && git reset --hard cd449b28e1149a5bafa7f1c6262879ce509b7eea && opam update
+RUN cd ~/opam-repository && git pull origin master && git reset --hard 164c8ecdbe88cb6ee4c0b137997c2e7f3763577e && opam update
 RUN opam depext -ui mirage
 RUN mkdir -p /home/opam/src
 WORKDIR /home/opam/src
@@ -13,4 +13,4 @@ COPY --chown=opam:root unikernel/spamfilter/ /home/opam/src
 RUN opam pin add ptt -ny git+https://github.com/mirage/ptt.git#$BRANCH
 RUN opam depext -ui ptt
 RUN opam config exec -- make depends
-RUN opam config exec -- mirage build
+RUN opam config exec -- make build

Dockerfile.submission

@@ -1,6 +1,6 @@
 FROM ocaml/opam:ubuntu-20.04-ocaml-4.14
 RUN sudo ln -f /usr/bin/opam-2.1 /usr/bin/opam
-RUN cd ~/opam-repository && git pull origin master && git reset --hard cd449b28e1149a5bafa7f1c6262879ce509b7eea && opam update
+RUN cd ~/opam-repository && git pull origin master && git reset --hard 164c8ecdbe88cb6ee4c0b137997c2e7f3763577e && opam update
 RUN opam depext -ui mirage
 RUN mkdir -p /home/opam/src
 WORKDIR /home/opam/src
@@ -13,4 +13,4 @@ COPY --chown=opam:root unikernel/submission/ /home/opam/src
 RUN opam pin add ptt -ny git+https://github.com/dinosaure/ptt.git#$BRANCH
 RUN opam depext -ui ptt
 RUN opam config exec -- make depends
-RUN opam config exec -- mirage build
+RUN opam config exec -- make build

Dockerfile.verifier

@@ -1,6 +1,6 @@
 FROM ocaml/opam:ubuntu-20.04-ocaml-4.14
 RUN sudo ln -f /usr/bin/opam-2.1 /usr/bin/opam
-RUN cd ~/opam-repository && git pull origin master && git reset --hard cd449b28e1149a5bafa7f1c6262879ce509b7eea && opam update
+RUN cd ~/opam-repository && git pull origin master && git reset --hard 164c8ecdbe88cb6ee4c0b137997c2e7f3763577e && opam update
 RUN opam depext -ui mirage
 RUN mkdir -p /home/opam/src
 WORKDIR /home/opam/src
@@ -13,4 +13,4 @@ COPY --chown=opam:root unikernel/verifier/ /home/opam/src
 RUN opam pin add ptt -ny git+https://github.com/dinosaure/ptt.git#$BRANCH
 RUN opam depext -ui ptt
 RUN opam config exec -- make depends
-RUN opam config exec -- mirage build
+RUN opam config exec -- make build

bin/adduser.ml

@@ -16,11 +16,10 @@ let ssh_edn, ssh_protocol = Mimic.register ~name:"ssh" (module SSH)
 let unix_ctx_with_ssh () =
   Git_unix.ctx (Happy_eyeballs_lwt.create ()) >|= fun ctx ->
   let open Mimic in
-  let k0 scheme user path host port capabilities =
+  let k0 scheme user path host port mode =
     match scheme, Unix.gethostbyname host with
     | `SSH, {Unix.h_addr_list; _} when Array.length h_addr_list > 0 ->
-      Lwt.return_some
-        {SSH.user; path; host= h_addr_list.(0); port; capabilities}
+      Lwt.return_some {SSH.user; path; host= h_addr_list.(0); port; mode}
     | _ -> Lwt.return_none in
   ctx
   |> Mimic.fold Smart_git.git_transmission
@@ -121,7 +120,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 +131,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)
 

bin/dune

@@ -19,8 +19,8 @@
  (public_name ptt.adduser)
  (package ptt-bin)
  (modules adduser sSH)
- (libraries logs.cli fmt.tty fmt.cli ca-certs mirage-flow git-unix git-kv
-   mirage-clock-unix ptt.value cmdliner))
+ (libraries logs.cli logs.fmt fmt.tty fmt.cli ca-certs mirage-flow git-unix
+   git-kv mirage-clock-unix ptt.value cmdliner))
 
 (executable
  (name spf)

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]
 

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 =

bin/sSH.ml

@@ -17,16 +17,16 @@ type endpoint = {
   ; path: string
   ; host: Unix.inet_addr
   ; port: int
-  ; capabilities: [ `Wr | `Rd ]
+  ; mode: [ `Rd | `Wr ]
 }
 
 let pp_inet_addr ppf inet_addr =
   Fmt.string ppf (Unix.string_of_inet_addr inet_addr)
 
-let connect {user; path; host; port; capabilities} =
+let connect {user; path; host; port; mode} =
   let edn = Fmt.str "%s@%a" user pp_inet_addr host in
   let cmd =
-    match capabilities with
+    match mode with
     | `Rd -> Fmt.str {sh|git-upload-pack '%s'|sh} path
     | `Wr -> Fmt.str {sh|git-receive-pack '%s'|sh} path in
   let cmd = Fmt.str "ssh -p %d %s %a" port edn Fmt.(quote string) cmd in
@@ -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,9 @@ 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
+
+let shutdown t = function
+  | `read -> close_in t.ic; Lwt.return_unit
+  | `write -> close_out t.oc; Lwt.return_unit
+  | `read_write -> close t

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
@@ -60,7 +61,7 @@ let ns_update (ipaddr, port) ~dns_key stack ~domain spf =
       |> R.reword_error (R.msgf "%a" Dns_tsig.pp_s)
       |> Lwt.return
       >>? fun (data, mac) ->
-        DNS.send_tcp flow data
+        DNS.send_tcp flow (Cstruct.of_string data)
         >|= R.reword_error (fun _ ->
                 R.msgf "Impossible to send a DNS packet to %a:%d" Ipaddr.pp
                   ipaddr port)
@@ -71,7 +72,7 @@ let ns_update (ipaddr, port) ~dns_key stack ~domain spf =
                   ipaddr port)
         >>? fun data ->
         Dns_tsig.decode_and_verify (Ptime_clock.now ()) dns_key key_name ~mac
-          data
+          (Cstruct.to_string data)
         |> R.reword_error (R.msgf "%a" Dns_tsig.pp_e)
         |> Lwt.return
         >>? fun (packet', _tsig, _mac) ->

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 =