github/linuxkit
1
0
Fork 0
mirror of https://github.com/linuxkit/linuxkit.git synced 2025-07-20 17:49:10 +00:00
Code Issues Projects Releases Wiki Activity

miragesdk: minor cleanups

Browse Source 
Signed-off-by: Thomas Gazagnaire <thomas@gazagnaire.org>
This commit is contained in:
Thomas Gazagnaire 2017-03-28 18:44:36 +02:00
parent df33c8a4d3
commit 13d110e2c7
4 changed files with 26 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
projects/miragesdk/dhcp-client/src/ctl.ml
View File

@ -25,10 +25,10 @@ let v path =
KV.Repo.v config >>= fun repo -> KV.Repo.v config >>= fun repo ->
KV.of_branch repo "calf" KV.of_branch repo "calf"
let set_listen_dir_hook () = let () =
Irmin.Private.Watch.set_listen_dir_hook Irmin_watcher.hook Irmin.Private.Watch.set_listen_dir_hook Irmin_watcher.hook
module HTTP = struct module Dispatch = struct
module Wm = struct module Wm = struct
module Rd = Webmachine.Rd module Rd = Webmachine.Rd
@ -112,7 +112,7 @@ module HTTP = struct
(Uri.path (Request.uri request))); (Uri.path (Request.uri request)));
Log.debug (fun l -> l "path=%a" Fmt.(Dump.list string) path); Log.debug (fun l -> l "path=%a" Fmt.(Dump.list string) path);
(* Finally, send the response to the client *) (* 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 in
(* create the server and handle requests with the function defined above *) (* create the server and handle requests with the function defined above *)
let conn_closed (_, conn) = let conn_closed (_, conn) =
@ -122,7 +122,15 @@ module HTTP = struct
Cohttp_lwt_unix.Server.make ~callback ~conn_closed () Cohttp_lwt_unix.Server.make ~callback ~conn_closed ()
end 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 serve ~routes db fd =
let http = HTTP.v db routes in let http = HTTP.v db routes in
let on_exn e = Log.err (fun l -> l "ERROR: %a" Fmt.exn e) 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 Cohttp_lwt_unix.Server.create ~on_exn ~mode:(`Fd fd) http

9
projects/miragesdk/dhcp-client/src/init.ml
View File

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

1
projects/miragesdk/dhcp-client/src/jbuild
View File

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

11
projects/miragesdk/dhcp-client/src/main.ml
View File

@ -97,10 +97,17 @@ let ethif =
in in
Arg.(value & opt string "eth0" & doc) 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 = let run =
Term.(const run $ setup_log $ cmd $ ethif), Term.(const run $ setup_log $ cmd $ ethif $ path),
Term.info "dhcp-client" ~version:"0.0" Term.info "dhcp-client" ~version:"0.0"
let () = match Term.eval run with let () = match Term.eval run with
| `Error _ -> exit 1 | `Error _ -> exit 1
| _ -> exit 0 | `Ok () |`Help |`Version -> exit 0