mirror of git://git.savannah.gnu.org/guix/dhcp.git
196 lines
6.0 KiB
Scheme
196 lines
6.0 KiB
Scheme
;;; GNU Guix DHCP Client.
|
|
;;;
|
|
;;; Copyright © 2015 Rohan Prinja <rohan.prinja@gmail.com>
|
|
;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
|
|
;;;
|
|
;;; 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/>.
|
|
|
|
(define-module (dhcp interfaces)
|
|
#:use-module (dhcp dhcp)
|
|
#:use-module (system foreign)
|
|
#:use-module (srfi srfi-9)
|
|
#:use-module (guix build syscalls)
|
|
#:use-module (rnrs base)
|
|
#:use-module (rnrs bytevectors)
|
|
#:export (<net-iface>
|
|
hardware-address
|
|
hardware-family
|
|
retain-ethernet-interfaces
|
|
|
|
print-hardware-address
|
|
hardware-address-to-string
|
|
|
|
make-net-iface
|
|
make-network-interface ; wrapper for 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
|
|
|
|
(define SIOCGIFHWADDR
|
|
(if (string-contains %host-type "linux")
|
|
#x8927 ; GNU/Linux
|
|
-1))
|
|
|
|
;; Maximum interface name size.
|
|
(define IF_NAMESIZE 16)
|
|
|
|
(define ifreq-struct-size
|
|
;; 'struct ifreq' begins with an array of IF_NAMESIZE bytes containing the
|
|
;; interface name (nul-terminated), followed by a bunch of stuff. This is
|
|
;; its size in bytes.
|
|
(if (= 8 (sizeof '*))
|
|
40
|
|
32))
|
|
|
|
(define %ioctl
|
|
;; The most terrible interface, live from Scheme.
|
|
(pointer->procedure int
|
|
(dynamic-func "ioctl" (dynamic-link))
|
|
(list int unsigned-long '*)))
|
|
|
|
;;; Taken/modified from (guix build syscalls) end
|
|
|
|
(define-syntax-rule (make-dgram-sock)
|
|
"Create a UDP datagram socket."
|
|
(let ((sock (socket PF_INET SOCK_DGRAM IPPROTO_UDP)))
|
|
(if (= (fileno sock) -1)
|
|
(throw 'system-error "make-dgram-sock")
|
|
sock)))
|
|
|
|
(define (read-hardware-address bv idx)
|
|
"Read a socket address from bytevector BV at index
|
|
IDX. BV is expected to correspond to a struct sockaddr"
|
|
(let* ((ushort-size (sizeof unsigned-short))
|
|
(start (+ ushort-size idx))
|
|
(hwaddr (make-bytevector 6 0))
|
|
(_ (bytevector-copy! bv start hwaddr 0 6)))
|
|
hwaddr))
|
|
|
|
(define (read-hardware-family bv idx)
|
|
"Read the family type from bytevector BV at index
|
|
IDX. BV is expected to correspond to a struct sockaddr"
|
|
(let* ((ushort-size (sizeof unsigned-short))
|
|
(start (+ ushort-size idx))
|
|
(family (bytevector-u8-ref bv idx)))
|
|
family))
|
|
|
|
(define (hardware-property property name)
|
|
"Retrieve a hardware property of the interface NAME,
|
|
like MAC address or hardware family type."
|
|
(let ((req (make-bytevector ifreq-struct-size))
|
|
(socket (make-dgram-sock)))
|
|
(bytevector-copy! (string->utf8 name) 0 req 0
|
|
(min (string-length name) (- IF_NAMESIZE 1)))
|
|
(let* ((ret (%ioctl (fileno socket) SIOCGIFHWADDR
|
|
(bytevector->pointer req)))
|
|
(err (errno)))
|
|
(if (zero? ret)
|
|
(cond ((eq? property 'address)
|
|
(read-hardware-address req IF_NAMESIZE))
|
|
((eq? property 'family)
|
|
(read-hardware-family req IF_NAMESIZE)))
|
|
(throw 'system-error "hardware-address"
|
|
"hardware-address on ~A: ~A"
|
|
(list name (strerror err))
|
|
(list err))))))
|
|
|
|
(define-syntax-rule (hardware-address name)
|
|
(hardware-property 'address name))
|
|
|
|
(define-syntax-rule (hardware-family name)
|
|
(hardware-property 'family name))
|
|
|
|
(define (print-hardware-address bv)
|
|
"Print a hardware address BV given as a length-6 bytevector"
|
|
(assert (= 6 (bytevector-length bv)))
|
|
(let loop ((i 0))
|
|
(when (< i 6)
|
|
(format #t "~2,'0x" (bytevector-u8-ref bv i))
|
|
(if (< i 5) (format #t ":"))
|
|
(loop (1+ i))))
|
|
(newline))
|
|
|
|
(define (hardware-address-to-string bv)
|
|
"Convert a hardware address BV given as a 6-length bytevector
|
|
to a string"
|
|
(assert (= 6 (bytevector-length bv)))
|
|
(let loop ((i 0) (ls '()))
|
|
(if (< i 6)
|
|
(let* ((byte (bytevector-u8-ref bv i))
|
|
(s (format #f "~2,'0x" byte)))
|
|
(loop (1+ i) (cons ":" (cons s ls))))
|
|
(string-concatenate (reverse (cdr ls))))))
|
|
|
|
(define (retain-ethernet-interfaces ifaces)
|
|
"Find all ethernet interfaces from a list of
|
|
interface names"
|
|
(filter (lambda (name)
|
|
(string-prefix? "eth" name))
|
|
ifaces))
|
|
|
|
;; Record type for network interfaces.
|
|
;; See also: getifaddrs (3).
|
|
(define-record-type <net-iface>
|
|
(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))
|
|
|
|
;; Note: DHCP in <net-iface> is an instance of
|
|
;; the <dhcp> 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).
|
|
|
|
;; Create a <net-iface> 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-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)))))
|