reynir
/
albatross
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
albatross/src/vmm_asn.ml

785 lines
29 KiB
OCaml
Raw Permalink Blame History

(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
(* please read this before changing this module:
Data encoded by this module is persisted in (a) log entry (b) dump file
(c) certificates (and subCA). It is important to be aware of backward and
forward compatibility when modifying this module. There are various version
fields around which are mostly useless in retrospect. On a server deployment,
upgrades are supported while downgrades are not (there could be a separate
tool reading newer data and dumping it for older albatross versions). The
assumption is that a server deployment moves forward. For the clients, older
clients should best be support smoothly, or an error from the server should
be issued informing about a too old version. Clients which support newer
wire version should as well be notified (it may be suitable to have a
--use-version command-line flag - so new clients can talk to old servers).
The log (a) is append-only, whenever a new log entry is added, the choice
log_entry should be extended. New entries just use the new choice. The dump
on disk (dumped via log_to_disk, restored logs_of_disk) prepends a (rather
useless) version field. Restoring a new log entry with an old albatross_log
will result in a warning (but restores the other log entries).
It should be ensured that old unikernels dumped to disk (b) can be read by
new albatross daemons. The functions unikernels_to_cstruct and
unikernels_of_cstruct are used for dump and restore, each an explicit choice.
They use the trie of unikernel_config, dump always uses the latest version in
the explicit choice. There's no version field involved.
The data in transit (certificates and commands) is out of control of a single
operator. This means that best effort should be done to support old clients
(and old servers - eventually with a command-line argument --use-version). If
a server receives a command (via TLS cert_extension), this is prefixed by a
version. The non-TLS command is a sequence of header and payload, where the
header includes a version. At the moment, the commands are all explicit
choices, adding new ones by extending the choice works in a
backwards-compatible way.
*)
(* The version field could be used (at the moment, decoding a newer version
leads to a decoding failure):
Now, to achieve version-dependent parsing, what is missing is a way to decode
the first element of a sequence only (i.e. treat the second element as
"any"). This is something missing for PKCS12 from the asn1 library. A
"quick hack" is to extract length information of the first element, and use
that decoder on the sub-buffer. The following implements this.
let seq_hd cs =
decode_seq_len cs >>= fun (l, off) ->
Ok (Cstruct.sub cs off l)
let decode_version cs =
let c = Asn.codec Asn.der version in
match Asn.decode c cs with
| Ok (a, _) -> Ok a
| Error (`Parse msg) -> Error (`Msg msg)
*)
open Vmm_core
open Vmm_commands
open Rresult
open Astring
let oid = Asn.OID.(base 1 3 <| 6 <| 1 <| 4 <| 1 <| 49836 <| 42)
open Rresult.R.Infix
let guard p err = if p then Ok () else Error err
let decode_seq_len cs =
(* we assume a ASN.1 DER/BER encoded sequence starting in cs:
- 0x30
- length (definite length field - not 0x80)
- <data> (of length length)
*)
guard (Cstruct.len cs > 2) (`Msg "buffer too short") >>= fun () ->
guard (Cstruct.get_uint8 cs 0 = 0x30) (`Msg "not a sequence") >>= fun () ->
let l1 = Cstruct.get_uint8 cs 1 in
(if l1 < 0x80 then
Ok (2, l1)
else if l1 = 0x80 then
Error (`Msg "indefinite length")
else
let octets = l1 land 0x7F in
guard (Cstruct.len cs > octets + 2) (`Msg "data too short") >>= fun () ->
let rec go off acc =
if off = octets then
Ok (2 + octets, acc)
else
go (succ off) (Cstruct.get_uint8 cs (off + 2) + acc lsl 8)
in
go 0 0) >>= fun (off, l) ->
guard (Cstruct.len cs >= l + off) (`Msg "buffer too small") >>= fun () ->
Ok (l, off)
let decode_strict codec cs =
match Asn.decode codec cs with
| Ok (a, cs) ->
guard (Cstruct.len cs = 0) (`Msg "trailing bytes") >>= fun () ->
Ok a
| Error (`Parse msg) -> Error (`Msg msg)
let projections_of asn =
let c = Asn.codec Asn.der asn in
(decode_strict c, Asn.encode c)
let ipv4 =
let f cs = Ipaddr.V4.of_octets_exn (Cstruct.to_string cs)
and g ip = Cstruct.of_string (Ipaddr.V4.to_octets ip)
in
Asn.S.map f g Asn.S.octet_string
let policy =
let f (cpuids, vms, memory, block, bridges) =
let bridges = String.Set.of_list bridges
and cpuids = IS.of_list cpuids
in
Policy.{ vms ; cpuids ; memory ; block ; bridges }
and g policy =
(IS.elements policy.Policy.cpuids,
policy.Policy.vms,
policy.Policy.memory,
policy.Policy.block,
String.Set.elements policy.Policy.bridges)
in
Asn.S.map f g @@
Asn.S.(sequence5
(required ~label:"cpuids" Asn.S.(sequence_of int))
(required ~label:"vms" int)
(required ~label:"memory" int)
(optional ~label:"block" int)
(required ~label:"bridges" Asn.S.(sequence_of utf8_string)))
let console_cmd =
let f = function
| `C1 () -> `Console_add
| `C2 `C1 ts -> `Console_subscribe (`Since ts)
| `C2 `C2 c -> `Console_subscribe (`Count c)
and g = function
| `Console_add -> `C1 ()
| `Console_subscribe `Since ts -> `C2 (`C1 ts)
| `Console_subscribe `Count c -> `C2 (`C2 c)
in
Asn.S.map f g @@
Asn.S.(choice2
(explicit 0 null)
(explicit 1 (choice2 (explicit 0 utc_time) (explicit 1 int))))
(* TODO is this good? *)
let int64 =
let f cs = Cstruct.BE.get_uint64 cs 0
and g data =
let buf = Cstruct.create 8 in
Cstruct.BE.set_uint64 buf 0 data ;
buf
in
Asn.S.map f g Asn.S.octet_string
let timeval =
Asn.S.(sequence2
(required ~label:"seconds" int64)
(required ~label:"microseconds" int))
let ru =
let open Stats in
let f (utime, (stime, (maxrss, (ixrss, (idrss, (isrss, (minflt, (majflt, (nswap, (inblock, (outblock, (msgsnd, (msgrcv, (nsignals, (nvcsw, nivcsw))))))))))))))) =
{ utime ; stime ; maxrss ; ixrss ; idrss ; isrss ; minflt ; majflt ; nswap ; inblock ; outblock ; msgsnd ; msgrcv ; nsignals ; nvcsw ; nivcsw }
and g ru =
(ru.utime, (ru.stime, (ru.maxrss, (ru.ixrss, (ru.idrss, (ru.isrss, (ru.minflt, (ru.majflt, (ru.nswap, (ru.inblock, (ru.outblock, (ru.msgsnd, (ru.msgrcv, (ru.nsignals, (ru.nvcsw, ru.nivcsw)))))))))))))))
in
Asn.S.map f g @@
Asn.S.(sequence @@
(required ~label:"utime" timeval)
@ (required ~label:"stime" timeval)
@ (required ~label:"maxrss" int64)
@ (required ~label:"ixrss" int64)
@ (required ~label:"idrss" int64)
@ (required ~label:"isrss" int64)
@ (required ~label:"minflt" int64)
@ (required ~label:"majflt" int64)
@ (required ~label:"nswap" int64)
@ (required ~label:"inblock" int64)
@ (required ~label:"outblock" int64)
@ (required ~label:"msgsnd" int64)
@ (required ~label:"msgrcv" int64)
@ (required ~label:"nsignals" int64)
@ (required ~label:"nvcsw" int64)
-@ (required ~label:"nivcsw" int64))
(* although this changed (+runtime + cow + start) from V3 to V4, since it's not
persistent, no need to care about it *)
let kinfo_mem =
let open Stats in
let f (vsize, (rss, (tsize, (dsize, (ssize, (runtime, (cow, start))))))) =
{ vsize ; rss ; tsize ; dsize ; ssize ; runtime ; cow ; start }
and g t =
(t.vsize, (t.rss, (t.tsize, (t.dsize, (t.ssize, (t.runtime, (t.cow, t.start)))))))
in
Asn.S.map f g @@
Asn.S.(sequence @@
(required ~label:"bsize" int64)
@ (required ~label:"rss" int64)
@ (required ~label:"tsize" int64)
@ (required ~label:"dsize" int64)
@ (required ~label:"ssize" int64)
@ (required ~label:"runtime" int64)
@ (required ~label:"cow" int)
-@ (required ~label:"start" timeval))
(* TODO is this good? *)
let int32 =
let f i = Int32.of_int i
and g i = Int32.to_int i
in
Asn.S.map f g Asn.S.int
let ifdata =
let open Stats in
let f (bridge, (flags, (send_length, (max_send_length, (send_drops, (mtu, (baudrate, (input_packets, (input_errors, (output_packets, (output_errors, (collisions, (input_bytes, (output_bytes, (input_mcast, (output_mcast, (input_dropped, output_dropped))))))))))))))))) =
{ bridge ; flags; send_length; max_send_length; send_drops; mtu; baudrate; input_packets; input_errors; output_packets; output_errors; collisions; input_bytes; output_bytes; input_mcast; output_mcast; input_dropped; output_dropped }
and g i =
(i.bridge, (i.flags, (i.send_length, (i.max_send_length, (i.send_drops, (i.mtu, (i.baudrate, (i.input_packets, (i.input_errors, (i.output_packets, (i.output_errors, (i.collisions, (i.input_bytes, (i.output_bytes, (i.input_mcast, (i.output_mcast, (i.input_dropped, i.output_dropped)))))))))))))))))
in
Asn.S.map f g @@
Asn.S.(sequence @@
(required ~label:"bridge" utf8_string)
@ (required ~label:"flags" int32)
@ (required ~label:"send_length" int32)
@ (required ~label:"max_send_length" int32)
@ (required ~label:"send_drops" int32)
@ (required ~label:"mtu" int32)
@ (required ~label:"baudrate" int64)
@ (required ~label:"input_packets" int64)
@ (required ~label:"input_errors" int64)
@ (required ~label:"output_packets" int64)
@ (required ~label:"output_errors" int64)
@ (required ~label:"collisions" int64)
@ (required ~label:"input_bytes" int64)
@ (required ~label:"output_bytes" int64)
@ (required ~label:"input_mcast" int64)
@ (required ~label:"output_mcast" int64)
@ (required ~label:"input_dropped" int64)
-@ (required ~label:"output_dropped" int64))
let stats_cmd =
let f = function
| `C1 (name, pid, taps) -> `Stats_add (name, pid, taps)
| `C2 () -> `Stats_remove
| `C3 () -> `Stats_subscribe
and g = function
| `Stats_add (name, pid, taps) -> `C1 (name, pid, taps)
| `Stats_remove -> `C2 ()
| `Stats_subscribe -> `C3 ()
in
Asn.S.map f g @@
Asn.S.(choice3
(explicit 0 (sequence3
(required ~label:"vmmdev" utf8_string)
(required ~label:"pid" int)
(required ~label:"network"
(sequence_of
(sequence2
(required ~label:"bridge" utf8_string)
(required ~label:"tap" utf8_string))))))
(explicit 1 null)
(explicit 2 null))
let of_name, to_name =
Name.to_list,
fun list -> match Name.of_list list with
| Error (`Msg msg) -> Asn.S.error (`Parse msg)
| Ok name -> name
let log_event =
(* this is stored on disk persistently -- be aware when changing the grammar
below to only ever extend it! *)
let f = function
| `C1 `C1 () -> `Startup
| `C1 `C2 (name, ip, port) -> `Login (to_name name, ip, port)
| `C1 `C3 (name, ip, port) -> `Logout (to_name name, ip, port)
| `C1 `C4 (name, pid, taps, block) ->
let name = to_name name in
let blocks = match block with
| None -> []
| Some block -> [ block, Name.block_name name block ]
and taps = List.map (fun tap -> tap, tap) taps
in
`Unikernel_start (name, pid, taps, blocks)
| `C2 `C1 (name, pid, taps, blocks) ->
let blocks = List.map (fun (name, dev) ->
name, match Name.of_string dev with
| Error `Msg msg -> Asn.S.error (`Parse msg)
| Ok id -> id) blocks
in
`Unikernel_start (to_name name, pid, taps, blocks)
| `C1 `C5 (name, pid, status) ->
let status' = match status with
| `C1 n -> `Exit n
| `C2 n -> `Signal n
| `C3 n -> `Stop n
in
`Unikernel_stop (to_name name, pid, status')
| `C1 `C6 () -> `Hup
| `C2 `C2 () -> assert false (* placeholder *)
and g = function
| `Startup -> `C1 (`C1 ())
| `Login (name, ip, port) -> `C1 (`C2 (of_name name, ip, port))
| `Logout (name, ip, port) -> `C1 (`C3 (of_name name, ip, port))
| `Unikernel_start (name, pid, taps, blocks) ->
let blocks =
List.map (fun (name, dev) -> name, Name.to_string dev) blocks
in
`C2 (`C1 (of_name name, pid, taps, blocks))
| `Unikernel_stop (name, pid, status) ->
let status' = match status with
| `Exit n -> `C1 n
| `Signal n -> `C2 n
| `Stop n -> `C3 n
in
`C1 (`C5 (of_name name, pid, status'))
| `Hup -> `C1 (`C6 ())
in
let endp =
Asn.S.(sequence3
(required ~label:"name" (sequence_of utf8_string))
(required ~label:"ip" ipv4)
(required ~label:"port" int))
in
Asn.S.map f g @@
Asn.S.(choice2
(choice6
(explicit 0 null)
(explicit 1 endp)
(explicit 2 endp)
(* the old V3 unikernel start *)
(explicit 3 (sequence4
(required ~label:"name" (sequence_of utf8_string))
(required ~label:"pid" int)
(required ~label:"taps" (sequence_of utf8_string))
(optional ~label:"block" utf8_string)))
(explicit 4 (sequence3
(required ~label:"name" (sequence_of utf8_string))
(required ~label:"pid" int)
(required ~label:"status" (choice3
(explicit 0 int)
(explicit 1 int)
(explicit 2 int)))))
(explicit 5 null))
(choice2
(* the new V4 unikernel start*)
(explicit 6 (sequence4
(required ~label:"name" (sequence_of utf8_string))
(required ~label:"pid" int)
(required ~label:"taps"
(sequence_of
(sequence2
(required ~label:"bridge" utf8_string)
(required ~label:"tap" utf8_string))))
(required ~label:"blocks"
(sequence_of
(sequence2
(required ~label:"name" utf8_string)
(required ~label:"device" utf8_string))))))
(explicit 7 null (* placeholder *) )))
let log_cmd =
let f = function
| `C1 since -> `Log_subscribe (`Since since)
| `C2 n -> `Log_subscribe (`Count n)
and g = function
| `Log_subscribe `Since since -> `C1 since
| `Log_subscribe `Count n -> `C2 n
in
Asn.S.map f g @@
Asn.S.(choice2 (explicit 0 utc_time) (explicit 1 int))
let typ =
let f = function
| `C1 () -> `Solo5
| `C2 () -> assert false
and g = function
| `Solo5 -> `C1 ()
in
Asn.S.map f g @@
Asn.S.(choice2 (explicit 0 null) (explicit 1 null))
let fail_behaviour =
let f = function
| `C1 () -> `Quit
| `C2 xs ->
let exit_codes = match xs with
| [] -> None
| xs -> Some (IS.of_list xs)
in
`Restart exit_codes
and g = function
| `Quit -> `C1 ()
| `Restart xs ->
let exit_codes = match xs with
| None -> []
| Some i -> IS.elements i
in
`C2 exit_codes
in
Asn.S.map f g @@
Asn.S.(choice2
(explicit 0 null)
(explicit 1 (set_of int)))
(* this is part of the state file! *)
let v0_unikernel_config =
let image =
let f = function
| `C1 x -> `Hvt_amd64, x
| `C2 x -> `Hvt_arm64, x
| `C3 x -> `Hvt_amd64_compressed, x
and g = function
| `Hvt_amd64, x -> `C1 x
| `Hvt_arm64, x -> `C2 x
| `Hvt_amd64_compressed, x -> `C3 x
in
Asn.S.map f g @@
Asn.S.(choice3
(explicit 0 octet_string)
(explicit 1 octet_string)
(explicit 2 octet_string))
in
let open Unikernel in
let f (cpuid, memory, block_device, network_interfaces, image, argv) =
let bridges = match network_interfaces with None -> [] | Some xs -> List.map (fun n -> n, None) xs
and block_devices = match block_device with None -> [] | Some b -> [ b ]
in
let typ = `Solo5
and compressed = match fst image with `Hvt_amd64_compressed -> true | _ -> false
and image = snd image
and fail_behaviour = `Quit (* TODO maybe set to restart by default :) *)
in
{ typ ; compressed ; image ; fail_behaviour ; cpuid ; memory ; block_devices ; bridges ; argv }
and g _vm = failwith "cannot encode v0 unikernel configs"
in
Asn.S.map f g @@
Asn.S.(sequence6
(required ~label:"cpu" int)
(required ~label:"memory" int)
(optional ~label:"block" utf8_string)
(optional ~label:"network_interfaces" (sequence_of utf8_string))
(required ~label:"image" image)
(optional ~label:"arguments" (sequence_of utf8_string)))
(* this is part of the state file (and unikernel_create command)
be aware if this (or a dependent grammar) is changed! *)
let v1_unikernel_config =
let open Unikernel in
let f (typ, (compressed, (image, (fail_behaviour, (cpuid, (memory, (blocks, (bridges, argv)))))))) =
let bridges = match bridges with None -> [] | Some xs -> List.map (fun b -> b, None) xs
and block_devices = match blocks with None -> [] | Some xs -> xs
in
{ typ ; compressed ; image ; fail_behaviour ; cpuid ; memory ; block_devices ; bridges ; argv }
and g _vm = failwith "cannot encode v1 unikernel configs"
in
Asn.S.(map f g @@ sequence @@
(required ~label:"typ" typ)
@ (required ~label:"compressed" bool)
@ (required ~label:"image" octet_string)
@ (required ~label:"fail behaviour" fail_behaviour)
@ (required ~label:"cpuid" int)
@ (required ~label:"memory" int)
@ (optional ~label:"blocks" (explicit 0 (set_of utf8_string)))
@ (optional ~label:"bridges" (explicit 1 (set_of utf8_string)))
-@ (optional ~label:"arguments"(explicit 2 (sequence_of utf8_string))))
let unikernel_config =
let open Unikernel in
let f (typ, (compressed, (image, (fail_behaviour, (cpuid, (memory, (blocks, (bridges, argv)))))))) =
let bridges = match bridges with None -> [] | Some xs -> xs
and block_devices = match blocks with None -> [] | Some xs -> xs
in
{ typ ; compressed ; image ; fail_behaviour ; cpuid ; memory ; block_devices ; bridges ; argv }
and g vm =
let bridges = match vm.bridges with [] -> None | xs -> Some xs
and blocks = match vm.block_devices with [] -> None | xs -> Some xs
in
(vm.typ, (vm.compressed, (vm.image, (vm.fail_behaviour, (vm.cpuid, (vm.memory, (blocks, (bridges, vm.argv))))))))
in
Asn.S.(map f g @@ sequence @@
(required ~label:"typ" typ)
@ (required ~label:"compressed" bool)
@ (required ~label:"image" octet_string)
@ (required ~label:"fail behaviour" fail_behaviour)
@ (required ~label:"cpuid" int)
@ (required ~label:"memory" int)
@ (optional ~label:"blocks" (explicit 0 (set_of utf8_string)))
@ (optional ~label:"bridges"
(explicit 1 (sequence_of
(sequence2
(required ~label:"netif" utf8_string)
(optional ~label:"bridge" utf8_string)))))
-@ (optional ~label:"arguments"(explicit 2 (sequence_of utf8_string))))
let unikernel_cmd =
let f = function
| `C1 `C1 () -> `Unikernel_info
| `C1 `C2 vm -> `Unikernel_create vm
| `C1 `C3 vm -> `Unikernel_force_create vm
| `C1 `C4 () -> `Unikernel_destroy
| `C1 `C5 vm -> `Unikernel_create vm
| `C1 `C6 vm -> `Unikernel_force_create vm
| `C2 `C1 () -> `Unikernel_get
| `C2 `C2 () -> assert false (* placeholder *)
and g = function
| `Unikernel_info -> `C1 (`C1 ())
| `Unikernel_create vm -> `C1 (`C5 vm)
| `Unikernel_force_create vm -> `C1 (`C6 vm)
| `Unikernel_destroy -> `C1 (`C4 ())
| `Unikernel_get -> `C2 (`C1 ())
in
Asn.S.map f g @@
Asn.S.(choice2
(choice6
(explicit 0 null)
(explicit 1 v1_unikernel_config)
(explicit 2 v1_unikernel_config)
(explicit 3 null)
(explicit 4 unikernel_config)
(explicit 5 unikernel_config))
(choice2
(explicit 6 null)
(explicit 7 null (* placeholder *) )))
let policy_cmd =
let f = function
| `C1 () -> `Policy_info
| `C2 policy -> `Policy_add policy
| `C3 () -> `Policy_remove
and g = function
| `Policy_info -> `C1 ()
| `Policy_add policy -> `C2 policy
| `Policy_remove -> `C3 ()
in
Asn.S.map f g @@
Asn.S.(choice3
(explicit 0 null)
(explicit 1 policy)
(explicit 2 null))
let block_cmd =
let f = function
| `C1 () -> `Block_info
| `C2 size -> `Block_add size
| `C3 () -> `Block_remove
and g = function
| `Block_info -> `C1 ()
| `Block_add size -> `C2 size
| `Block_remove -> `C3 ()
in
Asn.S.map f g @@
Asn.S.(choice3
(explicit 0 null)
(explicit 1 int)
(explicit 2 null))
let version =
let f data = match data with
| 4 -> `AV4
| 3 -> `AV3
| x -> Asn.S.error (`Parse (Printf.sprintf "unknown version number 0x%X" x))
and g = function
| `AV4 -> 4
| `AV3 -> 3
in
Asn.S.map f g Asn.S.int
let wire_command =
let f = function
| `C1 console -> `Console_cmd console
| `C2 stats -> `Stats_cmd stats
| `C3 log -> `Log_cmd log
| `C4 vm -> `Unikernel_cmd vm
| `C5 policy -> `Policy_cmd policy
| `C6 block -> `Block_cmd block
and g = function
| `Console_cmd c -> `C1 c
| `Stats_cmd c -> `C2 c
| `Log_cmd c -> `C3 c
| `Unikernel_cmd c -> `C4 c
| `Policy_cmd c -> `C5 c
| `Block_cmd c -> `C6 c
in
Asn.S.map f g @@
Asn.S.(choice6
(explicit 0 console_cmd)
(explicit 1 stats_cmd)
(explicit 2 log_cmd)
(explicit 3 unikernel_cmd)
(explicit 4 policy_cmd)
(explicit 5 block_cmd))
let data =
let f = function
| `C1 (timestamp, data) -> `Console_data (timestamp, data)
| `C2 (ru, ifs, vmm, mem) -> `Stats_data (ru, mem, vmm, ifs)
| `C3 (timestamp, event) -> `Log_data (timestamp, event)
and g = function
| `Console_data (timestamp, data) -> `C1 (timestamp, data)
| `Stats_data (ru, mem, ifs, vmm) -> `C2 (ru, vmm, ifs, mem)
| `Log_data (timestamp, event) -> `C3 (timestamp, event)
in
Asn.S.map f g @@
Asn.S.(choice3
(explicit 0 (sequence2
(required ~label:"timestamp" utc_time)
(required ~label:"data" utf8_string)))
(explicit 1 (sequence4
(required ~label:"resource_usage" ru)
(required ~label:"ifdata" (sequence_of ifdata))
(optional ~label:"vmm_stats" @@ explicit 0
(sequence_of (sequence2
(required ~label:"key" utf8_string)
(required ~label:"value" int64))))
(optional ~label:"kinfo_mem" @@ implicit 1 kinfo_mem)))
(explicit 2 (sequence2
(required ~label:"timestamp" utc_time)
(required ~label:"event" log_event))))
let header =
let f (version, sequence, name) = { version ; sequence ; name = to_name name }
and g h = h.version, h.sequence, of_name h.name
in
Asn.S.map f g @@
Asn.S.(sequence3
(required ~label:"version" version)
(required ~label:"sequence" int64)
(required ~label:"name" (sequence_of utf8_string)))
let success =
let f = function
| `C1 () -> `Empty
| `C2 str -> `String str
| `C3 policies -> `Policies (List.map (fun (name, p) -> to_name name, p) policies)
| `C4 vms -> `Unikernels (List.map (fun (name, vm) -> to_name name, vm) vms)
| `C5 blocks -> `Block_devices (List.map (fun (name, s, a) -> to_name name, s, a) blocks)
and g = function
| `Empty -> `C1 ()
| `String s -> `C2 s
| `Policies ps -> `C3 (List.map (fun (name, p) -> of_name name, p) ps)
| `Unikernels vms -> `C4 (List.map (fun (name, v) -> of_name name, v) vms)
| `Block_devices blocks -> `C5 (List.map (fun (name, s, a) -> of_name name, s, a) blocks)
in
Asn.S.map f g @@
Asn.S.(choice5
(explicit 0 null)
(explicit 1 utf8_string)
(explicit 2 (sequence_of
(sequence2
(required ~label:"name" (sequence_of utf8_string))
(required ~label:"policy" policy))))
(explicit 3 (sequence_of
(sequence2
(required ~label:"name" (sequence_of utf8_string))
(required ~label:"config" unikernel_config))))
(explicit 4 (sequence_of
(sequence3
(required ~label:"name" (sequence_of utf8_string))
(required ~label:"size" int)
(required ~label:"active" bool)))))
let payload =
let f = function
| `C1 cmd -> `Command cmd
| `C2 s -> `Success s
| `C3 str -> `Failure str
| `C4 data -> `Data data
and g = function
| `Command cmd -> `C1 cmd
| `Success s -> `C2 s
| `Failure str -> `C3 str
| `Data d -> `C4 d
in
Asn.S.map f g @@
Asn.S.(choice4
(explicit 0 wire_command)
(explicit 1 success)
(explicit 2 utf8_string)
(explicit 3 data))
let wire =
Asn.S.(sequence2
(required ~label:"header" header)
(required ~label:"payload" payload))
let wire_of_cstruct, wire_to_cstruct = projections_of wire
let log_entry =
Asn.S.(sequence2
(required ~label:"timestamp" utc_time)
(required ~label:"event" log_event))
let log_entry_of_cstruct, log_entry_to_cstruct = projections_of log_entry
let log_disk =
(* data is persisted to disk, we need to ensure to be able to decode (and
encode) properly without conflicts! *)
Asn.S.(sequence2
(required ~label:"version" version)
(required ~label:"entry" log_entry))
let log_disk_of_cstruct, log_disk_to_cstruct =
let c = Asn.codec Asn.der log_disk in
(Asn.decode c, Asn.encode c)
let log_to_disk entry = log_disk_to_cstruct (current, entry)
let skip_seq cs =
decode_seq_len cs >>= fun (l, off) ->
Ok (Cstruct.shift cs (l + off))
let logs_of_disk buf =
let rec next acc buf =
match log_disk_of_cstruct buf with
| Ok ((version, entry), cs) ->
Logs.info (fun m -> m "read a log entry version %a" pp_version version) ;
next (entry :: acc) cs
| Error (`Parse msg) ->
Logs.warn (fun m -> m "parse error %s while parsing log" msg) ;
match skip_seq buf with
| Ok cs' -> next acc cs'
| Error _ -> acc (* ignore *)
in
next [] buf
let trie e =
let f elts =
List.fold_left (fun trie (key, value) ->
match Name.of_string key with
| Error (`Msg m) -> invalid_arg m
| Ok name ->
let trie, ret = Vmm_trie.insert name value trie in
assert (ret = None);
trie) Vmm_trie.empty elts
and g trie =
List.map (fun (k, v) -> Name.to_string k, v) (Vmm_trie.all trie)
in
Asn.S.map f g @@
Asn.S.(sequence_of
(sequence2
(required ~label:"name" utf8_string)
(required ~label:"value" e)))
let version0_unikernels = trie v0_unikernel_config
let version1_unikernels = trie v1_unikernel_config
let version2_unikernels = trie unikernel_config
let unikernels =
(* the choice is the implicit version + migration... be aware when
any dependent data layout changes .oO(/o\) *)
let f = function
| `C1 data -> data
| `C2 data -> data
| `C3 data -> data
and g data =
`C3 data
in
Asn.S.map f g @@
Asn.S.(choice3
(explicit 0 version1_unikernels)
(explicit 1 version0_unikernels)
(explicit 2 version2_unikernels))
let unikernels_of_cstruct, unikernels_to_cstruct = projections_of unikernels
let cert_extension =
(* note that subCAs are deployed out there, thus modifying the encoding of
commands may break them. *)
Asn.S.(sequence2
(required ~label:"version" version)
(required ~label:"command" wire_command))
let of_cert_extension, to_cert_extension =
let a, b = projections_of cert_extension in
a, (fun d -> b (current, d))
Reference in New Issue View Git Blame Copy Permalink