port to new asn + x509

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:
+To install Albatross, run `opam pin add albatross
-- `asn1-combinators https://github.com/hannesm/ocaml-asn1-combinators.git#enum`
+https://github.com/hannesm/albatross`.  On FreeBSD, `opam pin add
-- `x509 https://github.com/hannesm/ocaml-x509.git#crl`
+solo5-kernel-ukvm --dev` is needed as well.
-- `tls https://github.com/hannesm/ocaml-tls.git#changes`
-- on FreeBSD, `solo5-kernel-ukvm https://github.com/solo5/solo5.git`
 
 The following elaborates on how to get the software up and running, following by
 provisioning and deploying some unikernels.  There is a *server* (`SRV`)

_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
 
-<src/vmm_wire.{ml,mli}>: package(cstruct.ppx)
+<src/vmm_wire.{ml,mli}>: package(ppx_cstruct)
 <src/vmm_asn.{ml,mli}>: package(asn1-combinators)
 <src/vmm_lwt.{ml,mli}>: package(lwt)
 <src/vmm_tls.{ml,mli}>: package(lwt tls.lwt)

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

opam

@@ -14,9 +14,18 @@ depends: [
   "ipaddr" {>= "2.2.0"}
   "hex"
   "cstruct"
-  "ppx_cstruct" {build}
+  "ppx_cstruct" {build & >= "3.0.0"}
-  "logs" "rresult" "bos" "ptime" "cmdliner" "fmt" "astring"
+  "logs"
-  "x509" "tls" "nocrypto" "asn1-combinators"
+  "rresult"
+  "bos"
+  "ptime"
+  "cmdliner"
+  "fmt"
+  "astring"
+  "x509" {>= "0.6.0"}
+  "tls" {>= "0.9.0"}
+  "nocrypto"
+  "asn1-combinators" {>= "0.2.0"}
   "duration"
 ]
 

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
+  let now = Ptime_clock.now () in
-  and now = Unix.time ()
+  match Ptime.add_span now (Ptime.Span.of_int_s (Duration.to_sec validity)) with
-  in
+  | None -> Error (`Msg "span too big - reached end of ptime")
-  let start = asn1_of_unix now
+  | Some exp -> Ok (now, exp)
-  and expire = asn1_of_unix (now +. valid)
-  in
-  (start, expire)
 
 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
+  timestamps delta >>= fun (valid_from, valid_until) ->
-  (match dbname with
+  let extensions =
-   | None -> Ok extensions (* evil hack to avoid issuer + public key for CA cert *)
+    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
-       Ok (extensions @ key_ids (X509.CA.info csr).X509.CA.public_key capub)) >>= fun extensions ->
+        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! *)

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

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
+  match Asn.decode codec cs with
-    let (a, cs) = Asn.decode_exn codec cs in
+  | Ok (a, cs) ->
-    if Cstruct.len cs = 0 then
+    guard (Cstruct.len cs = 0) (`Msg "trailing bytes") >>= fun () ->
     Ok a
-    else
+  | Error (`Parse msg) -> Error (`Msg msg)
-      Error (`Msg "trailing bytes")
-  with
-  | e -> Error (`Msg (Printexc.to_string e))
 
 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 int_of_cstruct, int_to_cstruct = projections_of Asn.S.int
-let ints_of_cstruct, ints_to_cstruct = projections_of Asn.(sequence_of 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,8 +80,8 @@ let bridge =
     | `Internal nam -> `C1 nam
     | `External (nam, s, e, r, n) -> `C2 (nam, s, e, r, n)
   in
-  Asn.map f g @@
+  Asn.S.map f g @@
-  Asn.(choice2
+  Asn.S.(choice2
            (explicit 0 utf8_string)
            (explicit 1 (sequence5
                           (required ~label:"name" utf8_string)
@@ -90,12 +91,12 @@ let bridge =
                           (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,8 +106,8 @@ let image =
     | `Ukvm_amd64, x -> `C1 x
     | `Ukvm_arm64, x -> `C2 x
   in
-  Asn.map f g @@
+  Asn.S.map f g @@
-  Asn.(choice2
+  Asn.S.(choice2
            (explicit 0 octet_string)
            (explicit 1 octet_string))
 
@@ -114,11 +115,9 @@ 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 =

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 > <local>.this_update, number > <local>.number *)
   (* TODO: can we have something better for uniqueness of CRL? *)