summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/python.scm42
-rw-r--r--guix/build/python-build-system.scm35
-rw-r--r--guix/build/syscalls.scm200
-rw-r--r--guix/packages.scm61
-rw-r--r--guix/profiles.scm8
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
generated by cgit v1.2.3 (git 2.46.2) at 2024-11-10 21:33:05 +0000