guix
/
dhcp
mirror of git://git.savannah.gnu.org/guix/dhcp.git
2
0
Fork 0
Code Issues Releases Wiki Activity

dhcp: switch to srfi-9 records + numerous small fixes to follow style guide

This commit is contained in:
Rohan Prinja 2015-06-10 09:47:51 +05:30
parent a60c0f4e88
commit f591e1fd4d
5 changed files with 224 additions and 214 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
dhcp/client.scm
View File

@ -20,7 +20,7 @@
coding: utf-8 coding: utf-8
!# !#
; DHCP client module ;; DHCP client module
(define-module (dhcp client) (define-module (dhcp client)
#:use-module (dhcp dhcp) #:use-module (dhcp dhcp)
#:use-module (ice-9 getopt-long) #:use-module (ice-9 getopt-long)
@ -59,5 +59,5 @@ dhcp-client [options]
(begin (begin
(display "Hello, World!") (newline))))) (display "Hello, World!") (newline)))))
; Seed the random state. ;; Seed the random state.
(set! *random-state* (random-state-from-platform)) (set! *random-state* (random-state-from-platform))

31
dhcp/dhcp.scm
View File

@ -17,7 +17,6 @@
(define-module (dhcp dhcp) (define-module (dhcp dhcp)
#:use-module (dhcp messages) #:use-module (dhcp messages)
#:use-module (oop goops)
#:use-module (rnrs base) #:use-module (rnrs base)
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
@ -27,6 +26,12 @@
dhcp-state set-dhcp-state! dhcp-state set-dhcp-state!
dhcp-tries set-dhcp-tries! dhcp-tries set-dhcp-tries!
dhcp-ip-addr set-dhcp-ip-addr!
dhcp-sn-mask set-dhcp-sn-mask!
dhcp-gw-addr set-dhcp-gw-addr!
dhcp-config-start set-dhcp-config-start!
dhcp-start dhcp-start
dhcp-renew dhcp-renew
dhcp-release dhcp-release
@ -37,8 +42,8 @@
generate-different-xid generate-different-xid
generate-random-xid)) generate-random-xid))
;; Class for DHCP objects. ;; Record type for DHCP objects.
;; A <dhcp> object is held by an interface, and contains ;; A <dhcp> record is held by an interface, and contains
;; information about the configuration process for that ;; information about the configuration process for that
;; specific interface. ;; specific interface.
(define-record-type <dhcp> (define-record-type <dhcp>
@ -59,21 +64,21 @@
(lease-ack dhcp-lease-ack) ; time since last DHCPACK (lease-ack dhcp-lease-ack) ; time since last DHCPACK
;; Offered IP address, subnet mask and gateway address. ;; Offered IP address, subnet mask and gateway address.
(ip-addr dhcp-ip-addr) (ip-addr dhcp-ip-addr set-dhcp-ip-addr!)
(sn-mask dhcp-sn-mask) (sn-mask dhcp-sn-mask set-dhcp-sn-mask!)
(gw-addr dhcp-gw-addr) (gw-addr dhcp-gw-addr set-dhcp-gw-addr!)
;; Time at which configuration process was started. ;; Time at which configuration process was started.
(config-start dhcp-config-start set-dhcp-config-start!)) (config-start dhcp-config-start set-dhcp-config-start!))
(define (generate-random-xid) ;; Generate a random 32-bit number to be used as
"Generate a random 32-bit number to be used as ;; a transaction id.
a transaction id." (define-syntax-rule (generate-random-xid)
(random (expt 2 32))) (random (expt 2 32)))
(define-method (generate-different-xid (dhcp <dhcp>)) ;; Generate a new, different transaction id for
"Generate a new, different transaction id for ;; a dhcp object. We simply increment the old one.
a dhcp object. We simply increment the old one." (define-syntax-rule (generate-different-xid dhcp)
(1+ (dhcp-xid dhcp))) (1+ (dhcp-xid dhcp)))
;; TODO: make a separate lease file for each interface rather than ;; TODO: make a separate lease file for each interface rather than
@ -146,7 +151,7 @@ interface NETIF."
'DHCP-INIT-REBOOT 'DHCP-INIT-REBOOT
'DHCP-INIT))) 'DHCP-INIT)))
(display (format #f "start-config: entered ~a state\n" dhcp-state)) (display (format #f "start-config: entered ~a state\n" dhcp-state))
(slot-set! (slot-ref netif 'dhcp) (current-time)) (slot-set! (net-iface-dhcp netif) (current-time))
(if (eq? dhcp-state 'INIT) (if (eq? dhcp-state 'INIT)
(begin (begin
(wait-desync) (wait-desync)

137
dhcp/interfaces.scm
View File

@ -18,16 +18,24 @@
(define-module (dhcp interfaces) (define-module (dhcp interfaces)
#:use-module (dhcp dhcp) #:use-module (dhcp dhcp)
#:use-module (system foreign) #:use-module (system foreign)
#:use-module (oop goops) #:use-module (srfi srfi-9)
#:use-module (guix build syscalls) #:use-module (guix build syscalls)
#:use-module (rnrs base) #:use-module (rnrs base)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:export (<net-interface> #:export (<net-iface>
hardware-address hardware-address
hardware-family hardware-family
retain-ethernet-interfaces retain-ethernet-interfaces
print-hardware-address print-hardware-address
make-network-interface)) make-net-iface
net-iface?
net-iface-name
net-iface-flags set-net-iface-flags!
net-iface-ipaddr set-net-iface-ipaddr!
net-iface-netmask set-net-iface-netmask!
net-iface-gateway set-net-iface-gateway!
net-iface-hwaddr set-net-iface-hwaddr!
net-iface-dhcp))
;;; Taken/modified from (guix build syscalls) begin ;;; Taken/modified from (guix build syscalls) begin
@ -36,7 +44,7 @@
#x8927 ; GNU/Linux #x8927 ; GNU/Linux
-1)) -1))
; Maximum interface name size ;; Maximum interface name size.
(define IF_NAMESIZE 16) (define IF_NAMESIZE 16)
(define ifreq-struct-size (define ifreq-struct-size
@ -55,7 +63,7 @@
;;; Taken from (guix build syscalls) end ;;; Taken from (guix build syscalls) end
(define *libinterfaces* (dynamic-link "../lib/libinterfaces.so")) (define *libinterfaces* (dynamic-link "lib/libinterfaces.so"))
(define-syntax-rule (link-fn c-fn-name lib ret-type c-fn-args arg ...) (define-syntax-rule (link-fn c-fn-name lib ret-type c-fn-args arg ...)
"FFI wrapper for a function defined in a .so library" "FFI wrapper for a function defined in a .so library"
@ -64,46 +72,37 @@
c-fn-args))) c-fn-args)))
(f arg ...))) (f arg ...)))
; Obtain a list of interfaces from getifaddrs (3) ;; Obtain a list of interfaces from getifaddrs (3).
(define-syntax-rule (get-first-interface-ptr) (define-syntax-rule (get-first-interface-ptr)
(link-fn "get_first_interface_ptr" *libinterfaces* '* '())) (link-fn "get_first_interface_ptr" *libinterfaces* '* '()))
; Free the memory allocated by (find-interfaces) ;; Free the memory allocated by (find-interfaces).
(define-syntax-rule (free-interfaces ifaddrs) (define-syntax-rule (free-interfaces ifaddrs)
(link-fn "free_interfaces" *libinterfaces* void '(*) ifaddrs)) (link-fn "free_interfaces" *libinterfaces* void '(*) ifaddrs))
; Print some information about the interfaces. ;; Struct type for struct ifaddrs. See also: getifaddrs (3).
(define-syntax-rule (print-interfaces)
(link-fn "print_interfaces" *libinterfaces* void '()))
; Get address data for a given ifaddr
;; (define-syntax-rule (get-sockaddr-data ifaddrs)
;; (pointer->string
;; (link-fn "get_sockaddr_data" *libinterfaces* '* '(*) ifaddrs)))
; Struct type for struct ifaddrs. See also: getifaddrs (3)
(define *ifaddrs-struct-type* (list '* '* unsigned-int '* '* '* '*)) (define *ifaddrs-struct-type* (list '* '* unsigned-int '* '* '* '*))
; Struct type for struct sockaddr. See also: bind (2) ;; Struct type for struct sockaddr. See also: bind (2).
(define *sockaddr-struct-type* (list unsigned-short '*)) (define *sockaddr-struct-type* (list unsigned-short '*))
; Given a pointer to a struct ifaddrs, parse it using ;; Given a pointer to a struct ifaddrs, parse it using
; parse-c-struct. ;; parse-c-struct.
(define-syntax-rule (parse-ifaddr ifaddrs) (define-syntax-rule (parse-ifaddr ifaddrs)
(parse-c-struct ifaddrs *ifaddrs-struct-type*)) (parse-c-struct ifaddrs *ifaddrs-struct-type*))
; Given a pointer to a struct sockaddr, parse it using ;; Given a pointer to a struct sockaddr, parse it using
; parse-c-struct. ;; parse-c-struct.
(define-syntax-rule (parse-sockaddr sockaddr) (define-syntax-rule (parse-sockaddr sockaddr)
(parse-c-struct sockaddr *sockaddr-struct-type*)) (parse-c-struct sockaddr *sockaddr-struct-type*))
; Note: In the <ifaddrs.h> library, struct ifaddrs is ;; Note: In the <ifaddrs.h> library, struct ifaddrs is
; an intrusive linked list of interface addresses. ;; an intrusive linked list of interface addresses.
; Given a struct ifaddrs pointer which has been parsed ;; Given a struct ifaddrs pointer which has been parsed
; using parse-c-struct, obtain and parse the next ifaddrs ;; using parse-c-struct, obtain and parse the next ifaddrs
; struct in the intrusive linked list. If we are already ;; struct in the intrusive linked list. If we are already
; at the end of the list, do not do anything. ;; at the end of the list, do not do anything.
(define-syntax-rule (next-parsed-ifaddr parsed) (define-syntax-rule (next-parsed-ifaddr parsed)
(let ((next-ptr (car parsed))) (let ((next-ptr (car parsed)))
(if (null-pointer? next-ptr) (if (null-pointer? next-ptr)
@ -125,10 +124,7 @@
"Create a UDP datagram socket." "Create a UDP datagram socket."
(let ((sock (socket PF_INET SOCK_DGRAM IPPROTO_UDP))) (let ((sock (socket PF_INET SOCK_DGRAM IPPROTO_UDP)))
(if (= (fileno sock) -1) (if (= (fileno sock) -1)
(throw 'system-error "make-dgram-sock" (throw 'system-error "make-dgram-sock")
"make-dgram-sock on ~A: ~A"
(list name (strerror err))
(list err))
sock))) sock)))
(define (find-interfaces ifaddrs) (define (find-interfaces ifaddrs)
@ -147,9 +143,11 @@
(if (af-inet? family) (if (af-inet? family)
(display (format #f "Name ~a, Family ~a\n" name family))) (display (format #f "Name ~a, Family ~a\n" name family)))
(helper (next-parsed-ifaddr parsed) (helper (next-parsed-ifaddr parsed)
(cons (make <net-interface> (cons (make-net-iface
#:name name name
#:flags flags) flags
#vu8(0 0 0 0) #vu8(0 0 0 0) #vu8(0 0 0 0)
(cons #f #f))
result))))) result)))))
(helper (parse-ifaddr ifaddrs) '())) (helper (parse-ifaddr ifaddrs) '()))
@ -213,41 +211,48 @@ interface names"
(string-prefix? "eth" name)) (string-prefix? "eth" name))
ifaces)) ifaces))
; Class for network interfaces. ;; Record type for network interfaces.
; See also: getifaddrs (3). ;; See also: getifaddrs (3).
(define-class <net-interface> () (define-record-type <net-iface>
(name #:init-keyword #:name) (make-net-iface name
(flags #:init-keyword #:flags) flags
(ipaddr #:init-keyword #:ipaddr) ipaddr netmask gateway
(netmask #:init-keyword #:netmask) hwaddr
(gateway #:init-keyword #:gateway) dhcp)
(hwaddr #:init-keyword #:hwaddr) net-iface?
(dhcp #:init-keyword #:dhcp)) (name net-iface-name)
(flags net-iface-flags set-net-iface-flags!)
(ipaddr net-iface-ipaddr set-net-iface-ipaddr!)
(netmask net-iface-netmask set-net-iface-netmask!)
(gateway net-iface-gateway set-net-iface-gateway!)
(hwaddr net-iface-hwaddr set-net-iface-hwaddr!)
(dhcp net-iface-dhcp))
; DHCP in <net-interface> is an instance of ;; Note: DHCP in <net-iface> is an instance of
; the <dhcp> class storing the configuration ;; the <dhcp> record type storing the configuration
; details for that particular interface. ;; details for that particular interface.
; HWADDR is a pair in which the first element ;; HWADDR is a pair in which the first element
; is the hardware address as a bytevector, and ;; is the hardware address as a bytevector, and
; the second element is the hardware type (see ;; the second element is the hardware type (see
; arp/identifiers.scm). ;; arp/identifiers.scm).
(define (make-network-interface name init-state) ;; Create a <net-iface> record for the
"Create a <network-interface> instance for the ;; interface NAME
interface NAME" (define-syntax-rule (make-network-interface name init-state)
(let* ((_ (assert (or (eq? init-state 'DHCP-INIT) (let* ((_ (assert (or (eq? init-state 'DHCP-INIT)
(eq? init-state 'DHCP-INIT-REBOOT)))) (eq? init-state 'DHCP-INIT-REBOOT))))
(hwaddr (hardware-address name)) (hwaddr (hardware-address name))
(htype (hardware-family name)) (htype (hardware-family name))
(pair (cons hwaddr htype))) (pair (cons hwaddr htype)))
(make <net-interface> (make-net-iface
#:name name name
#:hwaddr pair 0
#:ipaddr #vu8(0 0 0 0) #vu8(0 0 0 0) #vu8(0 0 0 0) #vu8(0 0 0 0)
#:dhcp (make <dhcp> pair
#:state init-state (make-dhcp
#:xid (generate-random-xid))))) (generate-random-xid)
init-state
; name = name of the network interface ("lo", "eth0", "wlan0", etc.) 0
; addr = interface address 0 0 0
; netmask = netmask of interface 0
#vu8(0 0 0 0) #vu8(0 0 0 0) #vu8(0 0 0 0)))))

248
dhcp/messages.scm
View File

@ -21,11 +21,31 @@
#:use-module (dhcp dhcp) #:use-module (dhcp dhcp)
#:use-module (dhcp options base) #:use-module (dhcp options base)
#:use-module (dhcp options names) #:use-module (dhcp options names)
#:use-module (oop goops) #:use-module (srfi srfi-9)
#:use-module (rnrs base) #:use-module (rnrs base)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (rnrs enums) #:use-module (rnrs enums)
#:export (<dhcp-message> #:export (<dhcp-msg>
make-dhcp-msg
dhcp-msg?
dhcp-msg-op set-dhcp-msg-op!
dhcp-msg-htype set-dhcp-msg-htype!
dhcp-msg-hlen set-dhcp-msg-hlen!
dhcp-msg-hops set-dhcp-msg-hops!
dhcp-msg-xid set-dhcp-msg-xid!
dhcp-msg-secs set-dhcp-msg-secs!
dhcp-msg-flags set-dhcp-msg-flags!
dhcp-msg-ciaddr set-dhcp-msg-ciaddr!
dhcp-msg-yiaddr set-dhcp-msg-yiaddr!
dhcp-msg-siaddr set-dhcp-msg-siaddr!
dhcp-msg-giaddr set-dhcp-msg-giaddr!
dhcp-msg-chaddr set-dhcp-msg-chaddr!
dhcp-msg-sname set-dhcp-msg-sname!
dhcp-msg-file set-dhcp-msg-file!
dhcp-msg-options set-dhcp-msg-options
set-broadcast-bit set-broadcast-bit
unset-broadcast-bit unset-broadcast-bit
option-value option-value
@ -35,12 +55,12 @@
make-dhcpdiscover make-dhcpdiscover
map-type-to-code)) map-type-to-code))
; Magic cookie that starts off the 'options' field ;; Magic cookie that starts off the 'options' field
; in a DHCP message packet. ;; in a DHCP message packet.
(define *magic-cookie* #vu8(99 130 83 99)) (define *magic-cookie* #vu8(99 130 83 99))
; Valid types for a DHCP message. ;; Valid types for a DHCP message.
(define *dhcp-message-types* (define *dhcp-msg-types*
(make-enumeration '(DHCPDISCOVER (make-enumeration '(DHCPDISCOVER
DHCPOFFER DHCPOFFER
DHCPREQUEST DHCPREQUEST
@ -50,41 +70,56 @@
DHCPRELEASE DHCPRELEASE
DHCPINFORM))) DHCPINFORM)))
; DHCP message object. ;; DHCP message object.
; See page 8, RFC 2131 for the message format. ;; See page 8, RFC 2131 for the message format.
(define-class <dhcp-message> () (define-record-type <dhcp-msg>
(op #:init-keyword #:op) (make-dhcp-msg op
(htype #:init-keyword #:htype) htype hlen
(hlen #:init-keyword #:hlen) hops
(hops #:init-form 0) xid
(xid #:init-keyword #:xid) secs
(secs #:init-keyword #:secs) flags
(flags #:init-form 0) ciaddr
(ciaddr #:init-keyword #:ciaddr) yiaddr siaddr giaddr
(yiaddr #:init-form (make-bytevector 4 0)) chaddr
(siaddr #:init-form (make-bytevector 4 0)) sname
(giaddr #:init-form (make-bytevector 4 0)) file
(chaddr #:init-keyword #:chaddr) options)
(sname #:init-form (make-bytevector 64 0))
(file #:init-form (make-bytevector 128 0)) dhcp-msg?
; Options are represented as a fixed-length
; vector in which each element is either a (op dhcp-msg-op set-dhcp-msg-op!)
; <dhcp-option> object or #nil. (htype dhcp-msg-htype set-dhcp-msg-htype!)
(options #:init-form (make-vector 256 #nil) (hlen dhcp-msg-hlen set-dhcp-msg-hlen!)
#:init-keyword #:options)) (hops dhcp-msg-hops set-dhcp-msg-hops!)
(xid dhcp-msg-xid set-dhcp-msg-xid!)
(secs dhcp-msg-secs set-dhcp-msg-secs!)
(flags dhcp-msg-flags set-dhcp-msg-flags!)
(ciaddr dhcp-msg-ciaddr set-dhcp-msg-ciaddr!)
(yiaddr dhcp-msg-yiaddr set-dhcp-msg-yiaddr!)
(siaddr dhcp-msg-siaddr set-dhcp-msg-siaddr!)
(giaddr dhcp-msg-giaddr set-dhcp-msg-giaddr!)
(chaddr dhcp-msg-chaddr set-dhcp-msg-chaddr!)
(sname dhcp-msg-sname set-dhcp-msg-sname!)
(file dhcp-msg-file set-dhcp-msg-file!)
;; Options are represented as a fixed-length
;; vector in which each element is either a
;; <dhcp-option> object or #nil.
(options dhcp-msg-options set-dhcp-msg-options))
; Note: client initializes #hops to 0. ;; Note: client initializes #hops to 0.
; Note: yiaddr, siaddr, giaddr are always 0 for ;; Note: yiaddr, siaddr, giaddr are always 0 for
; client->server DHCP messages. See Page 32, RFC 2131. ;; client->server DHCP messages. See Page 32, RFC 2131.
; Set/unset the BROADCAST bit in the 'flags' field. The ;; Set/unset the BROADCAST bit in the 'flags' field. The
; remaining bits are always zero, see Figure 2, RFC 2131. ;; remaining bits are always zero, see Figure 2, RFC 2131.
(define-method (set-broadcast-bit (msg <dhcp-message>)) (define-syntax-rule (set-broadcast-bit msg)
(slot-set! msg 'flags #x8000)) (set-dhcp-msg-flags #x8000))
(define-method (unset-broadcast-bit (msg <dhcp-message>)) (define-syntax-rule (unset-broadcast-bit msg)
(slot-set! msg 'flags 0)) (set-dhcp-msg-flags 0))
(define (serialize-options! opts dst idx) #;(define (serialize-options! opts dst idx)
"Copy the options field OPTS from a <dhcp-message> into a "Copy the options field OPTS from a <dhcp-message> into a
bytevector. OPTS is a vector, DST is a bytevector. bytevector. OPTS is a vector, DST is a bytevector.
Copying starts at index IDX in DST. This function mutates DST. Copying starts at index IDX in DST. This function mutates DST.
@ -108,7 +143,7 @@ simply ignored whilst serializing."
(loop (1+ i))))))))) (loop (1+ i)))))))))
; Serialize a <dhcp-message> object into a bytevector. ; Serialize a <dhcp-message> object into a bytevector.
(define-method (serialize-dhcp-message (msg <dhcp-message>)) #;(define-method (serialize-dhcp-message (msg <dhcp-message>))
(let* ((res (make-bytevector 576 0)) (let* ((res (make-bytevector 576 0))
(chaddr (slot-ref msg 'chaddr)) (chaddr (slot-ref msg 'chaddr))
(chaddr-len (bytevector-length chaddr)) (chaddr-len (bytevector-length chaddr))
@ -136,7 +171,7 @@ simply ignored whilst serializing."
; Read options from a bytevector 'src' starting at index ; Read options from a bytevector 'src' starting at index
; 'idx' and returns a vector of <dhcp-option> objects. ; 'idx' and returns a vector of <dhcp-option> objects.
(define (deserialize-options src idx) #;(define (deserialize-options src idx)
(define (helper src i res) (define (helper src i res)
(if (= i (bytevector-length src)) (if (= i (bytevector-length src))
res ; nothing more to read from 'src' res ; nothing more to read from 'src'
@ -153,31 +188,9 @@ simply ignored whilst serializing."
(helper src (+ i 2 len) res))))))) (helper src (+ i 2 len) res)))))))
(helper src idx (make-vector 256 #nil))) (helper src idx (make-vector 256 #nil)))
; 'Pad' and 'End' are the only zero-length options. ;; 'Pad' and 'End' are the only zero-length options.
; In RFC 4039, 'Rapid Commit' (also zero-length) was introduced. ;; In RFC 4039, 'Rapid Commit' (also zero-length) was introduced.
; This is not yet supported in this client implementation. ;; This is not yet supported in this client implementation.
;; (define (deserialize-dhcp-message msg)
;; "Given a serialized DHCP packet MSG, parse it and
;; return a <dhcp-message> object."
;; (let ((res (make <dhcp-message>)))
;; (slot-set! res 'op (bytevector-u8-ref msg 0))
;; (slot-set! res 'htype (bytevector-u8-ref msg 1))
;; (slot-set! res 'hlen (bytevector-u8-ref msg 2))
;; (slot-set! res 'hops (bytevector-u8-ref msg 3))
;; (slot-set! res 'xid (bytevector-u32-ref msg 4 (endianness big)))
;; (slot-set! res 'secs (bytevector-u16-ref msg 8 (endianness big)))
;; (slot-set! res 'flags (bytevector-u16-ref msg 10 (endianness big)))
;; (slot-set! res 'ciaddr (bytevector-u32-ref msg 12 (endianness big)))
;; (slot-set! res 'yiaddr (bytevector-u32-ref msg 16 (endianness big)))
;; (slot-set! res 'siaddr (bytevector-u32-ref msg 20 (endianness big)))
;; (slot-set! res 'giaddr (bytevector-u32-ref msg 24 (endianness big)))
;; (slot-set! res 'chaddr (bytevector-copy! msg 28 (slot-ref res 'chaddr) 0 16))
;; (slot-set! res 'sname (bytevector-copy! msg 44 (slot-ref res 'sname) 0 64))
;; (slot-set! res 'file (bytevector-copy! msg 108 (slot-ref res 'file) 0 128))
;; ; we skip the 4-byte magic cookie that starts off the options field
;; (slot-set! res 'options (deserialize-options msg 240))
;; res))
(define (bytevector-slice bv start len) (define (bytevector-slice bv start len)
"Return a new bytevector with LEN elements sliced "Return a new bytevector with LEN elements sliced
@ -186,7 +199,7 @@ from BV starting at index START"
(bytevector-copy! bv start res 0 len) (bytevector-copy! bv start res 0 len)
res)) res))
(define (deserialize-dhcp-message msg) #;(define (deserialize-dhcp-message msg)
(make <dhcp-message> (make <dhcp-message>
#:op (bytevector-u8-ref msg 0) #:op (bytevector-u8-ref msg 0)
#:htype (bytevector-u8-ref msg 1) #:htype (bytevector-u8-ref msg 1)
@ -201,90 +214,96 @@ from BV starting at index START"
; TODO: chaddr ; TODO: chaddr
#:options (deserialize-options msg 240))) #:options (deserialize-options msg 240)))
(define-method (set-option! (msg <dhcp-message>) (opt <dhcp-option>)) ;; Set an <option> in a <dhcp-msg>.
"Set an <option> in a <dhcp-message>." (define-syntax-rule (set-option! msg opt)
(vector-set! (slot-ref msg 'options) (let ((opts (dhcp-msg-options msg)))
(dhcp-option-code opt) (vector-set! opts
opt)) (dhcp-option-code opt)
opt)))
(define-method (option-value (msg <dhcp-message>) code) ;; Retrieve an option's value from a <dhcp-msg>
"Retrieve an option's value from a <dhcp-message>." ;; record MSG given its code CODE.
(define-syntax-rule (option-value msg code)
(let* ((opts (slot-ref msg 'options)) (let* ((opts (slot-ref msg 'options))
(opt (vector-ref opts code)) (opt (vector-ref opts code))
(val (dhcp-option-val opt))) (val (dhcp-option-val opt)))
val)) val))
; Get the DHCP message type. See Section 9.6, RFC 2132. ;; Get the DHCP message type. See Section 9.6, RFC 2132.
(define-syntax-rule (message-type msg) (define-syntax-rule (message-type msg)
(option-value msg 53)) (option-value msg 53))
; Map a DHCP message type to its single-digit code. ;; Map a DHCP message type to its single-digit code.
; See Section 9.6, RFC 2132. ;; See Section 9.6, RFC 2132.
(define-syntax-rule (map-type-to-code type) (define-syntax-rule (map-type-to-code type)
(begin (begin
(assert (enum-set-member? type *dhcp-message-types*)) (assert (enum-set-member? type *dhcp-msg-types*))
(1+ ((enum-set-indexer *dhcp-message-types*) type)))) (1+ ((enum-set-indexer *dhcp-msg-types*) type))))
; Map a DHCP message type TYPE to its op. ;; Map a DHCP message type TYPE to its op.
; 1 = BOOTREQUEST, 2 = BOOTREPLY. See Pages 9, 27, 36 of ;; 1 = BOOTREQUEST, 2 = BOOTREPLY. See Pages 9, 27, 36 of
; RFC 2131. ;; RFC 2131.
(define-syntax-rule (map-type-to-op type) (define-syntax-rule (map-type-to-op type)
(begin (begin
(assert (enum-set-member? type *dhcp-message-types*)) (assert (enum-set-member? type *dhcp-msg-types*))
(cond ((eq? 'DHCPOFFER type) 2) (cond ((eq? 'DHCPOFFER type) 2)
((eq? 'DHCPACK type) 2) ((eq? 'DHCPACK type) 2)
((eq? 'DHCPNAK type) 2) ((eq? 'DHCPNAK type) 2)
(else 1)))) (else 1))))
(define (make-dhcp-message netif type opts) (define (make-dhcp-msg netif type opts)
"Make an instance of <dhcp-message> for interface NETIF "Make an instance of <dhcp-msg> for interface NETIF
with message type TYPE and options initialized to OPTS" with message type TYPE and options initialized to OPTS"
(let* ((pair (slot-ref netif 'hwaddr)) (let* ((pair (net-iface-hwaddr netif))
(chaddr (car pair)) (chaddr (car pair))
(htype (cdr pair)) (htype (cdr pair))
(hlen (bytevector-length chaddr)) (hlen (bytevector-length chaddr))
(op (map-type-to-op type)) (op (map-type-to-op type))
(dhcp (slot-ref netif 'dhcp)) (dhcp (net-iface-dhcp netif))
(msg-type-code (map-name-to-code (msg-type-code (map-name-to-code
'DHCP-MESSAGE-TYPE))) 'DHCP-MSG-TYPE)))
(begin (begin
(vector-set! opts (vector-set! opts
msg-type-code ; 53 msg-type-code ; 53
(make <dhcp-option> (make-dhcp-option
#:code msg-type-code msg-type-code
#:len 1 1
#:val (make-bytevector 1 (map-type-to-code type)))) (make-bytevector 1 (map-type-to-code type))))
(make <dhcp-message> (make-dhcp-msg
#:op op op
#:xid (retrieve-xid netif) htype hlen
#:htype htype 0
#:hlen hlen (retrieve-xid netif)
#:secs (retrieve-secs netif type) (retrieve-secs netif type)
#:chaddr chaddr 0
#:ciaddr (retrieve-ciaddr netif type) (retrieve-ciaddr netif type)
#:options opts)))) #vu8(0 0 0 0) #vu8(0 0 0 0) #vu8(0 0 0 0)
chaddr
(make-bytevector 64 0)
(make-bytevector 128 0)
opts))))
(define (retrieve-xid netif) (define (retrieve-xid netif)
"Given a <net-interface> NETIF, return the "Given a <net-interface> NETIF, return the
its current transaction ID, unless it has just its current transaction ID, unless it has just
started out, in which give it a new transaction started out, in which give it a new transaction
ID and return that" ID and return that"
(let* ((dhcp (slot-ref netif 'dhcp)) (let* ((dhcp (net-iface-dhcp netif))
(state (slot-ref dhcp 'state))) (state (dhcp-state dhcp)))
(if (eq? state 'DHCP-INIT) (if (eq? state 'DHCP-INIT)
(let* ((new-xid (generate-random-xid)) (let* ((new-xid (generate-random-xid))
(_ (slot-set! dhcp 'xid new-xid))) (_ (set-dhcp-xid! dhcp new-xid)))
new-xid) new-xid)
(slot-ref dhcp 'xid)))) (dhcp-xid dhcp))))
(define (retrieve-ciaddr netif type) (define (retrieve-ciaddr netif type)
"Given a <net-interface> NETIF and the message "Given a <net-interface> NETIF and the message
type TYPE, return the appropriate value for the type TYPE, return the appropriate value for the
ciaddr field in a <dhcp-message> object." ciaddr field in a <dhcp-msg> object."
(let* ((dhcp (slot-ref netif 'dhcp)) (let* ((dhcp (net-iface-dhcp netif))
(state (slot-ref dhcp 'state)) (state (dhcp-state dhcp))
(zeroaddr (make-bytevector 4 0)) (zeroaddr (make-bytevector 4 0))
(ipaddr (slot-ref netif 'ipaddr))) (ipaddr (net-iface-ipaddr netif)))
(cond ((or (eq? type 'DHCPDISCOVER) (cond ((or (eq? type 'DHCPDISCOVER)
(eq? type 'DHCPDECLINE)) (eq? type 'DHCPDECLINE))
zeroaddr) zeroaddr)
@ -298,19 +317,18 @@ ciaddr field in a <dhcp-message> object."
ipaddr ipaddr
zeroaddr))))) zeroaddr)))))
; TODO: figure out from 2131 exactly when to ;; TODO: figure out from 2131 exactly when to
; return secs since config and when to return 0 ;; 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 "Given a <net-interface> NETIF and the message
type TYPE, return the appropriate value for the type TYPE, return the appropriate value for the
secs field in a <dhcp-message> object." secs field in a <dhcp-msg> object."
(let ((dhcp (slot-ref netif 'dhcp))) (let ((dhcp (net-iface-dhcp netif)))
(cond ((or (eq? type 'DHCPDECLINE) (cond ((or (eq? type 'DHCPDECLINE)
(eq? type 'DHCPRELEASE)) (eq? type 'DHCPRELEASE))
0) 0)
(else (- (current-time) ; might need to change (else (- (current-time) ; might need to change
(slot-ref dhcp (dhcp-config-start dhcp))))))
'config-started-at))))))
(define-syntax-rule (make-dhcpdiscover netif opts) (define-syntax-rule (make-dhcpdiscover netif opts)
(make-dhcp-message netif 'DHCPDISCOVER opts)) (make-dhcp-msg netif 'DHCPDISCOVER opts))

18
lib/interfaces.c
View File

@ -19,24 +19,6 @@
#include <ifaddrs.h> #include <ifaddrs.h>
#include <stdio.h> #include <stdio.h>
void print_interfaces() {
struct ifaddrs *ifaddr, *itr;
if (getifaddrs(&ifaddr) == -1) {
return;
}
for (itr = ifaddr; itr; itr = itr->ifa_next) {
if (itr->ifa_addr == NULL) {
continue;
}
int family = itr->ifa_addr->sa_family;
if (family == AF_INET || family == AF_INET6) {
printf("Name: %s, ", itr->ifa_name);
printf("Address: %s, ", family == AF_INET ? "AF_INET" : family == AF_INET6 ? "AF_INET6" : "");
printf("Flags: %d\n", itr->ifa_flags);
}
}
}
char* get_sockaddr_data(struct ifaddrs* ifaddr) { char* get_sockaddr_data(struct ifaddrs* ifaddr) {
return ifaddr->ifa_addr->sa_data; return ifaddr->ifa_addr->sa_data;
} }