From a0546bba889525574b066fe17f49f01aea4cfaa9 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Mon, 10 Apr 2017 22:35:44 +0200 Subject: [PATCH 1/2] miragesdk: use cap-n-proto instead of custom binary protocol for calf/priv API Signed-off-by: Thomas Gazagnaire --- projects/miragesdk/examples/mirage-dhcp.yml | 2 +- projects/miragesdk/src/Dockerfile.build | 22 +- projects/miragesdk/src/Dockerfile.dev | 22 +- projects/miragesdk/src/Makefile | 4 +- .../src/dhcp-client/calf/unikernel.ml | 11 +- projects/miragesdk/src/dhcp-client/main.ml | 6 +- projects/miragesdk/src/sdk/ctl.ml | 480 +++++++++--------- projects/miragesdk/src/sdk/ctl.mli | 157 +++--- projects/miragesdk/src/sdk/jbuild | 12 +- projects/miragesdk/src/sdk/proto.capnp | 19 + projects/miragesdk/src/test/test.ml | 111 ++-- 11 files changed, 435 insertions(+), 411 deletions(-) create mode 100644 projects/miragesdk/src/sdk/proto.capnp diff --git a/projects/miragesdk/examples/mirage-dhcp.yml b/projects/miragesdk/examples/mirage-dhcp.yml index 0e1d06db1..b159c620b 100644 --- a/projects/miragesdk/examples/mirage-dhcp.yml +++ b/projects/miragesdk/examples/mirage-dhcp.yml @@ -28,7 +28,7 @@ services: oomScoreAdj: -800 readonly: true - name: dhcp-client - image: mobylinux/dhcp-client:882ad65d1ef89a9a307b019c61f5f69301f59214 + image: mobylinux/dhcp-client:a7a6b49b0ff51ffa2f44ac848cd649e29f946e0c net: host capabilities: - CAP_NET_ADMIN # to bring eth0 up diff --git a/projects/miragesdk/src/Dockerfile.build b/projects/miragesdk/src/Dockerfile.build index 2fd882440..ee8017da3 100644 --- a/projects/miragesdk/src/Dockerfile.build +++ b/projects/miragesdk/src/Dockerfile.build @@ -1,20 +1,22 @@ FROM ocaml/opam:alpine-3.5_ocaml-4.04.0 RUN cd /home/opam/opam-repository && git pull && opam update -u -# to be able to use cstruct.ppx + jbuilder -RUN opam pin add cstruct 2.4.0 -n +## pins for priv + # to bring eth0 up RUN opam pin add tuntap 1.0.0 -n -RUN opam pin add mirage-net-fd --dev -n +RUN opam pin add mirage-net-fd 0.2.0 -n -RUN opam depext -iy mirage-net-unix logs-syslog irmin-unix cohttp decompress -RUN opam depext -iy rawlink tuntap jbuilder irmin-watcher inotify rresult +## pins for calf -# TMP: to compile the calf -RUN opam pin add -n charrua-client https://github.com/yomimono/charrua-client.git#state-halfway -RUN opam depext -uiy ocamlfind topkg-care ocamlbuild lwt mirage-types-lwt mirage -RUN opam depext -uiy charrua-client cohttp conduit mirage-unix -RUN opam depext -uiy mirage-net-fd ptime mirage-logs +RUN opam pin add charrua-client https://github.com/yomimono/charrua-client.git#state-halfway -n + +## depdendencies + +RUN opam depext -iy \ + irmin-unix cohttp decompress rawlink tuntap jbuilder irmin-watcher inotify \ + rresult lwt capnp charrua-client mirage-net-fd ptime bos \ + mirage-flow-lwt mirage-channel-lwt mirage-types-lwt RUN sudo mkdir -p /src COPY ./sdk /src/sdk diff --git a/projects/miragesdk/src/Dockerfile.dev b/projects/miragesdk/src/Dockerfile.dev index 8e55e5084..651fe74f8 100644 --- a/projects/miragesdk/src/Dockerfile.dev +++ b/projects/miragesdk/src/Dockerfile.dev @@ -1,20 +1,22 @@ FROM ocaml/opam:alpine-3.5_ocaml-4.04.0 RUN cd /home/opam/opam-repository && git pull && opam update -u -# to be able to use cstruct.ppx + jbuilder -RUN opam pin add cstruct 2.4.0 -n +## pins for priv + # to bring eth0 up RUN opam pin add tuntap 1.0.0 -n -RUN opam pin add mirage-net-fd --dev -n +RUN opam pin add mirage-net-fd 0.2.0 -n -RUN opam depext -iy mirage-net-unix logs-syslog irmin-unix cohttp decompress -RUN opam depext -iy rawlink tuntap jbuilder irmin-watcher inotify rresult +## pins for calf -# TMP: to compile the calf -RUN opam pin add -n charrua-client https://github.com/yomimono/charrua-client.git#state-halfway -RUN opam depext -uiy ocamlfind topkg-care ocamlbuild lwt mirage-types-lwt mirage -RUN opam depext -uiy charrua-client cohttp conduit mirage-unix -RUN opam depext -uiy mirage-net-fd ptime mirage-logs +RUN opam pin add charrua-client https://github.com/yomimono/charrua-client.git#state-halfway -n + +## depdendencies + +RUN opam depext -iy \ + irmin-unix cohttp decompress rawlink tuntap jbuilder irmin-watcher inotify \ + rresult lwt capnp charrua-client mirage-net-fd ptime bos \ + mirage-flow-lwt mirage-channel-lwt mirage-types-lwt RUN sudo mkdir -p /src /bin COPY . /src diff --git a/projects/miragesdk/src/Makefile b/projects/miragesdk/src/Makefile index 93dc3e834..4e13f2935 100644 --- a/projects/miragesdk/src/Makefile +++ b/projects/miragesdk/src/Makefile @@ -15,7 +15,7 @@ default: push @ .build: Dockerfile.build $(FILES) - docker build -t $(IMAGE):build -f Dockerfile.build -q . > .build || \ + docker build $(NO_CACHE) -t $(IMAGE):build -f Dockerfile.build -q . > .build || \ (rm -f $@ && exit 1) .pkg: Dockerfile.pkg $(OBJS) $(CALF_OBJS) obj/config.json @@ -23,7 +23,7 @@ default: push (rm -f $@ && exit 1) .dev: Dockerfile.dev init-dev.sh - docker build -t $(IMAGE):dev -f Dockerfile.dev -q . > .dev || \ + docker build $(NO_CACHE) -t $(IMAGE):dev -f Dockerfile.dev -q . > .dev || \ (rm -f $@ && exit 1) enter-pkg: .pkg diff --git a/projects/miragesdk/src/dhcp-client/calf/unikernel.ml b/projects/miragesdk/src/dhcp-client/calf/unikernel.ml index 49fa75bae..322a854da 100644 --- a/projects/miragesdk/src/dhcp-client/calf/unikernel.ml +++ b/projects/miragesdk/src/dhcp-client/calf/unikernel.ml @@ -175,18 +175,21 @@ let setup_log = module Dhcp_client = Dhcp_client_mirage.Make(Time)(Net) +let pp_path = Fmt.(list ~sep:(unit "/") string) + let set_ip ctl k ip = let str = Ipaddr.V4.to_string ip ^ "\n" in Sdk.Ctl.Client.write ctl k str >>= function | Ok () -> Lwt.return_unit - | Error e -> failf "error while writing %s: %a" k Sdk.Ctl.Client.pp_error e + | Error e -> + failf "error while writing %a: %a" pp_path k Sdk.Ctl.Client.pp_error e let set_ip_opt ctl k = function | None -> Lwt.return_unit | Some ip -> set_ip ctl k ip let get_mac ctl = - Sdk.Ctl.Client.read ctl "/mac" >>= function + Sdk.Ctl.Client.read ctl ["mac"] >>= function | Ok None -> Lwt.return None | Ok Some s -> Lwt.return @@ Macaddr.of_string (String.trim s) | Error e -> failf "get_mac: %a" Sdk.Ctl.Client.pp_error e @@ -208,8 +211,8 @@ let start () dhcp_codes net ctl = Lwt_stream.last_new stream >>= fun result -> let result = of_ipv4_config result in Log.info (fun l -> l "found lease: %a" pp result); - set_ip ctl "/ip" result.address >>= fun () -> - set_ip_opt ctl "/gateway" result.gateway + set_ip ctl ["ip"] result.address >>= fun () -> + set_ip_opt ctl ["gateway"] result.gateway (* FIXME: Main end *) diff --git a/projects/miragesdk/src/dhcp-client/main.ml b/projects/miragesdk/src/dhcp-client/main.ml index 717da27b2..6ae838926 100644 --- a/projects/miragesdk/src/dhcp-client/main.ml +++ b/projects/miragesdk/src/dhcp-client/main.ml @@ -84,9 +84,9 @@ let run () cmd ethif path = in Lwt_main.run ( let routes = [ - "/ip" , [`Write]; - "/mac" , [`Read ]; - "/gateway", [`Write]; + ["ip"] , [`Write]; + ["mac"] , [`Read ]; + ["gateway"], [`Write]; ] in Ctl.v path >>= fun db -> let ctl fd = Ctl.Server.listen ~routes db fd in diff --git a/projects/miragesdk/src/sdk/ctl.ml b/projects/miragesdk/src/sdk/ctl.ml index bb911df4d..11a339137 100644 --- a/projects/miragesdk/src/sdk/ctl.ml +++ b/projects/miragesdk/src/sdk/ctl.ml @@ -1,11 +1,8 @@ open Lwt.Infix -open Astring let src = Logs.Src.create "init" ~doc:"Init steps" module Log = (val Logs.src_log src : Logs.LOG) -let failf fmt = Fmt.kstrf Lwt.fail_with fmt - (* FIXME: to avoid linking with gmp *) module No_IO = struct type ic = unit @@ -36,214 +33,199 @@ let () = module C = Mirage_channel_lwt.Make(IO) -module Query = struct +module P = Proto.Make(Capnp.BytesMessage) - (* FIXME: this should probably be replaced by protobuf *) +exception Undefined_field of int - [%%cenum - type operation = - | Write - | Read - | Delete - [@@uint8_t] - ] +module Endpoint = struct + + let compression = `None type t = { - version : int32; - id : int32; - operation: operation; - path : string; - payload : string; + output : IO.t; + input : C.t; (* reads are buffered *) + decoder: Capnp.Codecs.FramedStream.t; } - [%%cstruct type msg = { - version : uint32_t; (* protocol version *) - id : uint32_t; (* session identifier *) - operation : uint8_t; (* = type operation *) - path : uint16_t; - payload : uint32_t; - } [@@little_endian] + type error = [ + | `IO of IO.write_error + | `Channel of C.error + | `Msg of string + | `Undefined_field of int ] - type error = [ `Eof | `Msg of string ] - let pp_error ppf t = Fmt.string ppf (match t with `Eof -> "EOF" | `Msg s -> s) + let pp_error ppf (e:error) = match e with + | `IO e -> Fmt.pf ppf "IO: %a" IO.pp_write_error e + | `Channel e -> Fmt.pf ppf "channel: %a" C.pp_error e + | `Msg e -> Fmt.string ppf e + | `Undefined_field i -> Fmt.pf ppf "undefined field %d" i - (* to avoid warning 32 *) - let _ = hexdump_msg - let _ = string_to_operation + let err_io e = Error (`IO e) + let err_channel e = Error (`Channel e) + let err_msg fmt = Fmt.kstrf (fun s -> Error (`Msg s)) fmt + let err_frame = err_msg "Unsupported Cap'n'Proto frame received" + let err_undefined_field i = Error (`Undefined_field i) - let pp ppf t = - Fmt.pf ppf "%ld:%s:%S:%S" - t.id (operation_to_string t.operation) t.path t.payload + let v fd = + let output = fd in + let input = C.create fd in + let decoder = Capnp.Codecs.FramedStream.empty compression in + { output; input; decoder } - (* FIXME: allocate less ... *) + let send t msg = + let buf = Capnp.Codecs.serialize ~compression msg in + (* FIXME: avoid copying *) + IO.write t.output (Cstruct.of_string buf) >|= function + | Error e -> err_io e + | Ok () -> Ok () - let of_cstruct buf = - let open Rresult.R in - Log.debug (fun l -> l "Query.of_cstruct %S" @@ Cstruct.to_string buf); - let version = get_msg_version buf in - let id = get_msg_id buf in - (match int_to_operation (get_msg_operation buf) with - | None -> Error (`Msg "invalid operation") - | Some o -> Ok o) - >>= fun operation -> - let path_len = get_msg_path buf in - let payload_len = get_msg_payload buf in - let path = - Cstruct.sub buf sizeof_msg path_len - |> Cstruct.to_string - in - let payload = - Cstruct.sub buf (sizeof_msg + path_len) (Int32.to_int payload_len) - |> Cstruct.to_string - in - if String.Ascii.is_valid path then Ok { version; id; operation; path; payload } - else Error (`Msg "invalid path") - - let to_cstruct msg = - Log.debug (fun l -> l "Query.to_cstruct %a" pp msg); - let operation = operation_to_int msg.operation in - let path = String.length msg.path in - let payload = String.length msg.payload in - let len = sizeof_msg + path + payload in - let buf = Cstruct.create len in - set_msg_version buf msg.version; - set_msg_id buf msg.id; - set_msg_operation buf operation; - set_msg_path buf path; - set_msg_payload buf (Int32.of_int payload); - Cstruct.blit_from_bytes msg.path 0 buf sizeof_msg path; - Cstruct.blit_from_bytes msg.payload 0 buf (sizeof_msg+path) payload; - buf - - let err e = Lwt.return (Error (`Msg (Fmt.to_to_string C.pp_error e))) - let err_eof = Lwt.return (Error `Eof) - - let read fd = - let fd = C.create fd in - C.read_exactly fd ~len:4 >>= function - | Ok `Eof -> err_eof - | Error e -> err e - | Ok (`Data buf) -> - let buf = Cstruct.concat buf in - Log.debug (fun l -> l "Message.read len=%a" Cstruct.hexdump_pp buf); - let len = Cstruct.LE.get_uint32 buf 0 |> Int32.to_int in - C.read_exactly fd ~len >>= function - | Ok `Eof -> err_eof - | Error e -> err e - | Ok (`Data buf) -> - let buf = Cstruct.concat buf in - Lwt.return (of_cstruct buf) - - let write fd msg = - let buf = to_cstruct msg in - let len = - let len = Cstruct.create 4 in - Cstruct.LE.set_uint32 len 0 (Int32.of_int @@ Cstruct.len buf); - len - in - IO.write fd len >>= function - | Error e -> failf "Query.write(len) %a" IO.pp_write_error e - | Ok () -> IO.write fd buf >>= function - | Ok () -> Lwt.return_unit - | Error e -> failf "Query.write(buf) %a" IO.pp_write_error e + let rec recv t = + match Capnp.Codecs.FramedStream.get_next_frame t.decoder with + | Ok msg -> Lwt.return (Ok (`Data msg)) + | Error Capnp.Codecs.FramingError.Unsupported -> Lwt.return err_frame + | Error Capnp.Codecs.FramingError.Incomplete -> + Log.info (fun f -> f "Endpoint.recv: incomplete; waiting for more data"); + C.read_some ~len:4096 t.input >>= function + | Ok `Eof -> Lwt.return (Ok `Eof) + | Error e -> Lwt.return (err_channel e) + | Ok (`Data data) -> + (* FIXME: avoid copying *) + let data = Cstruct.to_string data in + Log.info (fun f -> f "Got %S" data); + Capnp.Codecs.FramedStream.add_fragment t.decoder data; + recv t end -module Reply = struct +module Request = struct - (* FIXME: this should probably be replaced by protobuf *) + type action = + | Write of string + | Read + | Delete - [%%cenum - type status = - | Ok - | Error - [@@uint8_t] - ] + let pp_action ppf = function + | Write s -> Fmt.pf ppf "write[%S]" s + | Read -> Fmt.pf ppf "read" + | Delete -> Fmt.pf ppf "delete" type t = { - id : int32; - status : status; - payload: string; + id : int32 Lazy.t; + path : string list Lazy.t; + action: action Lazy.t; } - [%%cstruct type msg = { - id : uint32_t; (* session identifier *) - status : uint8_t; (* = type operation *) - payload: uint32_t; - } [@@little_endian] - ] + let id t = Lazy.force t.id + let path t = Lazy.force t.path + let action t = Lazy.force t.action - type error = [ `Eof | `Msg of string ] - let pp_error ppf t = Fmt.string ppf (match t with `Eof -> "EOF" | `Msg s -> s) - - (* to avoid warning 32 *) - let _ = hexdump_msg - let _ = string_to_status + let pp_path = Fmt.(list ~sep:(unit "/") string) let pp ppf t = - Fmt.pf ppf "%ld:%s:%S" t.id (status_to_string t.status) t.payload + let id = id t and path = path t and action = action t in + match action with + | exception Undefined_field i -> Fmt.pf ppf "" i + | action -> Fmt.pf ppf "%ld:%a:%a" id pp_path path pp_action action - (* FIXME: allocate less ... *) + let equal x y = + id x = id y && path x = path y && match action x = action y with + | exception Undefined_field _ -> false + | b -> b - let of_cstruct buf = - let open Rresult.R in - Log.debug (fun l -> l "Message.of_cstruct %S" @@ Cstruct.to_string buf); - let id = get_msg_id buf in - (match int_to_status (get_msg_status buf) with - | None -> Error (`Msg "invalid operation") - | Some o -> Ok o) - >>= fun status -> - let payload_len = Int32.to_int (get_msg_payload buf) in - let payload = - Cstruct.sub buf sizeof_msg payload_len - |> Cstruct.to_string - in - Ok { id; status; payload } + let v ~id ~path action = + { id = lazy id; action = lazy action; path = lazy path } - let to_cstruct msg = - Log.debug (fun l -> l "Message.to_cstruct %a" pp msg); - let status = status_to_int msg.status in - let payload = String.length msg.payload in - let len = sizeof_msg + payload in - let buf = Cstruct.create len in - set_msg_id buf msg.id; - set_msg_status buf status; - set_msg_payload buf (Int32.of_int payload); - Cstruct.blit_from_bytes msg.payload 0 buf sizeof_msg payload; - buf + let read e: (t, Endpoint.error) result Lwt.t = + Endpoint.recv e >|= function + | Error e -> Error e + | Ok `Eof -> Error (`IO `Closed) + | Ok (`Data x) -> + let open P.Reader in + let msg = Request.of_message x in + let id = lazy (Request.id_get msg) in + let path = lazy (Request.path_get_list msg) in + let action = lazy (match Request.get msg with + | Request.Write x -> Write x + | Request.Read -> Read + | Request.Delete -> Delete + | Request.Undefined i -> raise (Undefined_field i) + ) in + Ok { id; path; action } - let err e = Lwt.return (Result.Error (`Msg (Fmt.to_to_string C.pp_error e))) - let err_eof = Lwt.return (Result.Error `Eof) + let write e t = + let open P.Builder in + match action t with + | exception Undefined_field i -> Lwt.return (Endpoint.err_undefined_field i) + | action -> + let msg = + let b = Request.init_root () in + Request.id_set b (id t); + ignore (Request.path_set_list b (path t)); + (match action with + | Write x -> Request.write_set b x + | Read -> Request.read_set b + | Delete -> Request.delete_set b); + b + in + Endpoint.send e (Request.to_message msg) - let read fd = - let fd = C.create fd in - C.read_exactly fd ~len:4 >>= function - | Ok `Eof -> err_eof - | Error e -> err e - | Ok (`Data buf) -> - let buf = Cstruct.concat buf in - Log.debug (fun l -> l "Message.read len=%a" Cstruct.hexdump_pp buf); - let len = Cstruct.LE.get_uint32 buf 0 |> Int32.to_int in - C.read_exactly fd ~len >>= function - | Ok `Eof -> err_eof - | Error e -> err e - | Ok (`Data buf) -> - let buf = Cstruct.concat buf in - Lwt.return (of_cstruct buf) +end - let write fd msg = - let buf = to_cstruct msg in - let len = - let len = Cstruct.create 4 in - Cstruct.LE.set_uint32 len 0 (Int32.of_int @@ Cstruct.len buf); - len - in - IO.write fd len >>= function - | Error e -> failf "Reply.write(len) %a" IO.pp_write_error e - | Ok () -> IO.write fd buf >>= function - | Ok () -> Lwt.return_unit - | Error e -> failf "Reply.write(buf) %a" IO.pp_write_error e +module Response = struct + + type status = (string, string) result + + let pp_status ppf = function + | Ok ok -> Fmt.pf ppf "ok:%S" ok + | Error e -> Fmt.pf ppf "error:%S" e + + type t = { + id : int32 Lazy.t; + status: status Lazy.t; + } + + let v ~id status = { id = lazy id; status = lazy status } + let id t = Lazy.force t.id + let status t = Lazy.force t.status + + let pp ppf t = match status t with + | exception Undefined_field i -> Fmt.pf ppf "" i + | s -> Fmt.pf ppf "%ld:%a" (id t) pp_status s + + let equal x y = + id x = id y && match status x = status y with + | exception Undefined_field _ -> false + | b -> b + + let read e: (t, Endpoint.error) result Lwt.t = + Endpoint.recv e >|= function + | Error e -> Error e + | Ok `Eof -> Error (`IO `Closed) + | Ok (`Data x) -> + let open P.Reader in + let msg = Response.of_message x in + let id = lazy (Response.id_get msg) in + let status = lazy (match Response.get msg with + | Response.Ok x -> Ok x + | Response.Error x -> Error x + | Response.Undefined i -> raise (Undefined_field i) + ) in + Ok { id; status } + + let write e t = + let open P.Builder in + match status t with + | exception Undefined_field i -> Lwt.return (Endpoint.err_undefined_field i) + | s -> + let msg = + let b = Response.init_root () in + Response.id_set b (id t); + (match s with + | Error s -> Response.error_set b s + | Ok s -> Response.ok_set b s); + b + in + Endpoint.send e (Response.to_message msg) end @@ -255,8 +237,6 @@ module Client = struct let n = ref 0l in fun () -> n := Int32.succ !n; !n - let version = 0l - type error = [`Msg of string] let pp_error ppf (`Msg s) = Fmt.string ppf s @@ -268,60 +248,64 @@ module Client = struct module Cache = Hashtbl.Make(K) type t = { - fd : IO.t; - replies: Reply.t Cache.t; + e : Endpoint.t; + replies: Response.t Cache.t; } - let v fd = { fd; replies = Cache.create 12 } + let v fd = { e = Endpoint.v fd; replies = Cache.create 12 } + let err e = Fmt.kstrf (fun e -> Error (`Msg e)) "%a" Endpoint.pp_error e - let call t query = - let id = query.Query.id in - Query.write t.fd query >>= fun () -> - let rec loop () = - try - let r = Cache.find t.replies id in - Cache.remove t.replies id; - Lwt.return r - with Not_found -> - Reply.read t.fd >>= function - | Error e -> - Log.err (fun l -> l "Got %a while waiting for a reply to %ld" - Query.pp_error e id); - loop () - | Ok r -> - if r.id = id then Lwt.return r - else ( - (* FIXME: maybe we want to check if id is not already - allocated *) - Cache.add t.replies r.id r; + let call t r = + let id = Request.id r in + Request.write t.e r >>= function + | Error e -> Lwt.return (err e) + | Ok () -> + let rec loop () = + try + let r = Cache.find t.replies id in + Cache.remove t.replies id; + Lwt.return r + with Not_found -> + Response.read t.e >>= function + | Error e -> + Log.err (fun l -> l "Got %a while waiting for a reply to %ld" + Endpoint.pp_error e id); loop () - ) - in - loop () >|= fun r -> - assert (r.Reply.id = id); - match r.Reply.status with - | Ok -> Ok r.Reply.payload - | Error -> Error (`Msg r.Reply.payload) + | Ok r -> + let rid = Response.id r in + if rid = id then Lwt.return r + else ( + (* FIXME: maybe we want to check if id is not already + allocated *) + Cache.add t.replies rid r; + loop () + ) + in + loop () >|= fun r -> + assert (Response.id r = id); + match Response.status r with + | Ok s -> Ok s + | Error s -> Error (`Msg s) - let query operation path payload = + let request path action = let id = new_id () in - { Query.version; id; operation; path; payload } + Request.v ~id ~path action let read t path = - call t (query Read path "") >|= function - | Ok x -> Ok (Some x) - | Error (`Msg e) -> - if e = err_not_found then Ok None - else Error (`Msg e) + call t (request path Read) >|= function + | Ok x -> Ok (Some x) + | Error e -> + if e = `Msg err_not_found then Ok None + else Error e let write t path v = - call t (query Write path v) >|= function + call t (request path @@ Write v) >|= function | Ok "" -> Ok () | Ok _ -> Error (`Msg "invalid return") | Error _ as e -> e let delete t path = - call t (query Delete path "") >|= function + call t (request path Delete) >|= function | Ok "" -> Ok () | Ok _ -> Error (`Msg "invalid return") | Error _ as e -> e @@ -332,17 +316,9 @@ module Server = struct type op = [ `Read | `Write | `Delete ] - let ok q payload = - { Reply.id = q.Query.id; status = Reply.Ok; payload } - - let error q payload = - { Reply.id = q.Query.id; status = Reply.Error; payload } - - let with_key q f = - match KV.Key.of_string q.Query.path with - | Ok x -> f x - | Error (`Msg e) -> - Fmt.kstrf (fun msg -> Lwt.return (error q msg)) "invalid key: %s" e + let ok q s = Response.v ~id:(Request.id q) (Ok s) + let error q s = Response.v ~id:(Request.id q) (Error s) + let with_key q f = f (Request.path q) let infof fmt = Fmt.kstrf (fun msg () -> @@ -351,18 +327,20 @@ module Server = struct ) fmt let not_allowed q = - let path = q.Query.path in - let err = Fmt.strf "%s is not an allowed path" path in - Log.err (fun l -> l "%ld: %s" q.Query.id path); + let path = Request.path q in + let err = Fmt.strf "%a is not an allowed path" Request.pp_path path in + Log.err (fun l -> l "%ld: %a" (Request.id q) Request.pp_path path); error q err let dispatch db op q = with_key q (fun key -> let can x = List.mem x op in - match q.Query.operation with - | Write when can `Write -> + match Request.action q with + | exception Undefined_field i -> + Fmt.kstrf (fun e -> Lwt.return (error q e)) "undefined field %i" i + | Write s when can `Write -> let info = infof "Updating %a" KV.Key.pp key in - KV.set db ~info key q.payload >|= fun () -> + KV.set db ~info key s >|= fun () -> ok q "" | Delete when can `Delete -> let info = infof "Removing %a" KV.Key.pp key in @@ -379,11 +357,14 @@ module Server = struct Log.debug (fun l -> l "Serving the control state over %a" IO.pp fd); let queries = Queue.create () in let cond = Lwt_condition.create () in + let e = Endpoint.v fd in let rec listen () = - Query.read fd >>= function - | Error `Eof -> Lwt.return_unit - | Error (`Msg e) -> - Log.err (fun l -> l "received invalid message: %s" e); + Request.read e >>= function + | Error (`Channel _ | `IO _ as e) -> + Log.err (fun l -> l "fatal error: %a" Endpoint.pp_error e); + Lwt.return_unit + | Error (`Msg _ | `Undefined_field _ as e) -> + Log.err (fun l -> l "transient error: %a" Endpoint.pp_error e); listen () | Ok q -> Queue.add q queries; @@ -393,15 +374,18 @@ module Server = struct let rec process () = Lwt_condition.wait cond >>= fun () -> let q = Queue.pop queries in - let path = q.Query.path in + let path = Request.path q in (if List.mem_assoc path routes then ( let op = List.assoc path routes in dispatch db op q >>= fun r -> - Reply.write fd r + Response.write e r ) else ( - Reply.write fd (not_allowed q) - )) >>= fun () -> - process () + Response.write e (not_allowed q) + )) >>= function + | Ok () -> process () + | Error e -> + Log.err (fun l -> l "%a" Endpoint.pp_error e); + process () in Lwt.pick [ listen (); diff --git a/projects/miragesdk/src/sdk/ctl.mli b/projects/miragesdk/src/sdk/ctl.mli index 92f80dcd5..896dfefdd 100644 --- a/projects/miragesdk/src/sdk/ctl.mli +++ b/projects/miragesdk/src/sdk/ctl.mli @@ -1,81 +1,102 @@ (** [Control] handle the server part of the control path, running in the privileged container. *) -module Query: sig - (** The type for operations. *) - type operation = - | Write - | Read - | Delete +exception Undefined_field of int - (** The type for control plane queries. *) - type t = { - version : int32; (** Protocol version. *) - id : int32; (** Session identifier. *) - operation: operation; - path : string; (** Should be only valid ASCII. *) - payload : string; (** Arbitrary payload. *) - } +module Endpoint: sig - type error = [ `Eof | `Msg of string ] - (** The type of errors. *) + type t + (** The type for SDK endpoints. *) - val pp_error: error Fmt.t - (** [pp_error] is the pretty-printer for query errors. *) + val v: IO.t ->t + (** [v f] is a fresh endpoint state built on top of the flow [f]. *) - val pp: t Fmt.t - (** [pp] is the pretty-printer for queries. *) - - val of_cstruct: Cstruct.t -> (t, [`Msg of string]) result - (** [of_cstruct buf] is the query [t] such that the serialization of - [t] is [buf]. *) - - val to_cstruct: t -> Cstruct.t - (** [to_cstruct t] is the serialization of [t]. *) - - val write: IO.flow -> t -> unit Lwt.t - (** [write fd t] writes a query message. *) - - val read: IO.flow -> (t, error) result Lwt.t - (** [read fd] reads a query message. *) - -end - -module Reply: sig - - (** The type for status. *) - type status = - | Ok - | Error - - (** The type for control plane replies. *) - type t = { - id : int32; (** Session identifier. *) - status : status; (** Status of the operation. *) - payload: string; (** Arbitrary payload. *) - } - - val pp: t Fmt.t - (** [pp] is the pretty-printer for replies. *) - - val of_cstruct: Cstruct.t -> (t, [`Msg of string]) result - (** [of_cstruct buf] is the reply [t] such that the serialization of - [t] is [buf]. *) - - val to_cstruct: t -> Cstruct.t - (** [to_cstruct t] is the serialization of [t]. *) - - type error = [`Eof | `Msg of string ] - (** The type for reply errors. *) + (** The type for endpoint errors. *) + type error = private [> + | `IO of IO.write_error + | `Msg of string + | `Undefined_field of int + ] val pp_error: error Fmt.t (** [pp_error] is the pretty-printer for errors. *) - val write: IO.flow -> t -> unit Lwt.t +end + +module Request: sig + + type t + (** The type for SDK requests. *) + + (** The type for request actions. *) + type action = + | Write of string + | Read + | Delete + + val pp: t Fmt.t + (** [pp] is the pretty-printer for requests. *) + + val equal: t -> t -> bool + (** [equal] is the equality function for requests. *) + + val pp_action: action Fmt.t + (** [pp_action] is the pretty-printer for request actions. *) + + val action: t -> action + (** [action t] is [t]'s requested operation. Can raise + [Endpoint.Undefined_field]. *) + + val path: t -> string list + (** [path t] is the [t]'s request path. *) + + val id: t -> int32 + (** [id t] it [t]'s request id. *) + + val v: id:int32 -> path:string list -> action -> t + (** [v ~id ~path action] is a new request. *) + + val write: Endpoint.t -> t -> (unit, Endpoint.error) result Lwt.t + (** [write e t] writes a request message for the + action [action] and the path [path] using the unique ID [id]. *) + + val read: Endpoint.t -> (t, Endpoint.error) result Lwt.t + (** [read e] reads a query message. *) + +end + +module Response: sig + + type t + (** The type for responses. *) + + (** The type for response status. *) + type status = (string, string) result + + val pp: t Fmt.t + (** [pp] is the pretty-printer for responses. *) + + val equal: t -> t -> bool + (** [equal] is the equality function for responses. *) + + val pp_status: status Fmt.t + (** [pp_status] is the pretty-printer for response statuses. *) + + val status: t -> status + (** [status t] is [t]'s response status. Can raise + [Endpoint.Undefined_field]. *) + + val id: t -> int32 + (** [id t] is [t]'s response ID. *) + + val v: id:int32 -> status -> t + (** [v ~id status] is a new response. *) + + val write: Endpoint.t -> t -> (unit, Endpoint.error) result Lwt.t (** [write fd t] writes a reply message. *) - val read: IO.flow -> (t, error) result Lwt.t + val read: Endpoint.t -> (t, Endpoint.error) result Lwt.t (** [read fd] reads a reply message. *) end @@ -103,16 +124,16 @@ module Client: sig server. A client state also stores some state for all the incomplete client queries. *) - val read: t -> string -> (string option, error) result Lwt.t + val read: t -> string list -> (string option, error) result Lwt.t (** [read t k] is the value associated with the key [k] in the control plane state. Return [None] if no value is associated to [k]. *) - val write: t -> string -> string -> (unit, error) result Lwt.t + val write: t -> string list -> string -> (unit, error) result Lwt.t (** [write t p v] associates [v] to the key [k] in the control plane state. *) - val delete: t -> string -> (unit, error) result Lwt.t + val delete: t -> string list -> (unit, error) result Lwt.t (** [delete t k] remove [k]'s binding in the control plane state. *) end @@ -129,7 +150,7 @@ module Server: sig type op = [ `Read | `Write | `Delete ] (** The type for operations to perform on routes. *) - val listen: routes:(string * op list) list -> KV.t -> IO.t -> unit Lwt.t + val listen: routes:(string list * op list) list -> KV.t -> IO.t -> unit Lwt.t (** [listen ~routes kv fd] is the thread exposing the KV store [kv], holding control plane state, running inside the privileged container. [routes] are the routes exposed by the server to the diff --git a/projects/miragesdk/src/sdk/jbuild b/projects/miragesdk/src/sdk/jbuild index 8fb46a101..ffaecc244 100644 --- a/projects/miragesdk/src/sdk/jbuild +++ b/projects/miragesdk/src/sdk/jbuild @@ -5,6 +5,14 @@ (libraries (threads cstruct.lwt cmdliner fmt.cli logs.fmt logs.cli fmt.tty decompress irmin irmin-git lwt.unix rawlink tuntap dispatch irmin-watcher inotify astring rresult mirage-flow-lwt - mirage-channel-lwt io-page.unix ipaddr)) - (preprocess (per_file ((pps (cstruct.ppx)) (ctl)))) + mirage-channel-lwt io-page.unix ipaddr capnp)) )) + +(rule + ((targets (proto.ml proto.mli)) + (deps (proto.capnp)) + (action (progn + (run capnp compile -o ocaml ${<}) + (system "mv proto.ml proto.ml.in") + (system "echo '[@@@ocaml.warning \"-A\"]\n' > proto.ml") + (system "cat proto.ml.in >> proto.ml"))))) diff --git a/projects/miragesdk/src/sdk/proto.capnp b/projects/miragesdk/src/sdk/proto.capnp new file mode 100644 index 000000000..b204d1478 --- /dev/null +++ b/projects/miragesdk/src/sdk/proto.capnp @@ -0,0 +1,19 @@ +@0x9e83562906de8259; + +struct Request { + id @0 :Int32; + path @1 :List(Text); + union { + write @2 :Data; + read @3 :Void; + delete @4 :Void; + } +} + +struct Response { + id @0: Int32; + union { + ok @1 :Data; + error @2 :Data; + } +} diff --git a/projects/miragesdk/src/test/test.ml b/projects/miragesdk/src/test/test.ml index ac279b9ad..637148770 100644 --- a/projects/miragesdk/src/test/test.ml +++ b/projects/miragesdk/src/test/test.ml @@ -93,119 +93,107 @@ let test_socketpair pipe () = Lwt.return_unit -let query = Alcotest.testable Ctl.Query.pp (=) -let reply = Alcotest.testable Ctl.Reply.pp (=) +let request = Alcotest.testable Ctl.Request.pp Ctl.Request.equal +let response = Alcotest.testable Ctl.Response.pp Ctl.Response.equal let queries = - let open Ctl.Query in + let open Ctl.Request in [ - { version = 0l; id = 0l; operation = Read; path = "/foo/bar"; payload = "" }; - { version = Int32.max_int; id = Int32.max_int; operation = Write ; path = ""; payload = "foo" }; - { version = 1l;id = 0l; operation = Delete; path = ""; payload = "" }; - { version = -2l; id = -3l; operation = Delete; path = "foo"; payload = "foo" }; + v ~id:0l ~path:["foo";"bar"] Read; + v ~id:Int32.max_int ~path:[] (Write "foo"); + v ~id:0l ~path:[] Delete; + v ~id:(-3l) ~path:["foo"] Delete; ] let replies = - let open Ctl.Reply in + let open Ctl.Response in [ - { id = 0l; status = Ok; payload = "" }; - { id = Int32.max_int; status = Ok; payload = "foo" }; - { id = 0l; status = Error; payload = "" }; - { id = -3l; status = Error; payload = "foo" }; + v ~id:0l (Ok ""); + v ~id:Int32.max_int (Ok "foo"); + v ~id:0l (Error ""); + v ~id:(-3l) (Error "foo"); ] -let test_serialization to_cstruct of_cstruct message messages = - let test m = - let buf = to_cstruct m in - match of_cstruct buf with - | Ok m' -> Alcotest.(check message) "to_cstruct/of_cstruct" m m' - | Error (`Msg e) -> Alcotest.fail ("Message.of_cstruct: " ^ e) - in - List.iter test messages +let failf fmt = Fmt.kstrf Alcotest.fail fmt -let test_send t write read message pp_error messages = - let calf = calf Init.Pipe.(ctl t) in - let priv = priv Init.Pipe.(ctl t) in +let test_send t write read message messages = + let calf = Ctl.Endpoint.v @@ calf Init.Pipe.(ctl t) in + let priv = Ctl.Endpoint.v @@ priv Init.Pipe.(ctl t) in let test m = - write calf m >>= fun () -> - read priv >|= function - | Ok m' -> Alcotest.(check message) "write/read" m m' - | Error e -> Fmt.kstrf Alcotest.fail "Message.read: %a" pp_error e + write calf m >>= function + | Error e -> failf "Message.write: %a" Ctl.Endpoint.pp_error e + | Ok () -> + read priv >|= function + | Ok m' -> Alcotest.(check message) "write/read" m m' + | Error e -> failf "Message.read: %a" Ctl.Endpoint.pp_error e in Lwt_list.iter_s test messages -let test_query_serialization () = - let open Ctl.Query in - test_serialization to_cstruct of_cstruct query queries +let test_request_send t () = + let open Ctl.Request in + test_send t write read request queries -let test_reply_serialization () = - let open Ctl.Reply in - test_serialization to_cstruct of_cstruct reply replies - -let test_query_send t () = - let open Ctl.Query in - test_send t write read query pp_error queries - -let test_reply_send t () = - let open Ctl.Reply in - test_send t write read reply pp_error replies +let test_response_send t () = + let open Ctl.Response in + test_send t write read response replies let failf fmt = Fmt.kstrf Alcotest.fail fmt (* read ops *) let pp_error = Ctl.Client.pp_error +let pp_path = Fmt.(Dump.list string) let read_should_err t k = Ctl.Client.read t k >|= function | Error _ -> () - | Ok None -> failf "read(%s) -> got: none, expected: err" k - | Ok Some v -> failf "read(%s) -> got: found:%S, expected: err" k v + | Ok None -> failf "read(%a) -> got: none, expected: err" pp_path k + | Ok Some v -> failf "read(%a) -> got: found:%S, expected: err" pp_path k v let read_should_none t k = Ctl.Client.read t k >|= function - | Error e -> failf "read(%s) -> got: error:%a, expected none" k pp_error e + | Error e -> failf "read(%a) -> got: error:%a, expected none" pp_path k pp_error e | Ok None -> () - | Ok Some v -> failf "read(%s) -> got: found:%S, expected none" k v + | Ok Some v -> failf "read(%a) -> got: found:%S, expected none" pp_path k v let read_should_work t k v = Ctl.Client.read t k >|= function - | Error e -> failf "read(%s) -> got: error:%a, expected ok" k pp_error e - | Ok None -> failf "read(%s) -> got: none, expected ok" k + | Error e -> failf "read(%a) -> got: error:%a, expected ok" pp_path k pp_error e + | Ok None -> failf "read(%a) -> got: none, expected ok" pp_path k | Ok Some v' -> - if v <> v' then failf "read(%s) -> got: ok:%S, expected: ok:%S" k v' v + if v <> v' then failf "read(%a) -> got: ok:%S, expected: ok:%S" pp_path k v' v (* write ops *) let write_should_err t k v = Ctl.Client.write t k v >|= function - | Ok () -> failf "write(%s) -> ok" k + | Ok () -> failf "write(%a) -> ok" pp_path k | Error _ -> () let write_should_work t k v = Ctl.Client.write t k v >|= function | Ok () -> () - | Error e -> failf "write(%s) -> error: %a" k pp_error e + | Error e -> failf "write(%a) -> error: %a" pp_path k pp_error e (* del ops *) let delete_should_err t k = Ctl.Client.delete t k >|= function - | Ok () -> failf "del(%s) -> ok" k + | Ok () -> failf "del(%a) -> ok" pp_path k | Error _ -> () let delete_should_work t k = Ctl.Client.delete t k >|= function | Ok () -> () - | Error e -> failf "write(%s) -> error: %a" k pp_error e + | Error e -> failf "write(%a) -> error: %a" pp_path k pp_error e let test_ctl t () = let calf = calf Init.Pipe.(ctl t) in let priv = priv Init.Pipe.(ctl t) in - let k1 = "/foo/bar" in - let k2 = "a" in - let k3 = "b/c" in - let k4 = "xxxxxx" in + let k1 = ["foo"; "bar"] in + let k2 = ["a"] in + let k3 = ["b"; "c"] in + let k4 = ["xxxxxx"] in let all = [`Read; `Write; `Delete] in let routes = [k1,all; k2,all; k3,all ] in let git_root = "/tmp/sdk/ctl" in @@ -215,12 +203,11 @@ let test_ctl t () = let client () = let t = Ctl.Client.v calf in let allowed k v = - delete_should_work t k >>= fun () -> + delete_should_work t k >>= fun () -> read_should_none t k >>= fun () -> write_should_work t k v >>= fun () -> read_should_work t k v >>= fun () -> - let path = String.cuts ~empty:false ~sep:"/" k in - Ctl.KV.get ctl path >|= fun v' -> + Ctl.KV.get ctl k >|= fun v' -> Alcotest.(check string) "in the db" v v' in let disallowed k v = @@ -281,10 +268,8 @@ let test = [ "stdout is a pipe" , `Quick, run (test_pipe Init.Pipe.(stderr t)); "net is a socket pair", `Quick, run (test_socketpair Init.Pipe.(net t)); "ctl is a socket pair", `Quick, run (test_socketpair Init.Pipe.(ctl t)); - "seralize queries" , `Quick, test_query_serialization; - "seralize replies" , `Quick, test_reply_serialization; - "send queries" , `Quick, run (test_query_send t); - "send replies" , `Quick, run (test_reply_send t); + "send requests" , `Quick, run (test_request_send t); + "send responses" , `Quick, run (test_response_send t); "ctl" , `Quick, run (test_ctl t); "exec" , `Quick, run test_exec; ] From 238879f2d485059ac742448df24d471bd4d5f7ae Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Wed, 12 Apr 2017 14:47:52 +0200 Subject: [PATCH 2/2] miragesdk: add temporary auto-gen files The capnp compiler is not yet available in alpine. Signed-off-by: Thomas Gazagnaire --- projects/miragesdk/src/Dockerfile.build | 1 + projects/miragesdk/src/sdk/jbuild | 16 +- projects/miragesdk/src/sdk/proto.ml | 4368 +++++++++++++++++++++++ projects/miragesdk/src/sdk/proto.mli | 109 + 4 files changed, 4486 insertions(+), 8 deletions(-) create mode 100644 projects/miragesdk/src/sdk/proto.ml create mode 100644 projects/miragesdk/src/sdk/proto.mli diff --git a/projects/miragesdk/src/Dockerfile.build b/projects/miragesdk/src/Dockerfile.build index ee8017da3..42095b053 100644 --- a/projects/miragesdk/src/Dockerfile.build +++ b/projects/miragesdk/src/Dockerfile.build @@ -30,6 +30,7 @@ RUN opam list RUN opam config exec -- jbuilder build dhcp-client/main.exe RUN sudo cp /src/_build/default/dhcp-client/main.exe /dhcp-client +RUN apk add capnp RUN opam config exec -- jbuilder build dhcp-client/calf/unikernel.exe RUN sudo mkdir -p /calf diff --git a/projects/miragesdk/src/sdk/jbuild b/projects/miragesdk/src/sdk/jbuild index ffaecc244..14bf8569a 100644 --- a/projects/miragesdk/src/sdk/jbuild +++ b/projects/miragesdk/src/sdk/jbuild @@ -8,11 +8,11 @@ mirage-channel-lwt io-page.unix ipaddr capnp)) )) -(rule - ((targets (proto.ml proto.mli)) - (deps (proto.capnp)) - (action (progn - (run capnp compile -o ocaml ${<}) - (system "mv proto.ml proto.ml.in") - (system "echo '[@@@ocaml.warning \"-A\"]\n' > proto.ml") - (system "cat proto.ml.in >> proto.ml"))))) +;(rule +; ((targets (proto.ml proto.mli)) +; (deps (proto.capnp)) +; (action (progn +; (run capnp compile -o ocaml ${<}) +; (system "mv proto.ml proto.ml.in") +; (system "echo '[@@@ocaml.warning \"-A\"]\n' > proto.ml") +; (system "cat proto.ml.in >> proto.ml"))))) diff --git a/projects/miragesdk/src/sdk/proto.ml b/projects/miragesdk/src/sdk/proto.ml new file mode 100644 index 000000000..d3f6444c0 --- /dev/null +++ b/projects/miragesdk/src/sdk/proto.ml @@ -0,0 +1,4368 @@ +[@@@ocaml.warning "-A"] + +type ro = Capnp.Message.ro +type rw = Capnp.Message.rw + +module type S = sig + type 'cap message_t + + type reader_t_Request_14112192289179464829 + type builder_t_Request_14112192289179464829 + type reader_t_Response_16897334327181152309 + type builder_t_Response_16897334327181152309 + + module Reader : sig + type array_t + type builder_array_t + type pointer_t + module Response : sig + type t = reader_t_Response_16897334327181152309 + type builder_t = builder_t_Response_16897334327181152309 + type unnamed_union_t = + | Ok of string + | Error of string + | Undefined of int + val get : t -> unnamed_union_t + val id_get : t -> int32 + val id_get_int_exn : t -> int + val of_message : 'cap message_t -> t + val of_builder : builder_t -> t + end + module Request : sig + type t = reader_t_Request_14112192289179464829 + type builder_t = builder_t_Request_14112192289179464829 + type unnamed_union_t = + | Write of string + | Read + | Delete + | Undefined of int + val get : t -> unnamed_union_t + val id_get : t -> int32 + val id_get_int_exn : t -> int + val has_path : t -> bool + val path_get : t -> (ro, string, array_t) Capnp.Array.t + val path_get_list : t -> string list + val path_get_array : t -> string array + val of_message : 'cap message_t -> t + val of_builder : builder_t -> t + end + end + + module Builder : sig + type array_t = Reader.builder_array_t + type reader_array_t = Reader.array_t + type pointer_t + module Response : sig + type t = builder_t_Response_16897334327181152309 + type reader_t = reader_t_Response_16897334327181152309 + type unnamed_union_t = + | Ok of string + | Error of string + | Undefined of int + val get : t -> unnamed_union_t + val ok_set : t -> string -> unit + val error_set : t -> string -> unit + val id_get : t -> int32 + val id_get_int_exn : t -> int + val id_set : t -> int32 -> unit + val id_set_int_exn : t -> int -> unit + val of_message : rw message_t -> t + val to_message : t -> rw message_t + val to_reader : t -> reader_t + val init_root : ?message_size:int -> unit -> t + end + module Request : sig + type t = builder_t_Request_14112192289179464829 + type reader_t = reader_t_Request_14112192289179464829 + type unnamed_union_t = + | Write of string + | Read + | Delete + | Undefined of int + val get : t -> unnamed_union_t + val write_set : t -> string -> unit + val read_set : t -> unit + val delete_set : t -> unit + val id_get : t -> int32 + val id_get_int_exn : t -> int + val id_set : t -> int32 -> unit + val id_set_int_exn : t -> int -> unit + val has_path : t -> bool + val path_get : t -> (rw, string, array_t) Capnp.Array.t + val path_get_list : t -> string list + val path_get_array : t -> string array + val path_set : t -> (rw, string, array_t) Capnp.Array.t -> (rw, string, array_t) Capnp.Array.t + val path_set_list : t -> string list -> (rw, string, array_t) Capnp.Array.t + val path_set_array : t -> string array -> (rw, string, array_t) Capnp.Array.t + val path_init : t -> int -> (rw, string, array_t) Capnp.Array.t + val of_message : rw message_t -> t + val to_message : t -> rw message_t + val to_reader : t -> reader_t + val init_root : ?message_size:int -> unit -> t + end + end +end + +module Make (MessageWrapper : Capnp.MessageSig.S) = struct + module CamlBytes = Bytes + module DefaultsMessage_ = Capnp.BytesMessage + + let _builder_defaults_message = + let message_segments = [ + Bytes.unsafe_of_string "\ + "; + ] in + DefaultsMessage_.Message.readonly + (DefaultsMessage_.Message.of_storage message_segments) + + let invalid_msg = Capnp.Message.invalid_msg + + module RA_ = struct + open Capnp.Runtime + (****************************************************************************** + * capnp-ocaml + * + * Copyright (c) 2013-2014, Paul Pelzl + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * 1. Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + ******************************************************************************) + + (* Runtime support for Reader interfaces. None of the functions provided + here will modify the underlying message; derefencing null pointers and + reading from truncated structs both lead to default data being returned. *) + + + open Core_kernel.Std + + let sizeof_uint64 = 8 + + module RC = struct + (****************************************************************************** + * capnp-ocaml + * + * Copyright (c) 2013-2014, Paul Pelzl + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * 1. Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + ******************************************************************************) + + (* Runtime support which is common to both Reader and Builder interfaces. *) + + open Core_kernel.Std + + + let sizeof_uint32 = 4 + let sizeof_uint64 = 8 + + let invalid_msg = Message.invalid_msg + let out_of_int_range = Message.out_of_int_range + type ro = Message.ro + type rw = Message.rw + + include MessageWrapper + + let bounds_check_slice_exn ?err (slice : 'cap Slice.t) : unit = + let open Slice in + if slice.segment_id < 0 || + slice.segment_id >= Message.num_segments slice.msg || + slice.start < 0 || + slice.start + slice.len > Segment.length (Slice.get_segment slice) + then + let error_msg = + match err with + | None -> "pointer referenced a memory region outside the message" + | Some msg -> msg + in + invalid_msg error_msg + else + () + + + (** Get the range of bytes associated with a pointer stored in a struct. *) + let ss_get_pointer + (struct_storage : 'cap StructStorage.t) + (word : int) (* Struct-relative pointer index *) + : 'cap Slice.t option = (* Returns None if storage is too small for this word *) + let pointers = struct_storage.StructStorage.pointers in + let start = word * sizeof_uint64 in + let len = sizeof_uint64 in + if start + len <= pointers.Slice.len then + Some { + pointers with + Slice.start = pointers.Slice.start + start; + Slice.len = len + } + else + None + + + let decode_pointer64 (pointer64 : int64) : Pointer.t = + if Util.is_int64_zero pointer64 then + Pointer.Null + else + let pointer_int = Caml.Int64.to_int pointer64 in + let tag = pointer_int land Pointer.Bitfield.tag_mask in + (* OCaml won't match an int against let-bound variables, + only against constants. *) + match tag with + | 0x0 -> (* Pointer.Bitfield.tag_val_struct *) + Pointer.Struct (StructPointer.decode pointer64) + | 0x1 -> (* Pointer.Bitfield.tag_val_list *) + Pointer.List (ListPointer.decode pointer64) + | 0x2 -> (* Pointer.Bitfield.tag_val_far *) + Pointer.Far (FarPointer.decode pointer64) + | 0x3 -> (* Pointer.Bitfield.tag_val_other *) + Pointer.Other (OtherPointer.decode pointer64) + | _ -> + assert false + + + (* Given a range of eight bytes corresponding to a cap'n proto pointer, + decode the information stored in the pointer. *) + let decode_pointer (pointer_bytes : 'cap Slice.t) : Pointer.t = + let pointer64 = Slice.get_int64 pointer_bytes 0 in + decode_pointer64 pointer64 + + + let make_list_storage_aux ~message ~num_words ~num_elements ~storage_type + ~segment_id ~segment_offset = + let storage = { + Slice.msg = message; + Slice.segment = Message.get_segment message segment_id; + Slice.segment_id = segment_id; + Slice.start = segment_offset; + Slice.len = num_words * sizeof_uint64; + } in + let () = bounds_check_slice_exn + ~err:"list pointer describes invalid storage region" storage + in { + ListStorage.storage = storage; + ListStorage.storage_type = storage_type; + ListStorage.num_elements = num_elements; + } + + + (* Given a list pointer descriptor, construct the corresponding list storage + descriptor. *) + let make_list_storage + ~(message : 'cap Message.t) (* Message of interest *) + ~(segment_id : int) (* Segment ID where list storage is found *) + ~(segment_offset : int) (* Segment offset where list storage is found *) + ~(list_pointer : ListPointer.t) + : 'cap ListStorage.t = + let open ListPointer in + match list_pointer.element_type with + | Void -> + make_list_storage_aux ~message ~num_words:0 + ~num_elements:list_pointer.num_elements + ~storage_type:ListStorageType.Empty ~segment_id ~segment_offset + | OneBitValue -> + make_list_storage_aux ~message + ~num_words:(Util.ceil_ratio list_pointer.num_elements 64) + ~num_elements:list_pointer.num_elements ~storage_type:ListStorageType.Bit + ~segment_id ~segment_offset + | OneByteValue -> + make_list_storage_aux ~message + ~num_words:(Util.ceil_ratio list_pointer.num_elements 8) + ~num_elements:list_pointer.num_elements + ~storage_type:ListStorageType.Bytes1 + ~segment_id ~segment_offset + | TwoByteValue -> + make_list_storage_aux ~message + ~num_words:(Util.ceil_ratio list_pointer.num_elements 4) + ~num_elements:list_pointer.num_elements + ~storage_type:ListStorageType.Bytes2 + ~segment_id ~segment_offset + | FourByteValue -> + make_list_storage_aux ~message + ~num_words:(Util.ceil_ratio list_pointer.num_elements 2) + ~num_elements:list_pointer.num_elements + ~storage_type:ListStorageType.Bytes4 + ~segment_id ~segment_offset + | EightByteValue -> + make_list_storage_aux ~message ~num_words:list_pointer.num_elements + ~num_elements:list_pointer.num_elements + ~storage_type:ListStorageType.Bytes8 + ~segment_id ~segment_offset + | EightBytePointer -> + make_list_storage_aux ~message ~num_words:list_pointer.num_elements + ~num_elements:list_pointer.num_elements + ~storage_type:ListStorageType.Pointer + ~segment_id ~segment_offset + | Composite -> + if segment_id < 0 || segment_id >= Message.num_segments message then + invalid_msg "composite list pointer describes invalid tag region" + else + let segment = Message.get_segment message segment_id in + if segment_offset + sizeof_uint64 > Segment.length segment then + invalid_msg "composite list pointer describes invalid tag region" + else + let pointer64 = Segment.get_int64 segment segment_offset in + let pointer_int = Caml.Int64.to_int pointer64 in + let tag = pointer_int land Pointer.Bitfield.tag_mask in + if tag = Pointer.Bitfield.tag_val_struct then + let struct_pointer = StructPointer.decode pointer64 in + let num_words = list_pointer.num_elements in + let num_elements = struct_pointer.StructPointer.offset in + let words_per_element = struct_pointer.StructPointer.data_words + + struct_pointer.StructPointer.pointer_words + in + if num_elements * words_per_element > num_words then + invalid_msg "composite list pointer describes invalid word count" + else + make_list_storage_aux ~message ~num_words ~num_elements + ~storage_type:(ListStorageType.Composite + (struct_pointer.StructPointer.data_words, + struct_pointer.StructPointer.pointer_words)) + ~segment_id ~segment_offset + else + invalid_msg "composite list pointer has malformed element type tag" + + + (* Given a description of a cap'n proto far pointer, get the object which + the pointer points to. *) + let rec deref_far_pointer + (far_pointer : FarPointer.t) + (message : 'cap Message.t) + : 'cap Object.t = + let open FarPointer in + match far_pointer.landing_pad with + | NormalPointer -> + let next_pointer_bytes = { + Slice.msg = message; + Slice.segment = Message.get_segment message far_pointer.segment_id; + Slice.segment_id = far_pointer.segment_id; + Slice.start = far_pointer.offset * sizeof_uint64; + Slice.len = sizeof_uint64; + } in + let () = bounds_check_slice_exn + ~err:"far pointer describes invalid landing pad" next_pointer_bytes + in + deref_pointer next_pointer_bytes + | TaggedFarPointer -> + let content_pointer_bytes = { + Slice.msg = message; + Slice.segment = Message.get_segment message far_pointer.segment_id; + Slice.segment_id = far_pointer.segment_id; + Slice.start = far_pointer.offset * sizeof_uint64; + Slice.len = sizeof_uint64; + } in + let tag_bytes = { + content_pointer_bytes with + Slice.start = Slice.get_end content_pointer_bytes; + } in + match (decode_pointer content_pointer_bytes, decode_pointer tag_bytes) with + | (Pointer.Far content_pointer, Pointer.List list_pointer) -> + Object.List (make_list_storage + ~message + ~segment_id:content_pointer.FarPointer.segment_id + ~segment_offset:(content_pointer.FarPointer.offset * sizeof_uint64) + ~list_pointer) + | (Pointer.Far content_pointer, Pointer.Struct struct_pointer) -> + let segment_id = content_pointer.FarPointer.segment_id in + let data = { + Slice.msg = message; + Slice.segment = Message.get_segment message segment_id; + Slice.segment_id; + Slice.start = content_pointer.FarPointer.offset * sizeof_uint64; + Slice.len = struct_pointer.StructPointer.data_words * sizeof_uint64; + } in + let pointers = { + data with + Slice.start = Slice.get_end data; + Slice.len = + struct_pointer.StructPointer.pointer_words * sizeof_uint64; + } in + let () = bounds_check_slice_exn + ~err:"struct-tagged far pointer describes invalid data region" + data + in + let () = bounds_check_slice_exn + ~err:"struct-tagged far pointer describes invalid pointers region" + pointers + in + Object.Struct { StructStorage.data; StructStorage.pointers; } + | _ -> + invalid_msg "tagged far pointer points to invalid landing pad" + + + (* Given a range of eight bytes which represent a pointer, get the object which + the pointer points to. *) + and deref_pointer (pointer_bytes : 'cap Slice.t) : 'cap Object.t = + let pointer64 = Slice.get_int64 pointer_bytes 0 in + if Util.is_int64_zero pointer64 then + Object.None + else + let pointer64 = Slice.get_int64 pointer_bytes 0 in + let tag_bits = Caml.Int64.to_int pointer64 in + let tag = tag_bits land Pointer.Bitfield.tag_mask in + (* OCaml won't match an int against let-bound variables, + only against constants. *) + match tag with + | 0x0 -> (* Pointer.Bitfield.tag_val_struct *) + let struct_pointer = StructPointer.decode pointer64 in + let open StructPointer in + let data = { + pointer_bytes with + Slice.start = + (Slice.get_end pointer_bytes) + (struct_pointer.offset * sizeof_uint64); + Slice.len = struct_pointer.data_words * sizeof_uint64; + } in + let pointers = { + data with + Slice.start = Slice.get_end data; + Slice.len = struct_pointer.pointer_words * sizeof_uint64; + } in + let () = bounds_check_slice_exn + ~err:"struct pointer describes invalid data region" data + in + let () = bounds_check_slice_exn + ~err:"struct pointer describes invalid pointers region" pointers + in + Object.Struct { StructStorage.data; StructStorage.pointers; } + | 0x1 -> (* Pointer.Bitfield.tag_val_list *) + let list_pointer = ListPointer.decode pointer64 in + Object.List (make_list_storage + ~message:pointer_bytes.Slice.msg + ~segment_id:pointer_bytes.Slice.segment_id + ~segment_offset:((Slice.get_end pointer_bytes) + + (list_pointer.ListPointer.offset * sizeof_uint64)) + ~list_pointer) + | 0x2 -> (* Pointer.Bitfield.tag_val_far *) + let far_pointer = FarPointer.decode pointer64 in + deref_far_pointer far_pointer pointer_bytes.Slice.msg + | 0x3 -> (* Pointer.Bitfield.tag_val_other *) + let other_pointer = OtherPointer.decode pointer64 in + let (OtherPointer.Capability index) = other_pointer in + Object.Capability index + | _ -> + assert false + + + module ListDecoders = struct + type ('cap, 'a) struct_decoders_t = { + bytes : 'cap Slice.t -> 'a; + pointer : 'cap Slice.t -> 'a; + composite : 'cap StructStorage.t -> 'a; + } + + type ('cap, 'a) t = + | Empty of (unit -> 'a) + | Bit of (bool -> 'a) + | Bytes1 of ('cap Slice.t -> 'a) + | Bytes2 of ('cap Slice.t -> 'a) + | Bytes4 of ('cap Slice.t -> 'a) + | Bytes8 of ('cap Slice.t -> 'a) + | Pointer of ('cap Slice.t -> 'a) + | Struct of ('cap, 'a) struct_decoders_t + end + + + module ListCodecs = struct + type 'a struct_codecs_t = { + bytes : (rw Slice.t -> 'a) * ('a -> rw Slice.t -> unit); + pointer : (rw Slice.t -> 'a) * ('a -> rw Slice.t -> unit); + composite : (rw StructStorage.t -> 'a) * ('a -> rw StructStorage.t -> unit); + } + + type 'a t = + | Empty of (unit -> 'a) * ('a -> unit) + | Bit of (bool -> 'a) * ('a -> bool) + | Bytes1 of (rw Slice.t -> 'a) * ('a -> rw Slice.t -> unit) + | Bytes2 of (rw Slice.t -> 'a) * ('a -> rw Slice.t -> unit) + | Bytes4 of (rw Slice.t -> 'a) * ('a -> rw Slice.t -> unit) + | Bytes8 of (rw Slice.t -> 'a) * ('a -> rw Slice.t -> unit) + | Pointer of (rw Slice.t -> 'a) * ('a -> rw Slice.t -> unit) + | Struct of 'a struct_codecs_t + end + + let _dummy = ref true + + let make_array_readonly + (list_storage : 'cap ListStorage.t) + (decoders : ('cap, 'a) ListDecoders.t) + : (ro, 'a, 'cap ListStorage.t) InnerArray.t = + let make_element_slice ls i byte_count = { + ls.ListStorage.storage with + Slice.start = ls.ListStorage.storage.Slice.start + (i * byte_count); + Slice.len = byte_count; + } in + let length = list_storage.ListStorage.num_elements in + (* Note: the following is attempting to strike a balance between + * (1) building InnerArray.get_unsafe closures that do as little work as + * possible and + * (2) making the closure calling convention as efficient as possible. + * + * A naive implementation of this getter can result in quite slow code. *) + match list_storage.ListStorage.storage_type with + | ListStorageType.Empty -> + begin match decoders with + | ListDecoders.Empty decode -> + let ro_get_unsafe_void ls i = decode () in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_void; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List where a different list type was expected" + end + | ListStorageType.Bit -> + begin match decoders with + | ListDecoders.Bit decode -> + let ro_get_unsafe_bool ls i = + let byte_ofs = i / 8 in + let bit_ofs = i mod 8 in + let byte_val = + Slice.get_uint8 ls.ListStorage.storage byte_ofs + in + decode ((byte_val land (1 lsl bit_ofs)) <> 0) + in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_bool; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List where a different list type was expected" + end + | ListStorageType.Bytes1 -> + begin match decoders with + | ListDecoders.Bytes1 decode + | ListDecoders.Struct { ListDecoders.bytes = decode; _ } -> + let ro_get_unsafe_bytes1 ls i = decode (make_element_slice ls i 1) in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_bytes1; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List<1 byte> where a different list type was expected" + end + | ListStorageType.Bytes2 -> + begin match decoders with + | ListDecoders.Bytes2 decode + | ListDecoders.Struct { ListDecoders.bytes = decode; _ } -> + let ro_get_unsafe_bytes2 ls i = decode (make_element_slice ls i 2) in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_bytes2; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List<2 byte> where a different list type was expected" + end + | ListStorageType.Bytes4 -> + begin match decoders with + | ListDecoders.Bytes4 decode + | ListDecoders.Struct { ListDecoders.bytes = decode; _ } -> + let ro_get_unsafe_bytes4 ls i = decode (make_element_slice ls i 4) in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_bytes4; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List<4 byte> where a different list type was expected" + end + | ListStorageType.Bytes8 -> + begin match decoders with + | ListDecoders.Bytes8 decode + | ListDecoders.Struct { ListDecoders.bytes = decode; _ } -> + let ro_get_unsafe_bytes8 ls i = decode (make_element_slice ls i 8) in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_bytes8; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List<8 byte> where a different list type was expected" + end + | ListStorageType.Pointer -> + begin match decoders with + | ListDecoders.Pointer decode + | ListDecoders.Struct { ListDecoders.pointer = decode; _ } -> + let ro_get_unsafe_pointer ls i = decode (make_element_slice ls i sizeof_uint64) in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_pointer; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List a different list type was expected" + end + | ListStorageType.Composite (data_words, pointer_words) -> + let data_size = data_words * sizeof_uint64 in + let pointers_size = pointer_words * sizeof_uint64 in + let make_storage ls i ~data_size ~pointers_size = + let total_size = data_size + pointers_size in + (* Skip over the composite tag word *) + let content_offset = + ls.ListStorage.storage.Slice.start + sizeof_uint64 + in + let data = { + ls.ListStorage.storage with + Slice.start = content_offset + (i * total_size); + Slice.len = data_size; + } in + let pointers = { + data with + Slice.start = Slice.get_end data; + Slice.len = pointers_size; + } in + { StructStorage.data; StructStorage.pointers; } + in + let make_bytes_handler ~size ~decode = + if data_words = 0 then + invalid_msg + "decoded List with empty data region where data was expected" + else + let ro_get_unsafe_composite_bytes ls i = + let struct_storage = make_storage ls i ~data_size ~pointers_size in + let slice = { + struct_storage.StructStorage.data with + Slice.len = size + } in + decode slice + in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_composite_bytes; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + in + begin match decoders with + | ListDecoders.Empty decode -> + let ro_get_unsafe_composite_void ls i = decode () in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_composite_void; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + | ListDecoders.Bit decode -> + if data_words = 0 then + invalid_msg + "decoded List with empty data region where data was expected" + else + let ro_get_unsafe_composite_bool ls i = + let struct_storage = make_storage ls i ~data_size ~pointers_size in + let first_byte = Slice.get_uint8 struct_storage.StructStorage.data 0 in + let is_set = (first_byte land 0x1) <> 0 in + decode is_set + in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_composite_bool; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + | ListDecoders.Bytes1 decode -> + make_bytes_handler ~size:1 ~decode + | ListDecoders.Bytes2 decode -> + make_bytes_handler ~size:2 ~decode + | ListDecoders.Bytes4 decode -> + make_bytes_handler ~size:4 ~decode + | ListDecoders.Bytes8 decode -> + make_bytes_handler ~size:8 ~decode + | ListDecoders.Pointer decode -> + if pointer_words = 0 then + invalid_msg + "decoded List with empty pointers region where \ + pointers were expected" + else + let ro_get_unsafe_composite_pointer ls i = + let struct_storage = make_storage ls i ~data_size ~pointers_size in + let slice = { + struct_storage.StructStorage.pointers with + Slice.len = sizeof_uint64 + } in + decode slice + in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_composite_pointer; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + | ListDecoders.Struct struct_decoders -> + let ro_get_unsafe_composite_struct ls i = + let struct_storage = make_storage ls i ~data_size ~pointers_size in + struct_decoders.ListDecoders.composite struct_storage + in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_composite_struct; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + end + + + let make_array_readwrite + ~(list_storage : rw ListStorage.t) + ~(init : int -> rw ListStorage.t) + ~(codecs : 'a ListCodecs.t) + : (rw, 'a, rw ListStorage.t) InnerArray.t = + let make_element_slice ls i byte_count = { + ls.ListStorage.storage with + Slice.start = ls.ListStorage.storage.Slice.start + (i * byte_count); + Slice.len = byte_count; + } in + let length = list_storage.ListStorage.num_elements in + (* Note: the following is attempting to strike a balance between + * (1) building InnerArray.get_unsafe/set_unsafe closures that do as little + * work as possible and + * (2) making the closure calling convention as efficient as possible. + * + * A naive implementation of these accessors can result in quite slow code. *) + match list_storage.ListStorage.storage_type with + | ListStorageType.Empty -> + begin match codecs with + | ListCodecs.Empty (decode, encode) -> + let rw_get_unsafe_void ls i = decode () in + let rw_set_unsafe_void ls i v = encode v in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_void; + InnerArray.set_unsafe = rw_set_unsafe_void; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List where a different list type was expected" + end + | ListStorageType.Bit -> + begin match codecs with + | ListCodecs.Bit (decode, encode) -> + let rw_get_unsafe_bool ls i = + let byte_ofs = i / 8 in + let bit_ofs = i mod 8 in + let byte_val = + Slice.get_uint8 ls.ListStorage.storage byte_ofs + in + decode ((byte_val land (1 lsl bit_ofs)) <> 0) + in + let rw_set_unsafe_bool ls i v = + let byte_ofs = i / 8 in + let bit_ofs = i mod 8 in + let bitmask = 1 lsl bit_ofs in + let old_byte_val = + Slice.get_uint8 ls.ListStorage.storage byte_ofs + in + let new_byte_val = + if encode v then + old_byte_val lor bitmask + else + old_byte_val land (lnot bitmask) + in + Slice.set_uint8 ls.ListStorage.storage byte_ofs new_byte_val + in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_bool; + InnerArray.set_unsafe = rw_set_unsafe_bool; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List where a different list type was expected" + end + | ListStorageType.Bytes1 -> + begin match codecs with + | ListCodecs.Bytes1 (decode, encode) + | ListCodecs.Struct { ListCodecs.bytes = (decode, encode); _ } -> + let rw_get_unsafe_bytes1 ls i = decode (make_element_slice ls i 1) in + let rw_set_unsafe_bytes1 ls i v = encode v (make_element_slice ls i 1) in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_bytes1; + InnerArray.set_unsafe = rw_set_unsafe_bytes1; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List<1 byte> where a different list type was expected" + end + | ListStorageType.Bytes2 -> + begin match codecs with + | ListCodecs.Bytes2 (decode, encode) + | ListCodecs.Struct { ListCodecs.bytes = (decode, encode); _ } -> + let rw_get_unsafe_bytes2 ls i = decode (make_element_slice ls i 2) in + let rw_set_unsafe_bytes2 ls i v = encode v (make_element_slice ls i 2) in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_bytes2; + InnerArray.set_unsafe = rw_set_unsafe_bytes2; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List<2 byte> where a different list type was expected" + end + | ListStorageType.Bytes4 -> + begin match codecs with + | ListCodecs.Bytes4 (decode, encode) + | ListCodecs.Struct { ListCodecs.bytes = (decode, encode); _ } -> + let rw_get_unsafe_bytes4 ls i = decode (make_element_slice ls i 4) in + let rw_set_unsafe_bytes4 ls i v = encode v (make_element_slice ls i 4) in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_bytes4; + InnerArray.set_unsafe = rw_set_unsafe_bytes4; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List<4 byte> where a different list type was expected" + end + | ListStorageType.Bytes8 -> + begin match codecs with + | ListCodecs.Bytes8 (decode, encode) + | ListCodecs.Struct { ListCodecs.bytes = (decode, encode); _ } -> + let rw_get_unsafe_bytes8 ls i = decode (make_element_slice ls i 8) in + let rw_set_unsafe_bytes8 ls i v = encode v (make_element_slice ls i 8) in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_bytes8; + InnerArray.set_unsafe = rw_set_unsafe_bytes8; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List<8 byte> where a different list type was expected" + end + | ListStorageType.Pointer -> + begin match codecs with + | ListCodecs.Pointer (decode, encode) + | ListCodecs.Struct { ListCodecs.pointer = (decode, encode); _ } -> + let rw_get_unsafe_ptr ls i = + decode (make_element_slice ls i sizeof_uint64) + in + let rw_set_unsafe_ptr ls i v = + encode v (make_element_slice ls i sizeof_uint64) + in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_ptr; + InnerArray.set_unsafe = rw_set_unsafe_ptr; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List where a different list type was expected" + end + | ListStorageType.Composite (data_words, pointer_words) -> + let data_size = data_words * sizeof_uint64 in + let pointers_size = pointer_words * sizeof_uint64 in + let make_storage ls i ~data_size ~pointers_size = + let total_size = data_size + pointers_size in + (* Skip over the composite tag word *) + let content_offset = + ls.ListStorage.storage.Slice.start + sizeof_uint64 + in + let data = { + ls.ListStorage.storage with + Slice.start = content_offset + (i * total_size); + Slice.len = data_size; + } in + let pointers = { + data with + Slice.start = Slice.get_end data; + Slice.len = pointers_size; + } in + { StructStorage.data; StructStorage.pointers; } + in + let make_bytes_handlers ~size ~decode ~encode = + if data_words = 0 then + invalid_msg + "decoded List with empty data region where data was expected" + else + let rw_get_unsafe_composite_bytes ls i = + let struct_storage = make_storage ls i ~data_size ~pointers_size in + let slice = { + struct_storage.StructStorage.data with + Slice.len = size + } in + decode slice + in + let rw_set_unsafe_composite_bytes ls i v = + let struct_storage = make_storage ls i ~data_size ~pointers_size in + let slice = { + struct_storage.StructStorage.data with + Slice.len = size + } in + encode v slice + in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_composite_bytes; + InnerArray.set_unsafe = rw_set_unsafe_composite_bytes; + InnerArray.storage = Some list_storage; + } + in + begin match codecs with + | ListCodecs.Empty (decode, encode) -> + let rw_get_unsafe_composite_void ls i = decode () in + let rw_set_unsafe_composite_void ls i v = encode v in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_composite_void; + InnerArray.set_unsafe = rw_set_unsafe_composite_void; + InnerArray.storage = Some list_storage; + } + | ListCodecs.Bit (decode, encode) -> + if data_words = 0 then + invalid_msg + "decoded List with empty data region where data was expected" + else + let rw_get_unsafe_composite_bool ls i = + let struct_storage = make_storage ls i ~data_size ~pointers_size in + let first_byte = Slice.get_uint8 struct_storage.StructStorage.data 0 in + let is_set = (first_byte land 0x1) <> 0 in + decode is_set + in + let rw_set_unsafe_composite_bool ls i v = + let struct_storage = make_storage ls i ~data_size ~pointers_size in + let first_byte = + Slice.get_uint8 struct_storage.StructStorage.data 0 + in + let first_byte = + if encode v then first_byte lor 0x1 else first_byte land 0xfe + in + Slice.set_uint8 struct_storage.StructStorage.data 0 first_byte + in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_composite_bool; + InnerArray.set_unsafe = rw_set_unsafe_composite_bool; + InnerArray.storage = Some list_storage; + } + | ListCodecs.Bytes1 (decode, encode) -> + make_bytes_handlers ~size:1 ~decode ~encode + | ListCodecs.Bytes2 (decode, encode) -> + make_bytes_handlers ~size:2 ~decode ~encode + | ListCodecs.Bytes4 (decode, encode) -> + make_bytes_handlers ~size:4 ~decode ~encode + | ListCodecs.Bytes8 (decode, encode) -> + make_bytes_handlers ~size:8 ~decode ~encode + | ListCodecs.Pointer (decode, encode) -> + if pointer_words = 0 then + invalid_msg + "decoded List with empty pointers region where \ + pointers were expected" + else + let rw_get_unsafe_composite_ptr ls i = + let struct_storage = make_storage ls i ~data_size ~pointers_size in + let slice = { + struct_storage.StructStorage.pointers with + Slice.len = sizeof_uint64 + } in + decode slice + in + let rw_set_unsafe_composite_ptr ls i v = + let struct_storage = make_storage ls i ~data_size ~pointers_size in + let slice = { + struct_storage.StructStorage.pointers with + Slice.len = sizeof_uint64 + } in + encode v slice + in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_composite_ptr; + InnerArray.set_unsafe = rw_set_unsafe_composite_ptr; + InnerArray.storage = Some list_storage; + } + | ListCodecs.Struct { ListCodecs.composite = (decode, encode); _ } -> + let rw_get_unsafe_composite_struct ls i = + decode (make_storage ls i ~data_size ~pointers_size) + in + let rw_set_unsafe_composite_struct ls i v = + encode v (make_storage ls i ~data_size ~pointers_size) + in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_composite_struct; + InnerArray.set_unsafe = rw_set_unsafe_composite_struct; + InnerArray.storage = Some list_storage; + } + end + + + (* Given list storage which is expected to contain UInt8 data, decode the data as + an OCaml string. *) + let string_of_uint8_list + ~(null_terminated : bool) (* true if the data is expected to end in 0 *) + (list_storage : 'cap ListStorage.t) + : string = + let open ListStorage in + match list_storage.storage_type with + | ListStorageType.Bytes1 -> + let result_byte_count = + if null_terminated then + let () = + if list_storage.num_elements < 1 then + invalid_msg "empty string list has no space for null terminator" + in + let terminator = + Slice.get_uint8 list_storage.storage (list_storage.num_elements - 1) + in + let () = if terminator <> 0 then + invalid_msg "string list is not null terminated" + in + list_storage.num_elements - 1 + else + list_storage.num_elements + in + let buf = CamlBytes.create result_byte_count in + Slice.blit_to_bytes + ~src:list_storage.storage ~src_pos:0 + ~dst:buf ~dst_pos:0 + ~len:result_byte_count; + CamlBytes.unsafe_to_string buf + | _ -> + invalid_msg "decoded non-UInt8 list where string data was expected" + + + let struct_of_bytes_slice slice = + let data = slice in + let pointers = { + slice with + Slice.start = Slice.get_end data; + Slice.len = 0; + } in + { StructStorage.data; StructStorage.pointers } + + let struct_of_pointer_slice slice = + let () = assert (slice.Slice.len = sizeof_uint64) in + let data = { + slice with + Slice.len = 0 + } in + let pointers = { + slice with + Slice.len = sizeof_uint64; + } in + { StructStorage.data; StructStorage.pointers } + + + (* Given some list storage corresponding to a struct list, construct + a function for mapping an element index to the associated + struct storage. *) + let make_struct_of_list_index list_storage = + let storage = list_storage.ListStorage.storage in + let storage_type = list_storage.ListStorage.storage_type in + match list_storage.ListStorage.storage_type with + | ListStorageType.Empty -> + let make_struct_of_list_index_void i = + let slice = { + storage with + Slice.start = storage.Slice.start; + Slice.len = 0; + } in + struct_of_bytes_slice slice + in + make_struct_of_list_index_void + | ListStorageType.Bytes1 + | ListStorageType.Bytes2 + | ListStorageType.Bytes4 + | ListStorageType.Bytes8 -> + (* Short data-only struct *) + let byte_count = ListStorageType.get_byte_count storage_type in + let make_struct_of_list_index_bytes i = + let slice = { + storage with + Slice.start = storage.Slice.start + (i * byte_count); + Slice.len = byte_count; + } in + struct_of_bytes_slice slice + in + make_struct_of_list_index_bytes + | ListStorageType.Pointer -> + (* Single-pointer struct *) + let make_struct_of_list_index_pointer i = + let slice = { + storage with + Slice.start = (storage.Slice.start) + (i * sizeof_uint64); + Slice.len = sizeof_uint64; + } in + struct_of_pointer_slice slice + in + make_struct_of_list_index_pointer + | ListStorageType.Composite (data_words, pointer_words) -> + let data_size = data_words * sizeof_uint64 in + let pointers_size = pointer_words * sizeof_uint64 in + let element_size = data_size + pointers_size in + (* Skip over the composite tag word *) + let content_offset = storage.Slice.start + sizeof_uint64 in + let make_struct_of_list_index_composite i = + let data = { + storage with + Slice.start = content_offset + (i * element_size); + Slice.len = data_size; + } in + let pointers = { + storage with + Slice.start = Slice.get_end data; + Slice.len = pointers_size; + } in + { StructStorage.data; StructStorage.pointers } + in + make_struct_of_list_index_composite + | ListStorageType.Bit -> + invalid_msg "decoded List where List was expected" + + + end + include RC + + (* Given a pointer which is expected to be a list pointer, compute the + corresponding list storage descriptor. Returns None if the pointer is + null. *) + let deref_list_pointer (pointer_bytes : 'cap Slice.t) + : 'cap ListStorage.t option = + match deref_pointer pointer_bytes with + | Object.None -> + None + | Object.List list_descr -> + Some list_descr + | Object.Struct _ -> + invalid_msg "decoded struct pointer where list pointer was expected" + | Object.Capability _ -> + invalid_msg "decoded capability pointer where list pointer was expected" + + + (* Given a pointer which is expected to be a struct pointer, compute the + corresponding struct storage descriptor. Returns None if the pointer is + null. *) + let deref_struct_pointer (pointer_bytes : 'cap Slice.t) + : 'cap StructStorage.t option = + match deref_pointer pointer_bytes with + | Object.None -> + None + | Object.Struct struct_descr -> + Some struct_descr + | Object.List _ -> + invalid_msg "decoded list pointer where struct pointer was expected" + | Object.Capability _ -> + invalid_msg "decoded capability pointer where struct pointer was expected" + + + let void_list_decoders = + ListDecoders.Empty (fun (x : unit) -> x) + + let bit_list_decoders = + ListDecoders.Bit (fun (x : bool) -> x) + + let int8_list_decoders = + ListDecoders.Bytes1 (fun slice -> Slice.get_int8 slice 0) + + let int16_list_decoders = + ListDecoders.Bytes2 (fun slice -> Slice.get_int16 slice 0) + + let int32_list_decoders = + ListDecoders.Bytes4 (fun slice -> Slice.get_int32 slice 0) + + let int64_list_decoders = + ListDecoders.Bytes8 (fun slice -> Slice.get_int64 slice 0) + + let uint8_list_decoders = + ListDecoders.Bytes1 (fun slice -> Slice.get_uint8 slice 0) + + let uint16_list_decoders = + ListDecoders.Bytes2 (fun slice -> Slice.get_uint16 slice 0) + + let uint32_list_decoders = + ListDecoders.Bytes4 (fun slice -> Slice.get_uint32 slice 0) + + let uint64_list_decoders = + ListDecoders.Bytes8 (fun slice -> Slice.get_uint64 slice 0) + + let float32_list_decoders = ListDecoders.Bytes4 + (fun slice -> Int32.float_of_bits (Slice.get_int32 slice 0)) + + let float64_list_decoders = ListDecoders.Bytes8 + (fun slice -> Int64.float_of_bits (Slice.get_int64 slice 0)) + + let text_list_decoders = ListDecoders.Pointer (fun slice -> + match deref_list_pointer slice with + | Some list_storage -> + string_of_uint8_list ~null_terminated:true list_storage + | None -> + "") + + let blob_list_decoders = ListDecoders.Pointer (fun slice -> + match deref_list_pointer slice with + | Some list_storage -> + string_of_uint8_list ~null_terminated:false list_storage + | None -> + "") + + let struct_list_decoders = + let struct_decoders = + let bytes slice = Some { + StructStorage.data = slice; + StructStorage.pointers = { + slice with + Slice.start = Slice.get_end slice; + Slice.len = 0; + }; + } + in + let pointer slice = Some { + StructStorage.data = { + slice with + Slice.len = 0; + }; + StructStorage.pointers = slice; + } + in + let composite x = Some x in { + ListDecoders.bytes; + ListDecoders.pointer; + ListDecoders.composite; + } + in + ListDecoders.Struct struct_decoders + + + (* Locate the storage region corresponding to the root struct of a message. *) + let get_root_struct (m : 'cap Message.t) : 'cap StructStorage.t option = + let first_segment = Message.get_segment m 0 in + if Segment.length first_segment < sizeof_uint64 then + None + else + let pointer_bytes = { + Slice.msg = m; + Slice.segment = first_segment; + Slice.segment_id = 0; + Slice.start = 0; + Slice.len = sizeof_uint64 + } in + deref_struct_pointer pointer_bytes + + + (******************************************************************************* + * METHODS FOR GETTING OBJECTS STORED BY VALUE + *******************************************************************************) + + let get_bit + ~(default : bool) + (struct_storage_opt : 'cap StructStorage.t option) + ~(byte_ofs : int) + ~(bit_ofs : int) + : bool = + match struct_storage_opt with + | Some struct_storage -> + let data = struct_storage.StructStorage.data in + if byte_ofs < data.Slice.len then + let byte_val = Slice.get_uint8 data byte_ofs in + let is_set = Util.get_bit byte_val bit_ofs in + if default then + not is_set + else + is_set + else + default + | None -> + default + + let get_int8 + ~(default : int) + (struct_storage_opt : 'cap StructStorage.t option) + (byte_ofs : int) + : int = + match struct_storage_opt with + | Some struct_storage -> + let data = struct_storage.StructStorage.data in + if byte_ofs < data.Slice.len then + let numeric = Slice.get_int8 data byte_ofs in + numeric lxor default + else + default + | None -> + default + + let get_int16 + ~(default : int) + (struct_storage_opt : 'cap StructStorage.t option) + (byte_ofs : int) + : int = + match struct_storage_opt with + | Some struct_storage -> + let data = struct_storage.StructStorage.data in + if byte_ofs + 1 < data.Slice.len then + let numeric = Slice.get_int16 data byte_ofs in + numeric lxor default + else + default + | None -> + default + + let get_int32 + ~(default : int32) + (struct_storage_opt : 'cap StructStorage.t option) + (byte_ofs : int) + : int32 = + match struct_storage_opt with + | Some struct_storage -> + let data = struct_storage.StructStorage.data in + if byte_ofs + 3 < data.Slice.len then + let numeric = Slice.get_int32 data byte_ofs in + Int32.bit_xor numeric default + else + default + | None -> + default + + let get_int64 + ~(default : int64) + (struct_storage_opt : 'cap StructStorage.t option) + (byte_ofs : int) + : int64 = + match struct_storage_opt with + | Some struct_storage -> + let data = struct_storage.StructStorage.data in + if byte_ofs + 7 < data.Slice.len then + let numeric = Slice.get_int64 data byte_ofs in + Int64.bit_xor numeric default + else + default + | None -> + default + + let get_uint8 + ~(default : int) + (struct_storage_opt : 'cap StructStorage.t option) + (byte_ofs : int) + : int = + match struct_storage_opt with + | Some struct_storage -> + let data = struct_storage.StructStorage.data in + if byte_ofs < data.Slice.len then + let numeric = Slice.get_uint8 data byte_ofs in + numeric lxor default + else + default + | None -> + default + + let get_uint16 + ~(default : int) + (struct_storage_opt : 'cap StructStorage.t option) + (byte_ofs : int) + : int = + match struct_storage_opt with + | Some struct_storage -> + let data = struct_storage.StructStorage.data in + if byte_ofs + 1 < data.Slice.len then + let numeric = Slice.get_uint16 data byte_ofs in + numeric lxor default + else + default + | None -> + default + + let get_uint32 + ~(default : Uint32.t) + (struct_storage_opt : 'cap StructStorage.t option) + (byte_ofs : int) + : Uint32.t = + match struct_storage_opt with + | Some struct_storage -> + let data = struct_storage.StructStorage.data in + if byte_ofs + 3 < data.Slice.len then + let numeric = Slice.get_uint32 data byte_ofs in + Uint32.logxor numeric default + else + default + | None -> + default + + let get_uint64 + ~(default : Uint64.t) + (struct_storage_opt : 'cap StructStorage.t option) + (byte_ofs : int) + : Uint64.t = + match struct_storage_opt with + | Some struct_storage -> + let data = struct_storage.StructStorage.data in + if byte_ofs + 7 < data.Slice.len then + let numeric = Slice.get_uint64 data byte_ofs in + Uint64.logxor numeric default + else + default + | None -> + default + + let get_float32 + ~(default_bits : int32) + (struct_storage_opt : 'cap StructStorage.t option) + (byte_ofs : int) + : float = + let numeric = + match struct_storage_opt with + | Some struct_storage -> + let data = struct_storage.StructStorage.data in + if byte_ofs + 3 < data.Slice.len then + Slice.get_int32 data byte_ofs + else + Int32.zero + | None -> + Int32.zero + in + let bits = Int32.bit_xor numeric default_bits in + Int32.float_of_bits bits + + let get_float64 + ~(default_bits : int64) + (struct_storage_opt : 'cap StructStorage.t option) + (byte_ofs : int) + : float = + let numeric = + match struct_storage_opt with + | Some struct_storage -> + let data = struct_storage.StructStorage.data in + if byte_ofs + 7 < data.Slice.len then + Slice.get_int64 data byte_ofs + else + Int64.zero + | None -> + Int64.zero + in + let bits = Int64.bit_xor numeric default_bits in + Int64.float_of_bits bits + + + (******************************************************************************* + * METHODS FOR GETTING OBJECTS STORED BY POINTER + *******************************************************************************) + + let has_field + (struct_storage_opt : 'cap StructStorage.t option) + (pointer_word : int) + : bool = + match struct_storage_opt with + | Some struct_storage -> + let pointers = struct_storage.StructStorage.pointers in + let start = pointer_word * sizeof_uint64 in + let len = sizeof_uint64 in + if start + len <= pointers.Slice.len then + let pointer64 = Slice.get_int64 pointers start in + not (Util.is_int64_zero pointer64) + else + false + | None -> + false + + let get_text + ~(default : string) + (struct_storage_opt : 'cap StructStorage.t option) + (pointer_word : int) + : string = + match struct_storage_opt with + | Some struct_storage -> + let pointers = struct_storage.StructStorage.pointers in + let start = pointer_word * sizeof_uint64 in + let len = sizeof_uint64 in + if start + len <= pointers.Slice.len then + let pointer_bytes = { + pointers with + Slice.start = pointers.Slice.start + start; + Slice.len = len; + } in + match deref_list_pointer pointer_bytes with + | Some list_storage -> + string_of_uint8_list ~null_terminated:true list_storage + | None -> + default + else + default + | None -> + default + + let get_blob + ~(default : string) + (struct_storage_opt : 'cap StructStorage.t option) + (pointer_word : int) + : string = + match struct_storage_opt with + | Some struct_storage -> + let pointers = struct_storage.StructStorage.pointers in + let start = pointer_word * sizeof_uint64 in + let len = sizeof_uint64 in + if start + len <= pointers.Slice.len then + let pointer_bytes = { + pointers with + Slice.start = pointers.Slice.start + start; + Slice.len = len; + } in + match deref_list_pointer pointer_bytes with + | Some list_storage -> + string_of_uint8_list ~null_terminated:false list_storage + | None -> + default + else + default + | None -> + default + + let get_list + ?(default : ro ListStorage.t option) + (decoders : ('cap, 'a) ListDecoders.t) + (struct_storage_opt : 'cap StructStorage.t option) + (pointer_word : int) + : (ro, 'a, 'cap ListStorage.t) InnerArray.t = + let make_default default' decoders' = + begin match default' with + | Some default_storage -> + make_array_readonly default_storage decoders' + | None -> + (* Empty array *) + { InnerArray.length = 0; + InnerArray.storage = None; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = InnerArray.invalid_get_unsafe; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; } + end + in + match struct_storage_opt with + | Some struct_storage -> + let pointers = struct_storage.StructStorage.pointers in + let start = pointer_word * sizeof_uint64 in + let len = sizeof_uint64 in + if start + len <= pointers.Slice.len then + (* Fast path. *) + let pointer64 = Slice.get_int64 pointers start in + let pointer_int = Caml.Int64.to_int pointer64 in + let tag = pointer_int land Pointer.Bitfield.tag_mask in + if tag = Pointer.Bitfield.tag_val_list then + let list_pointer = ListPointer.decode pointer64 in + let list_storage = make_list_storage + ~message:pointers.Slice.msg + ~segment_id:pointers.Slice.segment_id + ~segment_offset:((pointers.Slice.start + start + len) + + (list_pointer.ListPointer.offset * sizeof_uint64)) + ~list_pointer + in + make_array_readonly list_storage decoders + else + (* Slow path... most likely a far pointer.*) + let pointer_bytes = { + pointers with + Slice.start = pointers.Slice.start + start; + Slice.len = len; + } in + match deref_list_pointer pointer_bytes with + | Some list_storage -> + make_array_readonly list_storage decoders + | None -> + make_default default decoders + else + make_default default decoders + | None -> + make_default default decoders + + let get_void_list + ?(default : ro ListStorage.t option) + (struct_storage_opt : 'cap StructStorage.t option) + (pointer_word : int) + : (ro, unit, 'cap ListStorage.t) InnerArray.t = + get_list ?default void_list_decoders struct_storage_opt pointer_word + + let get_bit_list + ?(default : ro ListStorage.t option) + (struct_storage_opt : 'cap StructStorage.t option) + (pointer_word : int) + : (ro, bool, 'cap ListStorage.t) InnerArray.t = + get_list ?default bit_list_decoders struct_storage_opt pointer_word + + let get_int8_list + ?(default : ro ListStorage.t option) + (struct_storage_opt : 'cap StructStorage.t option) + (pointer_word : int) + : (ro, int, 'cap ListStorage.t) InnerArray.t = + get_list ?default int8_list_decoders struct_storage_opt pointer_word + + let get_int16_list + ?(default : ro ListStorage.t option) + (struct_storage_opt : 'cap StructStorage.t option) + (pointer_word : int) + : (ro, int, 'cap ListStorage.t) InnerArray.t = + get_list ?default int16_list_decoders struct_storage_opt pointer_word + + let get_int32_list + ?(default : ro ListStorage.t option) + (struct_storage_opt : 'cap StructStorage.t option) + (pointer_word : int) + : (ro, int32, 'cap ListStorage.t) InnerArray.t = + get_list ?default int32_list_decoders struct_storage_opt pointer_word + + let get_int64_list + ?(default : ro ListStorage.t option) + (struct_storage_opt : 'cap StructStorage.t option) + (pointer_word : int) + : (ro, int64, 'cap ListStorage.t) InnerArray.t = + get_list ?default int64_list_decoders struct_storage_opt pointer_word + + let get_uint8_list + ?(default : ro ListStorage.t option) + (struct_storage_opt : 'cap StructStorage.t option) + (pointer_word : int) + : (ro, int, 'cap ListStorage.t) InnerArray.t = + get_list ?default uint8_list_decoders struct_storage_opt pointer_word + + let get_uint16_list + ?(default : ro ListStorage.t option) + (struct_storage_opt : 'cap StructStorage.t option) + (pointer_word : int) + : (ro, int, 'cap ListStorage.t) InnerArray.t = + get_list ?default uint16_list_decoders struct_storage_opt pointer_word + + let get_uint32_list + ?(default : ro ListStorage.t option) + (struct_storage_opt : 'cap StructStorage.t option) + (pointer_word : int) + : (ro, Uint32.t, 'cap ListStorage.t) InnerArray.t = + get_list ?default uint32_list_decoders struct_storage_opt pointer_word + + let get_uint64_list + ?(default : ro ListStorage.t option) + (struct_storage_opt : 'cap StructStorage.t option) + (pointer_word : int) + : (ro, Uint64.t, 'cap ListStorage.t) InnerArray.t = + get_list ?default uint64_list_decoders struct_storage_opt pointer_word + + let get_float32_list + ?(default : ro ListStorage.t option) + (struct_storage_opt : 'cap StructStorage.t option) + (pointer_word : int) + : (ro, float, 'cap ListStorage.t) InnerArray.t = + get_list ?default float32_list_decoders struct_storage_opt pointer_word + + let get_float64_list + ?(default : ro ListStorage.t option) + (struct_storage_opt : 'cap StructStorage.t option) + (pointer_word : int) + : (ro, float, 'cap ListStorage.t) InnerArray.t = + get_list ?default float64_list_decoders struct_storage_opt pointer_word + + let get_text_list + ?(default : ro ListStorage.t option) + (struct_storage_opt : 'cap StructStorage.t option) + (pointer_word : int) + : (ro, string, 'cap ListStorage.t) InnerArray.t = + get_list ?default text_list_decoders struct_storage_opt pointer_word + + let get_blob_list + ?(default : ro ListStorage.t option) + (struct_storage_opt : 'cap StructStorage.t option) + (pointer_word : int) + : (ro, string, 'cap ListStorage.t) InnerArray.t = + get_list ?default blob_list_decoders struct_storage_opt pointer_word + + let get_struct_list + ?(default : ro ListStorage.t option) + (struct_storage_opt : 'cap StructStorage.t option) + (pointer_word : int) + : (ro, 'cap StructStorage.t option, 'cap ListStorage.t) InnerArray.t = + get_list ?default struct_list_decoders struct_storage_opt pointer_word + + let get_struct + ?(default : ro StructStorage.t option) + (struct_storage_opt : 'cap StructStorage.t option) + (pointer_word : int) + : 'cap StructStorage.t option = + match struct_storage_opt with + | Some struct_storage -> + let pointers = struct_storage.StructStorage.pointers in + let start = pointer_word * sizeof_uint64 in + let len = sizeof_uint64 in + if start + len <= pointers.Slice.len then + let pointer_bytes = { + pointers with + Slice.start = pointers.Slice.start + start; + Slice.len = len; + } in + match deref_struct_pointer pointer_bytes with + | Some storage -> + Some storage + | None -> + default + else + default + | None -> + default + + let get_pointer + ?(default: ro Slice.t option) + (struct_storage_opt : 'cap StructStorage.t option) + (pointer_word : int) + : 'cap Slice.t option = + match struct_storage_opt with + | Some struct_storage -> + let pointers = struct_storage.StructStorage.pointers in + let start = pointer_word * sizeof_uint64 in + let len = sizeof_uint64 in + if start + len <= pointers.Slice.len then + let pointer64 = Slice.get_int64 pointers start in + if Util.is_int64_zero pointer64 then + default + else + let pointer_bytes = { + pointers with + Slice.start = pointers.Slice.start + start; + Slice.len = len; + } in + Some pointer_bytes + else + default + | None -> + default + + let get_interface + (struct_storage_opt : 'cap StructStorage.t option) + (pointer_word : int) + : Uint32.t option = + match struct_storage_opt with + | Some struct_storage -> + let pointers = struct_storage.StructStorage.pointers in + let start = pointer_word * sizeof_uint64 in + let len = sizeof_uint64 in + if start + len <= pointers.Slice.len then + let pointer_bytes = { + pointers with + Slice.start = pointers.Slice.start + start; + Slice.len = len; + } in + match decode_pointer pointer_bytes with + | Pointer.Null -> + None + | Pointer.Other (OtherPointer.Capability index) -> + Some index + | _ -> + invalid_msg "decoded non-capability pointer where capability was expected" + else + None + | None -> + None + + end + module BA_ = struct + open Capnp.Runtime + module NM = MessageWrapper + (****************************************************************************** + * capnp-ocaml + * + * Copyright (c) 2013-2014, Paul Pelzl + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * 1. Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + ******************************************************************************) + + (* Runtime support for Builder interfaces. In many ways this parallels the + Reader support, to the point of using the same function names; however, + the underlying message must be tagged as read/write, and many functions in + this module may allocate message space (for example, dereferencing a struct + pointer will cause struct storage to be immediately allocated if that pointer + was null). *) + + open Core_kernel.Std + + type ro = Message.ro + type rw = Message.rw + let invalid_msg = Message.invalid_msg + + let sizeof_uint64 = 8 + + (* Functor parameter: NM == "native message" *) + + (* DM == "defaults message", meaning "the type of messages that store default values" *) + module DM = Message.BytesMessage + + module NC = struct + module MessageWrapper = NM + (****************************************************************************** + * capnp-ocaml + * + * Copyright (c) 2013-2014, Paul Pelzl + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * 1. Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + ******************************************************************************) + + (* Runtime support which is common to both Reader and Builder interfaces. *) + + open Core_kernel.Std + + + let sizeof_uint32 = 4 + let sizeof_uint64 = 8 + + let invalid_msg = Message.invalid_msg + let out_of_int_range = Message.out_of_int_range + type ro = Message.ro + type rw = Message.rw + + include MessageWrapper + + let bounds_check_slice_exn ?err (slice : 'cap Slice.t) : unit = + let open Slice in + if slice.segment_id < 0 || + slice.segment_id >= Message.num_segments slice.msg || + slice.start < 0 || + slice.start + slice.len > Segment.length (Slice.get_segment slice) + then + let error_msg = + match err with + | None -> "pointer referenced a memory region outside the message" + | Some msg -> msg + in + invalid_msg error_msg + else + () + + + (** Get the range of bytes associated with a pointer stored in a struct. *) + let ss_get_pointer + (struct_storage : 'cap StructStorage.t) + (word : int) (* Struct-relative pointer index *) + : 'cap Slice.t option = (* Returns None if storage is too small for this word *) + let pointers = struct_storage.StructStorage.pointers in + let start = word * sizeof_uint64 in + let len = sizeof_uint64 in + if start + len <= pointers.Slice.len then + Some { + pointers with + Slice.start = pointers.Slice.start + start; + Slice.len = len + } + else + None + + + let decode_pointer64 (pointer64 : int64) : Pointer.t = + if Util.is_int64_zero pointer64 then + Pointer.Null + else + let pointer_int = Caml.Int64.to_int pointer64 in + let tag = pointer_int land Pointer.Bitfield.tag_mask in + (* OCaml won't match an int against let-bound variables, + only against constants. *) + match tag with + | 0x0 -> (* Pointer.Bitfield.tag_val_struct *) + Pointer.Struct (StructPointer.decode pointer64) + | 0x1 -> (* Pointer.Bitfield.tag_val_list *) + Pointer.List (ListPointer.decode pointer64) + | 0x2 -> (* Pointer.Bitfield.tag_val_far *) + Pointer.Far (FarPointer.decode pointer64) + | 0x3 -> (* Pointer.Bitfield.tag_val_other *) + Pointer.Other (OtherPointer.decode pointer64) + | _ -> + assert false + + + (* Given a range of eight bytes corresponding to a cap'n proto pointer, + decode the information stored in the pointer. *) + let decode_pointer (pointer_bytes : 'cap Slice.t) : Pointer.t = + let pointer64 = Slice.get_int64 pointer_bytes 0 in + decode_pointer64 pointer64 + + + let make_list_storage_aux ~message ~num_words ~num_elements ~storage_type + ~segment_id ~segment_offset = + let storage = { + Slice.msg = message; + Slice.segment = Message.get_segment message segment_id; + Slice.segment_id = segment_id; + Slice.start = segment_offset; + Slice.len = num_words * sizeof_uint64; + } in + let () = bounds_check_slice_exn + ~err:"list pointer describes invalid storage region" storage + in { + ListStorage.storage = storage; + ListStorage.storage_type = storage_type; + ListStorage.num_elements = num_elements; + } + + + (* Given a list pointer descriptor, construct the corresponding list storage + descriptor. *) + let make_list_storage + ~(message : 'cap Message.t) (* Message of interest *) + ~(segment_id : int) (* Segment ID where list storage is found *) + ~(segment_offset : int) (* Segment offset where list storage is found *) + ~(list_pointer : ListPointer.t) + : 'cap ListStorage.t = + let open ListPointer in + match list_pointer.element_type with + | Void -> + make_list_storage_aux ~message ~num_words:0 + ~num_elements:list_pointer.num_elements + ~storage_type:ListStorageType.Empty ~segment_id ~segment_offset + | OneBitValue -> + make_list_storage_aux ~message + ~num_words:(Util.ceil_ratio list_pointer.num_elements 64) + ~num_elements:list_pointer.num_elements ~storage_type:ListStorageType.Bit + ~segment_id ~segment_offset + | OneByteValue -> + make_list_storage_aux ~message + ~num_words:(Util.ceil_ratio list_pointer.num_elements 8) + ~num_elements:list_pointer.num_elements + ~storage_type:ListStorageType.Bytes1 + ~segment_id ~segment_offset + | TwoByteValue -> + make_list_storage_aux ~message + ~num_words:(Util.ceil_ratio list_pointer.num_elements 4) + ~num_elements:list_pointer.num_elements + ~storage_type:ListStorageType.Bytes2 + ~segment_id ~segment_offset + | FourByteValue -> + make_list_storage_aux ~message + ~num_words:(Util.ceil_ratio list_pointer.num_elements 2) + ~num_elements:list_pointer.num_elements + ~storage_type:ListStorageType.Bytes4 + ~segment_id ~segment_offset + | EightByteValue -> + make_list_storage_aux ~message ~num_words:list_pointer.num_elements + ~num_elements:list_pointer.num_elements + ~storage_type:ListStorageType.Bytes8 + ~segment_id ~segment_offset + | EightBytePointer -> + make_list_storage_aux ~message ~num_words:list_pointer.num_elements + ~num_elements:list_pointer.num_elements + ~storage_type:ListStorageType.Pointer + ~segment_id ~segment_offset + | Composite -> + if segment_id < 0 || segment_id >= Message.num_segments message then + invalid_msg "composite list pointer describes invalid tag region" + else + let segment = Message.get_segment message segment_id in + if segment_offset + sizeof_uint64 > Segment.length segment then + invalid_msg "composite list pointer describes invalid tag region" + else + let pointer64 = Segment.get_int64 segment segment_offset in + let pointer_int = Caml.Int64.to_int pointer64 in + let tag = pointer_int land Pointer.Bitfield.tag_mask in + if tag = Pointer.Bitfield.tag_val_struct then + let struct_pointer = StructPointer.decode pointer64 in + let num_words = list_pointer.num_elements in + let num_elements = struct_pointer.StructPointer.offset in + let words_per_element = struct_pointer.StructPointer.data_words + + struct_pointer.StructPointer.pointer_words + in + if num_elements * words_per_element > num_words then + invalid_msg "composite list pointer describes invalid word count" + else + make_list_storage_aux ~message ~num_words ~num_elements + ~storage_type:(ListStorageType.Composite + (struct_pointer.StructPointer.data_words, + struct_pointer.StructPointer.pointer_words)) + ~segment_id ~segment_offset + else + invalid_msg "composite list pointer has malformed element type tag" + + + (* Given a description of a cap'n proto far pointer, get the object which + the pointer points to. *) + let rec deref_far_pointer + (far_pointer : FarPointer.t) + (message : 'cap Message.t) + : 'cap Object.t = + let open FarPointer in + match far_pointer.landing_pad with + | NormalPointer -> + let next_pointer_bytes = { + Slice.msg = message; + Slice.segment = Message.get_segment message far_pointer.segment_id; + Slice.segment_id = far_pointer.segment_id; + Slice.start = far_pointer.offset * sizeof_uint64; + Slice.len = sizeof_uint64; + } in + let () = bounds_check_slice_exn + ~err:"far pointer describes invalid landing pad" next_pointer_bytes + in + deref_pointer next_pointer_bytes + | TaggedFarPointer -> + let content_pointer_bytes = { + Slice.msg = message; + Slice.segment = Message.get_segment message far_pointer.segment_id; + Slice.segment_id = far_pointer.segment_id; + Slice.start = far_pointer.offset * sizeof_uint64; + Slice.len = sizeof_uint64; + } in + let tag_bytes = { + content_pointer_bytes with + Slice.start = Slice.get_end content_pointer_bytes; + } in + match (decode_pointer content_pointer_bytes, decode_pointer tag_bytes) with + | (Pointer.Far content_pointer, Pointer.List list_pointer) -> + Object.List (make_list_storage + ~message + ~segment_id:content_pointer.FarPointer.segment_id + ~segment_offset:(content_pointer.FarPointer.offset * sizeof_uint64) + ~list_pointer) + | (Pointer.Far content_pointer, Pointer.Struct struct_pointer) -> + let segment_id = content_pointer.FarPointer.segment_id in + let data = { + Slice.msg = message; + Slice.segment = Message.get_segment message segment_id; + Slice.segment_id; + Slice.start = content_pointer.FarPointer.offset * sizeof_uint64; + Slice.len = struct_pointer.StructPointer.data_words * sizeof_uint64; + } in + let pointers = { + data with + Slice.start = Slice.get_end data; + Slice.len = + struct_pointer.StructPointer.pointer_words * sizeof_uint64; + } in + let () = bounds_check_slice_exn + ~err:"struct-tagged far pointer describes invalid data region" + data + in + let () = bounds_check_slice_exn + ~err:"struct-tagged far pointer describes invalid pointers region" + pointers + in + Object.Struct { StructStorage.data; StructStorage.pointers; } + | _ -> + invalid_msg "tagged far pointer points to invalid landing pad" + + + (* Given a range of eight bytes which represent a pointer, get the object which + the pointer points to. *) + and deref_pointer (pointer_bytes : 'cap Slice.t) : 'cap Object.t = + let pointer64 = Slice.get_int64 pointer_bytes 0 in + if Util.is_int64_zero pointer64 then + Object.None + else + let pointer64 = Slice.get_int64 pointer_bytes 0 in + let tag_bits = Caml.Int64.to_int pointer64 in + let tag = tag_bits land Pointer.Bitfield.tag_mask in + (* OCaml won't match an int against let-bound variables, + only against constants. *) + match tag with + | 0x0 -> (* Pointer.Bitfield.tag_val_struct *) + let struct_pointer = StructPointer.decode pointer64 in + let open StructPointer in + let data = { + pointer_bytes with + Slice.start = + (Slice.get_end pointer_bytes) + (struct_pointer.offset * sizeof_uint64); + Slice.len = struct_pointer.data_words * sizeof_uint64; + } in + let pointers = { + data with + Slice.start = Slice.get_end data; + Slice.len = struct_pointer.pointer_words * sizeof_uint64; + } in + let () = bounds_check_slice_exn + ~err:"struct pointer describes invalid data region" data + in + let () = bounds_check_slice_exn + ~err:"struct pointer describes invalid pointers region" pointers + in + Object.Struct { StructStorage.data; StructStorage.pointers; } + | 0x1 -> (* Pointer.Bitfield.tag_val_list *) + let list_pointer = ListPointer.decode pointer64 in + Object.List (make_list_storage + ~message:pointer_bytes.Slice.msg + ~segment_id:pointer_bytes.Slice.segment_id + ~segment_offset:((Slice.get_end pointer_bytes) + + (list_pointer.ListPointer.offset * sizeof_uint64)) + ~list_pointer) + | 0x2 -> (* Pointer.Bitfield.tag_val_far *) + let far_pointer = FarPointer.decode pointer64 in + deref_far_pointer far_pointer pointer_bytes.Slice.msg + | 0x3 -> (* Pointer.Bitfield.tag_val_other *) + let other_pointer = OtherPointer.decode pointer64 in + let (OtherPointer.Capability index) = other_pointer in + Object.Capability index + | _ -> + assert false + + + module ListDecoders = struct + type ('cap, 'a) struct_decoders_t = { + bytes : 'cap Slice.t -> 'a; + pointer : 'cap Slice.t -> 'a; + composite : 'cap StructStorage.t -> 'a; + } + + type ('cap, 'a) t = + | Empty of (unit -> 'a) + | Bit of (bool -> 'a) + | Bytes1 of ('cap Slice.t -> 'a) + | Bytes2 of ('cap Slice.t -> 'a) + | Bytes4 of ('cap Slice.t -> 'a) + | Bytes8 of ('cap Slice.t -> 'a) + | Pointer of ('cap Slice.t -> 'a) + | Struct of ('cap, 'a) struct_decoders_t + end + + + module ListCodecs = struct + type 'a struct_codecs_t = { + bytes : (rw Slice.t -> 'a) * ('a -> rw Slice.t -> unit); + pointer : (rw Slice.t -> 'a) * ('a -> rw Slice.t -> unit); + composite : (rw StructStorage.t -> 'a) * ('a -> rw StructStorage.t -> unit); + } + + type 'a t = + | Empty of (unit -> 'a) * ('a -> unit) + | Bit of (bool -> 'a) * ('a -> bool) + | Bytes1 of (rw Slice.t -> 'a) * ('a -> rw Slice.t -> unit) + | Bytes2 of (rw Slice.t -> 'a) * ('a -> rw Slice.t -> unit) + | Bytes4 of (rw Slice.t -> 'a) * ('a -> rw Slice.t -> unit) + | Bytes8 of (rw Slice.t -> 'a) * ('a -> rw Slice.t -> unit) + | Pointer of (rw Slice.t -> 'a) * ('a -> rw Slice.t -> unit) + | Struct of 'a struct_codecs_t + end + + let _dummy = ref true + + let make_array_readonly + (list_storage : 'cap ListStorage.t) + (decoders : ('cap, 'a) ListDecoders.t) + : (ro, 'a, 'cap ListStorage.t) InnerArray.t = + let make_element_slice ls i byte_count = { + ls.ListStorage.storage with + Slice.start = ls.ListStorage.storage.Slice.start + (i * byte_count); + Slice.len = byte_count; + } in + let length = list_storage.ListStorage.num_elements in + (* Note: the following is attempting to strike a balance between + * (1) building InnerArray.get_unsafe closures that do as little work as + * possible and + * (2) making the closure calling convention as efficient as possible. + * + * A naive implementation of this getter can result in quite slow code. *) + match list_storage.ListStorage.storage_type with + | ListStorageType.Empty -> + begin match decoders with + | ListDecoders.Empty decode -> + let ro_get_unsafe_void ls i = decode () in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_void; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List where a different list type was expected" + end + | ListStorageType.Bit -> + begin match decoders with + | ListDecoders.Bit decode -> + let ro_get_unsafe_bool ls i = + let byte_ofs = i / 8 in + let bit_ofs = i mod 8 in + let byte_val = + Slice.get_uint8 ls.ListStorage.storage byte_ofs + in + decode ((byte_val land (1 lsl bit_ofs)) <> 0) + in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_bool; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List where a different list type was expected" + end + | ListStorageType.Bytes1 -> + begin match decoders with + | ListDecoders.Bytes1 decode + | ListDecoders.Struct { ListDecoders.bytes = decode; _ } -> + let ro_get_unsafe_bytes1 ls i = decode (make_element_slice ls i 1) in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_bytes1; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List<1 byte> where a different list type was expected" + end + | ListStorageType.Bytes2 -> + begin match decoders with + | ListDecoders.Bytes2 decode + | ListDecoders.Struct { ListDecoders.bytes = decode; _ } -> + let ro_get_unsafe_bytes2 ls i = decode (make_element_slice ls i 2) in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_bytes2; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List<2 byte> where a different list type was expected" + end + | ListStorageType.Bytes4 -> + begin match decoders with + | ListDecoders.Bytes4 decode + | ListDecoders.Struct { ListDecoders.bytes = decode; _ } -> + let ro_get_unsafe_bytes4 ls i = decode (make_element_slice ls i 4) in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_bytes4; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List<4 byte> where a different list type was expected" + end + | ListStorageType.Bytes8 -> + begin match decoders with + | ListDecoders.Bytes8 decode + | ListDecoders.Struct { ListDecoders.bytes = decode; _ } -> + let ro_get_unsafe_bytes8 ls i = decode (make_element_slice ls i 8) in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_bytes8; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List<8 byte> where a different list type was expected" + end + | ListStorageType.Pointer -> + begin match decoders with + | ListDecoders.Pointer decode + | ListDecoders.Struct { ListDecoders.pointer = decode; _ } -> + let ro_get_unsafe_pointer ls i = decode (make_element_slice ls i sizeof_uint64) in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_pointer; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List a different list type was expected" + end + | ListStorageType.Composite (data_words, pointer_words) -> + let data_size = data_words * sizeof_uint64 in + let pointers_size = pointer_words * sizeof_uint64 in + let make_storage ls i ~data_size ~pointers_size = + let total_size = data_size + pointers_size in + (* Skip over the composite tag word *) + let content_offset = + ls.ListStorage.storage.Slice.start + sizeof_uint64 + in + let data = { + ls.ListStorage.storage with + Slice.start = content_offset + (i * total_size); + Slice.len = data_size; + } in + let pointers = { + data with + Slice.start = Slice.get_end data; + Slice.len = pointers_size; + } in + { StructStorage.data; StructStorage.pointers; } + in + let make_bytes_handler ~size ~decode = + if data_words = 0 then + invalid_msg + "decoded List with empty data region where data was expected" + else + let ro_get_unsafe_composite_bytes ls i = + let struct_storage = make_storage ls i ~data_size ~pointers_size in + let slice = { + struct_storage.StructStorage.data with + Slice.len = size + } in + decode slice + in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_composite_bytes; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + in + begin match decoders with + | ListDecoders.Empty decode -> + let ro_get_unsafe_composite_void ls i = decode () in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_composite_void; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + | ListDecoders.Bit decode -> + if data_words = 0 then + invalid_msg + "decoded List with empty data region where data was expected" + else + let ro_get_unsafe_composite_bool ls i = + let struct_storage = make_storage ls i ~data_size ~pointers_size in + let first_byte = Slice.get_uint8 struct_storage.StructStorage.data 0 in + let is_set = (first_byte land 0x1) <> 0 in + decode is_set + in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_composite_bool; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + | ListDecoders.Bytes1 decode -> + make_bytes_handler ~size:1 ~decode + | ListDecoders.Bytes2 decode -> + make_bytes_handler ~size:2 ~decode + | ListDecoders.Bytes4 decode -> + make_bytes_handler ~size:4 ~decode + | ListDecoders.Bytes8 decode -> + make_bytes_handler ~size:8 ~decode + | ListDecoders.Pointer decode -> + if pointer_words = 0 then + invalid_msg + "decoded List with empty pointers region where \ + pointers were expected" + else + let ro_get_unsafe_composite_pointer ls i = + let struct_storage = make_storage ls i ~data_size ~pointers_size in + let slice = { + struct_storage.StructStorage.pointers with + Slice.len = sizeof_uint64 + } in + decode slice + in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_composite_pointer; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + | ListDecoders.Struct struct_decoders -> + let ro_get_unsafe_composite_struct ls i = + let struct_storage = make_storage ls i ~data_size ~pointers_size in + struct_decoders.ListDecoders.composite struct_storage + in { + InnerArray.length; + InnerArray.init = InnerArray.invalid_init; + InnerArray.get_unsafe = ro_get_unsafe_composite_struct; + InnerArray.set_unsafe = InnerArray.invalid_set_unsafe; + InnerArray.storage = Some list_storage; + } + end + + + let make_array_readwrite + ~(list_storage : rw ListStorage.t) + ~(init : int -> rw ListStorage.t) + ~(codecs : 'a ListCodecs.t) + : (rw, 'a, rw ListStorage.t) InnerArray.t = + let make_element_slice ls i byte_count = { + ls.ListStorage.storage with + Slice.start = ls.ListStorage.storage.Slice.start + (i * byte_count); + Slice.len = byte_count; + } in + let length = list_storage.ListStorage.num_elements in + (* Note: the following is attempting to strike a balance between + * (1) building InnerArray.get_unsafe/set_unsafe closures that do as little + * work as possible and + * (2) making the closure calling convention as efficient as possible. + * + * A naive implementation of these accessors can result in quite slow code. *) + match list_storage.ListStorage.storage_type with + | ListStorageType.Empty -> + begin match codecs with + | ListCodecs.Empty (decode, encode) -> + let rw_get_unsafe_void ls i = decode () in + let rw_set_unsafe_void ls i v = encode v in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_void; + InnerArray.set_unsafe = rw_set_unsafe_void; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List where a different list type was expected" + end + | ListStorageType.Bit -> + begin match codecs with + | ListCodecs.Bit (decode, encode) -> + let rw_get_unsafe_bool ls i = + let byte_ofs = i / 8 in + let bit_ofs = i mod 8 in + let byte_val = + Slice.get_uint8 ls.ListStorage.storage byte_ofs + in + decode ((byte_val land (1 lsl bit_ofs)) <> 0) + in + let rw_set_unsafe_bool ls i v = + let byte_ofs = i / 8 in + let bit_ofs = i mod 8 in + let bitmask = 1 lsl bit_ofs in + let old_byte_val = + Slice.get_uint8 ls.ListStorage.storage byte_ofs + in + let new_byte_val = + if encode v then + old_byte_val lor bitmask + else + old_byte_val land (lnot bitmask) + in + Slice.set_uint8 ls.ListStorage.storage byte_ofs new_byte_val + in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_bool; + InnerArray.set_unsafe = rw_set_unsafe_bool; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List where a different list type was expected" + end + | ListStorageType.Bytes1 -> + begin match codecs with + | ListCodecs.Bytes1 (decode, encode) + | ListCodecs.Struct { ListCodecs.bytes = (decode, encode); _ } -> + let rw_get_unsafe_bytes1 ls i = decode (make_element_slice ls i 1) in + let rw_set_unsafe_bytes1 ls i v = encode v (make_element_slice ls i 1) in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_bytes1; + InnerArray.set_unsafe = rw_set_unsafe_bytes1; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List<1 byte> where a different list type was expected" + end + | ListStorageType.Bytes2 -> + begin match codecs with + | ListCodecs.Bytes2 (decode, encode) + | ListCodecs.Struct { ListCodecs.bytes = (decode, encode); _ } -> + let rw_get_unsafe_bytes2 ls i = decode (make_element_slice ls i 2) in + let rw_set_unsafe_bytes2 ls i v = encode v (make_element_slice ls i 2) in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_bytes2; + InnerArray.set_unsafe = rw_set_unsafe_bytes2; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List<2 byte> where a different list type was expected" + end + | ListStorageType.Bytes4 -> + begin match codecs with + | ListCodecs.Bytes4 (decode, encode) + | ListCodecs.Struct { ListCodecs.bytes = (decode, encode); _ } -> + let rw_get_unsafe_bytes4 ls i = decode (make_element_slice ls i 4) in + let rw_set_unsafe_bytes4 ls i v = encode v (make_element_slice ls i 4) in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_bytes4; + InnerArray.set_unsafe = rw_set_unsafe_bytes4; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List<4 byte> where a different list type was expected" + end + | ListStorageType.Bytes8 -> + begin match codecs with + | ListCodecs.Bytes8 (decode, encode) + | ListCodecs.Struct { ListCodecs.bytes = (decode, encode); _ } -> + let rw_get_unsafe_bytes8 ls i = decode (make_element_slice ls i 8) in + let rw_set_unsafe_bytes8 ls i v = encode v (make_element_slice ls i 8) in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_bytes8; + InnerArray.set_unsafe = rw_set_unsafe_bytes8; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List<8 byte> where a different list type was expected" + end + | ListStorageType.Pointer -> + begin match codecs with + | ListCodecs.Pointer (decode, encode) + | ListCodecs.Struct { ListCodecs.pointer = (decode, encode); _ } -> + let rw_get_unsafe_ptr ls i = + decode (make_element_slice ls i sizeof_uint64) + in + let rw_set_unsafe_ptr ls i v = + encode v (make_element_slice ls i sizeof_uint64) + in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_ptr; + InnerArray.set_unsafe = rw_set_unsafe_ptr; + InnerArray.storage = Some list_storage; + } + | _ -> + invalid_msg + "decoded List where a different list type was expected" + end + | ListStorageType.Composite (data_words, pointer_words) -> + let data_size = data_words * sizeof_uint64 in + let pointers_size = pointer_words * sizeof_uint64 in + let make_storage ls i ~data_size ~pointers_size = + let total_size = data_size + pointers_size in + (* Skip over the composite tag word *) + let content_offset = + ls.ListStorage.storage.Slice.start + sizeof_uint64 + in + let data = { + ls.ListStorage.storage with + Slice.start = content_offset + (i * total_size); + Slice.len = data_size; + } in + let pointers = { + data with + Slice.start = Slice.get_end data; + Slice.len = pointers_size; + } in + { StructStorage.data; StructStorage.pointers; } + in + let make_bytes_handlers ~size ~decode ~encode = + if data_words = 0 then + invalid_msg + "decoded List with empty data region where data was expected" + else + let rw_get_unsafe_composite_bytes ls i = + let struct_storage = make_storage ls i ~data_size ~pointers_size in + let slice = { + struct_storage.StructStorage.data with + Slice.len = size + } in + decode slice + in + let rw_set_unsafe_composite_bytes ls i v = + let struct_storage = make_storage ls i ~data_size ~pointers_size in + let slice = { + struct_storage.StructStorage.data with + Slice.len = size + } in + encode v slice + in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_composite_bytes; + InnerArray.set_unsafe = rw_set_unsafe_composite_bytes; + InnerArray.storage = Some list_storage; + } + in + begin match codecs with + | ListCodecs.Empty (decode, encode) -> + let rw_get_unsafe_composite_void ls i = decode () in + let rw_set_unsafe_composite_void ls i v = encode v in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_composite_void; + InnerArray.set_unsafe = rw_set_unsafe_composite_void; + InnerArray.storage = Some list_storage; + } + | ListCodecs.Bit (decode, encode) -> + if data_words = 0 then + invalid_msg + "decoded List with empty data region where data was expected" + else + let rw_get_unsafe_composite_bool ls i = + let struct_storage = make_storage ls i ~data_size ~pointers_size in + let first_byte = Slice.get_uint8 struct_storage.StructStorage.data 0 in + let is_set = (first_byte land 0x1) <> 0 in + decode is_set + in + let rw_set_unsafe_composite_bool ls i v = + let struct_storage = make_storage ls i ~data_size ~pointers_size in + let first_byte = + Slice.get_uint8 struct_storage.StructStorage.data 0 + in + let first_byte = + if encode v then first_byte lor 0x1 else first_byte land 0xfe + in + Slice.set_uint8 struct_storage.StructStorage.data 0 first_byte + in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_composite_bool; + InnerArray.set_unsafe = rw_set_unsafe_composite_bool; + InnerArray.storage = Some list_storage; + } + | ListCodecs.Bytes1 (decode, encode) -> + make_bytes_handlers ~size:1 ~decode ~encode + | ListCodecs.Bytes2 (decode, encode) -> + make_bytes_handlers ~size:2 ~decode ~encode + | ListCodecs.Bytes4 (decode, encode) -> + make_bytes_handlers ~size:4 ~decode ~encode + | ListCodecs.Bytes8 (decode, encode) -> + make_bytes_handlers ~size:8 ~decode ~encode + | ListCodecs.Pointer (decode, encode) -> + if pointer_words = 0 then + invalid_msg + "decoded List with empty pointers region where \ + pointers were expected" + else + let rw_get_unsafe_composite_ptr ls i = + let struct_storage = make_storage ls i ~data_size ~pointers_size in + let slice = { + struct_storage.StructStorage.pointers with + Slice.len = sizeof_uint64 + } in + decode slice + in + let rw_set_unsafe_composite_ptr ls i v = + let struct_storage = make_storage ls i ~data_size ~pointers_size in + let slice = { + struct_storage.StructStorage.pointers with + Slice.len = sizeof_uint64 + } in + encode v slice + in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_composite_ptr; + InnerArray.set_unsafe = rw_set_unsafe_composite_ptr; + InnerArray.storage = Some list_storage; + } + | ListCodecs.Struct { ListCodecs.composite = (decode, encode); _ } -> + let rw_get_unsafe_composite_struct ls i = + decode (make_storage ls i ~data_size ~pointers_size) + in + let rw_set_unsafe_composite_struct ls i v = + encode v (make_storage ls i ~data_size ~pointers_size) + in { + InnerArray.length; + InnerArray.init; + InnerArray.get_unsafe = rw_get_unsafe_composite_struct; + InnerArray.set_unsafe = rw_set_unsafe_composite_struct; + InnerArray.storage = Some list_storage; + } + end + + + (* Given list storage which is expected to contain UInt8 data, decode the data as + an OCaml string. *) + let string_of_uint8_list + ~(null_terminated : bool) (* true if the data is expected to end in 0 *) + (list_storage : 'cap ListStorage.t) + : string = + let open ListStorage in + match list_storage.storage_type with + | ListStorageType.Bytes1 -> + let result_byte_count = + if null_terminated then + let () = + if list_storage.num_elements < 1 then + invalid_msg "empty string list has no space for null terminator" + in + let terminator = + Slice.get_uint8 list_storage.storage (list_storage.num_elements - 1) + in + let () = if terminator <> 0 then + invalid_msg "string list is not null terminated" + in + list_storage.num_elements - 1 + else + list_storage.num_elements + in + let buf = CamlBytes.create result_byte_count in + Slice.blit_to_bytes + ~src:list_storage.storage ~src_pos:0 + ~dst:buf ~dst_pos:0 + ~len:result_byte_count; + CamlBytes.unsafe_to_string buf + | _ -> + invalid_msg "decoded non-UInt8 list where string data was expected" + + + let struct_of_bytes_slice slice = + let data = slice in + let pointers = { + slice with + Slice.start = Slice.get_end data; + Slice.len = 0; + } in + { StructStorage.data; StructStorage.pointers } + + let struct_of_pointer_slice slice = + let () = assert (slice.Slice.len = sizeof_uint64) in + let data = { + slice with + Slice.len = 0 + } in + let pointers = { + slice with + Slice.len = sizeof_uint64; + } in + { StructStorage.data; StructStorage.pointers } + + + (* Given some list storage corresponding to a struct list, construct + a function for mapping an element index to the associated + struct storage. *) + let make_struct_of_list_index list_storage = + let storage = list_storage.ListStorage.storage in + let storage_type = list_storage.ListStorage.storage_type in + match list_storage.ListStorage.storage_type with + | ListStorageType.Empty -> + let make_struct_of_list_index_void i = + let slice = { + storage with + Slice.start = storage.Slice.start; + Slice.len = 0; + } in + struct_of_bytes_slice slice + in + make_struct_of_list_index_void + | ListStorageType.Bytes1 + | ListStorageType.Bytes2 + | ListStorageType.Bytes4 + | ListStorageType.Bytes8 -> + (* Short data-only struct *) + let byte_count = ListStorageType.get_byte_count storage_type in + let make_struct_of_list_index_bytes i = + let slice = { + storage with + Slice.start = storage.Slice.start + (i * byte_count); + Slice.len = byte_count; + } in + struct_of_bytes_slice slice + in + make_struct_of_list_index_bytes + | ListStorageType.Pointer -> + (* Single-pointer struct *) + let make_struct_of_list_index_pointer i = + let slice = { + storage with + Slice.start = (storage.Slice.start) + (i * sizeof_uint64); + Slice.len = sizeof_uint64; + } in + struct_of_pointer_slice slice + in + make_struct_of_list_index_pointer + | ListStorageType.Composite (data_words, pointer_words) -> + let data_size = data_words * sizeof_uint64 in + let pointers_size = pointer_words * sizeof_uint64 in + let element_size = data_size + pointers_size in + (* Skip over the composite tag word *) + let content_offset = storage.Slice.start + sizeof_uint64 in + let make_struct_of_list_index_composite i = + let data = { + storage with + Slice.start = content_offset + (i * element_size); + Slice.len = data_size; + } in + let pointers = { + storage with + Slice.start = Slice.get_end data; + Slice.len = pointers_size; + } in + { StructStorage.data; StructStorage.pointers } + in + make_struct_of_list_index_composite + | ListStorageType.Bit -> + invalid_msg "decoded List where List was expected" + + + end + + (* DefaultsCopier will provide algorithms for making deep copies of default + data from DM storage into native storage *) + module DefaultsCopier = BuilderOps.Make(DM)(NM) + + (* Most of the Builder operations need to copy from native storage back into + native storage *) + module BOps = BuilderOps.Make(NM)(NM) + + (* Given a string, generate an orphaned cap'n proto List which contains + the string content. *) + let uint8_list_of_string + ~(null_terminated : bool) (* true if the data is expected to end in 0 *) + ~(dest_message : rw NM.Message.t) + (src : string) + : rw NM.ListStorage.t = + let list_storage = BOps.alloc_list_storage dest_message + ListStorageType.Bytes1 + (String.length src + (if null_terminated then 1 else 0)) + in + NM.Slice.blit_from_string + ~src ~src_pos:0 + ~dst:list_storage.NM.ListStorage.storage ~dst_pos:0 + ~len:(String.length src); + list_storage + + + let void_list_codecs = NC.ListCodecs.Empty ( + (fun (x : unit) -> x), (fun (x : unit) -> x)) + + let bit_list_codecs = NC.ListCodecs.Bit ( + (fun (x : bool) -> x), (fun (x : bool) -> x)) + + let int8_list_codecs = NC.ListCodecs.Bytes1 ( + (fun slice -> NM.Slice.get_int8 slice 0), + (fun v slice -> NM.Slice.set_int8 slice 0 v)) + + let int16_list_codecs = NC.ListCodecs.Bytes2 ( + (fun slice -> NM.Slice.get_int16 slice 0), + (fun v slice -> NM.Slice.set_int16 slice 0 v)) + + let int32_list_codecs = NC.ListCodecs.Bytes4 ( + (fun slice -> NM.Slice.get_int32 slice 0), + (fun v slice -> NM.Slice.set_int32 slice 0 v)) + + let int64_list_codecs = NC.ListCodecs.Bytes8 ( + (fun slice -> NM.Slice.get_int64 slice 0), + (fun v slice -> NM.Slice.set_int64 slice 0 v)) + + let uint8_list_codecs = NC.ListCodecs.Bytes1 ( + (fun slice -> NM.Slice.get_uint8 slice 0), + (fun v slice -> NM.Slice.set_uint8 slice 0 v)) + + let uint16_list_codecs = NC.ListCodecs.Bytes2 ( + (fun slice -> NM.Slice.get_uint16 slice 0), + (fun v slice -> NM.Slice.set_uint16 slice 0 v)) + + let uint32_list_codecs = NC.ListCodecs.Bytes4 ( + (fun slice -> NM.Slice.get_uint32 slice 0), + (fun v slice -> NM.Slice.set_uint32 slice 0 v)) + + let uint64_list_codecs = NC.ListCodecs.Bytes8 ( + (fun slice -> NM.Slice.get_uint64 slice 0), + (fun v slice -> NM.Slice.set_uint64 slice 0 v)) + + let float32_list_codecs = NC.ListCodecs.Bytes4 ( + (fun slice -> Int32.float_of_bits (NM.Slice.get_int32 slice 0)), + (fun v slice -> NM.Slice.set_int32 slice 0 + (Int32.bits_of_float v))) + + let float64_list_codecs = NC.ListCodecs.Bytes8 ( + (fun slice -> Int64.float_of_bits (NM.Slice.get_int64 slice 0)), + (fun v slice -> NM.Slice.set_int64 slice 0 + (Int64.bits_of_float v))) + + let text_list_codecs = + let decode slice = + (* Text fields are always accessed by value, not by reference, since + we always do an immediate decode to [string]. Therefore we can + use the Reader logic to handle this case. *) + match RA_.deref_list_pointer slice with + | Some list_storage -> + NC.string_of_uint8_list ~null_terminated:true list_storage + | None -> + "" + in + let encode s slice = + let new_list_storage = uint8_list_of_string ~null_terminated:true + ~dest_message:slice.NM.Slice.msg s + in + BOps.init_list_pointer slice new_list_storage + in + NC.ListCodecs.Pointer (decode, encode) + + let blob_list_codecs = + let decode slice = + (* Data fields are always accessed by value, not by reference, since + we always do an immediate decode to [string]. Therefore we can + use the Reader logic to handle this case. *) + match RA_.deref_list_pointer slice with + | Some list_storage -> + NC.string_of_uint8_list ~null_terminated:false list_storage + | None -> + "" + in + let encode s slice = + let new_list_storage = uint8_list_of_string ~null_terminated:false + ~dest_message:slice.NM.Slice.msg s + in + BOps.init_list_pointer slice new_list_storage + in + NC.ListCodecs.Pointer (decode, encode) + + let struct_list_codecs = + let bytes_decoder slice = + NC.struct_of_bytes_slice slice + in + let bytes_encoder v slice = + let dest = NC.struct_of_bytes_slice slice in + BOps.deep_copy_struct_to_dest ~src:v ~dest + in + let pointer_decoder slice = + NC.struct_of_pointer_slice slice + in + let pointer_encoder v slice = + let dest = NC.struct_of_pointer_slice slice in + BOps.deep_copy_struct_to_dest ~src:v ~dest + in + let composite_decoder x = x in + let composite_encoder v dest = BOps.deep_copy_struct_to_dest ~src:v ~dest in + NC.ListCodecs.Struct { + NC.ListCodecs.bytes = (bytes_decoder, bytes_encoder); + NC.ListCodecs.pointer = (pointer_decoder, pointer_encoder); + NC.ListCodecs.composite = (composite_decoder, composite_encoder); + } + + + (******************************************************************************* + * METHODS FOR GETTING OBJECTS STORED BY VALUE + *******************************************************************************) + + module Discr = struct + type t = { + value : int; + byte_ofs : int; + } + end + + let rec set_opt_discriminant + (data : rw NM.Slice.t) + (discr : Discr.t option) + : unit = + match discr with + | None -> + () + | Some x -> + set_uint16 data ~default:0 ~byte_ofs:x.Discr.byte_ofs x.Discr.value + + and set_uint16 + ?(discr : Discr.t option) + (data : rw NM.Slice.t) + ~(default : int) + ~(byte_ofs : int) + (value : int) + : unit = + let () = set_opt_discriminant data discr in + NM.Slice.set_uint16 data byte_ofs (value lxor default) + + + (* Given storage for a struct, get the bytes associated with the + struct data section. If the optional discriminant parameter is + supplied, then the discriminant is also set as a side-effect. *) + let get_data_region + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + : rw NM.Slice.t = + let data = struct_storage.NM.StructStorage.data in + let () = set_opt_discriminant data discr in + data + + let get_bit + ~(default : bool) + (struct_storage : rw NM.StructStorage.t) + ~(byte_ofs : int) + ~(bit_ofs : int) + : bool = + let data = struct_storage.NM.StructStorage.data in + let byte_val = NM.Slice.get_uint8 data byte_ofs in + let is_set = Util.get_bit byte_val bit_ofs in + if default then + not is_set + else + is_set + + let get_int8 + ~(default : int) + (struct_storage : rw NM.StructStorage.t) + (byte_ofs : int) + : int = + let data = struct_storage.NM.StructStorage.data in + let numeric = NM.Slice.get_int8 data byte_ofs in + numeric lxor default + + let get_int16 + ~(default : int) + (struct_storage : rw NM.StructStorage.t) + (byte_ofs : int) + : int = + let data = struct_storage.NM.StructStorage.data in + let numeric = NM.Slice.get_int16 data byte_ofs in + numeric lxor default + + let get_int32 + ~(default : int32) + (struct_storage : rw NM.StructStorage.t) + (byte_ofs : int) + : int32 = + let data = struct_storage.NM.StructStorage.data in + let numeric = NM.Slice.get_int32 data byte_ofs in + Int32.bit_xor numeric default + + let get_int64 + ~(default : int64) + (struct_storage : rw NM.StructStorage.t) + (byte_ofs : int) + : int64 = + let data = struct_storage.NM.StructStorage.data in + let numeric = NM.Slice.get_int64 data byte_ofs in + Int64.bit_xor numeric default + + let get_uint8 + ~(default : int) + (struct_storage : rw NM.StructStorage.t) + (byte_ofs : int) + : int = + let data = struct_storage.NM.StructStorage.data in + let numeric = NM.Slice.get_uint8 data byte_ofs in + numeric lxor default + + let get_uint16 + ~(default : int) + (struct_storage : rw NM.StructStorage.t) + (byte_ofs : int) + : int = + let data = struct_storage.NM.StructStorage.data in + let numeric = NM.Slice.get_uint16 data byte_ofs in + numeric lxor default + + let get_uint32 + ~(default : Uint32.t) + (struct_storage : rw NM.StructStorage.t) + (byte_ofs : int) + : Uint32.t = + let data = struct_storage.NM.StructStorage.data in + let numeric = NM.Slice.get_uint32 data byte_ofs in + Uint32.logxor numeric default + + let get_uint64 + ~(default : Uint64.t) + (struct_storage : rw NM.StructStorage.t) + (byte_ofs : int) + : Uint64.t = + let data = struct_storage.NM.StructStorage.data in + let numeric = NM.Slice.get_uint64 data byte_ofs in + Uint64.logxor numeric default + + let get_float32 + ~(default_bits : int32) + (struct_storage : rw NM.StructStorage.t) + (byte_ofs : int) + : float = + let data = struct_storage.NM.StructStorage.data in + let numeric = NM.Slice.get_int32 data byte_ofs in + let bits = Int32.bit_xor numeric default_bits in + Int32.float_of_bits bits + + let get_float64 + ~(default_bits : int64) + (struct_storage : rw NM.StructStorage.t) + (byte_ofs : int) + : float = + let data = struct_storage.NM.StructStorage.data in + let numeric = NM.Slice.get_int64 data byte_ofs in + let bits = Int64.bit_xor numeric default_bits in + Int64.float_of_bits bits + + + (******************************************************************************* + * METHODS FOR SETTING OBJECTS STORED BY VALUE + *******************************************************************************) + + let set_void + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + : unit = + let data = struct_storage.NM.StructStorage.data in + set_opt_discriminant data discr + + let set_bit + ?(discr : Discr.t option) + ~(default : bool) + (struct_storage : rw NM.StructStorage.t) + ~(byte_ofs : int) + ~(bit_ofs : int) + (value : bool) + : unit = + let data = struct_storage.NM.StructStorage.data in + let () = set_opt_discriminant data discr in + let default_bit = Util.int_of_bool default in + let value_bit = Util.int_of_bool value in + let stored_bit = default_bit lxor value_bit in + let byte_val = NM.Slice.get_uint8 data byte_ofs in + let byte_val = byte_val land (lnot (1 lsl bit_ofs)) in + let byte_val = byte_val lor (stored_bit lsl bit_ofs) in + NM.Slice.set_uint8 data byte_ofs byte_val + + let set_int8 + ?(discr : Discr.t option) + ~(default : int) + (struct_storage : rw NM.StructStorage.t) + (byte_ofs : int) + (value : int) + : unit = + let data = struct_storage.NM.StructStorage.data in + let () = set_opt_discriminant data discr in + NM.Slice.set_int8 data byte_ofs (value lxor default) + + let set_int16 + ?(discr : Discr.t option) + ~(default : int) + (struct_storage : rw NM.StructStorage.t) + (byte_ofs : int) + (value : int) + : unit = + let data = struct_storage.NM.StructStorage.data in + let () = set_opt_discriminant data discr in + NM.Slice.set_int16 data byte_ofs (value lxor default) + + let set_int32 + ?(discr : Discr.t option) + ~(default : int32) + (struct_storage : rw NM.StructStorage.t) + (byte_ofs : int) + (value : int32) + : unit = + let data = struct_storage.NM.StructStorage.data in + let () = set_opt_discriminant data discr in + NM.Slice.set_int32 data byte_ofs (Int32.bit_xor value default) + + let set_int64 + ?(discr : Discr.t option) + ~(default : int64) + (struct_storage : rw NM.StructStorage.t) + (byte_ofs : int) + (value : int64) + : unit = + let data = struct_storage.NM.StructStorage.data in + let () = set_opt_discriminant data discr in + NM.Slice.set_int64 data byte_ofs (Int64.bit_xor value default) + + let set_uint8 + ?(discr : Discr.t option) + ~(default : int) + (struct_storage : rw NM.StructStorage.t) + (byte_ofs : int) + (value : int) + : unit = + let data = struct_storage.NM.StructStorage.data in + let () = set_opt_discriminant data discr in + NM.Slice.set_uint8 data byte_ofs (value lxor default) + + let set_uint16 + ?(discr : Discr.t option) + ~(default : int) + (struct_storage : rw NM.StructStorage.t) + (byte_ofs : int) + (value : int) + : unit = + let data = struct_storage.NM.StructStorage.data in + let () = set_opt_discriminant data discr in + NM.Slice.set_uint16 data byte_ofs (value lxor default) + + let set_uint32 + ?(discr : Discr.t option) + ~(default : Uint32.t) + (struct_storage : rw NM.StructStorage.t) + (byte_ofs : int) + (value : Uint32.t) + : unit = + let data = struct_storage.NM.StructStorage.data in + let () = set_opt_discriminant data discr in + NM.Slice.set_uint32 data byte_ofs (Uint32.logxor value default) + + let set_uint64 + ?(discr : Discr.t option) + ~(default : Uint64.t) + (struct_storage : rw NM.StructStorage.t) + (byte_ofs : int) + (value : Uint64.t) + : unit = + let data = struct_storage.NM.StructStorage.data in + let () = set_opt_discriminant data discr in + NM.Slice.set_uint64 data byte_ofs (Uint64.logxor value default) + + let set_float32 + ?(discr : Discr.t option) + ~(default_bits : int32) + (struct_storage : rw NM.StructStorage.t) + (byte_ofs : int) + (value : float) + : unit = + let data = struct_storage.NM.StructStorage.data in + let () = set_opt_discriminant data discr in + NM.Slice.set_int32 data byte_ofs + (Int32.bit_xor (Int32.bits_of_float value) default_bits) + + let set_float64 + ?(discr : Discr.t option) + ~(default_bits : int64) + (struct_storage : rw NM.StructStorage.t) + (byte_ofs : int) + (value : float) + : unit = + let data = struct_storage.NM.StructStorage.data in + let () = set_opt_discriminant data discr in + NM.Slice.set_int64 data byte_ofs + (Int64.bit_xor (Int64.bits_of_float value) default_bits) + + + (******************************************************************************* + * METHODS FOR GETTING OBJECTS STORED BY POINTER + *******************************************************************************) + + let has_field + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : bool = + let pointers = struct_storage.NM.StructStorage.pointers in + let num_pointers = pointers.NM.Slice.len / sizeof_uint64 in + (* Struct should have already been upgraded to at least the + expected data region and pointer region sizes *) + assert (pointer_word < num_pointers); + let pointer64 = NM.Slice.get_int64 pointers (pointer_word * sizeof_uint64) in + not (Util.is_int64_zero pointer64) + + let get_text + ~(default : string) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : string = + let pointers = struct_storage.NM.StructStorage.pointers in + let num_pointers = pointers.NM.Slice.len / sizeof_uint64 in + (* Struct should have already been upgraded to at least the + expected data region and pointer region sizes *) + assert (pointer_word < num_pointers); + let pointer_bytes = { + pointers with + NM.Slice.start = pointers.NM.Slice.start + (pointer_word * sizeof_uint64); + NM.Slice.len = sizeof_uint64; + } in + (* Text fields are always accessed by value, not by reference, since + we always do an immediate decode to [string]. Therefore we can + use the Reader logic to handle this case. *) + match RA_.deref_list_pointer pointer_bytes with + | Some list_storage -> + NC.string_of_uint8_list ~null_terminated:true list_storage + | None -> + default + + let get_blob + ~(default : string) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : string = + let pointers = struct_storage.NM.StructStorage.pointers in + let num_pointers = pointers.NM.Slice.len / sizeof_uint64 in + (* Struct should have already been upgraded to at least the + expected data region and pointer region sizes *) + assert (pointer_word < num_pointers); + let pointer_bytes = { + pointers with + NM.Slice.start = pointers.NM.Slice.start + (pointer_word * sizeof_uint64); + NM.Slice.len = sizeof_uint64; + } in + (* Data fields are always accessed by value, not by reference, since + we always do an immediate decode to [string]. Therefore we can + use the Reader logic to handle this case. *) + match RA_.deref_list_pointer pointer_bytes with + | Some list_storage -> + NC.string_of_uint8_list ~null_terminated:false list_storage + | None -> + default + + + (* Zero-initialize list storage of the given length and storage type, + associating it with the specified list pointer. *) + let init_list_storage + ~(storage_type : ListStorageType.t) + ~(num_elements : int) + (pointer_bytes : rw NM.Slice.t) + : rw NM.ListStorage.t = + let () = BOps.deep_zero_pointer pointer_bytes in + let message = pointer_bytes.NM.Slice.msg in + let list_storage = BOps.alloc_list_storage message storage_type num_elements in + let () = BOps.init_list_pointer pointer_bytes list_storage in + list_storage + + + let get_list + ?(struct_sizes : BuilderOps.StructSizes.t option) + ?(default : ro DM.ListStorage.t option) + ~(storage_type : ListStorageType.t) + ~(codecs : 'a NC.ListCodecs.t) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : (rw, 'a, rw NM.ListStorage.t) InnerArray.t = + let create_default message = + match default with + | Some default_storage -> + DefaultsCopier.deep_copy_list ?struct_sizes + ~src:default_storage ~dest_message:message () + | None -> + BOps.alloc_list_storage message storage_type 0 + in + let pointers = struct_storage.NM.StructStorage.pointers in + let num_pointers = pointers.NM.Slice.len / sizeof_uint64 in + (* Struct should have already been upgraded to at least the + expected data region and pointer region sizes *) + assert (pointer_word < num_pointers); + let pointer_bytes = { + pointers with + NM.Slice.start = pointers.NM.Slice.start + (pointer_word * sizeof_uint64); + NM.Slice.len = sizeof_uint64; + } in + let list_storage = BOps.deref_list_pointer ?struct_sizes ~create_default + pointer_bytes + in + NC.make_array_readwrite ~list_storage ~codecs + ~init:(fun n -> init_list_storage ~storage_type ~num_elements:n pointer_bytes) + + let get_void_list + ?(default : ro DM.ListStorage.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : (rw, unit, rw NM.ListStorage.t) InnerArray.t = + get_list ?default ~storage_type:ListStorageType.Empty + ~codecs:void_list_codecs struct_storage pointer_word + + let get_bit_list + ?(default : ro DM.ListStorage.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : (rw, bool, rw NM.ListStorage.t) InnerArray.t = + get_list ?default ~storage_type:ListStorageType.Bit + ~codecs:bit_list_codecs struct_storage pointer_word + + let get_int8_list + ?(default : ro DM.ListStorage.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : (rw, int, rw NM.ListStorage.t) InnerArray.t = + get_list ?default ~storage_type:ListStorageType.Bytes1 + ~codecs:int8_list_codecs struct_storage pointer_word + + let get_int16_list + ?(default : ro DM.ListStorage.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : (rw, int, rw NM.ListStorage.t) InnerArray.t = + get_list ?default ~storage_type:ListStorageType.Bytes2 + ~codecs:int16_list_codecs struct_storage pointer_word + + let get_int32_list + ?(default : ro DM.ListStorage.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : (rw, int32, rw NM.ListStorage.t) InnerArray.t = + get_list ?default ~storage_type:ListStorageType.Bytes4 + ~codecs:int32_list_codecs struct_storage pointer_word + + let get_int64_list + ?(default : ro DM.ListStorage.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : (rw, int64, rw NM.ListStorage.t) InnerArray.t = + get_list ?default ~storage_type:ListStorageType.Bytes8 + ~codecs:int64_list_codecs struct_storage pointer_word + + let get_uint8_list + ?(default : ro DM.ListStorage.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : (rw, int, rw NM.ListStorage.t) InnerArray.t = + get_list ?default ~storage_type:ListStorageType.Bytes1 + ~codecs:uint8_list_codecs struct_storage pointer_word + + let get_uint16_list + ?(default : ro DM.ListStorage.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : (rw, int, rw NM.ListStorage.t) InnerArray.t = + get_list ?default ~storage_type:ListStorageType.Bytes2 + ~codecs:uint16_list_codecs struct_storage pointer_word + + let get_uint32_list + ?(default : ro DM.ListStorage.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : (rw, Uint32.t, rw NM.ListStorage.t) InnerArray.t = + get_list ?default ~storage_type:ListStorageType.Bytes4 + ~codecs:uint32_list_codecs struct_storage pointer_word + + let get_uint64_list + ?(default : ro DM.ListStorage.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : (rw, Uint64.t, rw NM.ListStorage.t) InnerArray.t = + get_list ?default ~storage_type:ListStorageType.Bytes8 + ~codecs:uint64_list_codecs struct_storage pointer_word + + let get_float32_list + ?(default : ro DM.ListStorage.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : (rw, float, rw NM.ListStorage.t) InnerArray.t = + get_list ?default ~storage_type:ListStorageType.Bytes4 + ~codecs:float32_list_codecs struct_storage pointer_word + + let get_float64_list + ?(default : ro DM.ListStorage.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : (rw, float, rw NM.ListStorage.t) InnerArray.t = + get_list ?default ~storage_type:ListStorageType.Bytes8 + ~codecs:float64_list_codecs struct_storage pointer_word + + let get_text_list + ?(default : ro DM.ListStorage.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : (rw, string, rw NM.ListStorage.t) InnerArray.t = + get_list ?default ~storage_type:ListStorageType.Pointer + ~codecs:text_list_codecs struct_storage pointer_word + + let get_blob_list + ?(default : ro DM.ListStorage.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : (rw, string, rw NM.ListStorage.t) InnerArray.t = + get_list ?default ~storage_type:ListStorageType.Pointer + ~codecs:blob_list_codecs struct_storage pointer_word + + let get_struct_list + ?(default : ro DM.ListStorage.t option) + ~(data_words : int) + ~(pointer_words : int) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : (rw, rw NM.StructStorage.t, rw NM.ListStorage.t) InnerArray.t = + get_list ~struct_sizes:{ + BuilderOps.StructSizes.data_words; + BuilderOps.StructSizes.pointer_words } + ?default ~storage_type:( + ListStorageType.Composite (data_words, pointer_words)) + ~codecs:struct_list_codecs struct_storage pointer_word + + let get_struct + ?(default : ro DM.StructStorage.t option) + ~(data_words : int) + ~(pointer_words : int) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : rw NM.StructStorage.t = + let create_default message = + match default with + | Some default_storage -> + DefaultsCopier.deep_copy_struct ~src:default_storage ~dest_message:message + ~data_words ~pointer_words + | None -> + BOps.alloc_struct_storage message ~data_words ~pointer_words + in + let pointers = struct_storage.NM.StructStorage.pointers in + let num_pointers = pointers.NM.Slice.len / sizeof_uint64 in + (* Struct should have already been upgraded to at least the + expected data region and pointer region sizes *) + assert (pointer_word < num_pointers); + let pointer_bytes = { + pointers with + NM.Slice.start = pointers.NM.Slice.start + (pointer_word * sizeof_uint64); + NM.Slice.len = sizeof_uint64; + } in + BOps.deref_struct_pointer ~create_default ~data_words ~pointer_words pointer_bytes + + let get_pointer + ?(default : ro DM.Slice.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : rw NM.Slice.t = + let pointers = struct_storage.NM.StructStorage.pointers in + let num_pointers = pointers.NM.Slice.len / sizeof_uint64 in + (* Struct should have already been upgraded to at least the + expected data region and pointer region sizes *) + assert (pointer_word < num_pointers); + let pointer_bytes = { + pointers with + NM.Slice.start = pointers.NM.Slice.start + (pointer_word * sizeof_uint64); + NM.Slice.len = sizeof_uint64; + } in + let () = + let pointer_val = NM.Slice.get_int64 pointer_bytes 0 in + if Util.is_int64_zero pointer_val then + match default with + | Some default_pointer -> + DefaultsCopier.deep_copy_pointer ~src:default_pointer + ~dest:pointer_bytes + | None -> + () + else + () + in + pointer_bytes + + let get_interface + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : Uint32.t option = + let pointers = struct_storage.NM.StructStorage.pointers in + let num_pointers = pointers.NM.Slice.len / sizeof_uint64 in + (* Struct should have already been upgraded to at least the + expected data region and pointer region sizes *) + assert (pointer_word < num_pointers); + let pointer_bytes = { + pointers with + NM.Slice.start = pointers.NM.Slice.start + (pointer_word * sizeof_uint64); + NM.Slice.len = sizeof_uint64; + } in + match NC.decode_pointer pointer_bytes with + | Pointer.Null -> + None + | Pointer.Other (OtherPointer.Capability index) -> + Some index + | _ -> + invalid_msg "decoded non-capability pointer where capability was expected" + + + (******************************************************************************* + * METHODS FOR SETTING OBJECTS STORED BY POINTER + *******************************************************************************) + + let set_text + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (value : string) + : unit = + let pointers = struct_storage.NM.StructStorage.pointers in + let num_pointers = pointers.NM.Slice.len / sizeof_uint64 in + (* Struct should have already been upgraded to at least the + expected data region and pointer region sizes *) + assert (pointer_word < num_pointers); + let pointer_bytes = { + pointers with + NM.Slice.start = pointers.NM.Slice.start + (pointer_word * sizeof_uint64); + NM.Slice.len = sizeof_uint64; + } in + let () = set_opt_discriminant struct_storage.NM.StructStorage.data discr in + let new_string_storage = uint8_list_of_string + ~null_terminated:true ~dest_message:pointer_bytes.NM.Slice.msg + value + in + let () = BOps.deep_zero_pointer pointer_bytes in + BOps.init_list_pointer pointer_bytes new_string_storage + + let set_blob + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (value : string) + : unit = + let pointers = struct_storage.NM.StructStorage.pointers in + let num_pointers = pointers.NM.Slice.len / sizeof_uint64 in + (* Struct should have already been upgraded to at least the + expected data region and pointer region sizes *) + assert (pointer_word < num_pointers); + let pointer_bytes = { + pointers with + NM.Slice.start = pointers.NM.Slice.start + (pointer_word * sizeof_uint64); + NM.Slice.len = sizeof_uint64; + } in + let () = set_opt_discriminant struct_storage.NM.StructStorage.data discr in + let new_string_storage = uint8_list_of_string + ~null_terminated:false ~dest_message:pointer_bytes.NM.Slice.msg + value + in + let () = BOps.deep_zero_pointer pointer_bytes in + BOps.init_list_pointer pointer_bytes new_string_storage + + let set_list_from_storage + ?(struct_sizes : BuilderOps.StructSizes.t option) + ~(storage_type : ListStorageType.t) + ~(codecs : 'a NC.ListCodecs.t) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (value : 'cap NM.ListStorage.t option) + : (rw, 'a, rw NM.ListStorage.t) InnerArray.t = + let pointers = struct_storage.NM.StructStorage.pointers in + let num_pointers = pointers.NM.Slice.len / sizeof_uint64 in + (* Struct should have already been upgraded to at least the + expected data region and pointer region sizes *) + assert (pointer_word < num_pointers); + let pointer_bytes = { + pointers with + NM.Slice.start = pointers.NM.Slice.start + (pointer_word * sizeof_uint64); + NM.Slice.len = sizeof_uint64; + } in + let list_storage = + match value with + | Some src_storage -> + BOps.deep_copy_list ?struct_sizes + ~src:src_storage ~dest_message:pointer_bytes.NM.Slice.msg () + | None -> + BOps.alloc_list_storage pointer_bytes.NM.Slice.msg storage_type 0 + in + let () = BOps.deep_zero_pointer pointer_bytes in + let () = BOps.init_list_pointer pointer_bytes list_storage in + NC.make_array_readwrite ~list_storage ~codecs + ~init:(fun n -> init_list_storage ~storage_type ~num_elements:n pointer_bytes) + + let set_list + ?(discr : Discr.t option) + ?(struct_sizes : BuilderOps.StructSizes.t option) + ~(storage_type : ListStorageType.t) + ~(codecs : 'a NC.ListCodecs.t) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (value : ('cap1, 'a, 'cap2 NM.ListStorage.t) InnerArray.t) + : (rw, 'a, rw NM.ListStorage.t) InnerArray.t = + let () = set_opt_discriminant struct_storage.NM.StructStorage.data discr in + set_list_from_storage ?struct_sizes ~storage_type ~codecs + struct_storage pointer_word (InnerArray.to_storage value) + + let set_void_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (value : ('cap1, unit, 'cap2 NM.ListStorage.t) InnerArray.t) + : (rw, unit, rw NM.ListStorage.t) InnerArray.t = + set_list ?discr ~storage_type:ListStorageType.Empty ~codecs:void_list_codecs + struct_storage pointer_word value + + let set_bit_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (value : ('cap1, bool, 'cap2 NM.ListStorage.t) InnerArray.t) + : (rw, bool, rw NM.ListStorage.t) InnerArray.t = + set_list ?discr ~storage_type:ListStorageType.Bit ~codecs:bit_list_codecs + struct_storage pointer_word value + + let set_int8_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (value : ('cap1, int, 'cap2 NM.ListStorage.t) InnerArray.t) + : (rw, int, 'cap NM.ListStorage.t) InnerArray.t = + set_list ?discr ~storage_type:ListStorageType.Bytes1 ~codecs:int8_list_codecs + struct_storage pointer_word value + + let set_int16_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (value : ('cap1, int, 'cap2 NM.ListStorage.t) InnerArray.t) + : (rw, int, 'cap NM.ListStorage.t) InnerArray.t = + set_list ?discr ~storage_type:ListStorageType.Bytes2 ~codecs:int16_list_codecs + struct_storage pointer_word value + + let set_int32_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (value : ('cap1, int32, 'cap NM.ListStorage.t) InnerArray.t) + : (rw, int32, rw NM.ListStorage.t) InnerArray.t = + set_list ?discr ~storage_type:ListStorageType.Bytes4 ~codecs:int32_list_codecs + struct_storage pointer_word value + + let set_int64_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (value : ('cap1, int64, 'cap2 NM.ListStorage.t) InnerArray.t) + : (rw, int64, rw NM.ListStorage.t) InnerArray.t = + set_list ?discr ~storage_type:ListStorageType.Bytes8 ~codecs:int64_list_codecs + struct_storage pointer_word value + + let set_uint8_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (value : ('cap1, int, 'cap2 NM.ListStorage.t) InnerArray.t) + : (rw, int, rw NM.ListStorage.t) InnerArray.t = + set_list ?discr ~storage_type:ListStorageType.Bytes1 ~codecs:uint8_list_codecs + struct_storage pointer_word value + + let set_uint16_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (value : ('cap1, int, 'cap2 NM.ListStorage.t) InnerArray.t) + : (rw, int, rw NM.ListStorage.t) InnerArray.t = + set_list ?discr ~storage_type:ListStorageType.Bytes2 ~codecs:uint16_list_codecs + struct_storage pointer_word value + + let set_uint32_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (value : ('cap1, Uint32.t, 'cap2 NM.ListStorage.t) InnerArray.t) + : (rw, Uint32.t, rw NM.ListStorage.t) InnerArray.t = + set_list ?discr ~storage_type:ListStorageType.Bytes4 ~codecs:uint32_list_codecs + struct_storage pointer_word value + + let set_uint64_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (value : ('cap1, Uint64.t, 'cap2 NM.ListStorage.t) InnerArray.t) + : (rw, Uint64.t, rw NM.ListStorage.t) InnerArray.t = + set_list ?discr ~storage_type:ListStorageType.Bytes8 ~codecs:uint64_list_codecs + struct_storage pointer_word value + + let set_float32_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (value : ('cap1, float, 'cap2 NM.ListStorage.t) InnerArray.t) + : (rw, float, rw NM.ListStorage.t) InnerArray.t = + set_list ?discr ~storage_type:ListStorageType.Bytes4 ~codecs:float32_list_codecs + struct_storage pointer_word value + + let set_float64_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (value : ('cap1, float, 'cap2 NM.ListStorage.t) InnerArray.t) + : (rw, float, rw NM.ListStorage.t) InnerArray.t = + set_list ?discr ~storage_type:ListStorageType.Bytes8 ~codecs:float64_list_codecs + struct_storage pointer_word value + + let set_text_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (value : ('cap1, string, 'cap2 NM.ListStorage.t) InnerArray.t) + : (rw, string, rw NM.ListStorage.t) InnerArray.t = + set_list ?discr ~storage_type:ListStorageType.Pointer ~codecs:text_list_codecs + struct_storage pointer_word value + + let set_blob_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (value : ('cap1, string, 'cap2 NM.ListStorage.t) InnerArray.t) + : (rw, string, rw NM.ListStorage.t) InnerArray.t = + set_list ?discr ~storage_type:ListStorageType.Pointer ~codecs:blob_list_codecs + struct_storage pointer_word value + + let set_struct_list + ?(discr : Discr.t option) + ~(data_words : int) + ~(pointer_words : int) + (* FIXME: this won't allow assignment from Reader struct lists *) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (value : ('cap1, 'cap2 NM.StructStorage.t, 'cap2 NM.ListStorage.t) InnerArray.t) + : (rw, rw NM.StructStorage.t, rw NM.ListStorage.t) InnerArray.t = + set_list ?discr ~struct_sizes:{ + BuilderOps.StructSizes.data_words; + BuilderOps.StructSizes.pointer_words } + ~storage_type:(ListStorageType.Composite (data_words, pointer_words)) + ~codecs:struct_list_codecs struct_storage pointer_word value + + let set_struct + ?(discr : Discr.t option) + ~(data_words : int) + ~(pointer_words : int) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (value : 'cap NM.StructStorage.t option) + : rw NM.StructStorage.t = + let pointers = struct_storage.NM.StructStorage.pointers in + let num_pointers = pointers.NM.Slice.len / sizeof_uint64 in + (* Struct should have already been upgraded to at least the + expected data region and pointer region sizes *) + assert (pointer_word < num_pointers); + let pointer_bytes = { + pointers with + NM.Slice.start = pointers.NM.Slice.start + (pointer_word * sizeof_uint64); + NM.Slice.len = sizeof_uint64; + } in + let () = set_opt_discriminant struct_storage.NM.StructStorage.data discr in + let dest_storage = + match value with + | Some src_storage -> + BOps.deep_copy_struct ~src:src_storage + ~dest_message:pointer_bytes.NM.Slice.msg ~data_words ~pointer_words + | None -> + BOps.alloc_struct_storage pointer_bytes.NM.Slice.msg ~data_words ~pointer_words + in + let () = BOps.deep_zero_pointer pointer_bytes in + let () = BOps.init_struct_pointer pointer_bytes dest_storage in + dest_storage + + let set_pointer + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (value : 'cap NM.Slice.t) + : rw NM.Slice.t = + let pointers = struct_storage.NM.StructStorage.pointers in + let num_pointers = pointers.NM.Slice.len / sizeof_uint64 in + (* Struct should have already been upgraded to at least the + expected data region and pointer region sizes *) + assert (pointer_word < num_pointers); + let pointer_bytes = { + pointers with + NM.Slice.start = pointers.NM.Slice.start + (pointer_word * sizeof_uint64); + NM.Slice.len = sizeof_uint64; + } in + let () = set_opt_discriminant struct_storage.NM.StructStorage.data discr in + let () = BOps.deep_copy_pointer ~src:value ~dest:pointer_bytes in + pointer_bytes + + let set_interface + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (value : Uint32.t option) + : unit = + let pointers = struct_storage.NM.StructStorage.pointers in + let num_pointers = pointers.NM.Slice.len / sizeof_uint64 in + (* Struct should have already been upgraded to at least the + expected data region and pointer region sizes *) + assert (pointer_word < num_pointers); + let pointer_bytes = { + pointers with + NM.Slice.start = pointers.NM.Slice.start + (pointer_word * sizeof_uint64); + NM.Slice.len = sizeof_uint64; + } in + let () = set_opt_discriminant struct_storage.NM.StructStorage.data discr in + match value with + | Some index -> + NM.Slice.set_int64 pointer_bytes 0 + (OtherPointer.encode (OtherPointer.Capability index)) + | None -> + NM.Slice.set_int64 pointer_bytes 0 Int64.zero + + + (******************************************************************************* + * METHODS FOR INITIALIZING OBJECTS STORED BY POINTER + *******************************************************************************) + + let init_blob + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (num_elements : int) + : unit = + let s = String.make num_elements '\x00' in + set_blob ?discr struct_storage pointer_word s + + let init_list + ?(discr : Discr.t option) + ~(storage_type : ListStorageType.t) + ~(codecs : 'a NC.ListCodecs.t) + (struct_storage : 'cap NM.StructStorage.t) + (pointer_word : int) + (num_elements : int) + : (rw, 'a, rw NM.ListStorage.t) InnerArray.t = + let pointers = struct_storage.NM.StructStorage.pointers in + let num_pointers = pointers.NM.Slice.len / sizeof_uint64 in + (* Struct should have already been upgraded to at least the + expected data region and pointer region sizes *) + assert (pointer_word < num_pointers); + let pointer_bytes = { + pointers with + NM.Slice.start = pointers.NM.Slice.start + (pointer_word * sizeof_uint64); + NM.Slice.len = sizeof_uint64; + } in + let () = set_opt_discriminant struct_storage.NM.StructStorage.data discr in + let list_storage = init_list_storage ~storage_type ~num_elements pointer_bytes in + NC.make_array_readwrite ~list_storage ~codecs + ~init:(fun n -> init_list_storage ~storage_type ~num_elements:n pointer_bytes) + + let init_void_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (num_elements : int) + : (rw, unit, rw NM.ListStorage.t) InnerArray.t = + init_list ?discr ~storage_type:ListStorageType.Empty ~codecs:void_list_codecs + struct_storage pointer_word num_elements + + let init_bit_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (num_elements : int) + : (rw, bool, rw NM.ListStorage.t) InnerArray.t = + init_list ?discr ~storage_type:ListStorageType.Bit ~codecs:bit_list_codecs + struct_storage pointer_word num_elements + + let init_int8_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (num_elements : int) + : (rw, int, rw NM.ListStorage.t) InnerArray.t = + init_list ?discr ~storage_type:ListStorageType.Bytes1 ~codecs:int8_list_codecs + struct_storage pointer_word num_elements + + let init_int16_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (num_elements : int) + : (rw, int, rw NM.ListStorage.t) InnerArray.t = + init_list ?discr ~storage_type:ListStorageType.Bytes2 ~codecs:int16_list_codecs + struct_storage pointer_word num_elements + + let init_int32_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (num_elements : int) + : (rw, int32, rw NM.ListStorage.t) InnerArray.t = + init_list ?discr ~storage_type:ListStorageType.Bytes4 ~codecs:int32_list_codecs + struct_storage pointer_word num_elements + + let init_int64_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (num_elements : int) + : (rw, int64, rw NM.ListStorage.t) InnerArray.t = + init_list ?discr ~storage_type:ListStorageType.Bytes8 ~codecs:int64_list_codecs + struct_storage pointer_word num_elements + + let init_uint8_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (num_elements : int) + : (rw, int, rw NM.ListStorage.t) InnerArray.t = + init_list ?discr ~storage_type:ListStorageType.Bytes1 ~codecs:uint8_list_codecs + struct_storage pointer_word num_elements + + let init_uint16_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (num_elements : int) + : (rw, int, rw NM.ListStorage.t) InnerArray.t = + init_list ?discr ~storage_type:ListStorageType.Bytes2 ~codecs:uint16_list_codecs + struct_storage pointer_word num_elements + + let init_uint32_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (num_elements : int) + : (rw, Uint32.t, rw NM.ListStorage.t) InnerArray.t = + init_list ?discr ~storage_type:ListStorageType.Bytes4 ~codecs:uint32_list_codecs + struct_storage pointer_word num_elements + + let init_uint64_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (num_elements : int) + : (rw, Uint64.t, rw NM.ListStorage.t) InnerArray.t = + init_list ?discr ~storage_type:ListStorageType.Bytes8 ~codecs:uint64_list_codecs + struct_storage pointer_word num_elements + + let init_float32_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (num_elements : int) + : (rw, float, rw NM.ListStorage.t) InnerArray.t = + init_list ?discr ~storage_type:ListStorageType.Bytes4 ~codecs:float32_list_codecs + struct_storage pointer_word num_elements + + let init_float64_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (num_elements : int) + : (rw, float, rw NM.ListStorage.t) InnerArray.t = + init_list ?discr ~storage_type:ListStorageType.Bytes8 ~codecs:float64_list_codecs + struct_storage pointer_word num_elements + + let init_text_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (num_elements : int) + : (rw, string, rw NM.ListStorage.t) InnerArray.t = + init_list ?discr ~storage_type:ListStorageType.Pointer ~codecs:text_list_codecs + struct_storage pointer_word num_elements + + let init_blob_list + ?(discr : Discr.t option) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (num_elements : int) + : (rw, string, rw NM.ListStorage.t) InnerArray.t = + init_list ?discr ~storage_type:ListStorageType.Pointer ~codecs:blob_list_codecs + struct_storage pointer_word num_elements + + let init_struct_list + ?(discr : Discr.t option) + ~(data_words : int) + ~(pointer_words : int) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + (num_elements : int) + : (rw, rw NM.StructStorage.t, rw NM.ListStorage.t) InnerArray.t = + init_list ?discr ~storage_type:( + ListStorageType.Composite (data_words, pointer_words)) + struct_storage pointer_word ~codecs:struct_list_codecs num_elements + + let init_struct + ?(discr : Discr.t option) + ~(data_words : int) + ~(pointer_words : int) + (struct_storage : rw NM.StructStorage.t) + (pointer_word : int) + : rw NM.StructStorage.t = + let pointers = struct_storage.NM.StructStorage.pointers in + let num_pointers = pointers.NM.Slice.len / sizeof_uint64 in + (* Struct should have already been upgraded to at least the + expected data region and pointer region sizes *) + assert (pointer_word < num_pointers); + let pointer_bytes = { + pointers with + NM.Slice.start = pointers.NM.Slice.start + (pointer_word * sizeof_uint64); + NM.Slice.len = sizeof_uint64; + } in + let () = set_opt_discriminant struct_storage.NM.StructStorage.data discr in + let () = BOps.deep_zero_pointer pointer_bytes in + let storage = + BOps.alloc_struct_storage pointer_bytes.NM.Slice.msg ~data_words ~pointer_words + in + let () = BOps.init_struct_pointer pointer_bytes storage in + storage + + (* Locate the storage region corresponding to the root struct of a message. + The [data_words] and [pointer_words] specify the expected struct layout. *) + let get_root_struct + (m : rw NM.Message.t) + ~(data_words : int) + ~(pointer_words : int) + : rw NM.StructStorage.t = + let first_segment = NM.Message.get_segment m 0 in + if NM.Segment.length first_segment < sizeof_uint64 then + invalid_msg "message is too small to contain root struct pointer" + else + let pointer_bytes = { + NM.Slice.msg = m; + NM.Slice.segment = first_segment; + NM.Slice.segment_id = 0; + NM.Slice.start = 0; + NM.Slice.len = sizeof_uint64 + } in + let create_default message = + BOps.alloc_struct_storage message ~data_words ~pointer_words + in + BOps.deref_struct_pointer ~create_default ~data_words ~pointer_words + pointer_bytes + + + (* Allocate a new message of at least the given [message_size], creating a + root struct with the specified struct layout. + Returns: newly-allocated root struct storage *) + let alloc_root_struct + ?(message_size : int option) + ~(data_words : int) + ~(pointer_words : int) + () + : rw NM.StructStorage.t = + let act_message_size = + let requested_size = + match message_size with + | Some x -> x + | None -> 8192 + in + max requested_size ((data_words + pointer_words + 1) * sizeof_uint64) + in + let message = NM.Message.create act_message_size in + (* Has the important side effect of reserving space in the message for + the root struct pointer... *) + let _ = NM.Slice.alloc message sizeof_uint64 in + get_root_struct message ~data_words ~pointer_words + + end + + type 'cap message_t = 'cap MessageWrapper.Message.t + + type reader_t_Request_14112192289179464829 = ro MessageWrapper.StructStorage.t option + type builder_t_Request_14112192289179464829 = rw MessageWrapper.StructStorage.t + type reader_t_Response_16897334327181152309 = ro MessageWrapper.StructStorage.t option + type builder_t_Response_16897334327181152309 = rw MessageWrapper.StructStorage.t + + module DefaultsCopier_ = + Capnp.Runtime.BuilderOps.Make(Capnp.BytesMessage)(MessageWrapper) + + let _reader_defaults_message = + MessageWrapper.Message.create + (DefaultsMessage_.Message.total_size _builder_defaults_message) + + + module Reader = struct + type array_t = ro MessageWrapper.ListStorage.t + type builder_array_t = rw MessageWrapper.ListStorage.t + type pointer_t = ro MessageWrapper.Slice.t option + + module Response = struct + type t = reader_t_Response_16897334327181152309 + type builder_t = builder_t_Response_16897334327181152309 + let has_ok x = + RA_.has_field x 0 + let ok_get x = + RA_.get_blob ~default:"" x 0 + let has_error x = + RA_.has_field x 0 + let error_get x = + RA_.get_blob ~default:"" x 0 + type unnamed_union_t = + | Ok of string + | Error of string + | Undefined of int + let get x = + match RA_.get_uint16 ~default:0 x 4 with + | 0 -> Ok (ok_get x) + | 1 -> Error (error_get x) + | v -> Undefined v + let id_get x = + RA_.get_int32 ~default:(0l) x 0 + let id_get_int_exn x = + Capnp.Runtime.Util.int_of_int32_exn (id_get x) + let of_message x = RA_.get_root_struct (RA_.Message.readonly x) + let of_builder x = Some (RA_.StructStorage.readonly x) + end + module Request = struct + type t = reader_t_Request_14112192289179464829 + type builder_t = builder_t_Request_14112192289179464829 + let has_write x = + RA_.has_field x 1 + let write_get x = + RA_.get_blob ~default:"" x 1 + let read_get x = () + let delete_get x = () + type unnamed_union_t = + | Write of string + | Read + | Delete + | Undefined of int + let get x = + match RA_.get_uint16 ~default:0 x 4 with + | 0 -> Write (write_get x) + | 1 -> Read + | 2 -> Delete + | v -> Undefined v + let id_get x = + RA_.get_int32 ~default:(0l) x 0 + let id_get_int_exn x = + Capnp.Runtime.Util.int_of_int32_exn (id_get x) + let has_path x = + (RA_.has_field x 0) + let path_get x = + RA_.get_text_list x 0 + let path_get_list x = + Capnp.Array.to_list (path_get x) + let path_get_array x = + Capnp.Array.to_array (path_get x) + let of_message x = RA_.get_root_struct (RA_.Message.readonly x) + let of_builder x = Some (RA_.StructStorage.readonly x) + end + end + + module Builder = struct + type array_t = Reader.builder_array_t + type reader_array_t = Reader.array_t + type pointer_t = rw MessageWrapper.Slice.t + + module Response = struct + type t = builder_t_Response_16897334327181152309 + type reader_t = reader_t_Response_16897334327181152309 + let has_ok x = + BA_.has_field x 0 + let ok_get x = + BA_.get_blob ~default:"" x 0 + let ok_set x v = + BA_.set_blob ~discr:{BA_.Discr.value=0; BA_.Discr.byte_ofs=4} x 0 v + let has_error x = + BA_.has_field x 0 + let error_get x = + BA_.get_blob ~default:"" x 0 + let error_set x v = + BA_.set_blob ~discr:{BA_.Discr.value=1; BA_.Discr.byte_ofs=4} x 0 v + type unnamed_union_t = + | Ok of string + | Error of string + | Undefined of int + let get x = + match BA_.get_uint16 ~default:0 x 4 with + | 0 -> Ok (ok_get x) + | 1 -> Error (error_get x) + | v -> Undefined v + let id_get x = + BA_.get_int32 ~default:(0l) x 0 + let id_get_int_exn x = + Capnp.Runtime.Util.int_of_int32_exn (id_get x) + let id_set x v = + BA_.set_int32 ~default:(0l) x 0 v + let id_set_int_exn x v = id_set x (Capnp.Runtime.Util.int32_of_int_exn v) + let of_message x = BA_.get_root_struct ~data_words:1 ~pointer_words:1 x + let to_message x = x.BA_.NM.StructStorage.data.MessageWrapper.Slice.msg + let to_reader x = Some (RA_.StructStorage.readonly x) + let init_root ?message_size () = + BA_.alloc_root_struct ?message_size ~data_words:1 ~pointer_words:1 () + end + module Request = struct + type t = builder_t_Request_14112192289179464829 + type reader_t = reader_t_Request_14112192289179464829 + let has_write x = + BA_.has_field x 1 + let write_get x = + BA_.get_blob ~default:"" x 1 + let write_set x v = + BA_.set_blob ~discr:{BA_.Discr.value=0; BA_.Discr.byte_ofs=4} x 1 v + let read_get x = () + let read_set x = + BA_.set_void ~discr:{BA_.Discr.value=1; BA_.Discr.byte_ofs=4} x + let delete_get x = () + let delete_set x = + BA_.set_void ~discr:{BA_.Discr.value=2; BA_.Discr.byte_ofs=4} x + type unnamed_union_t = + | Write of string + | Read + | Delete + | Undefined of int + let get x = + match BA_.get_uint16 ~default:0 x 4 with + | 0 -> Write (write_get x) + | 1 -> Read + | 2 -> Delete + | v -> Undefined v + let id_get x = + BA_.get_int32 ~default:(0l) x 0 + let id_get_int_exn x = + Capnp.Runtime.Util.int_of_int32_exn (id_get x) + let id_set x v = + BA_.set_int32 ~default:(0l) x 0 v + let id_set_int_exn x v = id_set x (Capnp.Runtime.Util.int32_of_int_exn v) + let has_path x = + (BA_.has_field x 0) + let path_get x = + BA_.get_text_list x 0 + let path_get_list x = + Capnp.Array.to_list (path_get x) + let path_get_array x = + Capnp.Array.to_array (path_get x) + let path_set x v = + BA_.set_text_list x 0 v + let path_init x n = + BA_.init_text_list x 0 n + let path_set_list x v = + let builder = path_init x (List.length v) in + let () = List.iteri (fun i a -> Capnp.Array.set builder i a) v in + builder + let path_set_array x v = + let builder = path_init x (Array.length v) in + let () = Array.iteri (fun i a -> Capnp.Array.set builder i a) v in + builder + let of_message x = BA_.get_root_struct ~data_words:1 ~pointer_words:2 x + let to_message x = x.BA_.NM.StructStorage.data.MessageWrapper.Slice.msg + let to_reader x = Some (RA_.StructStorage.readonly x) + let init_root ?message_size () = + BA_.alloc_root_struct ?message_size ~data_words:1 ~pointer_words:2 () + end + end +end diff --git a/projects/miragesdk/src/sdk/proto.mli b/projects/miragesdk/src/sdk/proto.mli new file mode 100644 index 000000000..ac8c0ac99 --- /dev/null +++ b/projects/miragesdk/src/sdk/proto.mli @@ -0,0 +1,109 @@ +type ro = Capnp.Message.ro +type rw = Capnp.Message.rw + +module type S = sig + type 'cap message_t + + type reader_t_Request_14112192289179464829 + type builder_t_Request_14112192289179464829 + type reader_t_Response_16897334327181152309 + type builder_t_Response_16897334327181152309 + + module Reader : sig + type array_t + type builder_array_t + type pointer_t + module Response : sig + type t = reader_t_Response_16897334327181152309 + type builder_t = builder_t_Response_16897334327181152309 + type unnamed_union_t = + | Ok of string + | Error of string + | Undefined of int + val get : t -> unnamed_union_t + val id_get : t -> int32 + val id_get_int_exn : t -> int + val of_message : 'cap message_t -> t + val of_builder : builder_t -> t + end + module Request : sig + type t = reader_t_Request_14112192289179464829 + type builder_t = builder_t_Request_14112192289179464829 + type unnamed_union_t = + | Write of string + | Read + | Delete + | Undefined of int + val get : t -> unnamed_union_t + val id_get : t -> int32 + val id_get_int_exn : t -> int + val has_path : t -> bool + val path_get : t -> (ro, string, array_t) Capnp.Array.t + val path_get_list : t -> string list + val path_get_array : t -> string array + val of_message : 'cap message_t -> t + val of_builder : builder_t -> t + end + end + + module Builder : sig + type array_t = Reader.builder_array_t + type reader_array_t = Reader.array_t + type pointer_t + module Response : sig + type t = builder_t_Response_16897334327181152309 + type reader_t = reader_t_Response_16897334327181152309 + type unnamed_union_t = + | Ok of string + | Error of string + | Undefined of int + val get : t -> unnamed_union_t + val ok_set : t -> string -> unit + val error_set : t -> string -> unit + val id_get : t -> int32 + val id_get_int_exn : t -> int + val id_set : t -> int32 -> unit + val id_set_int_exn : t -> int -> unit + val of_message : rw message_t -> t + val to_message : t -> rw message_t + val to_reader : t -> reader_t + val init_root : ?message_size:int -> unit -> t + end + module Request : sig + type t = builder_t_Request_14112192289179464829 + type reader_t = reader_t_Request_14112192289179464829 + type unnamed_union_t = + | Write of string + | Read + | Delete + | Undefined of int + val get : t -> unnamed_union_t + val write_set : t -> string -> unit + val read_set : t -> unit + val delete_set : t -> unit + val id_get : t -> int32 + val id_get_int_exn : t -> int + val id_set : t -> int32 -> unit + val id_set_int_exn : t -> int -> unit + val has_path : t -> bool + val path_get : t -> (rw, string, array_t) Capnp.Array.t + val path_get_list : t -> string list + val path_get_array : t -> string array + val path_set : t -> (rw, string, array_t) Capnp.Array.t -> (rw, string, array_t) Capnp.Array.t + val path_set_list : t -> string list -> (rw, string, array_t) Capnp.Array.t + val path_set_array : t -> string array -> (rw, string, array_t) Capnp.Array.t + val path_init : t -> int -> (rw, string, array_t) Capnp.Array.t + val of_message : rw message_t -> t + val to_message : t -> rw message_t + val to_reader : t -> reader_t + val init_root : ?message_size:int -> unit -> t + end + end +end + +module Make (MessageWrapper : Capnp.MessageSig.S) : + (S with type 'cap message_t = 'cap MessageWrapper.Message.t + and type Reader.pointer_t = ro MessageWrapper.Slice.t option + and type Builder.pointer_t = rw MessageWrapper.Slice.t +) +