mirror of git://git.savannah.gnu.org/guix/dhcp.git
358 lines
11 KiB
Scheme
358 lines
11 KiB
Scheme
;;; GNU Guix DHCP Client.
|
|
;;;
|
|
;;; Copyright © 2015 Rohan Prinja <rohan.prinja@gmail.com>
|
|
;;;
|
|
;;; 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/>.
|
|
|
|
;; Module for constructing and parsing DHCP messages
|
|
(define-module (dhcp messages)
|
|
#:use-module (dhcp interfaces)
|
|
#:use-module (dhcp dhcp)
|
|
#:use-module (dhcp options base)
|
|
#:use-module (dhcp options names)
|
|
#:use-module (srfi srfi-9)
|
|
#:use-module (rnrs base)
|
|
#:use-module (rnrs bytevectors)
|
|
#: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!
|
|
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
|
|
|
|
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.
|
|
(define *magic-cookie* #vu8(99 130 83 99))
|
|
|
|
;; Valid types for a DHCP message.
|
|
(define *dhcp-msg-types*
|
|
(make-enumeration '(DHCPDISCOVER
|
|
DHCPOFFER
|
|
DHCPREQUEST
|
|
DHCPDECLINE
|
|
DHCPACK
|
|
DHCPNAK
|
|
DHCPRELEASE
|
|
DHCPINFORM)))
|
|
|
|
;; DHCP message object.
|
|
;; See page 8, RFC 2131 for the message format.
|
|
(define-record-type <dhcp-msg>
|
|
(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
|
|
;; <dhcp-option> object or #f.
|
|
(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.
|
|
|
|
;; 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)
|
|
"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 does not exist, so it is
|
|
simply ignored whilst serializing."
|
|
(let loop ((i 0) (to idx))
|
|
(if (< i 255)
|
|
(let* ((opt (vector-ref opts 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 to code)
|
|
(begin
|
|
(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))))
|
|
|
|
(define (serialize-dhcp-msg msg)
|
|
"Serialize a <dhcp-message> record MSG into a bytevector"
|
|
(let* ((res (make-bytevector 576 0))
|
|
(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 (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! (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! (dhcp-msg-options msg) res 240)
|
|
res))
|
|
|
|
(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 (= 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
|
|
(vector-set! res code (make-dhcp-option code len val))
|
|
(helper src (+ i 2 len) res)))))))
|
|
(helper src idx (make-vector 256 #f)))
|
|
|
|
;; '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
|
|
from BV starting at index START"
|
|
(let ((res (make-bytevector len)))
|
|
(bytevector-copy! bv start res 0 len)
|
|
res))
|
|
|
|
(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)
|
|
(let ((opts (dhcp-msg-options msg)))
|
|
(vector-set! opts
|
|
(dhcp-option-code opt)
|
|
opt)))
|
|
|
|
;; Retrieve an option's value from a <dhcp-msg>
|
|
;; record MSG given its code CODE.
|
|
(define-syntax-rule (option-value msg code)
|
|
(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 (msg-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-msg-types*))
|
|
(1+ ((enum-set-indexer *dhcp-msg-types*) type))))
|
|
|
|
;; Map a DHCP message type TYPE to its op.
|
|
;; 1 = BOOTREQUEST, 2 = BOOTREPLY. See Pages 9, 27, 36 of
|
|
;; RFC 2131.
|
|
(define-syntax-rule (map-type-to-op type)
|
|
(begin
|
|
(assert (enum-set-member? type *dhcp-msg-types*))
|
|
(cond ((eq? 'DHCPOFFER type) 2)
|
|
((eq? 'DHCPACK type) 2)
|
|
((eq? 'DHCPNAK type) 2)
|
|
(else 1))))
|
|
|
|
(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* ((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))
|
|
(msg-type-code (map-name-to-code
|
|
'DHCP-MESSAGE-TYPE))
|
|
(end-code (map-name-to-code 'END)))
|
|
(begin
|
|
(vector-set! opts
|
|
msg-type-code ; 53
|
|
(make-dhcp-option
|
|
msg-type-code
|
|
1
|
|
(make-bytevector 1 (map-type-to-code type))))
|
|
(make-dhcp-msg
|
|
op
|
|
htype hlen
|
|
0
|
|
(retrieve-xid netif)
|
|
(retrieve-secs netif type)
|
|
0
|
|
(retrieve-ciaddr netif type)
|
|
#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)
|
|
"Given a <net-interface> NETIF, return the
|
|
its current transaction ID, unless it has just
|
|
started out, in which give it a new transaction
|
|
ID and return that"
|
|
(let* ((dhcp (net-iface-dhcp netif))
|
|
(state (dhcp-state dhcp)))
|
|
(if (eq? state 'DHCP-INIT)
|
|
(let* ((new-xid (generate-random-xid))
|
|
(_ (set-dhcp-xid! dhcp new-xid)))
|
|
new-xid)
|
|
(dhcp-xid dhcp))))
|
|
|
|
(define (retrieve-ciaddr netif type)
|
|
"Given a <net-interface> NETIF and the message
|
|
type TYPE, return the appropriate value for the
|
|
ciaddr field in a <dhcp-msg> object."
|
|
(let* ((dhcp (net-iface-dhcp netif))
|
|
(state (dhcp-state dhcp))
|
|
(zeroaddr (make-bytevector 4 0))
|
|
(ipaddr (net-iface-ipaddr netif)))
|
|
(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)))))
|
|
|
|
;; TODO: figure out from 2131 exactly when to
|
|
;; return secs since config and when to return 0
|
|
#;(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."
|
|
(let ((dhcp (net-iface-dhcp netif)))
|
|
(cond ((or (eq? type 'DHCPDECLINE)
|
|
(eq? type 'DHCPRELEASE))
|
|
0)
|
|
(else (- (current-time) ; might need to change
|
|
(dhcp-config-start dhcp))))))
|
|
|
|
(define (retrieve-secs netif type)
|
|
0)
|
|
|
|
(define (make-dhcpdiscover netif opts)
|
|
(make-dhcp-message netif 'DHCPDISCOVER opts))
|