mirror of
https://github.com/linuxkit/linuxkit.git
synced 2025-07-19 17:26:28 +00:00
sdk: use upstream libraires for SDK helpers
- IO has been upstreamed in mirage-flow-lwt - Init.Flow.Fd has been upstreamed in mirage-flow-unix - Init.Flow.Rawlink has been upstreamed in mirage-flow-rawlink - Remove some dead-code in unikernel.ml Signed-off-by: Thomas Gazagnaire <thomas@gazagnaire.org>
This commit is contained in:
Thomas Gazagnaire
parent
98028d417b
commit
852468bc99
@ -210,7 +210,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
|
||||
)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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