diff --git a/.ocamlinit b/.ocamlinit index 6702b21..df86c9a 100644 --- a/.ocamlinit +++ b/.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" diff --git a/README.md b/README.md index 7580feb..91ed44d 100644 --- a/README.md +++ b/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) diff --git a/app/vmm_cli.ml b/app/vmm_cli.ml index 6292dac..5dd3796 100644 --- a/app/vmm_cli.ml +++ b/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 -> - Ok (Cstruct.of_string s)) >>| fun image -> + Bos.OS.File.read (Fpath.v image) >>| 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 - | 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 + let bridges = + 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 bridges 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) diff --git a/app/vmmc_bistro.ml b/app/vmmc_bistro.ml index 31e0c8a..4a63a11 100644 --- a/app/vmmc_bistro.ml +++ b/app/vmmc_bistro.ml @@ -6,8 +6,7 @@ let version = `AV2 let process fd = Vmm_tls_lwt.read_tls fd >|= function - | Error _ -> - Error (`Msg "read or parse error") + | 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 = diff --git a/app/vmmd.ml b/app/vmmd.ml index 74597f8..6f264b9 100644 --- a/app/vmmd.ml +++ b/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 - | Error (`Msg msg) -> - Logs.err (fun m -> m "error %s on handling shutdown" msg) - | Ok () -> ()) >|= fun () -> + (process "handle_shutdown" out' >|= fun _ -> ()) >|= fun () -> Lwt.wakeup wakeme ()) ; - (process out >|= function - | Error (`Msg msg) -> Logs.err (fun m -> m "error %s while setting up stats and logging" msg) - | Ok () -> ()) >>= fun () -> + (process "setting up console" out >|= fun _ -> ()) >>= fun () -> let state', out = Vmm_vmmd.setup_stats !state name vm in state := state' ; - process [ out ] >|= function - | Error (`Msg msg) -> Logs.err (fun m -> m "error %s sending information to stats" msg) - | Ok () -> () + process "setting up statistics" [ out ] >|= fun _ -> () 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 - | Error (`Msg msg) -> Logs.err (fun m -> m "received error %s" msg) ; Lwt.return_unit + process "handle_command" data >>= function + | 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) diff --git a/app/vmmp_ca.ml b/app/vmmp_ca.ml index 73a1870..a9c9645 100644 --- a/app/vmmp_ca.ml +++ b/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) diff --git a/opam b/opam index f65dcb5..f44d5bb 100644 --- a/opam +++ b/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" diff --git a/src/vmm_lwt.ml b/src/vmm_lwt.ml index d8ab4bc..7428704 100644 --- a/src/vmm_lwt.ml +++ b/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 - Lwt.return (Error `Eof) + end else begin + Lwt.return (Error `Eof) + end let write_raw s buf = let rec w off l = diff --git a/src/vmm_resources.ml b/src/vmm_resources.ml index 4df3791..6000960 100644 --- a/src/vmm_resources.ml +++ b/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 - | Some (Vm _) -> assert false - | Some (Policy p) -> check_resource p vm res + | None -> Ok true + | Some (Vm vm) -> + 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 - match Vmm_trie.insert name (Vm vm) t with - | t', None -> Ok t' - | _, Some _ -> Error (`Msg "vm already exists") - else - Error (`Msg "resource policy mismatch") + let open Rresult.R.Infix in + check_vm_policy t name vm.config >>= function + | true -> + begin match Vmm_trie.insert name (Vm vm) t with + | t', None -> Ok t' + | _, 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 diff --git a/src/vmm_resources.mli b/src/vmm_resources.mli index a0eb877..e38a12b 100644 --- a/src/vmm_resources.mli +++ b/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. *) diff --git a/src/vmm_vmmd.ml b/src/vmm_vmmd.ml index ffcc7fd..585435d 100644 --- a/src/vmm_vmmd.ml +++ b/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 - Ok () - else - Error (`Msg "resource policies don't allow this")) >>= fun () -> + (Vmm_resources.check_vm_policy t.resources name vm_config >>= function + | false -> Error (`Msg "resource policies don't allow this") + | true -> Ok ()) >>= 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 = - match Vmm_resources.remove_vm t.resources id with - | Error _ -> t.resources - | Ok r -> r - in - if Vmm_resources.check_vm_policy resources id vm_config then - begin match Vmm_resources.find_vm t.resources id with + begin + let resources = + match Vmm_resources.remove_vm t.resources id with + | Error _ -> t.resources + | Ok r -> r + in + 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 - else - Error (`Msg "wouldn't match policy") + end | `Vm_destroy -> begin match Vmm_resources.find_vm t.resources id with | Some vm ->