diff --git a/projects/miragesdk/examples/mirage-dhcp.yml b/projects/miragesdk/examples/mirage-dhcp.yml index 9a717a187..dd57907a0 100644 --- a/projects/miragesdk/examples/mirage-dhcp.yml +++ b/projects/miragesdk/examples/mirage-dhcp.yml @@ -2,10 +2,13 @@ kernel: image: "mobylinux/kernel:4.9.x" cmdline: "console=ttyS0 page_poison=1" init: - - "mobylinux/init:9d755f7e7d108d523448e4a503f1613b7d870389@sha256:9ccb16f2d8b3a09d12f5459106763f1836c064e420a13360e2e25599337960dc" + - mobylinux/init:286e9864b12beaff71b06809b6f0d832b6408eb5 # base init + strace + git + - mobylinux/runc:b0fb122e10dbb7e4e45115177a61a3f8d68c19a9 + - mobylinux/containerd:18eaf72f3f4f9a9f29ca1951f66df701f873060b + - mobylinux/ca-certificates:eabc5a6e59f05aa91529d80e9a595b85b046f935 onboot: - name: sysctl - image: "mobylinux/sysctl:2cf2f9d5b4d314ba1bfc22b2fe931924af666d8c" + image: mobylinux/sysctl:2cf2f9d5b4d314ba1bfc22b2fe931924af666d8c net: host pid: host ipc: host @@ -13,19 +16,19 @@ onboot: - CAP_SYS_ADMIN readonly: true - name: binfmt - image: "mobylinux/binfmt:bdb754f25a5d851b4f5f8d185a43dfcbb3c22d01" + image: mobylinux/binfmt:bdb754f25a5d851b4f5f8d185a43dfcbb3c22d01 binds: - /proc/sys/fs/binfmt_misc:/binfmt_misc readonly: true services: - name: rngd - image: "mobylinux/rngd:3dad6dd43270fa632ac031e99d1947f20b22eec9@sha256:1c93c1db7196f6f71f8e300bc1d15f0376dd18e8891c8789d77c8ff19f3a9a92" + image: mobylinux/rngd:3dad6dd43270fa632ac031e99d1947f20b22eec9 capabilities: - CAP_SYS_ADMIN oomScoreAdj: -800 readonly: true - name: dhcp-client - image: "mobylinux/dhcp-client:9e7009ae469ddd4d37f9cffaad2cf612114a3fb0@sha256:4421e05a0082b56c4ef83ca652e1da1a5af3a24e5baec61e7ba5b981f3b94a09" + image: mobylinux/dhcp-client:882ad65d1ef89a9a307b019c61f5f69301f59214 net: host capabilities: - CAP_NET_ADMIN # to bring eth0 up diff --git a/projects/miragesdk/pkg/init/Makefile b/projects/miragesdk/pkg/init/Makefile index d5cf7127a..8b5f30eef 100644 --- a/projects/miragesdk/pkg/init/Makefile +++ b/projects/miragesdk/pkg/init/Makefile @@ -1,22 +1,8 @@ -CONTAINERD_IMAGE=mobylinux/containerd:a688df6aee1e3700eb8d54dbc81070361df397a2@sha256:59ee3da05fe4dad4fbecff582c86fc30ce75e19a225eeeb07e203c9cc36fe34f -CONTAINERD_BINARIES=usr/bin/containerd usr/bin/containerd-shim usr/bin/ctr usr/bin/dist - -RUNC_IMAGE=mobylinux/runc:f225fb93dc3e6dda1cc9004962893015b29dc2d6@sha256:e75c4b274236bd3ad9f4db0a91a6f2174c8c77009c361ab5dd7a4169406675bc -RUNC_BINARY=usr/bin/runc - C_COMPILE=mobylinux/c-compile:81a6bd8ff45d769b60a2ee1acdaccda11ab835c8@sha256:eac250997a3b9784d3285a03c0c8311d4ca6fb63dc75164c987411ba93006487 START_STOP_DAEMON=sbin/start-stop-daemon default: push -$(RUNC_BINARY): Makefile - mkdir -p $(dir $@) - docker run --rm --net=none $(RUNC_IMAGE) tar cf - $@ | tar xf - - -$(CONTAINERD_BINARIES): Makefile - mkdir -p $(dir $@) - docker run --rm --net=none $(CONTAINERD_IMAGE) tar cf - $@ | tar xf - - $(START_STOP_DAEMON): start-stop-daemon.c mkdir -p $(dir $@) tar cf - $^ | docker run --rm --net=none --log-driver=none -i $(C_COMPILE) -o $@ | tar xf - @@ -28,7 +14,7 @@ IMAGE=init ETC=$(shell find etc -type f) -hash: Dockerfile $(ETC) init $(RUNC_BINARY) $(CONTAINERD_BINARIES) $(START_STOP_DAEMON) +hash: Dockerfile $(ETC) init $(START_STOP_DAEMON) DOCKER_CONTENT_TRUST=1 docker pull $(BASE) tar cf - $^ | docker build --no-cache -t $(IMAGE):build - docker run --rm $(IMAGE):build sh -c 'cat $^ /lib/apk/db/installed | sha1sum' | sed 's/ .*//' > $@ diff --git a/projects/miragesdk/src/Dockerfile.build b/projects/miragesdk/src/Dockerfile.build index 8b8a38015..2fd882440 100644 --- a/projects/miragesdk/src/Dockerfile.build +++ b/projects/miragesdk/src/Dockerfile.build @@ -1,12 +1,14 @@ FROM ocaml/opam:alpine-3.5_ocaml-4.04.0 -RUN git -C /home/opam/opam-repository pull origin master && opam update -u +RUN cd /home/opam/opam-repository && git pull && opam update -u -RUN opam info mirage-net-fd +# to be able to use cstruct.ppx + jbuilder +RUN opam pin add cstruct 2.4.0 -n +# to bring eth0 up +RUN opam pin add tuntap 1.0.0 -n +RUN opam pin add mirage-net-fd --dev -n RUN opam depext -iy mirage-net-unix logs-syslog irmin-unix cohttp decompress -RUN opam depext -iy rawlink tuntap.1.0.0 jbuilder irmin-watcher inotify -RUN opam install rresult -RUN opam pin add tuntap 1.0.0 +RUN opam depext -iy rawlink tuntap jbuilder irmin-watcher inotify rresult # TMP: to compile the calf RUN opam pin add -n charrua-client https://github.com/yomimono/charrua-client.git#state-halfway @@ -22,6 +24,8 @@ RUN sudo chown opam -R /src USER opam WORKDIR /src +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 diff --git a/projects/miragesdk/src/Dockerfile.dev b/projects/miragesdk/src/Dockerfile.dev index c237b7ad0..8e55e5084 100644 --- a/projects/miragesdk/src/Dockerfile.dev +++ b/projects/miragesdk/src/Dockerfile.dev @@ -1,23 +1,26 @@ -FROM mobylinux/mirage-compile:4e4686b60909d88a75f3f24c0429d0a8e415faa3 +FROM ocaml/opam:alpine-3.5_ocaml-4.04.0 RUN cd /home/opam/opam-repository && git pull && opam update -u -RUN opam pin -n add conduit https://github.com/samoht/ocaml-conduit.git#fd -RUN opam pin -n add mirage-net-unix https://github.com/samoht/mirage-net-unix.git#fd +# to be able to use cstruct.ppx + jbuilder +RUN opam pin add cstruct 2.4.0 -n +# to bring eth0 up +RUN opam pin add tuntap 1.0.0 -n +RUN opam pin add mirage-net-fd --dev -n -RUN opam depext -iy mirage-net-unix logs-syslog cohttp decompress -RUN opam depext -iy rawlink tuntap.1.0.0 jbuilder +RUN opam depext -iy mirage-net-unix logs-syslog irmin-unix cohttp decompress +RUN opam depext -iy rawlink tuntap jbuilder irmin-watcher inotify rresult -RUN opam pin add tuntap 1.0.0 +# 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 sudo mkdir -p /src /bin - -COPY calf /src/calf -RUN sudo chown opam -R /src -RUN cd /src/calf && opam config exec -- mirage configure && make depend - COPY . /src COPY init-dev.sh /home/opam/init-dev.sh USER opam WORKDIR /src + ENTRYPOINT ["/bin/sh", "/home/opam/init-dev.sh"] diff --git a/projects/miragesdk/src/dhcp-client/calf/unikernel.ml b/projects/miragesdk/src/dhcp-client/calf/unikernel.ml index b023a2970..49fa75bae 100644 --- a/projects/miragesdk/src/dhcp-client/calf/unikernel.ml +++ b/projects/miragesdk/src/dhcp-client/calf/unikernel.ml @@ -178,15 +178,22 @@ module Dhcp_client = Dhcp_client_mirage.Make(Time)(Net) 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 (`Msg e) -> failf "error while writing %s: %s" k e + | Ok () -> Lwt.return_unit + | Error e -> failf "error while writing %s: %a" 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 + | 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 + let start () dhcp_codes net ctl = - Netif_fd.connect net >>= fun net -> + get_mac ctl >>= fun mac -> + Netif_fd.connect ?mac net >>= fun net -> let requests = match dhcp_codes with | [] -> default_options | l -> diff --git a/projects/miragesdk/src/dhcp-client/main.ml b/projects/miragesdk/src/dhcp-client/main.ml index 860fd4100..717da27b2 100644 --- a/projects/miragesdk/src/dhcp-client/main.ml +++ b/projects/miragesdk/src/dhcp-client/main.ml @@ -5,15 +5,6 @@ open Astring let src = Logs.Src.create "dhcp-client" ~doc:"DHCP client" module Log = (val Logs.src_log src : Logs.LOG) -let failf fmt = Fmt.kstrf Lwt.fail_with fmt - -let run fmt = - Fmt.kstrf (fun str -> - match Sys.command str with - | 0 -> Lwt.return () - | i -> Fmt.kstrf Lwt.fail_with "%S exited with code %d" str i - ) fmt - module Handlers = struct (* System handlers *) @@ -23,27 +14,27 @@ module Handlers = struct | `Updated (_, (_, `Contents (v, _))) -> Some v | _ -> None + let with_ip str f = + match Ipaddr.V4.of_string (String.trim str) with + | Some ip -> + Log.info (fun l -> l "SET IP to %a" Ipaddr.V4.pp_hum ip); + f ip + | None -> + Log.err (fun l -> l "%s is not a valid IP" str); + Lwt.return_unit + let ip ~ethif t = Ctl.KV.watch_key t ["ip"] (fun diff -> match contents_of_diff diff with | None -> Lwt.return_unit - | Some ip -> - let ip = String.trim ip in - Log.info (fun l -> l "SET IP to %s" ip); - (* FIXME: use language bindings to netlink instead *) - run "ifconfig %s %s netmask 255.255.255.0" ethif ip - (* run "ip addr add %s/24 dev %s" ip ethif *) + | Some ip -> with_ip ip (fun ip -> Net.set_ip ethif ip) ) let gateway t = Ctl.KV.watch_key t ["gateway"] (fun diff -> match contents_of_diff diff with | None -> Lwt.return_unit - | Some gw -> - let gw = String.trim gw in - Log.info (fun l -> l "SET GATEWAY to %s" gw); - (* FIXME: use language bindings to netlink instead *) - run "ip route add default via %s" gw + | Some gw -> with_ip gw (fun gw -> Net.set_gateway gw) ) let handlers ~ethif = [ @@ -52,7 +43,7 @@ module Handlers = struct ] let watch ~ethif db = - Lwt_list.map_p (fun f -> f db) (handlers ethif) >>= fun _ -> + Lwt_list.map_p (fun f -> f db) (handlers ~ethif) >>= fun _ -> let t, _ = Lwt.task () in t @@ -80,24 +71,30 @@ let read_cmd file = else failwith ("Cannot read " ^ file) - let run () cmd ethif path = +let infof fmt = + Fmt.kstrf (fun msg () -> + let date = Int64.of_float (Unix.gettimeofday ()) in + Irmin.Info.v ~date ~author:"priv" msg + ) fmt + +let run () cmd ethif path = let cmd = match cmd with | None -> default_cmd | Some f -> read_cmd f in Lwt_main.run ( let routes = [ - "/ip"; - "/gateway"; - "/domain"; - "/search"; - "/mtu"; - "/nameservers/*" + "/ip" , [`Write]; + "/mac" , [`Read ]; + "/gateway", [`Write]; ] in Ctl.v path >>= fun db -> let ctl fd = Ctl.Server.listen ~routes db fd in let handlers () = Handlers.watch ~ethif db in let net = Init.rawlink ~filter:(dhcp_filter ()) ethif in + Net.mac ethif >>= fun mac -> + let mac = Macaddr.to_string mac ^ "\n" in + Ctl.KV.set db ~info:(infof "Add mac") ["mac"] mac >>= fun () -> Init.run t ~net ~ctl ~handlers cmd ) diff --git a/projects/miragesdk/src/sdk/IO.ml b/projects/miragesdk/src/sdk/IO.ml index 4e8a2d023..13790e6d7 100644 --- a/projects/miragesdk/src/sdk/IO.ml +++ b/projects/miragesdk/src/sdk/IO.ml @@ -35,7 +35,7 @@ let pp ppf (Flow (name, _, _)) = Fmt.string ppf name type t = flow -let forward ~src ~dst = +let forward ?(verbose=false) ~src ~dst = let rec loop () = read src >>= function | Ok `Eof -> @@ -45,8 +45,12 @@ let forward ~src ~dst = Log.err (fun l -> l "forward[%a => %a] %a" pp src pp dst pp_error e); Lwt.return_unit | Ok (`Data buf) -> - Log.debug (fun l -> l "forward[%a => %a] %a" - pp src pp dst Cstruct.hexdump_pp buf); + Log.debug (fun l -> + let payload = + if verbose then Fmt.strf "[%S]" @@ Cstruct.to_string buf + else Fmt.strf "%d bytes" (Cstruct.len buf) + in + l "forward[%a => %a] %s" pp src pp dst payload); write dst buf >>= function | Ok () -> loop () | Error e -> @@ -56,8 +60,8 @@ let forward ~src ~dst = in loop () -let proxy f1 f2 = +let proxy ?verbose f1 f2 = Lwt.join [ - forward ~src:f1 ~dst:f2; - forward ~src:f2 ~dst:f1; + forward ?verbose ~src:f1 ~dst:f2; + forward ?verbose ~src:f2 ~dst:f1; ] diff --git a/projects/miragesdk/src/sdk/IO.mli b/projects/miragesdk/src/sdk/IO.mli index 2883e34d2..fa1e0450d 100644 --- a/projects/miragesdk/src/sdk/IO.mli +++ b/projects/miragesdk/src/sdk/IO.mli @@ -12,10 +12,14 @@ val create: (module Mirage_flow_lwt.S with type flow = 'a) -> 'a -> string -> fl val pp: flow Fmt.t (** [pp] is the pretty-printer for IO flows. *) -val forward: src:t -> dst:t -> unit Lwt.t -(** [forward ~src ~dst] forwards writes from [src] to [dst]. Block - until either [src] or [dst] is closed. *) +val forward: ?verbose:bool -> src:t -> dst:t -> unit Lwt.t +(** [forward ?verbose ~src ~dst] forwards writes from [src] to + [dst]. Block until either [src] or [dst] is closed. If [verbose] + is set (by default it is not), show the raw flow in debug mode, + otherwise just show the lenght. *) -val proxy: t -> t -> unit Lwt.t -(** [proxy x y] is the same as [forward x y <*> forward y x]. Block - until both flows are closed. *) +val proxy: ?verbose:bool -> t -> t -> unit Lwt.t +(** [proxy ?verbose x y] is the same as [forward x y <*> forward y + x]. Block until both flows are closed. If [verbose] is set (by + default it is not), show the raw flow in debug mode, otherwise + just show the lenght. *) diff --git a/projects/miragesdk/src/sdk/ctl.ml b/projects/miragesdk/src/sdk/ctl.ml index 909ae8be0..bb911df4d 100644 --- a/projects/miragesdk/src/sdk/ctl.ml +++ b/projects/miragesdk/src/sdk/ctl.ml @@ -257,6 +257,9 @@ module Client = struct let version = 0l + type error = [`Msg of string] + let pp_error ppf (`Msg s) = Fmt.string ppf s + module K = struct type t = int32 let equal = Int32.equal @@ -327,6 +330,8 @@ end module Server = struct + type op = [ `Read | `Write | `Delete ] + let ok q payload = { Reply.id = q.Query.id; status = Reply.Ok; payload } @@ -345,21 +350,29 @@ module Server = struct Irmin.Info.v ~date ~author:"calf" msg ) fmt - let dispatch db q = + 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); + 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 -> + | Write when can `Write -> let info = infof "Updating %a" KV.Key.pp key in KV.set db ~info key q.payload >|= fun () -> ok q "" - | Delete -> + | Delete when can `Delete -> let info = infof "Removing %a" KV.Key.pp key in KV.remove db ~info key >|= fun () -> ok q "" - | Read -> - KV.find db key >|= function + | Read when can `Read -> + (KV.find db key >|= function | None -> error q err_not_found - | Some v -> ok q v + | Some v -> ok q v) + | _ -> Lwt.return (not_allowed q) ) let listen ~routes db fd = @@ -381,13 +394,12 @@ module Server = struct Lwt_condition.wait cond >>= fun () -> let q = Queue.pop queries in let path = q.Query.path in - (if List.mem path routes then ( - dispatch db q >>= fun r -> + (if List.mem_assoc path routes then ( + let op = List.assoc path routes in + dispatch db op q >>= fun r -> Reply.write fd r ) else ( - let err = Fmt.strf "%s is not an allowed path" path in - Log.err (fun l -> l "%ld: %s" q.Query.id path); - Reply.write fd (error q err) + Reply.write fd (not_allowed q) )) >>= fun () -> process () in diff --git a/projects/miragesdk/src/sdk/ctl.mli b/projects/miragesdk/src/sdk/ctl.mli index 6974e211a..92f80dcd5 100644 --- a/projects/miragesdk/src/sdk/ctl.mli +++ b/projects/miragesdk/src/sdk/ctl.mli @@ -92,21 +92,27 @@ module Client: sig type t (** The type for client state. *) + type error + (** The type for client errors. *) + + val pp_error: error Fmt.t + (** [pp_error] is the pretty-printer for client errors. *) + val v: IO.t -> t (** [v fd] is the client state using [fd] to send requests to the server. A client state also stores some state for all the incomplete client queries. *) - val read: t -> string -> (string option, [`Msg of string]) result Lwt.t + val read: t -> string -> (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, [`Msg of string]) result Lwt.t + val write: t -> string -> 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, [`Msg of string]) result Lwt.t + val delete: t -> string -> (unit, error) result Lwt.t (** [delete t k] remove [k]'s binding in the control plane state. *) end @@ -120,7 +126,10 @@ val v: string -> KV.t Lwt.t module Server: sig - val listen: routes:string list -> KV.t -> IO.t -> unit Lwt.t + 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 (** [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/init.ml b/projects/miragesdk/src/sdk/init.ml index 1ef40cb05..d0590cd28 100644 --- a/projects/miragesdk/src/sdk/init.ml +++ b/projects/miragesdk/src/sdk/init.ml @@ -291,11 +291,11 @@ let exec_and_forward ?(handlers=block_for_ever) ~pid ~cmd ~net ~ctl t = Lwt.pick ([ wait (); (* data *) - IO.proxy net priv_net; + IO.proxy ~verbose:true net priv_net; (* redirect the calf stdout to the shim stdout *) - IO.forward ~src:priv_stdout ~dst:Fd.(flow stdout); - IO.forward ~src:priv_stderr ~dst:Fd.(flow stderr); + IO.forward ~verbose:false ~src:priv_stdout ~dst:Fd.(flow stdout); + IO.forward ~verbose:false ~src:priv_stderr ~dst:Fd.(flow stderr); (* TODO: Init.Fd.forward ~src:Init.Pipe.(priv metrics) ~dst:Init.Fd.metric; *) ctl priv_ctl; diff --git a/projects/miragesdk/src/sdk/jbuild b/projects/miragesdk/src/sdk/jbuild index 12c0bce23..8fb46a101 100644 --- a/projects/miragesdk/src/sdk/jbuild +++ b/projects/miragesdk/src/sdk/jbuild @@ -5,6 +5,6 @@ (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)) + mirage-channel-lwt io-page.unix ipaddr)) (preprocess (per_file ((pps (cstruct.ppx)) (ctl)))) )) diff --git a/projects/miragesdk/src/sdk/net.ml b/projects/miragesdk/src/sdk/net.ml new file mode 100644 index 000000000..d093888f5 --- /dev/null +++ b/projects/miragesdk/src/sdk/net.ml @@ -0,0 +1,28 @@ +(* This file is a big hack and should be replaced ASAP with proper bindings *) + +open Lwt.Infix + +let run fmt = + Fmt.kstrf (fun str -> + match Sys.command str with + | 0 -> Lwt.return () + | i -> Fmt.kstrf Lwt.fail_with "%S exited with code %d" str i + ) fmt + +let read fmt = + Fmt.kstrf (fun str -> + Lwt_process.pread ("/bin/sh", [|"/bin/sh"; "-c"; str|]) + ) fmt + +let mac ethif = + read "ifconfig -a %s | grep -o -E '([[:xdigit:]]{1,2}:){5}[[:xdigit:]]{1,2}'" + ethif >|= fun mac -> + Macaddr.of_string_exn (String.trim mac) + +let set_ip ethif ip = + (* FIXME: use language bindings to netlink instead *) + (* run "ip addr add %s/24 dev %s" ip ethif *) + run "ifconfig %s %a netmask 255.255.255.0" ethif Ipaddr.V4.pp_hum ip + +let set_gateway gw = + run "ip route add default via %a" Ipaddr.V4.pp_hum gw diff --git a/projects/miragesdk/src/sdk/net.mli b/projects/miragesdk/src/sdk/net.mli new file mode 100644 index 000000000..58ebdffe4 --- /dev/null +++ b/projects/miragesdk/src/sdk/net.mli @@ -0,0 +1,10 @@ +(** [Net] exposes low-level system functions related to network. *) + +val mac: string -> Macaddr.t Lwt.t +(** [mac e] is the MAC address of the interface [e]. *) + +val set_ip: string -> Ipaddr.V4.t -> unit Lwt.t +(** [set_ip e ip] sets [e]'s IP address to [ip]. *) + +val set_gateway: Ipaddr.V4.t -> unit Lwt.t +(** [set_gateway ip] set the default host gateway to [ip]. *) diff --git a/projects/miragesdk/src/test/test.ml b/projects/miragesdk/src/test/test.ml index b90fa511d..ac279b9ad 100644 --- a/projects/miragesdk/src/test/test.ml +++ b/projects/miragesdk/src/test/test.ml @@ -154,23 +154,25 @@ let failf fmt = Fmt.kstrf Alcotest.fail fmt (* read ops *) +let pp_error = Ctl.Client.pp_error + let read_should_err t k = Ctl.Client.read t k >|= function - | Error (`Msg _) -> () - | Ok None -> failf "read(%s) -> got: none, expected: err" k - | Ok Some v -> failf "read(%s) -> got: found:%S, expected: err" k v + | Error _ -> () + | Ok None -> failf "read(%s) -> got: none, expected: err" k + | Ok Some v -> failf "read(%s) -> got: found:%S, expected: err" k v let read_should_none t k = Ctl.Client.read t k >|= function - | Error (`Msg e) -> failf "read(%s) -> got: error:%s, expected none" k e - | Ok None -> () - | Ok Some v -> failf "read(%s) -> got: found:%S, expected none" k v + | Error e -> failf "read(%s) -> got: error:%a, expected none" k pp_error e + | Ok None -> () + | Ok Some v -> failf "read(%s) -> got: found:%S, expected none" k v let read_should_work t k v = Ctl.Client.read t k >|= function - | Error (`Msg e) -> failf "read(%s) -> got: error:%s, expected ok" k e - | Ok None -> failf "read(%s) -> got: none, expected ok" k - | Ok Some v' -> + | Error e -> failf "read(%s) -> got: error:%a, expected ok" k pp_error e + | Ok None -> failf "read(%s) -> got: none, expected ok" k + | Ok Some v' -> if v <> v' then failf "read(%s) -> got: ok:%S, expected: ok:%S" k v' v (* write ops *) @@ -182,8 +184,8 @@ let write_should_err t k v = let write_should_work t k v = Ctl.Client.write t k v >|= function - | Ok () -> () - | Error (`Msg e) -> failf "write(%s) -> error: %s" k e + | Ok () -> () + | Error e -> failf "write(%s) -> error: %a" k pp_error e (* del ops *) @@ -194,8 +196,8 @@ let delete_should_err t k = let delete_should_work t k = Ctl.Client.delete t k >|= function - | Ok () -> () - | Error (`Msg e) -> failf "write(%s) -> error: %s" k e + | Ok () -> () + | Error e -> failf "write(%s) -> error: %a" k pp_error e let test_ctl t () = let calf = calf Init.Pipe.(ctl t) in @@ -204,7 +206,8 @@ let test_ctl t () = let k2 = "a" in let k3 = "b/c" in let k4 = "xxxxxx" in - let routes = [k1; k2; k3] in + let all = [`Read; `Write; `Delete] in + let routes = [k1,all; k2,all; k3,all ] in let git_root = "/tmp/sdk/ctl" in let _ = Sys.command (Fmt.strf "rm -rf %s" git_root) in Ctl.v git_root >>= fun ctl ->