wip: vmmc_bistro

_tags

@@ -16,6 +16,7 @@ true : package(rresult logs ipaddr bos hex ptime astring duration cstruct decomp
 <app/vmmd_stats.{ml,native,byte}>: link_vmm_stats, package(asn1-combinators)
 
 <app/vmmc_remote.{ml,native,byte}>: package(nocrypto tls.lwt nocrypto.lwt)
+<app/vmmc_bistro.{ml,native,byte}>: package(nocrypto tls.lwt nocrypto.lwt)
 
 <app/vmmp_request.{ml,native,byte}>: package(nocrypto.unix ptime.clock.os x509)
 <app/vmmp_sign.{ml,native,byte}>: package(nocrypto.unix ptime.clock.os x509)

app/vmm_provision.ml

@@ -2,20 +2,6 @@
 
 let asn_version = `AV2
 
-let setup_log style_renderer level =
-  Fmt_tty.setup_std_outputs ?style_renderer ();
-  Logs.set_level level;
-  Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
-
-let l_exts =
-  [ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ])
-  ; (true, `Basic_constraints (false, None))
-  ; (true, `Ext_key_usage [`Client_auth]) ]
-
-let d_exts ?len () =
-  [ (true, (`Basic_constraints (true, len)))
-  ; (true, (`Key_usage [ `Key_cert_sign ; `CRL_sign ; `Digital_signature ; `Content_commitment ])) ]
-
 let timestamps validity =
   let now = Ptime_clock.now () in
   match Ptime.add_span now (Ptime.Span.of_int_s (Duration.to_sec validity)) with
@@ -93,11 +79,6 @@ let priv_key ?(bits = 2048) fn name =
 
 open Cmdliner
 
-let setup_log =
-  Term.(const setup_log
-        $ Fmt_cli.style_renderer ()
-        $ Logs_cli.level ())
-
 let nam =
   let doc = "Name to provision" in
   Arg.(required & pos 0 (some string) None & info [] ~doc)

app/vmmc_bistro.ml

@@ -0,0 +1,333 @@
+(* (c) 2018 Hannes Mehnert, all rights reserved *)
+
+open Lwt.Infix
+
+open Astring
+
+open Vmm_core
+
+let version = `AV2
+
+let process fd =
+  Vmm_tls_lwt.read_tls fd >|= function
+  | Error _ ->
+    Error (`Msg "read or parse error")
+  | Ok (header, reply) ->
+    if Vmm_commands.version_eq header.Vmm_commands.version version then begin
+      Logs.app (fun m -> m "%a" Vmm_commands.pp_wire (header, reply)) ;
+      Ok ()
+    end else begin
+      Logs.err (fun m -> m "version not equal") ;
+      Error (`Msg "version not equal")
+    end
+
+let connect socket_path =
+  let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
+  Lwt_unix.set_close_on_exec c ;
+  Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket_path) >|= fun () ->
+  c
+
+let read fd =
+  (* now we busy read and process output *)
+  let rec loop () =
+    process fd >>= function
+    | Error e -> Lwt.return (Error e)
+    | Ok () -> loop ()
+  in
+  loop ()
+
+let key_ids pub issuer =
+  let auth = (Some (X509.key_id issuer), [], None) in
+  [ (false, `Subject_key_id (X509.key_id pub)) ; (false, `Authority_key_id auth) ]
+
+let timestamps validity =
+  let now = Ptime_clock.now () in
+  match Ptime.add_span now (Ptime.Span.of_int_s validity) with
+  | None -> invalid_arg "span too big - reached end of ptime"
+  | Some exp -> (now, exp)
+
+let handle (host, port) cert key ca id (cmd : Vmm_commands.t) =
+  Vmm_lwt.read_from_file cert >>= fun cert_cs ->
+  let cert = X509.Encoding.Pem.Certificate.of_pem_cstruct1 cert_cs in
+  Vmm_lwt.read_from_file key >>= fun key_cs ->
+  let key = X509.Encoding.Pem.Private_key.of_pem_cstruct1 key_cs in
+  let tmpkey = Nocrypto.Rsa.generate 4096 in
+  let name = string_of_id id in
+  let extensions =
+    [ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ])
+    ; (true, `Basic_constraints (false, None))
+    ; (true, `Ext_key_usage [`Client_auth]) ;
+      (false, `Unsupported (Vmm_asn.oid, Vmm_asn.cert_extension_to_cstruct (version, cmd))) ] in
+  let csr =
+    let name = [ `CN name ] in
+    X509.CA.request name ~extensions:[`Extensions extensions] (`RSA tmpkey)
+  in
+  let mycert =
+    let valid_from, valid_until = timestamps 300 in
+    let extensions =
+      let capub = match key with `RSA key -> Nocrypto.Rsa.pub_of_priv key in
+      extensions @ key_ids (X509.CA.info csr).X509.CA.public_key (`RSA capub)
+    in
+    let issuer = X509.subject cert in
+    X509.CA.sign csr ~valid_from ~valid_until ~extensions key issuer
+  in
+  let certificates = `Single ([ mycert ; cert ], tmpkey) in
+  X509_lwt.authenticator (`Ca_file ca) >>= fun authenticator ->
+  Lwt_unix.gethostbyname host >>= fun host_entry ->
+  let host_inet_addr = Array.get host_entry.Lwt_unix.h_addr_list 0 in
+  let fd = Lwt_unix.socket host_entry.Lwt_unix.h_addrtype Lwt_unix.SOCK_STREAM 0 in
+  Lwt_unix.connect fd (Lwt_unix.ADDR_INET (host_inet_addr, port)) >>= fun _ ->
+  let client = Tls.Config.client ~reneg:true ~certificates ~authenticator () in
+  Tls_lwt.Unix.client_of_fd client (* ~host *) fd >>= fun t ->
+  read t
+
+let jump endp cert key ca name cmd =
+  match
+    Lwt_main.run (handle endp cert key ca name cmd)
+  with
+  | Ok () -> `Ok ()
+  | Error (`Msg m) -> `Error (false, m)
+
+let info_ _ endp cert key ca name = jump endp cert key ca name (`Vm_cmd `Vm_info)
+
+let policy _ endp cert key ca name = jump endp cert key ca name (`Policy_cmd `Policy_info)
+
+let remove_policy _ endp cert key ca name =
+  jump endp cert key ca name (`Policy_cmd `Policy_remove)
+
+let add_policy _ endp cert key ca name vms memory cpus block bridges =
+  let bridges = match bridges with
+    | xs ->
+      let add m v =
+        let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in
+        String.Map.add n v m
+      in
+      List.fold_left add String.Map.empty xs
+  and cpuids = IS.of_list cpus
+  in
+  let policy = { vms ; cpuids ; memory ; block ; bridges } in
+  jump endp cert key ca name (`Policy_cmd (`Policy_add policy))
+
+let destroy _ endp cert key ca name =
+  jump endp cert key ca name (`Vm_cmd `Vm_destroy)
+
+let create _ endp cert key ca force name image cpuid requested_memory boot_params block_device network =
+  let image' = match Bos.OS.File.read (Fpath.v image) with
+    | Ok data -> data
+    | Error (`Msg s) -> invalid_arg s
+  in
+  let argv = match boot_params with
+    | [] -> None
+    | xs -> Some xs
+  (* TODO we could do the compression btw *)
+  and vmimage = `Hvt_amd64, Cstruct.of_string image'
+  in
+  let vm_config = { cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } in
+  let cmd =
+    if force then
+      `Vm_force_create vm_config
+    else
+      `Vm_create vm_config
+  in
+  jump endp cert key ca name (`Vm_cmd cmd)
+
+let console _ endp cert key ca name since =
+  jump endp cert key ca name (`Console_cmd (`Console_subscribe since))
+
+let stats _ endp cert key ca name =
+  jump endp cert key ca name (`Stats_cmd `Stats_subscribe)
+
+let event_log _ endp cert key ca name since =
+  jump endp cert key ca name (`Log_cmd (`Log_subscribe since))
+
+let help _ _ man_format cmds = function
+  | None -> `Help (`Pager, None)
+  | Some t when List.mem t cmds -> `Help (man_format, Some t)
+  | Some _ -> List.iter print_endline cmds; `Ok ()
+
+open Cmdliner
+open Vmm_cli
+
+let server_ca =
+  let doc = "The certificate authority used to verify the remote server." in
+  Arg.(value & opt string "cacert.pem" & info [ "server-ca" ] ~doc)
+
+let ca_cert =
+  let doc = "The certificate authority used to issue the certificate" in
+  Arg.(value & opt string "ca.pem" & info [ "ca" ] ~doc)
+
+let ca_key =
+  let doc = "The private key of the signing certificate authority" in
+  Arg.(value & opt string "ca.key" & info [ "ca-key" ] ~doc)
+
+let destination =
+  Arg.(required & pos 0 (some host_port) None & info [] ~docv:"destination"
+         ~doc:"the destination hostname:port to connect to")
+
+let force =
+  let doc = "force VM creation." in
+  Arg.(value & flag & info [ "f" ; "force" ] ~doc)
+
+let image =
+  let doc = "File of virtual machine image." in
+  Arg.(required & pos 2 (some file) None & info [] ~doc)
+
+let vm_name =
+  let doc = "Name virtual machine." in
+  Arg.(required & pos 1 (some vm_c) None & info [] ~doc)
+
+let destroy_cmd =
+  let doc = "destroys a virtual machine" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Destroy a virtual machine."]
+  in
+  Term.(ret (const destroy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ vm_name)),
+  Term.info "destroy" ~doc ~man
+
+let remove_policy_cmd =
+  let doc = "removes a policy" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Removes a policy."]
+  in
+  Term.(ret (const remove_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)),
+  Term.info "remove_policy" ~doc ~man
+
+let info_cmd =
+  let doc = "information about VMs" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Shows information about VMs."]
+  in
+  Term.(ret (const info_ $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)),
+  Term.info "info" ~doc ~man
+
+let policy_cmd =
+  let doc = "active policies" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Shows information about policies."]
+  in
+  Term.(ret (const policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)),
+  Term.info "policy" ~doc ~man
+
+let cpus =
+  let doc = "CPUs to allow" in
+  Arg.(value & opt_all int [] & info [ "cpu" ] ~doc)
+
+let vms =
+  let doc = "Number of VMs to allow" in
+  Arg.(required & pos 0 (some int) None & info [] ~doc)
+
+let block =
+  let doc = "Block storage to allow" in
+  Arg.(value & opt (some int) None & info [ "block" ] ~doc)
+
+let mem =
+  let doc = "Memory to allow" in
+  Arg.(value & opt int 512 & info [ "mem" ] ~doc)
+
+let bridge =
+  let doc = "Bridge to allow" in
+  Arg.(value & opt_all bridge [] & info [ "bridge" ] ~doc)
+
+let add_policy_cmd =
+  let doc = "Add a policy" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Adds a policy."]
+  in
+  Term.(ret (const add_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name $ vms $ mem $ cpus $ block $ bridge)),
+  Term.info "add_policy" ~doc ~man
+
+let cpu =
+  let doc = "CPUid" in
+  Arg.(value & opt int 0 & info [ "cpu" ] ~doc)
+
+let args =
+  let doc = "Boot arguments" in
+  Arg.(value & opt_all string [] & info [ "arg" ] ~doc)
+
+let block =
+  let doc = "Block device name" in
+  Arg.(value & opt (some string) None & info [ "block" ] ~doc)
+
+let net =
+  let doc = "Network device" in
+  Arg.(value & opt_all string [] & info [ "net" ] ~doc)
+
+let create_cmd =
+  let doc = "creates a virtual machine" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Creates a virtual machine."]
+  in
+  Term.(ret (const create $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net)),
+  Term.info "create" ~doc ~man
+
+let timestamp_c =
+  let parse s = match Ptime.of_rfc3339 s with
+    | Ok (t, _, _) -> `Ok t
+    | Error _ -> `Error "couldn't parse timestamp"
+  in
+  (parse, Ptime.pp_rfc3339 ())
+
+let since =
+  let doc = "Since" in
+  Arg.(value & opt (some timestamp_c) None & info [ "since" ] ~doc)
+
+let console_cmd =
+  let doc = "console of a VM" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Shows console output of a VM."]
+  in
+  Term.(ret (const console $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ vm_name $ since)),
+  Term.info "console" ~doc ~man
+
+let stats_cmd =
+  let doc = "statistics of VMs" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Shows statistics of VMs."]
+  in
+  Term.(ret (const stats $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)),
+  Term.info "stats" ~doc ~man
+
+let log_cmd =
+  let doc = "Event log" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Shows event log of VM."]
+  in
+  Term.(ret (const event_log $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name $ since)),
+  Term.info "log" ~doc ~man
+
+let help_cmd =
+  let topic =
+    let doc = "The topic to get help on. `topics' lists the topics." in
+    Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc)
+  in
+  let doc = "display help about vmmc" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Prints help about conex commands and subcommands"]
+  in
+  Term.(ret (const help $ setup_log $ destination $ Term.man_format $ Term.choice_names $ topic)),
+  Term.info "help" ~doc ~man
+
+let default_cmd =
+  let doc = "VMM client and go to bistro" in
+  let man = [
+    `S "DESCRIPTION" ;
+    `P "$(tname) executes the provided subcommand on a remote albatross" ]
+  in
+  Term.(ret (const help $ setup_log $ destination $ Term.man_format $ Term.choice_names $ Term.pure None)),
+  Term.info "vmmc_bistro" ~version:"%%VERSION_NUM%%" ~doc ~man
+
+let cmds = [ help_cmd ; info_cmd ; policy_cmd ; remove_policy_cmd ; add_policy_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ; log_cmd ]
+
+let () =
+  match Term.eval_choice default_cmd cmds
+  with `Ok () -> exit 0 | _ -> exit 1

app/vmmd_log.ml

@@ -30,20 +30,8 @@ let write_complete s cs =
   w 0
 
 let read_from_file file =
-  Lwt_unix.stat file >>= fun stat ->
+  Vmm_lwt.read_from_file file >|= fun data ->
-  let size = stat.Lwt_unix.st_size in
+  let logs = Vmm_asn.logs_of_disk my_version data in
-  Lwt_unix.openfile file Lwt_unix.[O_RDONLY] 0 >>= fun fd ->
-  let buf = Bytes.create size in
-  let rec read off =
-    Lwt_unix.read fd buf off (size - off) >>= fun bytes ->
-    if bytes + off = size then
-      Lwt.return_unit
-    else
-      read (bytes + off)
-  in
-  read 0 >>= fun () ->
-  let logs = Vmm_asn.logs_of_disk my_version (Cstruct.of_bytes buf) in
-  Vmm_lwt.safe_close fd >|= fun () ->
   List.rev logs
 
 let write_to_file file =

app/vmmp_request.ml

@@ -36,43 +36,8 @@ let jump _ name key image mem cpu args block net force compression =
   | Ok () -> `Ok ()
   | Error (`Msg m) -> `Error (false, m)
 
-open Cmdliner
-
-let cpu =
-  let doc = "CPUid" in
-  Arg.(required & pos 3 (some int) None & info [] ~doc)
-
-let image =
-  let doc = "Image file to provision" in
-  Arg.(required & pos 1 (some file) None & info [] ~doc)
-
-let args =
-  let doc = "Boot arguments" in
-  Arg.(value & opt_all string [] & info [ "arg" ] ~doc)
-
-let block =
-  let doc = "Block device name" in
-  Arg.(value & opt (some string) None & info [ "block" ] ~doc)
-
-let net =
-  let doc = "Network device" in
-  Arg.(value & opt_all string [] & info [ "net" ] ~doc)
-
-let force =
-  let doc = "Force creation (destroy VM with same name if it exists)" in
-  Arg.(value & flag & info [ "force" ] ~doc)
-
-let compress_level =
-  let doc = "Compression level (0 for no compression)" in
-  Arg.(value & opt int 4 & info [ "compression-level" ] ~doc)
-
-let cmd =
-  Term.(ret (const jump $ setup_log $ nam $ key $ image $ mem $ cpu $ args $ block $ net $ force $ compress_level)),
-  Term.info "vmmp_csr" ~version:"%%VERSION_NUM%%"
-
-let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1
 (* (c) 2017 Hannes Mehnert, all rights reserved *)
-
+(*
 open Vmm_provision
 open Vmm_asn
 
@@ -129,4 +94,41 @@ let cmd =
   Term.(ret (const jump $ setup_log $ nam $ key $ vms $ mem $ cpus $ block $ bridge)),
   Term.info "vmmp_csr" ~version:"%%VERSION_NUM%%"
 
+let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1
+                                                          *)
+open Cmdliner
+open Vmm_cli
+
+let cpu =
+  let doc = "CPUid" in
+  Arg.(required & pos 3 (some int) None & info [] ~doc)
+
+let image =
+  let doc = "Image file to provision" in
+  Arg.(required & pos 1 (some file) None & info [] ~doc)
+
+let args =
+  let doc = "Boot arguments" in
+  Arg.(value & opt_all string [] & info [ "arg" ] ~doc)
+
+let block =
+  let doc = "Block device name" in
+  Arg.(value & opt (some string) None & info [ "block" ] ~doc)
+
+let net =
+  let doc = "Network device" in
+  Arg.(value & opt_all string [] & info [ "net" ] ~doc)
+
+let force =
+  let doc = "Force creation (destroy VM with same name if it exists)" in
+  Arg.(value & flag & info [ "force" ] ~doc)
+
+let compress_level =
+  let doc = "Compression level (0 for no compression)" in
+  Arg.(value & opt int 4 & info [ "compression-level" ] ~doc)
+
+let cmd =
+  Term.(ret (const jump $ setup_log $ nam $ key $ image $ mem $ cpu $ args $ block $ net $ force $ compress_level)),
+  Term.info "vmmp_csr" ~version:"%%VERSION_NUM%%"
+
 let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

app/vmmp_sign.ml

@@ -71,6 +71,7 @@ let jump _ db cacert cakey csrname days =
   | Error (`Msg e) -> `Error (false, e)
 
 open Cmdliner
+open Vmm_cli
 
 let csr =
   let doc = "signing request" in

src/vmm_lwt.ml

@@ -105,3 +105,28 @@ let safe_close fd =
   Lwt.catch
     (fun () -> Lwt_unix.close fd)
     (fun _ -> Lwt.return_unit)
+
+let read_from_file file =
+  Lwt.catch (fun () ->
+      Lwt_unix.stat file >>= fun stat ->
+      let size = stat.Lwt_unix.st_size in
+      Lwt_unix.openfile file Lwt_unix.[O_RDONLY] 0 >>= fun fd ->
+      Lwt.catch (fun () ->
+          let buf = Bytes.create size in
+          let rec read off =
+            Lwt_unix.read fd buf off (size - off) >>= fun bytes ->
+            if bytes + off = size then
+              Lwt.return_unit
+            else
+              read (bytes + off)
+          in
+          read 0 >>= fun () ->
+          safe_close fd >|= fun () ->
+          Cstruct.of_bytes buf)
+        (fun e ->
+           Logs.err (fun m -> m "exception %s while reading %s" (Printexc.to_string e) file) ;
+           safe_close fd >|= fun () ->
+           Cstruct.empty))
+    (fun e ->
+       Logs.err (fun m -> m "exception %s while reading %s" (Printexc.to_string e) file) ;
+       Lwt.return Cstruct.empty)

src/vmm_lwt.mli

@@ -20,3 +20,5 @@ val write_wire :
   Lwt_unix.file_descr -> Vmm_commands.wire -> (unit, [> `Exception ]) result Lwt.t
 
 val safe_close : Lwt_unix.file_descr -> unit Lwt.t
+
+val read_from_file : string -> Cstruct.t Lwt.t

src/vmm_tls.ml

@@ -3,7 +3,13 @@
 open Rresult
 open Rresult.R.Infix
 
-let name cert = X509.common_name_to_string cert
+(* we skip all non-albatross certificates *)
+let name chain =
+  List.fold_left (fun acc cert ->
+      match X509.Extension.unsupported cert Vmm_asn.oid with
+      | None -> acc
+      | Some _ -> X509.common_name_to_string cert :: acc)
+    [] chain
 
 (* this separates the leaf and top-level certificate from the chain,
    and also reverses the intermediates (to be (leaf, CA -> subCA -> subCA')
@@ -39,13 +45,12 @@ let wire_command_of_cert version cert =
 *)
 
 let handle _addr version chain =
-  separate_chain chain >>= fun (leaf, chain) ->
+  separate_chain chain >>= fun (leaf, rest) ->
-  let prefix = List.map name chain in
+  let name = name chain in
-  let name = prefix @ [ name leaf ] in
   Logs.debug (fun m -> m "leaf is %s, chain %a"
                  (X509.common_name_to_string leaf)
                  Fmt.(list ~sep:(unit " -> ") string)
-                 (List.map X509.common_name_to_string chain)) ;
+                 (List.map X509.common_name_to_string rest)) ;
   (* TODO: inspect top-level-cert of chain. *)
   (* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *)
   (* TODO: update policies (parse chain for policy, and apply them)! *)