reynir
/
albatross
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

address most of @cfcs comments

This commit is contained in:
Hannes Mehnert 2018-10-29 17:14:51 +01:00
parent 2c0ded4272
commit c669be8e02
11 changed files with 70 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.ocamlinit
View File

@ -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"

2
README.md
View File

@ -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)

38
app/vmm_cli.ml
View File

@ -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)

13
app/vmmc_bistro.ml
View File

@ -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 =

29
app/vmmd.ml
View File

@ -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)

4
app/vmmp_ca.ml
View File

@ -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)

2
opam
View File

@ -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"

7
src/vmm_lwt.ml
View File

@ -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 =

22
src/vmm_resources.ml
View File

@ -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

2
src/vmm_resources.mli
View File

@ -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. *)

27
src/vmm_vmmd.ml
View File

@ -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 ->