diff --git a/projects/miragesdk/examples/mirage-dhcp.yml b/projects/miragesdk/examples/mirage-dhcp.yml index 63900f2c9..a843fc8d1 100644 --- a/projects/miragesdk/examples/mirage-dhcp.yml +++ b/projects/miragesdk/examples/mirage-dhcp.yml @@ -24,14 +24,16 @@ daemon: oomScoreAdj: -800 readonly: true - name: dhcp-client + image: "mobylinux/dhcp-client:99ecd3304172eb7570aa5c7f527cec2577b48a84" net: 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] + - /sbin:/sbin # for ifconfig + - /bin:/bin # for ifconfig + - /lib:/lib # for ifconfig readonly: true files: - path: /var/run/dhcp-client/README diff --git a/projects/miragesdk/src/Dockerfile.build b/projects/miragesdk/src/Dockerfile.build index fe1d25f83..556f09aa8 100644 --- a/projects/miragesdk/src/Dockerfile.build +++ b/projects/miragesdk/src/Dockerfile.build @@ -1,13 +1,11 @@ FROM ocaml/opam:alpine-3.5_ocaml-4.04.0 RUN git -C /home/opam/opam-repository pull origin master && 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 +RUN opam info mirage-net-fd 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 diff --git a/projects/miragesdk/src/dhcp-client/calf/unikernel.ml b/projects/miragesdk/src/dhcp-client/calf/unikernel.ml index b59692da6..4bf52574b 100644 --- a/projects/miragesdk/src/dhcp-client/calf/unikernel.ml +++ b/projects/miragesdk/src/dhcp-client/calf/unikernel.ml @@ -3,8 +3,11 @@ open Lwt.Infix let src = Logs.Src.create "charrua" module Log = (val Logs.src_log src : Logs.LOG) +let failf fmt = Fmt.kstrf Lwt.fail_with fmt + type t = { address: Ipaddr.V4.t; + gateway: Ipaddr.V4.t option; domain: string option; search: string option; nameservers: Ipaddr.V4.t list; @@ -13,8 +16,9 @@ type t = { (* FIXME: we loose lots of info here *) let of_ipv4_config (t: Mirage_protocols_lwt.ipv4_config) = { address = t.Mirage_protocols_lwt.address; - domain = None; - search = None; + gateway = t.Mirage_protocols_lwt.gateway; + domain = None; + search = None; nameservers = [] } let pp ppf t = @@ -33,10 +37,14 @@ let of_pkt lease = (* ipv4_config expects a single IP address and the information * needed to construct a prefix. It can optionally use one router. *) let address = lease.yiaddr in + let gateway = match Dhcp_wire.collect_routers lease.options with + | [] -> None + | h::_ -> Some h + in let domain = Dhcp_wire.find_domain_name lease.options in let search = Dhcp_wire.find_domain_search lease.options in let nameservers = Dhcp_wire.collect_name_servers lease.options in - { address; domain; search; nameservers } + { address; gateway; domain; search; nameservers } let of_pkt_opt = function | None -> None @@ -167,6 +175,16 @@ let setup_log = 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 + +let set_ip_opt ctl k = function + | None -> Lwt.return_unit + | Some ip -> set_ip ctl k ip + 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 @@ -184,7 +202,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); - Sdk.Ctl.Client.write ctl "/ip" (Ipaddr.V4.to_string result.address ^ "\n") + set_ip ctl "/ip" result.address >>= fun () -> + set_ip_opt ctl "/gateway" result.gateway (* FIXME: Main end *) let magic (x: int) = (Obj.magic x: Unix.file_descr) @@ -202,7 +221,4 @@ let run = 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 + | `Ok () |`Help |`Version -> exit 0 diff --git a/projects/miragesdk/src/dhcp-client/jbuild b/projects/miragesdk/src/dhcp-client/jbuild index cece90bb7..37c01d523 100644 --- a/projects/miragesdk/src/dhcp-client/jbuild +++ b/projects/miragesdk/src/dhcp-client/jbuild @@ -2,6 +2,6 @@ (executables ((names (main)) - (libraries (sdk bpf_dhcp)) + (libraries (sdk bpf_dhcp bos)) (flags (-cclib -static)) )) diff --git a/projects/miragesdk/src/dhcp-client/main.ml b/projects/miragesdk/src/dhcp-client/main.ml index 22f590ac8..3a72c2429 100644 --- a/projects/miragesdk/src/dhcp-client/main.ml +++ b/projects/miragesdk/src/dhcp-client/main.ml @@ -7,6 +7,12 @@ 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 @@ -17,23 +23,37 @@ module Handlers = struct | `Updated (_, (_, `Contents (v, _))) -> Some v | _ -> None - let ip t = + 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); - Lwt.return () - | _ -> - Lwt.return () + (* 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 *) ) - let handlers = [ - 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 + ) + + let handlers ~ethif = [ + ip ~ethif; + gateway; ] - let watch path = + let watch ~ethif path = Ctl.v path >>= fun db -> - Lwt_list.map_p (fun f -> f db) handlers >>= fun _ -> + Lwt_list.map_p (fun f -> f db) (handlers ethif) >>= fun _ -> let t, _ = Lwt.task () in t @@ -74,6 +94,7 @@ let read_cmd file = let net = Init.rawlink ~filter:(bpf_filter ()) ethif in let routes = [ "/ip"; + "/gateway"; "/domain"; "/search"; "/mtu"; @@ -82,7 +103,7 @@ let read_cmd file = Ctl.v "/data" >>= fun ctl -> let fd = Init.(Fd.fd @@ Pipe.(priv @@ ctl t)) in let ctl () = Ctl.Server.listen ~routes ctl fd in - let handlers () = Handlers.watch path in + let handlers () = Handlers.watch ~ethif path in Init.run t ~net ~ctl ~handlers cmd )