diff --git a/projects/miragesdk/examples/mirage-dhcp.yml b/projects/miragesdk/examples/mirage-dhcp.yml index 9a717a187..61db6c858 100644 --- a/projects/miragesdk/examples/mirage-dhcp.yml +++ b/projects/miragesdk/examples/mirage-dhcp.yml @@ -25,7 +25,7 @@ services: oomScoreAdj: -800 readonly: true - name: dhcp-client - image: "mobylinux/dhcp-client:9e7009ae469ddd4d37f9cffaad2cf612114a3fb0@sha256:4421e05a0082b56c4ef83ca652e1da1a5af3a24e5baec61e7ba5b981f3b94a09" + image: "mobylinux/dhcp-client:aadc4b05ef53cc75befcf60963d4b273f34267bd" net: host capabilities: - CAP_NET_ADMIN # to bring eth0 up diff --git a/projects/miragesdk/src/dhcp-client/calf/unikernel.ml b/projects/miragesdk/src/dhcp-client/calf/unikernel.ml index da1c38b7b..49fa75bae 100644 --- a/projects/miragesdk/src/dhcp-client/calf/unikernel.ml +++ b/projects/miragesdk/src/dhcp-client/calf/unikernel.ml @@ -185,8 +185,15 @@ 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 7fcd71104..717da27b2 100644 --- a/projects/miragesdk/src/dhcp-client/main.ml +++ b/projects/miragesdk/src/dhcp-client/main.ml @@ -71,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/ctl.ml b/projects/miragesdk/src/sdk/ctl.ml index 9fb640828..bb911df4d 100644 --- a/projects/miragesdk/src/sdk/ctl.ml +++ b/projects/miragesdk/src/sdk/ctl.ml @@ -330,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 } @@ -348,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 = @@ -384,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 2d05551d0..92f80dcd5 100644 --- a/projects/miragesdk/src/sdk/ctl.mli +++ b/projects/miragesdk/src/sdk/ctl.mli @@ -126,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/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/test/test.ml b/projects/miragesdk/src/test/test.ml index d6f93989f..ac279b9ad 100644 --- a/projects/miragesdk/src/test/test.ml +++ b/projects/miragesdk/src/test/test.ml @@ -206,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 ->