From c33c21033b48e247949c66e450ea6db662bfc179 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 26 Nov 2018 23:46:47 +0100 Subject: [PATCH 1/4] mirage-net 2.0.0 changes: - provide mtu : t -> int - remove writev - write API changes --- mirage-net-unix.opam | 9 ++--- src/dune | 2 +- src/netif.ml | 86 ++++++++++++++++++++++---------------------- 3 files changed, 49 insertions(+), 48 deletions(-) diff --git a/mirage-net-unix.opam b/mirage-net-unix.opam index a808b0e..1b37271 100644 --- a/mirage-net-unix.opam +++ b/mirage-net-unix.opam @@ -13,17 +13,18 @@ depends: [ "cstruct" {>= "1.7.1"} "cstruct-lwt" "lwt" {>= "2.4.3"} - "mirage-net-lwt" {>= "1.0.0"} - "io-page-unix" {>= "2.0.0"} - "tuntap" {>= "1.3.0"} + "mirage-net-lwt" {>= "2.0.0"} + "tuntap" {>= "1.8.0"} "alcotest" {with-test} + "logs" + "macaddr" ] build: [ ["dune" "subst"] {pinned} ["dune" "build" "-p" name "-j" jobs] ] dev-repo: "git+https://github.com/mirage/mirage-net-unix.git" -synopsis: "Unix implementation of the Mirage NETWORK interface" +synopsis: "Unix implementation of the Mirage_net_lwt interface" description: """ This interface exposes raw Ethernet frames using `ocaml-tuntap`, suitable for use with an OCaml network stack such as the one diff --git a/src/dune b/src/dune index ffa17ec..10330e9 100644 --- a/src/dune +++ b/src/dune @@ -1,5 +1,5 @@ (library (name mirage_net_unix) (public_name mirage-net-unix) - (libraries io-page-unix cstruct cstruct-lwt lwt.unix mirage-net-lwt tuntap) + (libraries logs macaddr cstruct cstruct-lwt lwt.unix mirage-net-lwt tuntap) (wrapped false)) diff --git a/src/netif.ml b/src/netif.ml index 1efd58c..ad062d8 100644 --- a/src/netif.ml +++ b/src/netif.ml @@ -14,15 +14,13 @@ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +open Lwt.Infix [@@@warning "-52"] -open Result open Mirage_net -let log fmt = Format.printf ("Netif: " ^^ fmt ^^ "\n%!") - -let (>>=) = Lwt.(>>=) -let (>|=) = Lwt.(>|=) +let src = Logs.Src.create "netif" ~doc:"Mirage unix network module" +module Log = (val Logs.src_log src : Logs.LOG) type +'a io = 'a Lwt.t @@ -30,27 +28,26 @@ type t = { id: string; dev: Lwt_unix.file_descr; mutable active: bool; - mutable mac: Macaddr.t; + mac: Macaddr.t; + mtu : int; stats : Mirage_net.stats; } let fd t = t.dev type error = [ - | Mirage_net.error + | Mirage_net.Net.error | `Partial of string * int * Cstruct.t | `Exn of exn ] let pp_error ppf = function - | #Mirage_net.error as e -> Mirage_net.pp_error ppf e + | #Mirage_net.Net.error as e -> Mirage_net.Net.pp_error ppf e | `Partial (id, len', buffer) -> Fmt.pf ppf "netif %s: partial write (%d, expected %d)" id len' buffer.Cstruct.len | `Exn e -> Fmt.exn ppf e -let devices = Hashtbl.create 1 - let err_permission_denied devname = Printf.sprintf "Permission denied while opening the %s device. Please re-run using sudo." @@ -63,14 +60,15 @@ let connect devname = let dev = Lwt_unix.of_unix_file_descr ~blocking:true fd in let mac = Macaddr.make_local (fun _ -> Random.int 256) in Tuntap.set_up_and_running devname; - log "plugging into %s with mac %s" devname (Macaddr.to_string mac); + let mtu = Tuntap.get_mtu devname in + Log.debug (fun m -> m "plugging into %s with mac %a and mtu %d" + devname Macaddr.pp mac mtu); let active = true in let t = { - id=devname; dev; active; mac; + id=devname; dev; active; mac; mtu; stats= { rx_bytes=0L;rx_pkts=0l; tx_bytes=0L; tx_pkts=0l } } in - Hashtbl.add devices devname t; - log "connect %s" devname; + Log.info (fun m -> m "connect %s with mac %a" devname Macaddr.pp mac); Lwt.return t with | Failure "tun[open]: Permission denied" -> @@ -78,19 +76,17 @@ let connect devname = | exn -> Lwt.fail exn let disconnect t = - log "disconnect %s" t.id; + Log.info (fun m -> m "disconnect %s" t.id); t.active <- false; Lwt_unix.close t.dev >>= fun () -> Tuntap.closetap t.id; Lwt.return_unit type macaddr = Macaddr.t -type page_aligned_buffer = Io_page.t type buffer = Cstruct.t (* Input a frame, and block if nothing is available *) -let rec read t page = - let buf = Io_page.to_cstruct page in +let rec read t buf = let process () = Lwt.catch (fun () -> Lwt_cstruct.read t.dev buf >|= function @@ -103,17 +99,17 @@ let rec read t page = Ok buf) (function | Unix.Unix_error(Unix.ENXIO, _, _) -> - log "[read] device %s is down, stopping" t.id; + Log.err (fun m -> m "[read] device %s is down, stopping" t.id); Lwt.return (Error `Disconnected) | Lwt.Canceled -> - log "[read] user program requested cancellation of listen on %s" t.id; + Log.err (fun m -> m "[read] user program requested cancellation of listen on %s" t.id); Lwt.return (Error `Canceled) | exn -> - log "[read] error: %s, continuing" (Printexc.to_string exn); + Log.err (fun m -> m "[read] error: %s, continuing" (Printexc.to_string exn)); Lwt.return (Error `Continue)) in process () >>= function - | Error `Continue -> read t page + | Error `Continue -> read t buf | Error `Canceled -> Lwt.return (Error `Canceled) | Error `Disconnected -> Lwt.return (Error `Disconnected) | Ok buf -> Lwt.return (Ok buf) @@ -122,10 +118,11 @@ let safe_apply f x = Lwt.catch (fun () -> f x) (fun exn -> - log "[listen] error while handling %s, continuing. bt: %s" - (Printexc.to_string exn) (Printexc.get_backtrace ()); + Log.err (fun m -> m "[listen] error while handling %s, continuing. bt: %s" + (Printexc.to_string exn) (Printexc.get_backtrace ())); Lwt.return_unit) + (* Loop and listen for packets permanently *) (* this function has to be tail recursive, since it is called at the top level, otherwise memory of received packets and all reachable @@ -133,9 +130,9 @@ let safe_apply f x = let rec listen t fn = match t.active with | true -> - let page = Io_page.get 1 in + let buf = Cstruct.create (t.mtu + 14) in let process () = - read t page >|= function + read t buf >|= function | Ok buf -> Lwt.async (fun () -> safe_apply fn buf) ; Ok () | Error `Canceled -> Error `Disconnected | Error `Disconnected -> t.active <- false ; Error `Disconnected @@ -146,27 +143,30 @@ let rec listen t fn = | false -> Lwt.return (Ok ()) (* Transmit a packet from a Cstruct.t *) -let write t buffer = - let open Cstruct in - (* Unfortunately we peek inside the cstruct type here: *) +let write t ?size fillf = (* This is the interface to the cruel Lwt world with exceptions, we've to guard *) - Lwt.catch (fun () -> - Lwt_bytes.write t.dev buffer.buffer buffer.off buffer.len >|= fun len' -> - t.stats.tx_pkts <- Int32.succ t.stats.tx_pkts; - t.stats.tx_bytes <- Int64.add t.stats.tx_bytes (Int64.of_int buffer.len); - if len' <> buffer.len then Error (`Partial (t.id, len', buffer)) - else Ok ()) - (fun exn -> Lwt.return (Error (`Exn exn))) - - -let writev t = function - | [] -> Lwt.return (Ok ()) - | [page] -> write t page - | pages -> - write t @@ Cstruct.concat pages + let size = match size with None -> t.mtu | Some s -> s in + if size > t.mtu then + Lwt.return (Error `Exceeds_mtu) + else + let size = 14 + size in + let buf = Cstruct.create size in + let len = 14 + fillf buf in + if len > size then + Lwt.return (Error `Invalid_length) + else + Lwt.catch (fun () -> + Lwt_bytes.write t.dev buf.Cstruct.buffer 0 len >|= fun len' -> + t.stats.tx_pkts <- Int32.succ t.stats.tx_pkts; + t.stats.tx_bytes <- Int64.add t.stats.tx_bytes (Int64.of_int len); + if len' <> len then Error (`Partial (t.id, len', buf)) + else Ok ()) + (fun exn -> Lwt.return (Error (`Exn exn))) let mac t = t.mac +let mtu t = t.mtu + let get_stats_counters t = t.stats let reset_stats_counters t = From 357ec726ad6b71a4655a03405dea540944a2cbb1 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 8 Feb 2019 22:31:24 +0100 Subject: [PATCH 2/4] temporarily add layering remote --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index a7ca57f..2b5d052 100644 --- a/.travis.yml +++ b/.travis.yml @@ -7,6 +7,7 @@ script: bash -ex ./.travis-docker.sh env: global: - PACKAGE="mirage-net-unix" + - EXTRA_REMOTES="https://github.com/mirage/mirage-dev.git#layering" matrix: - DISTRO="alpine" OCAML_VERSION="4.04" - DISTRO="alpine" OCAML_VERSION="4.05" From 51a109356f5d9d09fc02828d51ab5fb3d140bc9e Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 14 Feb 2019 12:17:05 +0100 Subject: [PATCH 3/4] introduce ethernet_header_size instead of hardcoding 14 all over the place --- src/netif.ml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/netif.ml b/src/netif.ml index ad062d8..fa12c7c 100644 --- a/src/netif.ml +++ b/src/netif.ml @@ -24,6 +24,8 @@ module Log = (val Logs.src_log src : Logs.LOG) type +'a io = 'a Lwt.t +let ethernet_header_size = 14 + type t = { id: string; dev: Lwt_unix.file_descr; @@ -130,7 +132,7 @@ let safe_apply f x = let rec listen t fn = match t.active with | true -> - let buf = Cstruct.create (t.mtu + 14) in + let buf = Cstruct.create (t.mtu + ethernet_header_size) in let process () = read t buf >|= function | Ok buf -> Lwt.async (fun () -> safe_apply fn buf) ; Ok () @@ -149,9 +151,9 @@ let write t ?size fillf = if size > t.mtu then Lwt.return (Error `Exceeds_mtu) else - let size = 14 + size in + let size = ethernet_header_size + size in let buf = Cstruct.create size in - let len = 14 + fillf buf in + let len = ethernet_header_size + fillf buf in if len > size then Lwt.return (Error `Invalid_length) else From 15ca39d4ecd81df0296d8eb1ec9f5acee0bc1cfd Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 14 Feb 2019 20:30:24 +0100 Subject: [PATCH 4/4] adapt to newer mirage-net API --- src/netif.ml | 37 +++++++++++++++---------------------- test/test.ml | 6 +++--- 2 files changed, 18 insertions(+), 25 deletions(-) diff --git a/src/netif.ml b/src/netif.ml index fa12c7c..89f0a1f 100644 --- a/src/netif.ml +++ b/src/netif.ml @@ -24,8 +24,6 @@ module Log = (val Logs.src_log src : Logs.LOG) type +'a io = 'a Lwt.t -let ethernet_header_size = 14 - type t = { id: string; dev: Lwt_unix.file_descr; @@ -129,10 +127,10 @@ let safe_apply f x = (* this function has to be tail recursive, since it is called at the top level, otherwise memory of received packets and all reachable data is never claimed. take care when modifying, here be dragons! *) -let rec listen t fn = +let rec listen t ~header_size fn = match t.active with | true -> - let buf = Cstruct.create (t.mtu + ethernet_header_size) in + let buf = Cstruct.create (t.mtu + header_size) in let process () = read t buf >|= function | Ok buf -> Lwt.async (fun () -> safe_apply fn buf) ; Ok () @@ -140,30 +138,25 @@ let rec listen t fn = | Error `Disconnected -> t.active <- false ; Error `Disconnected in process () >>= (function - | Ok () -> (listen[@tailcall]) t fn + | Ok () -> (listen[@tailcall]) t ~header_size fn | Error e -> Lwt.return (Error e)) | false -> Lwt.return (Ok ()) (* Transmit a packet from a Cstruct.t *) -let write t ?size fillf = +let write t ~size fillf = (* This is the interface to the cruel Lwt world with exceptions, we've to guard *) - let size = match size with None -> t.mtu | Some s -> s in - if size > t.mtu then - Lwt.return (Error `Exceeds_mtu) + let buf = Cstruct.create size in + let len = fillf buf in + if len > size then + Lwt.return (Error `Invalid_length) else - let size = ethernet_header_size + size in - let buf = Cstruct.create size in - let len = ethernet_header_size + fillf buf in - if len > size then - Lwt.return (Error `Invalid_length) - else - Lwt.catch (fun () -> - Lwt_bytes.write t.dev buf.Cstruct.buffer 0 len >|= fun len' -> - t.stats.tx_pkts <- Int32.succ t.stats.tx_pkts; - t.stats.tx_bytes <- Int64.add t.stats.tx_bytes (Int64.of_int len); - if len' <> len then Error (`Partial (t.id, len', buf)) - else Ok ()) - (fun exn -> Lwt.return (Error (`Exn exn))) + Lwt.catch (fun () -> + Lwt_bytes.write t.dev buf.Cstruct.buffer 0 len >|= fun len' -> + t.stats.tx_pkts <- Int32.succ t.stats.tx_pkts; + t.stats.tx_bytes <- Int64.add t.stats.tx_bytes (Int64.of_int len); + if len' <> len then Error (`Partial (t.id, len', buf)) + else Ok ()) + (fun exn -> Lwt.return (Error (`Exn exn))) let mac t = t.mac diff --git a/test/test.ml b/test/test.ml index 9b72af8..f83701e 100644 --- a/test/test.ml +++ b/test/test.ml @@ -34,9 +34,9 @@ let test_close () = let test_write () = Netif.connect "tap2" >>= fun t -> - let data = Cstruct.create 4096 in - Netif.writev t [ data ] >>= fun _t -> - Netif.writev t [ data ; (Cstruct.create 14) ] >>= fun _t -> + let mtu = Netif.mtu t in + Netif.write t ~size:mtu (fun _data -> mtu) >>= fun _t -> + Netif.write t ~size:(mtu + 14) (fun _data -> mtu + 14) >>= fun _t -> Lwt.return_unit let suite = [