Hackathon Trip Reports

Jul 18 2016 16 0 · By Gemma Gordon, Anil Madhavapeddy

opam update
opam upgrade mirage-net-xen
opam upgrade
opam reinstall mirage-net-xen=1.4.2
open Mirage
let main = foreign "Unikernel.Main" (console @-> job)
let () = register "console" [main $ default_console]
let lang_key =
  let doc = Key.Arg.info
      ~doc:"The default language for the unikernel." [ "l" ; "lang" ]
  in
  Key.(create "language" Arg.(opt ~stage:`Both string "en" doc))
       -l VAL, --lang=VAL (absent=en)
           The default language for the unikernel.
let fat_key =
  let doc = Key.Arg.info
      ~doc:"Use a fat device if true, crunch otherwise." [ "fat" ]
  in
  Key.(create "fat" Arg.(opt ~stage:`Configure bool false doc))
let dynamic_storage =
  if_impl (Key.value fat_key)
    (kv_ro_of_fs my_fat_device)
    (my_crunch_device)
       --fat=VAL (absent=false)
           Use a fat device if true, crunch otherwise.
open Mirage

let main = foreign "Unikernel.Main" (console @-> job)
let () = register "console" [main $ default_console]
let main =
  foreign "Unikernel.Main" ~deps:[abstract app_info] (console @-> job)
name: console
libraries: [functoria.runtime; lwt.syntax; mirage-console.unix;
            mirage-types.lwt; mirage.runtime; sexplib]
packages: [functoria.0.1; lwt.2.5.0; mirage-console.2.1.3; mirage-unix.2.3.1;
           sexplib.113.00.00]
val pkt_of_buf : Cstruct.t -> int -> [> `Error of string | `Ok of pkt ]
val buf_of_pkt : pkt -> Cstruct.t
type dhcp_option =
  | Subnet_mask of Ipaddr.V4.t
  | Time_offset of int32
  | Routers of Ipaddr.V4.t list
  | Time_servers of Ipaddr.V4.t list
  | Name_servers of Ipaddr.V4.t list
  | Dns_servers of Ipaddr.V4.t list
  | Log_servers of Ipaddr.V4.t list
type result = 
| Silence                 (* Input packet didn't belong to us, normal nop event. *)
| Reply of Dhcp_wire.pkt  (* A reply packet to be sent on the same subnet. *)
| Warning of string       (* An odd event, could be logged. *)
| Error of string         (* Input packet is invalid, or some other error ocurred. *)

val input_pkt : Dhcp_server.Config.t -> Dhcp_server.Config.subnet ->
   Dhcp_wire.pkt -> float -> result
(** input_pkt config subnet pkt time Inputs packet pkt, the resulting action
    should be performed by the caller, normally a Reply packet is returned and
    must be sent on the same subnet. time is a float representing time as in
    Unix.time or MirageOS's Clock.time. **)
  let input_dhcp c net config subnet buf =
    let open Dhcp_server.Input in
    match (Dhcp_wire.pkt_of_buf buf (Cstruct.len buf)) with
    | `Error e -> Lwt.return (log c (red "Can't parse packet: %s" e))
    | `Ok pkt ->
      match (input_pkt config subnet pkt (Clock.time ())) with
      | Silence -> Lwt.return_unit
      | Warning w -> Lwt.return (log c (yellow "%s" w))
      | Error e -> Lwt.return (log c (red "%s" e))
      | Reply reply ->
        log c (blue "Received packet %s" (Dhcp_wire.pkt_to_string pkt));
        N.write net (Dhcp_wire.buf_of_pkt reply)
        >>= fun () ->
        log c (blue "Sent reply packet %s" (Dhcp_wire.pkt_to_string reply));
        Lwt.return_unit
  type t = {
    addresses : (Ipaddr.V4.t * Macaddr.t) list;
    subnets : subnet list;
    options : Dhcp_wire.dhcp_option list;
    hostname : string;
    default_lease_time : int32;
    max_lease_time : int32;
  }

  val parse : string -> (Ipaddr.V4.Prefix.addr * Macaddr.t) list -> t
  (** [parse cf l] Creates a server configuration by parsing [cf] as an ISC
      dhcpd.conf file, currently only the options at [sample/dhcpd.conf] are
      supported. [l] is a list of network addresses, each pair is the output
      address to be used for building replies and each must match a [network
      section] of [cf]. A normal usage would be a list of all interfaces
      configured in the system *)
opam pin add certify https://github.com/yomimono/ocaml-certify.git
opam install certify
selfsign -c secrets/server.pem -k secrets/server.key -d 365 totallyradhttpsunikernel.example
csr -c server.csr -k server.key totallyradhttpsunikernel.example "Rad Unikernel Construction, Ltd."
cat signed_cert.pem intermediate_certs.pem > server.pem
cat intermediate.pem cert.pem > server.pem
opam install mirage-seal
mirage-seal --data=/home/me/coolwebsite/public --keys=/home/me/coolwebsite/secrets -t xen
sudo xl create seal.xl -c
opam install lwt tls cohttp
export CONDUIT_TLS=native
cohttp-server-lwt -c <certfile> -p <port> <directory>
778 files changed, 1949 insertions(+), 59689 deletions(-)
$ opam init
$ opam install mirage-xen-minios
$ opam remote add mirage-dev git://github.com/mirage/mirage-dev
$ opam install mirage
module type VIEW = sig
  type t

  val create: unit -> t Lwt.t
  (** Create a fresh VIEW from the current state of the store.
      A VIEW tracks state queries and updates and acts like a branch
      which has an explicit [merge]. *)

  val read: t -> Protocol.Path.t -> 
    [ `Ok of Node.contents | `Enoent of Protocol.Path.t ] Lwt.t
  (** Read a single key *)

  val list: t -> Protocol.Path.t -> 
    [ `Ok of string list | `Enoent of Protocol.Path.t ] Lwt.t
  (** List all the children of a key *)

  val write: t -> Protocol.Path.t -> Node.contents -> 
    [ `Ok of unit ] Lwt.t
  (** Update a single key *)

  val mem: t -> Protocol.Path.t -> bool Lwt.t
  (** Check whether a key exists *)

  val rm: t -> Protocol.Path.t -> [ `Ok of unit ] Lwt.t
  (** Remove a key *)

  val merge: t -> string -> bool Lwt.t
  (** Merge this VIEW into the current state of the store *)
end
    let open Irmin_unix in
    let module Git = IrminGit.FS(struct
      let root = Some filename
      let bare = true
    end) in
    let module DB = Git.Make(IrminKey.SHA1)(IrminContents.String)(IrminTag.String) in
    DB.create () >>= fun db ->
    let module V = struct
      type t = DB.View.t
      let create = DB.View.create
      let write t path contents =
        DB.View.update t (value_of_filename path) (Sexp.to_string (Node.sexp_of_contents contents))
      (* omit read,list,write,rm for brevity *)
      let merge t origin =
        let origin = IrminOrigin.create "%s" origin in
        DB.View.merge_path ~origin db [] t >>= function
        | `Ok () -> return true
        | `Conflict msg ->
          info "Conflict while merging database view: %s" msg;
          return false
    end in
$ git log --pretty=oneline --abbrev-commit --graph
* 2578013 Closing connection -1 to domain 0
* d4728ba Domain 0: rm /bench/local/domain/0/backend/vbd/10 = ()
* 4b55c99 Domain 0: directory /bench/local/domain/0/backend = [ vbd ]
* a71a903 Domain 0: rm /bench/local/domain/10 = ()
* f267b31 Domain 0: rm /bench/vss/uuid-10 = ()
* 94df8ce Domain 0: rm /bench/vm/uuid-10 = ()
* 0abe6b0 Domain 0: directory /bench/vm/uuid-10/domains = [  ]
* 06ddd3b Domain 0: rm /bench/vm/uuid-10/domains/10 = ()
* 1be2633 Domain 0: read /bench/local/domain/10/vss = /bench/vss/uuid-10
* 237a8e4 Domain 0: read /bench/local/domain/10/vm = /bench/vm/uuid-10
* 49d70f6 Domain 0: directory /bench/local/domain/10/device = [  ]
*   ebf4935 Merge view to /
|\
| * e9afd9f Domain 0: read /bench/local/domain/10 =
* | c4e0fa6 Domain 0: merging transaction 375
|/
$ git show bd44e03
commit bd44e0388696380cafd048eac49474f68d41bd3a
Author: 448 <irminsule@openmirage.org>
Date:   Thu Jan 1 00:09:26 1970 +0000

    Domain 0: merging transaction 363

diff --git a/*0/bench.dir/local.dir/domain.dir/7.dir/control.dir/shutdown.value b/*0/bench.dir/local.dir/domain.dir/7.dir/control.dir/shutdown.value
new file mode 100644
index 0000000..aa38106
--- /dev/null
+++ b/*0/bench.dir/local.dir/domain.dir/7.dir/control.dir/shutdown.value
@@ -0,0 +1 @@
+((creator 0)(perms((owner 7)(other NONE)(acl())))(value halt))
  sudo apt-get install libxen-dev xenstore-utils opam build-essential m4
  opam init
  opam update
  opam switch 4.01.0
  opam install lwt irmin git sexplib cstruct uri sexplib cmdliner xen-evtchn shared-memory-ring io-page ounit
  git clone git://github.com/mirage/ocaml-xenstore-server
  cd ocaml-xenstore-server
  make
  ./main.native --database /tmp/db --enable-unix --path /tmp/xenstored
  export XENSTORED_PATH=/tmp/xenstored
  xenstore-write -s /one/two/three 4 /five/six/seven 8
  xenstore-ls -s /
  cd /tmp/db
  git log
type t
(** The type for Irmin block store. *)

type key
(** The type for Irmin pointers *)

type value = ...
(** The type for Irmin blocks *)

val read: t -> key -> value option
(** [read t k] is the block stored at the location [k] of the
store. It is [None] if no block is available at that location. *)

val add: t -> key -> value -> t
(** [add t k v] is the *new* store storing the block [v] at the
location [k]. *)
type t
(** The type for Irmin store. *)

type tag
(** Mutable tags *)

type key = ...
(** The type for user-defined keys (for instance a list of strings) *)

type value = ...
(** The type for user-defined values *)

val read: t -> ?branch:tag -> key -> value option
(** [read t ?branch k] reads the contents of the key [k] in the branch
[branch] of the store [t]. If no branch is specified, then use the
["HEAD"] one. *)

val update: t -> ?branch:tag -> key -> value -> unit
(** [update t ?branch k v] *updates* the branch [branch] of the store
[t] the association of the key [key] to the value [value]. *)
type t = int
(** distributed counters are just normal integers! *)

let merge ~old t1 t2 = old + (t1-old) + (t2-old)
(** Merging counters means:
   - computing the increments of the two states [t1] and [t2]
     relatively to the initial state [old]; and
   - and add these two increments to [old]. *)
(** Single network stack *)                                                     
module type STACKV4 = STACKV4                                                   
  with type 'a io = 'a Lwt.t                                                    
   and type ('a,'b,'c) config = ('a,'b,'c) stackv4_config                       
   and type ipv4addr = Ipaddr.V4.t                                              
   and type buffer = Cstruct.t 
    val listen_udpv4 : t -> port:int -> UDPV4.callback -> unit
    val listen_tcpv4 : t -> port:int -> TCPV4.callback -> unit
    val listen : t -> unit io
    module UDPV4 :
      sig
        type callback =
            src:ipv4addr -> dst:ipv4addr -> src_port:int -> buffer -> unit io
        val input :
          listeners:(dst_port:int -> callback option) -> t -> ipv4input
        val write :
          ?source_port:int ->
          dest_ip:ipv4addr -> dest_port:int -> t -> buffer -> unit io
    module TCPV4 :
      sig
        type flow
        type callback = flow -> unit io
        val read : flow -> [ `Eof | `Error of error | `Ok of buffer ] io
        val write : flow -> buffer -> unit io
        val close : flow -> unit io
        val create_connection :
          t -> ipv4addr * int -> [ `Error of error | `Ok of flow ] io
        val input : t -> listeners:(int -> callback option) -> ipv4input
module STACKV4_direct: CONFIGURABLE with                                        
  type t = console impl * network impl * [`DHCP | `IPV4 of ipv4_config]         
                                                                                
module STACKV4_socket: CONFIGURABLE with                                        
  type t = console impl * Ipaddr.V4.t list  
let main = foreign "Services.Main" (console @-> stackv4 @-> job)

let net =
  try match Sys.getenv "NET" with
    | "direct" -> `Direct
    | "socket" -> `Socket
    | _        -> `Direct
  with Not_found -> `Direct

let dhcp =
  try match Sys.getenv "ADDR" with
    | "dhcp"   -> `Dhcp
    | "static" -> `Static
    | _ -> `Dhcp
  with Not_found -> `Dhcp

let stack console =
  match net, dhcp with
  | `Direct, `Dhcp   -> direct_stackv4_with_dhcp console tap0
  | `Direct, `Static -> direct_stackv4_with_default_ipv4 console tap0
  | `Socket, _       -> socket_stackv4 console [Ipaddr.V4.any]

let () =
  register "services" [
    main $ default_console $ stack default_console
  ]
let client = foreign "Unikernel.Client" (console @-> stackv4 @-> job)
let server = foreign "Unikernel.Server" (console @-> stackv4 @-> job) 

let client_netif = (netif "0")
let server_netif = (netif "1") 

let client_stack = direct_stackv4_with_dhcp default_console client_netif
let server_stack = direct_stackv4_with_dhcp default_console server_netif

let () = 
  register "unikernel" [
    main $ default_console $ client_stack;
    server $ default_console $ server_stack 
  ]


open Lwt
open V1_LWT

module Main (C: V1_LWT.CONSOLE) (S: V1_LWT.STACKV4) = struct
  let report_and_close c flow message =
    C.log c message;
    S.TCPV4.close flow

  let rec echo c flow =
    S.TCPV4.read flow >>= fun result -> (
      match result with  
        | `Eof -> report_and_close c flow "Echo connection closure initiated."
        | `Error e -> 
          let message = 
          match e with 
            | `Timeout -> "Echo connection timed out; closing.\n"
            | `Refused -> "Echo connection refused; closing.\n"
            | `Unknown s -> (Printf.sprintf "Echo connection error: %s\n" s)
             in
          report_and_close c flow message
        | `Ok buf ->
            S.TCPV4.write flow buf >>= fun () -> echo c flow
        ) 

  let start c s = 
    S.listen_tcpv4 s ~port:7 (echo c);
    S.listen s

end
$ sudo lvs
   LV     VG      Attr      LSize  Pool Origin Data%  Move Log Copy%  Convert
   root   st28-vg -wi-ao--- 37.25g
   swap_1 st28-vg -wi-ao---  7.99g
$ sudo apt-get install xen-system-amd64
$ sudo xl list
Name                                        ID   Mem VCPUs      State   Time(s)
Domain-0                                     0  7958     6     r-----       9.7
$ sudo xenstore-write /local/domain/0/memory/target 4096000
$ sudo xl list
Name                                        ID   Mem VCPUs      State   Time(s)
Domain-0                                     0  4000     6     r-----      12.2
GRUB_CMDLINE_XEN_DEFAULT="dom0_mem=4096M,max:4096M"
$ sudo apt-get install ocaml opam ocaml-native-compilers camlp4-extra
...
$ opam init
...
$ eval `opam config env`
$ sudo apt-get install m4 libxen-dev
$ opam install mirage mirage-xen mirage-unix vchan
$ git clone https://github.com/mirage/ocaml-vchan
let (>>=) = Lwt.bind

let (>>|=) m f = m >>= function
| `Ok x -> f x
| `Eof -> Lwt.fail (Failure "End of file")
| `Error (`Not_connected state) ->
    Lwt.fail (Failure (Printf.sprintf "Not in a connected state: %s"
      (Sexplib.Sexp.to_string (Node.V.sexp_of_state state))))

let rec echo vch =
  Node.V.read vch >>|= fun input_line ->
  let line = String.uppercase (Cstruct.to_string input_line) in
  let buf = Cstruct.create (String.length line) in
  Cstruct.blit_from_string line 0 buf 0 (String.length line);
  Node.V.write vch buf >>|= fun () ->
  echo vch
$ make
...
$ ls -l node_cli.native
lrwxrwxrwx 1 jludlam jludlam 52 Jul 14 14:56 node_cli.native -> /home/jludlam/ocaml-vchan/_build/cli/node_cli.native
$ cd test
$ mirage configure --xen
...
$ make depend
...
$ make
...
$ ls -l mir-echo.xen echo.xl
-rw-rw-r-- 1 jludlam jludlam     596 Jul 14 14:58 echo.xl
-rwxrwxr-x 1 jludlam jludlam 3803982 Jul 14 14:59 mir-echo.xen
$ sudo xl create -c echo.xl
Parsing config from echo.xl
kernel.c: Mirage OS!
kernel.c:   start_info: 0x11cd000(VA)
kernel.c:     nr_pages: 0x10000
kernel.c:   shared_inf: 0xdf2f6000(MA)
kernel.c:      pt_base: 0x11d0000(VA)
kernel.c: nr_pt_frames: 0xd
kernel.c:     mfn_list: 0x114d000(VA)
kernel.c:    mod_start: 0x0(VA)
kernel.c:      mod_len: 0
kernel.c:        flags: 0x0
kernel.c:     cmd_line:
x86_setup.c:   stack:      0x144f40-0x944f40
mm.c: MM: Init
x86_mm.c:       _text: 0x0(VA)
x86_mm.c:      _etext: 0xb8eec(VA)
x86_mm.c:    _erodata: 0xde000(VA)
x86_mm.c:      _edata: 0x1336f0(VA)
x86_mm.c: stack start: 0x144f40(VA)
x86_mm.c:        _end: 0x114d000(VA)
x86_mm.c:   start_pfn: 11e0
x86_mm.c:     max_pfn: 10000
x86_mm.c: Mapping memory range 0x1400000 - 0x10000000
x86_mm.c: setting 0x0-0xde000 readonly
x86_mm.c: skipped 0x1000
mm.c: MM: Initialise page allocator for 0x1256000 -> 0x10000000
mm.c: MM: done
x86_mm.c: Pages to allocate for p2m map: 2
x86_mm.c: Used 2 pages for map
x86_mm.c: Demand map pfns at 10001000-2010001000.
Initialising timer interface
Initializing Server domid=0 xs_path=data/vchan
gnttab_stubs.c: gnttab_table mapped at 0x10001000
Server: right_order = 13, left_order = 13
allocate_buffer_locations: gntref = 9
allocate_buffer_locations: gntref = 10
allocate_buffer_locations: gntref = 11
allocate_buffer_locations: gntref = 12
Writing config into the XenStore
Shared page is:

00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
0d 00 0d 00 02 01 01 00 09 00 00 00 0a 00 00 00
0b 00 00 00 0c 00 00 00
Initialization done!
$ sudo xl list
Name                                        ID   Mem VCPUs      State   Time(s)
Domain-0                                     0  4095     6     r-----    1602.9
echo                                         2   256     1     -b----       0.0
$ sudo ./node_cli.native 2
Client initializing: Received gntref = 8, evtchn = 4
Mapped the ring shared page:

00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
0d 00 0d 00 02 01 01 00 09 00 00 00 0a 00 00 00
0b 00 00 00 0c 00 00 00
Correctly bound evtchn number 71
hello from dom0
HELLO FROM DOM0
$ sudo xl destroy test
let puts = foreign "puts" (string @-> returning int)
# puts "Hello, world";;
Hello, world
- : int = 13
struct xml_ParserStruct;
typedef xml_ParserStruct *xml_Parser;
let parser_struct : [`XML_ParserStruct] structure typ = structure "xml_ParserStruct"
let xml_Parser = ptr parser_struct
let parser_create = foreign "XML_ParserCreate"
  (ptr void @-> returning xml_Parser)
let parser_free = foreign "XML_ParserFree"
  (xml_Parser @-> returning void)
typedef void (*start_handler)(void *, char *, char **);
typedef void (*end_handler)(void *, char *);
let start_handler =
  funptr (ptr void @-> string @-> ptr string @-> returning void)
let end_handler =
  funptr (ptr void @-> string @-> returning void)
let set_element_handler = foreign "XML_SetElementHandler"
  (xml_Parser @-> start_handler @-> end_handler @-> returning void)
val set_element_handler :
  [ `XML_ParserStruct ] structure ptr ->
  (unit ptr -> string -> string ptr -> unit) ->
  (unit ptr -> string -> unit) -> unit
let parse = foreign "XML_Parse"
  (xml_Parser @-> string @-> int @-> int @-> returning int)
let parse_string ~start_handler ~end_handler s =
  let p = parser_create null in
  let () = set_element_handler p start_handler end_handler in
  let _ = parse p s (String.length s) 1 in
  parser_free p
let depth = ref 0

let start_handler _ name _ =
  Printf.printf "%*s%s\n" (!depth * 3) "" name;
  incr depth

let end_handler _ _ =
  decr depth

let () =
  parse_string ~start_handler ~end_handler (In_channel.input_all stdin)
$ ocamlfind opt -thread -package core,ctypes.foreign expat_example.ml \
   -linkpkg -cclib -lexpat -o expat_example
$ wget -q http://openmirage.org/blog/atom.xml -O /dev/stdout \
  | ./expat_example
feed
   id
   title
   subtitle
   rights
   updated
   link
   link
   contributor
      email
      uri
      name
[...]
module Bindings(F : FOREIGN) =
struct
  let parser_create = F.foreign "XML_ParserCreate"
    (ptr void @-> returning xml_Parser)
  let parser_free = F.foreign "XML_ParserFree"
    (xml_Parser @-> returning void)
  let set_element_handler = F.foreign "XML_SetElementHandler"
    (xml_Parser @-> start_handler @-> end_handler @-> returning void)
  let parse = F.foreign "XML_Parse"
    (xml_Parser @-> string @-> int @-> int @-> returning int)
end
Cstubs.write_c formatter ~prefix:"expat" ~bindings:(module Bindings)
Cstubs.write_ml formatter ~prefix:"expat" ~bindings:(module Bindings)
memcpy(p, q, SIZE_MAX)
# StringLabels.blit ~src ~dst ~src_pos:0 ~dst_pos:0 ~len:max_int;;
Exception: Invalid_argument "String.blit".
type state

type ret = [
  | `Ok of [ `Ok of state | `Eof | `Alert of alert ] *
      [ `Response of Cstruct.t ] * [ `Data of Cstruct.t option ]
  | `Fail of alert * [ `Response of Cstruct.t ]
]

val handle_tls : state -> Cstruct.t -> ret
val client : Config.client -> (state * Cstruct.t)
val server : Config.server -> state
module Server (Stack: STACKV4) (Entropy: ENTROPY) (KV: KV_RO) =
struct

  module TLS  = Tls_mirage.Make (Stack.TCPV4) (Entropy)
  module X509 = Tls_mirage.X509 (KV) (Clock)

  let accept conf flow =
    TLS.server_of_tcp_flow conf flow >>= function
    | `Ok tls ->
      TLS.read tls >>= function
      | `Ok buf ->
        TLS.write tls buf >>= fun () -> TLS.close buf

  let start stack e kv =
    TLS.attach_entropy e >>= fun () ->
    lwt authenticator = X509.authenticator kv `Default in
    let conf          = Tls.Config.server_exn ~authenticator () in
    Stack.listen_tcpv4 stack 4433 (accept conf) ;
    Stack.listen stack

end
let main host port =
  Tls_lwt.rng_init () >>= fun () ->
  lwt authenticator = X509_lwt.authenticator (`Ca_dir nss_trusted_ca_dir) in
  lwt (ic, oc)      = Tls_lwt.connect ~authenticator (host, port) in
  let req = String.concat "\r\n" [
    "GET / HTTP/1.1" ; "Host: " ^ host ; "Connection: close" ; "" ; ""
  ] in
  Lwt_io.(write oc req >>= fun () -> read ic >>= print)
-- Simple name bindings
UniqueIdentifier ::= BIT STRING

-- Products
Validity ::= SEQUENCE {
  notBefore Time,
  notAfter  Time
}

-- Sums
Time ::= CHOICE {
  utcTime     UTCTime,
  generalTime GeneralizedTime
}
Pair ::= SEQUENCE {
  car Value,
  cdr Value
}

Value ::= CHOICE {
  v_str UTF8String,
  v_int INTEGER
}
  30         - SEQUENCE            30         - SEQUENCE
  08         - length              0c         - length
  [ 0c       - UTF8String          [ 2c       - UTF8String, compound
    03       - length                07       - length
    [ 66     - 'f'                   [ 0c     - UTF8String
      6f     - 'o'                     01     - length
      6f ]   - 'o'                     [ 66 ] - 'f'
    02       - INTEGER                 0c     - UTF8String
    01       - length                  02     - length
    [ 2a ] ] - 42                      [ 6f   - 'o'
                                         6f ] - 'o'
                                     02       - INTEGER
                                     01       - length
                                     [ 2a ] ] - 42
( (pa : a t) >>= fun (a : a) ->
  (pb : b t) >>= fun (b : b) ->
  return (b, b, a) ) : (b * b * a) t
( (fun a b -> (b, b, a))
  <$> (pa : a t)
  <*> (pb : b t) ) : (b * b * a) t
val gen_time : gen_time t
val utc_time : utc_time t
val choice   : 'a t -> 'b t -> ('a, 'b) choice t
val sequence : 'a t -> 'b t -> ('a * 'b) t
type time = (gen_time, utc_time) choice
let time     : time t          = choice gen_time utc_time
let validity : (time * time) t = sequence time time
val required : 'a t -> 'a element
val optional : 'a t -> 'a option element
val ( -@ )   : 'a element -> 'b element -> ('a * 'b) sequence
val ( @ )    : 'a element -> 'a sequence -> ('a * 'b) sequence
val sequence : 'a sequence -> 'a t
Triple ::= SEQUENCE {
  a INTEGER,
  b BOOLEAN,
  c BOOLEAN OPTIONAL
}
let triple : (int * (bool * bool option)) t =
  sequence (
      required int
    @ required bool
   -@ optional bool
  )
val map : ('a -> 'b) -> ('b -> 'a) -> 'a t -> 'b t
type 'a p = string -> 'a * string

let bool : bool p = fun str -> (s.[0] <> "\000", tail_of_string str)
type 'a t =
  | Bool
  ...

let boolean : bool t = Bool
type _ t =
  | Bool   : bool t
  | Pair   : ('a t * 'b t) -> ('a * 'b) t
  | Choice : ('a t * 'b t) -> ('a, 'b) choice t
  ...
let rec list = choice null (pair int list)
val fix : ('a t -> 'a t) -> 'a t
let list = fix @@ fun list -> choice null (pair int list)
type _ t =
  | Fix : ('a t -> 'a t) -> 'a t
  ...
let unique_identifier = bit_string_cs

let time =
  map (function `C1 t -> t | `C2 t -> t) (fun t -> `C2 t)
      (choice2 utc_time generalized_time)

let validity =
  sequence2
    (required ~label:"not before" time)
    (required ~label:"not after"  time)
val choice2 : 'a t -> 'b t -> [ `C1 of 'a | `C2 of 'b ] t
lwt authenticator = X509_lwt.authenticator (`Ca_dir ca_cert_dir) in
lwt (ic, oc) =
  Tls_lwt.connect_ext
    (Tls.Config.client_exn ~authenticator ())
    (host, port)
match
 X509.Authenticator.authenticate ?host:server_name authenticator stack
with
 | `Fail SelfSigned         -> fail Packet.UNKNOWN_CA
 | `Fail NoTrustAnchor      -> fail Packet.UNKNOWN_CA
 | `Fail CertificateExpired -> fail Packet.CERTIFICATE_EXPIRED
 | `Fail _                  -> fail Packet.BAD_CERTIFICATE
 | `Ok                      -> return server_cert
type tBSCertificate = {
  version    : [ `V1 | `V2 | `V3 ] ;
  serial     : Z.t ;
  signature  : Algorithm.t ;
  issuer     : Name.dn ;
  validity   : Time.t * Time.t ;
  subject    : Name.dn ;
  pk_info    : PK.t ;
  issuer_id  : Cstruct.t option ;
  subject_id : Cstruct.t option ;
  extensions : (bool * Extension.t) list
}

type certificate = {
  tbs_cert       : tBSCertificate ;
  signature_algo : Algorithm.t ;
  signature_val  : Cstruct.t
}
let key = "abcd1234abcd1234"
and iv  = "1234abcd1234abcd"
and msg = "fire the missile"

let aes     = new Cryptokit.Block.aes_encrypt key
let aes_cbc = new Cryptokit.Block.cbc_encrypt ~iv aes

let cip =
  let size =
    int_of_float (ceil (float String.(length msg) /. 16.) *. 16.) in
  String.create size

let () = aes_cbc#transform msg 0 cip 0
let md5 = Cryptokit.Hash.md5 ()

let s1 = Cryptokit.hash_string md5 "bacon"
let s2 = Cryptokit.hash_string md5 "bacon"
let s3 = Cryptokit.hash_string md5 "bacon"

(*
  s1 = "x\019%\142\248\198\1822\221\232\204\128\246\189\166/"
  s2 = "'\\F\017\234\172\196\024\142\255\161\145o\142\128\197"
  s3 = "'\\F\017\234\172\196\024\142\255\161\145o\142\128\197"
*)
void rijndaelEncrypt(const unsigned long *rk, int nrounds,
  const unsigned char plaintext[16], unsigned char ciphertext[16]);

void rijndaelDecrypt(const unsigned long *rk, int nrounds,
  const unsigned char ciphertext[16], unsigned char plaintext[16]);
open Nocrypto.Block

let key = AES.CBC.of_secret Cstruct.(of_string "abcd1234abcd1234")
and iv  = Cstruct.of_string "1234abcd1234abcd"
and msg = Cstruct.of_string "fire the missile"

let { AES.CBC.message ; iv } = AES.CBC.encrypt ~key ~iv msg
let () =
  let main = foreign "Unikernel.Block_test" (console @-> block @-> job) in
  let img = block_of_file "disk.img" in
  register "block_test" [main $ default_console $ img]
module Main (C: CONSOLE) (N: NETWORK) = struct

  module E = Ethif.Make(N)
  module I = Ipv4.Make(E)
  module U = Udpv4.Make(I)
  module T = Tcpv4.Flow.Make(I)(OS.Time)(Clock)(Random)
  module D = Dhcp_clientv4.Make(C)(OS.Time)(Random)(E)(I)(U)
  
    opam install mirari mirage-xen mirage vchan
    git clone git://github.com/mirage/ocaml-vchan
    cd test
    mirari configure --xen --no-install
    mirari build --xen
    sudo mirari run --xen
    ./vchan-node2 client <domid>/local/domain/<domid>/data/vchan
  opam init
  eval `opam config env`
  opam remote add mirage-dev git://github.com/mirage/opam-repo-dev
  opam remote add xapi-dev git://github.com/xapi-project/opam-repo-dev
  opam install xen-disk
  xen-disk connect <vmname>
  git clone git://github.com/mirage/xen-disk
  cd xen-disk
  make
type configuration = {
  filename: string;      (** path where the data will be stored *)
  format: string option; (** format of physical data *)
}
(** Information needed to "open" a disk *)

module type S = sig
  (** A concrete mechanism to access and update a virtual disk. *)

  type t
  (** An open virtual disk *)

  val open_disk: configuration -> t option Lwt.t
  (** Given a configuration, attempt to open a virtual disk *)

  val size: t -> int64
  (** [size t] is the size of the virtual disk in bytes. The actual
      number of bytes stored on media may be different. *)

  val read: t -> Cstruct.t -> int64 -> int -> unit Lwt.t
  (** [read t buf offset_sectors len_sectors] copies [len_sectors]
      sectors beginning at sector [offset_sectors] from [t] into [buf] *)

  val write: t -> Cstruct.t -> int64 -> int -> unit Lwt.t
  (** [write t buf offset_sectors len_sectors] copies [len_sectors]
      sectors from [buf] into [t] beginning at sector [offset_sectors]. *)
end
  let open_disk configuration =
    let fd = Unix.openfile configuration.filename [ Unix.O_RDONLY ] 0o0 in
    let stats = Unix.LargeFile.fstat fd in
    let mmap = Lwt_bytes.map_file ~fd ~shared:false () in
    Unix.close fd;
    return (Some (stats.Unix.LargeFile.st_size, Cstruct.of_bigarray mmap))
  let read (_, mmap) buf offset_sectors len_sectors =
    let offset_sectors = Int64.to_int offset_sectors in
    let len_bytes = len_sectors * sector_size in
    let offset_bytes = offset_sectors * sector_size in
    Cstruct.blit mmap offset_bytes buf 0 len_bytes;
    return ()

  let write (_, mmap) buf offset_sectors len_sectors =
    let offset_sectors = Int64.to_int offset_sectors in
    let offset_bytes = offset_sectors * sector_size in
    let len_bytes = len_sectors * sector_size in
    Cstruct.blit buf 0 mmap offset_bytes len_bytes;
    return () 
  dd if=/dev/zero of=disk.raw bs=1M seek=1024 count=1
  losetup /dev/loop0 disk.raw
  mkfs.ext3 /dev/loop0
  losetup -d /dev/loop0

  dist/build/xen-disk/xen-disk connect <myvm> --path disk.raw
  # dd if=/dev/xvdb of=/dev/null bs=1M iflag=direct count=100
  100+0 records in
  100+0 records out
  104857600 bytes (105 MB) copied, 0.125296 s, 837 MB/s
    type t
    val read: t -> string -> int -> int -> int Lwt.t
    val write: t -> string -> int -> int -> unit Lwt.t
    val destroy: t -> unit Lwt.t
    apt-get install ocaml build-essential git curl rsync
    git clone git://github.com/OCamlPro/opam.git
    cd opam
    make
    make install
    cd ..
    opam --yes init
    eval `opam config -env`
    opam remote -add dev git://github.com/mirage/opam-repo-dev
    opam --yes switch -install 3.12.1+mirage-xen
    opam --yes switch 3.12.1+mirage-xen
    eval `opam config -env`
    opam --yes install xenstore
    opam --yes install mirage
    git clone git://github.com/djs55/ocaml-xenstore-xen
    cd ocaml-xenstore-xen
    make
    init-xenstore-domain /path/to/server_xen.xen 256 flask_label
type mac_switch = {
  addr: OP.eaddr; 
  switch: OP.datapath_id;
}

type switch_state = {
  mutable mac_cache: 
        (mac_switch, OP.Port.t) Hashtbl.t;
  mutable dpid: OP.datapath_id list
}

let switch_data = {
  mac_cache = Hashtbl.create 7; 
  dpid = [];
} 

let join_cb controller dpid evt =
  let dp = match evt with
      | OE.Datapath_join c -> c
      | _ -> invalid_arg "bogus datapath_join"
  in 
  switch_data.dpid <- switch_data.dpid @ [dp]

let packet_in_cb controller dpid evt =
  (* algorithm details omitted for space *)

let init ctrl = 
  OC.register_cb ctrl OE.DATAPATH_JOIN join_cb;
  OC.register_cb ctrl OE.PACKET_IN packet_in_cb

let main () =
  Net.Manager.create (fun mgr interface id ->
    let port = 6633 in 
    OC.listen mgr (None, port) init
  )
  val return : 'a -> 'a Lwt.t 
  val bind : 'a Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t
  val run : 'a Lwt.t -> 'a
  val sleep: int -> unit Lwt.t
  let x = sleep 5 in
  let y = bind x (fun () -> print_endline "awake!") in
  run y
  lwt x = sleep 5 in
  print_endline "awake"
  val start: (unit -> 'a) -> 'a Lwt.t
  val await : 'a Lwt.t -> 'a
  module Fiber = struct
    let basic fn yields =
      for i = 1 to 15000 do
        for x = 1 to yields do
          Lwt_fiber.await (fn ())
        done
      done

    let run fn yields =
      Lwt_fiber.start (fun () -> basic fn yields)
  end
  module LWT = struct
    let basic fn yields =
      for_lwt i = 1 to 15000 do
        for_lwt x = 1 to yields do
          fn ()
        done
      done
  
    let run = basic
  end
  module Fiber = struct
    let recurse fn depth =
      let rec sum n = 
        Lwt_fiber.await (fn ());
        match n with
        |0 -> 0
        |n -> n + (sum (n-1)) 
      in
      for i = 1 to 15000 do
        ignore(sum depth)
      done

    let run fn depth = 
      Lwt_fiber.start (fun () -> recurse fn depth)
  end
  module LWT = struct
    let recurse fn depth =
      let rec sum n =
        lwt () = fn () in
        match n with
        |0 -> return 0
        |n ->
          lwt n' = sum (n-1) in 
          return (n + n')
      in
      for_lwt i = 1 to 15000 do
        lwt res = sum depth in
        return ()
      done

   let run = recurse
  end
  module Fiber = struct
    let recurse fn depth =
      let rec sum n = 
        match n with
        |0 -> Lwt_fiber.await (fn ()); 0
        |n -> n + (sum (n-1)) 
      in
      for i = 1 to 15000 do
        ignore(sum depth)
      done

    let run fn depth = 
      Lwt_fiber.start (fun () -> recurse fn depth)
  end
  let recurse fn depth =
    let rec sum n =
      match n with
      | 0 -> 
          fn () >> return 0
      | n ->
          lwt n' = sum (n-1) in 
          return (n + n') in
  let recurse fn depth =
    let rec sum n =
      match n with
      | 0 ->
          Lwt.bind (fn ()) (fun _ -> return 0)
      | n ->
          let __pa_lwt_0 = sum (n - 1)
          in Lwt.bind __pa_lwt_0 (fun n' -> return (n + n')) in

Virtual address	Physical address (IPA)	Purpose
400000	40000000	Stack (16 KB)
404000	40004000	Translation tables (16 KB)
408000	40008000	Kernel image

The MirageOS Blogon building functional operating systems

Solo5/MirageOS integration (KVM-based backend)

Onboarding new MirageOS/OCaml users

Packaging

ARM and Cubieboards

MirageOS 3.0 API changes

Error logging

Ctypes 0.7.0 release

P2P key-value store over DataKit

Developer experience improvements

Windows Support

General Libraries and utilities

Hackathon Trip Reports

Trip Report

MirageOS hackathon in Marrakech

Setting up and settling in

My week inside the camel's nest

Conclusion

MirageOS + OCaml Newcomers

Hackathon Projects

MirageOS Security Advisory 00 - memory disclosure in mirage-net-xen

Background

Problem Description

Impact

Workaround

Solution

Correction details

References

Configuration

Keys

Switching implementation

Drawing unikernels

Data dependencies

Sharing

All your functors are belong to us

Why focus so far down the software stack?

Solo5: Building a Unikernel Base from Scratch

Next Steps and Getting Involved

Dhcp_wire

Dhcp_server

Input

Configuration

Building a simple server

Future

Finishing words

Videos of recent talks

Playing dice

Random failures

Random sequences and stuff

Entropy

Do Virtual Machines Dream of Electric Sheep?

Parting words

Unikernels: HTTP -> HTTPS

Prerequisites

Get a Certificate

Self-Signed

Signed by Someone Else

Generating a Certificate-Signing Request

Example: Gandi.net

Example: StartSSL.com

Packaging Up an HTTPS Site with Mirage-Seal

What are you talking about?

Accesses

We are not talking to everybody

Attempts worth noting

Conclusion

Why OCaml-TLS matters

TLS Unix Tools

openmirage.org -> mirage.io

Security disclosure process

Get started!

Clean-Slate Transport Layer Security

HTTP and JavaScript

IPv6

Profiling

Irmin

Jitsu

Community

Upcoming features

Want to get involved?