[dhcp] 06/12: dhcp: packet objects, untested

[Rohan Prinja]

wenderen pushed a commit to branch master
in repository dhcp.

commit d96db6c0d2692b311d9a1f7a891da55cf0b159b2
Author: Rohan Prinja <address@hidden>
Date:   Sat Jun 6 23:39:01 2015 +0530

    dhcp: packet objects, untested
---
 dhcp/messages.scm |  272 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 files changed, 272 insertions(+), 0 deletions(-)

diff --git a/dhcp/messages.scm b/dhcp/messages.scm
new file mode 100644
index 0000000..3fee82c
--- /dev/null
+++ b/dhcp/messages.scm
@@ -0,0 +1,272 @@
+3;;; GNU Guix DHCP Client.
+;;;
+;;; Copyright 2015 Free Software Foundation, Inc.
+;;;
+;;; This program is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+(add-to-load-path (string-append (dirname (current-filename))
+                                "/.."))
+
+; Module for constructing and parsing DHCP messages
+(define-module (dhcp messages)
+  #:export (<dhcp-message>
+           set-broadcast-bit
+           unset-broadcast-bit
+           option-value
+           serialize-dhcp-message
+           deserialize-dhcp-message
+           message-type
+           make-dhcpdiscover
+           map-type-to-code))
+
+(use-modules (dhcp interfaces)
+            (dhcp options base)
+            (dhcp options names)
+            (oop goops)
+            (rnrs base)
+            (rnrs bytevectors)
+            (rnrs enums))
+
+; 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*
+  (make-enumeration '(DHCPDISCOVER
+                     DHCPOFFER
+                     DHCPREQUEST
+                     DHCPDECLINE
+                     DHCPACK
+                     DHCPNAK
+                     DHCPRELEASE
+                     DHCPINFORM)))
+
+; DHCP message object.
+; See page 8, RFC 2131 for the message format.
+(define-class <dhcp-message> ()
+  (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
+  ; <dhcp-option> object or #nil.
+  (options #:init-form (make-vector 255 #nil)
+          #:init-keyword #:options))
+
+; Note: client initializes #hops to 0.
+; Note: yiaddr, siaddr, giaddr are always 0 for
+; client->server DHCP messages. See Page 32, RFC 2131.
+
+(define *big-endian* (endianness big))
+
+; 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 <dhcp-message>))
+  (slot-set! msg 'flags #x8000))
+(define-method (unset-broadcast-bit (msg <dhcp-message>))
+  (slot-set! msg 'flags 0))
+
+(define (serialize-options! opts dst idx)
+  "Copy the options field from a <dhcp-message> into a bytevector
+while serializing. 'opts' is a vector, 'dst' is a bytevector.
+Copying starts at index 'idx' in the 'dst' bytevector.
+This function mutates 'dst'"
+  (let loop ((i 0))
+    (if (< i 256)
+       (let* ((opt (vector-ref opts i))
+              (code i)
+              (len (slot-ref opt 'len))
+              (val (slot-ref opt 'val)))
+         (begin
+           (if (zero? len)
+               (bytevector-u8-set! dst idx 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)))))))
+
+; Serialize a <dhcp-message> object into a bytevector.
+(define-method (serialize-dhcp-message (msg <dhcp-message>))
+  (let ((res (make-bytevector 576 0))
+       (chaddr (slot-ref msg 'chaddr))
+       (sname (slot-ref msg 'sname))
+       (file (slot-ref msg 'file))
+       (opts (slot-ref msg 'options)))
+    (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) *big-endian*)
+    (bytevector-u16-set! res 8 (slot-ref msg 'secs) *big-endian*)
+    (bytevector-u16-set! res 10 (slot-ref msg 'flags) *big-endian*)
+    (bytevector-u32-set! res 12 (slot-ref msg 'ciaddr) *big-endian*)
+    (bytevector-u32-set! res 16 (slot-ref msg 'yiaddr) *big-endian*)
+    (bytevector-u32-set! res 20 (slot-ref msg 'siaddr) *big-endian*)
+    (bytevector-u32-set! res 24 (slot-ref msg 'giaddr) *big-endian*)
+    (bytevector-copy! chaddr 0 res 28 16)
+    (bytevector-copy! sname 0 res 44 64)
+    (bytevector-copy! file 0 res 108 128)
+    (bytevector-copy! *magic-cookie* 0 res 236 4)
+    (serialize-options! opts 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 (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 #nil))
+               (helper src (+ i 1) res))
+             (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))
+                 (helper src (+ i 2 len) res)))))))
+  (helper src idx (make-vector 255 #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.
+
+; Given a serialized DHCP message, parse it and
+; return a <dhcp-message> object.
+(define (deserialize-dhcp-message msg)
+  (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 *big-endian*))
+    (slot-set! res 'secs (bytevector-u16-ref msg 8 *big-endian*))
+    (slot-set! res 'flags (bytevector-u16-ref msg 10 *big-endian*))
+    (slot-set! res 'ciaddr (bytevector-u32-ref msg 12 *big-endian*))
+    (slot-set! res 'yiaddr (bytevector-u32-ref msg 16 *big-endian*))
+    (slot-set! res 'siaddr (bytevector-u32-ref msg 20 *big-endian*))
+    (slot-set! res 'giaddr (bytevector-u32-ref msg 24 *big-endian*))
+    (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-method (set-option! (msg <dhcp-message>) (opt <dhcp-option>))
+  "Set an <option> in a <dhcp-message>."
+  (vector-set! (slot-ref msg 'options)
+              (slot-ref opt 'code)
+              opt))
+
+(define-method (option-value (msg <dhcp-message>) code)
+  "Retrieve an option's value from a <dhcp-message>."
+  (let* ((opts (slot-ref msg 'options))
+        (opt (vector-ref opts code))
+        (val (slot-ref opt 'val)))
+    val))
+
+; Get the DHCP message type. See Section 9.6, RFC 2132.
+(define-syntax-rule (message-type msg)
+  (option-value msg 53))
+
+; Map a DHCP message type to its single-digit code.
+; See Section 9.6, RFC 2132.
+(define-syntax-rule (map-type-to-code type)
+  (begin
+    (assert (enum-set-member? type *dhcp-message-types*))
+    (1+ ((enum-set-indexer *dhcp-message-types*) type))))
+
+; Map a DHCP message type TYPE to its op.
+; 1 = BOOTREQUEST, 2 = BOOTREPLY. See Page 9, RFC 2131.
+(define-syntax-rule (map-type-to-op type)
+  (begin
+    (assert (enum-set-member? type *dhcp-message-types*))
+    (cond ((eq? 'DHCPOFFER type) 1)
+         ((eq? 'DHCPACK type) 1)
+         ((eq? 'DHCPNAK type) 1)
+         (else 'BOOTREQUEST))))
+
+(define (make-dhcp-message netif type opts)
+  "Make an instance of <dhcp-message> for interface NETIF
+with message type TYPE and options initialized to OPTS"
+  (let* ((pair (slot-ref netif 'hwaddr))
+        (chaddr (car pair))
+        (htype (cdr pair))
+        (hlen (bytevector-length chaddr))
+        (op (map-type-to-op type))
+        (msg-type-code (map-name-to-code
+                        'DHCP-MESSAGE-TYPE)))
+    (begin
+      (vector-set! opts
+                  msg-type-code ; 53
+                  (make <dhcp-option>
+                    #:code msg-type-code
+                    #:len 1
+                    #:val (map-type-to-code type)))
+      (make <dhcp-message>
+       #:op op
+       #:htype htype
+       #:hlen hlen
+       #:secs (retrieve-secs dhcp type)
+       #:chaddr chaddr
+       #:ciaddr (retrieve-ciaddr dhcp type)
+       #:options opts))))
+
+(define (retrieve-ciaddr dhcp type)
+  "Given a dhcp object DHCP and the message type
+TYPE, return the appropriate value for the ciaddr
+field in a <dhcp-message> object."
+  (let* ((state (slot-ref dhcp 'state))
+        (zeroaddr (make-bytevector 4 0))
+        (ipaddr (slot-ref netif 'ipaddr)))
+    (cond ((or (eq? type 'DHCPDISCOVER)
+              (eq? type 'DHCPDECLINE))
+          zeroaddr)
+         ((or (eq? type 'DHCPINFORM)
+              (eq? type 'DHCPRELEASE))
+          ipaddr)
+         ((eq? type 'DHCPREQUEST)
+          (if (or (eq? state 'DHCP-BOUND)
+                  (eq? state 'DHCP-RENEW)
+                  (eq? state 'DHCP-REBIND))
+              ipaddr
+              zeroaddr)))))
+
+(define (retrieve-secs dhcp type)
+  "Given a dhcp object DHCP and the message type
+TYPE, return the appropriate value for the secs
+field in a <dhcp-message> object."
+  (cond ((or (eq? type 'DHCPDECLINE)
+            (eq? type 'DHCPRELEASE))
+        0)
+       (else 'TODO)))
+
+(define-syntax-rule (make-dhcpdiscover netif opts)
+  (make-dhcp-message netif 'DHCPDISCOVER opts))