diff --git a/.travis.yml b/.travis.yml index bb5dabe..5867ee8 100644 --- a/.travis.yml +++ b/.travis.yml @@ -8,13 +8,11 @@ env: global: - TESTS=true - PINS="charrua.dev:. charrua-server.dev:. charrua-unix.dev:. charrua-client.dev:. charrua-client-lwt.dev:. charrua-client-mirage.dev:." - - EXTRA_REMOTES="https://github.com/mirage/mirage-dev.git" - - PRE_INSTALL_HOOK="cd /home/opam/opam-repository && git pull origin master && opam update -u -y" matrix: - - DISTRO="alpine" OCAML_VERSION="4.08" PACKAGE="charrua-client" DEPOPTS="charrua-server" - - DISTRO="debian-unstable" OCAML_VERSION="4.07" PACKAGE="charrua-client" - - DISTRO="ubuntu-lts" OCAML_VERSION="4.07" PACKAGE="charrua-client-lwt" - - DISTRO="ubuntu" OCAML_VERSION="4.06" PACKAGE="charrua-client-mirage" - - DISTRO="debian-stable" OCAML_VERSION="4.06" PACKAGE="charrua-server" - - DISTRO="alpine" OCAML_VERSION="4.05" PACKAGE="charrua" - - DISTRO="centos" OCAML_VERSION="4.04" PACKAGE="charrua-unix" + - DISTRO="alpine" OCAML_VERSION="4.09" PACKAGE="charrua-client" DEPOPTS="charrua-server" + - DISTRO="debian-unstable" OCAML_VERSION="4.08" PACKAGE="charrua-client" + - DISTRO="ubuntu-lts" OCAML_VERSION="4.08" PACKAGE="charrua-client-lwt" + - DISTRO="ubuntu" OCAML_VERSION="4.07" PACKAGE="charrua-client-mirage" + - DISTRO="debian-stable" OCAML_VERSION="4.07" PACKAGE="charrua-server" + - DISTRO="alpine" OCAML_VERSION="4.06" PACKAGE="charrua" + - DISTRO="centos" OCAML_VERSION="4.06" PACKAGE="charrua-unix" diff --git a/charrua-client-lwt.opam b/charrua-client-lwt.opam index 85f3160..b181ec7 100644 --- a/charrua-client-lwt.opam +++ b/charrua-client-lwt.opam @@ -14,21 +14,21 @@ build: [ ] depends: [ - "dune" {>= "1.0"} - "ocaml" {>= "4.04.2"} + "dune" {>= "1.2.0"} + "ocaml" {>= "4.06.0"} "alcotest" {with-test} "cstruct-unix" {with-test} "charrua" {= version} "charrua-client" {= version} "cstruct" {>="3.0.2"} - "ipaddr" {>="3.0.0"} - "mirage-random" {>= "1.0.0"} + "ipaddr" {>="4.0.0"} + "mirage-random" {>= "2.0.0"} "duration" - "mirage-time-lwt" - "mirage-net-lwt" {>= "2.0.0"} + "mirage-time" {>= "2.0.0"} + "mirage-net" {>= "3.0.0"} "logs" "fmt" - "lwt" + "lwt" {>= "4.0.0"} ] synopsis: "A DHCP client using lwt as effectful layer" description: """ diff --git a/charrua-client-mirage.opam b/charrua-client-mirage.opam index 3a78822..ed3e8b1 100644 --- a/charrua-client-mirage.opam +++ b/charrua-client-mirage.opam @@ -13,17 +13,17 @@ build: [ ] depends: [ - "dune" {>= "1.0"} - "ocaml" {>= "4.04.2"} + "dune" {>= "1.2.0"} + "ocaml" {>= "4.06.0"} "charrua-client-lwt" {= version} - "ipaddr" {>= "3.0.0"} - "mirage-random" {>= "1.0.0"} - "mirage-clock" - "mirage-time-lwt" - "mirage-net-lwt" {>= "2.0.0"} - "mirage-protocols-lwt" {>= "2.0.0"} + "ipaddr" {>= "4.0.0"} + "mirage-random" {>= "2.0.0"} + "mirage-clock" {>= "3.0.0"} + "mirage-time" {>= "2.0.0"} + "mirage-net" {>= "3.0.0"} + "mirage-protocols" {>= "4.0.0"} "logs" - "lwt" + "lwt" {>= "4.0.0"} ] synopsis: "A DHCP client for MirageOS" description: """ diff --git a/charrua-client.opam b/charrua-client.opam index 8eccd29..73e7697 100644 --- a/charrua-client.opam +++ b/charrua-client.opam @@ -14,16 +14,16 @@ build: [ ] depends: [ - "dune" {>= "1.0"} - "ocaml" {>= "4.04.2"} + "dune" {>= "1.2.0"} + "ocaml" {>= "4.06.0"} "alcotest" {with-test} "cstruct-unix" {with-test} - "mirage-random-test" {with-test} + "mirage-random-test" {with-test & >= "0.1.0"} "charrua-server" {= version & with-test} "charrua" {= version} "cstruct" {>="3.0.2"} - "ipaddr" - "macaddr" + "ipaddr" {>= "4.0.0"} + "macaddr" {>= "4.0.0"} ] synopsis: "DHCP client implementation" description: """ diff --git a/charrua-server.opam b/charrua-server.opam index b275484..c64c0cc 100644 --- a/charrua-server.opam +++ b/charrua-server.opam @@ -14,11 +14,11 @@ build: [ ] depends: [ - "dune" + "ocaml" {>= "4.06.0"} + "dune" {>= "1.2.0"} "ppx_sexp_conv" {>= "v0.9.0"} "menhir" {build} "charrua" {= version} - "ocaml" {>= "4.04.2"} "cstruct" {>= "3.0.1"} "sexplib" "ipaddr" {>= "4.0.0"} diff --git a/charrua-unix.opam b/charrua-unix.opam index 2659de3..df92b1e 100644 --- a/charrua-unix.opam +++ b/charrua-unix.opam @@ -10,8 +10,8 @@ build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ - "dune" {>= "1.0"} - "ocaml" {>= "4.04.2"} + "dune" {>= "1.2.0"} + "ocaml" {>= "4.06.0"} "lwt" {>="3.0.0"} "lwt_log" "charrua" {= version} diff --git a/charrua.opam b/charrua.opam index 97268ae..4895ce9 100644 --- a/charrua.opam +++ b/charrua.opam @@ -13,8 +13,8 @@ build: [ ] depends: [ - "ocaml" {>= "4.04.2"} - "dune" + "ocaml" {>= "4.06.0"} + "dune" {>= "1.2.0"} "ppx_sexp_conv" {>="v0.10.0"} "ppx_cstruct" "cstruct" {>= "3.0.1"} @@ -23,8 +23,8 @@ depends: [ "macaddr" {>= "4.0.0"} "ipaddr-sexp" "macaddr-sexp" - "ethernet" {>= "2.0.0"} - "tcpip" {>= "3.7.0"} + "ethernet" {>= "2.2.0"} + "tcpip" {>= "4.0.0"} "rresult" ] synopsis: "DHCP wire frame encoder and decoder" diff --git a/client/lwt/dhcp_client_lwt.ml b/client/lwt/dhcp_client_lwt.ml index f6b9021..9c895fe 100644 --- a/client/lwt/dhcp_client_lwt.ml +++ b/client/lwt/dhcp_client_lwt.ml @@ -1,7 +1,7 @@ let src = Logs.Src.create "dhcp_client_lwt" module Log = (val Logs.src_log src : Logs.LOG) -module Make(Random : Mirage_random.C)(Time : Mirage_time_lwt.S) (Net : Mirage_net_lwt.S) = struct +module Make(Random : Mirage_random.S)(Time : Mirage_time.S) (Net : Mirage_net.S) = struct open Lwt.Infix type lease = Dhcp_wire.pkt diff --git a/client/lwt/dhcp_client_lwt.mli b/client/lwt/dhcp_client_lwt.mli index 08bdafa..65f38e4 100644 --- a/client/lwt/dhcp_client_lwt.mli +++ b/client/lwt/dhcp_client_lwt.mli @@ -1,4 +1,4 @@ -module Make(Random : Mirage_random.C)(Time : Mirage_time_lwt.S) (Net : Mirage_net_lwt.S) : sig +module Make(Random : Mirage_random.S)(Time : Mirage_time.S) (Net : Mirage_net.S) : sig type lease = Dhcp_wire.pkt type t = lease Lwt_stream.t diff --git a/client/lwt/dune b/client/lwt/dune index 1230e8b..124749d 100644 --- a/client/lwt/dune +++ b/client/lwt/dune @@ -2,5 +2,5 @@ (name dhcp_client_lwt) (public_name charrua-client-lwt) (modules dhcp_client_lwt) - (libraries charrua lwt charrua-client cstruct ipaddr mirage-time-lwt - mirage-random mirage-net-lwt duration fmt logs)) + (libraries charrua lwt charrua-client cstruct ipaddr mirage-time + mirage-random mirage-net duration fmt logs)) diff --git a/client/mirage/dhcp_client_mirage.ml b/client/mirage/dhcp_client_mirage.ml index c6ae4bc..169f3b6 100644 --- a/client/mirage/dhcp_client_mirage.ml +++ b/client/mirage/dhcp_client_mirage.ml @@ -1,7 +1,7 @@ let src = Logs.Src.create "dhcp_client_mirage" module Log = (val Logs.src_log src : Logs.LOG) -let config_of_lease lease : Mirage_protocols_lwt.ipv4_config option = +let config_of_lease lease : Mirage_protocols.ipv4_config option = let open Dhcp_wire in (* ipv4_config expects a single IP address and the information * needed to construct a prefix. It can optionally use one router. *) @@ -15,15 +15,14 @@ let config_of_lease lease : Mirage_protocols_lwt.ipv4_config option = let network = Ipaddr.V4.Prefix.of_netmask subnet address in let valid_routers = Dhcp_wire.collect_routers lease.options in match valid_routers with - | [] -> Some Mirage_protocols_lwt.{ address; network; gateway = None } + | [] -> Some Mirage_protocols.{ address; network; gateway = None } | hd::_ -> - Some Mirage_protocols_lwt.{ address; network; gateway = (Some hd) } + Some Mirage_protocols.{ address; network; gateway = (Some hd) } -module Make(Random : Mirage_random.C)(Time : Mirage_time_lwt.S) (Net : Mirage_net_lwt.S) = struct +module Make(Random : Mirage_random.S)(Time : Mirage_time.S) (Net : Mirage_net.S) = struct open Lwt.Infix - open Mirage_protocols_lwt - type t = ipv4_config Lwt_stream.t + type t = Mirage_protocols.ipv4_config Lwt_stream.t let connect ?(requests : Dhcp_wire.option_code list option) net = let module Lwt_client = Dhcp_client_lwt.Make(Random)(Time)(Net) in diff --git a/client/mirage/dhcp_client_mirage.mli b/client/mirage/dhcp_client_mirage.mli index a731185..f6593eb 100644 --- a/client/mirage/dhcp_client_mirage.mli +++ b/client/mirage/dhcp_client_mirage.mli @@ -1,5 +1,5 @@ -module Make(Random : Mirage_random.C)(Time : Mirage_time_lwt.S) (Network : Mirage_net_lwt.S) : sig - type t = Mirage_protocols_lwt.ipv4_config Lwt_stream.t +module Make(Random : Mirage_random.S)(Time : Mirage_time.S) (Network : Mirage_net.S) : sig + type t = Mirage_protocols.ipv4_config Lwt_stream.t val connect : ?requests:Dhcp_wire.option_code list -> Network.t -> t Lwt.t (** [connect ?requests net] attempts to use [net] to obtain a valid diff --git a/client/mirage/dhcp_ipv4.ml b/client/mirage/dhcp_ipv4.ml index 03dfbd5..16eaebb 100644 --- a/client/mirage/dhcp_ipv4.ml +++ b/client/mirage/dhcp_ipv4.ml @@ -1,10 +1,9 @@ open Lwt.Infix -open Mirage_protocols_lwt -module Make(Dhcp_client : DHCP_CLIENT) (R : Mirage_random.C) (C : Mirage_clock.MCLOCK) (E : ETHERNET) (Arp : ARP) = struct +module Make(Dhcp_client : Mirage_protocols.DHCP_CLIENT) (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (E : Mirage_protocols.ETHERNET) (Arp : Mirage_protocols.ARP) = struct (* for now, just wrap a static ipv4 *) include Static_ipv4.Make(R)(C)(E)(Arp) - let connect dhcp clock ethernet arp = - Lwt_stream.last_new dhcp >>= fun (config : ipv4_config) -> - connect ~ip:config.address ~network:config.network ~gateway:config.gateway clock ethernet arp + let connect dhcp ethernet arp = + Lwt_stream.last_new dhcp >>= fun (config : Mirage_protocols.ipv4_config) -> + connect ~ip:(config.network, config.address) ?gateway:config.gateway ethernet arp end diff --git a/client/mirage/dhcp_ipv4.mli b/client/mirage/dhcp_ipv4.mli index 57c7be1..afd0ddc 100644 --- a/client/mirage/dhcp_ipv4.mli +++ b/client/mirage/dhcp_ipv4.mli @@ -14,8 +14,8 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -module Make (D: Mirage_protocols_lwt.DHCP_CLIENT) (R : Mirage_random.C) (C : Mirage_clock.MCLOCK) (E:Mirage_protocols_lwt.ETHERNET) (A: Mirage_protocols_lwt.ARP) : sig - include Mirage_protocols_lwt.IPV4 - val connect : D.t -> C.t -> E.t -> A.t -> t Lwt.t +module Make (D: Mirage_protocols.DHCP_CLIENT) (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (E:Mirage_protocols.ETHERNET) (A: Mirage_protocols.ARP) : sig + include Mirage_protocols.IPV4 + val connect : D.t -> E.t -> A.t -> t Lwt.t (** Connect to an ipv4 device using information from a DHCP lease. *) end diff --git a/client/mirage/dune b/client/mirage/dune index aa89796..8dd0b40 100644 --- a/client/mirage/dune +++ b/client/mirage/dune @@ -1,6 +1,6 @@ (library (name dhcp_client_mirage) (public_name charrua-client-mirage) - (libraries charrua-client-lwt ipaddr mirage-clock mirage-random mirage-time-lwt - mirage-net-lwt mirage-protocols-lwt logs) + (libraries charrua-client-lwt ipaddr mirage-clock mirage-random mirage-time + mirage-net mirage-protocols logs) (wrapped false)) diff --git a/test/client/lwt/test_client_lwt.ml b/test/client/lwt/test_client_lwt.ml index 78ea844..2dbac7b 100644 --- a/test/client/lwt/test_client_lwt.ml +++ b/test/client/lwt/test_client_lwt.ml @@ -3,14 +3,13 @@ open Lwt.Infix (* additional tests for time- and network-dependent code *) module No_random = struct - type buffer = Cstruct.t type g - let generate ?g n = Cstruct.create n + let generate ?g:_ n = Cstruct.create n end module No_time = struct - type 'a io = 'a Lwt.t - let sleep_ns n = Format.printf "Ignoring request to wait %f seconds\n" @@ Duration.to_f n; + let sleep_ns n = + Format.printf "Ignoring request to wait %f seconds\n" (Duration.to_f n); Lwt_main.yield () end @@ -18,9 +17,6 @@ module No_net = struct 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 buffer = Cstruct.t type t = { mac : Macaddr.t; mutable packets : Cstruct.t list } let disconnect _ = Lwt.return_unit let write t ~size fillf = @@ -32,7 +28,7 @@ module No_net = struct Lwt.return_ok () let listen _ ~header_size:_ _ = Lwt.return_ok () let mac t = t.mac - let mtu t = 1500 + 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 3f39045..cdcebee 100644 --- a/test/client/test_client.ml +++ b/test/client/test_client.ml @@ -30,14 +30,13 @@ let random_buffer () = let rec no_result t n () = if n <= 0 then () else begin - let buf = random_buffer () in - (* TODO: it would be better to randomize a valid DHCP message; currently - * we're fuzz testing the Dhcp_wire parser's ability to handle random garbage *) - let res = Dhcp_client.input t buf in - Alcotest.(check bool) "no action" true (res = `Noop); - no_result t (n - 1) () + let buf = random_buffer () in + (* TODO: it would be better to randomize a valid DHCP message; currently + * we're fuzz testing the Dhcp_wire parser's ability to handle random garbage *) + let res = Dhcp_client.input t buf in + Alcotest.(check bool) "no action" true (res = `Noop); + no_result t (n - 1) () end -;; let parseable buf = Alcotest.(check bool) "buffer we constructed is valid dhcp" true (Dhcp_wire.is_dhcp buf (Cstruct.len buf)) @@ -97,7 +96,7 @@ 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, pkt) -> + | `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 @@ -114,7 +113,7 @@ 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, pkt) -> + | `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 @@ -138,7 +137,7 @@ let client_returns_lease () = | `Response _ -> Alcotest.fail "client wanted to send more packets after receiving DHCPACK" | `Noop -> Alcotest.fail "client disregarded its lease" - | `New_lease (s, l) -> + | `New_lease (s, _l) -> Alcotest.(check (option pass)) "lease is held" (Some dhcpack) (Dhcp_client.lease s) let random_init n = @@ -155,7 +154,7 @@ let random_requesting n = let (pkt, _db) = assert_reply @@ Dhcp_server.Input.input_pkt config empty_db dhcpdiscover 0l in 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) -> +| `Response (s, _dhcprequest) -> "random buffer entry to REQUESTING client", `Quick, (no_result s n) let random_bound n = @@ -167,11 +166,11 @@ let random_bound n = | `Response (s, dhcprequest) -> 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 + 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 a new lease" - | `New_lease (s, response) -> + | `New_lease (s, _response) -> "random buffer entry to BOUND client", `Quick, (no_result s n) let () = diff --git a/test/test.ml b/test/test.ml index 6d06ed5..2e2fc20 100644 --- a/test/test.ml +++ b/test/test.ml @@ -385,7 +385,6 @@ let t_discover_range () = t_discover false let t_discover_fixed () = t_discover true let t_discover_no_range () = - let open Dhcp_server.Config in let config = Config.make ~hostname:"Duder DHCP server!" ~default_lease_time:(60 * 60 * 1) @@ -621,7 +620,7 @@ let t_request_fixed () = let () = match Lease.lease_of_client_id (Id "W.Sobchak") db with | None -> () (* good, lease is not there. *) - | Some l -> failwith "Found a fixed lease, bad juju." + | Some _l -> failwith "Found a fixed lease, bad juju." in assert (reply.srcmac = mac_t); assert (reply.dstmac = Macaddr.broadcast); @@ -735,11 +734,11 @@ let t_request () = | Some l -> let open Dhcp_server.Lease in assert (l.client_id = (Id "W.Sobchak")); - assert (not (expired l now)); + assert (not (expired l ~now)); assert (l.tm_start <= now); assert (l.tm_end >= now); - assert ((Lease.timeleft l now) <= (Int32.of_int 3600)); - assert ((Lease.timeleft l now) >= (Int32.of_int 3599)); + assert ((Lease.timeleft l ~now) <= (Int32.of_int 3600)); + assert ((Lease.timeleft l ~now) >= (Int32.of_int 3599)); in assert (reply.srcmac = mac_t); assert (reply.dstmac = Macaddr.broadcast); @@ -796,7 +795,6 @@ let t_request () = | _ -> failwith "No reply" let t_request_no_range () = - let open Dhcp_server.Config in let config = Config.make ~hostname:"Duder DHCP server!" ~default_lease_time:(60 * 60 * 1) @@ -931,7 +929,7 @@ let t_request_no_range_fixed () = let () = match Lease.lease_of_client_id (Id "W.Sobchak") db with | None -> () (* good, lease is not there. *) - | Some l -> failwith "Found a fixed lease, bad juju." + | Some _l -> failwith "Found a fixed lease, bad juju." in assert (reply.srcmac = mac_t); assert (reply.dstmac = Macaddr.broadcast);