Merge branch 'master' into core-updates

2 files changed, 225 insertions, 10 deletions

diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm
index 2f3d04a5d8..74ba0c765d 100644
--- a/guix/build/python-build-system.scm
+++ b/guix/build/python-build-system.scm
@@ -105,19 +105,36 @@
                             files)))
               bindirs)))
 
+(define* (rename-pth-file #:key name inputs outputs #:allow-other-keys)
+  "Rename easy-install.pth to NAME.pth to avoid conflicts between packages
+installed with setuptools."
+  (let* ((out (assoc-ref outputs "out"))
+         (python (assoc-ref inputs "python"))
+         (site-packages (string-append out "/lib/python"
+                                       (get-python-version python)
+                                       "/site-packages"))
+         (easy-install-pth (string-append site-packages "/easy-install.pth"))
+         (new-pth (string-append site-packages "/" name ".pth")))
+    (when (file-exists? easy-install-pth)
+      (rename-file easy-install-pth new-pth))
+    #t))
+
 (define %standard-phases
   ;; 'configure' and 'build' phases are not needed.  Everything is done during
   ;; 'install'.
-  (alist-cons-after
-   'install 'wrap
-   wrap
-   (alist-replace
-    'build build
+  (alist-cons-before
+   'strip 'rename-pth-file
+   rename-pth-file
+   (alist-cons-after
+    'install 'wrap
+    wrap
     (alist-replace
-     'check check
-     (alist-replace 'install install
-                    (alist-delete 'configure
-                                               gnu:%standard-phases))))))
+     'build build
+     (alist-replace
+      'check check
+      (alist-replace 'install install
+                     (alist-delete 'configure
+                                   gnu:%standard-phases)))))))
 
 (define* (python-build #:key inputs (phases %standard-phases)
                        #:allow-other-keys #:rest args)
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index e1fafe2266..b210f8faa8 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -42,7 +42,11 @@
             all-network-interfaces
             network-interfaces
             network-interface-flags
-            loopback-network-interface?))
+            loopback-network-interface?
+            network-interface-address
+            set-network-interface-flags
+            set-network-interface-address
+            configure-network-interface))
 
 ;;; Commentary:
 ;;;
@@ -230,6 +234,77 @@ user-land process."
 
 
 ;;;
+;;; Packed structures.
+;;;
+
+(define-syntax sizeof*
+  ;; XXX: This duplicates 'compile-time-value'.
+  (syntax-rules (int128)
+    ((_ int128)
+     16)
+    ((_ type)
+     (let-syntax ((v (lambda (s)
+                       (let ((val (sizeof type)))
+                         (syntax-case s ()
+                           (_ val))))))
+       v))))
+
+(define-syntax type-size
+  (syntax-rules (~)
+    ((_ (type ~ order))
+     (sizeof* type))
+    ((_ type)
+     (sizeof* type))))
+
+(define-syntax write-type
+  (syntax-rules (~)
+    ((_ bv offset (type ~ order) value)
+     (bytevector-uint-set! bv offset value
+                           (endianness order) (sizeof* type)))
+    ((_ bv offset type value)
+     (bytevector-uint-set! bv offset value
+                           (native-endianness) (sizeof* type)))))
+
+(define-syntax write-types
+  (syntax-rules ()
+    ((_ bv offset () ())
+     #t)
+    ((_ bv offset (type0 types ...) (field0 fields ...))
+     (begin
+       (write-type bv offset type0 field0)
+       (write-types bv (+ offset (type-size type0))
+                    (types ...) (fields ...))))))
+
+(define-syntax read-type
+  (syntax-rules (~)
+    ((_ bv offset (type ~ order))
+     (bytevector-uint-ref bv offset
+                          (endianness order) (sizeof* type)))
+    ((_ bv offset type)
+     (bytevector-uint-ref bv offset
+                          (native-endianness) (sizeof* type)))))
+
+(define-syntax read-types
+  (syntax-rules ()
+    ((_ bv offset ())
+     '())
+    ((_ bv offset (type0 types ...))
+     (cons (read-type bv offset type0)
+           (read-types bv (+ offset (type-size type0)) (types ...))))))
+
+(define-syntax define-c-struct
+  (syntax-rules ()
+    "Define READ as an optimized serializer and WRITE! as a deserializer for
+the C structure with the given TYPES."
+    ((_ name read write! (fields types) ...)
+     (begin
+       (define (write! bv offset fields ...)
+         (write-types bv offset (types ...) (fields ...)))
+       (define (read bv offset)
+         (read-types bv offset (types ...)))))))
+
+
+;;;
 ;;; Network interfaces.
 ;;;
 
@@ -241,6 +316,18 @@ user-land process."
   (if (string-contains %host-type "linux")
       #x8913                                      ;GNU/Linux
       #xc4804191))                                ;GNU/Hurd
+(define SIOCSIFFLAGS
+  (if (string-contains %host-type "linux")
+      #x8914                                      ;GNU/Linux
+      -1))                                        ;FIXME: GNU/Hurd?
+(define SIOCGIFADDR
+  (if (string-contains %host-type "linux")
+      #x8915                                      ;GNU/Linux
+      -1))                                        ;FIXME: GNU/Hurd?
+(define SIOCSIFADDR
+  (if (string-contains %host-type "linux")
+      #x8916                                      ;GNU/Linux
+      -1))                                        ;FIXME: GNU/Hurd?
 
 ;; Flags and constants from <net/if.h>.
 
@@ -263,6 +350,56 @@ user-land process."
       40
       32))
 
+(define-c-struct sockaddr-in                      ;<linux/in.h>
+  read-sockaddr-in
+  write-sockaddr-in!
+  (family    unsigned-short)
+  (port      (int16 ~ big))
+  (address   (int32 ~ big)))
+
+(define-c-struct sockaddr-in6                     ;<linux/in6.h>
+  read-sockaddr-in6
+  write-sockaddr-in6!
+  (family    unsigned-short)
+  (port      (int16 ~ big))
+  (flowinfo  (int32 ~ big))
+  (address   (int128 ~ big))
+  (scopeid   int32))
+
+(define (write-socket-address! sockaddr bv index)
+  "Write SOCKADDR, a socket address as returned by 'make-socket-address', to
+bytevector BV at INDEX."
+  (let ((family (sockaddr:fam sockaddr)))
+    (cond ((= family AF_INET)
+           (write-sockaddr-in! bv index
+                               family
+                               (sockaddr:port sockaddr)
+                               (sockaddr:addr sockaddr)))
+          ((= family AF_INET6)
+           (write-sockaddr-in6! bv index
+                                family
+                                (sockaddr:port sockaddr)
+                                (sockaddr:flowinfo sockaddr)
+                                (sockaddr:addr sockaddr)
+                                (sockaddr:scopeid sockaddr)))
+          (else
+           (error "unsupported socket address" sockaddr)))))
+
+(define (read-socket-address bv index)
+  "Read a socket address from bytevector BV at INDEX."
+  (let ((family (bytevector-u16-native-ref bv index)))
+    (cond ((= family AF_INET)
+           (match (read-sockaddr-in bv index)
+             ((family port address)
+              (make-socket-address family address port))))
+          ((= family AF_INET6)
+           (match (read-sockaddr-in6 bv index)
+             ((family port flowinfo address scopeid)
+              (make-socket-address family address port
+                                   flowinfo scopeid))))
+          (else
+           "unsupported socket address family" family))))
+
 (define %ioctl
   ;; The most terrible interface, live from Scheme.
   (pointer->procedure int
@@ -354,4 +491,65 @@ interface NAME."
     (close-port sock)
     (not (zero? (logand flags IFF_LOOPBACK)))))
 
+(define (set-network-interface-flags socket name flags)
+  "Set the flag of network interface NAME to FLAGS."
+  (let ((req (make-bytevector ifreq-struct-size)))
+    (bytevector-copy! (string->utf8 name) 0 req 0
+                      (min (string-length name) (- IF_NAMESIZE 1)))
+    ;; Set the 'ifr_flags' field.
+    (bytevector-uint-set! req IF_NAMESIZE flags (native-endianness)
+                          (sizeof short))
+    (let* ((ret (%ioctl (fileno socket) SIOCSIFFLAGS
+                        (bytevector->pointer req)))
+           (err (errno)))
+      (unless (zero? ret)
+        (throw 'system-error "set-network-interface-flags"
+               "set-network-interface-flags on ~A: ~A"
+               (list name (strerror err))
+               (list err))))))
+
+(define (set-network-interface-address socket name sockaddr)
+  "Set the address of network interface NAME to SOCKADDR."
+  (let ((req (make-bytevector ifreq-struct-size)))
+    (bytevector-copy! (string->utf8 name) 0 req 0
+                      (min (string-length name) (- IF_NAMESIZE 1)))
+    ;; Set the 'ifr_addr' field.
+    (write-socket-address! sockaddr req IF_NAMESIZE)
+    (let* ((ret (%ioctl (fileno socket) SIOCSIFADDR
+                        (bytevector->pointer req)))
+           (err (errno)))
+      (unless (zero? ret)
+        (throw 'system-error "set-network-interface-address"
+               "set-network-interface-address on ~A: ~A"
+               (list name (strerror err))
+               (list err))))))
+
+(define (network-interface-address socket name)
+  "Return the address of network interface NAME.  The result is an object of
+the same type as that returned by 'make-socket-address'."
+  (let ((req (make-bytevector ifreq-struct-size)))
+    (bytevector-copy! (string->utf8 name) 0 req 0
+                      (min (string-length name) (- IF_NAMESIZE 1)))
+    (let* ((ret (%ioctl (fileno socket) SIOCGIFADDR
+                        (bytevector->pointer req)))
+           (err (errno)))
+      (if (zero? ret)
+          (read-socket-address req IF_NAMESIZE)
+          (throw 'system-error "network-interface-address"
+                 "network-interface-address on ~A: ~A"
+                 (list name (strerror err))
+                 (list err))))))
+
+(define (configure-network-interface name sockaddr flags)
+  "Configure network interface NAME to use SOCKADDR, an address as returned by
+'make-socket-address', and FLAGS, a bitwise-or of IFF_* constants."
+  (let ((sock (socket (sockaddr:fam sockaddr) SOCK_STREAM 0)))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        (set-network-interface-address sock name sockaddr)
+        (set-network-interface-flags sock name flags))
+      (lambda ()
+        (close-port sock)))))
+
 ;;; syscalls.scm ends here