miragesdk: minor cleanups

Signed-off-by: Thomas Gazagnaire <thomas@gazagnaire.org>

projects/miragesdk/dhcp-client/src/ctl.ml

@@ -25,10 +25,10 @@ let v path =
   KV.Repo.v config >>= fun repo ->
   KV.of_branch repo "calf"
 
-let set_listen_dir_hook () =
+let () =
   Irmin.Private.Watch.set_listen_dir_hook Irmin_watcher.hook
 
-module HTTP = struct
+module Dispatch = struct
 
   module Wm = struct
     module Rd = Webmachine.Rd
@@ -112,7 +112,7 @@ module HTTP = struct
             (Uri.path (Request.uri request)));
       Log.debug (fun l -> l "path=%a" Fmt.(Dump.list string) path);
       (* Finally, send the response to the client *)
-      Cohttp_lwt_unix.Server.respond ~flush:true ~headers ~body ~status ()
+      Cohttp_lwt_unix.Server.respond ~headers ~body ~status ()
     in
     (* create the server and handle requests with the function defined above *)
     let conn_closed (_, conn) =
@@ -122,7 +122,15 @@ module HTTP = struct
     Cohttp_lwt_unix.Server.make ~callback ~conn_closed ()
 end
 
+let int_of_fd (t:Lwt_unix.file_descr) =
+  (Obj.magic (Lwt_unix.unix_file_descr t): int)
+
 let serve ~routes db fd =
   let http = HTTP.v db routes in
   let on_exn e = Log.err (fun l -> l "ERROR: %a" Fmt.exn e) in
+  Lwt_unix.blocking fd >>= fun blocking ->
+  Log.debug (fun l ->
+      l "Serving the control state over fd:%d (blocking=%b)"
+        (int_of_fd fd) blocking
+    );
   Cohttp_lwt_unix.Server.create ~on_exn ~mode:(`Fd fd) http

projects/miragesdk/dhcp-client/src/init.ml

@@ -126,8 +126,8 @@ module Pipe = struct
     { Fd.name = name; fd = priv }, { Fd.name = name ^ "-calf"; fd = calf }
 
   (* logs pipe *)
-  let stdout = pipe "logs-out"
-  let stderr = pipe "logs-err"
+  let stdout = pipe "stdout"
+  let stderr = pipe "stderr"
 
   (* store pipe *)
   let ctl = socketpair "ctl"
@@ -182,8 +182,9 @@ let check_exit_status cmd status =
 
 let exec_priv ~pid ~cmd ~net ~ctl ~handlers =
 
+  Fd.(redirect_to_dev_null stdin) >>= fun () ->
+
   (* close child fds *)
-  Fd.(redirect_to_dev_null stdin)   >>= fun () ->
   Fd.close Pipe.(calf stdout)  >>= fun () ->
   Fd.close Pipe.(calf stderr)  >>= fun () ->
   Fd.close Pipe.(calf net)     >>= fun () ->
@@ -206,7 +207,7 @@ let exec_priv ~pid ~cmd ~net ~ctl ~handlers =
       Fd.forward ~src:Pipe.(priv stderr)  ~dst:Fd.stderr;
       (* TODO: Init.Fd.forward ~src:Init.Pipe.(priv metrics) ~dst:Init.Fd.metric; *)
       ctl ();
-      handlers ();
+(*      handlers (); *)
     ])
 
 let run ~net ~ctl ~handlers cmd =

projects/miragesdk/dhcp-client/src/jbuild

@@ -6,5 +6,6 @@
               cmdliner fmt.cli logs.fmt logs.cli fmt.tty decompress
               irmin irmin-git irmin-http lwt.unix rawlink tuntap bpf_dhcp
               irmin-watcher inotify))
+  (preprocess (pps (cstruct.ppx)))
   (flags (-cclib -static))
  ))

projects/miragesdk/dhcp-client/src/main.ml

@@ -97,10 +97,17 @@ let ethif =
   in
   Arg.(value & opt string "eth0" & doc)
 
+let path =
+  let doc =
+    Arg.info ~docv:"DIR"
+      ~doc:"The directory where control state will be stored." ["path"]
+  in
+  Arg.(value & opt string "/data" & doc)
+
 let run =
-  Term.(const run $ setup_log $ cmd $ ethif),
+  Term.(const run $ setup_log $ cmd $ ethif $ path),
   Term.info "dhcp-client" ~version:"0.0"
 
 let () = match Term.eval run with
   | `Error _ -> exit 1
-  | _        -> exit 0
+  | `Ok () |`Help |`Version -> exit 0