diff --git a/projects/miragesdk/examples/mirage-dhcp.yml b/projects/miragesdk/examples/mirage-dhcp.yml index f3c7cef50..fb93fbcd9 100644 --- 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' diff --git a/projects/miragesdk/pkg/init/Dockerfile b/projects/miragesdk/pkg/init/Dockerfile index 68f6fec25..5d0cc2a72 100644 --- 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 . ./ diff --git a/projects/miragesdk/src/.gitignore b/projects/miragesdk/src/.gitignore index 21a037422..2a8d64394 100644 --- 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 diff --git a/projects/miragesdk/src/Dockerfile.build b/projects/miragesdk/src/Dockerfile.build index 4c0cfb568..fe1d25f83 100644 --- 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 diff --git a/projects/miragesdk/src/Makefile b/projects/miragesdk/src/Makefile index 9fb07d3f0..a7cd8a225 100644 --- 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: diff --git a/projects/miragesdk/src/dhcp-client/calf/.merlin b/projects/miragesdk/src/dhcp-client/calf/.merlin deleted file mode 100644 index ada5d1966..000000000 --- a/projects/miragesdk/src/dhcp-client/calf/.merlin +++ /dev/null @@ -1,3 +0,0 @@ -PKG mirage mirage-time-lwt mirage-net-lwt jsonm duration charrua-client mirage-http -B _build -S . \ No newline at end of file diff --git a/projects/miragesdk/src/dhcp-client/calf/jbuild b/projects/miragesdk/src/dhcp-client/calf/jbuild new file mode 100644 index 000000000..874579a02 --- /dev/null +++ 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)) + )) diff --git a/projects/miragesdk/src/dhcp-client/calf/unikernel.ml b/projects/miragesdk/src/dhcp-client/calf/unikernel.ml index 5c3437d74..b59692da6 100644 --- 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 diff --git a/projects/miragesdk/src/dhcp-client/main.ml b/projects/miragesdk/src/dhcp-client/main.ml index 35809c587..88994e257 100644 --- 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 = diff --git a/projects/miragesdk/src/sdk/ctl.ml b/projects/miragesdk/src/sdk/ctl.ml index 7b092ff4d..d097664bd 100644 --- 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