minor tweaks
This commit is contained in:
Hannes Mehnert
parent
a08f35ee5e
commit
d6c87bacde
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 *)
|
||||
|
|
|
|||
232
src/vmm_core.mli
232
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 =
|
||||
|
|
|
|||
Loading…
Reference in New Issue