Hi,
'git rebase' kept failing after a pull, so I squashed my 8 commits
into one. That got the rebase to work. Sorry for the giant patch...
Ludo: the tests for syscalls.scm are included in the patch as well.
Thank you,
Rohan
On 16 July 2015 at 21:08, Ludovic Courtès <l...@gnu.org> wrote:
> Rohan Prinja <rohan.pri...@gmail.com> skribis:
>
>> Added a convenience macro to make the filtering out of unneeded
>> interfaces cleaner.
>
>>> On 2 July 2015 at 17:53, Ludovic Courtès <l...@gnu.org> wrote:
>
> [...]
>
>>>> Could you send the updated patch against master, that includes a simple
>>>> test in tests/syscalls.scm that makes sure that ‘getifaddrs’ returns a
>>>> possibly empty list of <interface-address>?
>
> Could you please do both things ↑, or at least the first item (I’ll
> finish polishing it)?
>
> ‘git diff origin/master’ should produce the patch.
>
> TIA!
>
> Ludo’.
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index dcca5fc..8262e0b 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015 Ludovic Courtès <l...@gnu.org>
;;; Copyright © 2015 David Thompson <da...@gnu.org>
+;;; Copyright © 2015 Rohan Prinja <rohan.pri...@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -21,6 +22,7 @@
#:use-module (system foreign)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (ice-9 match)
@@ -57,6 +59,26 @@
clone
setns
+ getifaddrs
+
+ <interface-address>
+ interface-address?
+ interface-address-name
+ interface-address-flags
+ interface-address-data
+
+ interface-address-addr
+ interface-address-netmask
+ interface-address-broadaddr
+
+ ;; Wrappers around the above three functions. Each
+ ;; of these returns either a socket address or #f.
+ interface-address-address
+ interface-address-broadcast-addr
+ interface-address-netmask-addr
+
+ remove-if-netmask-null
+
IFF_UP
IFF_BROADCAST
IFF_LOOPBACK
@@ -478,6 +500,202 @@ the C structure with the given TYPES."
(address (int128 ~ big))
(scopeid int32))
+(define-c-struct ifaddrs ;<ifaddrs.h>
+ read-ifaddrs
+ write-ifaddrs!
+ (ifa-next '*)
+ (ifa-name '*)
+ (ifa-flags unsigned-int)
+ (ifa-addr '*)
+ (ifa-netmask '*)
+ (ifu-broadcastaddr '*)
+ (ifa-data '*))
+
+(define-record-type <interface-address>
+ (make-interface-address name flags addr netmask broadaddr data)
+ interface-address?
+ (name interface-address-name)
+ (flags interface-address-flags)
+ (addr interface-address-addr)
+ (netmask interface-address-netmask)
+ (broadaddr interface-address-broadaddr)
+ (data interface-address-data))
+
+(define (bytevector-slice bv start len)
+ "Return a new bytevector (not a view into the old one)
+containing the elements from BV from index START upto
+index START + LEN - 1"
+ (let* ((res (make-bytevector len 0)))
+ (bytevector-copy! bv start res 0 len)
+ res))
+
+;; FFI type for 'struct ifaddrs'.
+(define %struct-ifaddrs-type
+ `(* * ,unsigned-int * * * *))
+
+;; Size of 'struct sockaddr' in bytes.
+;; See also: bind (2).
+(define %sizeof-struct-sockaddr
+ (+ 14 (sizeof unsigned-short)))
+
+(define (ifaddrs-pointer->bv ptr)
+ "Return a bytevector aliasing the memory pointed to by a
+'struct ifaddrs' pointer, passed as a pointer object PTR."
+ (pointer->bytevector ptr (sizeof %struct-ifaddrs-type)))
+
+;; Initializer for 'struct ifaddrs'.
+(define %struct-ifaddrs-init
+ (list %null-pointer
+ %null-pointer
+ 0
+ %null-pointer
+ %null-pointer
+ %null-pointer
+ %null-pointer))
+
+(define (next-ifaddr-ptr bv)
+ "Return a bytevector aliasing the memory pointed to by the
+ifa_next field of a struct ifaddrs* pointer passed as a
+bytevector BV."
+ (let* ((ptr-size (sizeof '*))
+ (address (cond ((= ptr-size 4) (bytevector-u32-native-ref bv 0))
+ ((= ptr-size 8) (bytevector-u64-native-ref bv 0)))))
+ (make-pointer address)))
+
+;; Return the bytevector aliasing the memory pointed to by
+;; the ifa-next field in a 'struct ifaddrs' pointer passed in
+;; as a bytevector.
+(define next-ifaddr
+ (compose ifaddrs-pointer->bv
+ next-ifaddr-ptr))
+
+(define %getifaddrs
+ (let* ((func-ptr (dynamic-func "getifaddrs" (dynamic-link)))
+ (proc (pointer->procedure int func-ptr (list '*))))
+ (lambda ()
+ "Wrapper around getifaddrs (3)."
+ (let* ((ptr (make-c-struct %struct-ifaddrs-type
+ %struct-ifaddrs-init))
+ (ret (proc ptr))
+ (err (errno)))
+ (if (zero? ret)
+ (next-ifaddr (ifaddrs-pointer->bv ptr))
+ (throw 'system-error "getifaddrs" "~S: ~A"
+ (list ptr (strerror err))
+ (list err)))))))
+
+(define (make-ifaddrs bv)
+ "Convert a bytevector aliasing the memory pointed to by a
+'struct ifaddrs' pointer into a <interface-address> record."
+ (match (read-ifaddrs bv 0)
+ ((next name-ptr flags addr netmask broadaddr data)
+ (make-interface-address (pointer->string (make-pointer name-ptr))
+ flags
+ (make-pointer addr)
+ (make-pointer netmask)
+ (make-pointer broadaddr)
+ (make-pointer data)))))
+
+;; Is an interface the last in the intrusive linked list of struct ifaddrs?
+;; Here, the only argument is a bytevector aliasing the memory pointed to by
+;; a 'struct ifaddrs' pointer.
+(define last-interface?
+ (compose null-pointer? next-ifaddr-ptr))
+
+(define (pack-ifaddrs bv)
+ "Strip out the needless 4-byte padding after the
+unsigned-int ifa-flags field"
+ (if (and (= 8 (sizeof '*))
+ (= 4 (sizeof unsigned-int)))
+ (let* ((res (make-bytevector 52 0)))
+ (bytevector-copy! bv 0 res 0 20)
+ (bytevector-copy! bv 24 res 20 32)
+ res)
+ bv))
+
+(define (getifaddrs)
+ "Return the list of network interfaces on the local system."
+ (let ((ifaddrs (%getifaddrs)))
+ (let loop ((curr ifaddrs) (res '()))
+ (if (last-interface? curr)
+ (map (compose make-ifaddrs pack-ifaddrs)
+ (reverse res))
+ (loop (next-ifaddr curr)
+ (cons curr res))))))
+
+;; Given a bytevector aliasing the memory pointed to by
+;; a 'struct sockaddr' pointer, return a socket address.
+(define-syntax-rule (bytevector->sockaddr bv)
+ (match (read-sockaddr-in bv 0)
+ ((family port address)
+ (if (member family (list AF_INET AF_INET6 AF_UNIX))
+ (inet-ntop family address)
+ #f))))
+
+;; Note: getifaddrs returns multiple interfaces with the same
+;; e.g. on my system I see multiple "eth0"s. The difference is
+;; that for one of the eth0's, the family of the address
+;; pointed to by the ifu.ifa-broadaddr field is 17, which is
+;; not an AF_* constant. Hence the check for "(member family ...)".
+
+(define (extract-address-field iface field)
+ "Extract a field corresponding to an IPv4 address from a 'struct
+sockaddr' from an <interface-address> record type."
+ (let* ((addr (field iface))
+ (bv (pointer->bytevector addr %sizeof-struct-sockaddr)))
+ (bytevector->sockaddr bv)))
+
+;; Note: address fields in 'struct getifaddrs' are pointers to
+;; 'struct sockaddr'. In 'extract-address-field' we are
+;; implicitly typecasting this 'sockaddr' pointer to a
+;; 'sockaddr_in' pointer.
+
+;; Utility macro to remove all ifaces from the output IFACES of
+;; (getifaddrs) that have a null-pointer in the 'netmask' field.
+(define-syntax-rule (remove-if-netmask-null ifaces)
+ (remove (compose null-pointer? interface-address-netmask) ifaces))
+
+;; Given an <interface-address> record IFACE, return its
+;; address field as a sockaddr if it exists, otherwise return #f.
+(define (interface-address-address iface)
+ (extract-address-field iface interface-address-addr))
+
+;; Given an <interface-address> record IFACE, return its broadcast
+;; address field as a sockaddr if it exists, otherwise return #f.
+(define (interface-address-broadcast-addr iface)
+ (extract-address-field iface interface-address-broadaddr))
+
+;; Given an <interface-address> record IFACE, return its netmask
+;; address field as a sockaddr if it exists, otherwise return #f.
+(define (interface-address-netmask-addr iface)
+ (extract-address-field iface interface-address-netmask))
+
+;; Retrieve the ifa-next-ptr field from a 'struct ifaddrs'
+;; pointer passed in as a bytevector BV.
+(define-syntax-rule (ifaddr-next-ptr bv)
+ (match (read-ifaddrs bv 0)
+ ((next name-ptr flags addr netmask broadaddr data)
+ next)))
+
+;; Retrieve the bytes corresponding to the ifa-name field
+;; from a 'struct ifaddrs' pointer passed in as a bytevector BV.
+(define-syntax-rule (ifaddr-name-bytes bv)
+ (match (read-ifaddrs bv 0)
+ ((next name-ptr flags addr netmask broadaddr data)
+ name-ptr)))
+
+;; Retrieve the string pointed to by the ifa-name field
+;; from a 'struct ifaddrs' pointer passed in as a bytevector BV.
+(define-syntax-rule (ifaddr-name bv)
+ (pointer->string (make-pointer (ifaddr-name-bytes bv))))
+
+;; Retrieve the ifa-flags field from a 'struct ifaddrs'
+;; pointer passed in as a bytevector BV.
+(define-syntax-rule (ifaddr-flags bv)
+ (match (read-ifaddrs bv 0)
+ ((next name-ptr flags addr netmask broadaddr data)
+ flags)))
+
(define (write-socket-address! sockaddr bv index)
"Write SOCKADDR, a socket address as returned by 'make-socket-address', to
bytevector BV at INDEX."
diff --git a/tests/syscalls.scm b/tests/syscalls.scm
index 6b614a5..73105a5 100644
--- a/tests/syscalls.scm
+++ b/tests/syscalls.scm
@@ -23,11 +23,98 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-64)
- #:use-module (ice-9 match))
+ #:use-module (ice-9 match)
+ #:use-module ((ice-9 popen) #:select (open-pipe*))
+ #:use-module ((ice-9 rdelim) #:select (read-line))
+ #:use-module ((ice-9 regex) #:select (string-match match:substring))
+ #:use-module (rnrs bytevectors)
+ #:use-module (system foreign)
+ #:use-module ((rnrs io ports) #:select (port-eof?)))
;; Test the (guix build syscalls) module, although there's not much that can
;; actually be tested without being root.
+;; Is the first character of a string #\space?
+(define-syntax-rule (first-char-is-space? string)
+ (eq? #\space (string-ref string 0)))
+
+;; In the output produced by ifconfig (8), is a line
+;; one that starts a new interface description?
+(define-syntax-rule (line-contains-iface-name? line)
+ (not (or (string-null? line)
+ (first-char-is-space? line))))
+
+(define (ifconfig-find-all-interfaces)
+ "List all the network interfaces as identified
+by ifconfig (8)."
+ (let ((pipe (open-pipe* OPEN_READ "ifconfig")))
+ (let lp ((line (read-line pipe))
+ (res '()))
+ (cond ((port-eof? pipe) (reverse res))
+ ((line-contains-iface-name? line)
+ (let* ((trimmed-line (string-trim-both line))
+ (split-line (string-split trimmed-line #\space))
+ (iface-name (car split-line)))
+ (lp (read-line pipe)
+ (cons iface-name res))))
+ (else (lp (read-line pipe) res))))))
+
+(define (extract-iface-name line)
+ "Extract the name of the interface from a line in the output of
+ifconfig (8) which is known to be the first line describing said
+interface."
+ (let ((str-ls (string->list line)))
+ (let lp ((ls str-ls) (res '()))
+ (if (eq? #\space (car ls))
+ (apply string (reverse res))
+ (lp (cdr ls) (cons (car ls) res))))))
+
+(define (ifconfig-extract-addr-of iface-name type)
+ "Call ifconfig (8) to find out the broadcast address of the
+interface whose name is a prefix of the string IFACE-NAME. The
+broadcast address is returned as a printable string."
+ (let ((pipe (open-pipe* OPEN_READ "ifconfig")))
+ (let lp ((line (read-line pipe)))
+ (if (eof-object? line)
+ #f
+ (if (and (line-contains-iface-name? line)
+ (string-prefix? iface-name
+ (extract-iface-name line)))
+ (let* ((next-line (read-line pipe))
+ (search-string (cond ((eq? type 'broadcast) "Bcast:")
+ ((eq? type 'netmask) "Mask:")
+ (else "inet addr:")))
+ (str-byte "[0-9]([0-9][0-9])?")
+ (ipaddr-regex (string-append search-string
+ str-byte "\\."
+ str-byte "\\."
+ str-byte "\\."
+ str-byte))
+ (match (string-match ipaddr-regex next-line)))
+ (if match
+ (string-drop (match:substring match) (cond ((eq? type 'broadcast) 6)
+ ((eq? type 'netmask) 5)
+ (else 10)))
+ (lp (read-line pipe))))
+ (lp (read-line pipe)))))))
+
+(define (prefix? ls1 ls2)
+ "Is list LS1 a prefix of list LS2?. This procedure
+assumes that (length ls1) <= (length ls2)."
+ (or (null? ls1)
+ (and (equal? (car ls1) (car ls2))
+ (prefix? (cdr ls1) (cdr ls2)))))
+
+(define (remove-duplicates ls)
+ "Remove consecutive duplicate elements from a list LS.
+For example, (4 2 2 2 2 1 3 3) => (4 2 1 3)."
+ (cond ((< (length ls) 2)
+ ls)
+ ((equal? (car ls) (cadr ls))
+ (remove-duplicates (cdr ls)))
+ (else
+ (cons (car ls) (remove-duplicates (cdr ls))))))
+
(test-begin "syscalls")
(test-equal "mount, ENOENT"
@@ -211,6 +298,51 @@
;; We get EPERM with Linux 3.18ish and EACCES with 2.6.32.
(memv (system-error-errno args) (list EPERM EACCES))))))
+(test-assert "getifaddrs"
+ (let* ((ifaddrs (getifaddrs))
+ (names (map interface-address-name ifaddrs)))
+ (member "lo" names)))
+
+(test-assert "ifconfig-result-is-subset-of-getifaddrs-result"
+ (let* ((ifaddrs (getifaddrs))
+ (names (map interface-address-name ifaddrs))
+ (sorted-names (sort names string<?))
+ (unique-names (remove-duplicates sorted-names))
+ (ifconfig (ifconfig-find-all-interfaces)))
+ (prefix?
+ (sort (ifconfig-find-all-interfaces) string<?)
+ unique-names)))
+
+(test-assert "getifaddrs-address"
+ (let* ((is-eth-iface? (lambda (i)
+ (string-prefix? "eth"
+ (interface-address-name i))))
+ (ifaddrs (remove-if-netmask-null (getifaddrs)))
+ (eth-ifaces (filter is-eth-iface? ifaddrs))
+ (getifaddrs-result (map interface-address-address eth-ifaces))
+ (ifconfig-result (ifconfig-extract-addr-of "eth" 'address)))
+ (member ifconfig-result getifaddrs-result)))
+
+(test-assert "getifaddrs-broadcast-address"
+ (let* ((is-eth-iface? (lambda (i)
+ (string-prefix? "eth"
+ (interface-address-name i))))
+ (ifaddrs (remove-if-netmask-null (getifaddrs)))
+ (eth-ifaces (filter is-eth-iface? ifaddrs))
+ (getifaddrs-result (map interface-address-broadcast-addr eth-ifaces))
+ (ifconfig-result (ifconfig-extract-addr-of "eth" 'broadcast)))
+ (member ifconfig-result getifaddrs-result)))
+
+(test-assert "getifaddrs-netmask-address"
+ (let* ((is-eth-iface? (lambda (i)
+ (string-prefix? "eth"
+ (interface-address-name i))))
+ (ifaddrs (remove-if-netmask-null (getifaddrs)))
+ (eth-ifaces (filter is-eth-iface? ifaddrs))
+ (getifaddrs-result (map interface-address-netmask-addr eth-ifaces))
+ (ifconfig-result (ifconfig-extract-addr-of "eth" 'netmask)))
+ (member ifconfig-result getifaddrs-result)))
+
(test-end)
