[movitz-cvs] CVS update: movitz/losp/lib/net/dhcp.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Tue May 24 07:15:54 UTC 2005
Update of /project/movitz/cvsroot/movitz/losp/lib/net
In directory common-lisp.net:/tmp/cvs-serv14520
Modified Files:
dhcp.lisp
Log Message:
*** empty log message ***
Date: Tue May 24 09:15:54 2005
Author: ffjeld
Index: movitz/losp/lib/net/dhcp.lisp
diff -u movitz/losp/lib/net/dhcp.lisp:1.2 movitz/losp/lib/net/dhcp.lisp:1.3
--- movitz/losp/lib/net/dhcp.lisp:1.2 Tue May 24 01:30:38 2005
+++ movitz/losp/lib/net/dhcp.lisp Tue May 24 09:15:54 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.2 2005/05/23 23:30:38 ffjeld Exp $
+;;;; $Id: dhcp.lisp,v 1.3 2005/05/24 07:15:54 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -56,14 +56,15 @@
+---------------------------------------------------------------+
|#
-(defmacro with-dhcp-header ((dhcp packet &key (start '(udp :end))) &body body)
+(defmacro with-dhcp-header ((dhcp packet &key start) &body body)
(let* ((dhcp-ref (gensym "dhcp-ref-"))
(start-var (gensym "dhcp-start-"))
(packet-var (gensym "dhcp-packet-"))
(offset-var (gensym "dhcp-packet-start-")))
- `(let* ((,start-var ,start)
- (,packet-var (ensure-data-vector ,packet ,start-var 232))
+ `(let* ((,packet-var ,packet)
+ (,start-var ,(or start `(fill-pointer ,packet-var)))
(,offset-var (+ ,start-var (movitz-type-slot-offset 'movitz-basic-vector 'data))))
+ (ensure-data-vector ,packet ,start-var 232)
(macrolet ((,dhcp-ref (offset type)
`(memref ,',packet-var (+ ,',offset-var ,offset) :type ,type :endian :big))
(,dhcp (slot)
@@ -77,7 +78,7 @@
(:flags
`(,',dhcp-ref 10 :unsigned-byte16))
((:ciaddr :yiaddr :siaddr :giaddr)
- `(,',dhcp-ref ,(+ 12 (position slot '(:ciaddr :yiaddr :siaddr :giaddr)))
+ `(,',dhcp-ref ,(+ 12 (* 4 (position slot '(:ciaddr :yiaddr :siaddr :giaddr))))
:unsigned-byte32))
(:chaddr
`(memrange ,',packet-var 0 (+ ,',offset-var 28) 16 :unsigned-byte8))
@@ -102,7 +103,7 @@
(defun dhcp-push-options (packet &rest options)
(declare (dynamic-extent options))
(loop while options
- do (ecase (pop options)
+ do (case (pop options)
(:lease-time
(vector-push 51 packet)
(vector-push 4 packet)
@@ -133,16 +134,17 @@
unless (= 0 option)
collect
(case option
- (1 (assert (= 4 (vector-read packet)))
+ (1 (assert (= 4 (vector-read packet)) () "Wrong length for subnet-mask.")
(cons :subnet-mask
(subseq packet
(fill-pointer packet)
(incf (fill-pointer packet) 4))))
(3 (let ((length (vector-read packet)))
(cons :routers
- (subseq packet
- (fill-pointer packet)
- (incf (fill-pointer packet) length)))))
+ (loop repeat (truncate length 4)
+ collect (subseq packet
+ (fill-pointer packet)
+ (incf (fill-pointer packet) 4))))))
(6 (let ((length (vector-read packet)))
(cons :dns-servers
(subseq packet
@@ -160,7 +162,7 @@
(subseq packet
(fill-pointer packet)
(incf (fill-pointer packet) length))))))
- (28 (assert (= 4 (vector-read packet)))
+ (28 (assert (= 4 (vector-read packet)) () "Wrong length for broadcast.")
(cons :broadcast
(subseq packet
(fill-pointer packet)
@@ -175,7 +177,7 @@
(subseq packet
(fill-pointer packet)
(incf (fill-pointer packet) length)))))
- (51 (assert (= 4 (vector-read packet)))
+ (51 (assert (= 4 (vector-read packet)) () "Wrong length for lease-time.")
(cons :lease-time
(loop with time = 0 repeat 4
do (setf time (+ (* 256 time) (vector-read packet)))
@@ -205,7 +207,7 @@
(fill-pointer packet)
(incf (fill-pointer packet) length)))))))))
-(defun format-dhcp-request (nic &rest dhcp-options &key (message-type :dhcpdiscover))
+(defun format-dhcp-request (nic &rest dhcp-options &key (xid 0) (message-type :dhcpdiscover))
(let ((packet (make-ethernet-packet)))
(with-ether-header (ether packet)
(setf (ether :source) (mac-address nic)
@@ -213,7 +215,7 @@
(ether :type) +ether-type-ip4+)
(with-ip4-header (ip packet :start (ether :end))
(with-udp-header (udp packet)
- (with-dhcp-header (dhcp packet)
+ (with-dhcp-header (dhcp packet :start (udp :end))
(setf (ip :version) 4
(ip :protocol) 17
(ip :ihl) 5
@@ -226,6 +228,7 @@
(dhcp :hlen ) 6
(dhcp :hops) 0
(dhcp :secs) 0
+ (dhcp :xid) xid
(dhcp :chaddr) (mac-address nic)
(dhcp :magic) +dhcp-magic+)
(setf (fill-pointer packet) (dhcp :end))
@@ -241,10 +244,12 @@
(udp :checksum) (udp :compute-checksum ip))
packet))))))
-(defun dhcp-request (&optional (nic (or *ip4-nic* (ip4-init))))
- (loop with packet = (make-ethernet-packet)
+(defun dhcp-request (&optional (nic (or *ip4-nic* (ip4-init))) &rest dhcp-options)
+ (declare (dynamic-extent dhcp-options))
+ (loop with packet = (make-ethernet-packet)
+ with xid = (random 10000)
repeat 5
- do (transmit nic (format-dhcp-request nic))
+ do (transmit nic (apply #'format-dhcp-request nic :xid xid dhcp-options))
(sleep 1/2)
when (loop while (receive nic packet)
thereis (with-ether-header (ether packet)
@@ -256,15 +261,25 @@
(ip4-address (ip :source)))
(with-udp-header (udp packet)
(when (= 68 (udp :destination-port))
+ (setf (fill-pointer packet)
+ (udp :end))
(with-dhcp-header (dhcp packet)
- (and (= +dhcp-magic+ (dhcp :magic))
- (setf (fill-pointer packet)
- (dhcp :end))))))))))
- return (values packet (parse-dhcp-options packet))))
-
-
-
-
-
-
-
\ No newline at end of file
+ (and (= xid (dhcp :xid))
+ (= +dhcp-magic+ (dhcp :magic))))))))))
+ return packet))
+
+(defun dhcp-init ()
+ (let ((packet (dhcp-request)))
+ (if (not packet)
+ (warn "DHCP lookup failed.")
+ (with-dhcp-header (dhcp packet)
+ (setf (fill-pointer packet) (dhcp :end))
+ (let ((options (parse-dhcp-options packet)))
+ (setf *ip4-ip* (ip4-address (dhcp :yiaddr))
+ *ip4-router* (first (cdr (assoc :routers options))))
+ (format *terminal-io* "Setting IP ~/ip4:pprint-ip4/ ~@[~A~]~@[.~A~] router ~/ip4:pprint-ip4/."
+ *ip4-ip*
+ (cdr (assoc :host-name options))
+ (cdr (assoc :domain-name options))
+ *ip4-router*)))))
+ (values))
More information about the Movitz-cvs
mailing list