minor tweaks

provision/vmm_provision.ml

@@ -57,19 +57,6 @@ let sign ?dbname ?certname extensions issuer key csr delta =
      match nam with
      | `CN name -> Ok name
      | _ -> Error (`Msg "cannot happen")) >>= fun certname ->
-  (match dbname with
-   | None -> Ok None
-   | Some dbname ->
-     Bos.OS.File.exists dbname >>= function
-     | false -> Ok None
-     | true ->
-       Bos.OS.File.read_lines dbname >>= fun content ->
-       Vmm_core.parse_db content >>= fun db ->
-       match Vmm_core.find_name db certname with
-       | Ok serial ->
-         Logs.info (fun m -> m "reusing serial %s" (Z.to_string serial)) ;
-         Ok (Some serial)
-       | Error _ -> Ok None) >>= fun serial ->
   timestamps delta >>= fun (valid_from, valid_until) ->
   let extensions =
     match dbname with
@@ -80,11 +67,10 @@ let sign ?dbname ?certname extensions issuer key csr delta =
         let capub = `RSA (Nocrypto.Rsa.pub_of_priv priv) in
         extensions @ key_ids (X509.CA.info csr).X509.CA.public_key capub
   in
-  let cert = X509.CA.sign csr ?serial ~valid_from ~valid_until ~extensions key issuer in
+  let cert = X509.CA.sign csr ~valid_from ~valid_until ~extensions key issuer in
-  (match serial, dbname with
+  (match dbname with
-   | Some _, _ -> Ok () (* already in DB! *)
+   | None -> Ok () (* no DB! *)
-   | _, None -> Ok () (* no DB! *)
+   | Some dbname ->
-   | None, Some dbname ->
      append dbname (Printf.sprintf "%s %s\n" (Z.to_string (X509.serial cert)) certname)) >>= fun () ->
   let enc = X509.Encoding.Pem.Certificate.to_pem_cstruct1 cert in
   Bos.OS.File.write Fpath.(v certname + "pem") (Cstruct.to_string enc)

provision/vmm_revoke.ml

@@ -6,6 +6,26 @@ open Astring
 
 open Rresult.R.Infix
 
+
+let parse_db lines =
+  List.fold_left (fun acc s ->
+      acc >>= fun datas ->
+      match String.cut ~sep:" " s with
+      | None -> Rresult.R.error_msgf "unable to parse entry %s" s
+      | Some (a, b) ->
+        (try Ok (Z.of_string a) with Invalid_argument x -> Error (`Msg x)) >>= fun s ->
+        Ok ((s, b) :: datas))
+    (Ok []) lines
+
+let find_in_db label db tst =
+  try Ok (List.find tst db)
+  with Not_found -> Rresult.R.error_msgf "couldn't find %s in database" label
+
+let find_name db name =
+  find_in_db name db (fun (_, n) -> String.equal n name) >>= fun (serial, _) ->
+  Ok serial
+
+
 let jump _ db cacert cakey crl cn serial =
   Nocrypto_entropy_unix.initialize () ;
   match
@@ -14,8 +34,8 @@ let jump _ db cacert cakey crl cn serial =
        (try Ok (Z.of_string y) with Invalid_argument x -> Error (`Msg x))
      | x, y when y = "" ->
        Bos.OS.File.read_lines (Fpath.v db) >>= fun entries ->
-       Vmm_core.parse_db entries >>= fun db ->
+       parse_db entries >>= fun db ->
-       Vmm_core.find_name db x
+       find_name db x
      | _ -> Error (`Msg "please provide either common name or serial!")) >>= fun serial ->
     Bos.OS.File.read (Fpath.v cakey) >>= fun pk ->
     let cakey = X509.Encoding.Pem.Private_key.of_pem_cstruct1 (Cstruct.of_string pk) in

src/vmm_core.ml

@@ -229,35 +229,6 @@ let id cert = identifier (X509.serial cert)
 
 let name cert = X509.common_name_to_string cert
 
-let parse_db lines =
-  List.fold_left (fun acc s ->
-      acc >>= fun datas ->
-      match String.cut ~sep:" " s with
-      | None -> Rresult.R.error_msgf "unable to parse entry %s" s
-      | Some (a, b) ->
-        (try Ok (Z.of_string a) with Invalid_argument x -> Error (`Msg x)) >>= fun s ->
-        Ok ((s, b) :: datas))
-    (Ok []) lines
-
-let find_in_db label db tst =
-  try Ok (List.find tst db)
-  with Not_found -> Rresult.R.error_msgf "couldn't find %s in database" label
-
-let find_name db name =
-  find_in_db name db (fun (_, n) -> String.equal n name) >>= fun (serial, _) ->
-  Ok serial
-
-let translate_serial db serial =
-  let tst (s, _) = String.equal serial (identifier s) in
-  match find_in_db "" db tst with
-  | Ok (_, n) -> n
-  | Error _ -> serial
-
-let translate_name db name =
-  match find_name db name with
-  | Ok serial -> identifier serial
-  | Error _ -> name
-
 (* this separates the leaf and top-level certificate from the chain,
    and also reverses the intermediates (to be (leaf, CA -> subCA -> subCA')
    in which subCA' signed leaf *)

src/vmm_core.mli

@@ -4,126 +4,20 @@ val socket_path : [< `Console | `Log | `Stats | `Vmmd ] -> string
 val pp_socket :
   Format.formatter -> [< `Console | `Log | `Stats | `Vmmd ] -> unit
 module I : sig type t = int val compare : int -> int -> int end
-module IS :
+
-  sig
+module IS : sig
-    type elt = I.t
+  include Set.S with type elt = I.t
-    type t = Set.Make(I).t
+end
-    val empty : t
+val pp_is : IS.t Fmt.t
-    val is_empty : t -> bool
+
-    val mem : elt -> t -> bool
+module IM : sig
-    val add : elt -> t -> t
+  include Map.S with type key = I.t
-    val singleton : elt -> t
+end
-    val remove : elt -> t -> t
+
-    val union : t -> t -> t
+module IM64 : sig
-    val inter : t -> t -> t
+  include Map.S with type key = Int64.t
-    val diff : t -> t -> t
+end
-    val compare : t -> t -> int
+
-    val equal : t -> t -> bool
-    val subset : t -> t -> bool
-    val iter : (elt -> unit) -> t -> unit
-    val map : (elt -> elt) -> t -> t
-    val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
-    val for_all : (elt -> bool) -> t -> bool
-    val exists : (elt -> bool) -> t -> bool
-    val filter : (elt -> bool) -> t -> t
-    val partition : (elt -> bool) -> t -> t * t
-    val cardinal : t -> int
-    val elements : t -> elt list
-    val min_elt : t -> elt
-    val min_elt_opt : t -> elt option
-    val max_elt : t -> elt
-    val max_elt_opt : t -> elt option
-    val choose : t -> elt
-    val choose_opt : t -> elt option
-    val split : elt -> t -> t * bool * t
-    val find : elt -> t -> elt
-    val find_opt : elt -> t -> elt option
-    val find_first : (elt -> bool) -> t -> elt
-    val find_first_opt : (elt -> bool) -> t -> elt option
-    val find_last : (elt -> bool) -> t -> elt
-    val find_last_opt : (elt -> bool) -> t -> elt option
-    val of_list : elt list -> t
-  end
-module IM :
-  sig
-    type key = I.t
-    type 'a t = 'a Map.Make(I).t
-    val empty : 'a t
-    val is_empty : 'a t -> bool
-    val mem : key -> 'a t -> bool
-    val add : key -> 'a -> 'a t -> 'a t
-    val update : key -> ('a option -> 'a option) -> 'a t -> 'a t
-    val singleton : key -> 'a -> 'a t
-    val remove : key -> 'a t -> 'a t
-    val merge :
-      (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
-    val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t
-    val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
-    val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
-    val iter : (key -> 'a -> unit) -> 'a t -> unit
-    val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
-    val for_all : (key -> 'a -> bool) -> 'a t -> bool
-    val exists : (key -> 'a -> bool) -> 'a t -> bool
-    val filter : (key -> 'a -> bool) -> 'a t -> 'a t
-    val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
-    val cardinal : 'a t -> int
-    val bindings : 'a t -> (key * 'a) list
-    val min_binding : 'a t -> key * 'a
-    val min_binding_opt : 'a t -> (key * 'a) option
-    val max_binding : 'a t -> key * 'a
-    val max_binding_opt : 'a t -> (key * 'a) option
-    val choose : 'a t -> key * 'a
-    val choose_opt : 'a t -> (key * 'a) option
-    val split : key -> 'a t -> 'a t * 'a option * 'a t
-    val find : key -> 'a t -> 'a
-    val find_opt : key -> 'a t -> 'a option
-    val find_first : (key -> bool) -> 'a t -> key * 'a
-    val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option
-    val find_last : (key -> bool) -> 'a t -> key * 'a
-    val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option
-    val map : ('a -> 'b) -> 'a t -> 'b t
-    val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
-  end
-module IM64 :
-  sig
-    type key = Int64.t
-    type 'a t = 'a Map.Make(Int64).t
-    val empty : 'a t
-    val is_empty : 'a t -> bool
-    val mem : key -> 'a t -> bool
-    val add : key -> 'a -> 'a t -> 'a t
-    val update : key -> ('a option -> 'a option) -> 'a t -> 'a t
-    val singleton : key -> 'a -> 'a t
-    val remove : key -> 'a t -> 'a t
-    val merge :
-      (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
-    val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t
-    val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
-    val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
-    val iter : (key -> 'a -> unit) -> 'a t -> unit
-    val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
-    val for_all : (key -> 'a -> bool) -> 'a t -> bool
-    val exists : (key -> 'a -> bool) -> 'a t -> bool
-    val filter : (key -> 'a -> bool) -> 'a t -> 'a t
-    val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
-    val cardinal : 'a t -> int
-    val bindings : 'a t -> (key * 'a) list
-    val min_binding : 'a t -> key * 'a
-    val min_binding_opt : 'a t -> (key * 'a) option
-    val max_binding : 'a t -> key * 'a
-    val max_binding_opt : 'a t -> (key * 'a) option
-    val choose : 'a t -> key * 'a
-    val choose_opt : 'a t -> (key * 'a) option
-    val split : key -> 'a t -> 'a t * 'a option * 'a t
-    val find : key -> 'a t -> 'a
-    val find_opt : key -> 'a t -> 'a option
-    val find_first : (key -> bool) -> 'a t -> key * 'a
-    val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option
-    val find_last : (key -> bool) -> 'a t -> key * 'a
-    val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option
-    val map : ('a -> 'b) -> 'a t -> 'b t
-    val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
-  end
 type command =
     [ `Console
     | `Create_block
@@ -135,56 +29,28 @@ type command =
     | `Info
     | `Log
     | `Statistics ]
-val pp_command :
+val pp_command : command Fmt.t
-  Format.formatter ->
+
-  [< `Console
+val command_of_string : string -> command option
-   | `Create_block
+
-   | `Create_vm
-   | `Crl
-   | `Destroy_block
-   | `Destroy_vm
-   | `Force_create_vm
-   | `Info
-   | `Log
-   | `Statistics ] ->
-  unit
-val command_of_string :
-  string ->
-  [> `Console
-   | `Create_block
-   | `Create_vm
-   | `Crl
-   | `Destroy_block
-   | `Destroy_vm
-   | `Force_create_vm
-   | `Info
-   | `Log
-   | `Statistics ]
-  option
 type vmtype = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ]
-val vmtype_to_int :
+val vmtype_to_int : vmtype -> int
-  [< `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] -> int
+val int_to_vmtype : int -> vmtype option
-val int_to_vmtype :
+val pp_vmtype : vmtype Fmt.t
-  int -> [> `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] option
+
-val pp_vmtype :
-  Format.formatter ->
-  [< `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] -> unit
 type id = string list
 val string_of_id : string list -> string
 val id_of_string : string -> string list
 val drop_super : super:string list -> sub:string list -> string list option
 val is_sub_id : super:string list -> sub:string list -> bool
 val domain : 'a list -> 'a list
-val pp_id : Format.formatter -> string list -> unit
+val pp_id : id Fmt.t
-val pp_is : Format.formatter -> IS.t -> unit
+
 type bridge =
     [ `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int
     | `Internal of string ]
-val pp_bridge :
+val pp_bridge : bridge Fmt.t
-  Format.formatter ->
+
-  [< `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int
-   | `Internal of string ] ->
-  unit
 type policy = {
   vms : int;
   cpuids : IS.t;
@@ -192,17 +58,14 @@ type policy = {
   block : int option;
   bridges : bridge Astring.String.Map.t;
 }
-val pp_policy : Format.formatter -> policy -> unit
+val pp_policy : policy Fmt.t
-val sub_bridges :
+
-  [> `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * 'a
+val sub_bridges : bridge Astring.String.map -> bridge Astring.String.map -> bool
-   | `Internal of string ]
+
-  Astring.String.map ->
-  [> `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * 'a
-   | `Internal of string ]
-  Astring.String.map -> bool
 val sub_block : 'a option -> 'a option -> bool
 val sub_cpu : IS.t -> IS.t -> bool
 val is_sub : super:policy -> sub:policy -> bool
+
 type vm_config = {
   cpuid : int;
   requested_memory : int;
@@ -211,14 +74,17 @@ type vm_config = {
   vmimage : vmtype * Cstruct.t;
   argv : string list option;
 }
-val pp_image :
+
-  Format.formatter ->
+val pp_image : (vmtype * Cstruct.t) Fmt.t
-  [< `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] * Cstruct.t -> unit
+
-val pp_vm_config : Format.formatter -> vm_config -> unit
+val pp_vm_config : vm_config Fmt.t
-val good_bridge : string list -> 'a Astring.String.map -> bool
+val good_bridge : id -> 'a Astring.String.map -> bool
+
 val vm_matches_res : policy -> vm_config -> bool
+
 val check_policies :
   vm_config -> policy list -> (unit, [> `Msg of string ]) Result.result
+
 type vm = {
   config : vm_config;
   cmd : Bos.Cmd.t;
@@ -226,21 +92,16 @@ type vm = {
   taps : string list;
   stdout : Unix.file_descr;
 }
-val pp_vm : Format.formatter -> vm -> unit
+
+val pp_vm : vm Fmt.t
 val translate_tap : vm -> string -> string option
+
 val identifier : Nocrypto.Numeric.Z.t -> string
 val id : X509.t -> string
 val name : X509.t -> string
-val parse_db :
+
-  string list -> ((Z.t * string) list, [> Rresult.R.msg ]) Result.result
-val find_in_db :
-  string -> 'a list -> ('a -> bool) -> ('a, [> Rresult.R.msg ]) Result.result
-val find_name :
-  ('a * string) list -> string -> ('a, [> Rresult.R.msg ]) Result.result
-val translate_serial :
-  (Nocrypto.Numeric.Z.t * string) list -> string -> string
-val translate_name : (Nocrypto.Numeric.Z.t * string) list -> string -> string
 val separate_chain : 'a list -> ('a * 'a list, [> `Msg of string ]) result
+
 type rusage = {
   utime : int64 * int;
   stime : int64 * int;
@@ -259,7 +120,7 @@ type rusage = {
   nvcsw : int64;
   nivcsw : int64;
 }
-val pp_rusage : Format.formatter -> rusage -> unit
+val pp_rusage : rusage Fmt.t
 val pp_vmm : (string * int64) list Fmt.t
 
 type ifdata = {
@@ -282,7 +143,8 @@ type ifdata = {
   input_dropped : int64;
   output_dropped : int64;
 }
-val pp_ifdata : Format.formatter -> ifdata -> unit
+val pp_ifdata : ifdata Fmt.t
+
 module Log :
   sig
     type event =