mirror of
https://github.com/linuxkit/linuxkit.git
synced 2025-07-20 09:39:08 +00:00
Merge pull request #2072 from samoht/sdk-upstream-cleanup
Sdk upstream cleanup
This commit is contained in:
Rolf Neugebauer
GitHub
commit
43ac05e4dd
@ -37,6 +37,10 @@ RUN git -C /home/opam/opam-repository fetch origin && \
|
||||
RUN opam pin add -n capnp.dev 'https://github.com/talex5/capnp-ocaml.git#interfaces'
|
||||
RUN opam pin add -n capnp-rpc.dev 'https://github.com/mirage/capnp-rpc.git'
|
||||
RUN opam pin add -n capnp-rpc-lwt.dev 'https://github.com/mirage/capnp-rpc.git'
|
||||
RUN opam pin add -n charrua-client.dev https://github.com/samoht/charrua-client.git#with-cdhcpc
|
||||
RUN opam pin add -n mirage-flow-rawlink.dev https://github.com/mirage/mirage-flow-rawlink.git
|
||||
RUN opam pin add -n mirage-flow-lwt --dev
|
||||
RUN opam pin add -n mirage-flow-unix --dev
|
||||
|
||||
COPY sdk.opam /src
|
||||
RUN sudo chown opam -R /src
|
||||
@ -56,14 +60,10 @@ RUN opam update sdk && opam install sdk -t
|
||||
|
||||
FROM sdk as priv
|
||||
|
||||
RUN opam depext -iy bos cmdliner
|
||||
|
||||
RUN opam list
|
||||
|
||||
COPY ./dhcp-client /src/dhcp-client
|
||||
RUN sudo chown opam -R /src
|
||||
|
||||
RUN opam config exec -- jbuilder build dhcp-client/main.exe
|
||||
RUN opam config exec -- jbuilder build --dev dhcp-client/main.exe
|
||||
RUN sudo mkdir -p /out
|
||||
RUN sudo cp /src/_build/default/dhcp-client/main.exe /out/dhcp-client
|
||||
|
||||
@ -72,18 +72,11 @@ RUN sudo cp /src/_build/default/dhcp-client/main.exe /out/dhcp-client
|
||||
|
||||
FROM sdk as calf
|
||||
|
||||
RUN opam pin add charrua-client.dev https://github.com/samoht/charrua-client.git#with-cdhcpc -n
|
||||
RUN opam pin add mirage-net-fd 0.2.0 -n
|
||||
RUN opam list
|
||||
RUN opam depext -iy mirage-net-fd charrua-client lwt mirage-types-lwt cmdliner
|
||||
|
||||
RUN opam list
|
||||
|
||||
COPY ./dhcp-client-calf/unikernel.ml /src/dhcp-client-calf/
|
||||
COPY ./dhcp-client-calf/jbuild /src/dhcp-client-calf/
|
||||
RUN sudo chown opam -R /src
|
||||
|
||||
RUN opam config exec -- jbuilder build dhcp-client-calf/unikernel.exe
|
||||
RUN opam config exec -- jbuilder build --dev dhcp-client-calf/unikernel.exe
|
||||
RUN sudo mkdir -p /out/
|
||||
RUN sudo cp /src/_build/default/dhcp-client-calf/unikernel.exe /out/dhcp-client-calf
|
||||
|
||||
|
||||
@ -53,75 +53,6 @@ let default_options =
|
||||
INTERFACE_MTU;
|
||||
]
|
||||
|
||||
(* Build a raw flow from a network interface *)
|
||||
module Raw (Net: Mirage_net_lwt.S): sig
|
||||
include Mirage_flow_lwt.S
|
||||
val connect: Net.t -> flow Lwt.t
|
||||
end = struct
|
||||
|
||||
type 'a io = 'a Net.io
|
||||
type error = Net.error
|
||||
let pp_error = Net.pp_error
|
||||
type write_error = [ Mirage_flow.write_error | `Net of Net.error ]
|
||||
|
||||
let pp_write_error ppf = function
|
||||
| #Mirage_flow.write_error as e -> Mirage_flow.pp_write_error ppf e
|
||||
| `Net e -> Net.pp_error ppf e
|
||||
|
||||
type flow = {
|
||||
netif: Net.t;
|
||||
mutable closed: bool;
|
||||
listener: unit Lwt.t;
|
||||
bufs: Cstruct.t Queue.t;
|
||||
cond: [`Eof | `Data] Lwt_condition.t;
|
||||
}
|
||||
|
||||
type buffer = Cstruct.t
|
||||
|
||||
let connect netif =
|
||||
let cond = Lwt_condition.create () in
|
||||
let bufs = Queue.create () in
|
||||
let listener =
|
||||
Net.listen netif (fun buf ->
|
||||
Queue.add buf bufs;
|
||||
Lwt_condition.signal cond `Data;
|
||||
Lwt.return_unit)
|
||||
>|= function
|
||||
| Ok () -> ()
|
||||
| Error e ->
|
||||
Log.debug (fun l -> l "net->flow listen: %a" Net.pp_error e);
|
||||
Lwt_condition.broadcast cond `Eof
|
||||
in
|
||||
Lwt.return { netif; bufs; cond; closed = false; listener }
|
||||
|
||||
let read flow =
|
||||
if flow.closed then Lwt.return (Error `Disconnected)
|
||||
else if Queue.is_empty flow.bufs then
|
||||
Lwt_condition.wait flow.cond >|= function
|
||||
| `Eof -> Ok `Eof
|
||||
| `Data -> Ok (`Data (Queue.pop flow.bufs))
|
||||
else
|
||||
Lwt.return (Ok (`Data (Queue.pop flow.bufs)))
|
||||
|
||||
let close flow =
|
||||
flow.closed <- true;
|
||||
Lwt.cancel flow.listener;
|
||||
Lwt.return_unit
|
||||
|
||||
let writev t bufs =
|
||||
if t.closed then Lwt.return (Error `Closed)
|
||||
else Net.writev t.netif bufs >|= function
|
||||
| Ok () -> Ok ()
|
||||
| Error e -> Error (`Net e)
|
||||
|
||||
let write t buf =
|
||||
if t.closed then Lwt.return (Error `Closed)
|
||||
else Net.write t.netif buf >|= function
|
||||
| Ok () -> Ok ()
|
||||
| Error e -> Error (`Net e)
|
||||
|
||||
end
|
||||
|
||||
(* FIXME: use the mirage tool *)
|
||||
|
||||
module Time = struct
|
||||
@ -210,7 +141,10 @@ let start () dhcp_codes net ctl =
|
||||
Lwt_main.run (
|
||||
Lwt_switch.with_switch @@ fun switch ->
|
||||
let net = fd net in
|
||||
let client = Capnp_rpc_lwt.CapTP.of_endpoint ~switch (Capnp_rpc_lwt.Endpoint.of_flow ~switch (module Sdk.IO) (flow ctl)) in
|
||||
let flow =
|
||||
Capnp_rpc_lwt.Endpoint.of_flow ~switch (module Mirage_flow_lwt) (flow ctl)
|
||||
in
|
||||
let client = Capnp_rpc_lwt.CapTP.of_endpoint ~switch flow in
|
||||
let ctl = Capnp_rpc_lwt.CapTP.bootstrap client in
|
||||
start () dhcp_codes net ctl
|
||||
)
|
||||
|
||||
1
projects/miragesdk/src/dhcp-client-calf/unikernel.mli
Normal file
1
projects/miragesdk/src/dhcp-client-calf/unikernel.mli
Normal file
@ -0,0 +1 @@
|
||||
(* empty *)
|
||||
@ -92,7 +92,7 @@ let run () cmd ethif path =
|
||||
Ctl.v path >>= fun db ->
|
||||
let ctl fd =
|
||||
let service = Ctl.Server.service ~routes db in
|
||||
let endpoint = Capnp_rpc_lwt.Endpoint.of_flow ~switch (module Sdk.IO) fd in
|
||||
let endpoint = Capnp_rpc_lwt.Endpoint.of_flow ~switch (module Mirage_flow_lwt) fd in
|
||||
ignore (Capnp_rpc_lwt.CapTP.of_endpoint ~switch ~offer:service endpoint)
|
||||
in
|
||||
let handlers () = Handlers.watch ~ethif db in
|
||||
|
||||
1
projects/miragesdk/src/dhcp-client/main.mli
Normal file
1
projects/miragesdk/src/dhcp-client/main.mli
Normal file
@ -0,0 +1 @@
|
||||
(* empty *)
|
||||
@ -7,7 +7,6 @@ homepage: "https://github.com/linuxkit/linuxkit"
|
||||
bug-reports: "https://github.com/linuxkit/linuxkit/issues"
|
||||
license: "Apache"
|
||||
dev-repo: "https://github.com/linuxkit/linuxkit.git"
|
||||
|
||||
build: ["jbuilder" "build" "-p" name "-j" jobs "@install"]
|
||||
depends: [
|
||||
"jbuilder" {build & >= "1.0+beta7"}
|
||||
@ -25,5 +24,10 @@ depends: [
|
||||
"rawlink"
|
||||
"tuntap" {= "1.0.0"}
|
||||
"ipaddr"
|
||||
"bos"
|
||||
"mirage-flow-rawlink"
|
||||
"mirage-net-fd"
|
||||
"charrua-client"
|
||||
"mirage-types-lwt"
|
||||
"alcotest" {test}
|
||||
]
|
||||
|
||||
@ -1,67 +0,0 @@
|
||||
open Lwt.Infix
|
||||
|
||||
let src = Logs.Src.create "IO" ~doc:"IO helpers"
|
||||
module Log = (val Logs.src_log src : Logs.LOG)
|
||||
|
||||
(* from mirage-conduit. FIXME: move to mirage-flow *)
|
||||
type 'a io = 'a Lwt.t
|
||||
type buffer = Cstruct.t
|
||||
type error = [`Msg of string]
|
||||
type write_error = [ Mirage_flow.write_error | error ]
|
||||
let pp_error ppf (`Msg s) = Fmt.string ppf s
|
||||
|
||||
let pp_write_error ppf = function
|
||||
| #Mirage_flow.write_error as e -> Mirage_flow.pp_write_error ppf e
|
||||
| #error as e -> pp_error ppf e
|
||||
|
||||
type flow =
|
||||
| Flow: string
|
||||
* (module Mirage_flow_lwt.CONCRETE with type flow = 'a)
|
||||
* 'a
|
||||
-> flow
|
||||
|
||||
let create (type a) (module M: Mirage_flow_lwt.S with type flow = a) t name =
|
||||
let m =
|
||||
(module Mirage_flow_lwt.Concrete(M):
|
||||
Mirage_flow_lwt.CONCRETE with type flow = a)
|
||||
in
|
||||
Flow (name, m , t)
|
||||
|
||||
let read (Flow (_, (module F), flow)) = F.read flow
|
||||
let write (Flow (_, (module F), flow)) b = F.write flow b
|
||||
let writev (Flow (_, (module F), flow)) b = F.writev flow b
|
||||
let close (Flow (_, (module F), flow)) = F.close flow
|
||||
let pp ppf (Flow (name, _, _)) = Fmt.string ppf name
|
||||
|
||||
type t = flow
|
||||
|
||||
let forward ?(verbose=false) ~src ~dst =
|
||||
let rec loop () =
|
||||
read src >>= function
|
||||
| Ok `Eof ->
|
||||
Log.err (fun l -> l "forward[%a => %a] EOF" pp src pp dst);
|
||||
Lwt.return_unit
|
||||
| Error e ->
|
||||
Log.err (fun l -> l "forward[%a => %a] %a" pp src pp dst pp_error e);
|
||||
Lwt.return_unit
|
||||
| Ok (`Data buf) ->
|
||||
Log.debug (fun l ->
|
||||
let payload =
|
||||
if verbose then Fmt.strf "[%S]" @@ Cstruct.to_string buf
|
||||
else Fmt.strf "%d bytes" (Cstruct.len buf)
|
||||
in
|
||||
l "forward[%a => %a] %s" pp src pp dst payload);
|
||||
write dst buf >>= function
|
||||
| Ok () -> loop ()
|
||||
| Error e ->
|
||||
Log.err (fun l -> l "forward[%a => %a] %a"
|
||||
pp src pp dst pp_write_error e);
|
||||
Lwt.return_unit
|
||||
in
|
||||
loop ()
|
||||
|
||||
let proxy ?verbose f1 f2 =
|
||||
Lwt.join [
|
||||
forward ?verbose ~src:f1 ~dst:f2;
|
||||
forward ?verbose ~src:f2 ~dst:f1;
|
||||
]
|
||||
@ -1,25 +0,0 @@
|
||||
(** IO helpers *)
|
||||
|
||||
type t
|
||||
(** The type for IO flows *)
|
||||
|
||||
include Mirage_flow_lwt.S with type flow = t
|
||||
|
||||
val create: (module Mirage_flow_lwt.S with type flow = 'a) -> 'a -> string -> flow
|
||||
(** [create (module M) t name] is the flow representing [t] using the
|
||||
function defined in [M]. *)
|
||||
|
||||
val pp: flow Fmt.t
|
||||
(** [pp] is the pretty-printer for IO flows. *)
|
||||
|
||||
val forward: ?verbose:bool -> src:t -> dst:t -> unit Lwt.t
|
||||
(** [forward ?verbose ~src ~dst] forwards writes from [src] to
|
||||
[dst]. Block until either [src] or [dst] is closed. If [verbose]
|
||||
is set (by default it is not), show the raw flow in debug mode,
|
||||
otherwise just show the lenght. *)
|
||||
|
||||
val proxy: ?verbose:bool -> t -> t -> unit Lwt.t
|
||||
(** [proxy ?verbose x y] is the same as [forward x y <*> forward y
|
||||
x]. Block until both flows are closed. If [verbose] is set (by
|
||||
default it is not), show the raw flow in debug mode, otherwise
|
||||
just show the lenght. *)
|
||||
@ -34,7 +34,7 @@ let () =
|
||||
(* FIXME: inotify need some unknown massaging. *)
|
||||
(* Irmin_watcher.hook *)
|
||||
|
||||
module C = Mirage_channel_lwt.Make(IO)
|
||||
module C = Mirage_channel_lwt.Make(Mirage_flow_lwt)
|
||||
|
||||
exception Undefined_field of int
|
||||
|
||||
|
||||
@ -5,113 +5,13 @@ module Log = (val Logs.src_log src : Logs.LOG)
|
||||
|
||||
let failf fmt = Fmt.kstrf Lwt.fail_with fmt
|
||||
|
||||
let pp_fd ppf (t:Lwt_unix.file_descr) =
|
||||
Fmt.int ppf (Obj.magic (Lwt_unix.unix_file_descr t): int)
|
||||
|
||||
let rec really_write fd buf off len =
|
||||
match len with
|
||||
| 0 -> Lwt.return_unit
|
||||
| len ->
|
||||
Log.debug (fun l -> l "really_write %a off=%d len=%d" pp_fd fd off len);
|
||||
Lwt_unix.write fd buf off len >>= fun n ->
|
||||
if n = 0 then Lwt.fail_with "write 0"
|
||||
else really_write fd buf (off+n) (len-n)
|
||||
|
||||
let write_all fd buf = really_write fd buf 0 (String.length buf)
|
||||
|
||||
let read_all fd =
|
||||
Log.debug (fun l -> l "read_all %a" pp_fd fd);
|
||||
let len = 16 * 1024 in
|
||||
let buf = Bytes.create len in
|
||||
let rec loop acc =
|
||||
Lwt_unix.read fd buf 0 len >>= fun n ->
|
||||
if n = 0 then failf "read %a: 0" pp_fd fd
|
||||
else
|
||||
let acc = String.sub buf 0 n :: acc in
|
||||
if n <= len then Lwt.return (List.rev acc)
|
||||
else loop acc
|
||||
in
|
||||
loop [] >|= fun bufs ->
|
||||
String.concat "" bufs
|
||||
|
||||
module Flow = struct
|
||||
|
||||
(* build a flow from Lwt_unix.file_descr *)
|
||||
module Fd: Mirage_flow_lwt.CONCRETE with type flow = Lwt_unix.file_descr = struct
|
||||
type 'a io = 'a Lwt.t
|
||||
type buffer = Cstruct.t
|
||||
type error = [`Msg of string]
|
||||
type write_error = [ Mirage_flow.write_error | error ]
|
||||
|
||||
let pp_error ppf (`Msg s) = Fmt.string ppf s
|
||||
|
||||
let pp_write_error ppf = function
|
||||
| #Mirage_flow.write_error as e -> Mirage_flow.pp_write_error ppf e
|
||||
| #error as e -> pp_error ppf e
|
||||
|
||||
type flow = Lwt_unix.file_descr
|
||||
|
||||
let err e = Lwt.return (Error (`Msg (Printexc.to_string e)))
|
||||
|
||||
let read t =
|
||||
Lwt.catch (fun () ->
|
||||
read_all t >|= fun buf -> Ok (`Data (Cstruct.of_string buf))
|
||||
) (function Failure _ -> Lwt.return (Ok `Eof) | e -> err e)
|
||||
|
||||
let write t b =
|
||||
Lwt.catch (fun () ->
|
||||
write_all t (Cstruct.to_string b) >|= fun () -> Ok ()
|
||||
) (fun e -> err e)
|
||||
|
||||
let close t = Lwt_unix.close t
|
||||
|
||||
let writev t bs =
|
||||
Lwt.catch (fun () ->
|
||||
Lwt_list.iter_s (fun b -> write_all t (Cstruct.to_string b)) bs
|
||||
>|= fun () -> Ok ()
|
||||
) (fun e -> err e)
|
||||
end
|
||||
|
||||
(* build a flow from rawlink *)
|
||||
module Rawlink: Mirage_flow_lwt.CONCRETE with type flow = Lwt_rawlink.t = struct
|
||||
type 'a io = 'a Lwt.t
|
||||
type buffer = Cstruct.t
|
||||
type error = [`Msg of string]
|
||||
type write_error = [ Mirage_flow.write_error | error ]
|
||||
|
||||
let pp_error ppf (`Msg s) = Fmt.string ppf s
|
||||
|
||||
let pp_write_error ppf = function
|
||||
| #Mirage_flow.write_error as e -> Mirage_flow.pp_write_error ppf e
|
||||
| #error as e -> pp_error ppf e
|
||||
|
||||
type flow = Lwt_rawlink.t
|
||||
|
||||
let err e = Lwt.return (Error (`Msg (Printexc.to_string e)))
|
||||
|
||||
let read t =
|
||||
Lwt.catch (fun () ->
|
||||
Lwt_rawlink.read_packet t >|= fun buf -> Ok (`Data buf)
|
||||
) (function Failure _ -> Lwt.return (Ok `Eof) | e -> err e)
|
||||
|
||||
let write t b =
|
||||
Lwt.catch (fun () ->
|
||||
Lwt_rawlink.send_packet t b >|= fun () -> Ok ()
|
||||
) (fun e -> err e)
|
||||
|
||||
let close t = Lwt_rawlink.close_link t
|
||||
|
||||
let writev t bs =
|
||||
Lwt.catch (fun () ->
|
||||
Lwt_list.iter_s (Lwt_rawlink.send_packet t) bs >|= fun () -> Ok ()
|
||||
) (fun e -> err e)
|
||||
end
|
||||
|
||||
let int_of_fd t =
|
||||
(Obj.magic (Lwt_unix.unix_file_descr t): int)
|
||||
|
||||
let fd ?name t =
|
||||
IO.create (module Fd) t (match name with
|
||||
Mirage_flow_lwt.create (module Mirage_flow_unix.Fd) t (match name with
|
||||
| None -> string_of_int (int_of_fd t)
|
||||
| Some n -> n)
|
||||
|
||||
@ -124,7 +24,7 @@ let rawlink ?filter ethif =
|
||||
(try Tuntap.set_up_and_running ethif
|
||||
with e -> Log.err (fun l -> l "rawlink: %a" Fmt.exn e));
|
||||
let t = Lwt_rawlink.open_link ?filter ethif in
|
||||
IO.create (module Flow.Rawlink) t ethif
|
||||
Mirage_flow_lwt.create (module Mirage_flow_rawlink) t ethif
|
||||
|
||||
module Fd = struct
|
||||
|
||||
@ -293,11 +193,11 @@ let exec_and_forward ?(handlers=block_for_ever) ~pid ~cmd ~net ~ctl t =
|
||||
Lwt.pick ([
|
||||
wait ();
|
||||
(* data *)
|
||||
IO.proxy ~verbose:true net priv_net;
|
||||
Mirage_flow_lwt.proxy ~verbose:true net priv_net;
|
||||
|
||||
(* redirect the calf stdout to the shim stdout *)
|
||||
IO.forward ~verbose:false ~src:priv_stdout ~dst:Fd.(flow stdout);
|
||||
IO.forward ~verbose:false ~src:priv_stderr ~dst:Fd.(flow stderr);
|
||||
Mirage_flow_lwt.forward ~verbose:false ~src:priv_stdout ~dst:Fd.(flow stdout);
|
||||
Mirage_flow_lwt.forward ~verbose:false ~src:priv_stderr ~dst:Fd.(flow stderr);
|
||||
(* TODO: Init.Fd.forward ~src:Init.Pipe.(priv metrics)
|
||||
~dst:Init.Fd.metric; *)
|
||||
handlers ();
|
||||
|
||||
@ -43,12 +43,12 @@ module Fd: sig
|
||||
val stderr: t
|
||||
(** [stderr] is the standard error. *)
|
||||
|
||||
val flow: t -> IO.t
|
||||
val flow: t -> Mirage_flow_lwt.t
|
||||
(** [flow t] is the flow representing [t]. *)
|
||||
|
||||
end
|
||||
|
||||
val file_descr: ?name:string -> Lwt_unix.file_descr -> IO.t
|
||||
val file_descr: ?name:string -> Lwt_unix.file_descr -> Mirage_flow_lwt.t
|
||||
(** [file_descr ?name fd] is the flow for the file-descripor [fd]. *)
|
||||
|
||||
module Pipe: sig
|
||||
@ -96,7 +96,7 @@ module Pipe: sig
|
||||
|
||||
end
|
||||
|
||||
val rawlink: ?filter:string -> string -> IO.t
|
||||
val rawlink: ?filter:string -> string -> Mirage_flow_lwt.t
|
||||
(** [rawlink ?filter x] is the flow using the network interface
|
||||
[x]. The packets can be filtered using the BPF filter
|
||||
[filter]. See the documentation of
|
||||
@ -110,7 +110,7 @@ val exec: Pipe.monitor -> string list -> (int -> unit Lwt.t) -> unit Lwt.t
|
||||
|
||||
(* FIXME(samoht): not very happy with that signatue *)
|
||||
val run: Pipe.monitor ->
|
||||
net:IO.t -> ctl:(IO.t -> unit) ->
|
||||
net:Mirage_flow_lwt.t -> ctl:(Mirage_flow_lwt.t -> unit) ->
|
||||
?handlers:(unit -> unit Lwt.t) ->
|
||||
string list -> unit Lwt.t
|
||||
(** [run m ~net ~ctl ?handlers cmd] runs [cmd] in a unprivileged calf
|
||||
|
||||
@ -6,7 +6,8 @@
|
||||
(flags (:standard -w -53-55))
|
||||
(libraries (cstruct.lwt decompress irmin irmin-git lwt.unix rawlink
|
||||
tuntap astring rresult mirage-flow-lwt capnp capnp-rpc-lwt
|
||||
mirage-channel-lwt io-page.unix ipaddr))))
|
||||
mirage-channel-lwt io-page.unix ipaddr mirage-flow-unix
|
||||
mirage-flow-rawlink))))
|
||||
|
||||
(rule
|
||||
((targets (proto.ml proto.mli))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user