diff --git a/Dockerfile b/Dockerfile index b51a2aa..bb07698 100644 --- a/Dockerfile +++ b/Dockerfile @@ -15,15 +15,17 @@ ENV HOME /home/opam WORKDIR /home/opam RUN opam pin add -n -y mirage-xen \ - git://github.com/jonludlam/mirage-platform#reenable-suspend-resume + git://github.com/jonludlam/mirage-platform#reenable-suspend-resume2 RUN opam pin add -n -y mirage-bootvar-xen \ git://github.com/jonludlam/mirage-bootvar-xen#better-parser RUN opam pin add -n -y minios-xen \ git://github.com/jonludlam/mini-os#suspend-resume3 + RUN opam install -q -y mirage-xen RUN opam install -q -y mirage-console RUN opam install -q -y mirage-bootvar-xen RUN opam install -q -y mirage +RUN opam install -q -y yojson ENTRYPOINT [ "opam", "config", "exec", "--" ] CMD [ "bash" ] diff --git a/Makefile b/Makefile index ed1ba33..6c5c8ce 100644 --- a/Makefile +++ b/Makefile @@ -1,30 +1,30 @@ -# vim:ft=make ts=8: +# vim: set ft=make ts=8: # -# - -HOST = "root@dt87" +PACKAGE = xen-test-vm +PREFIX = . +LIB = $(PREFIX)/$(PACKAGE)/lib +VM = src/test-vm.xen.gz all: src $(MAKE) -C src/ all - ls -lh src/test-vm.xen.gz + ls -lh $(VM) - -install: all - ssh $(HOST) "test -d /boot/guest || mkdir /boot/guest" - ssh $(HOST) "cd /boot/guest; rm -f test-vm.xen" - scp src/test-vm.xen.gz $(HOST):/boot/guest +package: src + opam pin add -y xen-test-vm . + opam install xen-test-vm -remove: - true +install: + mkdir -p $(LIB) + cp $(VM) $(LIB) +remove: + rm -f $(LIB)/$(VM) + clean: $(MAKE) -C src clean -release: opam descr - - -.PHONY: all clean install release +.PHONY: all clean install release diff --git a/README.md b/README.md index 9297751..88c7562 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,5 @@ + + [![Build Status](https://travis-ci.org/xapi-project/xen-test-vm.svg?branch=master)](https://travis-ci.org/xapi-project/xen-test-vm) # Xen Test VM @@ -8,24 +10,20 @@ using the Mirage unikernel framework. # Binary Releases -Binary releases are hosted on +Binary releases are hosted on [GitHub](https://github.com/xapi-project/xen-test-vm/releases) as -`xen-test.vm.gz`. The uncompressed file is the kernel that needs to be -installed. You could use the following code in a script: +`xen-test.vm.gz`. -```sh -VERSION="0.0.5" -NAME="xen-test-vm-$VERSION" -GH="https://github.com/xapi-project" -VM="$GH/xen-test-vm/releases/download/$VERSION/test-vm.xen.gz" -KERNEL="xen-test-vm-${VERSION//./-}.xen.gz" + VERSION="0.0.5" + GH="https://github.com/xapi-project" + VM="$GH/xen-test-vm/releases/download/$VERSION/test-vm.xen.gz" + KERNEL="xen-test-vm-${VERSION//./-}.xen.gz" -curl --fail -s -L "$VM" > "$KERNEL" -``` + curl --fail -s -L "$VM" > "$KERNEL" # Installing the VM -The VM is built as `src/test-vm.xen` and available as binary +The VM is built as `src/test-vm.xen.gz` and available as binary release. The file goes into `/boot/guest` on a host: HOST=host @@ -44,17 +42,20 @@ XenCenter. # Building from Source Code -The code relies on some pinned OCaml packages in Opam. This dependency -cannot be expressed naturally in the depends section of an `opam` file. For -now, this requires to install the dependencies manually. Apart from that, -calling `make` will build `src/test-vm.xen` +The easiest way is to let opam manage the installation of dependencies: + opam pin add -n -y mirage-xen \ + git://github.com/jonludlam/mirage-platform#reenable-suspend-resume2 + + opam pin add -n -y mirage-bootvar-xen \ + git://github.com/jonludlam/mirage-bootvar-xen#better-parser + + opam pin add -n -y minios-xen \ + git://github.com/jonludlam/mini-os#suspend-resume3 - ./setup.sh # executes opam installations - make + opam pin add xen-test-vm . + opam install -v xen-test-vm -A `Dockerfile` can be used to create a Docker container environment for -compiling the VM. It is used for building on Travis. # Travis CI @@ -64,13 +65,13 @@ The VM is built on Travis using the [Dockerfile](./Dockerfile) - see the # Out-of-Band Control Messages -The kernel reads control messages from the Xen Store from -"control/shutdown" and responds to them. In addition, it reads from -"control/testing". +In addition to the shutdown messages sent by Xen, the kernel monitors +the Xen Store for messages. These are used to control the response to +shutdown messages. ## Shutdown Messages -The kernel responds to these messages in the "control/shutdown". Usually +The kernel responds to these messages in "control/shutdown". Usually the hypervisor only sends these. suspend @@ -78,37 +79,51 @@ the hypervisor only sends these. reboot halt crash - ignore + +All other messages are logged and ignored. ## Testing Messages -The kernel reads messages in "control/testing". Legal messages are: +The kernel reads messages in "control/testing". It acknowledges a +message by replacing the read message with the empty string. - now:suspend - now:poweroff - now:reboot - now:halt - now:crash - now:ignore +A message in "control/testing" is a JSON object: -Each makes the kernel respond to these immediately. In addition, these -messages are legal: + { "when": "now" // when to react + , "ack": "ok" // how to ack control/shutdown + , "action": "reboot" // how to react to control/shutdown + } - next:suspend - next:poweroff - next:reboot - next:halt - next:crash - next:ignore +Note that proper JSON does not permit _//_-style comments. The message +describes three aspects: -The next time the kernel receives a shutdown message, it ignores the -message it received and acts on the next:message instead. This permits -to surprise the hypervisor. +1. `"when"`: either `"now"` or `"onshutdown"`. The kernel will either + immediately or when then next shutdown message arrives perform the + `"action"`. -Typically, control/shutdown is written only by Xen. To write to -control/testing, use: +2. `"ack"`: either `"ok"`, `"none"`, `"delete"`, or something else. This + controls, how the kernel acknowledges the next shutdown message. + * `"ok"`: regular behavior + * `"none"`: don't acknowledge the message + * `"delete"`: delete "control/shutdown" + * `"something"`: write the string read to "control/shutdown" - xenstore write /local/domain//control/testing now:reboot +3. `"action"`: what do do (eiter now or on shutdown). The message in + `control/shutdown` is ignored and superseeded by the `action` field: + * `"suspend"`: suspend + * `"poweroff"`: power off + * `"reboot"`: reboot + * `"halt"`: halt + * `"crash"`: crash + * `"ignore"`: do nothing - ignore the message + +To write to `control/testing`, use: + + msg='{"when":"now","ack":"ok","action":"reboot"}' + xenstore write /local/domain//control/testing "$msg" + +The _domid_ is logged to the console and can be obtained through the Xen +API. # Debugging the VM @@ -118,4 +133,3 @@ To direct console output of the VM to a file, you can tell the $HOST: Output then goes to `/tmp/console.`. - diff --git a/descr b/descr deleted file mode 100644 index c75a668..0000000 --- a/descr +++ /dev/null @@ -1,4 +0,0 @@ -xen-test-vm - minimal VM kernel for testing Xen - -This code builds a minimal kernel (or VM) that can be run on a Xen -hypervisor for exercising tests. diff --git a/opam b/opam deleted file mode 100644 index b414ea5..0000000 --- a/opam +++ /dev/null @@ -1,24 +0,0 @@ -# -# This opem file currently does NOT reflect dependencies correctly -# as we cannot express directly a dependency on a pinned package. -# - -opam-version: "1.2" -name: "xen-test-vm" -version: "0.1" -maintainer: "Christian Lindig -authors: "Christian Lindig " -build: [ - [make] -] -install: [make "PREFIX=%{prefix}%" "install"] -remove: [make "PREFIX=%{prefix}%" "remove"] -available: [ ocaml-version >= "4.02.3" ] - -depends: [ - "mirage-xen" - "mirage-console" - "mirage-bootvar-xen" - "mirage" -] - diff --git a/opam/descr b/opam/descr new file mode 100644 index 0000000..b34ae69 --- /dev/null +++ b/opam/descr @@ -0,0 +1,6 @@ +xen-test-vm - minimal VM kernel for testing Xen + +This code builds a minimal kernel (or VM) that can be run on a Xen +hypervisor for exercising tests. The behaviour of the kernel can be +controlled with a JSON record that can be passed to the kernel via the +XenStore. diff --git a/opam/opam b/opam/opam new file mode 100644 index 0000000..391786b --- /dev/null +++ b/opam/opam @@ -0,0 +1,26 @@ +opam-version: "1.2" +name: "xen-test-vm" +version: "0.2" +maintainer: "Christian Lindig " +authors: "Christian Lindig " +build: [ + [make] +] +install: [ + make "PREFIX=%{prefix}%" "install" +] +remove: [ + make "PREFIX=%{prefix}%" "remove" +] +homepage: "https://github.com/lindig/xen-test-vm" +dev-repo: "https://github.com/lindig/xen-test-vm" +bug-reports: "https://github.com/lindig/xen-test-vm" + +depends: [ + "mirage-xen" + "mirage-console" + "mirage-bootvar-xen" + "mirage" + "yojson" +] + diff --git a/setup.sh b/setup.sh deleted file mode 100755 index ed2713c..0000000 --- a/setup.sh +++ /dev/null @@ -1,13 +0,0 @@ -#! /bin/sh - -opam pin add -n -y mirage-xen git://github.com/jonludlam/mirage-platform#reenable-suspend-resume - -opam pin add -n -y mirage-bootvar-xen git://github.com/jonludlam/mirage-bootvar-xen#better-parser - -opam pin add -n -y minios-xen git://github.com/jonludlam/mini-os#suspend-resume3 - - -opam install -q -y mirage-xen -opam install -q -y mirage-console -opam install -q -y mirage-bootvar-xen -opam install -q -y mirage diff --git a/src/Makefile b/src/Makefile index 6a7ec3f..b21a0a6 100644 --- a/src/Makefile +++ b/src/Makefile @@ -14,12 +14,13 @@ OCB = ocamlbuild -use-ocamlfind $(OCBOPTS) all: $(OCB) main.native.o ld -d -static -nostdlib $(LIBS) -o $(VM) - gzip $(VM) + gzip -f $(VM) LIBS += _build/main.native.o LIBS += -L$(OPAMLIB) LIBS += -L$(OPAMLIB)/minios-xen LIBS += -L$(OPAMLIB)/io-page +# LIBS += -L$(OPAMLIB)/yojson LIBS += $(OPAMLIB)/mirage-xen/libxencamlbindings.a LIBS += $(OPAMLIB)/mirage-xen-ocaml/libxenasmrun.a LIBS += $(OPAMLIB)/mirage-xen-ocaml/libxenotherlibs.a diff --git a/src/_tags b/src/_tags index 9011e88..df6ced2 100644 --- a/src/_tags +++ b/src/_tags @@ -1,6 +1,7 @@ true: package(functoria.runtime) true: package(mirage-bootvar) true: package(mirage-console.xen) +true: package(yojson) # true: package(mirage-types.lwt) # true: package(mirage-xen) diff --git a/src/commands.ml b/src/commands.ml new file mode 100644 index 0000000..0b8b09a --- /dev/null +++ b/src/commands.ml @@ -0,0 +1,62 @@ +(* vim: set et sw=2 ts=2 *) + +module Y = Yojson.Basic +module U = Yojson.Basic.Util + +exception Error of string +let error fmt = Printf.ksprintf (fun msg -> raise (Error msg)) fmt + +(** actions a guest can take *) +type action = + | Suspend + | PowerOff + | Reboot + | Halt + | Crash + | Ignore + +(** how is a control message from the host acknowledged by the guest *) +type ack = + | AckOK (* ack by putting empty string *) + | AckWrite of string (* ack by putting string *) + | AckNone (* don't ack *) + | AckDelete (* delete key /control/shutdown *) + +(** message to a guest *) +type t = + | Now of action + | OnShutdown of ack * action + +let action = function + | "suspend" -> Suspend + | "poweroff" -> PowerOff + | "reboot" -> Reboot + | "halt" -> Halt + | "crash" -> Crash + | "ignore" -> Ignore + | x -> error "unknown action: %s" x + +let do_when ack action = function + | "now" -> Now(action) + | "onshutdown"-> OnShutdown(ack, action) + | x -> error "unknown when: %s" x + +let ack = function + | "ok" -> AckOK + | "none" -> AckNone + | "delete" -> AckDelete + | x -> AckWrite(x) + +let from_string str = + try + let json = Y.from_string str in + let ack' = json |> U.member "ack" |> U.to_string |> ack in + let action' = json |> U.member "action" |> U.to_string |> action in + json + |> U.member "when" + |> U.to_string + |> do_when ack' action' + with + Yojson.Json_error msg -> error "bad json: %s" msg + + diff --git a/src/commands.mli b/src/commands.mli index e27945b..f6b5337 100644 --- a/src/commands.mli +++ b/src/commands.mli @@ -1,7 +1,8 @@ exception Error of string -type shutdown = +(** actions a guest can take *) +type action = | Suspend | PowerOff | Reboot @@ -9,21 +10,21 @@ type shutdown = | Crash | Ignore -type testing = - | Now of shutdown - | Next of shutdown +(** how is a control message from the host acknowledged by the guest *) +type ack = + | AckOK (* ack by putting empty string *) + | AckWrite of string (* ack by putting string *) + | AckNone (* don't ack *) + | AckDelete (* delete key /control/shutdown *) +(** message to a guest *) +type t = + | Now of action + | OnShutdown of ack * action -module Scan : sig - val shutdown: string -> shutdown - val testing: string -> testing -end -(** module [String] provides functions to turn commands back into - * strings - *) - module String : sig - val shutdown: shutdown -> string - val testing: testing -> string -end +(** [from_string str] reads a JSON object [str] and returns a [t] + * value that represens it *) +val from_string: string -> t (* Error *) + diff --git a/src/commands.mll b/src/commands.mll deleted file mode 100644 index 2b1296f..0000000 --- a/src/commands.mll +++ /dev/null @@ -1,57 +0,0 @@ -(** This module implements recognizers for commands and maps them from - * strings to a more abstract data type - *) - -{ - module L = Lexing - exception Error of string - - type shutdown = - | Suspend - | PowerOff - | Reboot - | Halt - | Crash - | Ignore - - type testing = - | Now of shutdown - | Next of shutdown -} - - rule shutdown = parse - | "suspend" { Suspend } - | "poweroff" { PowerOff } - | "reboot" { Reboot } - | "halt" { Halt } - | "crash" { Crash } - | "ignore" { Ignore } - | _ { raise (Error "unknown shutdown command") } - - and testing = parse - | "now:" { Now(shutdown lexbuf) } - | "next:" { Next(shutdown lexbuf) } - | _ { raise (Error "unknown side channel command") } - -{ - - module Scan = struct - let shutdown str = shutdown (L.from_string str) - let testing str = testing (L.from_string str) - end - - module String = struct - let shutdown = function - | Suspend -> "suspend" - | PowerOff -> "poweroff" - | Reboot -> "reboot" - | Halt -> "halt" - | Crash -> "crash" - | Ignore -> "ignore" - - let testing = function - | Now(msg) -> Printf.sprintf "now:%s" (shutdown msg) - | Next(msg) -> Printf.sprintf "next:%s" (shutdown msg) - end -} - diff --git a/src/mirage_vm.ml b/src/mirage_vm.ml index 4a8a884..40ddceb 100644 --- a/src/mirage_vm.ml +++ b/src/mirage_vm.ml @@ -27,33 +27,61 @@ module Main (C: V1_LWT.CONSOLE) = struct * formatting instructions. *) let log c fmt = Printf.kprintf (fun msg -> C.log_s c msg) fmt - + let ack' client path = XS.(immediate client @@ fun h -> write h path "") let read client path = XS.(immediate client @@ fun h -> read h path) - let ack client path = XS.(immediate client @@ fun h -> write h path "") + + (* [ack] acknowledges a message and offers to violate the proper + * protocol (AckOK) by doing something else *) + + let ack client path = function + | CMD.AckOK -> XS.(immediate client @@ fun h -> write h path "") + | CMD.AckWrite(x) -> XS.(immediate client @@ fun h -> write h path x ) + | CMD.AckNone -> return () (* do nothing *) + | CMD.AckDelete -> XS.(immediate client @@ fun h -> rm h path) + (* [read_opt client path] reads [path] from the Xen Store and * returns it as an option value on success, and [None] otherwise. - * Unexpected errors still raise an exception. + * A empty string is returned as [None] (and thus conflates + * no string and the empty string). Unexpected errors still raise an + * exception. *) let read_opt client path = Lwt.catch ( fun () -> - read client path >>= fun msg -> - return (Some msg) + read client path >>= + ( function + | "" -> return None (* XXX right design choice? *) + | msg -> return (Some msg) + ) ) ( function | Xs_protocol.Enoent _ -> return None | ex -> Lwt.fail ex ) + (** [read_cmd] reads a command in JSON format from [path] and + * returns it, or [None] when nothing is there *) + let read_cmd c client path = + read_opt client path >>= function + | None -> return None + | Some msg -> + ack' client path >>= fun () -> + Lwt.catch + (fun () -> return @@ Some (Commands.from_string msg)) + (function + | CMD.Error msg -> + log c "bogus command %s" msg >>= fun () -> return None + | x -> Lwt.fail x + ) let sleep secs = OS.Time.sleep secs let suspend () = OS.Sched.suspend () >>= fun _ -> return true - let poweroff () = OS.Sched.(shutdown Poweroff); return false - let reboot () = OS.Sched.(shutdown Reboot); return false - let halt () = OS.Sched.(shutdown Poweroff); return false - let crash () = OS.Sched.(shutdown Crash); return false + let poweroff () = OS.Sched.(shutdown Poweroff); return true + let reboot () = OS.Sched.(shutdown Reboot); return true + let halt () = OS.Sched.(shutdown Poweroff); return true + let crash () = OS.Sched.(shutdown Crash); return true (** [dispatch] implements the reaction to control messages *) let dispatch = function @@ -68,45 +96,53 @@ module Main (C: V1_LWT.CONSOLE) = struct (* event loop *) let start c = OS.Xs.make () >>= fun client -> - let rec loop tick override = - (* read control messages, honor override if present *) + let rec loop tick cmd = read_opt client control_shutdown >>= fun msg -> - ( match msg, override with - | Some "" , _ -> return false - | Some _ , Some override -> - ack client control_shutdown >>= fun () -> - dispatch override >>= fun _ -> - loop (tick+1) None (* clear override *) - | Some msg, None -> - ack client control_shutdown >>= fun () -> - dispatch (CMD.Scan.shutdown msg) - | None , _ -> - return false - ) >>= fun x -> - (* read out-of band test messages like now:reboot or - * next:reboot and register it as an override - *) - read_opt client control_testing >>= - ( function - | Some "" -> return x - | Some msg -> - ack client control_testing >>= fun () -> - ( match CMD.Scan.testing msg with - | CMD.Now(shutdown) -> dispatch shutdown - | CMD.Next(override) -> loop (tick+1) (Some override) - ) - | None -> return x + ( match cmd, msg with + + (* no testing command present, regular kernel behaviour *) + | None, None -> return true + | None, Some msg -> + ack' client control_shutdown >>= fun () -> + ( match msg with + | "suspend" -> suspend () + | "poweroff" -> poweroff () + | "reboot" -> reboot () + | "halt" -> halt () + | "crash" -> crash () + | x -> log c "unknown shutdown reason %s" x + >>= fun () -> return true + ) + + (* we have a command to execute and to remove it for the + * next iteration of the loop *) + | Some(CMD.Now(action)), _ -> + dispatch action >>= fun _ -> loop (tick+1) None + | Some(CMD.OnShutdown(a, action)), Some _ -> + ack client control_shutdown a >>= fun () -> + dispatch action >>= fun _ -> loop (tick+1) None + | Some(CMD.OnShutdown(_, _)), None -> + return true (* not yet - wait for shutdown message *) + ) >>= fun x -> + + (* read command, ack it, and store it for execution *) + read_cmd c client control_testing >>= + ( function + | Some cmd -> loop (tick+1) (Some cmd) + | None -> return x ) >>= fun _ -> - (* just some reporting *) + + (* report the current state *) sleep 1.0 >>= fun x -> read client "domid" >>= fun domid -> log c "domain %s tick %d" domid tick >>= fun () -> - ( match override with - | Some cmd -> log c "override %s is active" - (CMD.String.shutdown cmd) >>= fun _ -> return x + ( match cmd with + | Some _ -> log c "command is active" >>= fun _ -> return x | None -> return x ) >>= fun _ -> - loop (tick+1) override + + (* loop *) + loop (tick+1) cmd in loop 0 None end