preserve htype for client identifier

As observed in #84, the client identifier type was set to 0 (and thus not respecting the client which sent the identifier). This violates RFC6842, which states that the client identifier must be replied with unmodified.
mirage · Nov 25, 2020 · afb0440 · afb0440
1 parent 2c71a91
commit afb0440
Show file tree

Hide file tree

Showing 4 changed files with 24 additions and 19 deletions.
diff --git a/lib/dhcp_wire.ml b/lib/dhcp_wire.ml
@@ -379,7 +379,7 @@ type flags =
 
 type client_id =
   | Hwaddr of Macaddr_sexp.t
-  | Id of string [@@deriving sexp]
+  | Id of int * string [@@deriving sexp]
 
 type dhcp_option =
   | Pad                                     (* code 0 *)
@@ -653,10 +653,11 @@ let options_of_buf buf buf_len =
       in
       let get_client_id () =  if len < 2 then invalid_arg bad_len else
           let s = Cstruct.copy body 1 (len - 1) in
-          if (Cstruct.get_uint8 body 0) = 1 && len = 7 then
+          let htype = Cstruct.get_uint8 body 0 in
+          if htype = 1 && len = 7 then
             Hwaddr (Macaddr.of_octets_exn s)
           else
-            Id s
+            Id (htype, s)
       in
       match code with
       | 0 ->   padding ()
@@ -883,7 +884,7 @@ let buf_of_options sbuf options =
   let put_client_id code v buf =
     let htype, s = match v with
       | Hwaddr mac -> (1, Macaddr.to_octets mac)
-      | Id id -> (0, id)
+      | Id (htype, id) -> (htype, id)
     in
     let len = String.length s in
     let buf = put_code code buf |> put_len (succ len) |> put_8 htype in

diff --git a/lib/dhcp_wire.mli b/lib/dhcp_wire.mli
@@ -374,7 +374,7 @@ val sexp_of_flags : flags -> Sexplib.Sexp.t
 
 type client_id =
   | Hwaddr of Macaddr.t
-  | Id of string
+  | Id of int * string
 (** A client_id is usually a mac address from a {! dhcp_option},
     but it can also be an opaque string. See {! client_id_of_pkt}. *)
 

diff --git a/server/dhcp_server.ml b/server/dhcp_server.ml
@@ -181,7 +181,11 @@ module Lease = struct
     let compare a b =
       match a, b with
       | Hwaddr maca,  Hwaddr macb -> Macaddr.compare maca macb
-      | Id ida,  Id idb -> String.compare ida idb
+      | Id (htype, ida),  Id (htype', idb) ->
+        begin match compare htype htype' with
+          | 0 -> String.compare ida idb
+          | x -> x
+        end
       | Id _, Hwaddr _ -> -1
       | Hwaddr _, Id _ -> 1
   end
@@ -294,7 +298,7 @@ module Lease = struct
       invalid_arg "invalid range, must be (low * high)";
     let hint_ip =
       let v = match id with
-        | Dhcp_wire.Id _s -> Int32.of_int 1805 (* XXX who cares *)
+        | Dhcp_wire.Id (_, _s) -> Int32.of_int 1805 (* XXX who cares *)
         | Dhcp_wire.Hwaddr hw ->
           let s = String.sub (Macaddr.to_octets hw) 2 4 in
           let b0 = Int32.shift_left (Char.code s.[3] |> Int32.of_int) 0 in

diff --git a/test/test.ml b/test/test.ml
@@ -207,7 +207,7 @@ let t_bad_junk_padding_config () =
         Subnet_mask mask_t;
         End; (* Should not allow end in configuration *)
         Pad; (* Should not allow pad in configuration *)
-        Client_id (Id "The dude");
+        Client_id (Id (0, "The dude"));
       ];
       false
     with
@@ -307,7 +307,7 @@ let discover_pkt = {
     file = "";
     options = [
       Message_type DHCPDISCOVER;
-      Client_id (Id "W.Sobchak");
+      Client_id (Id (0, "W.Sobchak"));
       Parameter_requests [
         DNS_SERVERS; NIS_SERVERS; ROUTERS; DOMAIN_NAME; URL;
         POP3_SERVERS; SUBNET_MASK; DEFAULT_IP_TTL;
@@ -509,7 +509,7 @@ let t_bad_discover () =
     file = "";
     options = [
       Message_type DHCPDISCOVER;
-      Client_id (Id "W.Sobchak");
+      Client_id (Id (0, "W.Sobchak"));
       Parameter_requests [
         DNS_SERVERS; NIS_SERVERS; ROUTERS; DOMAIN_NAME; URL;
         POP3_SERVERS; SUBNET_MASK; DEFAULT_IP_TTL;
@@ -545,7 +545,7 @@ let request_nak_pkt = {
   file = "";
   options = [
     Message_type DHCPREQUEST;
-    Client_id (Id "The Dude");
+    Client_id (Id (0, "The Dude"));
     Parameter_requests [
       DNS_SERVERS; NIS_SERVERS; ROUTERS; DOMAIN_NAME; URL;
       POP3_SERVERS; SUBNET_MASK; DEFAULT_IP_TTL;
@@ -599,7 +599,7 @@ let t_request_fixed () =
     file = "";
     options = [
       Message_type DHCPREQUEST;
-      Client_id (Id "W.Sobchak");
+      Client_id (Id (0, "W.Sobchak"));
       Parameter_requests [
         DNS_SERVERS; NIS_SERVERS; ROUTERS; DOMAIN_NAME; URL;
         POP3_SERVERS; SUBNET_MASK; DEFAULT_IP_TTL;
@@ -618,7 +618,7 @@ let t_request_fixed () =
       (* Fixed leases are mocked up, database should be unchanged *)
       assert (db = (Lease.make_db ()));
       let () =
-        match Lease.lease_of_client_id (Id "W.Sobchak") db with
+        match Lease.lease_of_client_id (Id (0, "W.Sobchak")) db with
         | None -> () (* good, lease is not there. *)
         | Some _l -> failwith "Found a fixed lease, bad juju."
       in
@@ -707,7 +707,7 @@ let t_request () =
     file = "";
     options = [
       Message_type DHCPREQUEST;
-      Client_id (Id "W.Sobchak");
+      Client_id (Id (0, "W.Sobchak"));
       Parameter_requests [
         DNS_SERVERS; NIS_SERVERS; ROUTERS; DOMAIN_NAME; URL;
         POP3_SERVERS; SUBNET_MASK; DEFAULT_IP_TTL;
@@ -729,11 +729,11 @@ let t_request () =
       if verbose then
         printf "lease %s\n%!" (Lease.to_string (List.hd (Lease.to_list db)));
       let () =
-        match Lease.lease_of_client_id (Id "W.Sobchak") db with
+        match Lease.lease_of_client_id (Id (0, "W.Sobchak")) db with
         | None -> failwith "Lease not found";
         | Some l ->
           let open Dhcp_server.Lease in
-          assert (l.client_id = (Id "W.Sobchak"));
+          assert (l.client_id = (Id (0, "W.Sobchak")));
           assert (not (expired l ~now));
           assert (l.tm_start <= now);
           assert (l.tm_end >= now);
@@ -834,7 +834,7 @@ let t_request_no_range () =
     file = "";
     options = [
       Message_type DHCPREQUEST;
-      Client_id (Id "W.Sobchak");
+      Client_id (Id (0, "W.Sobchak"));
       Parameter_requests [
         DNS_SERVERS; NIS_SERVERS; ROUTERS; DOMAIN_NAME; URL;
         POP3_SERVERS; SUBNET_MASK; DEFAULT_IP_TTL;
@@ -909,7 +909,7 @@ let t_request_no_range_fixed () =
     file = "";
     options = [
       Message_type DHCPREQUEST;
-      Client_id (Id "W.Sobchak");
+      Client_id (Id (0, "W.Sobchak"));
       Parameter_requests [
         DNS_SERVERS; NIS_SERVERS; ROUTERS; DOMAIN_NAME; URL;
         POP3_SERVERS; SUBNET_MASK; DEFAULT_IP_TTL;
@@ -927,7 +927,7 @@ let t_request_no_range_fixed () =
     (* Check if our new lease is there *)
     assert (db = (Lease.make_db ()));
     let () =
-      match Lease.lease_of_client_id (Id "W.Sobchak") db with
+      match Lease.lease_of_client_id (Id (0, "W.Sobchak")) db with
       | None -> () (* good, lease is not there. *)
       | Some _l -> failwith "Found a fixed lease, bad juju."
     in