aboutsummaryrefslogtreecommitdiff
path: root/guix/build
diff options
context:
space:
mode:
Diffstat (limited to 'guix/build')
-rw-r--r--guix/build/cmake-build-system.scm4
-rw-r--r--guix/build/download.scm92
-rw-r--r--guix/build/glib-or-gtk-build-system.scm10
-rw-r--r--guix/build/gnu-build-system.scm83
-rw-r--r--guix/build/gnu-dist.scm10
-rw-r--r--guix/build/gremlin.scm309
-rw-r--r--guix/build/haskell-build-system.scm214
-rw-r--r--guix/build/perl-build-system.scm8
-rw-r--r--guix/build/profiles.scm148
-rw-r--r--guix/build/python-build-system.scm12
-rw-r--r--guix/build/ruby-build-system.scm10
-rw-r--r--guix/build/syscalls.scm32
-rw-r--r--guix/build/utils.scm81
-rw-r--r--guix/build/waf-build-system.scm8
14 files changed, 913 insertions, 108 deletions
diff --git a/guix/build/cmake-build-system.scm b/guix/build/cmake-build-system.scm
index d8d437c653..f57622e0f4 100644
--- a/guix/build/cmake-build-system.scm
+++ b/guix/build/cmake-build-system.scm
@@ -73,8 +73,8 @@
;; Everything is as with the GNU Build System except for the `configure'
;; and 'check' phases.
(modify-phases gnu:%standard-phases
- (replace check check)
- (replace configure configure)))
+ (replace 'check check)
+ (replace 'configure configure)))
(define* (cmake-build #:key inputs (phases %standard-phases)
#:allow-other-keys #:rest args)
diff --git a/guix/build/download.scm b/guix/build/download.scm
index a3105ad41d..65d18eb839 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -19,7 +19,7 @@
(define-module (guix build download)
#:use-module (web uri)
- #:use-module (web client)
+ #:use-module ((web client) #:hide (open-socket-for-uri))
#:use-module (web response)
#:use-module (guix ftp-client)
#:use-module (guix build utils)
@@ -30,7 +30,8 @@
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
- #:export (open-connection-for-uri
+ #:export (open-socket-for-uri
+ open-connection-for-uri
resolve-uri-reference
maybe-expand-mirrors
url-fetch
@@ -195,47 +196,54 @@ host name without trailing dot."
(add-weak-reference record port)
record)))
+(define (open-socket-for-uri uri)
+ "Return an open port for URI. This variant works around
+<http://bugs.gnu.org/15368> which affects Guile's 'open-socket-for-uri' up to
+2.0.11 included."
+ (define rmem-max
+ ;; The maximum size for a receive buffer on Linux, see socket(7).
+ "/proc/sys/net/core/rmem_max")
+
+ (define buffer-size
+ (if (file-exists? rmem-max)
+ (call-with-input-file rmem-max read)
+ 126976)) ;the default for Linux, per 'rmem_default'
+
+ (let ((s ((@ (web client) open-socket-for-uri) uri)))
+ ;; Work around <http://bugs.gnu.org/15368> by restoring a decent
+ ;; buffer size.
+ (setsockopt s SOL_SOCKET SO_RCVBUF buffer-size)
+ s))
+
(define (open-connection-for-uri uri)
- "Return an open input/output port for a connection to URI.
-
-This is the same as Guile's `open-socket-for-uri', except that we always
-use a numeric port argument, to avoid the need to go through libc's NSS,
-which is not available during bootstrap."
- (define addresses
- (let ((port (or (uri-port uri)
- (case (uri-scheme uri)
- ((http) 80) ; /etc/services, not for me!
- ((https) 443)
- (else
- (error "unsupported URI scheme" uri))))))
- (delete-duplicates (getaddrinfo (uri-host uri)
- (number->string port)
- AI_NUMERICSERV)
- (lambda (ai1 ai2)
- (equal? (addrinfo:addr ai1)
- (addrinfo:addr ai2))))))
-
- (let loop ((addresses addresses))
- (let* ((ai (car addresses))
- (s (with-fluids ((%default-port-encoding #f))
- ;; Restrict ourselves to TCP.
- (socket (addrinfo:fam ai) SOCK_STREAM IPPROTO_IP))))
- (catch 'system-error
- (lambda ()
- (connect s (addrinfo:addr ai))
-
- ;; Buffer input and output on this port.
- (setvbuf s _IOFBF %http-receive-buffer-size)
-
- (if (eq? 'https (uri-scheme uri))
- (tls-wrap s (uri-host uri))
- s))
- (lambda args
- ;; Connection failed, so try one of the other addresses.
- (close s)
- (if (null? (cdr addresses))
- (apply throw args)
- (loop (cdr addresses))))))))
+ "Like 'open-socket-for-uri', but also handle HTTPS connections."
+ (define https?
+ (eq? 'https (uri-scheme uri)))
+
+ (let-syntax ((with-https-proxy
+ (syntax-rules ()
+ ((_ exp)
+ ;; For HTTPS URIs, honor 'https_proxy', not 'http_proxy'.
+ ;; FIXME: Proxying is not supported for https.
+ (let ((thunk (lambda () exp)))
+ (if (and https?
+ (module-variable
+ (resolve-interface '(web client))
+ 'current-http-proxy))
+ (parameterize ((current-http-proxy #f))
+ (when (getenv "https_proxy")
+ (format (current-error-port)
+ "warning: 'https_proxy' is ignored~%"))
+ (thunk))
+ (thunk)))))))
+ (with-https-proxy
+ (let ((s (open-socket-for-uri uri)))
+ ;; Buffer input and output on this port.
+ (setvbuf s _IOFBF %http-receive-buffer-size)
+
+ (if https?
+ (tls-wrap s (uri-host uri))
+ s)))))
;; XXX: This is an awful hack to make sure the (set-port-encoding! p
;; "ISO-8859-1") call in `read-response' passes, even during bootstrap
diff --git a/guix/build/glib-or-gtk-build-system.scm b/guix/build/glib-or-gtk-build-system.scm
index c57bc3e731..15d7de2236 100644
--- a/guix/build/glib-or-gtk-build-system.scm
+++ b/guix/build/glib-or-gtk-build-system.scm
@@ -140,7 +140,9 @@ add a dependency of that output on GLib and GTK+."
((output . directory)
(unless (member output glib-or-gtk-wrap-excluded-outputs)
(let* ((bindir (string-append directory "/bin"))
- (bin-list (find-files bindir ".*"))
+ (libexecdir (string-append directory "/libexec"))
+ (bin-list (append (find-files bindir ".*")
+ (find-files libexecdir ".*")))
(datadirs (data-directories
(alist-cons output directory inputs)))
(gtk-mod-dirs (gtk-module-directories
@@ -240,9 +242,9 @@ needed."
(define %standard-phases
(modify-phases gnu:%standard-phases
- (add-after install glib-or-gtk-compile-schemas compile-glib-schemas)
- (add-after install glib-or-gtk-icon-cache generate-icon-cache)
- (add-after install glib-or-gtk-wrap wrap-all-programs)))
+ (add-after 'install 'glib-or-gtk-compile-schemas compile-glib-schemas)
+ (add-after 'install 'glib-or-gtk-icon-cache generate-icon-cache)
+ (add-after 'install 'glib-or-gtk-wrap wrap-all-programs)))
(define* (glib-or-gtk-build #:key inputs (phases %standard-phases)
#:allow-other-keys #:rest args)
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 5ae537150f..5062479360 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -18,12 +18,15 @@
(define-module (guix build gnu-build-system)
#:use-module (guix build utils)
+ #:use-module (guix build gremlin)
+ #:use-module (guix elf)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
+ #:use-module (rnrs io ports)
#:export (%standard-phases
gnu-build))
@@ -161,7 +164,10 @@ files such as `.in' templates. Most scripts honor $SHELL and
$CONFIG_SHELL, but some don't, such as `mkinstalldirs' or Automake's
`missing' script."
(for-each patch-shebang
- (remove file-is-directory? (find-files "." ".*"))))
+ (remove (lambda (file)
+ (or (not (file-exists? file)) ;dangling symlink
+ (file-is-directory? file)))
+ (find-files "."))))
(define (patch-generated-file-shebangs . rest)
"Patch shebangs in generated files, including `SHELL' variables in
@@ -170,9 +176,10 @@ makefiles."
;; `configure'.
(for-each patch-shebang
(filter (lambda (file)
- (and (executable-file? file)
+ (and (file-exists? file)
+ (executable-file? file)
(not (file-is-directory? file))))
- (find-files "." ".*")))
+ (find-files ".")))
;; Patch `SHELL' in generated makefiles.
(for-each patch-makefile-SHELL (find-files "." "^(GNU)?[mM]akefile$")))
@@ -398,6 +405,64 @@ makefiles."
strip-directories)))
outputs))))
+(define (every* pred lst)
+ "This is like 'every', but process all the elements of LST instead of
+stopping as soon as PRED returns false. This is useful when PRED has side
+effects, such as displaying warnings or error messages."
+ (let loop ((lst lst)
+ (result #t))
+ (match lst
+ (()
+ result)
+ ((head . tail)
+ (loop tail (and (pred head) result))))))
+
+(define* (validate-runpath #:key
+ (validate-runpath? #t)
+ (elf-directories '("lib" "lib64" "libexec"
+ "bin" "sbin"))
+ outputs #:allow-other-keys)
+ "When VALIDATE-RUNPATH? is true, validate that all the ELF files in
+ELF-DIRECTORIES have their dependencies found in their 'RUNPATH'.
+
+Since the ELF parser needs to have a copy of files in memory, better run this
+phase after stripping."
+ (define (sub-directory parent)
+ (lambda (directory)
+ (let ((directory (string-append parent "/" directory)))
+ (and (directory-exists? directory) directory))))
+
+ (define (validate directory)
+ (define (file=? file1 file2)
+ (let ((st1 (stat file1))
+ (st2 (stat file2)))
+ (= (stat:ino st1) (stat:ino st2))))
+
+ ;; There are always symlinks from '.so' to '.so.1' and so on, so delete
+ ;; duplicates.
+ (let ((files (delete-duplicates (find-files directory (lambda (file stat)
+ (elf-file? file)))
+ file=?)))
+ (format (current-error-port)
+ "validating RUNPATH of ~a binaries in ~s...~%"
+ (length files) directory)
+ (every* validate-needed-in-runpath files)))
+
+ (if validate-runpath?
+ (let ((dirs (append-map (match-lambda
+ (("debug" . _)
+ ;; The "debug" output is full of ELF files
+ ;; that are not worth checking.
+ '())
+ ((name . output)
+ (filter-map (sub-directory output)
+ elf-directories)))
+ outputs)))
+ (every* validate dirs))
+ (begin
+ (format (current-error-port) "skipping RUNPATH validation~%")
+ #t)))
+
(define* (validate-documentation-location #:key outputs
#:allow-other-keys)
"Documentation should go to 'share/info' and 'share/man', not just 'info/'
@@ -477,6 +542,16 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
(format #t "not compressing documentation~%")
#t)))
+(define* (delete-info-dir-file #:key outputs #:allow-other-keys)
+ "Delete any 'share/info/dir' file from OUTPUTS."
+ (for-each (match-lambda
+ ((output . directory)
+ (let ((info-dir-file (string-append directory "/share/info/dir")))
+ (when (file-exists? info-dir-file)
+ (delete-file info-dir-file)))))
+ outputs)
+ #t)
+
(define %standard-phases
;; Standard build phases, as a list of symbol/procedure pairs.
(let-syntax ((phases (syntax-rules ()
@@ -486,7 +561,9 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
patch-source-shebangs configure patch-generated-file-shebangs
build check install
patch-shebangs strip
+ validate-runpath
validate-documentation-location
+ delete-info-dir-file
compress-documentation)))
diff --git a/guix/build/gnu-dist.scm b/guix/build/gnu-dist.scm
index 887b5e94e9..ad69c6cf16 100644
--- a/guix/build/gnu-dist.scm
+++ b/guix/build/gnu-dist.scm
@@ -83,10 +83,10 @@
(define %dist-phases
;; Phases for building a source tarball.
(modify-phases %standard-phases
- (delete strip)
- (replace install install-dist)
- (replace build build)
- (add-before configure autoreconf autoreconf)
- (replace unpack copy-source)))
+ (delete 'strip)
+ (replace 'install install-dist)
+ (replace 'build build)
+ (add-before 'configure 'autoreconf autoreconf)
+ (replace 'unpack copy-source)))
;;; gnu-dist.scm ends here
diff --git a/guix/build/gremlin.scm b/guix/build/gremlin.scm
new file mode 100644
index 0000000000..fed529b193
--- /dev/null
+++ b/guix/build/gremlin.scm
@@ -0,0 +1,309 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build gremlin)
+ #:use-module (guix elf)
+ #:use-module ((guix build utils) #:select (store-file-name?))
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (system foreign)
+ #:use-module (rnrs bytevectors)
+ #:use-module (rnrs io ports)
+ #:export (elf-error?
+ elf-error-elf
+ invalid-segment-size?
+ invalid-segment-size-segment
+
+ elf-dynamic-info
+ elf-dynamic-info?
+ elf-dynamic-info-sopath
+ elf-dynamic-info-needed
+ elf-dynamic-info-rpath
+ elf-dynamic-info-runpath
+ expand-origin
+
+ validate-needed-in-runpath))
+
+;;; Commentary:
+;;;
+;;; A gremlin is sort-of like an elf, you know, and this module provides tools
+;;; to deal with dynamic-link information from ELF files.
+;;;
+;;; Code:
+
+(define-condition-type &elf-error &error
+ elf-error?
+ (elf elf-error-elf))
+
+(define-condition-type &invalid-segment-size &elf-error
+ invalid-segment-size?
+ (segment invalid-segment-size-segment))
+
+
+(define (dynamic-link-segment elf)
+ "Return the 'PT_DYNAMIC' segment of ELF--i.e., the segment that contains
+dynamic linking information."
+ (let ((size (bytevector-length (elf-bytes elf))))
+ (find (lambda (segment)
+ (unless (<= (+ (elf-segment-offset segment)
+ (elf-segment-filesz segment))
+ size)
+ ;; This happens on separate debug output files created by
+ ;; 'strip --only-keep-debug' (Binutils 2.25.)
+ (raise (condition (&invalid-segment-size
+ (elf elf)
+ (segment segment)))))
+
+ (= (elf-segment-type segment) PT_DYNAMIC))
+ (elf-segments elf))))
+
+(define (word-reader size byte-order)
+ "Return a procedure to read a word of SIZE bytes according to BYTE-ORDER."
+ (case size
+ ((8)
+ (lambda (bv index)
+ (bytevector-u64-ref bv index byte-order)))
+ ((4)
+ (lambda (bv index)
+ (bytevector-u32-ref bv index byte-order)))))
+
+
+;; Dynamic entry:
+;;
+;; typedef struct
+;; {
+;; Elf64_Sxword d_tag; /* Dynamic entry type */
+;; union
+;; {
+;; Elf64_Xword d_val; /* Integer value */
+;; Elf64_Addr d_ptr; /* Address value */
+;; } d_un;
+;; } Elf64_Dyn;
+
+(define (raw-dynamic-entries elf segment)
+ "Return as a list of type/value pairs all the dynamic entries found in
+SEGMENT, the 'PT_DYNAMIC' segment of ELF. In the result, each car is a DT_
+value, and the interpretation of the cdr depends on the type."
+ (define start
+ (elf-segment-offset segment))
+ (define bytes
+ (elf-bytes elf))
+ (define word-size
+ (elf-word-size elf))
+ (define byte-order
+ (elf-byte-order elf))
+ (define read-word
+ (word-reader word-size byte-order))
+
+ (let loop ((offset 0)
+ (result '()))
+ (if (>= offset (elf-segment-memsz segment))
+ (reverse result)
+ (let ((type (read-word bytes (+ start offset)))
+ (value (read-word bytes (+ start offset word-size))))
+ (if (= type DT_NULL) ;finished?
+ (reverse result)
+ (loop (+ offset (* 2 word-size))
+ (alist-cons type value result)))))))
+
+(define (vma->offset elf vma)
+ "Convert VMA, a virtual memory address, to an offset within ELF.
+
+Do that by looking at the loadable program segment (PT_LOAD) of ELF that
+contains VMA and by taking into account that segment's virtual address and
+offset."
+ ;; See 'offset_from_vma' in Binutils.
+ (define loads
+ (filter (lambda (segment)
+ (= (elf-segment-type segment) PT_LOAD))
+ (elf-segments elf)))
+
+ (let ((load (find (lambda (segment)
+ (let ((vaddr (elf-segment-vaddr segment)))
+ (and (>= vma vaddr)
+ (< vma (+ (elf-segment-memsz segment)
+ vaddr)))))
+ loads)))
+ (+ (- vma (elf-segment-vaddr load))
+ (elf-segment-offset load))))
+
+(define (dynamic-entries elf segment)
+ "Return all the dynamic entries found in SEGMENT, the 'PT_DYNAMIC' segment
+of ELF, as a list of type/value pairs. The type is a DT_ value, and the value
+may be a string or an integer depending on the entry type (for instance, the
+value of DT_NEEDED entries is a string.)"
+ (define entries
+ (raw-dynamic-entries elf segment))
+
+ (define string-table-offset
+ (any (match-lambda
+ ((type . value)
+ (and (= type DT_STRTAB) value))
+ (_ #f))
+ entries))
+
+ (define (interpret-dynamic-entry type value)
+ (cond ((memv type (list DT_NEEDED DT_SONAME DT_RPATH DT_RUNPATH))
+ (if string-table-offset
+ (pointer->string
+ (bytevector->pointer (elf-bytes elf)
+ (vma->offset
+ elf
+ (+ string-table-offset value))))
+ value))
+ (else
+ value)))
+
+ (map (match-lambda
+ ((type . value)
+ (cons type (interpret-dynamic-entry type value))))
+ entries))
+
+
+;;;
+;;; High-level interface.
+;;;
+
+(define-record-type <elf-dynamic-info>
+ (%elf-dynamic-info soname needed rpath runpath)
+ elf-dynamic-info?
+ (soname elf-dynamic-info-soname)
+ (needed elf-dynamic-info-needed)
+ (rpath elf-dynamic-info-rpath)
+ (runpath elf-dynamic-info-runpath))
+
+(define search-path->list
+ (let ((not-colon (char-set-complement (char-set #\:))))
+ (lambda (str)
+ "Split STR on ':' characters."
+ (string-tokenize str not-colon))))
+
+(define (elf-dynamic-info elf)
+ "Return dynamic-link information for ELF as an <elf-dynamic-info> object, or
+#f if ELF lacks dynamic-link information."
+ (match (dynamic-link-segment elf)
+ (#f #f)
+ ((? elf-segment? dynamic)
+ (let ((entries (dynamic-entries elf dynamic)))
+ (%elf-dynamic-info (assv-ref entries DT_SONAME)
+ (filter-map (match-lambda
+ ((type . value)
+ (and (= type DT_NEEDED) value))
+ (_ #f))
+ entries)
+ (or (and=> (assv-ref entries DT_RPATH)
+ search-path->list)
+ '())
+ (or (and=> (assv-ref entries DT_RUNPATH)
+ search-path->list)
+ '()))))))
+
+(define %libc-libraries
+ ;; List of libraries as of glibc 2.21 (there are more but those are
+ ;; typically mean to be LD_PRELOADed and thus do not appear as NEEDED.)
+ '("libanl.so"
+ "libcrypt.so"
+ "libc.so"
+ "libdl.so"
+ "libm.so"
+ "libnsl.so" ;NEEDED by nscd
+ "libpthread.so"
+ "libresolv.so"
+ "librt.so"
+ "libutil.so"))
+
+(define (libc-library? lib)
+ "Return #t if LIB is one of the libraries shipped with the GNU C Library."
+ (find (lambda (libc-lib)
+ (string-prefix? libc-lib lib))
+ %libc-libraries))
+
+(define (expand-variable str variable value)
+ "Replace occurrences of '$VARIABLE' or '${VARIABLE}' in STR with VALUE."
+ (define variables
+ (list (string-append "$" variable)
+ (string-append "${" variable "}")))
+
+ (let loop ((thing variables)
+ (str str))
+ (match thing
+ (()
+ str)
+ ((head tail ...)
+ (let ((index (string-contains str head))
+ (len (string-length head)))
+ (loop (if index variables tail)
+ (if index
+ (string-replace str value
+ index (+ index len))
+ str)))))))
+
+(define (expand-origin str directory)
+ "Replace occurrences of '$ORIGIN' in STR with DIRECTORY."
+ (expand-variable str "ORIGIN" directory))
+
+(define* (validate-needed-in-runpath file
+ #:key (always-found? libc-library?))
+ "Return #t if all the libraries listed as FILE's 'DT_NEEDED' entries are
+present in its RUNPATH, or if FILE lacks dynamic-link information. Return #f
+otherwise. Libraries whose name matches ALWAYS-FOUND? are considered to be
+always available."
+ (guard (c ((invalid-segment-size? c)
+ (let ((segment (invalid-segment-size-segment c)))
+ (format (current-error-port)
+ "~a: error: offset + size of segment ~a (type ~a) \
+exceeds total size~%"
+ file
+ (elf-segment-index segment)
+ (elf-segment-type segment))
+ #f)))
+
+ (let* ((elf (call-with-input-file file
+ (compose parse-elf get-bytevector-all)))
+ (expand (cute expand-origin <> (dirname file)))
+ (dyninfo (elf-dynamic-info elf)))
+ (when dyninfo
+ ;; XXX: In theory we should also expand $PLATFORM and $LIB, but these
+ ;; appear to be really unused.
+ (let* ((expanded (map expand (elf-dynamic-info-runpath dyninfo)))
+ (runpath (filter store-file-name? expanded))
+ (bogus (remove store-file-name? expanded))
+ (needed (remove always-found?
+ (elf-dynamic-info-needed dyninfo)))
+ (not-found (remove (cut search-path runpath <>)
+ needed)))
+ (unless (null? bogus)
+ (format (current-error-port)
+ "~a: warning: RUNPATH contains bogus entries: ~s~%"
+ file bogus))
+
+ (for-each (lambda (lib)
+ (format (current-error-port)
+ "~a: error: depends on '~a', which cannot \
+be found in RUNPATH ~s~%"
+ file lib runpath))
+ not-found)
+ ;; (when (null? not-found)
+ ;; (format (current-error-port) "~a is OK~%" file))
+ (null? not-found))))))
+
+;;; gremlin.scm ends here
diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm
new file mode 100644
index 0000000000..d382ee403d
--- /dev/null
+++ b/guix/build/haskell-build-system.scm
@@ -0,0 +1,214 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build haskell-build-system)
+ #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+ #:use-module (guix build utils)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 match)
+ #:export (%standard-phases
+ haskell-build))
+
+;; Commentary:
+;;
+;; Builder-side code of the standard Haskell package build procedure.
+;;
+;; The Haskell compiler, to find libraries, relies on a library database with
+;; a binary cache. For GHC the cache has to be named 'package.cache'. If every
+;; library would generate the cache at build time, then they would clash in
+;; profiles. For this reason we do not generate the cache when we generate
+;; libraries substitutes. Instead:
+;;
+;; - At build time we use the 'setup-compiler' phase to generate a temporary
+;; library database and its cache.
+;;
+;; - We generate the cache when a profile is created.
+;;
+;; Code:
+
+;; Directory where we create the temporary libraries database with its cache
+;; as required by the compiler.
+(define %tmp-db-dir
+ (string-append (or (getenv "TMP") "/tmp")
+ "/package.conf.d"))
+
+(define (run-setuphs command params)
+ (let ((setup-file (cond
+ ((file-exists? "Setup.hs")
+ "Setup.hs")
+ ((file-exists? "Setup.lhs")
+ "Setup.lhs")
+ (else
+ #f))))
+ (if setup-file
+ (begin
+ (format #t "running \"runhaskell Setup.hs\" with command ~s \
+and parameters ~s~%"
+ command params)
+ (zero? (apply system* "runhaskell" setup-file command params)))
+ (error "no Setup.hs nor Setup.lhs found"))))
+
+(define* (configure #:key outputs inputs tests? (configure-flags '())
+ #:allow-other-keys)
+ "Configure a given Haskell package."
+ (let* ((out (assoc-ref outputs "out"))
+ (doc (assoc-ref outputs "doc"))
+ (lib (assoc-ref outputs "lib"))
+ (bin (assoc-ref outputs "bin"))
+ (input-dirs (match inputs
+ (((_ . dir) ...)
+ dir)
+ (_ '())))
+ (params (append `(,(string-append "--prefix=" out))
+ `(,(string-append "--libdir=" (or lib out) "/lib"))
+ `(,(string-append "--bindir=" (or bin out) "/bin"))
+ `(,(string-append
+ "--docdir=" (or doc out)
+ "/share/doc/" (package-name-version out)))
+ '("--libsubdir=$compiler/$pkg-$version")
+ `(,(string-append "--package-db=" %tmp-db-dir))
+ '("--global")
+ `(,@(map
+ (cut string-append "--extra-include-dirs=" <>)
+ (search-path-as-list '("include") input-dirs)))
+ `(,@(map
+ (cut string-append "--extra-lib-dirs=" <>)
+ (search-path-as-list '("lib") input-dirs)))
+ (if tests?
+ '("--enable-tests")
+ '())
+ configure-flags)))
+ (run-setuphs "configure" params)))
+
+(define* (build #:rest empty)
+ "Build a given Haskell package."
+ (run-setuphs "build" '()))
+
+(define* (install #:rest empty)
+ "Install a given Haskell package."
+ (run-setuphs "copy" '()))
+
+(define (package-name-version store-dir)
+ "Given a store directory STORE-DIR return 'name-version' of the package."
+ (let* ((base (basename store-dir)))
+ (string-drop base
+ (+ 1 (string-index base #\-)))))
+
+(define (grep rx port)
+ "Given a regular-expression RX including a group, read from PORT until the
+first match and return the content of the group."
+ (let ((line (read-line port)))
+ (if (eof-object? line)
+ #f
+ (let ((rx-result (regexp-exec rx line)))
+ (if rx-result
+ (match:substring rx-result 1)
+ (grep rx port))))))
+
+(define* (setup-compiler #:key system inputs outputs #:allow-other-keys)
+ "Setup the compiler environment."
+ (let* ((haskell (assoc-ref inputs "haskell"))
+ (name-version (package-name-version haskell)))
+ (cond
+ ((string-match "ghc" name-version)
+ (make-ghc-package-database system inputs outputs))
+ (else
+ (format #t
+ "Compiler ~a not supported~%" name-version)))))
+
+(define (make-ghc-package-database system inputs outputs)
+ "Generate the GHC package database."
+ (let* ((haskell (assoc-ref inputs "haskell"))
+ (input-dirs (match inputs
+ (((_ . dir) ...)
+ dir)
+ (_ '())))
+ (conf-dirs (search-path-as-list
+ `(,(string-append "lib/"
+ (package-name-version haskell)
+ "/package.conf.d"))
+ input-dirs))
+ (conf-files (append-map (cut find-files <> "\\.conf$") conf-dirs)))
+ (mkdir-p %tmp-db-dir)
+ (for-each (lambda (file)
+ (copy-file file
+ (string-append %tmp-db-dir "/" (basename file))))
+ conf-files)
+ (zero? (system* "ghc-pkg"
+ (string-append "--package-db=" %tmp-db-dir)
+ "recache"))))
+
+(define* (register #:key name system inputs outputs #:allow-other-keys)
+ "Generate the compiler registration file for a given Haskell package. Don't
+generate the cache as it would clash in user profiles."
+ (let* ((out (assoc-ref outputs "out"))
+ (haskell (assoc-ref inputs "haskell"))
+ (lib (string-append out "/lib"))
+ (config-dir (string-append lib "/"
+ (package-name-version haskell)
+ "/package.conf.d"))
+ (id-rx (make-regexp "^id: *(.*)$"))
+ (lib-rx (make-regexp "lib.*\\.(a|so)"))
+ (config-file (string-append config-dir "/" name ".conf"))
+ (params
+ (list (string-append "--gen-pkg-config=" config-file))))
+ (unless (null? (find-files lib lib-rx))
+ (mkdir-p config-dir)
+ (run-setuphs "register" params)
+ (let ((config-file-name+id
+ (call-with-ascii-input-file config-file (cut grep id-rx <>))))
+ (rename-file config-file
+ (string-append config-dir "/" config-file-name+id
+ ".conf"))))
+ #t))
+
+(define* (check #:key tests? test-target #:allow-other-keys)
+ "Run the test suite of a given Haskell package."
+ (if tests?
+ (run-setuphs test-target '())
+ (begin
+ (format #t "test suite not run~%")
+ #t)))
+
+(define* (haddock #:key outputs haddock? haddock-flags #:allow-other-keys)
+ "Run the test suite of a given Haskell package."
+ (if haddock?
+ (run-setuphs "haddock" haddock-flags)
+ #t))
+
+(define %standard-phases
+ (modify-phases gnu:%standard-phases
+ (add-before 'configure 'setup-compiler setup-compiler)
+ (add-before 'install 'haddock haddock)
+ (add-after 'install 'register register)
+ (replace 'install install)
+ (replace 'check check)
+ (replace 'build build)
+ (replace 'configure configure)))
+
+(define* (haskell-build #:key inputs (phases %standard-phases)
+ #:allow-other-keys #:rest args)
+ "Build the given Haskell package, applying all of PHASES in order."
+ (apply gnu:gnu-build
+ #:inputs inputs #:phases phases
+ args))
+
+;;; haskell-build-system.scm ends here
diff --git a/guix/build/perl-build-system.scm b/guix/build/perl-build-system.scm
index 9ca5353bb9..8f480eae16 100644
--- a/guix/build/perl-build-system.scm
+++ b/guix/build/perl-build-system.scm
@@ -72,10 +72,10 @@
;; Everything is as with the GNU Build System except for the `configure',
;; `build', `check', and `install' phases.
(modify-phases gnu:%standard-phases
- (replace install install)
- (replace check check)
- (replace build build)
- (replace configure configure)))
+ (replace 'install install)
+ (replace 'check check)
+ (replace 'build build)
+ (replace 'configure configure)))
(define* (perl-build #:key inputs (phases %standard-phases)
#:allow-other-keys #:rest args)
diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm
new file mode 100644
index 0000000000..2becc6b9af
--- /dev/null
+++ b/guix/build/profiles.scm
@@ -0,0 +1,148 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build profiles)
+ #:use-module (guix build union)
+ #:use-module (guix build utils)
+ #:use-module (guix search-paths)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 ftw)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 pretty-print)
+ #:export (build-profile))
+
+;;; Commentary:
+;;;
+;;; Build a user profile (essentially the union of all the installed packages)
+;;; with its associated meta-data.
+;;;
+;;; Code:
+
+(define (abstract-profile profile)
+ "Return a procedure that replaces PROFILE in VALUE with a reference to the
+'GUIX_PROFILE' environment variable. This allows users to specify what the
+user-friendly name of the profile is, for instance ~/.guix-profile rather than
+/gnu/store/...-profile."
+ (let ((replacement (string-append "${GUIX_PROFILE:-" profile "}")))
+ (match-lambda
+ ((search-path . value)
+ (let* ((separator (search-path-specification-separator search-path))
+ (items (string-tokenize* value separator))
+ (crop (cute string-drop <> (string-length profile))))
+ (cons search-path
+ (string-join (map (lambda (str)
+ (string-append replacement (crop str)))
+ items)
+ separator)))))))
+
+(define (write-environment-variable-definition port)
+ "Write the given environment variable definition to PORT."
+ (match-lambda
+ ((search-path . value)
+ (display (search-path-definition search-path value #:kind 'prefix)
+ port)
+ (newline port))))
+
+(define (build-etc/profile output search-paths)
+ "Build the 'OUTPUT/etc/profile' shell file containing environment variable
+definitions for all the SEARCH-PATHS."
+ (mkdir-p (string-append output "/etc"))
+ (call-with-output-file (string-append output "/etc/profile")
+ (lambda (port)
+ ;; The use of $GUIX_PROFILE described below is not great. Another
+ ;; option would have been to use "$1" and have users run:
+ ;;
+ ;; source ~/.guix-profile/etc/profile ~/.guix-profile
+ ;;
+ ;; However, when 'source' is used with no arguments, $1 refers to the
+ ;; first positional parameter of the calling scripts, so we can rely on
+ ;; it.
+ (display "\
+# Source this file to define all the relevant environment variables in Bash
+# for this profile. You may want to define the 'GUIX_PROFILE' environment
+# variable to point to the \"visible\" name of the profile, like this:
+#
+# GUIX_PROFILE=/path/to/profile
+# source /path/to/profile/etc/profile
+#
+# When GUIX_PROFILE is undefined, the various environment variables refer
+# to this specific profile generation.
+\n" port)
+ (let ((variables (evaluate-search-paths (cons $PATH search-paths)
+ (list output))))
+ (for-each (write-environment-variable-definition port)
+ (map (abstract-profile output) variables))))))
+
+(define (ensure-writable-directory directory)
+ "Ensure DIRECTORY exists and is writable. If DIRECTORY is currently a
+symlink (to a read-only directory in the store), then delete the symlink and
+instead make DIRECTORY a \"real\" directory containing symlinks."
+ (define (unsymlink link)
+ (let* ((target (readlink link))
+ ;; TARGET might itself be a symlink, so append "/" to make sure
+ ;; 'scandir' enters it.
+ (files (scandir (string-append target "/")
+ (negate (cut member <> '("." ".."))))))
+ (delete-file link)
+ (mkdir link)
+ (for-each (lambda (file)
+ (symlink (string-append target "/" file)
+ (string-append link "/" file)))
+ files)))
+
+ (catch 'system-error
+ (lambda ()
+ (mkdir directory))
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (if (= errno EEXIST)
+ (let ((stat (lstat directory)))
+ (case (stat:type stat)
+ ((symlink)
+ ;; "Unsymlink" DIRECTORY so that it is writable.
+ (unsymlink directory))
+ ((directory)
+ #t)
+ (else
+ (error "cannot mkdir because a same-named file exists"
+ directory))))
+ (apply throw args))))))
+
+(define* (build-profile output inputs
+ #:key manifest search-paths)
+ "Build a user profile from INPUTS in directory OUTPUT. Write MANIFEST, an
+sexp, to OUTPUT/manifest. Create OUTPUT/etc/profile with Bash definitions for
+-all the variables listed in SEARCH-PATHS."
+ ;; Make the symlinks.
+ (union-build output inputs
+ #:log-port (%make-void-port "w"))
+
+ ;; Store meta-data.
+ (call-with-output-file (string-append output "/manifest")
+ (lambda (p)
+ (pretty-print manifest p)))
+
+ ;; Make sure we can write to 'OUTPUT/etc'. 'union-build' above could have
+ ;; made 'etc' a symlink to a read-only sub-directory in the store so we need
+ ;; to work around that.
+ (ensure-writable-directory (string-append output "/etc"))
+
+ ;; Write 'OUTPUT/etc/profile'.
+ (build-etc/profile output search-paths))
+
+;;; profile.scm ends here
diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm
index 9f853134bd..26a7254db9 100644
--- a/guix/build/python-build-system.scm
+++ b/guix/build/python-build-system.scm
@@ -123,12 +123,12 @@ installed with setuptools."
;; 'configure' and 'build' phases are not needed. Everything is done during
;; 'install'.
(modify-phases gnu:%standard-phases
- (delete configure)
- (replace install install)
- (replace check check)
- (replace build build)
- (add-after install wrap wrap)
- (add-before strip rename-pth-file rename-pth-file)))
+ (delete 'configure)
+ (replace 'install install)
+ (replace 'check check)
+ (replace 'build build)
+ (add-after 'install 'wrap wrap)
+ (add-before 'strip 'rename-pth-file rename-pth-file)))
(define* (python-build #:key inputs (phases %standard-phases)
#:allow-other-keys #:rest args)
diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm
index a143df467f..531cf382ae 100644
--- a/guix/build/ruby-build-system.scm
+++ b/guix/build/ruby-build-system.scm
@@ -72,11 +72,11 @@ directory."
(define %standard-phases
(modify-phases gnu:%standard-phases
- (delete configure)
- (add-after unpack gitify gitify)
- (replace build build)
- (replace install install)
- (replace check check)))
+ (delete 'configure)
+ (add-after 'unpack 'gitify gitify)
+ (replace 'build build)
+ (replace 'install install)
+ (replace 'check check)))
(define* (ruby-build #:key inputs (phases %standard-phases)
#:allow-other-keys #:rest args)
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index b62a8cce64..3585bf27a8 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -29,6 +29,7 @@
MS_REMOUNT
MS_BIND
MS_MOVE
+ restart-on-EINTR
mount
umount
mount-points
@@ -46,6 +47,7 @@
network-interface-address
set-network-interface-flags
set-network-interface-address
+ set-network-interface-up
configure-network-interface))
;;; Commentary:
@@ -88,6 +90,19 @@
(ref bv))))
(lambda () 0)))
+(define (call-with-restart-on-EINTR thunk)
+ (let loop ()
+ (catch 'system-error
+ thunk
+ (lambda args
+ (if (= (system-error-errno args) EINTR)
+ (loop)
+ (apply throw args))))))
+
+(define-syntax-rule (restart-on-EINTR expr)
+ "Evaluate EXPR and restart upon EINTR. Return the value of EXPR."
+ (call-with-restart-on-EINTR (lambda () expr)))
+
(define (augment-mtab source target type options)
"Augment /etc/mtab with information about the given mount point."
(let ((port (open-file "/etc/mtab" "a")))
@@ -203,7 +218,7 @@ constants from <sys/mount.h>."
(let ((ret (proc (string->pointer device)))
(err (errno)))
(unless (zero? ret)
- (throw 'system-error "swapff" "~S: ~A"
+ (throw 'system-error "swapoff" "~S: ~A"
(list device (strerror err))
(list err)))))))
@@ -552,4 +567,17 @@ the same type as that returned by 'make-socket-address'."
(lambda ()
(close-port sock)))))
+(define* (set-network-interface-up name
+ #:key (family AF_INET))
+ "Turn up the interface NAME."
+ (let ((sock (socket family SOCK_STREAM 0)))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (let ((flags (network-interface-flags sock name)))
+ (set-network-interface-flags sock name
+ (logior flags IFF_UP))))
+ (lambda ()
+ (close-port sock)))))
+
;;; syscalls.scm ends here
diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index a5a6167a8c..676a0120e3 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -32,6 +32,7 @@
#:re-export (alist-cons
alist-delete)
#:export (%store-directory
+ store-file-name?
parallel-job-count
directory-exists?
@@ -44,6 +45,7 @@
mkdir-p
copy-recursively
delete-file-recursively
+ file-name-predicate
find-files
search-path-as-list
@@ -80,6 +82,10 @@
(or (getenv "NIX_STORE")
"/gnu/store"))
+(define (store-file-name? file)
+ "Return true if FILE is in the store."
+ (string-prefix? (%store-directory) file))
+
(define parallel-job-count
;; Number of processes to be passed next to GNU Make's `-j' argument.
(make-parameter
@@ -263,33 +269,46 @@ errors."
;; Don't follow symlinks.
lstat)))
-(define (find-files dir regexp)
- "Return the lexicographically sorted list of files under DIR whose basename
-matches REGEXP."
- (define file-rx
- (if (regexp? regexp)
- regexp
- (make-regexp regexp)))
-
- ;; Sort the result to get deterministic results.
- (sort (file-system-fold (const #t)
- (lambda (file stat result) ; leaf
- (if (regexp-exec file-rx (basename file))
- (cons file result)
- result))
- (lambda (dir stat result) ; down
- result)
- (lambda (dir stat result) ; up
- result)
- (lambda (file stat result) ; skip
- result)
- (lambda (file stat errno result)
- (format (current-error-port) "find-files: ~a: ~a~%"
- file (strerror errno))
- result)
- '()
- dir)
- string<?))
+(define (file-name-predicate regexp)
+ "Return a predicate that returns true when passed a file name whose base
+name matches REGEXP."
+ (let ((file-rx (if (regexp? regexp)
+ regexp
+ (make-regexp regexp))))
+ (lambda (file stat)
+ (regexp-exec file-rx (basename file)))))
+
+(define* (find-files dir #:optional (pred (const #t))
+ #:key (stat lstat))
+ "Return the lexicographically sorted list of files under DIR for which PRED
+returns true. PRED is passed two arguments: the absolute file name, and its
+stat buffer; the default predicate always returns true. PRED can also be a
+regular expression, in which case it is equivalent to (file-name-predicate
+PRED). STAT is used to obtain file information; using 'lstat' means that
+symlinks are not followed."
+ (let ((pred (if (procedure? pred)
+ pred
+ (file-name-predicate pred))))
+ ;; Sort the result to get deterministic results.
+ (sort (file-system-fold (const #t)
+ (lambda (file stat result) ; leaf
+ (if (pred file stat)
+ (cons file result)
+ result))
+ (lambda (dir stat result) ; down
+ result)
+ (lambda (dir stat result) ; up
+ result)
+ (lambda (file stat result) ; skip
+ result)
+ (lambda (file stat errno result)
+ (format (current-error-port) "find-files: ~a: ~a~%"
+ file (strerror errno))
+ result)
+ '()
+ dir
+ stat)
+ string<?)))
;;;
@@ -446,13 +465,13 @@ an expression evaluating to a procedure."
(define-syntax %modify-phases
(syntax-rules (delete replace add-before add-after)
((_ phases (delete old-phase-name))
- (alist-delete 'old-phase-name phases))
+ (alist-delete old-phase-name phases))
((_ phases (replace old-phase-name new-phase))
- (alist-replace 'old-phase-name new-phase phases))
+ (alist-replace old-phase-name new-phase phases))
((_ phases (add-before old-phase-name new-phase-name new-phase))
- (alist-cons-before 'old-phase-name 'new-phase-name new-phase phases))
+ (alist-cons-before old-phase-name new-phase-name new-phase phases))
((_ phases (add-after old-phase-name new-phase-name new-phase))
- (alist-cons-after 'old-phase-name 'new-phase-name new-phase phases))))
+ (alist-cons-after old-phase-name new-phase-name new-phase phases))))
;;;
diff --git a/guix/build/waf-build-system.scm b/guix/build/waf-build-system.scm
index d172c5a836..85f0abcfd6 100644
--- a/guix/build/waf-build-system.scm
+++ b/guix/build/waf-build-system.scm
@@ -70,10 +70,10 @@
(define %standard-phases
(modify-phases gnu:%standard-phases
- (replace configure configure)
- (replace build build)
- (replace check check)
- (replace install install)))
+ (replace 'configure configure)
+ (replace 'build build)
+ (replace 'check check)
+ (replace 'install install)))
(define* (waf-build #:key inputs (phases %standard-phases)
#:allow-other-keys #:rest args)
generated by cgit v1.2.3 (git 2.49.0) at 2025-08-12 03:58:52 +0000