Merge pull request #1448 from samoht/i-got-an-ip

miragesdk: put the DHCP lease info into the host filesystem
2025-07-21 10:09:07 +00:00 · 2017-04-02 18:32:51 +02:00 · 2017-04-02 18:32:51 +02:00 · 6a04d120a9
commit 6a04d120a9
parent 4db25372d0 15a524271d
10 changed files with 145 additions and 127 deletions
--- a/projects/miragesdk/examples/mirage-dhcp.yml
+++ b/projects/miragesdk/examples/mirage-dhcp.yml
@ -1,7 +1,7 @@
 kernel:
  image: "mobylinux/kernel:4.9.x"
  cmdline: "console=ttyS0 page_poison=1"
-init: "mobylinux/init:67913d76e75bebd78b4b2cc3843178c290405547"
+init: "mobylinux/init:3024f1eaf8779691229d661791607aade4df855d"
 system:
  - name: sysctl
    image: "mobylinux/sysctl:2cf2f9d5b4d314ba1bfc22b2fe931924af666d8c"
@ -17,16 +17,6 @@ system:
     - /proc/sys/fs/binfmt_misc:/binfmt_misc
    read_only: true
    command: [/usr/bin/binfmt, -dir, /etc/binfmt.d/, -mount, /binfmt_misc]
-  - name: dhcp-client
-    network_mode: host
-    image: "mobylinux/dhcp-client:aaf811d77ff8d8b2e16ca4dd9d0a2849ef8977b6"
-    capabilities:
-     - CAP_NET_ADMIN # to bring eth0 up
-     - CAP_NET_RAW   # to read /dev/eth0
-    binds:
-     - /var/run/dhcp-client:/data
-    command: [/dhcp-client, -vv]
-    read_only: true
 daemon:
  - name: rngd
    image: "mobylinux/rngd:3dad6dd43270fa632ac031e99d1947f20b22eec9@sha256:1c93c1db7196f6f71f8e300bc1d15f0376dd18e8891c8789d77c8ff19f3a9a92"
@ -35,6 +25,16 @@ daemon:
    oom_score_adj: -800
    read_only: true
    command: [/bin/tini, /usr/sbin/rngd, -f]
+  - name: dhcp-client
+    network_mode: host
+    image: "mobylinux/dhcp-client:f40cafe2ade4b115704750a85d21eb35b1116b91"
+    capabilities:
+     - CAP_NET_ADMIN # to bring eth0 up
+     - CAP_NET_RAW   # to read /dev/eth0
+    binds:
+     - /var/run/dhcp-client:/data
+    command: [/dhcp-client, -vv]
+    read_only: true
 files:
  - path: /var/run/dhcp-client/README
    contents: 'data for dhcp-client'
--- a/projects/miragesdk/pkg/init/Dockerfile
+++ b/projects/miragesdk/pkg/init/Dockerfile
@ -5,6 +5,7 @@ RUN \
  apk --no-cache upgrade -a && \
  apk --no-cache add \
    strace \
+    git \
  && rm -rf /var/cache/apk/*

 COPY . ./
--- a/projects/miragesdk/src/.gitignore
+++ b/projects/miragesdk/src/.gitignore
@ -5,6 +5,7 @@ obj/
 hash

 # Generated by jbuilder
+dhcp-client/calf/.merlin
 dhcp-client/bpf/.merlin
 dhcp-client/.merlin
 sdk/.merlin
--- a/projects/miragesdk/src/Dockerfile.build
+++ b/projects/miragesdk/src/Dockerfile.build
@ -7,6 +7,14 @@ RUN opam pin -n add mirage-net-unix https://github.com/samoht/mirage-net-unix.gi
 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 cstruct --dev # for ppx/jbuilder
+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
 COPY ./sdk /src/sdk
@ -16,7 +24,8 @@ RUN sudo chown opam -R /src
 USER opam
 WORKDIR /src

-RUN opam pin add cstruct --dev # for ppx/jbuilder
-
 RUN opam config exec -- jbuilder build dhcp-client/main.exe
 RUN sudo cp /src/_build/default/dhcp-client/main.exe /dhcp-client
+
+RUN opam config exec -- jbuilder build dhcp-client/calf/unikernel.exe
+RUN sudo cp /src/_build/default/dhcp-client/calf/unikernel.exe /dhcp-client-calf
--- a/projects/miragesdk/src/Makefile
+++ b/projects/miragesdk/src/Makefile
@ -8,7 +8,8 @@ OBJS=obj/dhcp-client

 MIRAGE_COMPILE=mobylinux/mirage-compile:f903b0e1b4328271364cc63f123ac49d56739cef@sha256:a54d9ca84d3f5998dba92ce83d60d49289cee8908a8b0f6ec280d30ab8edf46c
 CALF_OBJS=obj/dhcp-client-calf
-CALF_FILES=dhcp-client/calf/config.ml dhcp-client/calf/unikernel.ml
+CALF_FILES=dhcp-client/calf/config.ml dhcp-client/calf/unikernel.ml \
+	   dhcp-client/calf/jbuild

 default: push
 	@
@ -34,18 +35,18 @@ enter-build: .build
 enter-dev: .dev
 	docker run --privileged -it -v `pwd`:/src $(shell cat .dev)

-$(CALF_OBJS): $(CALF_FILES)
-	mkdir -p obj/bin
-	( cd obj && \
-	  tar -C ../dhcp-client/calf -cf - $(CALF_FILES:dhcp-client/calf/%=%) | \
-	    docker run --rm -i --log-driver=none $(MIRAGE_COMPILE) -o dhcp-client-calf | \
-	    tar xf - || exit 1) && \
-	touch $@
+#$(CALF_OBJS): $(CALF_FILES)
+#	mkdir -p obj/bin
+#	( cd obj && \
+#	  tar -C ../dhcp-client/calf -cf - $(CALF_FILES:dhcp-client/calf/%=%) | \
+#	    docker run --rm -i --log-driver=none $(MIRAGE_COMPILE) -o dhcp-client-calf | \
+#	    tar xf - || exit 1) && \
+#	touch $@

-$(OBJS): .build $(FILES)
+$(OBJS) $(CALF_OBJS): .build $(FILES) $(CALF_FILES)
 	mkdir -p obj/usr/lib obj/bin
 	( cd obj && \
-	  docker run --rm --net=none --log-driver=none -i $(IMAGE):build tar -cf - $(OBJS:obj/%=/%) | tar xf - ) && \
+	  docker run --rm --net=none --log-driver=none -i $(IMAGE):build tar -cf - $(OBJS:obj/%=/%) $(CALF_OBJS:obj/%=/%) | tar xf - ) && \
 	touch $@

 hash: Makefile Dockerfile.build Dockerfile.pkg $(FILES) $(CALF_FILES) .build
@ -77,7 +78,8 @@ dev-clean:
 	rm -rf _build dhcp-client/calf/_build

 dev:
-	cd dhcp-client/calf && mirage configure && make
 	jbuilder build dhcp-client/main.exe --dev
+	jbuilder build dhcp-client/calf/unikernel.exe --dev
+#	cd dhcp-client/calf && mirage configure && make

 .DELETE_ON_ERROR:
--- a/projects/miragesdk/src/dhcp-client/calf/.merlin
+++ b/projects/miragesdk/src/dhcp-client/calf/.merlin
@ -1,3 +0,0 @@
-PKG mirage mirage-time-lwt mirage-net-lwt jsonm duration charrua-client mirage-http
-B _build
-S .
--- a/projects/miragesdk/src/dhcp-client/calf/jbuild
+++ b/projects/miragesdk/src/dhcp-client/calf/jbuild
@ -0,0 +1,8 @@
+(jbuild_version 1)
+
+(executables
+ ((names (unikernel))
+  (libraries (sdk mirage-net-fd lwt charrua-client.mirage charrua-client
+              lwt.unix))
+  (flags (-cclib -static))
+ ))
--- a/projects/miragesdk/src/dhcp-client/calf/unikernel.ml
+++ b/projects/miragesdk/src/dhcp-client/calf/unikernel.ml
@ -128,98 +128,81 @@ end = struct

 end

-(* FIXME: this code is way too much complex *)
-module HTTP (Net: Mirage_net_lwt.S) = struct
-  module Flow = Raw(Net)
-  module Channel = Mirage_channel_lwt.Make(Flow)
-  (* FIXME: copy/pasted from mirage-http to avoid the dependency chain:
-      mirage-http -> mirage-conduit -> nocrypto -> gmp -> .so needed  *)
-  module HTTP_IO = struct
-    type 'a t = 'a Lwt.t
-    type ic = Channel.t
-    type oc = Channel.t
-    type conn = Channel.flow
-    let failf fmt = Fmt.kstrf Lwt.fail_with fmt
-    let read_line ic =
-      Channel.read_line ic >>= function
-      | Ok (`Data [])   -> Lwt.return_none
-      | Ok `Eof         -> Lwt.return_none
-      | Ok (`Data bufs) -> Lwt.return (Some (Cstruct.copyv bufs))
-      | Error e         -> failf "Flow error: %a" Channel.pp_error e
-    let read ic len =
-      Channel.read_some ~len ic >>= function
-      | Ok (`Data buf) -> Lwt.return (Cstruct.to_string buf)
-      | Ok `Eof        -> Lwt.return ""
-      | Error e        -> failf "Flow error: %a" Channel.pp_error e
-    let write oc buf =
-      Channel.write_string oc buf 0 (String.length buf);
-      Channel.flush oc >>= function
-      | Ok ()         -> Lwt.return_unit
-      | Error `Closed -> Lwt.fail_with "Trying to write on closed channel"
-      | Error e       -> failf "Flow error: %a" Channel.pp_write_error e
-    let flush _ = Lwt.return_unit
-    let  (>>= ) = Lwt.( >>= )
-    let return = Lwt.return
-  end
-  module Net_IO = struct
-    module IO = HTTP_IO
-    type ctx = Net.t option
-    let default_ctx = None
-    let sexp_of_ctx _ = Sexplib.Sexp.Atom "netif"
-    let connect_uri ~ctx _uri =
-      match ctx with
-      | None     -> Lwt.fail_with "No context"
-      | Some ctx ->
-        Flow.connect ctx >|= fun flow ->
-        let ch = Channel.create flow in
-        flow, ch, ch
-    let close_in _ic = ()
-    let close_out _oc = ()
-    let close ic _oc = Lwt.ignore_result (Channel.close ic)
-  end
-  include Cohttp_lwt.Make_client(HTTP_IO)(Net_IO)
+(* FIXME: use the mirage tool *)
+
+module Time = struct
+  type +'a io = 'a Lwt.t
+  let sleep_ns x = Lwt_unix.sleep (Int64.to_float x /. 1_000_000_000.)
 end
+module Net = Netif_fd
+module Ctl = Netif_fd

-module API (Store: Mirage_net_lwt.S) = struct
+open Cmdliner

-  module HTTP = HTTP(Store)
+let dhcp_codes =
+  let doc = Arg.info ~docv:"OPT" ~doc:"DHCP options." ["c";"codes"] in
+  Arg.(value & opt (list string) [] doc)

-  let http_post t uri ~body =
-    HTTP.post ~ctx:(Some t) ~body:(`String body) uri >|= fun (response, _) ->
-    (* FIXME check that response is ok *)
-    Log.info
-      (fun l -> l "POST %a: %a" Uri.pp_hum uri Cohttp.Response.pp_hum response)
+let net =
+  let doc = Arg.info ~docv:"FD" ~doc:"Network interface" ["net"] in
+  Arg.(value & opt int 3 doc)

-  let set_ip t ip =
-    http_post t (Uri.of_string "/ip") ~body:(Ipaddr.V4.to_string ip)
+let ctl =
+  let doc = Arg.info ~docv:"FD" ~doc:"Control interface" ["ctl"] in
+  Arg.(value & opt int 4 doc)

-end
+let setup_log style_renderer level =
+  Fmt_tty.setup_std_outputs ?style_renderer ();
+  Logs.set_level level;
+  let pp_header ppf x =
+    Fmt.pf ppf "%5d: %a " (Unix.getpid ()) Logs_fmt.pp_header x
+  in
+  Logs.set_reporter (Logs_fmt.reporter ~pp_header ());
+  ()

+let setup_log =
+  Term.(const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ())

-module Main
-    (Time :Mirage_time_lwt.S)
-    (Net  : Mirage_net_lwt.S)
-    (Ctl  : Mirage_net_lwt.S) =
-struct
+(* FIXME: module Main ... *)

-  module API = API(Ctl)
-  module Dhcp_client = Dhcp_client_mirage.Make(Time)(Net)
+module Dhcp_client = Dhcp_client_mirage.Make(Time)(Net)

-  let start () net ctl =
-    let requests = match Key_gen.codes () with
-      | [] -> default_options
-      | l  ->
-        List.fold_left (fun acc c -> match parse_option_code c with
-            | Ok x    -> x :: acc
-            | Error e ->
-              Log.err (fun l -> l "error: %s" e);
-              acc
-          ) [] l
-    in
-    Dhcp_client.connect ~requests net >>= fun stream ->
-    Lwt_stream.last_new stream >>= fun result ->
-    let result = of_ipv4_config result in
-    Log.info (fun l -> l "found lease: %a" pp result);
-    API.set_ip ctl result.address
+let start () dhcp_codes net ctl =
+  Netif_fd.connect net >>= fun net ->
+  let ctl = Sdk.Ctl.Client.v (Lwt_unix.of_unix_file_descr ctl) in
+  let requests = match dhcp_codes with
+    | [] -> default_options
+    | l  ->
+      List.fold_left (fun acc c -> match parse_option_code c with
+          | Ok x    -> x :: acc
+          | Error e ->
+            Log.err (fun l -> l "error: %s" e);
+            acc
+        ) [] l
+  in
+  Dhcp_client.connect ~requests net >>= fun stream ->
+  Lwt_stream.last_new stream >>= fun result ->
+  let result = of_ipv4_config result in
+  Log.info (fun l -> l "found lease: %a" pp result);
+  Sdk.Ctl.Client.write ctl "/ip" (Ipaddr.V4.to_string result.address ^ "\n")

-end
+(* FIXME: Main end *)
+let magic (x: int) = (Obj.magic x: Unix.file_descr)
+
+let start () dhcp_codes net ctl =
+  Lwt_main.run (
+    let net = magic net in
+    let ctl = magic ctl in
+    start () dhcp_codes net ctl
+  )
+
+let run =
+  Term.(const start $ setup_log $ dhcp_codes $ net $ ctl),
+  Term.info "dhcp-client" ~version:"0.0"
+
+let () = match Term.eval run with
+  | `Error _ -> exit 1
+  | `Ok (Ok ()) |`Help |`Version -> exit 0
+  | `Ok (Error (`Msg e)) ->
+    Printf.eprintf "%s\n%!" e;
+    exit 1
--- a/projects/miragesdk/src/dhcp-client/main.ml
+++ b/projects/miragesdk/src/dhcp-client/main.ml
@ -1,5 +1,6 @@
 open Lwt.Infix
 open Sdk
+open Astring

 let src = Logs.Src.create "dhcp-client" ~doc:"DHCP client"
 module Log = (val Logs.src_log src : Logs.LOG)
@ -40,7 +41,33 @@ end

 external bpf_filter: unit -> string = "bpf_filter"

-let run () cmd ethif path =
+let ctl = string_of_int Init.(Fd.to_int Pipe.(calf ctl))
+let net = string_of_int Init.(Fd.to_int Pipe.(calf net))
+let default_cmd = [
+  "/dhcp-client-calf"; "--ctl="^ctl; "--net="^net
+]
+
+(* FIXME: use runc isolation
+   let default_cmd = [
+    "/usr/bin/runc"; "--"; "run";
+    "--bundle"; "/containers/images/000-dhcp-client";
+    "dhcp-client"
+  ] in
+  *)
+
+let read_cmd file =
+  if Sys.file_exists file then
+    let ic = open_in_bin file in
+    let line = input_line ic in
+    String.cuts ~sep:" " line
+  else
+    failwith ("Cannot read " ^ file)
+
+ let run () cmd ethif path =
+  let cmd = match cmd with
+    | None   -> default_cmd
+    | Some f -> read_cmd f
+  in
  Lwt_main.run (
    let net = Init.rawlink ~filter:(bpf_filter ()) ethif in
    let routes = [
@ -73,24 +100,11 @@ let setup_log style_renderer level =
 let setup_log =
  Term.(const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ())

-let ctl = string_of_int Init.(Fd.to_int Pipe.(calf ctl))
-let net = string_of_int Init.(Fd.to_int Pipe.(calf net))
-
 let cmd =
-  (* FIXME: use runc isolation
-   let default_cmd = [
-    "/usr/bin/runc"; "--"; "run";
-    "--bundle"; "/containers/images/000-dhcp-client";
-    "dhcp-client"
-  ] in
-  *)
-  let default_cmd = [
-    "/dhcp-client-calf"; "--ctl="^ctl; "--net="^net
-  ] in
  let doc =
    Arg.info ~docv:"CMD" ~doc:"Command to run the calf process." ["cmd"]
  in
-  Arg.(value & opt (list ~sep:' ' string) default_cmd & doc)
+  Arg.(value & opt (some string) None & doc)

 let ethif =
  let doc =
--- a/projects/miragesdk/src/sdk/ctl.ml
+++ b/projects/miragesdk/src/sdk/ctl.ml
@ -27,7 +27,10 @@ let v path =
  KV.of_branch repo "calf"

 let () =
-  Irmin.Private.Watch.set_listen_dir_hook Irmin_watcher.hook
+  Irmin.Private.Watch.set_listen_dir_hook
+    (fun _ _ _ -> Lwt.return (fun () -> Lwt.return_unit))
+    (* FIXME: inotify need some unknown massaging. *)
+    (* Irmin_watcher.hook *)

 module Query = struct