Source file vmm_commands.ml

(* (c) 2018 Hannes Mehnert, all rights reserved *)

(* the wire protocol *)
open Vmm_core

type version = [ `AV3 | `AV4 ]

let current = `AV4

let pp_version ppf v =
  Fmt.int ppf
    (match v with
     | `AV4 -> 4
     | `AV3 -> 3)

let version_eq a b =
  match a, b with
  | `AV4, `AV4 -> true
  | `AV3, `AV3 -> true
  | _ -> false

let is_current = version_eq current

type since_count = [ `Since of Ptime.t | `Count of int ]

let pp_since_count ppf = function
  | `Since since -> Fmt.pf ppf "since %a" (Ptime.pp_rfc3339 ()) since
  | `Count n -> Fmt.pf ppf "number %d" n

type console_cmd = [
  | `Console_add
  | `Console_subscribe of since_count
]

let pp_console_cmd ppf = function
  | `Console_add -> Fmt.string ppf "console add"
  | `Console_subscribe ts -> Fmt.pf ppf "console subscribe %a" pp_since_count ts

type stats_cmd = [
  | `Stats_add of string * int * (string * string) list
  | `Stats_remove
  | `Stats_subscribe
]

let pp_stats_cmd ppf = function
  | `Stats_add (vmmdev, pid, taps) ->
    Fmt.pf ppf "stats add: vmm device %s pid %d taps %a" vmmdev pid
      Fmt.(list ~sep:(unit ", ") (pair ~sep:(unit ": ") string string)) taps
  | `Stats_remove -> Fmt.string ppf "stat remove"
  | `Stats_subscribe -> Fmt.string ppf "stat subscribe"

type unikernel_cmd = [
  | `Unikernel_info
  | `Unikernel_create of Unikernel.config
  | `Unikernel_force_create of Unikernel.config
  | `Unikernel_destroy
  | `Unikernel_get
  | `Old_unikernel_info
  | `Old_unikernel_get
]

let pp_unikernel_cmd ppf = function
  | `Unikernel_info -> Fmt.string ppf "unikernel info"
  | `Unikernel_create config -> Fmt.pf ppf "unikernel create %a" Unikernel.pp_config config
  | `Unikernel_force_create config -> Fmt.pf ppf "vm force create %a" Unikernel.pp_config config
  | `Unikernel_destroy -> Fmt.string ppf "unikernel destroy"
  | `Unikernel_get -> Fmt.string ppf "unikernel get"
  | `Old_unikernel_info -> Fmt.string ppf "old unikernel info"
  | `Old_unikernel_get -> Fmt.string ppf "old unikernel get"

type policy_cmd = [
  | `Policy_info
  | `Policy_add of Policy.t
  | `Policy_remove
]

let pp_policy_cmd ppf = function
  | `Policy_info -> Fmt.string ppf "policy info"
  | `Policy_add policy -> Fmt.pf ppf "policy add %a" Policy.pp policy
  | `Policy_remove -> Fmt.string ppf "policy remove"

type block_cmd = [
  | `Block_info
  | `Block_add of int
  | `Block_remove
]

let pp_block_cmd ppf = function
  | `Block_info -> Fmt.string ppf "block info"
  | `Block_add size -> Fmt.pf ppf "block add %d" size
  | `Block_remove -> Fmt.string ppf "block remove"

type t = [
    | `Console_cmd of console_cmd
    | `Stats_cmd of stats_cmd
    | `Unikernel_cmd of unikernel_cmd
    | `Policy_cmd of policy_cmd
    | `Block_cmd of block_cmd
  ]

let pp ppf = function
  | `Console_cmd c -> pp_console_cmd ppf c
  | `Stats_cmd s -> pp_stats_cmd ppf s
  | `Unikernel_cmd v -> pp_unikernel_cmd ppf v
  | `Policy_cmd p -> pp_policy_cmd ppf p
  | `Block_cmd b -> pp_block_cmd ppf b

type data = [
  | `Console_data of Ptime.t * string
  | `Stats_data of Stats.t
]

let pp_data ppf = function
  | `Console_data (ts, line) -> Fmt.pf ppf "console data %a: %s"
                                  (Ptime.pp_rfc3339 ()) ts line
  | `Stats_data stats -> Fmt.pf ppf "stats data: %a" Stats.pp stats

type header = {
  version : version ;
  sequence : int64 ;
  name : Name.t ;
}

let header ?(version = current) ?(sequence = 0L) name = { version ; sequence ; name }

type success = [
  | `Empty
  | `String of string
  | `Policies of (Name.t * Policy.t) list
  | `Old_unikernels of (Name.t * Unikernel.config) list
  | `Unikernel_info of (Name.t * Unikernel.info) list
  | `Unikernel_image of bool * Cstruct.t
  | `Block_devices of (Name.t * int * bool) list
]

let pp_block ppf (id, size, active) =
  Fmt.pf ppf "block %a size %d MB active %B" Name.pp id size active

let my_fmt_list empty pp_elt ppf xs =
  match xs with
  | [] -> Fmt.string ppf empty
  | _ -> Fmt.(list ~sep:(unit "@.") pp_elt ppf xs)

let pp_success ppf = function
  | `Empty -> Fmt.string ppf "success"
  | `String data -> Fmt.pf ppf "success: %s" data
  | `Policies ps -> my_fmt_list "no policies" Fmt.(pair ~sep:(unit ": ") Name.pp Policy.pp) ppf ps
  | `Old_unikernels vms -> my_fmt_list "no unikernels" Fmt.(pair ~sep:(unit ": ") Name.pp Unikernel.pp_config) ppf vms
  | `Unikernel_info infos -> my_fmt_list "no unikernels" Fmt.(pair ~sep:(unit ": ") Name.pp Unikernel.pp_info) ppf infos
  | `Unikernel_image (compressed, image) -> Fmt.pf ppf "image (compression %B) %d bytes" compressed (Cstruct.len image)
  | `Block_devices blocks -> my_fmt_list "no block devices" pp_block ppf blocks

type res = [
  | `Command of t
  | `Success of success
  | `Failure of string
  | `Data of data
]

type wire = header * res

let pp_wire ppf (header, data) =
  let name = header.name in
  match data with
  | `Command c -> Fmt.pf ppf "host %a: %a" Name.pp name pp c
  | `Failure f -> Fmt.pf ppf "host %a: command failed %s" Name.pp name f
  | `Success s -> Fmt.pf ppf "host %a: %a" Name.pp name pp_success s
  | `Data d -> pp_data ppf d

let endpoint = function
  | `Unikernel_cmd _ -> `Vmmd, `End
  | `Policy_cmd _ -> `Vmmd, `End
  | `Block_cmd _ -> `Vmmd, `End
  | `Stats_cmd `Stats_subscribe -> `Stats, `Read
  | `Stats_cmd _ -> `Stats, `End
  | `Console_cmd _ -> `Console, `Read