diff --git a/provision/vmm_provision.ml b/provision/vmm_provision.ml index 0103eda..b8a2e98 100644 --- a/provision/vmm_provision.ml +++ b/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 - (match serial, dbname with - | Some _, _ -> Ok () (* already in DB! *) - | _, None -> Ok () (* no DB! *) - | None, Some dbname -> + let cert = X509.CA.sign csr ~valid_from ~valid_until ~extensions key issuer in + (match dbname with + | None -> Ok () (* no DB! *) + | 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) diff --git a/provision/vmm_revoke.ml b/provision/vmm_revoke.ml index 66239b6..84a8e78 100644 --- a/provision/vmm_revoke.ml +++ b/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 -> - Vmm_core.find_name db x + parse_db entries >>= fun db -> + 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 diff --git a/src/vmm_core.ml b/src/vmm_core.ml index cc03fc6..f27a928 100644 --- a/src/vmm_core.ml +++ b/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 *) diff --git a/src/vmm_core.mli b/src/vmm_core.mli index 979605b..fa9c71c 100644 --- a/src/vmm_core.mli +++ b/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 - type elt = I.t - type t = Set.Make(I).t - val empty : t - val is_empty : t -> bool - val mem : elt -> t -> bool - val add : elt -> t -> t - val singleton : elt -> t - val remove : elt -> t -> t - val union : t -> t -> t - val inter : t -> t -> t - val diff : t -> t -> t - 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 + +module IS : sig + include Set.S with type elt = I.t +end +val pp_is : IS.t Fmt.t + +module IM : sig + include Map.S with type key = I.t +end + +module IM64 : sig + include Map.S with type key = Int64.t +end + type command = [ `Console | `Create_block @@ -135,56 +29,28 @@ type command = | `Info | `Log | `Statistics ] -val pp_command : - Format.formatter -> - [< `Console - | `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 +val pp_command : command Fmt.t + +val command_of_string : string -> command option + type vmtype = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] -val vmtype_to_int : - [< `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] -> int -val int_to_vmtype : - int -> [> `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] option -val pp_vmtype : - Format.formatter -> - [< `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] -> unit +val vmtype_to_int : vmtype -> int +val int_to_vmtype : int -> vmtype option +val pp_vmtype : vmtype Fmt.t + 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_is : Format.formatter -> IS.t -> unit +val pp_id : id Fmt.t + type bridge = [ `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int | `Internal of string ] -val pp_bridge : - Format.formatter -> - [< `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int - | `Internal of string ] -> - unit +val pp_bridge : bridge Fmt.t + 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 sub_bridges : - [> `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * 'a - | `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 pp_policy : policy Fmt.t + +val sub_bridges : bridge Astring.String.map -> bridge 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 -> - [< `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] * Cstruct.t -> unit -val pp_vm_config : Format.formatter -> vm_config -> unit -val good_bridge : string list -> 'a Astring.String.map -> bool + +val pp_image : (vmtype * Cstruct.t) Fmt.t + +val pp_vm_config : vm_config Fmt.t +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 =