Renewal

client/dhcp_client.ml

@@ -12,6 +12,7 @@ type state  = | Selecting of Dhcp_wire.pkt (* dhcpdiscover sent *)
               | Requesting of (Dhcp_wire.pkt * Dhcp_wire.pkt) (* dhcpoffer input * dhcprequest sent *)
               | Bound of Dhcp_wire.pkt (* dhcpack received *)
               | Renewing of (Dhcp_wire.pkt * Dhcp_wire.pkt) (* dhcpack received, dhcprequest sent *)
+              | Rebinding of (Dhcp_wire.pkt * Dhcp_wire.pkt option * Dhcp_wire.pkt)
 
 (* `srcmac` will be used as the source of Ethernet frames,
    as well as the client identifier whenever one is required (e.g. padded with
@@ -76,29 +77,46 @@ let pp fmt p =
       Format.fprintf fmt
         "RENEWING.  Have lease %a, generated request %a"
         Dhcp_wire.pp_pkt ack Dhcp_wire.pp_pkt request
+    | Rebinding (ack, _renew_request, request) ->
+      Format.fprintf fmt
+        "REBINDING.  Have lease %a, generated request %a"
+        Dhcp_wire.pp_pkt ack Dhcp_wire.pp_pkt request
   in
   Format.fprintf fmt "%a: %a" Macaddr.pp p.srcmac pp_state p.state
 
 (* the lease function lets callers know whether the abstract (to them) lease
    object carries a usable network configuration. *)
 let lease {state; _} = match state with
-  | Bound dhcpack | Renewing (dhcpack, _) -> Some dhcpack
+  | Bound dhcpack | Renewing (dhcpack, _) | Rebinding (dhcpack, _, _) -> Some dhcpack
   | Requesting _ | Selecting _ -> None
 
 (* a convenience function for retrieving the most recently used transaction id.
    I don't know why this is needed or useful for anyone; it should probaby be
    removed. *)
-let xid {state; _} =
-  let open Dhcp_wire in
+let most_recent_xid { state; _ } =
   match state with
   | Selecting p -> p.xid
   | Requesting (_i, o) -> o.xid
   | Bound a -> a.xid
   | Renewing (_i, o) -> o.xid
+  | Rebinding (_i, _o, o') -> o'.xid
+
+let xid_matches {state; _} xid =
+  let open Dhcp_wire in
+  let is_match xid' = Int32.equal xid xid' in
+  match state with
+  | Selecting p -> is_match p.xid
+  | Requesting (_i, o) -> is_match o.xid
+  | Bound a -> is_match a.xid
+  | Renewing (_i, o) -> is_match o.xid
+  | Rebinding (_i, o, o') ->
+    Option.fold o ~none:false ~some:(fun o -> is_match o.xid)
+    || is_match o'.xid
 
 (* given a set of information, assemble a DHCPREQUEST packet from the Constants
    module and other constants defined in Dhcp_wire. *)
-let make_request ?(ciaddr = Ipaddr.V4.any) ~xid ~chaddr ~srcmac ~siaddr ~options () =
+let make_request ?(srcip = Ipaddr.V4.any) ?(dstip = Ipaddr.V4.broadcast) ?(ciaddr = Ipaddr.V4.any)
+    ~xid ~chaddr ~srcmac ~siaddr ~options () =
   let open Dhcp_wire in
   Constants.({
     htype; hlen; hops; sname; file;
@@ -107,14 +125,14 @@ let make_request ?(ciaddr = Ipaddr.V4.any) ~xid ~chaddr ~srcmac ~siaddr ~options
     srcport = Dhcp_wire.client_port;
     dstport = Dhcp_wire.server_port;
     srcmac;
-    srcip = Ipaddr.V4.any;
+    srcip;
     (* destinations should still be broadcast,
      * even though we have the necessary information to send unicast,
      * because there might be >1 DHCP server on the network.
      * those who we're not responding to should know that we're in a
      * transaction to accept another lease. *)
     dstmac = Macaddr.broadcast;
-    dstip = Ipaddr.V4.broadcast;
+    dstip;
     op = BOOTREQUEST;
     options;
     secs = 0;
@@ -147,6 +165,33 @@ let offer (t : t) ~xid ~chaddr ~server_ip ~request_ip ~offer_options =
   in
   make_request ~xid ~chaddr ~srcmac:t.srcmac ~siaddr:server_ip ~options:options ()
 
+(* DHCPREQUEST generated during RENEWING or REBINDING state (RFC 2131 Section 4.3.2):
+   - 'server identifier' MUST NOT be filled in
+   - 'requested IP address' option MUST NOT be filled in
+   - 'ciaddr' MUST be filled in with client's IP address
+   - for RENEWING we fill siaddr and unicast, for REBINDING we broadcast
+*)
+let renew_request ?siaddr (t : t) ~ciaddr ~xid ~chaddr =
+  let open Dhcp_wire in
+  let options = [
+    Message_type DHCPREQUEST;
+  ] @ t.options in
+  let options =
+    match t.request_options with
+    | [] -> options
+    | _::_ -> (Parameter_requests t.request_options) :: options
+  in
+  let dstip, siaddr =
+    (* [siaddr] being [Some _] signals we are renewing. When renewing:
+       - fill siaddr and unicast to the DHCP server
+       when rebinding:
+       - leave siaddr all zeroes and broadcast to any DHCP server *)
+    match siaddr with
+    | None -> None, Ipaddr.V4.any
+    | Some siaddr -> Some siaddr, siaddr
+  in
+  make_request ~srcip:ciaddr ?dstip ~ciaddr ~xid ~chaddr ~srcmac:t.srcmac ~siaddr ~options ()
+
 (* make a new DHCP client. allow the user to request a specific xid, any
    requests, and the MAC address to use as the source for Ethernet messages and
    the chaddr in the fixed-length part of the message *)
@@ -198,7 +243,7 @@ let input t buf =
   | Error `Msg _ -> `Noop
   | Ok incoming ->
     (* RFC2131 4.4.1: respond only to messages for our xid *)
-    if compare incoming.xid (xid t) = 0 then begin
+    if xid_matches t incoming.xid then begin
     match find_message_type incoming.options, t.state with
     | None, _ -> `Noop
     | Some DHCPOFFER, Selecting dhcpdiscover ->
@@ -214,9 +259,12 @@ let input t buf =
     | Some DHCPOFFER, _ -> (* DHCPOFFER is irrelevant when we're not selecting *)
       `Noop
     | Some DHCPACK, Renewing _
+    | Some DHCPACK, Rebinding _
     | Some DHCPACK, Requesting _ -> `New_lease ({t with state = Bound incoming}, incoming)
-    | Some DHCPNAK, Requesting _ | Some DHCPNAK, Renewing _ ->
-      `Response (create ~options:t.options ~requests:t.request_options (xid t) t.srcmac)
+    | Some DHCPNAK, Requesting _
+    | Some DHCPNAK, Renewing _
+    | Some DHCPNAK, Rebinding _ ->
+      `Response (create ~options:t.options ~requests:t.request_options (most_recent_xid t) t.srcmac)
     | Some DHCPACK, Selecting _ (* too soon *)
     | Some DHCPACK, Bound _ -> (* too late *)
       `Noop
@@ -236,12 +284,21 @@ 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
+  | Selecting _ | Requesting _ | Rebinding _ -> `Noop
   | 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 request = renew_request t ~ciaddr:lease.yiaddr ~xid:lease.xid ~chaddr:lease.chaddr ~siaddr:lease.siaddr in
     let state = Renewing (lease, request) in
     `Response ({t with state = state}, request)
+
+let rebind t = match t.state with
+  | Selecting _ | Requesting _ -> `Noop
+  | Rebinding (_lease, _renew_request, request) -> `Response (t, request)
+  | Bound lease ->
+    let request = renew_request t ~ciaddr:lease.yiaddr ~xid:lease.xid ~chaddr:lease.chaddr in
+    let state = Rebinding (lease, None, request) in
+    `Response ({ t with state }, request)
+  | Renewing (lease, old_renew_request) ->
+    let request = renew_request t ~ciaddr:lease.yiaddr ~xid:lease.xid ~chaddr:lease.chaddr in
+    let state = Rebinding (lease, Some old_renew_request, request) in
+    `Response ({ t with state }, request)

client/dhcp_client.mli

@@ -37,3 +37,6 @@ 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. *)
+
+val rebind : t -> [`Response of t * Dhcp_wire.pkt | `Noop]
+(** [rebind t] is much like [renew t] except for rebinding instead of renewing. *)

client/lwt/dhcp_client_lwt.ml

@@ -30,18 +30,94 @@ module Make (Net : Mirage_net.S) = struct
     let (client, dhcpdiscover) = Dhcp_client.create ?options ?requests xid (Net.mac net) in
     let c = ref client in
 
-    let rec do_renew c t =
-      Mirage_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, pkt) ->
-        Log.debug (fun f -> f "attempted to renew lease: %a" Dhcp_client.pp c);
-        Net.write net ~size (Dhcp_wire.pkt_into_buf pkt) >>= function
+    let cond = Lwt_condition.create () in
+
+    let rec do_renew lease =
+      let renewal =
+        Dhcp_wire.find_renewal_t1 lease.Dhcp_wire.options
+        |> Option.value ~default:1800l
+        |> Int32.unsigned_to_int
+        |> Option.value ~default:Int.max_int
+      in
+      let t2 (* rebinding *) =
+        Dhcp_wire.find_rebinding_t2 lease.Dhcp_wire.options
+        |> Option.value ~default:75600l (* 21h = (7/8)*24h *)
+        |> Int32.unsigned_to_int
+        |> Option.value ~default:Int.max_int
+      in
+      let expiry =
+        Dhcp_wire.find_ip_lease_time lease.Dhcp_wire.options
+        |> Option.value ~default:86400l (* 24h *)
+        |> Int32.unsigned_to_int
+        |> Option.value ~default:Int.max_int
+      in
+      let t2 = Mirage_sleep.ns @@ Duration.of_sec t2 in
+      let expiry = Mirage_sleep.ns @@ Duration.of_sec expiry in
+      let new_lease = Lwt_condition.wait cond >|= fun lease -> `Lease lease in
+      Mirage_sleep.ns @@ Duration.of_sec renewal >>= fun () ->
+      let rec send_renewal () =
+        match Dhcp_client.renew !c with
+        | `Noop -> 
+          Lwt.return `Can't_renew
+        | `Response (updated_c, pkt) ->
+          c := updated_c;
+          Log.debug (fun f -> f "attempted to renew lease: %a" Dhcp_client.pp updated_c);
+          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
+            Lwt.return (`Failed_to_write e)
           | Ok () ->
-            do_renew c t (* ideally t would come from the new lease... *)
+            Mirage_sleep.ns sleep_interval >>= send_renewal
+      in
+      Lwt.pick [
+        new_lease;
+        send_renewal ();
+        (t2 >|= fun () -> `T2_rebinding);
+        (expiry >|= fun () -> `Expired);
+      ] >>= function
+      | `Lease lease ->
+        do_renew lease
+      | `Can't_renew ->
+        Log.debug (fun f -> f "Can't renew this lease; won't try");
+        Lwt.return_unit
+      | `T2_rebinding ->
+        do_rebind expiry
+      | `Expired ->
+        Log.warn (fun f -> f "Lease expired before we could renew");
+        failwith "DHCP lease expired"
+      | `Failed_to_write e ->
+        Log.err (fun f -> f "Failed to write lease renewal request: %a" Net.pp_error e);
+        Lwt.return_unit
+    and do_rebind expiry =
+      let new_lease = Lwt_condition.wait cond >|= fun lease -> `Lease lease in
+      let rec send_rebind () =
+        match Dhcp_client.rebind !c with
+        | `Noop ->
+          Lwt.return `Can't_renew
+        | `Response (updated_c, pkt) ->
+          c := updated_c;
+          Log.debug (fun f -> f "attempted to rebind lease: %a" Dhcp_client.pp updated_c);
+          Net.write net ~size (Dhcp_wire.pkt_into_buf pkt) >>= function
+          | Error e ->
+            Lwt.return (`Failed_to_write e)
+          | Ok () ->
+            Mirage_sleep.ns sleep_interval >>= send_rebind
+      in
+      Lwt.pick [
+        new_lease;
+        send_rebind ();
+        (expiry >|= fun () -> `Expired);
+      ] >>= function
+      | `Lease lease ->
+        do_renew lease
+      | `Can't_renew ->
+        Log.debug (fun f -> f "Can't renew this lease; won't try");
+        Lwt.return_unit
+      | `Expired ->
+        Log.warn (fun f -> f "Lease expired before we could renew");
+        failwith "DHCP lease expired"
+      | `Failed_to_write e ->
+        Log.err (fun f -> f "Failed to write lease renewal request: %a" Net.pp_error e);
+        Lwt.return_unit
     in
     let rec get_lease cond dhcpdiscover =
       Log.debug (fun f -> f "Sending DHCPDISCOVER...");
@@ -51,12 +127,14 @@ module Make (Net : Mirage_net.S) = struct
         Lwt.return_unit
       | Ok () ->
         Lwt.pick [
-          Lwt_condition.wait cond;
-          Mirage_sleep.ns sleep_interval;
-        ] >>= fun () ->
-        match Dhcp_client.lease !c with
-        | Some _lease -> Lwt.return_unit
-        | None ->
+          (Lwt_condition.wait cond >|= fun lease -> `Lease lease);
+          (Mirage_sleep.ns sleep_interval >|= fun () -> `Timeout);
+        ] >>= function
+        | `Lease lease ->
+          if renew then
+            do_renew lease
+          else Lwt.return_unit
+        | `Timeout ->
           let xid = Randomconv.int32 Mirage_crypto_rng.generate in
           let (client, dhcpdiscover) = Dhcp_client.create ?requests xid (Net.mac net) in
           c := client;
@@ -89,23 +167,18 @@ module Make (Net : Mirage_net.S) = struct
                        (Fmt.list Ipaddr.V4.pp) (collect_routers l.options));
           Lwt_mvar.put t.lease l >>= fun () ->
           c := s;
-          Lwt_condition.broadcast cond ();
-          (* TODO think more abour renewal, adjust timeouts *)
-          match renew with
-          | true ->
-            Mirage_sleep.ns @@ Duration.of_sec 1800 >>= fun () ->
-            do_renew !c 1800
-          | false ->
-            Lwt.return_unit
+          Lwt_condition.broadcast cond l;
+          Lwt.return_unit
       )
     in
     let lease_wrapper t stop_waker =
-      let cond = Lwt_condition.create () in
-      Lwt.both
+      Lwt.all
+        [
         (listen t cond >|= fun r ->
-         Lwt.wakeup_later stop_waker r)
-        (get_lease cond dhcpdiscover)
-      >|= fun ((), ()) -> ()
+         Lwt.wakeup_later stop_waker r);
+        (get_lease cond dhcpdiscover);
+      ]
+      >|= fun _units -> ()
     in
     let lease = Lwt_mvar.create_empty () in
     let stop, stop_waker = Lwt.task () in