From f591e1fd4d2255039cf0c839ac42c7dc7385c8ce Mon Sep 17 00:00:00 2001 From: Rohan Prinja Date: Wed, 10 Jun 2015 09:47:51 +0530 Subject: [PATCH] dhcp: switch to srfi-9 records + numerous small fixes to follow style guide --- dhcp/client.scm | 4 +- dhcp/dhcp.scm | 31 +++--- dhcp/interfaces.scm | 137 ++++++++++++------------ dhcp/messages.scm | 248 ++++++++++++++++++++++++-------------------- lib/interfaces.c | 18 ---- 5 files changed, 224 insertions(+), 214 deletions(-) diff --git a/dhcp/client.scm b/dhcp/client.scm index ced9a40..34a609a 100644 --- a/dhcp/client.scm +++ b/dhcp/client.scm @@ -20,7 +20,7 @@ coding: utf-8 !# -; DHCP client module +;; DHCP client module (define-module (dhcp client) #:use-module (dhcp dhcp) #:use-module (ice-9 getopt-long) @@ -59,5 +59,5 @@ dhcp-client [options] (begin (display "Hello, World!") (newline))))) -; Seed the random state. +;; Seed the random state. (set! *random-state* (random-state-from-platform)) diff --git a/dhcp/dhcp.scm b/dhcp/dhcp.scm index 74aed88..7948487 100644 --- a/dhcp/dhcp.scm +++ b/dhcp/dhcp.scm @@ -17,7 +17,6 @@ (define-module (dhcp dhcp) #:use-module (dhcp messages) - #:use-module (oop goops) #:use-module (rnrs base) #:use-module (ice-9 regex) #:use-module (srfi srfi-9) @@ -27,6 +26,12 @@ dhcp-state set-dhcp-state! 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-renew dhcp-release @@ -37,8 +42,8 @@ generate-different-xid generate-random-xid)) -;; Class for DHCP objects. -;; A object is held by an interface, and contains +;; Record type for DHCP objects. +;; A record is held by an interface, and contains ;; information about the configuration process for that ;; specific interface. (define-record-type @@ -59,21 +64,21 @@ (lease-ack dhcp-lease-ack) ; time since last DHCPACK ;; Offered IP address, subnet mask and gateway address. - (ip-addr dhcp-ip-addr) - (sn-mask dhcp-sn-mask) - (gw-addr dhcp-gw-addr) + (ip-addr dhcp-ip-addr set-dhcp-ip-addr!) + (sn-mask dhcp-sn-mask set-dhcp-sn-mask!) + (gw-addr dhcp-gw-addr set-dhcp-gw-addr!) ;; Time at which configuration process was started. (config-start dhcp-config-start set-dhcp-config-start!)) -(define (generate-random-xid) - "Generate a random 32-bit number to be used as -a transaction id." +;; Generate a random 32-bit number to be used as +;; a transaction id. +(define-syntax-rule (generate-random-xid) (random (expt 2 32))) -(define-method (generate-different-xid (dhcp )) - "Generate a new, different transaction id for -a dhcp object. We simply increment the old one." +;; Generate a new, different transaction id for +;; a dhcp object. We simply increment the old one. +(define-syntax-rule (generate-different-xid dhcp) (1+ (dhcp-xid dhcp))) ;; TODO: make a separate lease file for each interface rather than @@ -146,7 +151,7 @@ interface NETIF." 'DHCP-INIT-REBOOT 'DHCP-INIT))) (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) (begin (wait-desync) diff --git a/dhcp/interfaces.scm b/dhcp/interfaces.scm index 5b01e12..549f7a1 100644 --- a/dhcp/interfaces.scm +++ b/dhcp/interfaces.scm @@ -18,16 +18,24 @@ (define-module (dhcp interfaces) #:use-module (dhcp dhcp) #:use-module (system foreign) - #:use-module (oop goops) + #:use-module (srfi srfi-9) #:use-module (guix build syscalls) #:use-module (rnrs base) #:use-module (rnrs bytevectors) - #:export ( + #:export ( hardware-address hardware-family retain-ethernet-interfaces 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 @@ -36,7 +44,7 @@ #x8927 ; GNU/Linux -1)) -; Maximum interface name size +;; Maximum interface name size. (define IF_NAMESIZE 16) (define ifreq-struct-size @@ -55,7 +63,7 @@ ;;; 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 ...) "FFI wrapper for a function defined in a .so library" @@ -64,46 +72,37 @@ c-fn-args))) (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) (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) (link-fn "free_interfaces" *libinterfaces* void '(*) ifaddrs)) -; Print some information about the interfaces. -(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) +;; Struct type for struct ifaddrs. See also: getifaddrs (3). (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 '*)) -; Given a pointer to a struct ifaddrs, parse it using -; parse-c-struct. +;; Given a pointer to a struct ifaddrs, parse it using +;; parse-c-struct. (define-syntax-rule (parse-ifaddr ifaddrs) (parse-c-struct ifaddrs *ifaddrs-struct-type*)) -; Given a pointer to a struct sockaddr, parse it using -; parse-c-struct. +;; Given a pointer to a struct sockaddr, parse it using +;; parse-c-struct. (define-syntax-rule (parse-sockaddr sockaddr) (parse-c-struct sockaddr *sockaddr-struct-type*)) -; Note: In the library, struct ifaddrs is -; an intrusive linked list of interface addresses. +;; Note: In the library, struct ifaddrs is +;; an intrusive linked list of interface addresses. -; Given a struct ifaddrs pointer which has been parsed -; using parse-c-struct, obtain and parse the next ifaddrs -; struct in the intrusive linked list. If we are already -; at the end of the list, do not do anything. +;; Given a struct ifaddrs pointer which has been parsed +;; using parse-c-struct, obtain and parse the next ifaddrs +;; struct in the intrusive linked list. If we are already +;; at the end of the list, do not do anything. (define-syntax-rule (next-parsed-ifaddr parsed) (let ((next-ptr (car parsed))) (if (null-pointer? next-ptr) @@ -125,10 +124,7 @@ "Create a UDP datagram socket." (let ((sock (socket PF_INET SOCK_DGRAM IPPROTO_UDP))) (if (= (fileno sock) -1) - (throw 'system-error "make-dgram-sock" - "make-dgram-sock on ~A: ~A" - (list name (strerror err)) - (list err)) + (throw 'system-error "make-dgram-sock") sock))) (define (find-interfaces ifaddrs) @@ -147,9 +143,11 @@ (if (af-inet? family) (display (format #f "Name ~a, Family ~a\n" name family))) (helper (next-parsed-ifaddr parsed) - (cons (make - #:name name - #:flags flags) + (cons (make-net-iface + name + flags + #vu8(0 0 0 0) #vu8(0 0 0 0) #vu8(0 0 0 0) + (cons #f #f)) result))))) (helper (parse-ifaddr ifaddrs) '())) @@ -213,41 +211,48 @@ interface names" (string-prefix? "eth" name)) ifaces)) -; Class for network interfaces. -; See also: getifaddrs (3). -(define-class () - (name #:init-keyword #:name) - (flags #:init-keyword #:flags) - (ipaddr #:init-keyword #:ipaddr) - (netmask #:init-keyword #:netmask) - (gateway #:init-keyword #:gateway) - (hwaddr #:init-keyword #:hwaddr) - (dhcp #:init-keyword #:dhcp)) +;; Record type for network interfaces. +;; See also: getifaddrs (3). +(define-record-type + (make-net-iface name + flags + ipaddr netmask gateway + hwaddr + dhcp) + net-iface? + (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 is an instance of -; the class storing the configuration -; details for that particular interface. -; HWADDR is a pair in which the first element -; is the hardware address as a bytevector, and -; the second element is the hardware type (see -; arp/identifiers.scm). +;; Note: DHCP in is an instance of +;; the record type storing the configuration +;; details for that particular interface. +;; HWADDR is a pair in which the first element +;; is the hardware address as a bytevector, and +;; the second element is the hardware type (see +;; arp/identifiers.scm). -(define (make-network-interface name init-state) - "Create a instance for the -interface NAME" +;; Create a record for the +;; interface NAME +(define-syntax-rule (make-network-interface name init-state) (let* ((_ (assert (or (eq? init-state 'DHCP-INIT) (eq? init-state 'DHCP-INIT-REBOOT)))) (hwaddr (hardware-address name)) (htype (hardware-family name)) (pair (cons hwaddr htype))) - (make - #:name name - #:hwaddr pair - #:ipaddr #vu8(0 0 0 0) - #:dhcp (make - #:state init-state - #:xid (generate-random-xid))))) - -; name = name of the network interface ("lo", "eth0", "wlan0", etc.) -; addr = interface address -; netmask = netmask of interface + (make-net-iface + name + 0 + #vu8(0 0 0 0) #vu8(0 0 0 0) #vu8(0 0 0 0) + pair + (make-dhcp + (generate-random-xid) + init-state + 0 + 0 0 0 + 0 + #vu8(0 0 0 0) #vu8(0 0 0 0) #vu8(0 0 0 0))))) diff --git a/dhcp/messages.scm b/dhcp/messages.scm index 84ff350..ba2c016 100644 --- a/dhcp/messages.scm +++ b/dhcp/messages.scm @@ -21,11 +21,31 @@ #:use-module (dhcp dhcp) #:use-module (dhcp options base) #:use-module (dhcp options names) - #:use-module (oop goops) + #:use-module (srfi srfi-9) #:use-module (rnrs base) #:use-module (rnrs bytevectors) #:use-module (rnrs enums) - #:export ( + #:export ( + 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 unset-broadcast-bit option-value @@ -35,12 +55,12 @@ make-dhcpdiscover map-type-to-code)) -; Magic cookie that starts off the 'options' field -; in a DHCP message packet. +;; Magic cookie that starts off the 'options' field +;; in a DHCP message packet. (define *magic-cookie* #vu8(99 130 83 99)) -; Valid types for a DHCP message. -(define *dhcp-message-types* +;; Valid types for a DHCP message. +(define *dhcp-msg-types* (make-enumeration '(DHCPDISCOVER DHCPOFFER DHCPREQUEST @@ -50,41 +70,56 @@ DHCPRELEASE DHCPINFORM))) -; DHCP message object. -; See page 8, RFC 2131 for the message format. -(define-class () - (op #:init-keyword #:op) - (htype #:init-keyword #:htype) - (hlen #:init-keyword #:hlen) - (hops #:init-form 0) - (xid #:init-keyword #:xid) - (secs #:init-keyword #:secs) - (flags #:init-form 0) - (ciaddr #:init-keyword #:ciaddr) - (yiaddr #:init-form (make-bytevector 4 0)) - (siaddr #:init-form (make-bytevector 4 0)) - (giaddr #:init-form (make-bytevector 4 0)) - (chaddr #:init-keyword #:chaddr) - (sname #:init-form (make-bytevector 64 0)) - (file #:init-form (make-bytevector 128 0)) - ; Options are represented as a fixed-length - ; vector in which each element is either a - ; object or #nil. - (options #:init-form (make-vector 256 #nil) - #:init-keyword #:options)) +;; DHCP message object. +;; See page 8, RFC 2131 for the message format. +(define-record-type + (make-dhcp-msg op + htype hlen + hops + xid + secs + flags + ciaddr + yiaddr siaddr giaddr + chaddr + sname + file + options) + + dhcp-msg? + + (op dhcp-msg-op set-dhcp-msg-op!) + (htype dhcp-msg-htype set-dhcp-msg-htype!) + (hlen dhcp-msg-hlen set-dhcp-msg-hlen!) + (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 + ;; object or #nil. + (options dhcp-msg-options set-dhcp-msg-options)) -; Note: client initializes #hops to 0. -; Note: yiaddr, siaddr, giaddr are always 0 for -; client->server DHCP messages. See Page 32, RFC 2131. +;; Note: client initializes #hops to 0. +;; Note: yiaddr, siaddr, giaddr are always 0 for +;; client->server DHCP messages. See Page 32, RFC 2131. -; Set/unset the BROADCAST bit in the 'flags' field. The -; remaining bits are always zero, see Figure 2, RFC 2131. -(define-method (set-broadcast-bit (msg )) - (slot-set! msg 'flags #x8000)) -(define-method (unset-broadcast-bit (msg )) - (slot-set! msg 'flags 0)) +;; Set/unset the BROADCAST bit in the 'flags' field. The +;; 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) +#;(define (serialize-options! opts dst idx) "Copy the options field OPTS from a into a bytevector. OPTS is a vector, DST is a bytevector. Copying starts at index IDX in DST. This function mutates DST. @@ -108,7 +143,7 @@ simply ignored whilst serializing." (loop (1+ i))))))))) ; Serialize a object into a bytevector. -(define-method (serialize-dhcp-message (msg )) +#;(define-method (serialize-dhcp-message (msg )) (let* ((res (make-bytevector 576 0)) (chaddr (slot-ref msg 'chaddr)) (chaddr-len (bytevector-length chaddr)) @@ -136,7 +171,7 @@ simply ignored whilst serializing." ; Read options from a bytevector 'src' starting at index ; 'idx' and returns a vector of objects. -(define (deserialize-options src idx) +#;(define (deserialize-options src idx) (define (helper src i res) (if (= i (bytevector-length src)) res ; nothing more to read from 'src' @@ -153,31 +188,9 @@ simply ignored whilst serializing." (helper src (+ i 2 len) res))))))) (helper src idx (make-vector 256 #nil))) -; 'Pad' and 'End' are the only zero-length options. -; In RFC 4039, 'Rapid Commit' (also zero-length) was introduced. -; 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 object." -;; (let ((res (make ))) -;; (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)) +;; 'Pad' and 'End' are the only zero-length options. +;; In RFC 4039, 'Rapid Commit' (also zero-length) was introduced. +;; This is not yet supported in this client implementation. (define (bytevector-slice bv start len) "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) res)) -(define (deserialize-dhcp-message msg) +#;(define (deserialize-dhcp-message msg) (make #:op (bytevector-u8-ref msg 0) #:htype (bytevector-u8-ref msg 1) @@ -201,90 +214,96 @@ from BV starting at index START" ; TODO: chaddr #:options (deserialize-options msg 240))) -(define-method (set-option! (msg ) (opt )) - "Set an