Merge branch 'master' into core-updates

5 files changed, 280 insertions, 66 deletions

diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm
index 4bba7167ca..e8af9f8146 100644
--- a/guix/build-system/python.scm
+++ b/guix/build-system/python.scm
@@ -55,8 +55,7 @@ PYTHON-BUILD-SYSTEM, such that it is compiled with PYTHON instead.  The
 inputs are changed recursively accordingly.  If the name of P starts with
 OLD-PREFIX, this is replaced by NEW-PREFIX; otherwise, NEW-PREFIX is
 prepended to the name."
-  (let* ((build-system (package-build-system p))
-         (rewrite-if-package
+  (let* ((rewrite-if-package
           (lambda (content)
             ;; CONTENT may be a file name, in which case it is returned, or a
             ;; package, which is rewritten with the new PYTHON and NEW-PREFIX.
@@ -68,28 +67,23 @@ prepended to the name."
            (match-lambda
              ((name content . rest)
               (append (list name (rewrite-if-package content)) rest)))))
-    (package (inherit p)
-      (name
-        (let ((name (package-name p)))
-          (if (eq? build-system python-build-system)
-              (string-append new-prefix
-                             (if (string-prefix? old-prefix name)
-                                 (substring name (string-length old-prefix))
-                                 name))
-              name)))
-      (arguments
-        (let ((arguments (package-arguments p)))
-          (if (eq? build-system python-build-system)
-              (if (member #:python arguments)
-                  (substitute-keyword-arguments arguments ((#:python p) python))
-                  (append arguments `(#:python ,python)))
-              arguments)))
-      (inputs
-        (map rewrite (package-inputs p)))
-      (propagated-inputs
-        (map rewrite (package-propagated-inputs p)))
-      (native-inputs
-        (map rewrite (package-native-inputs p))))))
+
+    (if (eq? (package-build-system p) python-build-system)
+        (package (inherit p)
+          (name (let ((name (package-name p)))
+                  (string-append new-prefix
+                                 (if (string-prefix? old-prefix name)
+                                     (substring name (string-length old-prefix))
+                                     name))))
+          (arguments
+           (let ((arguments (package-arguments p)))
+             (if (member #:python arguments)
+                 (substitute-keyword-arguments arguments ((#:python p) python))
+                 (append arguments `(#:python ,python)))))
+          (inputs (map rewrite (package-inputs p)))
+          (propagated-inputs (map rewrite (package-propagated-inputs p)))
+          (native-inputs (map rewrite (package-native-inputs p))))
+        p)))
 
 (define package-with-python2
   (cut package-with-explicit-python <> (default-python2) "python-" "python2-"))
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
diff --git a/guix/packages.scm b/guix/packages.scm
index cf16a4730c..a25eab7699 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -546,40 +547,38 @@ for the host system (\"native inputs\"), and not target inputs."
 recursively."
   (transitive-inputs (package-propagated-inputs package)))
 
-(define-syntax-rule (first-value exp)
-  "Truncate all but the first value returned by EXP."
-  (call-with-values (lambda () exp)
-    (lambda (result . _)
-      result)))
+(define-syntax define-memoized/v
+  (lambda (form)
+    "Define a memoized single-valued unary procedure with docstring.
+The procedure argument is compared to cached keys using `eqv?'."
+    (syntax-case form ()
+      ((_ (proc arg) docstring body body* ...)
+       (string? (syntax->datum #'docstring))
+       #'(define proc
+           (let ((cache (make-hash-table)))
+             (define (proc arg)
+               docstring
+               (match (hashv-get-handle cache arg)
+                 ((_ . value)
+                  value)
+                 (_
+                  (let ((result (let () body body* ...)))
+                    (hashv-set! cache arg result)
+                    result))))
+             proc))))))
 
-(define (package-transitive-supported-systems package)
+(define-memoized/v (package-transitive-supported-systems package)
   "Return the intersection of the systems supported by PACKAGE and those
 supported by its dependencies."
-  (first-value
-   (let loop ((package package)
-              (systems (package-supported-systems package))
-              (visited vlist-null))
-     (match (vhash-assq package visited)
-       ((_ . result)
-        (values (lset-intersection string=? systems result)
-                visited))
-       (#f
-        (call-with-values
-            (lambda ()
-              (fold2 (lambda (input systems visited)
-                       (match input
-                         ((label (? package? package) . _)
-                          (loop package systems visited))
-                         (_
-                          (values systems visited))))
-                     (lset-intersection string=?
-                                        systems
-                                        (package-supported-systems package))
-                     visited
-                     (package-direct-inputs package)))
-          (lambda (systems visited)
-            (values systems
-                    (vhash-consq package systems visited)))))))))
+  (fold (lambda (input systems)
+          (match input
+            ((label (? package? p) . _)
+             (lset-intersection
+              string=? systems (package-transitive-supported-systems p)))
+            (_
+             systems)))
+        (package-supported-systems package)
+        (package-direct-inputs package)))
 
 (define (bag-transitive-inputs bag)
   "Same as 'package-transitive-inputs', but applied to a bag."
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 2742ba8933..44d7a314a3 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -414,7 +414,13 @@ INFO-DIR? is #f."
                                     (return #f))))
     (define inputs
       (if info-dir
-          (cons info-dir (manifest-inputs manifest))
+          ;; XXX: Here we use the tuple (INFO-DIR "out") just so that the list
+          ;; is unambiguous for the gexp code when MANIFEST has a single input
+          ;; denoted as a string (the pattern (DRV STRING) is normally
+          ;; interpreted in a gexp as "the STRING output of DRV".).  See
+          ;; <http://lists.gnu.org/archive/html/guix-devel/2014-12/msg00292.html>.
+          (cons (list info-dir "out")
+                (manifest-inputs manifest))
           (manifest-inputs manifest)))
 
     (define builder