address most of @cfcs comments

.ocamlinit

@@ -1,3 +1,3 @@
-#require "cstruct, asn1-combinators, astring, fmt, ipaddr, rresult, lwt, x509, tls, hex, bos, decompress, tls.lwt"
+#require "checkseum.c, cstruct, asn1-combinators, astring, fmt, ipaddr, rresult, lwt, x509, tls, hex, bos, decompress, tls.lwt"
 #directory "_build/src"
 #load "albatross.cma"

README.md

@@ -1,4 +1,4 @@
-# Albatross: orchestrate and manage MirageOS unikernels
+# Albatross: orchestrate and manage MirageOS unikernels with Solo5
 
 [![Build Status](https://travis-ci.org/hannesm/albatross.svg?branch=master)](https://travis-ci.org/hannesm/albatross)
 

app/vmm_cli.ml

@@ -10,12 +10,11 @@ let setup_log style_renderer level =
 
 let create_vm force image cpuid requested_memory argv block_device network compression =
   let open Rresult.R.Infix in
-  (Bos.OS.File.read (Fpath.v image) >>= fun s ->
+  Bos.OS.File.read (Fpath.v image) >>| fun image ->
-   Ok (Cstruct.of_string s)) >>| fun image ->
   let vmimage = match compression with
-    | 0 -> `Hvt_amd64, image
+    | 0 -> `Hvt_amd64, Cstruct.of_string image
     | level ->
-      let img = Vmm_compress.compress ~level (Cstruct.to_string image) in
+      let img = Vmm_compress.compress ~level image in
       `Hvt_amd64_compressed, Cstruct.of_string img
   and argv = match argv with [] -> None | xs -> Some xs
   in
@@ -23,13 +22,12 @@ let create_vm force image cpuid requested_memory argv block_device network compr
   if force then `Vm_force_create vm_config else `Vm_create vm_config
 
 let policy vms memory cpus block bridges =
-  let bridges = match bridges with
+  let bridges =
-    | xs ->
+    let add m v =
-      let add m v =
+      let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in
-        let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in
+      String.Map.add n v m
-        String.Map.add n v m
+    in
-      in
+    List.fold_left add String.Map.empty bridges
-      List.fold_left add String.Map.empty xs
   and cpuids = IS.of_list cpus
   in
   { vms ; cpuids ; memory ; block ; bridges }
@@ -74,7 +72,7 @@ let bridge =
         | _ -> `Error "couldn't parse IP address"
       end
     | [ name ] -> `Ok (`Internal name)
-    | _ -> `Error "couldn't parse bridge (either 'name' or 'name/fstIP/lstIP/gwIP/netmask')"
+    | _ -> `Error "couldn't parse bridge (either specify 'name' or 'name/firstIP/lastIP/gatewayIP/netmask')"
   in
   (parse, pp_bridge)
 
@@ -96,7 +94,7 @@ let force =
   Arg.(value & flag & info [ "f" ; "force" ] ~doc)
 
 let cpus =
-  let doc = "CPUs to allow" in
+  let doc = "CPUids to allow" in
   Arg.(value & opt_all int [] & info [ "cpu" ] ~doc)
 
 let vms =
@@ -104,23 +102,23 @@ let vms =
   Arg.(required & pos 0 (some int) None & info [] ~doc ~docv:"VMS")
 
 let block_size =
-  let doc = "Block storage to allow" in
+  let doc = "Block storage to allow in MB" in
   Arg.(value & opt (some int) None & info [ "block" ] ~doc)
 
 let mem =
-  let doc = "Memory to allow" in
+  let doc = "Memory to allow in MB" in
   Arg.(value & opt int 512 & info [ "mem" ] ~doc)
 
 let bridge =
-  let doc = "Bridge to allow" in
+  let doc = "Bridges to allow" in
   Arg.(value & opt_all bridge [] & info [ "bridge" ] ~doc)
 
 let cpu =
-  let doc = "CPUid" in
+  let doc = "CPUid to use" in
   Arg.(value & opt int 0 & info [ "cpu" ] ~doc)
 
 let vm_mem =
-  let doc = "Memory to assign" in
+  let doc = "Assigned memory in MB" in
   Arg.(value & opt int 32 & info [ "mem" ] ~doc)
 
 let args =
@@ -132,7 +130,7 @@ let block =
   Arg.(value & opt (some string) None & info [ "block" ] ~doc)
 
 let net =
-  let doc = "Network device" in
+  let doc = "Network device names" in
   Arg.(value & opt_all string [] & info [ "net" ] ~doc)
 
 let timestamp_c =
@@ -143,5 +141,5 @@ let timestamp_c =
   (parse, Ptime.pp_rfc3339 ())
 
 let since =
-  let doc = "Since" in
+  let doc = "Receive data since a specified timestamp (RFC 3339 encoded)" in
   Arg.(value & opt (some timestamp_c) None & info [ "since" ] ~doc)

app/vmmc_bistro.ml

@@ -6,8 +6,7 @@ let version = `AV2
 
 let process fd =
   Vmm_tls_lwt.read_tls fd >|= function
-  | Error _ ->
+  | Error _ -> Error (`Msg "read or parse 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)) ;
@@ -17,12 +16,6 @@ let process fd =
       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 () =
@@ -72,9 +65,9 @@ let handle (host, port) cert key ca id (cmd : Vmm_commands.t) =
   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 _ ->
+  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 ->
+  Tls_lwt.Unix.client_of_fd client (* TODO ~host *) fd >>= fun t ->
   read t
 
 let jump endp cert key ca name cmd =

app/vmmd.ml

@@ -36,19 +36,12 @@ let create process cont =
         let state', out' = Vmm_vmmd.handle_shutdown !state name vm r in
         s := { !s with vm_destroyed = succ !s.vm_destroyed } ;
         state := state' ;
-        (process out' >|= function
+        (process "handle_shutdown" out' >|= fun _ -> ()) >|= fun () ->
-          | Error (`Msg msg) ->
-            Logs.err (fun m -> m "error %s on handling shutdown" msg)
-          | Ok () -> ()) >|= fun () ->
         Lwt.wakeup wakeme ()) ;
-    (process out >|= function
+    (process "setting up console" out >|= fun _ -> ()) >>= fun () ->
-      | Error (`Msg msg) -> Logs.err (fun m -> m "error %s while setting up stats and logging" msg)
-      | Ok () -> ()) >>= fun () ->
     let state', out = Vmm_vmmd.setup_stats !state name vm in
     state := state' ;
-    process [ out ] >|= function
+    process "setting up statistics" [ out ] >|= fun _ -> ()
-    | Error (`Msg msg) -> Logs.err (fun m -> m "error %s sending information to stats" msg)
-    | Ok () -> ()
 
 let handle out fd addr =
   Logs.debug (fun m -> m "connection from %a" Vmm_lwt.pp_sockaddr addr) ;
@@ -64,7 +57,7 @@ let handle out fd addr =
          -- Lwt effects happen (stats, logs, wait_and_clear) --
     (2) goto (1)
   *)
-  let process wires =
+  let process txt wires =
     Lwt_list.fold_left_s (fun r data ->
         match r, data with
         | Ok (), (#Vmm_vmmd.service_out as o) -> out o
@@ -73,7 +66,11 @@ let handle out fd addr =
           Vmm_lwt.write_wire fd wire >|= fun _ ->
           Ok ()
         | Error e, _ -> Lwt.return (Error e))
-      (Ok ()) wires
+      (Ok ()) wires >|= function
+    | Ok () -> Ok ()
+    | Error (`Msg msg) ->
+      Logs.err (fun m -> m "error in process %s: %s" txt msg) ;
+      Error ()
   in
   Logs.debug (fun m -> m "now reading") ;
   (Vmm_lwt.read_wire fd >>= function
@@ -84,19 +81,19 @@ let handle out fd addr =
       Logs.debug (fun m -> m "read sth") ;
       let state', data, next = Vmm_vmmd.handle_command !state wire in
       state := state' ;
-      process data >>= function
+      process "handle_command" data >>= function
-      | Error (`Msg msg) -> Logs.err (fun m -> m "received error %s" msg) ; Lwt.return_unit
+      | Error () -> Lwt.return_unit
       | Ok () -> match next with
         | `End -> Lwt.return_unit
         | `Wait (task, out) ->
           task >>= fun () ->
-          process [ out ] >|= fun _ ->
+          process "wait" [ out ] >|= fun _ ->
           ()
       | `Wait_and_create (task, next) ->
         task >>= fun () ->
         let state', data, n = next !state in
         state := state' ;
-        process data >>= fun _ ->
+        process "wait and create" data >>= fun _ ->
         (match n with
          | `End -> Lwt.return_unit
          | `Create cont -> create process cont)

app/vmmp_ca.ml

@@ -34,7 +34,7 @@ let albatross_extension csr =
   | [ (_, `Unsupported (_, v)) as ext ] -> Ok (ext, v)
   | _ -> Error (`Msg "couldn't find albatross extension in CSR")
 
-let sign dbname cacert key csr days =
+let sign_csr dbname cacert key csr days =
   let ri = X509.CA.info csr in
   Logs.app (fun m -> m "signing certificate with subject %s"
                (X509.distinguished_name_to_string ri.X509.CA.subject)) ;
@@ -66,7 +66,7 @@ let sign _ db cacert cakey csrname days =
     let cakey = X509.Encoding.Pem.Private_key.of_pem_cstruct1 (Cstruct.of_string pk) in
     Bos.OS.File.read (Fpath.v csrname) >>= fun enc ->
     let csr = X509.Encoding.Pem.Certificate_signing_request.of_pem_cstruct1 (Cstruct.of_string enc) in
-    sign (Fpath.v db) cacert cakey csr days
+    sign_csr (Fpath.v db) cacert cakey csr days
   with
   | Ok () -> `Ok ()
   | Error (`Msg e) -> `Error (false, e)

opam

@@ -33,4 +33,4 @@ depends: [
 build: [
   [ "ocaml" "pkg/pkg.ml" "build" "--pinned" "%{pinned}%" "--tests" "false" ]
 ]
-synopsis: "Albatross - orchestrate and manage MirageOS unikernels"
+synopsis: "Albatross - orchestrate and manage MirageOS unikernels with Solo5"

src/vmm_lwt.ml

@@ -63,7 +63,7 @@ let read_wire s =
   | Error e -> Lwt.return (Error e)
   | Ok () ->
     let len = Cstruct.BE.get_uint32 (Cstruct.of_bytes buf) 0 in
-    if len > 0l then
+    if len > 0l then begin
       let b = Bytes.create (Int32.to_int len) in
       r b 0 (Int32.to_int len) >|= function
       | Error e -> Error e
@@ -76,8 +76,9 @@ let read_wire s =
         | Error (`Msg msg) ->
           Logs.err (fun m -> m "error %s while parsing data" msg) ;
           Error `Exception
-    else
+    end else begin
-        Lwt.return (Error `Eof)
+      Lwt.return (Error `Eof)
+    end
 
 let write_raw s buf =
   let rec w off l =

src/vmm_resources.ml

@@ -72,17 +72,21 @@ let check_vm_policy t name vm =
   let dom = domain name in
   let res = resource_usage t dom in
   match Vmm_trie.find dom t with
-  | None -> true
+  | None -> Ok true
-  | Some (Vm _) -> assert false
+  | Some (Vm vm) ->
-  | Some (Policy p) -> check_resource p vm res
+    Logs.err (fun m -> m "id %a, expected policy, got vm %a" pp_id dom pp_vm vm) ;
+    Rresult.R.error_msgf "expected policy, found vm for %a" pp_id dom
+  | Some (Policy p) -> Ok (check_resource p vm res)
 
 let insert_vm t name vm =
-  if check_vm_policy t name vm.config then
+  let open Rresult.R.Infix in
-    match Vmm_trie.insert name (Vm vm) t with
+  check_vm_policy t name vm.config >>= function
-    | t', None -> Ok t'
+  | true ->
-    | _, Some _ -> Error (`Msg "vm already exists")
+    begin match Vmm_trie.insert name (Vm vm) t with
-  else
+      | t', None -> Ok t'
-    Error (`Msg "resource policy mismatch")
+      | _, Some _ -> Error (`Msg "vm already exists")
+    end
+  | false -> Error (`Msg "resource policy mismatch")
 
 let check_policy_above t name p =
   let above = Vmm_trie.collect name t in

src/vmm_resources.mli

@@ -25,7 +25,7 @@ val find_policy : t -> Vmm_core.id -> Vmm_core.policy option
 
 (** [check_vm_policy t vm] checks whether [vm] under [id] in [t] would be
     allowed under the current policies. *)
-val check_vm_policy : t -> Vmm_core.id -> Vmm_core.vm_config -> bool
+val check_vm_policy : t -> Vmm_core.id -> Vmm_core.vm_config -> (bool, [> `Msg of string ]) result
 
 (** [insert_vm t vm] inserts [vm] under [id] in [t], and returns the new [t] or
     an error. *)

src/vmm_vmmd.ml

@@ -46,10 +46,9 @@ let handle_create t hdr vm_config =
    | Some _ -> Error (`Msg "VM with same name is already running")
    | None -> Ok ()) >>= fun () ->
   Logs.debug (fun m -> m "now checking resource policies") ;
-  (if Vmm_resources.check_vm_policy t.resources name vm_config then
+  (Vmm_resources.check_vm_policy t.resources name vm_config >>= function
-     Ok ()
+    | false -> Error (`Msg "resource policies don't allow this")
-   else
+    | true -> Ok ()) >>= fun () ->
-     Error (`Msg "resource policies don't allow this")) >>= fun () ->
   (* prepare VM: save VM image to disk, create fifo, ... *)
   Vmm_unix.prepare name vm_config >>= fun taps ->
   Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ;
@@ -158,13 +157,15 @@ let handle_command t (header, payload) =
         | `Vm_create vm_config ->
           handle_create t header vm_config
         | `Vm_force_create vm_config ->
-          let resources =
+          begin
-            match Vmm_resources.remove_vm t.resources id with
+            let resources =
-            | Error _ -> t.resources
+              match Vmm_resources.remove_vm t.resources id with
-            | Ok r -> r
+              | Error _ -> t.resources
-          in
+              | Ok r -> r
-          if Vmm_resources.check_vm_policy resources id vm_config then
+            in
-            begin match Vmm_resources.find_vm t.resources id with
+            Vmm_resources.check_vm_policy resources id vm_config >>= function
+            | false -> Error (`Msg "wouldn't match policy")
+            | true -> match Vmm_resources.find_vm t.resources id with
               | None -> handle_create t header vm_config
               | Some vm ->
                 Vmm_unix.destroy vm ;
@@ -176,9 +177,7 @@ let handle_command t (header, payload) =
                   let t = { t with tasks } in
                   Ok (t, [], `Wait_and_create
                         (task, fun t -> msg_to_err @@ handle_create t header vm_config))
-            end
+          end
-          else
-            Error (`Msg "wouldn't match policy")
         | `Vm_destroy ->
           begin match Vmm_resources.find_vm t.resources id with
             | Some vm ->