06/06: syscalls: Add 'network-interfaces', which wraps libc's 'getifaddrs'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit e7f5691d4540e2cbcbc9f22f8b593f15890057b3
Author: Ludovic Courtès <address@hidden>
Date:   Sat Jul 25 13:06:01 2015 +0200

    syscalls: Add 'network-interfaces', which wraps libc's 'getifaddrs'.
    
    Based on discussions with Rohan Prinja <address@hidden>.
    
    * guix/build/syscalls.scm (<interface>): New record type.
      (write-interface, values->interface, unfold-interface-list,
      network-interfaces, free-ifaddrs): New procedures.
      (ifaddrs): New C struct.
      (%struct-ifaddrs-type, %sizeof-ifaddrs): New macros.
    * tests/syscalls.scm ("network-interfaces returns one or more interfaces",
      "network-interfaces returns \"lo\""): New tests.
---
 guix/build/syscalls.scm |  116 ++++++++++++++++++++++++++++++++++++++++++++++-
 tests/syscalls.scm      |   23 +++++++++
 2 files changed, 138 insertions(+), 1 deletions(-)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index ca26824..68f340c 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -21,6 +21,8 @@
   #:use-module (system foreign)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
@@ -70,7 +72,15 @@
             set-network-interface-flags
             set-network-interface-address
             set-network-interface-up
-            configure-network-interface))
+            configure-network-interface
+
+            interface?
+            interface-name
+            interface-flags
+            interface-address
+            interface-netmask
+            interface-broadcast-address
+            network-interfaces))
 
 ;;; Commentary:
 ;;;
@@ -713,4 +723,108 @@ the same type as that returned by 'make-socket-address'."
       (lambda ()
         (close-port sock)))))
 
+
+;;;
+;;; Details about network interfaces---aka. 'getifaddrs'.
+;;;
+
+;; Network interfaces.  XXX: We would call it <network-interface> but that
+;; would collide with the ioctl wrappers above.
+(define-record-type <interface>
+  (make-interface name flags address netmask broadcast-address)
+  interface?
+  (name              interface-name)               ;string
+  (flags             interface-flags)              ;or'd IFF_* values
+  (address           interface-address)            ;sockaddr | #f
+  (netmask           interface-netmask)            ;sockaddr | #f
+  (broadcast-address interface-broadcast-address)) ;sockaddr | #f
+
+(define (write-interface interface port)
+  (match interface
+    (($ <interface> name flags address)
+     (format port "#<interface ~s " name)
+     (unless (zero? (logand IFF_UP flags))
+       (display "up " port))
+     (if (member (sockaddr:fam address) (list AF_INET AF_INET6))
+         (format port "~a " (inet-ntop (sockaddr:fam address)
+                                       (sockaddr:addr address)))
+         (format port "family:~a " (sockaddr:fam address)))
+     (format port "~a>" (number->string (object-address interface) 16)))))
+
+(set-record-type-printer! <interface> write-interface)
+
+(define (values->interface next name flags address netmask
+                           broadcast-address data)
+  "Given the raw field values passed as arguments, return a pair whose car is
+an <interface> object, and whose cdr is the pointer NEXT."
+  (define (maybe-socket-address pointer)
+    (if (null-pointer? pointer)
+        #f
+        (read-socket-address (pointer->bytevector pointer 50)))) ;XXX: size
+
+  (cons (make-interface (if (null-pointer? name)
+                            #f
+                            (pointer->string name))
+                        flags
+                        (maybe-socket-address address)
+                        (maybe-socket-address netmask)
+                        (maybe-socket-address broadcast-address)
+                        ;; Ignore DATA.
+                        )
+        next))
+
+(define-c-struct ifaddrs                          ;<ifaddrs.h>
+  values->interface
+  read-ifaddrs
+  write-ifaddrs!
+  (next          '*)
+  (name          '*)
+  (flags         unsigned-int)
+  (addr          '*)
+  (netmask       '*)
+  (broadcastaddr '*)
+  (data          '*))
+
+(define-syntax %struct-ifaddrs-type
+  (identifier-syntax
+   `(* * ,unsigned-int * * * *)))
+
+(define-syntax %sizeof-ifaddrs
+  (identifier-syntax
+   (sizeof* %struct-ifaddrs-type)))
+
+(define (unfold-interface-list ptr)
+  "Call 'read-ifaddrs' on PTR and all its 'next' fields, recursively, and
+return the list of resulting <interface> objects."
+  (let loop ((ptr    ptr)
+             (result '()))
+    (if (null-pointer? ptr)
+        (reverse result)
+        (match (read-ifaddrs (pointer->bytevector ptr %sizeof-ifaddrs)
+                             0)
+          ((ifaddr . ptr)
+           (loop ptr (cons ifaddr result)))))))
+
+(define network-interfaces
+  (let* ((ptr  (dynamic-func "getifaddrs" (dynamic-link)))
+         (proc (pointer->procedure int ptr (list '*))))
+    (lambda ()
+      "Return a list of <interface> objects, each denoting a configured
+network interface.  This is implemented using the 'getifaddrs' libc function."
+      (let* ((ptr (bytevector->pointer (make-bytevector (sizeof* '*))))
+             (ret (proc ptr))
+             (err (errno)))
+        (if (zero? ret)
+            (let* ((ptr    (dereference-pointer ptr))
+                   (result (unfold-interface-list ptr)))
+              (free-ifaddrs ptr)
+              result)
+            (throw 'system-error "network-interfaces" "~A"
+                   (list (strerror err))
+                   (list err)))))))
+
+(define free-ifaddrs
+  (let ((ptr (dynamic-func "freeifaddrs" (dynamic-link))))
+    (pointer->procedure void ptr '(*))))
+
 ;;; syscalls.scm ends here
diff --git a/tests/syscalls.scm b/tests/syscalls.scm
index 3b71cd7..090e1e7 100644
--- a/tests/syscalls.scm
+++ b/tests/syscalls.scm
@@ -211,6 +211,29 @@
         ;; We get EPERM with Linux 3.18ish and EACCES with 2.6.32.
         (memv (system-error-errno args) (list EPERM EACCES))))))
 
+(test-equal "network-interfaces returns one or more interfaces"
+  '(#t #t #t)
+  (match (network-interfaces)
+    ((interfaces ..1)
+     (list (every interface? interfaces)
+           (every string? (map interface-name interfaces))
+           (every vector? (map interface-address interfaces))))))
+
+(test-equal "network-interfaces returns \"lo\""
+  (list #t (make-socket-address AF_INET (inet-pton AF_INET "127.0.0.1") 0))
+  (match (filter (lambda (interface)
+                   (string=? "lo" (interface-name interface)))
+                 (network-interfaces))
+    ((loopbacks ..1)
+     (list (every (lambda (lo)
+                    (not (zero? (logand IFF_LOOPBACK (interface-flags lo)))))
+                  loopbacks)
+           (match (find (lambda (lo)
+                          (= AF_INET (sockaddr:fam (interface-address lo))))
+                        loopbacks)
+             (#f #f)
+             (lo (interface-address lo)))))))
+
 (test-end)