mirror of
https://github.com/linuxkit/linuxkit.git
synced 2025-07-29 13:38:00 +00:00
Merge pull request #1543 from samoht/mac
miragesdk: do not generate a random mac
This commit is contained in:
Thomas Gazagnaire
GitHub
commit
2cc09805c9
@ -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
|
||||
|
||||
@ -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/ .*//' > $@
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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"]
|
||||
|
||||
@ -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 ->
|
||||
|
||||
@ -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
|
||||
)
|
||||
|
||||
|
||||
@ -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;
|
||||
]
|
||||
|
||||
@ -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. *)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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))))
|
||||
))
|
||||
|
||||
28
projects/miragesdk/src/sdk/net.ml
Normal file
28
projects/miragesdk/src/sdk/net.ml
Normal file
@ -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
|
||||
10
projects/miragesdk/src/sdk/net.mli
Normal file
10
projects/miragesdk/src/sdk/net.mli
Normal file
@ -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]. *)
|
||||
@ -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 ->
|
||||
|
||||
Loading…
Reference in New Issue
Block a user