Re: [PATCH] getifaddrs wrapper

[Rohan Prinja <rohan.prinja@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 935 bytes --]

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 <ludo@gnu.org> wrote:
> Rohan Prinja <rohan.prinja@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 <ludo@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’.

[-- Attachment #2: getifaddrs-patch.patch --]
[-- Type: text/x-patch, Size: 16008 bytes --]

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 <ludo@gnu.org>
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;; Copyright © 2015 Rohan Prinja <rohan.prinja@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)
 
 \f