From 8407d13b1501ca99104cc7dd30f2301fa66cee51 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 20 Dec 2017 23:06:51 +0100 Subject: [PATCH] port to new asn + x509 --- README.md | 10 +++---- _tags | 4 +-- app/vmmd.ml | 2 +- opam | 15 ++++++++-- provision/vmm_provision.ml | 35 +++++++++------------- provision/vmm_revoke.ml | 2 +- src/vmm_asn.ml | 61 +++++++++++++++++++------------------- src/vmm_engine.ml | 2 +- 8 files changed, 65 insertions(+), 66 deletions(-) diff --git a/README.md b/README.md index e9680cb..04c8a8b 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# Managing virtual machines +# Albatross: Managing virtual machines A set of binaries to manage, provision, and deploy virtual machine images. This is very much work in progress, don't expect anything stable. @@ -11,11 +11,9 @@ the (blocking!) Bos library for operating system commands. A thin layer of Lwt is used on top to (more gracefully) handle multiple connection, and to have a watching thread (in `waitpid(2)`) for every virtual machine started by vmmd. -It requires some pinned packages: -- `asn1-combinators https://github.com/hannesm/ocaml-asn1-combinators.git#enum` -- `x509 https://github.com/hannesm/ocaml-x509.git#crl` -- `tls https://github.com/hannesm/ocaml-tls.git#changes` -- on FreeBSD, `solo5-kernel-ukvm https://github.com/solo5/solo5.git` +To install Albatross, run `opam pin add albatross +https://github.com/hannesm/albatross`. On FreeBSD, `opam pin add +solo5-kernel-ukvm --dev` is needed as well. The following elaborates on how to get the software up and running, following by provisioning and deploying some unikernels. There is a *server* (`SRV`) diff --git a/_tags b/_tags index 62d1bab..0c98ee7 100644 --- a/_tags +++ b/_tags @@ -1,9 +1,9 @@ true : bin_annot, safe_string, principal, color(always) true : warn(+A-44) -true : package(rresult logs ipaddr x509 tls bos hex ptime ptime.clock.os astring duration) +true : package(rresult logs ipaddr x509 tls bos hex ptime ptime.clock.os astring duration cstruct) "src" : include -: package(cstruct.ppx) +: package(ppx_cstruct) : package(asn1-combinators) : package(lwt) : package(lwt tls.lwt) diff --git a/app/vmmd.ml b/app/vmmd.ml index 3ffdc29..f048071 100644 --- a/app/vmmd.ml +++ b/app/vmmd.ml @@ -29,7 +29,7 @@ let process state xs = let handle ca state t = Logs.debug (fun m -> m "connection from %a" pp_sockaddr t) ; let authenticator = - let time = Unix.gettimeofday () in + let time = Ptime_clock.now () in X509.Authenticator.chain_of_trust ~time ~crls:!state.Vmm_engine.crls [ca] in Lwt.catch diff --git a/opam b/opam index 21461c6..22ad851 100644 --- a/opam +++ b/opam @@ -14,9 +14,18 @@ depends: [ "ipaddr" {>= "2.2.0"} "hex" "cstruct" - "ppx_cstruct" {build} - "logs" "rresult" "bos" "ptime" "cmdliner" "fmt" "astring" - "x509" "tls" "nocrypto" "asn1-combinators" + "ppx_cstruct" {build & >= "3.0.0"} + "logs" + "rresult" + "bos" + "ptime" + "cmdliner" + "fmt" + "astring" + "x509" {>= "0.6.0"} + "tls" {>= "0.9.0"} + "nocrypto" + "asn1-combinators" {>= "0.2.0"} "duration" ] diff --git a/provision/vmm_provision.ml b/provision/vmm_provision.ml index 01abb19..221bd1a 100644 --- a/provision/vmm_provision.ml +++ b/provision/vmm_provision.ml @@ -16,20 +16,11 @@ let d_exts ?len () = [ (true, (`Basic_constraints (true, len))) ; (true, (`Key_usage [ `Key_cert_sign ; `CRL_sign ; `Digital_signature ; `Content_commitment ])) ] -let asn1_of_unix ts = - let tm = Unix.gmtime ts in - { Asn.Time.date = Unix.(tm.tm_year + 1900, (tm.tm_mon + 1), tm.tm_mday) ; - time = Unix.(tm.tm_hour, tm.tm_min, tm.tm_sec, 0.) ; - tz = None } - let timestamps validity = - let valid = Duration.to_f validity - and now = Unix.time () - in - let start = asn1_of_unix now - and expire = asn1_of_unix (now +. valid) - in - (start, expire) + let now = Ptime_clock.now () in + match Ptime.add_span now (Ptime.Span.of_int_s (Duration.to_sec validity)) with + | None -> Error (`Msg "span too big - reached end of ptime") + | Some exp -> Ok (now, exp) let rec safe f arg = try Ok (f arg) with @@ -79,14 +70,16 @@ let sign ?dbname ?certname extensions issuer key csr delta = Logs.info (fun m -> m "reusing serial %s" (Z.to_string serial)) ; Ok (Some serial) | Error _ -> Ok None) >>= fun serial -> - let valid_from, valid_until = timestamps delta in - (match dbname with - | None -> Ok extensions (* evil hack to avoid issuer + public key for CA cert *) - | Some _ -> - match key with - | `RSA priv -> - let capub = `RSA (Nocrypto.Rsa.pub_of_priv priv) in - Ok (extensions @ key_ids (X509.CA.info csr).X509.CA.public_key capub)) >>= fun extensions -> + timestamps delta >>= fun (valid_from, valid_until) -> + let extensions = + match dbname with + | None -> extensions (* evil hack to avoid issuer + public key for CA cert *) + | Some _ -> + match key with + | `RSA priv -> + 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! *) diff --git a/provision/vmm_revoke.ml b/provision/vmm_revoke.ml index 11d3f09..5a04e44 100644 --- a/provision/vmm_revoke.ml +++ b/provision/vmm_revoke.ml @@ -22,7 +22,7 @@ let jump _ db cacert cakey crl cn serial = Bos.OS.File.read (Fpath.v cacert) >>= fun cacert -> let cacert = X509.Encoding.Pem.Certificate.of_pem_cstruct1 (Cstruct.of_string cacert) in - let this_update = asn1_of_unix (Unix.time ()) in + let this_update = Ptime_clock.now () in let revoked = { X509.CRL.serial ; date = this_update ; extensions = [] } in let crl = Fpath.v crl in let issuer = X509.subject cacert in diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index 64c968b..ae94c15 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -37,7 +37,7 @@ module Oid = struct end let perms : permission list Asn.t = - Asn.bit_string_flags [ + Asn.S.bit_string_flags [ 0, `All ; 1, `Info ; 2, `Image ; @@ -48,28 +48,29 @@ let perms : permission list Asn.t = 7, `Crl ; ] +open Rresult.R.Infix + +let guard p err = if p then Ok () else Error err + let decode_strict codec cs = - try - let (a, cs) = Asn.decode_exn codec cs in - if Cstruct.len cs = 0 then - Ok a - else - Error (`Msg "trailing bytes") - with - | e -> Error (`Msg (Printexc.to_string e)) + match Asn.decode codec cs with + | Ok (a, cs) -> + guard (Cstruct.len cs = 0) (`Msg "trailing bytes") >>= fun () -> + Ok a + | Error (`Parse msg) -> Error (`Msg msg) let projections_of asn = let c = Asn.codec Asn.der asn in (decode_strict c, Asn.encode c) -let int_of_cstruct, int_to_cstruct = projections_of Asn.int -let ints_of_cstruct, ints_to_cstruct = projections_of Asn.(sequence_of int) +let int_of_cstruct, int_to_cstruct = projections_of Asn.S.int +let ints_of_cstruct, ints_to_cstruct = projections_of Asn.S.(sequence_of int) let ipv4 = let f cs = Ipaddr.V4.of_bytes_exn (Cstruct.to_string cs) and g ip = Cstruct.of_string (Ipaddr.V4.to_bytes ip) in - Asn.map f g Asn.octet_string + Asn.S.map f g Asn.S.octet_string let bridge = let f = function @@ -79,23 +80,23 @@ let bridge = | `Internal nam -> `C1 nam | `External (nam, s, e, r, n) -> `C2 (nam, s, e, r, n) in - Asn.map f g @@ - Asn.(choice2 - (explicit 0 utf8_string) - (explicit 1 (sequence5 - (required ~label:"name" utf8_string) - (required ~label:"start" ipv4) - (required ~label:"end" ipv4) - (required ~label:"router" ipv4) - (required ~label:"netmask" int)))) + Asn.S.map f g @@ + Asn.S.(choice2 + (explicit 0 utf8_string) + (explicit 1 (sequence5 + (required ~label:"name" utf8_string) + (required ~label:"start" ipv4) + (required ~label:"end" ipv4) + (required ~label:"router" ipv4) + (required ~label:"netmask" int)))) let bridges_of_cstruct, bridges_to_cstruct = - projections_of (Asn.sequence_of bridge) + projections_of (Asn.S.sequence_of bridge) let strings_of_cstruct, strings_to_cstruct = - projections_of Asn.(sequence_of utf8_string) + projections_of Asn.S.(sequence_of utf8_string) -let string_of_cstruct, string_to_cstruct = projections_of Asn.utf8_string +let string_of_cstruct, string_to_cstruct = projections_of Asn.S.utf8_string let image = let f = function @@ -105,20 +106,18 @@ let image = | `Ukvm_amd64, x -> `C1 x | `Ukvm_arm64, x -> `C2 x in - Asn.map f g @@ - Asn.(choice2 - (explicit 0 octet_string) - (explicit 1 octet_string)) + Asn.S.map f g @@ + Asn.S.(choice2 + (explicit 0 octet_string) + (explicit 1 octet_string)) let image_of_cstruct, image_to_cstruct = projections_of image let permissions_of_cstruct, permissions_to_cstruct = projections_of perms -open Rresult.R.Infix - let req label cert oid f = match X509.Extension.unsupported cert oid with - | None -> R.error_msgf "OID %s not present (%s)" label (Asn.OID.to_string oid) + | None -> R.error_msgf "OID %s not present (%a)" label Asn.OID.pp oid | Some (_, data) -> f data let opt cert oid f = diff --git a/src/vmm_engine.ml b/src/vmm_engine.ml index cb7eb84..169dc08 100644 --- a/src/vmm_engine.ml +++ b/src/vmm_engine.ml @@ -326,7 +326,7 @@ let handle_revocation t s leaf chain ca prefix = | subca::_ -> subca | [] -> ca in - let time = Ptime.to_float_s (Ptime_clock.now ()) in + let time = Ptime_clock.now () in (if X509.CRL.verify crl ~time issuer then Ok () else Error (`Msg "couldn't verify CRL")) >>= fun () -> (* the this_update must be > now, next_update < now, this_update > .this_update, number > .number *) (* TODO: can we have something better for uniqueness of CRL? *)