dhcp/dhcp/interfaces.scm

;;; 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/>.

(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
	    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 from (guix build syscalls) end

(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"
  (let ((f (pointer->procedure ret-type
			       (dynamic-func c-fn-name lib)
			       c-fn-args)))
    (f arg ...)))

;; 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).
(define-syntax-rule (free-interfaces ifaddrs)
  (link-fn "free_interfaces" *libinterfaces* void '(*) ifaddrs))

;; 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).
(define *sockaddr-struct-type* (list unsigned-short '*))

;; 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.
(define-syntax-rule (parse-sockaddr sockaddr)
  (parse-c-struct sockaddr *sockaddr-struct-type*))

;; Note: In the <ifaddrs.h> 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.
(define-syntax-rule (next-parsed-ifaddr parsed)
  (let ((next-ptr (car parsed)))
    (if (null-pointer? next-ptr)
	'()
	(parse-ifaddr (car parsed)))))

(define-syntax-rule (af-inet? family)
  "Is the family AF_INET or AF_INET6?"
  (or (= family AF_INET) (= family AF_INET6)))

(define (get-sockaddr-data sockaddr)
  "Retrieve the data field from struct sockaddr. It might be NULL."
  (let ((data-ptr (cadr sockaddr)))
    (if (null-pointer? data-ptr)
	""
	(pointer->string data-ptr))))

(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 (find-interfaces ifaddrs)
  "Find all AF_INET/AF_INET6 family network interfaces."
  (define (helper parsed result)
    (if (null? parsed)
	result
	(let* ((name (pointer->string (cadr parsed)))
	       (flags (caddr parsed))
	       (sockaddr-ptr (list-ref parsed 3))
	       (sockaddr (parse-sockaddr sockaddr-ptr))
	       (data (get-sockaddr-data sockaddr))
	       ;(_ (display (format #f "~a\n" sockaddr)))
	       (family (car sockaddr))
	       )
	  (if (af-inet? family)
	      (display (format #f "Name ~a, Family ~a\n" name family)))
	  (helper (next-parsed-ifaddr parsed)
		  (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) '()))

(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 (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)))))