[movitz-cvs] CVS update: movitz/losp/lib/net/dhcp.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz/losp/lib/net
In directory common-lisp.net:/tmp/cvs-serv18991

Modified Files:
	dhcp.lisp 
Log Message:
*** empty log message ***
Date: Tue May 24 01:30:38 2005
Author: ffjeld

Index: movitz/losp/lib/net/dhcp.lisp
diff -u movitz/losp/lib/net/dhcp.lisp:1.1 movitz/losp/lib/net/dhcp.lisp:1.2
--- movitz/losp/lib/net/dhcp.lisp:1.1	Sun May 22 00:36:33 2005
+++ movitz/losp/lib/net/dhcp.lisp	Tue May 24 01:30:38 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri May 13 23:24:01 2005
 ;;;;                
-;;;; $Id: dhcp.lisp,v 1.1 2005/05/21 22:36:33 ffjeld Exp $
+;;;; $Id: dhcp.lisp,v 1.2 2005/05/23 23:30:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -103,6 +103,13 @@
   (declare (dynamic-extent options))
   (loop while options
       do (ecase (pop options)
+	   (:lease-time
+	    (vector-push 51 packet)
+	    (vector-push 4 packet)
+	    (let ((time (pop options)))
+	      (check-type time (unsigned-byte 32))
+	      (loop for b from 24 downto 0 by 8
+		  do (vector-push (ldb (byte 8 b) time) packet))))
 	   (:message-type
 	    (vector-push 53 packet)
 	    (vector-push 1 packet)
@@ -168,6 +175,11 @@
 		      (subseq packet
 			      (fill-pointer packet)
 			      (incf (fill-pointer packet) length)))))
+	  (51 (assert (= 4 (vector-read packet)))
+	      (cons :lease-time
+		    (loop with time = 0 repeat 4
+			do (setf time (+ (* 256 time) (vector-read packet)))
+			finally (return time))))
 	  (53 (assert (= 1 (vector-read packet)))
 	      (cons :message-type
 		    (let ((message-type (vector-read packet)))
@@ -193,7 +205,7 @@
 			       (fill-pointer packet)
 			       (incf (fill-pointer packet) length)))))))))
 
-(defun format-dhcp-request (nic)
+(defun format-dhcp-request (nic &rest dhcp-options &key (message-type :dhcpdiscover))
   (let ((packet (make-ethernet-packet)))
     (with-ether-header (ether packet)
       (setf (ether :source) (mac-address nic)
@@ -217,8 +229,8 @@
 		  (dhcp :chaddr) (mac-address nic)
 		  (dhcp :magic) +dhcp-magic+)
 	    (setf (fill-pointer packet) (dhcp :end))
+	    (apply #'dhcp-push-options packet dhcp-options)
 	    (dhcp-push-options packet
-			       :message-type :dhcpdiscover
 			       :client-identifier (mac-address nic)
 			       :end)
 	    (setf (ip :length) (- (fill-pointer packet) (ether :end))
@@ -230,25 +242,26 @@
 	    packet))))))
 
 (defun dhcp-request (&optional (nic (or *ip4-nic* (ip4-init))))
-  (transmit nic (format-dhcp-request nic))
-  (loop with packet = (make-ethernet-packet)
-      when (and (receive nic packet)
-		(with-ether-header (ether packet)
-		  (format t "~&From ~@/ethernet:pprint-mac/ to ~:/ethernet:pprint-mac/..~%"
-			  packet packet)
-		  (with-ip4-header (ip packet :start (ether :end))
-		    (warn "Seeing ~/ip4:pprint-ip4/ from ~/ip4:pprint-ip4/."
-			  (ip4-address (ip :destination))
-			  (ip4-address (ip :source)))
-		    (with-udp-header (udp packet)
-		      (with-dhcp-header (dhcp packet)
-			(and (= 4 (ip :version))
-			     (= 17 (ip :protocol))
-			     (= 68 (udp :destination-port))
-			     (= +dhcp-magic+ (dhcp :magic))
-			     (setf (fill-pointer packet)
-			       (dhcp :end))))))))
+  (loop  with packet = (make-ethernet-packet)
+      repeat 5
+      do (transmit nic (format-dhcp-request nic))
+	 (sleep 1/2)
+      when (loop while (receive nic packet)
+	       thereis (with-ether-header (ether packet)
+			 (with-ip4-header (ip packet :start (ether :end))
+			   (when (and (= 4 (ip :version))
+				      (= 17 (ip :protocol)))
+			     (warn "Seeing UDP ~/ip4:pprint-ip4/ from ~/ip4:pprint-ip4/."
+				   (ip4-address (ip :destination))
+				   (ip4-address (ip :source)))
+			     (with-udp-header (udp packet)
+			       (when (= 68 (udp :destination-port))
+				 (with-dhcp-header (dhcp packet)
+				   (and (= +dhcp-magic+ (dhcp :magic))
+					(setf (fill-pointer packet)
+					  (dhcp :end))))))))))
       return (values packet (parse-dhcp-options packet))))
+