Merge pull request #40 from robur-coop/mc10

update to mirage-crypto 1.0 changes

.cirrus.yml

@@ -4,7 +4,7 @@ freebsd_instance:
 caldav_unikernel_task:
   pkg_install_script: pkg install -y ocaml-opam gmake bash
   ocaml_script: opam init -a --comp=4.14.2
-  mirage_script: eval `opam env` && opam install --confirm-level=unsafe-yes "mirage>=4.6.0"
+  mirage_script: eval `opam env` && opam install --confirm-level=unsafe-yes "mirage>=4.7.0"
   configure_script: eval `opam env` && cd mirage && mirage configure -t hvt
   depend_script: eval `opam env` && cd mirage && gmake depend
   copy_script: rm -rf mirage/duniverse/caldav/* && cp -R dune-project caldav.opam src ocaml-webmachine mirage/duniverse/caldav/

app/caldav_server.ml

@@ -116,7 +116,7 @@ let () =  Lwt_main.run (main ())
 
 
 open Lwt.Infix
-open OUnit
+open OUnit2
 open Cohttp
 open Cohttp_lwt_unix_test
 

app/dune

@@ -11,7 +11,7 @@
   cohttp
   cohttp-lwt-unix
   mirage-kv
-  oUnit
+  ounit2
   mirage-clock-unix
   tcpip
   tcpip.stack-socket

caldav.opam

@@ -24,27 +24,27 @@ depends: [
   "ocaml" {>= "4.08.0"}
   "dune" {>= "3.12"}
   "alcotest" {with-test & >= "0.8.5"}
-  "ounit" {with-test & >= "2.0.0"}
+  "ounit2" {with-test & >= "2.0.0"}
   "tcpip" {with-test & >= "3.7.0"}
   "mirage-clock-unix" {with-test & >= "2.0.0"}
   "mirage-kv-mem" {with-test & >= "2.0.0"}
   "fmt" {>= "0.8.7"}
   "mirage-kv" {>= "6.0.0"}
   "mirage-clock" {>= "2.0.0"}
-  "mirage-random" {>= "2.0.0" & < "4.0.0"}
   "ppx_deriving" {>= "4.3"}
   "lwt" {>= "4.0"}
   "ptime" {>= "0.8.5"}
   "cohttp" {>= "2.0.0"}
   "cohttp-lwt" {>= "2.0.0"}
   "cohttp-lwt-unix" {with-test & >= "2.0.0"}
-  "mirage-crypto"
-  "mirage-crypto-rng"
-  "mirage-crypto-rng-lwt" {with-test & >= "0.11.0"}
+  "digestif" {>= "1.2.0"}
+  "mirage-crypto-rng" {>= "1.0.0"}
+  "mirage-crypto-rng-mirage" {>= "1.0.0"}
+  "mirage-crypto-rng-lwt" {with-test & >= "1.0.0"}
   "base64" {>= "3.0.0"}
   "xmlm" {>= "1.3.0"}
   "tyxml" {>= "4.3.0"}
-  "icalendar" {>= "0.1.2"}
+  "icalendar" {>= "0.1.8"}
   "sexplib" {>= "v0.12.0"}
   "ppx_sexp_conv" {>= "v0.12.0"}
   "logs" {>= "0.6.3"}

mirage/config.ml

@@ -1,4 +1,4 @@
-(* mirage >= 4.6.0 & < 4.7.0 *)
+(* mirage >= 4.7.0 & < 4.8.0 *)
 open Mirage
 
 let net = generic_stackv4v6 default_network

mirage/unikernel.ml

@@ -61,7 +61,7 @@ module K = struct
             tofu $ hostname)
 end
 
-module Main (R : Mirage_random.S) (Clock: Mirage_clock.PCLOCK) (_ : sig end) (KEYS: Mirage_kv.RO) (S: Cohttp_mirage.Server.S) (Zap : Mirage_kv.RO) = struct
+module Main (R : Mirage_crypto_rng_mirage.S) (Clock: Mirage_clock.PCLOCK) (_ : sig end) (KEYS: Mirage_kv.RO) (S: Cohttp_mirage.Server.S) (Zap : Mirage_kv.RO) = struct
 
   let author = Lwt.new_key ()
   and user_agent = Lwt.new_key ()
@@ -88,13 +88,17 @@ module Main (R : Mirage_random.S) (Clock: Mirage_clock.PCLOCK) (_ : sig end) (KE
   let tls_init kv =
     Lwt.catch (fun () ->
         X509.certificate kv `Default >|= fun cert ->
-        Tls.Config.server ~certificates:(`Single cert) ())
+        match Tls.Config.server ~certificates:(`Single cert) () with
+        | Error `Msg msg ->
+          Logs.err (fun m -> m "Failed to construct TLS configuration: %s" msg);
+          exit Mirage_runtime.argument_error
+        | Ok tls -> tls)
       (fun e ->
          (match e with
           | Failure f ->
             Logs.err (fun m -> m "Could not find server.pem and server.key in the <working directory>/tls. %s" f)
           | e -> Logs.err (fun m -> m "Exception %s while reading certificates" (Printexc.to_string e)));
-         exit Functoria_runtime.argument_error)
+         exit Mirage_runtime.argument_error)
 
   (* Redirect to the same address, but in https. *)
   let redirect port request _body =
@@ -175,7 +179,7 @@ module Main (R : Mirage_random.S) (Clock: Mirage_clock.PCLOCK) (_ : sig end) (KE
     match arg.http_port, arg.https_port with
     | None, None ->
       Logs.err (fun m -> m "no port provided for neither HTTP nor HTTPS, exiting") ;
-      exit Functoria_runtime.argument_error
+      exit Mirage_runtime.argument_error
     | Some port, None ->
       let scheme, base_port =
         if arg.tls_proxy then "https", 443 else "http", port
@@ -186,15 +190,15 @@ module Main (R : Mirage_random.S) (Clock: Mirage_clock.PCLOCK) (_ : sig end) (KE
     | None, Some port ->
       (if arg.tls_proxy then begin
           Logs.err (fun m -> m "Both https port and TLS proxy chosen, please choose only one");
-          exit Functoria_runtime.argument_error
+          exit Mirage_runtime.argument_error
         end);
       let config = config @@ Caldav.Webdav_config.host ~scheme:"https" ~port ~hostname:arg.hostname () in
       init_store_for_runtime config >>=
       init_https port config
     | Some http_port, Some https_port ->
       (if arg.tls_proxy then begin
           Logs.err (fun m -> m "Both https port and TLS proxy chosen, please choose only one");
-          exit Functoria_runtime.argument_error
+          exit Mirage_runtime.argument_error
         end);
       Server_log.info (fun f -> f "redirecting on %d/HTTP to %d/HTTPS" http_port https_port);
       let config = config @@ Caldav.Webdav_config.host ~scheme:"https" ~port:https_port ~hostname:arg.hostname () in

src/dune

@@ -12,13 +12,13 @@
   xmlm
   tyxml
   icalendar
-  mirage-crypto
+  digestif
   mirage-crypto-rng
+  mirage-crypto-rng-mirage
   base64
   caldav.webmachine
   cohttp-lwt
   mirage-clock
-  mirage-random
   sexplib
   ohex
   metrics))

src/webdav_api.ml

@@ -34,9 +34,9 @@ sig
 
   val verify_auth_header : state -> Webdav_config.config -> string -> (string, [> `Msg of string | `Unknown_user of string * string ]) result Lwt.t
 
-  val make_user : ?props:(Webdav_xml.fqname * Properties.property) list -> state -> Ptime.t -> config -> name:string -> password:string -> salt:Cstruct.t ->
+  val make_user : ?props:(Webdav_xml.fqname * Properties.property) list -> state -> Ptime.t -> config -> name:string -> password:string -> salt:string ->
     (Uri.t, [> `Conflict | `Internal_server_error ]) result Lwt.t
-  val change_user_password : state -> config -> name:string -> password:string -> salt:Cstruct.t -> (unit, [> `Internal_server_error ]) result Lwt.t
+  val change_user_password : state -> config -> name:string -> password:string -> salt:string -> (unit, [> `Internal_server_error ]) result Lwt.t
   val delete_user : state -> config -> string -> (unit, [> `Internal_server_error | `Not_found | `Conflict ]) result Lwt.t
 
   val make_group : state -> Ptime.t -> config -> string -> string list -> (Uri.t, [> `Conflict | `Internal_server_error ]) result Lwt.t
@@ -48,7 +48,7 @@ sig
   val initialize_fs : state -> Ptime.t -> config -> unit Lwt.t
   val initialize_fs_for_apple_testsuite : state -> Ptime.t -> config -> unit Lwt.t
 
-  val generate_salt : unit -> Cstruct.t
+  val generate_salt : unit -> string
 
   val connect : state -> config -> string option -> state Lwt.t
 
@@ -57,7 +57,7 @@ end
 let src = Logs.Src.create "webdav.robur.io" ~doc:"webdav api logs"
 module Log = (val Logs.src_log src : Logs.LOG)
 
-module Make(R : Mirage_random.S)(Clock : Mirage_clock.PCLOCK)(Fs: Webdav_fs.S) = struct
+module Make(R : Mirage_crypto_rng_mirage.S)(Clock : Mirage_clock.PCLOCK)(Fs: Webdav_fs.S) = struct
   open Lwt.Infix
 
   type state = Fs.t
@@ -1053,10 +1053,10 @@ module Make(R : Mirage_random.S)(Clock : Mirage_clock.PCLOCK)(Fs: Webdav_fs.S) =
 
   (* moved from Caldav_server *)
 
-let base64_encode data = Base64.encode_string @@ Cstruct.to_string data
+let base64_encode data = Base64.encode_string data
 
 let hash_password password salt =
-  base64_encode @@ Mirage_crypto.Hash.SHA256.digest @@ Cstruct.of_string (salt ^ "-" ^ password)
+  base64_encode @@ Digestif.SHA256.(to_raw_string (digestv_string [ salt ; "-" ; password ]))
 
 let verify_auth_header fs config v =
   let basic = "Basic " in

src/webdav_api.mli

@@ -33,9 +33,9 @@ sig
 
   val verify_auth_header : state -> config -> string -> (string,  [> `Msg of string | `Unknown_user of string * string ]) result Lwt.t
 
-  val make_user : ?props:(Webdav_xml.fqname * Properties.property) list -> state -> Ptime.t -> config -> name:string -> password:string -> salt:Cstruct.t ->
+  val make_user : ?props:(Webdav_xml.fqname * Properties.property) list -> state -> Ptime.t -> config -> name:string -> password:string -> salt:string ->
     (Uri.t, [> `Conflict | `Internal_server_error ]) result Lwt.t
-  val change_user_password : state -> config -> name:string -> password:string -> salt:Cstruct.t -> (unit, [> `Internal_server_error ]) result Lwt.t
+  val change_user_password : state -> config -> name:string -> password:string -> salt:string -> (unit, [> `Internal_server_error ]) result Lwt.t
   val delete_user : state -> config -> string -> (unit, [> `Internal_server_error | `Not_found | `Conflict ]) result Lwt.t
 
   val make_group : state -> Ptime.t -> config -> string -> string list -> (Uri.t, [> `Conflict | `Internal_server_error ]) result Lwt.t
@@ -47,9 +47,9 @@ sig
   val initialize_fs : state -> Ptime.t -> config -> unit Lwt.t
   val initialize_fs_for_apple_testsuite : state -> Ptime.t -> config -> unit Lwt.t
 
-  val generate_salt : unit -> Cstruct.t
+  val generate_salt : unit -> string
 
   val connect : state -> config -> string option -> state Lwt.t
 end
 
-module Make(_ : Mirage_random.S)(_ : Mirage_clock.PCLOCK)(Fs: Webdav_fs.S) : S with type state = Fs.t
+module Make(_ : Mirage_crypto_rng_mirage.S)(_ : Mirage_clock.PCLOCK)(Fs: Webdav_fs.S) : S with type state = Fs.t

src/webdav_server.ml

@@ -108,7 +108,7 @@ module type Server = sig
     (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t
 end
 
-module Make (R : Mirage_random.S) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.S) (S: Server) = struct
+module Make (R : Mirage_crypto_rng_mirage.S) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.S) (S: Server) = struct
 
   module WmClock = struct
     let now () =

test/test.ml

@@ -1232,12 +1232,12 @@ let mkcol_success () =
         Properties.create_dir ~resourcetype acl now "Special Resource"
       in
       let properties = Properties.create_dir allow_all_acl now "home" in
-      Dav.make_user res_fs now config ~name:"testuser" ~password:"abc" ~salt:Cstruct.empty >>= fun _ ->
+      Dav.make_user res_fs now config ~name:"testuser" ~password:"abc" ~salt:"" >>= fun _ ->
       Fs.mkdir res_fs (`Dir ["home"]) properties >>= fun _ ->
       Fs.mkdir res_fs (`Dir [ "home" ; "special" ]) props >>= fun _ ->
       KV_mem.connect () >>= fun fs ->
       Fs.mkdir fs (`Dir ["home"]) properties >>= fun _ ->
-      Dav.make_user fs now config ~name:"testuser" ~password:"abc" ~salt:Cstruct.empty >>= fun _ ->
+      Dav.make_user fs now config ~name:"testuser" ~password:"abc" ~salt:"" >>= fun _ ->
       Dav.mkcol fs config ~path:"home/special/" ~user:"testuser" (`Other "MKCOL") now ~data:body >|= function
       | Error e -> (res_fs, Error e)
       | Ok () -> (res_fs, Ok fs))
@@ -1361,7 +1361,7 @@ let make_user () =
     let open Lwt.Infix in
     KV_mem.connect () >>= fun fs ->
     let now = Ptime.v (1, 0L) in
-    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:Cstruct.empty >>= function
+    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:"" >>= function
     | Error _ -> invalid_arg "expected make_user to succeed"
     | Ok uri ->
       let test_url = Uri.of_string "/principals/test/" in
@@ -1373,10 +1373,10 @@ let make_user_same_name () =
     let open Lwt.Infix in
     KV_mem.connect () >>= fun fs ->
     let now = Ptime.v (1, 0L) in
-    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:Cstruct.empty >>= function
+    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:"" >>= function
     | Error _ -> invalid_arg "expected make_user to succeed"
     | Ok _ ->
-      Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:Cstruct.empty >>= function
+      Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:"" >>= function
       | Error `Conflict -> Lwt.return_unit
       | Error _ -> invalid_arg "expected a conflict, got a different error"
       | Ok _ -> invalid_arg "expected a conflict, got ok")
@@ -1386,13 +1386,13 @@ let make_user_delete_make () =
     let open Lwt.Infix in
     KV_mem.connect () >>= fun fs ->
     let now = Ptime.v (1, 0L) in
-    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:Cstruct.empty >>= function
+    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:"" >>= function
     | Error _ -> invalid_arg "expected make_user to succeed"
     | Ok _ ->
       Dav.delete_user fs config "test" >>= function
       | Error _ -> invalid_arg "expected to succeed deleting a freshly created user"
       | Ok () ->
-        Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:Cstruct.empty >>= function
+        Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:"" >>= function
         | Error _ -> invalid_arg "expected creating a user to succeed"
         | Ok uri ->
           let test_url = Uri.of_string "/principals/test/" in
@@ -1465,7 +1465,7 @@ let make_group () =
     let open Lwt.Infix in
     KV_mem.connect () >>= fun fs ->
     let now = Ptime.v (1, 0L) in
-    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:Cstruct.empty >>= function
+    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:"" >>= function
     | Error _ -> invalid_arg "expected make_user to succeed"
     | Ok _ ->
       Dav.make_group fs now config "testgroup" ["test"] >>= function
@@ -1480,7 +1480,7 @@ let make_group_conflict () =
     let open Lwt.Infix in
     KV_mem.connect () >>= fun fs ->
     let now = Ptime.v (1, 0L) in
-    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:Cstruct.empty >>= function
+    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:"" >>= function
     | Error _ -> invalid_arg "expected make_user to succeed"
     | Ok _ ->
       Dav.make_group fs now config "test" [] >>= function
@@ -1513,10 +1513,10 @@ let replace_group_members_one () =
     let open Lwt.Infix in
     KV_mem.connect () >>= fun fs ->
     let now = Ptime.v (1, 0L) in
-    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:Cstruct.empty >>= function
+    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:"" >>= function
     | Error _ -> invalid_arg "expected make_user to succeed"
     | Ok _ ->
-      Dav.make_user fs now config ~name:"test2" ~password:"foo" ~salt:Cstruct.empty >>= function
+      Dav.make_user fs now config ~name:"test2" ~password:"foo" ~salt:"" >>= function
       | Error _ -> invalid_arg "expected make_user to succeed"
       | Ok _ ->
         Dav.make_group fs now config "testgroup" ["test"] >>= function
@@ -1531,7 +1531,7 @@ let replace_group_members_two () =
     let open Lwt.Infix in
     KV_mem.connect () >>= fun fs ->
     let now = Ptime.v (1, 0L) in
-    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:Cstruct.empty >>= function
+    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:"" >>= function
     | Error _ -> invalid_arg "expected make_user to succeed"
     | Ok _ ->
       Dav.make_group fs now config "testgroup" ["test"] >>= function
@@ -1566,7 +1566,7 @@ let make_group_and_enroll () =
     let open Lwt.Infix in
     KV_mem.connect () >>= fun fs ->
     let now = Ptime.v (1, 0L) in
-    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:Cstruct.empty >>= function
+    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:"" >>= function
     | Error _ -> invalid_arg "expected make_user to succeed"
     | Ok _ ->
       Dav.make_group fs now config "testgroup" [] >>= function
@@ -1606,7 +1606,7 @@ let make_group_and_resign () =
     let open Lwt.Infix in
     KV_mem.connect () >>= fun fs ->
     let now = Ptime.v (1, 0L) in
-    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:Cstruct.empty >>= function
+    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:"" >>= function
     | Error _ -> invalid_arg "expected make_user to succeed"
     | Ok _ ->
       Dav.make_group fs now config "testgroup" ["test"] >>= function
@@ -1623,7 +1623,7 @@ let make_group_and_resign_not_member () =
     let open Lwt.Infix in
     KV_mem.connect () >>= fun fs ->
     let now = Ptime.v (1, 0L) in
-    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:Cstruct.empty >>= function
+    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:"" >>= function
     | Error _ -> invalid_arg "expected make_user to succeed"
     | Ok _ ->
       Dav.make_group fs now config "testgroup" [] >>= function
@@ -1640,7 +1640,7 @@ let make_group_and_resign_not_existing_group () =
     let open Lwt.Infix in
     KV_mem.connect () >>= fun fs ->
     let now = Ptime.v (1, 0L) in
-    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:Cstruct.empty >>= function
+    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:"" >>= function
     | Error _ -> invalid_arg "expected make_user to succeed"
     | Ok _ ->
       Dav.resign fs config ~member:"test" ~group:"testgroup" >>= function
@@ -1672,7 +1672,7 @@ let make_group_and_resign_not_a_group () =
     let open Lwt.Infix in
     KV_mem.connect () >>= fun fs ->
     let now = Ptime.v (1, 0L) in
-    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:Cstruct.empty >>= function
+    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:"" >>= function
     | Error _ -> invalid_arg "expected make_user to succeed"
     | Ok _ ->
       Dav.resign fs config ~member:"test" ~group:"test" >>= function
@@ -1684,7 +1684,7 @@ let delete_group_fine () =
     let open Lwt.Infix in
     KV_mem.connect () >>= fun fs ->
     let now = Ptime.v (1, 0L) in
-    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:Cstruct.empty >>= function
+    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:"" >>= function
     | Error _ -> invalid_arg "expected make_user to succeed"
     | Ok _ ->
       Dav.make_group fs now config "testgroup" ["test"] >>= function
@@ -1708,7 +1708,7 @@ let delete_group_is_a_user () =
     let open Lwt.Infix in
     KV_mem.connect () >>= fun fs ->
     let now = Ptime.v (1, 0L) in
-    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:Cstruct.empty >>= function
+    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:"" >>= function
     | Error _ -> invalid_arg "expected make_user to succeed"
     | Ok _ ->
       Dav.delete_group fs config "test" >>= function
@@ -1720,7 +1720,7 @@ let write_calendar_event () =
     let open Lwt.Infix in
     KV_mem.connect () >>= fun fs ->
     let now = Ptime.v (1, 0L) in
-    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:Cstruct.empty >>= function
+    Dav.make_user fs now config ~name:"test" ~password:"foo" ~salt:"" >>= function
     | Error _ -> invalid_arg "expected make_user to succeed"
     | Ok _ ->
       let data = {|BEGIN:VCALENDAR
@@ -2271,7 +2271,7 @@ let default_group () =
     let initial_props = [ ((Xml.robur_ns, "default_groups"), robur_principal) ] in
     let dir_props = Properties.create_dir ~initial_props [] creation_time "Special Resource" in
     Fs.write_property_map fs (`Dir [config.principals]) dir_props >>= fun _ ->
-    Dav.make_user fs creation_time config ~name:"user1" ~password:"foo" ~salt:Cstruct.empty >>= function
+    Dav.make_user fs creation_time config ~name:"user1" ~password:"foo" ~salt:"" >>= function
     | Error _ -> invalid_arg "user already exists"
     | Ok resource ->
       (* check that resource is user1*)
@@ -2317,7 +2317,7 @@ let proppatch_acl_existing () =
     KV_mem.connect () >>= fun fs ->
     let properties = Properties.create_dir allow_all_acl now "home" in
     Fs.mkdir fs (`Dir ["home"]) properties >>= fun _ ->
-    Dav.make_user fs now config ~name:"testuser" ~password:"abc" ~salt:Cstruct.empty >>= fun _ ->
+    Dav.make_user fs now config ~name:"testuser" ~password:"abc" ~salt:"" >>= fun _ ->
     Dav.proppatch fs config ~path:"home" ~user:"testuser" ~data:body >|= function
     | Error _ -> invalid_arg "expected proppatch to succeed (acl existing principal)"
     | Ok _ -> ())