diff --git a/.travis.yml b/.travis.yml index b27eb4d..3c4bc68 100644 --- a/.travis.yml +++ b/.travis.yml @@ -8,7 +8,7 @@ env: global: - TESTS=true - PINS="charrua-core.dev:. charrua-unix.dev:. charrua-client.dev:. charrua-client-lwt.dev:. charrua-client-mirage.dev:." - - EXTRA_REMOTES="https://github.com/mirage/mirage-dev.git" + - EXTRA_REMOTES="https://github.com/mirage/mirage-dev.git#layering" matrix: - DISTRO="alpine" OCAML_VERSION="4.06" PACKAGE="charrua-client" - DISTRO="alpine" OCAML_VERSION="4.06" PACKAGE="charrua-client-lwt" diff --git a/charrua-client-lwt.opam b/charrua-client-lwt.opam index feb6229..4034724 100644 --- a/charrua-client-lwt.opam +++ b/charrua-client-lwt.opam @@ -18,15 +18,15 @@ depends: [ "ocaml" {>= "4.04.2"} "alcotest" {with-test} "cstruct-unix" {with-test} - "charrua-core" {>= "0.11.1"} - "charrua-client" {>= "0.11.1"} + "charrua-core" {>= "0.12.0"} + "charrua-client" {>= "0.12.0"} "cstruct" {>="3.0.2"} "ipaddr" {>="3.0.0"} "rresult" "mirage-random" {>= "1.0.0"} "duration" "mirage-time-lwt" - "mirage-net-lwt" + "mirage-net-lwt" {>= "2.0.0"} "logs" "tcpip" {>= "3.6.0"} "fmt" diff --git a/charrua-client-mirage.opam b/charrua-client-mirage.opam index 3815c01..7fe8833 100644 --- a/charrua-client-mirage.opam +++ b/charrua-client-mirage.opam @@ -15,9 +15,9 @@ build: [ depends: [ "dune" {build & >= "1.0"} "ocaml" {>= "4.04.2"} - "charrua-core" {>= "0.11.1"} - "charrua-client-lwt" {>= "0.11.1"} - "charrua-client" {>= "0.11.1"} + "charrua-core" {>= "0.12.0"} + "charrua-client-lwt" {>= "0.12.0"} + "charrua-client" {>= "0.12.0"} "cstruct" {>="3.0.2"} "ipaddr" {>= "3.0.0"} "rresult" diff --git a/charrua-client.opam b/charrua-client.opam index 9cf740a..161bb25 100644 --- a/charrua-client.opam +++ b/charrua-client.opam @@ -19,7 +19,7 @@ depends: [ "alcotest" {with-test} "cstruct-unix" {with-test} "mirage-random-test" {with-test} - "charrua-core" {>= "0.11.1"} + "charrua-core" {>= "0.12.0"} "cstruct" {>="3.0.2"} "ipaddr" "macaddr" diff --git a/charrua-core.opam b/charrua-core.opam index 955da1d..5b8cd03 100644 --- a/charrua-core.opam +++ b/charrua-core.opam @@ -26,7 +26,6 @@ depends: [ "ethernet" "tcpip" {>= "3.7.0"} "rresult" - "io-page-unix" {with-test} "cstruct-unix" {with-test} ] synopsis: "DHCP wire frame encoder and decoder" diff --git a/charrua-unix.opam b/charrua-unix.opam index ee89c9b..903e7ab 100644 --- a/charrua-unix.opam +++ b/charrua-unix.opam @@ -14,7 +14,7 @@ depends: [ "ocaml" {>= "4.03.0"} "lwt" {>="3.0.0"} "lwt_log" - "charrua-core" {>= "0.11.0"} + "charrua-core" {>= "0.12.0"} "cstruct-unix" "cmdliner" "rawlink" {>= "1.0"} diff --git a/client/dhcp_client.ml b/client/dhcp_client.ml index 3c18127..d3727f3 100644 --- a/client/dhcp_client.ml +++ b/client/dhcp_client.ml @@ -23,8 +23,6 @@ type t = { state : state; } -type buffer = Cstruct.t - (* constant fields are represented here for convenience. This module can then be locally opened where required *) module Constants = struct @@ -172,8 +170,7 @@ let create ?requests xid srcmac = Parameter_requests requests; ]; } in - {srcmac; request_options = requests; state = Selecting pkt}, - Dhcp_wire.buf_of_pkt pkt + {srcmac; request_options = requests; state = Selecting pkt}, pkt (* for a DHCP client, figure out whether an incoming packet should modify the state, and if a response message is warranted, generate it. @@ -202,7 +199,7 @@ let input t buf = ~xid:dhcpdiscover.xid ~chaddr:dhcpdiscover.chaddr in `Response ({t with state = Requesting (incoming, dhcprequest)}, - (Dhcp_wire.buf_of_pkt dhcprequest)) + dhcprequest) | Some DHCPOFFER, _ -> (* DHCPOFFER is irrelevant when we're not selecting *) `Noop | Some DHCPACK, Renewing _ @@ -229,11 +226,11 @@ let input t buf = (* try to renew the lease, probably because some time has elapsed. *) let renew t = match t.state with | Selecting _ | Requesting _ -> `Noop - | Renewing (_lease, request) -> `Response (t, Dhcp_wire.buf_of_pkt request) + | Renewing (_lease, request) -> `Response (t, request) | Bound lease -> let open Dhcp_wire in let request = offer t ~xid:lease.xid ~chaddr:lease.chaddr ~server_ip:lease.siaddr ~request_ip:lease.yiaddr ~offer_options:lease.options in let state = Renewing (lease, request) in - `Response ({t with state = state}, (Dhcp_wire.buf_of_pkt request)) + `Response ({t with state = state}, request) diff --git a/client/dhcp_client.mli b/client/dhcp_client.mli index b7acda0..82f39cf 100644 --- a/client/dhcp_client.mli +++ b/client/dhcp_client.mli @@ -1,10 +1,9 @@ type t -type buffer = Cstruct.t (** we expect all serialization and deserialization to happen through Cstruct.t *) val pp : Format.formatter -> t -> unit -val create : ?requests : Dhcp_wire.option_code list -> Cstruct.uint32 -> Macaddr.t -> (t * buffer) +val create : ?requests : Dhcp_wire.option_code list -> Cstruct.uint32 -> Macaddr.t -> (t * Dhcp_wire.pkt) (** [create xid mac] returns a pair of [t, buffer]. [t] represents the current * state of the client in the lease transaction, and [buffer] is the suggested * next packet the caller should take to progress toward accepting a lease. @@ -15,7 +14,7 @@ val create : ?requests : Dhcp_wire.option_code list -> Cstruct.uint32 -> Macaddr * guess rather than requesting nothing. *) -val input : t -> buffer -> [`Response of (t * buffer) | `New_lease of (t * Dhcp_wire.pkt) | `Noop ] +val input : t -> Cstruct.t -> [`Response of t * Dhcp_wire.pkt | `New_lease of t * Dhcp_wire.pkt | `Noop ] (** [input t buf] attempts to advance the state of [t] * with the contents of [buf]. If [buf] is invalid or not useful given * the current state of [t], [`Noop] is returned indicating no action should be taken. @@ -32,7 +31,7 @@ val lease : t -> Dhcp_wire.pkt option * necessary. * If [t] hasn't yet completed a lease transaction, [None] will be returned. *) -val renew : t -> [`Response of (t * buffer) | `Noop] +val renew : t -> [`Response of t * Dhcp_wire.pkt | `Noop] (** [renew t] returns either a [`Response] with the next state and suggested action * of the client attempting to renew [t]'s lease, * or [`Noop] if [t] does not have a lease and therefore can't be renewed. *) diff --git a/client/lwt/dhcp_client_lwt.ml b/client/lwt/dhcp_client_lwt.ml index 452140a..d05aa99 100644 --- a/client/lwt/dhcp_client_lwt.ml +++ b/client/lwt/dhcp_client_lwt.ml @@ -14,6 +14,8 @@ module Make(Random : Mirage_random.C)(Time : Mirage_time_lwt.S) (Net : Mirage_ne (* listener needs to occasionally check to see whether the state has advanced, * and if not, start a new attempt at a lease transaction *) let sleep_interval = Duration.of_sec 4 in + let header_size = Ethernet_wire.sizeof_ethernet in + let size = Net.mtu net + header_size in let xid = match xid with | None -> Cstruct.BE.get_uint32 (Random.generate 4) 0 @@ -26,9 +28,9 @@ module Make(Random : Mirage_random.C)(Time : Mirage_time_lwt.S) (Net : Mirage_ne Time.sleep_ns @@ Duration.of_sec t >>= fun () -> match Dhcp_client.renew c with | `Noop -> Log.debug (fun f -> f "Can't renew this lease; won't try"); Lwt.return_unit - | `Response (c, buf) -> + | `Response (c, pkt) -> Log.debug (fun f -> f "attempted to renew lease: %a" Dhcp_client.pp c); - Net.write net buf >>= function + Net.write net ~size (Dhcp_wire.pkt_into_buf pkt) >>= function | Error e -> Log.err (fun f -> f "Failed to write lease renewal request: %a" Net.pp_error e); Lwt.return_unit @@ -37,7 +39,7 @@ module Make(Random : Mirage_random.C)(Time : Mirage_time_lwt.S) (Net : Mirage_ne in let rec get_lease push dhcpdiscover = Log.debug (fun f -> f "Sending DHCPDISCOVER..."); - Net.write net dhcpdiscover >>= function + Net.write net ~size (Dhcp_wire.pkt_into_buf dhcpdiscover) >>= function | Error e -> Log.err (fun f -> f "Failed to write initial lease discovery request: %a" Net.pp_error e); Lwt.return_unit @@ -54,27 +56,27 @@ module Make(Random : Mirage_random.C)(Time : Mirage_time_lwt.S) (Net : Mirage_ne get_lease push dhcpdiscover in let listen push () = - Net.listen net (fun buf -> + Net.listen net ~header_size (fun buf -> match Dhcp_client.input !c buf with | `Noop -> Log.debug (fun f -> f "No action! State is %a" Dhcp_client.pp !c); Lwt.return_unit | `Response (s, action) -> begin - Net.write net action >>= function - | Error e -> - Log.err (fun f -> f "Failed to write lease transaction response: %a" Net.pp_error e); - Lwt.return_unit - | Ok () -> - Log.debug (fun f -> f "State advanced! Now %a" Dhcp_client.pp s); - c := s; - Lwt.return_unit + Net.write net ~size (Dhcp_wire.pkt_into_buf action) >>= function + | Error e -> + Log.err (fun f -> f "Failed to write lease transaction response: %a" Net.pp_error e); + Lwt.return_unit + | Ok () -> + Log.debug (fun f -> f "State advanced! Now %a" Dhcp_client.pp s); + c := s; + Lwt.return_unit end | `New_lease (s, l) -> let open Dhcp_wire in (* a lease is obtained! Note it, and replace the current listener *) Log.info (fun f -> f "Lease obtained! IP: %a, routers: %a" - Ipaddr.V4.pp l.yiaddr - (Fmt.list Ipaddr.V4.pp) (collect_routers l.options)); + Ipaddr.V4.pp l.yiaddr + (Fmt.list Ipaddr.V4.pp) (collect_routers l.options)); push @@ Some l; c := s; match renew with diff --git a/lib/dhcp_wire.ml b/lib/dhcp_wire.ml index 5c8441e..16b6aaa 100644 --- a/lib/dhcp_wire.ml +++ b/lib/dhcp_wire.ml @@ -1051,8 +1051,8 @@ let pkt_of_buf buf len = (* Handle ethernet *) Ethernet_packet.Unmarshal.of_cstruct buf >>= fun (eth_header, eth_payload) -> match eth_header.Ethernet_packet.ethertype with - | Ethernet_wire.ARP | Ethernet_wire.IPv6 -> Error "packet is not ipv4" - | Ethernet_wire.IPv4 -> + | `ARP | `IPv6 -> Error "packet is not ipv4" + | `IPv4 -> Ipv4_packet.Unmarshal.of_cstruct eth_payload >>= fun (ipv4_header, ipv4_payload) -> match Ipv4_packet.Unmarshal.int_to_protocol ipv4_header.Ipv4_packet.proto with @@ -1103,9 +1103,10 @@ let pkt_of_buf buf len = in try wrap () with | Invalid_argument e -> Error e -let buf_of_pkt pkt = - (* TODO mtu *) - let dhcp = Cstruct.create 2048 in +let pkt_into_buf pkt buf = + let eth, rest = Cstruct.split buf Ethernet_wire.sizeof_ethernet in + let ip, rest' = Cstruct.split rest Ipv4_wire.sizeof_ipv4 in + let udp, dhcp = Cstruct.split rest' Udp_wire.sizeof_udp in set_dhcp_op dhcp (op_to_int pkt.op); set_dhcp_htype dhcp (if pkt.htype = Ethernet_10mb then @@ -1127,10 +1128,10 @@ let buf_of_pkt pkt = set_dhcp_file (Util.string_extend_if_le pkt.file 128) 0 dhcp; let options_start = Cstruct.shift dhcp sizeof_dhcp in let options_end = buf_of_options options_start pkt.options in - let partial_len = (Cstruct.len dhcp) - (Cstruct.len options_end) in + let partial_len = Cstruct.len dhcp - Cstruct.len options_end in let buf_end = - if 300 - partial_len > 0 then - let pad_len = 300 - partial_len in + let pad_len = 300 - partial_len in + if pad_len > 0 then let () = for i = 0 to pad_len do Cstruct.set_uint8 options_end i 0 @@ -1140,39 +1141,52 @@ let buf_of_pkt pkt = else options_end in - let dhcp = Cstruct.set_len dhcp ((Cstruct.len dhcp) - (Cstruct.len buf_end)) in + let dhcp = Cstruct.sub dhcp 0 (Cstruct.len dhcp - Cstruct.len buf_end) in (* Ethernet *) - let ethernet = Ethernet_packet.(Marshal.make_cstruct - { source = pkt.srcmac; - destination = pkt.dstmac; - ethertype = Ethernet_wire.IPv4; }) - in + (match Ethernet_packet.(Marshal.into_cstruct + { source = pkt.srcmac; + destination = pkt.dstmac; + ethertype = `IPv4; } eth) + with + | Ok () -> () + | Error e -> invalid_arg e) ; (* IPv4 *) + let payload_len = Udp_wire.sizeof_udp + Cstruct.len dhcp in let pseudoheader = Ipv4_packet.Marshal.pseudoheader - ~src:pkt.srcip ~dst:pkt.dstip ~proto:`UDP - (Udp_wire.sizeof_udp + Cstruct.len dhcp) + ~src:pkt.srcip ~dst:pkt.dstip ~proto:`UDP payload_len in (* UDP *) - let udp = Udp_packet.(Marshal.make_cstruct ~pseudoheader ~payload:dhcp + (match Udp_packet.(Marshal.into_cstruct ~pseudoheader ~payload:dhcp { src_port = pkt.srcport; - dst_port = pkt.dstport }) - in - let ip = Ipv4_packet.(Marshal.make_cstruct ~payload_len:(Cstruct.lenv [udp;dhcp]) + dst_port = pkt.dstport } udp) + with + | Ok () -> () + | Error e -> invalid_arg e) ; + (match Ipv4_packet.(Marshal.into_cstruct ~payload_len { src = pkt.srcip; dst = pkt.dstip; id = 0 (* TODO: random? *); off = 0 ; proto = (Marshal.protocol_to_int `UDP); ttl = 255; - options = Cstruct.create 0; }) - in - Cstruct.concat [ ethernet; ip; udp; dhcp ] + options = Cstruct.create 0; } + ip) + with + | Ok () -> () + | Error e -> invalid_arg e) ; + Ethernet_wire.sizeof_ethernet + Ipv4_wire.sizeof_ipv4 + Udp_wire.sizeof_udp + Cstruct.len dhcp + +let buf_of_pkt pkg = + (* TODO mtu *) + let dhcp = Cstruct.create 2048 in + let l = pkt_into_buf pkg dhcp in + Cstruct.sub dhcp 0 l let is_dhcp buf len = let open Rresult in let aux buf = Ethernet_packet.Unmarshal.of_cstruct buf >>= fun (eth_header, eth_payload) -> match eth_header.Ethernet_packet.ethertype with - | Ethernet_wire.ARP | Ethernet_wire.IPv6 -> Ok false - | Ethernet_wire.IPv4 -> + | `ARP | `IPv6 -> Ok false + | `IPv4 -> Ipv4_packet.Unmarshal.of_cstruct eth_payload >>= fun (ipv4_header, ipv4_payload) -> (* TODO: tcpip doesn't currently do checksum checking, so we lose some functionality by making this change *) diff --git a/lib/dhcp_wire.mli b/lib/dhcp_wire.mli index a080374..b651a8e 100644 --- a/lib/dhcp_wire.mli +++ b/lib/dhcp_wire.mli @@ -754,6 +754,7 @@ type pkt = { val pkt_of_buf : Cstruct.t -> int -> (pkt, string) result val buf_of_pkt : pkt -> Cstruct.t +val pkt_into_buf : pkt -> Cstruct.t -> int val pkt_of_sexp : Sexplib.Sexp.t -> pkt val sexp_of_pkt : pkt -> Sexplib.Sexp.t diff --git a/test/client/lwt/test_client_lwt.ml b/test/client/lwt/test_client_lwt.ml index ba0c77d..78ea844 100644 --- a/test/client/lwt/test_client_lwt.ml +++ b/test/client/lwt/test_client_lwt.ml @@ -15,23 +15,24 @@ module No_time = struct end module No_net = struct - type error = Mirage_device.error - let pp_error = Mirage_device.pp_error + type error = Mirage_net.Net.error + let pp_error = Mirage_net.Net.pp_error type stats = Mirage_net.stats type 'a io = 'a Lwt.t type macaddr = Macaddr.t - type page_aligned_buffer = Io_page.t type buffer = Cstruct.t type t = { mac : Macaddr.t; mutable packets : Cstruct.t list } let disconnect _ = Lwt.return_unit - let writev t l = - t.packets <- t.packets @ l; + let write t ~size fillf = + let buf = Cstruct.create size in + let l = fillf buf in + assert (l <= size); + let b = Cstruct.sub buf 0 l in + t.packets <- t.packets @ [b]; Lwt.return_ok () - let write t p = - t.packets <- p :: t.packets; - Lwt.return_ok () - let listen _ _ = Lwt.return_ok () + let listen _ ~header_size:_ _ = Lwt.return_ok () let mac t = t.mac + let mtu t = 1500 let reset_stats_counters _ = () let get_stats_counters _ = { Mirage_net.rx_bytes = 0L; diff --git a/test/client/test_client.ml b/test/client/test_client.ml index 23a5934..3f39045 100644 --- a/test/client/test_client.ml +++ b/test/client/test_client.ml @@ -45,13 +45,14 @@ let parseable buf = let random_xid () = Cstruct.BE.get_uint32 (Mirage_random_test.generate 4) 0 let start_makes_dhcp () = - let (_s, buf) = Dhcp_client.create (random_xid ()) Defaults.client_mac in + let (_s, pkt) = Dhcp_client.create (random_xid ()) Defaults.client_mac in (* for now, any positive result is fine *) - parseable buf + parseable (Dhcp_wire.buf_of_pkt pkt) let client_to_selecting () = let open Defaults in - let (s, buf) = Dhcp_client.create (random_xid ()) client_mac in + let (s, pkt) = Dhcp_client.create (random_xid ()) client_mac in + let buf = Dhcp_wire.buf_of_pkt pkt in let answer = Dhcp_wire.pkt_of_buf buf (Cstruct.len buf) in Alcotest.(check (result pass reject)) "input succeeds" answer answer; (s, Rresult.R.get_ok answer) @@ -96,7 +97,8 @@ let client_asks_dhcprequest () = match Dhcp_client.input s (Dhcp_wire.buf_of_pkt pkt) with | `Noop -> Alcotest.fail "response to DHCPOFFER was silence" | `New_lease _ -> Alcotest.fail "thought a DHCPOFFER was a lease???" - | `Response (s, buf) -> + | `Response (s, pkt) -> + let buf = Dhcp_wire.buf_of_pkt pkt in parseable buf; let dhcprequest = Rresult.R.get_ok @@ Dhcp_wire.pkt_of_buf buf (Cstruct.len buf) in Alcotest.(check (option msgtype)) "responded to DHCPOFFER with DHCPREQUEST" @@ -112,7 +114,8 @@ let server_gives_dhcpack () = match Dhcp_client.input s (Dhcp_wire.buf_of_pkt dhcpoffer) with | `Noop -> Alcotest.fail "couldn't get client to respond to DHCPOFFER" | `New_lease _-> Alcotest.fail "thought a DHCPOFFER was a lease" - | `Response (s, buf) -> + | `Response (s, pkt) -> + let buf = Dhcp_wire.buf_of_pkt pkt in let dhcprequest = Rresult.R.get_ok @@ Dhcp_wire.pkt_of_buf buf (Cstruct.len buf) in let (dhcpack, _db) = assert_reply @@ Dhcp_server.Input.input_pkt config db dhcprequest 0l in Alcotest.(check (option msgtype)) "got a DHCPACK in response to DHCPREQUEST" @@ -125,7 +128,8 @@ let client_returns_lease () = let (dhcpoffer, db) = assert_reply @@ Dhcp_server.Input.input_pkt config empty_db dhcpdiscover 0l in match Dhcp_client.input s (Dhcp_wire.buf_of_pkt dhcpoffer) with | `Noop | `New_lease _ -> Alcotest.fail "incorrect response to DHCPOFFER" - | `Response (s, buf) -> + | `Response (s, pkt) -> + let buf = Dhcp_wire.buf_of_pkt pkt in let dhcprequest = Rresult.R.get_ok @@ Dhcp_wire.pkt_of_buf buf (Cstruct.len buf) in let (dhcpack, _db) = assert_reply @@ Dhcp_server.Input.input_pkt config db dhcprequest 0l in Alcotest.(check (option msgtype)) "got a DHCPACK in response to DHCPREQUEST" @@ -161,7 +165,8 @@ let random_bound n = match Dhcp_client.input s (Dhcp_wire.buf_of_pkt pkt) with | `Noop | `New_lease _ -> Alcotest.fail "couldn't enter REQUESTING properly" | `Response (s, dhcprequest) -> - let dhcprequest = Rresult.R.get_ok @@ Dhcp_wire.pkt_of_buf dhcprequest (Cstruct.len dhcprequest) in + let buf = Dhcp_wire.buf_of_pkt dhcprequest in + let dhcprequest = Rresult.R.get_ok @@ Dhcp_wire.pkt_of_buf buf (Cstruct.len buf) in let (dhcpack, db) = assert_reply @@ Dhcp_server.Input.input_pkt config db dhcprequest 0l in match Dhcp_client.input s (Dhcp_wire.buf_of_pkt dhcpack) with | `Noop | `Response _ -> Alcotest.fail "client did not recognize DHCPACK as diff --git a/test/dune b/test/dune index cde31f2..99fc1db 100644 --- a/test/dune +++ b/test/dune @@ -2,7 +2,7 @@ (names test) (preprocess (pps ppx_cstruct)) - (libraries cstruct-unix io-page.unix charrua-core.server tcpip.unix)) + (libraries cstruct-unix charrua-core.server tcpip.unix)) (alias (name runtest)