Merge pull request #1408 from samoht/reorg

mirageSDK: re-organise the file hierarchy

projects/miragesdk/dhcp-client/.gitignore

@@ -1,27 +0,0 @@
-.build
-.pkg
-.dev
-obj/
-
-hash
-
-# Generated by `make dev`
-_build/
-main.native
-calf/dhcp_client
-src/bpf/.merlin
-
-# Generated by the mirage tool
-calf/_build
-calf/Makefile
-calf/myocamlbuild.ml
-calf/*.opam
-calf/key_gen.ml
-calf/main.ml
-calf/.mirage.config
-
-# Trash files
-\#*
-.#*
-*~
-.*~

projects/miragesdk/dhcp-client/src/.merlin

@@ -1,74 +0,0 @@
-B ../_build/default/src
-B ../_build/default/src/bpf
-FLG -cclib -static
-PKG astring
-PKG base64
-PKG bigarray
-PKG bytes
-PKG calendar
-PKG cmdliner
-PKG cohttp
-PKG cohttp.lwt
-PKG cohttp.lwt-core
-PKG conduit
-PKG conduit.lwt
-PKG conduit.lwt-unix
-PKG cstruct
-PKG cstruct.lwt
-PKG cstruct.ppx
-PKG decompress
-PKG dispatch
-PKG fieldslib
-PKG fmt
-PKG fmt.cli
-PKG fmt.tty
-PKG git
-PKG hex
-PKG inotify
-PKG inotify.lwt
-PKG ipaddr
-PKG ipaddr.unix
-PKG irmin
-PKG irmin-git
-PKG irmin-http
-PKG irmin-watcher
-PKG irmin-watcher.core
-PKG irmin-watcher.inotify
-PKG irmin-watcher.polling
-PKG jsonm
-PKG logs
-PKG logs-syslog
-PKG logs-syslog.lwt
-PKG logs.cli
-PKG logs.fmt
-PKG logs.lwt
-PKG lwt
-PKG lwt.log
-PKG lwt.unix
-PKG magic-mime
-PKG mstruct
-PKG ocamlgraph
-PKG ocplib-endian
-PKG ocplib-endian.bigstring
-PKG ptime
-PKG ptime.clock.os
-PKG rawlink
-PKG re
-PKG re.emacs
-PKG re.posix
-PKG re.str
-PKG result
-PKG sexplib
-PKG str
-PKG stringext
-PKG syslog-message
-PKG threads
-PKG threads.posix
-PKG tuntap
-PKG uchar
-PKG unix
-PKG uri
-PKG uri.services
-PKG uutf
-PKG webmachine
-S .

projects/miragesdk/src/.gitignore

@@ -0,0 +1,31 @@
+.build
+.pkg
+.dev
+obj/
+hash
+
+# Generated by jbuilder
+dhcp-client/bpf/.merlin
+dhcp-client/.merlin
+sdk/.merlin
+
+# Generated by `make dev`
+_build/
+main.native
+calf/dhcp_client
+src/bpf/.merlin
+
+# Generated by the mirage tool
+dhcp-client/calf/_build
+dhcp-client/calf/Makefile
+dhcp-client/calf/myocamlbuild.ml
+dhcp-client/calf/*.opam
+dhcp-client/calf/key_gen.ml
+dhcp-client/calf/main.ml
+dhcp-client/calf/.mirage.config
+
+# Trash files
+\#*
+.#*
+*~
+.*~

projects/miragesdk/src/Dockerfile.build

@@ -7,14 +7,13 @@ 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 sudo mkdir -p /src /bin
-COPY ./src /src
+RUN sudo mkdir -p /src
+COPY ./sdk /src/sdk
+COPY ./dhcp-client /src/dhcp-client
 RUN sudo chown opam -R /src
 
 USER opam
 WORKDIR /src
 
-RUN opam pin add tuntap 1.0.0
-
-RUN opam config exec -- jbuilder build main.exe
-RUN sudo cp /src/_build/default/main.exe /dhcp-client
+RUN opam config exec -- jbuilder build dhcp-client/main.exe
+RUN sudo cp /src/_build/default/dhcp-client/main.exe /dhcp-client

projects/miragesdk/src/Makefile

@@ -1,12 +1,13 @@
 BASE=ocaml/opam:alpine-3.5_ocaml-4.04.0
-FILES=$(shell find src/ -regex '.*\.mli?') src/bpf/dhcp.c \
-	src/jbuild src/bpf/jbuild
+FILES=$(shell find . -name jbuild) \
+	$(shell find sdk/ -regex '.*\.mli?') \
+	dhcp-client/bpf/dhcp.c dhcp-client/main.ml
 IMAGE=dhcp-client
 OBJS=obj/dhcp-client
 
 MIRAGE_COMPILE=mobylinux/mirage-compile:f903b0e1b4328271364cc63f123ac49d56739cef@sha256:a54d9ca84d3f5998dba92ce83d60d49289cee8908a8b0f6ec280d30ab8edf46c
 CALF_OBJS=obj/dhcp-client-calf
-CALF_FILES=calf/config.ml calf/unikernel.ml
+CALF_FILES=dhcp-client/calf/config.ml dhcp-client/calf/unikernel.ml
 
 default: push
 	@

projects/miragesdk/src/dhcp-client/jbuild

@@ -0,0 +1,7 @@
+(jbuild_version 1)
+
+(executables
+ ((names (main))
+  (libraries (sdk bpf_dhcp))
+  (flags (-cclib -static))
+ ))

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

@@ -1,4 +1,5 @@
 open Lwt.Infix
+open Sdk
 
 let src = Logs.Src.create "dhcp-client" ~doc:"DHCP client"
 module Log = (val Logs.src_log src : Logs.LOG)
@@ -97,10 +98,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

projects/miragesdk/src/sdk/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 http = Dispatch.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/src/sdk/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/src/sdk/jbuild

@@ -1,10 +1,9 @@
 (jbuild_version 1)
 
-(executables
- ((names (main))
+(library
+ ((name sdk)
   (libraries (logs-syslog.lwt threads cohttp.lwt cstruct.lwt
               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
               irmin-watcher inotify))
-  (flags (-cclib -static))
  ))