MirageOS Winter Hack Retreat, Marrakesh 2017

Apr 20 2018 16 0 · By Stefanie Schirmer

type any_ssh_agent_response = Any_response : 'a ssh_agent_response -> any_ssh_agent_response
    val unpack_any_response : 'a ssh_agent_request -> any_ssh_agent_response ->
                              ('a ssh_agent_response, string) result
    let listen ((ic, oc) : in_channel * out_channel)
        (handler : 'a Ssh_agent.ssh_agent_request -> 'a Ssh_agent.ssh_agent_response) =
      match Angstrom_unix.parse Ssh_agent.Parse.ssh_agentc_message ic with
      | { len = 0; _ }, Ok (Ssh_agent.Any_request request) ->
        Ok (Ssh_agent.Any_response (handler response))
      | { len; _ }, Ok _ ->
        Error "Additional data in reply"
      | _, Error e ->
        Error e
opam install irmin
type metric = {
  name : string;
  gauge: int64;
}
let metric_t =
  let open Irmin.Type in
  record "metric" (fun name gauge -> { name; gauge })
  |+ field "name"  string (fun t -> t.name)
  |+ field "gauge" int64    (fun t -> t.gauge)
  |> sealr
let print m = Fmt.pr "%a\n%!" (Irmin.Type.pp_json metric_t) m
let merge =
  let open Irmin.Merge in
  like metric_t (pair string counter)
    (fun x -> x.name, x.gauge)
    (fun (name, gauge) -> {name; gauge })
  |> option
module Metric: Irmin.Contents.S with type t = metric = struct
  type t = metric
  let t = metric_t
  let merge = merge
  let pp = Irmin.Type.pp_json metric_t
  let of_string s =
    Irmin.Type.decode_json metric_t (Jsonm.decoder (`String s))
end
module Store = Irmin_unix.Git.FS.KV(Metric)
let config = Irmin_git.config "/tmp/irmin"
let info fmt = Irmin_unix.info ~author:"Thomas" fmt
# open Lwt.Infix;;

# let repo = Store.Repo.v config;;
val repo : Store.Repo.t Lwt.t = <abstr>
# let master = repo >>= fun repo -> Store.master repo;;
val master : Store.t Lwt.t = <abstr>
  Lwt_main.run begin
      Store.Repo.v config >>= Store.master >>= fun master ->
      Store.set master
        ~info:(info "Creating a new metric")
        ["vm"; "writes"] { name = "write Kb/s"; gauge = 0L }
      >>= fun () ->
      Store.get master ["vm"; "writes"] >|= fun m ->
      assert (m.gauge = 0L);
    end
let move t src dst =
  Store.with_tree t
    ~info:(info "Moving %a to %a" Store.Key.pp src Store.Key.pp dst)
    [] (fun tree ->
          let tree = match tree with
            | None -> Store.Tree.empty
            | Some tree -> tree
          in
          Store.Tree.get_tree tree src >>= fun v ->
          Store.Tree.remove tree src >>= fun _ ->
          Store.Tree.add_tree tree dst v >>= Lwt.return_some
    )
let incr t =
  let path = ["vm"; "writes"] in
  Store.with_tree ~info:(info "New write event") t path (fun tree ->
      let tree = match tree with
        | None -> Store.Tree.empty
        | Some tree -> tree
      in
      (Store.Tree.find tree [] >|= function
        | None   -> { name = "writes in kb/s"; gauge = 0L }
        | Some x -> { x with gauge = Int64.succ x.gauge })
      >>= fun m ->
      Store.Tree.add tree [] m
      >>= Lwt.return_some
    )
let () =
  Lwt_main.run begin
    Store.Repo.v config >>= Store.master >>= fun master -> (* guage 0 *)
    incr master >>= fun () -> (* gauge = 1 *)
    Store.clone ~src:master ~dst:"tmp" >>= fun tmp ->
    incr master >>= fun () -> (* gauge = 2 on master *)
    incr tmp    >>= fun () -> (* gauge = 2 on tmp *)
    Store.merge ~info:(info "Merge tmp into master") tmp ~into:master
    >>= function
    | Error (`Conflict e) -> failwith e
    | Ok () ->
      Store.get master ["vm"; "writes"] >|= fun m ->
      Fmt.pr "Gauge is %Ld\n%!" m.gauge
  end
(* Start qrexec agent, GUI agent and QubesDB agent in parallel *)
   let qrexec = RExec.connect ~domid:0 () in
   let gui = GUI.connect ~domid:0 () in
    (* Wait for clients to connect *)
    qrexec >>= fun qrexec ->
    let agent_listener = RExec.listen qrexec Command.handler in
    gui >>= fun gui ->
    Lwt.async (fun () -> GUI.listen gui);
    Lwt.async (fun () ->
      OS.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) ->
      RExec.disconnect qrexec
    );
module Main (N: Mirage_net_lwt.S) = struct

  let start (n : N.t)  =
    N.write n @@ Cstruct.of_string "omg hi network" >>= function
    | Error e -> Log.warn (fun f -> f "failed to send message"); Lwt.return_unit
    | Ok () -> Log.info (fun f -> f "said hello!"); Lwt.return_unit

end
let qrexec = job
let qrexec_qubes = impl @@ object
  inherit base_configurable
  method ty = qrexec
  val name = Name.ocamlify @@ "qrexec_"
  method name = name
  method module_name = "Qubes.RExec"
  method packages = Key.pure [ package "mirage-qubes" ]
  method configure i =
    match get_target i with
    | `Qubes -> R.ok ()
    | _ -> R.error_msg "Qubes remote-exec invoked for non-Qubes target."
  method connect _ modname _args =
    Fmt.strf
      "@[<v 2>\
       %s.connect ~domid:0 () >>= fun qrexec ->@ \
       Lwt.async (fun () ->@ \
       OS.Lifecycle.await_shutdown_request () >>= fun _ ->@ \
       %s.disconnect qrexec);@ \
       Lwt.return (`Ok qrexec)@]"
      modname modname
end
let gui = job

let gui_qubes = impl @@ object
  inherit base_configurable
  method ty = gui
  val name = Name.ocamlify @@ "gui"
  method name = name
  method module_name = "Qubes.GUI"
  method packages = Key.pure [ package "mirage-qubes" ]
  method configure i =
    match get_target i with
    | `Qubes -> R.ok ()
    | _ -> R.error_msg "Qubes GUI invoked for non-Qubes target."
  method connect _ modname _args =
    Fmt.strf
      "@[<v 2>\
       %s.connect ~domid:0 () >>= fun gui ->@ \
       Lwt.async (fun () -> %s.listen gui);@ \
       Lwt.return (`Ok gui)@]"
      modname modname
end
let qrexec_init = match_impl Key.(value target) [
  `Qubes, qrexec_qubes;
] ~default:Functoria_app.noop

let gui_init = match_impl Key.(value target) [
  `Qubes, gui_qubes;
] ~default:Functoria_app.noop

let register
    ?(argv=default_argv) ?tracing ?(reporter=default_reporter ())
    ?keys ?packages
    name jobs =
  let argv = Some (Functoria_app.keys argv) in
  let reporter = if reporter == no_reporter then None else Some reporter in
  let qubes_init = Some [qrexec_init; gui_init] in
  let init = qubes_init ++ argv ++ reporter ++ tracing in
  register ?keys ?packages ?init name jobs
type qubesdb = QUBES_DB
let qubesdb = Type QUBES_DB

let qubesdb_conf = object
  inherit base_configurable
  method ty = qubesdb
  method name = "qubesdb"
  method module_name = "Qubes.DB"
  method packages = Key.pure [ package "mirage-qubes" ]
  method configure i =
    match get_target i with
    | `Qubes -> R.ok ()
    | _ -> R.error_msg "Qubes DB invoked for non-Qubes target."
  method connect _ modname _args = Fmt.strf "%s.connect ~domid:0 ()" modname
end

let default_qubesdb = impl qubesdb_conf
let ipv4_qubes_conf = impl @@ object
    inherit base_configurable
    method ty = qubesdb @-> ethernet @-> arpv4 @-> ipv4
    method name = Name.create "qubes_ipv4" ~prefix:"qubes_ipv4"
    method module_name = "Qubesdb_ipv4.Make"
    method packages = Key.pure [ package ~sublibs:["ipv4"] "mirage-qubes" ]
    method connect _ modname = function
      | [ db ; etif; arp ] -> Fmt.strf "%s.connect %s %s %s" modname db etif arp
      | _ -> failwith (connect_err "qubes ipv4" 3)
  end

let ipv4_qubes db ethernet arp = ipv4_qubes_conf $ db $ ethernet $ arp
let generic_stackv4
    ?group ?config
    ?(dhcp_key = Key.value @@ Key.dhcp ?group ())
    ?(net_key = Key.value @@ Key.net ?group ())
    (tap : network impl) : stackv4 impl =
  let eq a b = Key.(pure ((=) a) $ b) in
  let choose qubes socket dhcp =
    if qubes then `Qubes
    else if socket then `Socket
    else if dhcp then `Dhcp
    else `Static
  in
  let p = Functoria_key.((pure choose)
          $ eq `Qubes Key.(value target)
          $ eq `Socket net_key
          $ eq true dhcp_key) in
  match_impl p [
    `Dhcp, dhcp_ipv4_stack ?group tap;
    `Socket, socket_stackv4 ?group [Ipaddr.V4.any];
    `Qubes, qubes_ipv4_stack ?group tap;
  ] ~default:(static_ipv4_stack ?config ?group tap)
4.04.0🐫  (qubes-target) mirageos:~/mirage-www/src$ mirage configure -t qubes
4.04.0🐫  (qubes-target) mirageos:~/mirage-www/src$ cat main.ml
(* Generated by mirage configure -t qubes (Tue, 28 Feb 2017 18:15:49 GMT). *)

open Lwt.Infix
let return = Lwt.return
let run =
OS.Main.run

let _ = Printexc.record_backtrace true

module Ethif1 = Ethif.Make(Netif)

module Arpv41 = Arpv4.Make(Ethif1)(Mclock)(OS.Time)

module Qubesdb_ipv41 = Qubesdb_ipv4.Make(Qubes.DB)(Ethif1)(Arpv41)

module Icmpv41 = Icmpv4.Make(Qubesdb_ipv41)

module Udp1 = Udp.Make(Qubesdb_ipv41)(Stdlibrandom)

module Tcp1 = Tcp.Flow.Make(Qubesdb_ipv41)(OS.Time)(Mclock)(Stdlibrandom)

module Tcpip_stack_direct1 = Tcpip_stack_direct.Make(OS.Time)(Stdlibrandom)
  (Netif)(Ethif1)(Arpv41)(Qubesdb_ipv41)(Icmpv41)(Udp1)(Tcp1)

module Conduit_mirage1 = Conduit_mirage.With_tcp(Tcpip_stack_direct1)

module Dispatch1 = Dispatch.Make(Cohttp_mirage.Server_with_conduit)(Static1)
  (Static2)(Pclock)

module Mirage_logs1 = Mirage_logs.Make(Pclock)

let net11 = lazy (
  Netif.connect (Key_gen.interface ())
  )

let time1 = lazy (
  return ()
  )

let mclock1 = lazy (
  Mclock.connect ()
  )

let ethif1 = lazy (
  let __net11 = Lazy.force net11 in
  __net11 >>= fun _net11 ->
  Ethif1.connect _net11
  )

let qubesdb1 = lazy (
  Qubes.DB.connect ~domid:0 ()
  )

let arpv41 = lazy (
  let __ethif1 = Lazy.force ethif1 in
  let __mclock1 = Lazy.force mclock1 in
  let __time1 = Lazy.force time1 in
  __ethif1 >>= fun _ethif1 ->
  __mclock1 >>= fun _mclock1 ->
  __time1 >>= fun _time1 ->
  Arpv41.connect _ethif1 _mclock1
  )

let qubes_ipv411 = lazy (
  let __qubesdb1 = Lazy.force qubesdb1 in
  let __ethif1 = Lazy.force ethif1 in
  let __arpv41 = Lazy.force arpv41 in
  __qubesdb1 >>= fun _qubesdb1 ->
  __ethif1 >>= fun _ethif1 ->
  __arpv41 >>= fun _arpv41 ->
  Qubesdb_ipv41.connect _qubesdb1 _ethif1 _arpv41
  )

let random1 = lazy (
  Lwt.return (Stdlibrandom.initialize ())
  )

let icmpv41 = lazy (
  let __qubes_ipv411 = Lazy.force qubes_ipv411 in
  __qubes_ipv411 >>= fun _qubes_ipv411 ->
  Icmpv41.connect _qubes_ipv411
  )

let udp1 = lazy (
  let __qubes_ipv411 = Lazy.force qubes_ipv411 in
  let __random1 = Lazy.force random1 in
  __qubes_ipv411 >>= fun _qubes_ipv411 ->
  __random1 >>= fun _random1 ->
  Udp1.connect _qubes_ipv411
  )

let tcp1 = lazy (
  let __qubes_ipv411 = Lazy.force qubes_ipv411 in
  let __time1 = Lazy.force time1 in
  let __mclock1 = Lazy.force mclock1 in
  let __random1 = Lazy.force random1 in
  __qubes_ipv411 >>= fun _qubes_ipv411 ->
  __time1 >>= fun _time1 ->
  __mclock1 >>= fun _mclock1 ->
  __random1 >>= fun _random1 ->
  Tcp1.connect _qubes_ipv411 _mclock1
  )

let stackv4_1 = lazy (
  let __time1 = Lazy.force time1 in
  let __random1 = Lazy.force random1 in
  let __net11 = Lazy.force net11 in
  let __ethif1 = Lazy.force ethif1 in
  let __arpv41 = Lazy.force arpv41 in
  let __qubes_ipv411 = Lazy.force qubes_ipv411 in
  let __icmpv41 = Lazy.force icmpv41 in
  let __udp1 = Lazy.force udp1 in
  let __tcp1 = Lazy.force tcp1 in
  __time1 >>= fun _time1 ->
  __random1 >>= fun _random1 ->
  __net11 >>= fun _net11 ->
  __ethif1 >>= fun _ethif1 ->
  __arpv41 >>= fun _arpv41 ->
  __qubes_ipv411 >>= fun _qubes_ipv411 ->
  __icmpv41 >>= fun _icmpv41 ->
  __udp1 >>= fun _udp1 ->
  __tcp1 >>= fun _tcp1 ->
  let config = {Mirage_stack_lwt. name = "stackv4_"; interface = _net11;} in
Tcpip_stack_direct1.connect config
_ethif1 _arpv41 _qubes_ipv411 _icmpv41 _udp1 _tcp1
  )

let nocrypto1 = lazy (
  Nocrypto_entropy_mirage.initialize ()
  )

let tcp_conduit_connector1 = lazy (
  let __stackv4_1 = Lazy.force stackv4_1 in
  __stackv4_1 >>= fun _stackv4_1 ->
  Lwt.return (Conduit_mirage1.connect _stackv4_1)

  )

let conduit11 = lazy (
  let __nocrypto1 = Lazy.force nocrypto1 in
  let __tcp_conduit_connector1 = Lazy.force tcp_conduit_connector1 in
  __nocrypto1 >>= fun _nocrypto1 ->
  __tcp_conduit_connector1 >>= fun _tcp_conduit_connector1 ->
  Lwt.return Conduit_mirage.empty >>= _tcp_conduit_connector1 >>=
fun t -> Lwt.return t
  )

let argv_qubes1 = lazy (
  let filter (key, _) = List.mem key (List.map snd Key_gen.runtime_keys) in
Bootvar.argv ~filter ()
  )

let http1 = lazy (
  let __conduit11 = Lazy.force conduit11 in
  __conduit11 >>= fun _conduit11 ->
  Cohttp_mirage.Server_with_conduit.connect _conduit11
  )

let static11 = lazy (
  Static1.connect ()
  )

let static21 = lazy (
  Static2.connect ()
  )

let pclock1 = lazy (
  Pclock.connect ()
  )

let key1 = lazy (
  let __argv_qubes1 = Lazy.force argv_qubes1 in
  __argv_qubes1 >>= fun _argv_qubes1 ->
  return (Functoria_runtime.with_argv (List.map fst Key_gen.runtime_keys) "www" _argv_qubes1)
  )

let gui1 = lazy (
  Qubes.GUI.connect ~domid:0 () >>= fun gui ->
  Lwt.async (fun () -> Qubes.GUI.listen gui);
  Lwt.return (`Ok gui)
  )

let qrexec_1 = lazy (
  Qubes.RExec.connect ~domid:0 () >>= fun qrexec ->
  Lwt.async (fun () ->
  OS.Lifecycle.await_shutdown_request () >>= fun _ ->
  Qubes.RExec.disconnect qrexec);
  Lwt.return (`Ok qrexec)
  )

let f11 = lazy (
  let __http1 = Lazy.force http1 in
  let __static11 = Lazy.force static11 in
  let __static21 = Lazy.force static21 in
  let __pclock1 = Lazy.force pclock1 in
  __http1 >>= fun _http1 ->
  __static11 >>= fun _static11 ->
  __static21 >>= fun _static21 ->
  __pclock1 >>= fun _pclock1 ->
  Dispatch1.start _http1 _static11 _static21 _pclock1
  )

let mirage_logs1 = lazy (
  let __pclock1 = Lazy.force pclock1 in
  __pclock1 >>= fun _pclock1 ->
  let ring_size = None in
  let reporter = Mirage_logs1.create ?ring_size _pclock1 in
  Mirage_runtime.set_level ~default:Logs.Info (Key_gen.logs ());
  Mirage_logs1.set_reporter reporter;
  Lwt.return reporter
  )

let mirage1 = lazy (
  let __qrexec_1 = Lazy.force qrexec_1 in
  let __gui1 = Lazy.force gui1 in
  let __key1 = Lazy.force key1 in
  let __mirage_logs1 = Lazy.force mirage_logs1 in
  let __f11 = Lazy.force f11 in
  __qrexec_1 >>= fun _qrexec_1 ->
  __gui1 >>= fun _gui1 ->
  __key1 >>= fun _key1 ->
  __mirage_logs1 >>= fun _mirage_logs1 ->
  __f11 >>= fun _f11 ->
  Lwt.return_unit
  )

let () =
  let t =
  Lazy.force qrexec_1 >>= fun _ ->
    Lazy.force gui1 >>= fun _ ->
    Lazy.force key1 >>= fun _ ->
    Lazy.force mirage_logs1 >>= fun _ ->
    Lazy.force mirage1
  in run t
4.04.0🐫  (qubes-target) mirageos:~/mirage-www/src$ make depend
4.04.0🐫  (qubes-target) mirageos:~/mirage-www/src$ make
4.04.0🐫  (qubes-target) mirageos:~/mirage-www/src$ ~/test-mirage www.xen mirage-test
.[32;1mMirageOS booting....[0m
Initialising timer interface
Initialising console ... done.
Note: cannot write Xen 'control' directory
Attempt to open(/dev/urandom)!
Unsupported function getpid called in Mini-OS kernel
Unsupported function getppid called in Mini-OS kernel
2017-02-28 18:29:54 -00:00: INF [net-xen:frontend] connect 0
2017-02-28 18:29:54 -00:00: INF [qubes.db] connecting to server...
gnttab_stubs.c: initialised mini-os gntmap
2017-02-28 18:29:54 -00:00: INF [qubes.db] connected
2017-02-28 18:29:54 -00:00: INF [net-xen:frontend] create: id=0 domid=2
2017-02-28 18:29:54 -00:00: INF [net-xen:frontend]  sg:true gso_tcpv4:true rx_copy:true rx_flip:false smart_poll:false
2017-02-28 18:29:54 -00:00: INF [net-xen:frontend] MAC: 00:16:3e:5e:6c:0e
2017-02-28 18:29:54 -00:00: INF [ethif] Connected Ethernet interface 00:16:3e:5e:6c:0e
2017-02-28 18:29:54 -00:00: INF [arpv4] Connected arpv4 device on 00:16:3e:5e:6c:0e
2017-02-28 18:29:54 -00:00: INF [udp] UDP interface connected on 10.137.3.16
2017-02-28 18:29:54 -00:00: INF [tcpip-stack-direct] stack assembled: mac=00:16:3e:5e:6c:0e,ip=10.137.3.16
2017-02-28 18:29:56 -00:00: INF [dispatch] Listening on http://localhost/
[user@sys-firewall ~]$ sudo iptables -I FORWARD -d 10.137.3.16 -i vif+ -j ACCEPT
4.04.0🐫  (qubes-target) mirageos:~/mirage-www/src$ wget -q -O - ht.137.3.16|head -1
<!DOCTYPE html>
  let () = Irmin_unix.install_dir_polling_listener 1.0
   let () = Irmin_unix.set_listen_dir_hook ()
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

MirageOS Winter Hack Retreat, Marrakesh 2017

Mindy Preston

Ximin Luo

Martin Keegan

Michele Orrù

Reynir Björnsson

The walk from the airport

People

My goals

GADT !!!FUN!!!

Ideas for uses of ocaml-ssh-agent

Saying goodbye

Cambio, OCaml and Karaoke: MirageOS Hack Retreat, Marrakech 2017

Hannes Mehnert

Ximin Luo

Michele Orrù

Mindy Preston

Viktor Baluch & Luk Burchard:

Aaron Zauner

Thomas Leonard

Amir Chaudhry

Jurre van Bergen

Reynir Björnsson

Mergeable Contents

Creating an Irmin Store

Creating and Merging Branches

Conclusion

slightly easier unikernels on the desktop

teach a robot to do human tricks

making mirageos unikernels

let's quickly revisit what impl passing usually looks like

providing additional modules

QRExec for nothing, GUI for free

how do I networks

So What?

What's Next?

Size matters: how Mirage got smaller and less magical

Generating code considered harmful

Device initialisation - connect

Workflow, phase separation, versioned opam dependencies

Other functionality removed or replaced

Conclusion

Solo5

Playing More Nicely with OPAM

Amazing Docs

Result-y Errors

Logs Where You Want Them

Disaggregated Module Type Definitions

Clockier Clocks, Timelier Time

Build System Shift

Less Code, Better Behavior

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

Hack retreat 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

Device initialisation - `connect`