mirror of git://git.savannah.gnu.org/guix/dhcp.git
fix bugs in serializer and deserializer
This commit is contained in:
parent
2145316f89
commit
0937fcf663
|
@ -27,9 +27,14 @@
|
|||
#:use-module (rnrs enums)
|
||||
#:export (<dhcp-msg>
|
||||
make-dhcp-msg
|
||||
make-dhcp-message ; wrapper for make-dhcp-msg
|
||||
|
||||
make-dhcpdiscover
|
||||
|
||||
dhcp-msg?
|
||||
|
||||
bytevector-slice
|
||||
|
||||
dhcp-msg-op set-dhcp-msg-op!
|
||||
dhcp-msg-htype set-dhcp-msg-htype!
|
||||
dhcp-msg-hlen set-dhcp-msg-hlen!
|
||||
|
@ -49,11 +54,19 @@
|
|||
set-broadcast-bit
|
||||
unset-broadcast-bit
|
||||
option-value
|
||||
serialize-dhcp-message
|
||||
deserialize-dhcp-message
|
||||
message-type
|
||||
make-dhcpdiscover
|
||||
map-type-to-code))
|
||||
|
||||
serialize-dhcp-msg
|
||||
deserialize-dhcp-msg
|
||||
deserialize-options
|
||||
|
||||
msg-type
|
||||
|
||||
retrieve-secs
|
||||
retrieve-xid
|
||||
retrieve-ciaddr
|
||||
|
||||
map-type-to-code
|
||||
map-type-to-op))
|
||||
|
||||
;; Magic cookie that starts off the 'options' field
|
||||
;; in a DHCP message packet.
|
||||
|
@ -116,75 +129,77 @@
|
|||
;; remaining bits are always zero, see Figure 2, RFC 2131.
|
||||
(define-syntax-rule (set-broadcast-bit msg)
|
||||
(set-dhcp-msg-flags #x8000))
|
||||
|
||||
(define-syntax-rule (unset-broadcast-bit msg)
|
||||
(set-dhcp-msg-flags 0))
|
||||
|
||||
#;(define (serialize-options! opts dst idx)
|
||||
"Copy the options field OPTS from a <dhcp-message> into a
|
||||
(define (serialize-options! opts dst idx)
|
||||
"Copy the options field OPTS from a <dhcp-msg> into a
|
||||
bytevector. OPTS is a vector, DST is a bytevector.
|
||||
Copying starts at index IDX in DST. This function mutates DST.
|
||||
If an option is #f, it means it does not exist, so it is
|
||||
If an option is #f, it does not exist, so it is
|
||||
simply ignored whilst serializing."
|
||||
(let loop ((i 0))
|
||||
(if (< i 256)
|
||||
(let loop ((i 0) (to idx))
|
||||
(if (< i 255)
|
||||
(let* ((opt (vector-ref opts i)))
|
||||
(if (eq? #f opt)
|
||||
(loop (1+ i))
|
||||
(if (eq? #f opt) ; option not present
|
||||
(loop (1+ i) to)
|
||||
(let ((code i)
|
||||
(len (dhcp-option-len opt))
|
||||
(val (dhcp-option-val opt)))
|
||||
(begin
|
||||
(if (zero? len)
|
||||
(bytevector-u8-set! dst idx code)
|
||||
(bytevector-u8-set! dst to code)
|
||||
(begin
|
||||
(bytevector-u8-set! dst idx code)
|
||||
(bytevector-u8-set! dst (1+ idx) len)
|
||||
(bytevector-copy! val 0 dst (+ idx 2) len)))
|
||||
(loop (1+ i)))))))))
|
||||
(bytevector-u8-set! dst to code)
|
||||
(bytevector-u8-set! dst (1+ to) len)
|
||||
(bytevector-copy! val 0 dst (+ to 2) len)))
|
||||
(loop (1+ i) (+ to 2 len))))))
|
||||
(bytevector-u8-set! dst to 255))))
|
||||
|
||||
; Serialize a <dhcp-message> object into a bytevector.
|
||||
#;(define-method (serialize-dhcp-message (msg <dhcp-message>))
|
||||
(define (serialize-dhcp-msg msg)
|
||||
"Serialize a <dhcp-message> record MSG into a bytevector"
|
||||
(let* ((res (make-bytevector 576 0))
|
||||
(chaddr (slot-ref msg 'chaddr))
|
||||
(chaddr (dhcp-msg-chaddr msg))
|
||||
(chaddr-len (bytevector-length chaddr))
|
||||
(padded-chaddr (make-bytevector 16 0))
|
||||
(_ (bytevector-copy! chaddr 0
|
||||
padded-chaddr (- 16 chaddr-len)
|
||||
chaddr-len)))
|
||||
(bytevector-u8-set! res 0 (slot-ref msg 'op))
|
||||
(bytevector-u8-set! res 1 (slot-ref msg 'htype))
|
||||
(bytevector-u8-set! res 2 (slot-ref msg 'hlen))
|
||||
(bytevector-u8-set! res 3 (slot-ref msg 'hops))
|
||||
(bytevector-u32-set! res 4 (slot-ref msg 'xid) (endianness big))
|
||||
(bytevector-u16-set! res 8 (slot-ref msg 'secs) (endianness big))
|
||||
(bytevector-u16-set! res 10 (slot-ref msg 'flags) (endianness big))
|
||||
(bytevector-copy! (slot-ref msg 'ciaddr) 0 res 12 4)
|
||||
(bytevector-copy! (slot-ref msg 'yiaddr) 0 res 16 4)
|
||||
(bytevector-copy! (slot-ref msg 'siaddr) 0 res 20 4)
|
||||
(bytevector-copy! (slot-ref msg 'giaddr) 0 res 24 4)
|
||||
(bytevector-u8-set! res 0 (dhcp-msg-op msg))
|
||||
(bytevector-u8-set! res 1 (dhcp-msg-htype msg))
|
||||
(bytevector-u8-set! res 2 (dhcp-msg-hlen msg))
|
||||
(bytevector-u8-set! res 3 (dhcp-msg-hops msg))
|
||||
(bytevector-u32-set! res 4 (dhcp-msg-xid msg) (endianness big))
|
||||
(bytevector-u16-set! res 8 (dhcp-msg-secs msg) (endianness big))
|
||||
(bytevector-u16-set! res 10 (dhcp-msg-flags msg) (endianness big))
|
||||
(bytevector-copy! (dhcp-msg-ciaddr msg) 0 res 12 4)
|
||||
(bytevector-copy! (dhcp-msg-yiaddr msg) 0 res 16 4)
|
||||
(bytevector-copy! (dhcp-msg-siaddr msg) 0 res 20 4)
|
||||
(bytevector-copy! (dhcp-msg-giaddr msg) 0 res 24 4)
|
||||
(bytevector-copy! padded-chaddr 0 res 28 16)
|
||||
(bytevector-copy! (slot-ref msg 'sname) 0 res 44 64)
|
||||
(bytevector-copy! (slot-ref msg 'file) 0 res 108 128)
|
||||
(bytevector-copy! (dhcp-msg-sname msg) 0 res 44 64)
|
||||
(bytevector-copy! (dhcp-msg-file msg) 0 res 108 128)
|
||||
(bytevector-copy! *magic-cookie* 0 res 236 4)
|
||||
(serialize-options! (slot-ref msg 'options) res 240)
|
||||
(serialize-options! (dhcp-msg-options msg) res 240)
|
||||
res))
|
||||
|
||||
; Read options from a bytevector 'src' starting at index
|
||||
; 'idx' and returns a vector of <dhcp-option> objects.
|
||||
#;(define (deserialize-options src idx)
|
||||
(define (deserialize-options src idx)
|
||||
"Read options from a bytevector SRC starting at index
|
||||
IDX and returns a vector of <dhcp-option> records. We ignore
|
||||
the PAD option since its only purpose is to pad the
|
||||
bytevector; it carries no other useful information."
|
||||
(define (helper src i res)
|
||||
(if (= i (bytevector-length src))
|
||||
res ; nothing more to read from 'src'
|
||||
(let* ((code (bytevector-u8-ref src i)))
|
||||
(if (or (= code 0) (code 255))
|
||||
(begin
|
||||
(slot-set! res code (make-dhcp-option code 0 #f))
|
||||
(helper src (+ i 1) res))
|
||||
(if (= code 255)
|
||||
res ; we have seen an 'end' option, stop reading
|
||||
(let* ((len (bytevector-u8-ref src (+ i 1)))
|
||||
(val (make-bytevector len))
|
||||
(_ (bytevector-copy! src (+ i 2) val 0 len)))
|
||||
(begin
|
||||
(slot-set! res code (make-dhcp-option code len val))
|
||||
(vector-set! res code (make-dhcp-option code len val))
|
||||
(helper src (+ i 2 len) res)))))))
|
||||
(helper src idx (make-vector 256 #f)))
|
||||
|
||||
|
@ -199,20 +214,24 @@ from BV starting at index START"
|
|||
(bytevector-copy! bv start res 0 len)
|
||||
res))
|
||||
|
||||
#;(define (deserialize-dhcp-message msg)
|
||||
(make <dhcp-message>
|
||||
#:op (bytevector-u8-ref msg 0)
|
||||
#:htype (bytevector-u8-ref msg 1)
|
||||
#:hops (bytevector-u8-ref msg 2)
|
||||
#:xid (bytevector-u32-ref msg 4 (endianness big))
|
||||
#:secs (bytevector-u16-ref msg 8 (endianness big))
|
||||
#:flags (bytevector-u16-ref msg 10 (endianness big))
|
||||
#:ciaddr (bytevector-u32-ref msg 12 (endianness big))
|
||||
#:yiaddr (bytevector-u32-ref msg 16 (endianness big))
|
||||
#:siaddr (bytevector-u32-ref msg 20 (endianness big))
|
||||
#:giaddr (bytevector-u32-ref msg 24 (endianness big))
|
||||
; TODO: chaddr
|
||||
#:options (deserialize-options msg 240)))
|
||||
(define (deserialize-dhcp-msg msg)
|
||||
(make-dhcp-msg
|
||||
(bytevector-u8-ref msg 0) ; op
|
||||
(bytevector-u8-ref msg 1) ; htype
|
||||
(bytevector-u8-ref msg 2) ; hlen
|
||||
(bytevector-u8-ref msg 3) ; hops
|
||||
(bytevector-u32-ref msg 4 (endianness big)) ; xid
|
||||
(bytevector-u16-ref msg 8 (endianness big)) ; secs
|
||||
(bytevector-u16-ref msg 10 (endianness big)) ; flags
|
||||
(bytevector-u32-ref msg 12 (endianness big)) ; ciaddr
|
||||
(bytevector-u32-ref msg 16 (endianness big)) ; yiaddr
|
||||
(bytevector-u32-ref msg 20 (endianness big)) ; siaddr
|
||||
(bytevector-u32-ref msg 24 (endianness big)) ; giaddr
|
||||
(bytevector-slice msg 28 16) ; chaddr
|
||||
(bytevector-slice msg 44 64) ; sname
|
||||
(bytevector-slice msg 108 128) ; file
|
||||
(deserialize-options msg 240) ; options
|
||||
))
|
||||
|
||||
;; Set an <option> in a <dhcp-msg>.
|
||||
(define-syntax-rule (set-option! msg opt)
|
||||
|
@ -224,13 +243,13 @@ from BV starting at index START"
|
|||
;; Retrieve an option's value from a <dhcp-msg>
|
||||
;; record MSG given its code CODE.
|
||||
(define-syntax-rule (option-value msg code)
|
||||
(let* ((opts (slot-ref msg 'options))
|
||||
(let* ((opts (dhcp-msg-options msg))
|
||||
(opt (vector-ref opts code))
|
||||
(val (dhcp-option-val opt)))
|
||||
val))
|
||||
|
||||
;; Get the DHCP message type. See Section 9.6, RFC 2132.
|
||||
(define-syntax-rule (message-type msg)
|
||||
(define-syntax-rule (msg-type msg)
|
||||
(option-value msg 53))
|
||||
|
||||
;; Map a DHCP message type to its single-digit code.
|
||||
|
@ -251,17 +270,18 @@ from BV starting at index START"
|
|||
((eq? 'DHCPNAK type) 2)
|
||||
(else 1))))
|
||||
|
||||
(define (make-dhcp-msg netif type opts)
|
||||
(define (make-dhcp-message netif type opts)
|
||||
"Make an instance of <dhcp-msg> for interface NETIF
|
||||
with message type TYPE and options initialized to OPTS"
|
||||
(let* ((pair (net-iface-hwaddr netif))
|
||||
(let* ((dhcp (net-iface-dhcp netif))
|
||||
(pair (net-iface-hwaddr netif))
|
||||
(chaddr (car pair))
|
||||
(htype (cdr pair))
|
||||
(hlen (bytevector-length chaddr))
|
||||
(op (map-type-to-op type))
|
||||
(dhcp (net-iface-dhcp netif))
|
||||
(msg-type-code (map-name-to-code
|
||||
'DHCP-MSG-TYPE)))
|
||||
'DHCP-MESSAGE-TYPE))
|
||||
(end-code (map-name-to-code 'END)))
|
||||
(begin
|
||||
(vector-set! opts
|
||||
msg-type-code ; 53
|
||||
|
@ -319,7 +339,7 @@ ciaddr field in a <dhcp-msg> object."
|
|||
|
||||
;; TODO: figure out from 2131 exactly when to
|
||||
;; return secs since config and when to return 0
|
||||
(define (retrieve-secs netif type)
|
||||
#;(define (retrieve-secs netif type)
|
||||
"Given a <net-interface> NETIF and the message
|
||||
type TYPE, return the appropriate value for the
|
||||
secs field in a <dhcp-msg> object."
|
||||
|
@ -330,5 +350,8 @@ secs field in a <dhcp-msg> object."
|
|||
(else (- (current-time) ; might need to change
|
||||
(dhcp-config-start dhcp))))))
|
||||
|
||||
(define-syntax-rule (make-dhcpdiscover netif opts)
|
||||
(make-dhcp-msg netif 'DHCPDISCOVER opts))
|
||||
(define (retrieve-secs netif type)
|
||||
0)
|
||||
|
||||
(define (make-dhcpdiscover netif opts)
|
||||
(make-dhcp-message netif 'DHCPDISCOVER opts))
|
||||
|
|
|
@ -19,8 +19,10 @@
|
|||
|
||||
(use-modules (srfi srfi-64)
|
||||
((guix build syscalls) #:select (all-network-interfaces))
|
||||
(dhcp interfaces)
|
||||
(dhcp messages)
|
||||
(dhcp interfaces)
|
||||
(dhcp dhcp)
|
||||
(dhcp options base)
|
||||
(dhcp options names)
|
||||
(rnrs bytevectors))
|
||||
|
||||
|
@ -31,18 +33,35 @@
|
|||
(all-network-interfaces)))
|
||||
'DHCP-INIT))
|
||||
|
||||
(define msg
|
||||
|
||||
(define msg-type-code (map-name-to-code
|
||||
'DHCP-MESSAGE-TYPE))
|
||||
|
||||
(define original
|
||||
(make-dhcpdiscover netif (make-vector 256 #f)))
|
||||
|
||||
(display (vector-ref (dhcp-msg-options original) 243))
|
||||
(newline) (newline)
|
||||
|
||||
(test-begin "dhcp-messages")
|
||||
|
||||
(test-eq "message-type"
|
||||
(map-type-to-code 'DHCPDISCOVER)
|
||||
(bytevector-u8-ref (message-type msg) 0))
|
||||
(bytevector-u8-ref (msg-type original) 0))
|
||||
|
||||
(define serialized (serialize-dhcp-message msg))
|
||||
(define serialized (serialize-dhcp-msg original))
|
||||
|
||||
;(define deserialized (deserialize-dhcp-message msg))
|
||||
;(define opts (deserialize-options serialized 240))
|
||||
|
||||
(define deserialized (deserialize-dhcp-msg serialized))
|
||||
|
||||
(test-eqv "fields-preserved-xid"
|
||||
(dhcp-msg-xid deserialized)
|
||||
(dhcp-msg-xid original))
|
||||
|
||||
(test-equal "fields-preserved-options"
|
||||
(dhcp-msg-options deserialized)
|
||||
(dhcp-msg-options original))
|
||||
|
||||
(test-end)
|
||||
|
||||
|
|
Loading…
Reference in New Issue