summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2017-02-13 22:35:05 +0100
committerMarius Bakke <mbakke@fastmail.com>2017-02-13 22:35:05 +0100
commit424b1ae76901c538457bd3c30d9d9cf67e79855f (patch)
treeacc35c1160625618cd6083e728c6a4ff7e9cccc9 /guix
parenta50e03014177d2f00b5b85d3e1c295406f842016 (diff)
parenteae2dbd47ac1f4a201b8584e2f88c30cd28e093a (diff)
Merge branch 'master' into python-tests
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/dub.scm147
-rw-r--r--guix/build-system/gnu.scm51
-rw-r--r--guix/build-system/python.scm89
-rw-r--r--guix/build/bournish.scm11
-rw-r--r--guix/build/dub-build-system.scm125
-rw-r--r--guix/build/r-build-system.scm3
-rw-r--r--guix/build/syscalls.scm137
-rw-r--r--guix/combinators.scm18
-rw-r--r--guix/derivations.scm89
-rw-r--r--guix/download.scm43
-rw-r--r--guix/git-download.scm43
-rw-r--r--guix/gnu-maintenance.scm111
-rw-r--r--guix/grafts.scm58
-rw-r--r--guix/http-client.scm26
-rw-r--r--guix/import/cran.scm4
-rw-r--r--guix/import/elpa.scm3
-rw-r--r--guix/import/github.scm25
-rw-r--r--guix/import/hackage.scm24
-rw-r--r--guix/import/json.scm3
-rw-r--r--guix/import/pypi.scm19
-rw-r--r--guix/import/stackage.scm135
-rw-r--r--guix/licenses.scm10
-rw-r--r--guix/memoization.scm114
-rw-r--r--guix/modules.scm25
-rw-r--r--guix/packages.scm70
-rw-r--r--guix/profiles.scm27
-rw-r--r--guix/scripts/build.scm22
-rw-r--r--guix/scripts/challenge.scm185
-rw-r--r--guix/scripts/container/exec.scm13
-rw-r--r--guix/scripts/copy.scm4
-rw-r--r--guix/scripts/environment.scm33
-rw-r--r--guix/scripts/graph.scm15
-rw-r--r--guix/scripts/import.scm3
-rw-r--r--guix/scripts/import/stackage.scm115
-rw-r--r--guix/scripts/lint.scm25
-rw-r--r--guix/scripts/refresh.scm1
-rw-r--r--guix/serialization.scm12
-rw-r--r--guix/store.scm71
-rw-r--r--guix/ui.scm52
-rw-r--r--guix/utils.scm11
40 files changed, 1470 insertions, 502 deletions
diff --git a/guix/build-system/dub.scm b/guix/build-system/dub.scm
new file mode 100644
index 0000000000..13c89e8648
--- /dev/null
+++ b/guix/build-system/dub.scm
@@ -0,0 +1,147 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
+;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2016 David Craven <david@craven.ch>
+;;; Copyright © 2016 Danny Milosavljevic <dannym@scratchpost.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-system dub)
+ #:use-module (guix search-paths)
+ #:use-module (guix store)
+ #:use-module (guix utils)
+ #:use-module (guix derivations)
+ #:use-module (guix packages)
+ #:use-module (guix build-system)
+ #:use-module (guix build-system gnu)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-26)
+ #:export (dub-build-system))
+
+(define (default-ldc)
+ "Return the default ldc package."
+ ;; Lazily resolve the binding to avoid a circular dependency.
+ (let ((ldc (resolve-interface '(gnu packages ldc))))
+ (module-ref ldc 'ldc)))
+
+(define (default-dub)
+ "Return the default dub package."
+ ;; Lazily resolve the binding to avoid a circular dependency.
+ (let ((ldc (resolve-interface '(gnu packages ldc))))
+ (module-ref ldc 'dub)))
+
+(define (default-pkg-config)
+ "Return the default pkg-config package."
+ ;; Lazily resolve the binding to avoid a circular dependency.
+ (let ((pkg-config (resolve-interface '(gnu packages pkg-config))))
+ (module-ref pkg-config 'pkg-config)))
+
+(define %dub-build-system-modules
+ ;; Build-side modules imported by default.
+ `((guix build dub-build-system)
+ (guix build syscalls)
+ ,@%gnu-build-system-modules))
+
+(define* (dub-build store name inputs
+ #:key
+ (tests? #t)
+ (test-target #f)
+ (dub-build-flags ''())
+ (phases '(@ (guix build dub-build-system)
+ %standard-phases))
+ (outputs '("out"))
+ (search-paths '())
+ (system (%current-system))
+ (guile #f)
+ (imported-modules %dub-build-system-modules)
+ (modules '((guix build dub-build-system)
+ (guix build utils))))
+ "Build SOURCE using DUB, and with INPUTS."
+ (define builder
+ `(begin
+ (use-modules ,@modules)
+ (dub-build #:name ,name
+ #:source ,(match (assoc-ref inputs "source")
+ (((? derivation? source))
+ (derivation->output-path source))
+ ((source)
+ source)
+ (source
+ source))
+ #:system ,system
+ #:test-target ,test-target
+ #:dub-build-flags ,dub-build-flags
+ #:tests? ,tests?
+ #:phases ,phases
+ #:outputs %outputs
+ #:search-paths ',(map search-path-specification->sexp
+ search-paths)
+ #:inputs %build-inputs)))
+
+ (define guile-for-build
+ (match guile
+ ((? package?)
+ (package-derivation store guile system #:graft? #f))
+ (#f ; the default
+ (let* ((distro (resolve-interface '(gnu packages commencement)))
+ (guile (module-ref distro 'guile-final)))
+ (package-derivation store guile system #:graft? #f)))))
+
+ (build-expression->derivation store name builder
+ #:inputs inputs
+ #:system system
+ #:modules imported-modules
+ #:outputs outputs
+ #:guile-for-build guile-for-build))
+
+(define* (lower name
+ #:key source inputs native-inputs outputs system target
+ (ldc (default-ldc))
+ (dub (default-dub))
+ (pkg-config (default-pkg-config))
+ #:allow-other-keys
+ #:rest arguments)
+ "Return a bag for NAME."
+
+ (define private-keywords
+ '(#:source #:target #:ldc #:dub #:pkg-config #:inputs #:native-inputs #:outputs))
+
+ (and (not target) ;; TODO: support cross-compilation
+ (bag
+ (name name)
+ (system system)
+ (target target)
+ (host-inputs `(,@(if source
+ `(("source" ,source))
+ '())
+ ,@inputs
+
+ ;; Keep the standard inputs of 'gnu-build-system'
+ ,@(standard-packages)))
+ (build-inputs `(("ldc" ,ldc)
+ ("dub" ,dub)
+ ,@native-inputs))
+ (outputs outputs)
+ (build dub-build)
+ (arguments (strip-keyword-arguments private-keywords arguments)))))
+
+(define dub-build-system
+ (build-system
+ (name 'dub)
+ (description
+ "DUB build system, to build D packages")
+ (lower lower)))
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index f6df183da4..730e638c89 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -19,7 +19,7 @@
(define-module (guix build-system gnu)
#:use-module (guix store)
#:use-module (guix utils)
- #:use-module (guix combinators)
+ #:use-module (guix memoization)
#:use-module (guix derivations)
#:use-module (guix search-paths)
#:use-module (guix build-system)
@@ -84,15 +84,15 @@ builder, or the distro's final Guile when GUILE is #f."
(let loop ((p p))
(define rewritten-input
- (memoize
- (match-lambda
- ((name (? package? p) sub-drv ...)
- ;; XXX: Check whether P's build system knows #:implicit-inputs, for
- ;; things like `cross-pkg-config'.
- (if (eq? (package-build-system p) gnu-build-system)
- (cons* name (loop p) sub-drv)
- (cons* name p sub-drv)))
- (x x))))
+ (mlambda (input)
+ (match input
+ ((name (? package? p) sub-drv ...)
+ ;; XXX: Check whether P's build system knows #:implicit-inputs, for
+ ;; things like `cross-pkg-config'.
+ (if (eq? (package-build-system p) gnu-build-system)
+ (cons* name (loop p) sub-drv)
+ (cons* name p sub-drv)))
+ (x x))))
(package (inherit p)
(location (if (pair? loc) (source-properties->location loc) loc))
@@ -393,22 +393,21 @@ packages that must not be referenced."
;;;
(define standard-cross-packages
- (memoize
- (lambda (target kind)
- "Return the list of name/package tuples to cross-build for TARGET. KIND
+ (mlambda (target kind)
+ "Return the list of name/package tuples to cross-build for TARGET. KIND
is one of `host' or `target'."
- (let* ((cross (resolve-interface '(gnu packages cross-base)))
- (gcc (module-ref cross 'cross-gcc))
- (binutils (module-ref cross 'cross-binutils))
- (libc (module-ref cross 'cross-libc)))
- (case kind
- ((host)
- `(("cross-gcc" ,(gcc target
- (binutils target)
- (libc target)))
- ("cross-binutils" ,(binutils target))))
- ((target)
- `(("cross-libc" ,(libc target)))))))))
+ (let* ((cross (resolve-interface '(gnu packages cross-base)))
+ (gcc (module-ref cross 'cross-gcc))
+ (binutils (module-ref cross 'cross-binutils))
+ (libc (module-ref cross 'cross-libc)))
+ (case kind
+ ((host)
+ `(("cross-gcc" ,(gcc target
+ (binutils target)
+ (libc target)))
+ ("cross-binutils" ,(binutils target))))
+ ((target)
+ `(("cross-libc" ,(libc target))))))))
(define* (gnu-cross-build store name
#:key
diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm
index d4d3d28f2a..17173f121e 100644
--- a/guix/build-system/python.scm
+++ b/guix/build-system/python.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
@@ -21,7 +21,7 @@
(define-module (guix build-system python)
#:use-module (guix store)
#:use-module (guix utils)
- #:use-module (guix combinators)
+ #:use-module (guix memoization)
#:use-module (guix packages)
#:use-module (guix derivations)
#:use-module (guix search-paths)
@@ -87,49 +87,48 @@ pre-defined variants."
;; Memoize the transformations. Failing to do that, we would build a huge
;; object graph with lots of duplicates, which in turns prevents us from
;; benefiting from memoization in 'package-derivation'.
- (memoize ;FIXME: use 'eq?'
- (lambda (p)
- (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.
- (if (package? content)
- (transform content)
- content)))
- (rewrite
- (match-lambda
- ((name content . rest)
- (append (list name (rewrite-if-package content)) rest)))))
-
- (cond
- ;; If VARIANT-PROPERTY is present, use that.
- ((and variant-property
- (assoc-ref (package-properties p) variant-property))
- => force)
-
- ;; Otherwise build the new package object graph.
- ((eq? (package-build-system p) python-build-system)
- (package
- (inherit p)
- (location (package-location 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 ((python (if (promise? python)
- (force python)
- python)))
- (ensure-keyword-arguments (package-arguments p)
- `(#:python ,python))))
- (inputs (map rewrite (package-inputs p)))
- (propagated-inputs (map rewrite (package-propagated-inputs p)))
- (native-inputs (map rewrite (package-native-inputs p)))))
- (else
- p))))))
+ (mlambdaq (p)
+ (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.
+ (if (package? content)
+ (transform content)
+ content)))
+ (rewrite
+ (match-lambda
+ ((name content . rest)
+ (append (list name (rewrite-if-package content)) rest)))))
+
+ (cond
+ ;; If VARIANT-PROPERTY is present, use that.
+ ((and variant-property
+ (assoc-ref (package-properties p) variant-property))
+ => force)
+
+ ;; Otherwise build the new package object graph.
+ ((eq? (package-build-system p) python-build-system)
+ (package
+ (inherit p)
+ (location (package-location 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 ((python (if (promise? python)
+ (force python)
+ python)))
+ (ensure-keyword-arguments (package-arguments p)
+ `(#:python ,python))))
+ (inputs (map rewrite (package-inputs p)))
+ (propagated-inputs (map rewrite (package-propagated-inputs p)))
+ (native-inputs (map rewrite (package-native-inputs p)))))
+ (else
+ p)))))
transform)
diff --git a/guix/build/bournish.scm b/guix/build/bournish.scm
index 51dad17ba7..e948cd03d3 100644
--- a/guix/build/bournish.scm
+++ b/guix/build/bournish.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -105,6 +106,14 @@ characters."
((@ (guix build utils) dump-port) port (current-output-port))
*unspecified*)))
+(define (rm-command . args)
+ "Emit code for the 'rm' command."
+ (cond ((member "-r" args)
+ `(for-each (@ (guix build utils) delete-file-recursively)
+ (list ,@(delete "-r" args))))
+ (else
+ `(for-each delete-file (list ,@args)))))
+
(define (lines+chars port)
"Return the number of lines and number of chars read from PORT."
(let loop ((lines 0) (chars 0))
@@ -194,7 +203,7 @@ commands such as 'ls' and 'cd'; it lacks globbing, pipes---everything.\n"))
`(("echo" ,(lambda strings `(list ,@strings)))
("cd" ,(lambda (dir) `(chdir ,dir)))
("pwd" ,(lambda () `(getcwd)))
- ("rm" ,(lambda (file) `(delete-file ,file)))
+ ("rm" ,rm-command)
("cp" ,(lambda (source dest) `(copy-file ,source ,dest)))
("help" ,help-command)
("ls" ,ls-command)
diff --git a/guix/build/dub-build-system.scm b/guix/build/dub-build-system.scm
new file mode 100644
index 0000000000..7c7cd8803c
--- /dev/null
+++ b/guix/build/dub-build-system.scm
@@ -0,0 +1,125 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 David Craven <david@craven.ch>
+;;; Copyright © 2017 Danny Milosavljevic <dannym@scratchpost.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 dub-build-system)
+ #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+ #:use-module (guix build syscalls)
+ #:use-module (guix build utils)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 ftw)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (rnrs io ports)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:export (%standard-phases
+ dub-build))
+
+;; Commentary:
+;;
+;; Builder-side code of the DUB (the build tool for D) build system.
+;;
+;; Code:
+
+;; FIXME: Needs to be parsed from url not package name.
+(define (package-name->d-package-name name)
+ "Return the package name of NAME."
+ (match (string-split name #\-)
+ (("d" rest ...)
+ (string-join rest "-"))
+ (_ #f)))
+
+(define* (configure #:key inputs #:allow-other-keys)
+ "Prepare one new directory with all the required dependencies.
+ It's necessary to do this (instead of just using /gnu/store as the
+ directory) because we want to hide the libraries in subdirectories
+ lib/dub/... instead of polluting the user's profile root."
+ (let* ((dir (mkdtemp! "/tmp/dub.XXXXXX"))
+ (vendor-dir (string-append dir "/vendor")))
+ (setenv "HOME" dir)
+ (mkdir vendor-dir)
+ (for-each
+ (match-lambda
+ ((name . path)
+ (let* ((d-package (package-name->d-package-name name))
+ (d-basename (basename path)))
+ (when (and d-package path)
+ (match (string-split (basename path) #\-)
+ ((_ ... version)
+ (symlink (string-append path "/lib/dub/" d-basename)
+ (string-append vendor-dir "/" d-basename))))))))
+ inputs)
+ (zero? (system* "dub" "add-path" vendor-dir))))
+
+(define (grep string file-name)
+ "Find the first occurence of STRING in the file named FILE-NAME.
+ Return the position of this occurence, or #f if none was found."
+ (string-contains (call-with-input-file file-name get-string-all)
+ string))
+
+(define (grep* string file-name)
+ "Find the first occurence of STRING in the file named FILE-NAME.
+ Return the position of this occurence, or #f if none was found.
+ If the file named FILE-NAME doesn't exist, return #f."
+ (catch 'system-error
+ (lambda ()
+ (grep string file-name))
+ (lambda args
+ #f)))
+
+(define* (build #:key (dub-build-flags '())
+ #:allow-other-keys)
+ "Build a given DUB package."
+ (if (or (grep* "sourceLibrary" "package.json")
+ (grep* "sourceLibrary" "dub.sdl") ; note: format is different!
+ (grep* "sourceLibrary" "dub.json"))
+ #t
+ (let ((status (zero? (apply system* `("dub" "build" ,@dub-build-flags)))))
+ (system* "dub" "run") ; might fail for "targetType": "library"
+ status)))
+
+(define* (check #:key tests? #:allow-other-keys)
+ (if tests?
+ (zero? (system* "dub" "test"))
+ #t))
+
+(define* (install #:key inputs outputs #:allow-other-keys)
+ "Install a given DUB package."
+ (let* ((out (assoc-ref outputs "out"))
+ (outbin (string-append out "/bin"))
+ (outlib (string-append out "/lib/dub/" (basename out))))
+ (mkdir-p outbin)
+ ;; TODO remove "-test-application"
+ (copy-recursively "bin" outbin)
+ (mkdir-p outlib)
+ (copy-recursively "." (string-append outlib))
+ #t))
+
+(define %standard-phases
+ (modify-phases gnu:%standard-phases
+ (replace 'configure configure)
+ (replace 'build build)
+ (replace 'check check)
+ (replace 'install install)))
+
+(define* (dub-build #:key inputs (phases %standard-phases)
+ #:allow-other-keys #:rest args)
+ "Build the given DUB package, applying all of PHASES in order."
+ (apply gnu:gnu-build #:inputs inputs #:phases phases args))
diff --git a/guix/build/r-build-system.scm b/guix/build/r-build-system.scm
index 3fc13eb835..24aa73d4f2 100644
--- a/guix/build/r-build-system.scm
+++ b/guix/build/r-build-system.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2015, 2017 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -84,6 +84,7 @@
(params (append configure-flags
(list "--install-tests"
(string-append "--library=" site-library)
+ "--built-timestamp=1970-01-01"
".")))
(site-path (string-append site-library ":"
(generate-site-path inputs))))
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 2e37846ff0..b68c48a05a 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -21,10 +21,12 @@
(define-module (guix build syscalls)
#:use-module (system foreign)
#:use-module (rnrs bytevectors)
+ #:autoload (ice-9 binary-ports) (get-bytevector-n)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-19)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (ice-9 match)
@@ -126,7 +128,23 @@
window-size-x-pixels
window-size-y-pixels
terminal-window-size
- terminal-columns))
+ terminal-columns
+
+ utmpx?
+ utmpx-login-type
+ utmpx-pid
+ utmpx-line
+ utmpx-id
+ utmpx-user
+ utmpx-host
+ utmpx-termination-status
+ utmpx-exit-status
+ utmpx-session-id
+ utmpx-time
+ utmpx-address
+ login-type
+ utmpx-entries
+ (read-utmpx-from-port . read-utmpx)))
;;; Commentary:
;;;
@@ -900,6 +918,15 @@ bytevector BV at INDEX."
;; The most terrible interface, live from Scheme.
(syscall->procedure int "ioctl" (list int unsigned-long '*)))
+(define (bytes->string bytes)
+ "Read BYTES, a list of bytes, and return the null-terminated string decoded
+from there, or #f if that would be an empty string."
+ (match (take-while (negate zero?) bytes)
+ (()
+ #f)
+ (non-zero
+ (list->string (map integer->char non-zero)))))
+
(define (bytevector->string-list bv stride len)
"Return the null-terminated strings found in BV every STRIDE bytes. Read at
most LEN bytes from BV."
@@ -911,9 +938,7 @@ most LEN bytes from BV."
(reverse result))
(_
(loop (drop bytes stride)
- (cons (list->string (map integer->char
- (take-while (negate zero?) bytes)))
- result))))))
+ (cons (bytes->string bytes) result))))))
(define* (network-interface-names #:optional sock)
"Return the names of existing network interfaces. This is typically limited
@@ -1480,4 +1505,108 @@ always a positive integer."
(fall-back)
(apply throw args))))))
+
+;;;
+;;; utmpx.
+;;;
+
+(define-record-type <utmpx-entry>
+ (utmpx type pid line id user host termination exit
+ session time address)
+ utmpx?
+ (type utmpx-login-type) ;login-type
+ (pid utmpx-pid)
+ (line utmpx-line) ;device name
+ (id utmpx-id)
+ (user utmpx-user) ;user name
+ (host utmpx-host) ;host name | #f
+ (termination utmpx-termination-status)
+ (exit utmpx-exit-status)
+ (session utmpx-session-id) ;session ID, for windowing
+ (time utmpx-time) ;entry time
+ (address utmpx-address))
+
+(define-c-struct %utmpx ;<utmpx.h>
+ sizeof-utmpx
+ (lambda (type pid line id user host termination exit session
+ seconds useconds address %reserved)
+ (utmpx type pid
+ (bytes->string line) id
+ (bytes->string user)
+ (bytes->string host) termination exit
+ session
+ (make-time time-utc (* 1000 useconds) seconds)
+ address))
+ read-utmpx
+ write-utmpx!
+ (type short)
+ (pid int)
+ (line (array uint8 32))
+ (id (array uint8 4))
+ (user (array uint8 32))
+ (host (array uint8 256))
+ (termination short)
+ (exit short)
+ (session int32)
+ (time-seconds int32)
+ (time-useconds int32)
+ (address-v6 (array int32 4))
+ (%reserved (array uint8 20)))
+
+(define-bits login-type
+ %unused-login-type->symbols
+ (define EMPTY 0) ;No valid user accounting information.
+ (define RUN_LVL 1) ;The system's runlevel.
+ (define BOOT_TIME 2) ;Time of system boot.
+ (define NEW_TIME 3) ;Time after system clock changed.
+ (define OLD_TIME 4) ;Time when system clock changed.
+
+ (define INIT_PROCESS 5) ;Process spawned by the init process.
+ (define LOGIN_PROCESS 6) ;Session leader of a logged in user.
+ (define USER_PROCESS 7) ;Normal process.
+ (define DEAD_PROCESS 8) ;Terminated process.
+
+ (define ACCOUNTING 9)) ;System accounting.
+
+(define setutxent
+ (let ((proc (syscall->procedure void "setutxent" '())))
+ (lambda ()
+ "Open the user accounting database."
+ (proc))))
+
+(define endutxent
+ (let ((proc (syscall->procedure void "endutxent" '())))
+ (lambda ()
+ "Close the user accounting database."
+ (proc))))
+
+(define getutxent
+ (let ((proc (syscall->procedure '* "getutxent" '())))
+ (lambda ()
+ "Return the next entry from the user accounting database."
+ (let ((ptr (proc)))
+ (if (null-pointer? ptr)
+ #f
+ (read-utmpx (pointer->bytevector ptr sizeof-utmpx)))))))
+
+(define (utmpx-entries)
+ "Return the list of entries read from the user accounting database."
+ (setutxent)
+ (let loop ((entries '()))
+ (match (getutxent)
+ (#f
+ (endutxent)
+ (reverse entries))
+ ((? utmpx? entry)
+ (loop (cons entry entries))))))
+
+(define (read-utmpx-from-port port)
+ "Read a utmpx entry from PORT. Return either the EOF object or a utmpx
+entry."
+ (match (get-bytevector-n port sizeof-utmpx)
+ ((? eof-object? eof)
+ eof)
+ ((? bytevector? bv)
+ (read-utmpx bv))))
+
;;; syscalls.scm ends here
diff --git a/guix/combinators.scm b/guix/combinators.scm
index 9e4689ba9c..11cad62ccf 100644
--- a/guix/combinators.scm
+++ b/guix/combinators.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;;
;;; This file is part of GNU Guix.
@@ -20,8 +20,7 @@
(define-module (guix combinators)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
- #:export (memoize
- fold2
+ #:export (fold2
fold-tree
fold-tree-leaves
compile-time-value))
@@ -33,19 +32,6 @@
;;;
;;; Code:
-(define (memoize proc)
- "Return a memoizing version of PROC."
- (let ((cache (make-hash-table)))
- (lambda args
- (let ((results (hash-ref cache args)))
- (if results
- (apply values results)
- (let ((results (call-with-values (lambda ()
- (apply proc args))
- list)))
- (hash-set! cache args results)
- (apply values results)))))))
-
(define fold2
(case-lambda
((proc seed1 seed2 lst)
diff --git a/guix/derivations.scm b/guix/derivations.scm
index b712c508e5..47a783f42f 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -31,6 +31,7 @@
#:use-module (ice-9 vlist)
#:use-module (guix store)
#:use-module (guix utils)
+ #:use-module (guix memoization)
#:use-module (guix combinators)
#:use-module (guix monads)
#:use-module (guix hash)
@@ -556,12 +557,11 @@ that form."
(display ")" port))))
(define derivation->string
- (memoize
- (lambda (drv)
- "Return the external representation of DRV as a string."
- (with-fluids ((%default-port-encoding "UTF-8"))
- (call-with-output-string
- (cut write-derivation drv <>))))))
+ (mlambda (drv)
+ "Return the external representation of DRV as a string."
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (call-with-output-string
+ (cut write-derivation drv <>)))))
(define* (derivation->output-path drv #:optional (output "out"))
"Return the store path of its output OUTPUT. Raise a
@@ -583,12 +583,14 @@ DRV."
(define derivation-path->output-path
;; This procedure is called frequently, so memoize it.
- (memoize
- (lambda* (path #:optional (output "out"))
- "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the store
+ (let ((memoized (mlambda (path output)
+ (derivation->output-path (call-with-input-file path
+ read-derivation)
+ output))))
+ (lambda* (path #:optional (output "out"))
+ "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the store
path of its output OUTPUT."
- (derivation->output-path (call-with-input-file path read-derivation)
- output))))
+ (memoized path output))))
(define (derivation-path->output-paths path)
"Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the
@@ -615,23 +617,21 @@ in SIZE bytes."
(loop (+ 1 i))))))
(define derivation-path->base16-hash
- (memoize
- (lambda (file)
- "Return a string containing the base16 representation of the hash of the
+ (mlambda (file)
+ "Return a string containing the base16 representation of the hash of the
derivation at FILE."
- (call-with-input-file file
- (compose bytevector->base16-string
- derivation-hash
- read-derivation)))))
+ (call-with-input-file file
+ (compose bytevector->base16-string
+ derivation-hash
+ read-derivation))))
(define derivation-hash ; `hashDerivationModulo' in derivations.cc
- (memoize
- (lambda (drv)
+ (mlambda (drv)
"Return the hash of DRV, modulo its fixed-output inputs, as a bytevector."
(match drv
(($ <derivation> ((_ . ($ <derivation-output> path
- (? symbol? hash-algo) (? bytevector? hash)
- (? boolean? recursive?)))))
+ (? symbol? hash-algo) (? bytevector? hash)
+ (? boolean? recursive?)))))
;; A fixed-output derivation.
(sha256
(string->utf8
@@ -641,14 +641,14 @@ derivation at FILE."
":" (bytevector->base16-string hash)
":" path))))
(($ <derivation> outputs inputs sources
- system builder args env-vars)
+ system builder args env-vars)
;; A regular derivation: replace the path of each input with that
;; input's hash; return the hash of serialization of the resulting
;; derivation.
(let* ((inputs (map (match-lambda
- (($ <derivation-input> path sub-drvs)
- (let ((hash (derivation-path->base16-hash path)))
- (make-derivation-input hash sub-drvs))))
+ (($ <derivation-input> path sub-drvs)
+ (let ((hash (derivation-path->base16-hash path)))
+ (make-derivation-input hash sub-drvs))))
inputs))
(drv (make-derivation outputs
(sort (coalesce-duplicate-inputs inputs)
@@ -661,7 +661,7 @@ derivation at FILE."
;; the SHA256 port's `write' method gets called for every single
;; character.
(sha256
- (string->utf8 (derivation->string drv)))))))))
+ (string->utf8 (derivation->string drv))))))))
(define (store-path type hash name) ; makeStorePath
"Return the store path for NAME/HASH/TYPE."
@@ -915,18 +915,17 @@ recursively."
(define rewritten-input
;; Rewrite the given input according to MAPPING, and return an input
;; in the format used in 'derivation' calls.
- (memoize
- (lambda (input loop)
- (match input
- (($ <derivation-input> path (sub-drvs ...))
- (match (vhash-assoc path mapping)
- ((_ . (? derivation? replacement))
- (cons replacement sub-drvs))
- ((_ . replacement)
- (list replacement))
- (#f
- (let* ((drv (loop (call-with-input-file path read-derivation))))
- (cons drv sub-drvs)))))))))
+ (mlambda (input loop)
+ (match input
+ (($ <derivation-input> path (sub-drvs ...))
+ (match (vhash-assoc path mapping)
+ ((_ . (? derivation? replacement))
+ (cons replacement sub-drvs))
+ ((_ . replacement)
+ (list replacement))
+ (#f
+ (let* ((drv (loop (call-with-input-file path read-derivation))))
+ (cons drv sub-drvs))))))))
(let loop ((drv drv))
(let* ((inputs (map (cut rewritten-input <> loop)
@@ -1057,13 +1056,13 @@ system, imported, and appears under FINAL-PATH in the resulting store path."
(define search-path*
;; A memoizing version of 'search-path' so 'imported-modules' does not end
;; up looking for the same files over and over again.
- (memoize (lambda (path file)
- "Search for FILE in PATH and memoize the result. Raise a
+ (mlambda (path file)
+ "Search for FILE in PATH and memoize the result. Raise a
'&file-search-error' condition if it could not be found."
- (or (search-path path file)
- (raise (condition
- (&file-search-error (file file)
- (path path))))))))
+ (or (search-path path file)
+ (raise (condition
+ (&file-search-error (file file)
+ (path path)))))))
(define (module->source-file-name module)
"Return the file name corresponding to MODULE, a Guile module name (a list
diff --git a/guix/download.scm b/guix/download.scm
index e2e5cee777..813f51f489 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -4,6 +4,7 @@
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
;;; Copyright © 2016 David Craven <david@craven.ch>
+;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -35,6 +36,7 @@
#:export (%mirrors
url-fetch
url-fetch/tarbomb
+ url-fetch/zipbomb
download-to-store))
;;; Commentary:
@@ -86,6 +88,7 @@
"http://ftp.belnet.be/ftp.gnome.org/"
"http://ftp.linux.org.uk/mirrors/ftp.gnome.org/"
"http://ftp.gnome.org/pub/GNOME/"
+ "https://download.gnome.org/"
"http://mirror.yandex.ru/mirrors/ftp.gnome.org/")
(hackage
"http://hackage.haskell.org/")
@@ -485,17 +488,24 @@ in the store."
(guile (default-guile)))
"Similar to 'url-fetch' but unpack the file from URL in a directory of its
own. This helper makes it easier to deal with \"tar bombs\"."
+ (define file-name
+ (match url
+ ((head _ ...)
+ (basename head))
+ (_
+ (basename url))))
(define gzip
(module-ref (resolve-interface '(gnu packages compression)) 'gzip))
(define tar
(module-ref (resolve-interface '(gnu packages base)) 'tar))
(mlet %store-monad ((drv (url-fetch url hash-algo hash
- (string-append "tarbomb-" name)
+ (string-append "tarbomb-"
+ (or name file-name))
#:system system
#:guile guile)))
;; Take the tar bomb, and simply unpack it as a directory.
- (gexp->derivation name
+ (gexp->derivation (or name file-name)
#~(begin
(mkdir #$output)
(setenv "PATH" (string-append #$gzip "/bin"))
@@ -504,6 +514,35 @@ own. This helper makes it easier to deal with \"tar bombs\"."
"xf" #$drv)))
#:local-build? #t)))
+(define* (url-fetch/zipbomb url hash-algo hash
+ #:optional name
+ #:key (system (%current-system))
+ (guile (default-guile)))
+ "Similar to 'url-fetch' but unpack the zip file at URL in a directory of its
+own. This helper makes it easier to deal with \"zip bombs\"."
+ (define file-name
+ (match url
+ ((head _ ...)
+ (basename head))
+ (_
+ (basename url))))
+ (define unzip
+ (module-ref (resolve-interface '(gnu packages zip)) 'unzip))
+
+ (mlet %store-monad ((drv (url-fetch url hash-algo hash
+ (string-append "zipbomb-"
+ (or name file-name))
+ #:system system
+ #:guile guile)))
+ ;; Take the zip bomb, and simply unpack it as a directory.
+ (gexp->derivation (or name file-name)
+ #~(begin
+ (mkdir #$output)
+ (chdir #$output)
+ (zero? (system* (string-append #$unzip "/bin/unzip")
+ #$drv)))
+ #:local-build? #t)))
+
(define* (download-to-store store url #:optional (name (basename url))
#:key (log (current-error-port)) recursive?
(verify-certificate? #t))
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 62e625c715..5d86ab2b62 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -17,6 +18,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix git-download)
+ #:use-module (guix build utils)
#:use-module (guix gexp)
#:use-module (guix store)
#:use-module (guix monads)
@@ -24,6 +26,9 @@
#:use-module (guix packages)
#:autoload (guix build-system gnu) (standard-packages)
#:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 rdelim)
+ #:use-module (srfi srfi-1)
#:export (git-reference
git-reference?
git-reference-url
@@ -32,7 +37,8 @@
git-fetch
git-version
- git-file-name))
+ git-file-name
+ git-predicate))
;;; Commentary:
;;;
@@ -119,4 +125,39 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
"Return the file-name for packages using git-download."
(string-append name "-" version "-checkout"))
+(define (git-predicate directory)
+ "Return a predicate that returns true if a file is part of the Git checkout
+living at DIRECTORY. Upon Git failure, return #f instead of a predicate.
+
+The returned predicate takes two arguments FILE and STAT where FILE is an
+absolute file name and STAT is the result of 'lstat'."
+ (define (parent-directory? thing directory)
+ ;; Return #t if DIRECTORY is the parent of THING.
+ (or (string-suffix? thing directory)
+ (and (string-index thing #\/)
+ (parent-directory? (dirname thing) directory))))
+
+ (let* ((pipe (with-directory-excursion directory
+ (open-pipe* OPEN_READ "git" "ls-files")))
+ (files (let loop ((lines '()))
+ (match (read-line pipe)
+ ((? eof-object?)
+ (reverse lines))
+ (line
+ (loop (cons line lines))))))
+ (status (close-pipe pipe)))
+ (and (zero? status)
+ (lambda (file stat)
+ (match (stat:type stat)
+ ('directory
+ ;; 'git ls-files' does not list directories, only regular files,
+ ;; so we need this special trick.
+ (any (lambda (f) (parent-directory? f file))
+ files))
+ ((or 'regular 'symlink)
+ (any (lambda (f) (string-suffix? f file))
+ files))
+ (_
+ #f))))))
+
;;; git-download.scm ends here
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 789724c8c0..07e6909641 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -30,7 +30,7 @@
#:use-module (guix http-client)
#:use-module (guix ftp-client)
#:use-module (guix utils)
- #:use-module (guix combinators)
+ #:use-module (guix memoization)
#:use-module (guix records)
#:use-module (guix upstream)
#:use-module (guix packages)
@@ -165,43 +165,48 @@ found."
(official-gnu-packages)))
(define gnu-package?
- (memoize
- (let ((official-gnu-packages (memoize official-gnu-packages)))
- (lambda (package)
- "Return true if PACKAGE is a GNU package. This procedure may access the
+ (let ((official-gnu-packages (memoize official-gnu-packages)))
+ (mlambdaq (package)
+ "Return true if PACKAGE is a GNU package. This procedure may access the
network to check in GNU's database."
- (define (mirror-type url)
- (let ((uri (string->uri url)))
- (and (eq? (uri-scheme uri) 'mirror)
- (cond
- ((member (uri-host uri)
- '("gnu" "gnupg" "gcc" "gnome"))
- ;; Definitely GNU.
- 'gnu)
- ((equal? (uri-host uri) "cran")
- ;; Possibly GNU: mirror://cran could be either GNU R itself
- ;; or a non-GNU package.
- #f)
- (else
- ;; Definitely non-GNU.
- 'non-gnu)))))
-
- (define (gnu-home-page? package)
- (and=> (package-home-page package)
- (lambda (url)
- (and=> (uri-host (string->uri url))
- (lambda (host)
- (member host '("www.gnu.org" "gnu.org")))))))
-
- (or (gnu-home-page? package)
- (let ((url (and=> (package-source package) origin-uri))
- (name (package-name package)))
- (case (and (string? url) (mirror-type url))
- ((gnu) #t)
- ((non-gnu) #f)
- (else
- (and (member name (map gnu-package-name (official-gnu-packages)))
- #t)))))))))
+ (define (mirror-type url)
+ (let ((uri (string->uri url)))
+ (and (eq? (uri-scheme uri) 'mirror)
+ (cond
+ ((member (uri-host uri)
+ '("gnu" "gnupg" "gcc" "gnome"))
+ ;; Definitely GNU.
+ 'gnu)
+ ((equal? (uri-host uri) "cran")
+ ;; Possibly GNU: mirror://cran could be either GNU R itself
+ ;; or a non-GNU package.
+ #f)
+ (else
+ ;; Definitely non-GNU.
+ 'non-gnu)))))
+
+ (define (gnu-home-page? package)
+ (letrec-syntax ((>> (syntax-rules ()
+ ((_ value proc)
+ (and=> value proc))
+ ((_ value proc rest ...)
+ (and=> value
+ (lambda (next)
+ (>> (proc next) rest ...)))))))
+ (>> package package-home-page
+ string->uri uri-host
+ (lambda (host)
+ (member host '("www.gnu.org" "gnu.org"))))))
+
+ (or (gnu-home-page? package)
+ (let ((url (and=> (package-source package) origin-uri))
+ (name (package-upstream-name package)))
+ (case (and (string? url) (mirror-type url))
+ ((gnu) #t)
+ ((non-gnu) #f)
+ (else
+ (and (member name (map gnu-package-name (official-gnu-packages)))
+ #t))))))))
;;;
@@ -210,10 +215,11 @@ network to check in GNU's database."
(define (ftp-server/directory package)
"Return the FTP server and directory where PACKAGE's tarball are stored."
- (values (or (assoc-ref (package-properties package) 'ftp-server)
- "ftp.gnu.org")
- (or (assoc-ref (package-properties package) 'ftp-directory)
- (string-append "/gnu/" (package-name package)))))
+ (let ((name (package-upstream-name package)))
+ (values (or (assoc-ref (package-properties package) 'ftp-server)
+ "ftp.gnu.org")
+ (or (assoc-ref (package-properties package) 'ftp-directory)
+ (string-append "/gnu/" name)))))
(define (sans-extension tarball)
"Return TARBALL without its .tar.* or .zip extension."
@@ -423,11 +429,9 @@ hosted on ftp.gnu.org, or not under that name (this is the case for
\"emacs-auctex\", for instance.)"
(let-values (((server directory)
(ftp-server/directory package)))
- (let ((name (or (assoc-ref (package-properties package) 'upstream-name)
- (package-name package))))
- (false-if-ftp-error (latest-release name
- #:server server
- #:directory directory)))))
+ (false-if-ftp-error (latest-release (package-upstream-name package)
+ #:server server
+ #:directory directory))))
(define %package-name-rx
;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses
@@ -444,8 +448,10 @@ hosted on ftp.gnu.org, or not under that name (this is the case for
(define (pure-gnu-package? package)
"Return true if PACKAGE is a non-Emacs and non-GNOME GNU package. This
excludes AucTeX, for instance, whose releases are now uploaded to
-elpa.gnu.org, and all the GNOME packages."
- (and (not (string-prefix? "emacs-" (package-name package)))
+elpa.gnu.org, and all the GNOME packages; EMMS is included though, because its
+releases are on gnu.org."
+ (and (or (not (string-prefix? "emacs-" (package-name package)))
+ (gnu-hosted? package))
(not (gnome-package? package))
(gnu-package? package)))
@@ -467,6 +473,9 @@ source URLs starts with PREFIX."
(_ #f)))
(_ #f))))
+(define gnu-hosted?
+ (url-prefix-predicate "mirror://gnu/"))
+
(define gnome-package?
(url-prefix-predicate "mirror://gnome/"))
@@ -491,8 +500,7 @@ source URLs starts with PREFIX."
(define upstream-name
;; Some packages like "NetworkManager" have camel-case names.
- (or (assoc-ref (package-properties package) 'upstream-name)
- (package-name package)))
+ (package-upstream-name package))
(false-if-ftp-error
(latest-ftp-release upstream-name
@@ -516,8 +524,7 @@ source URLs starts with PREFIX."
(let ((uri (string->uri (origin-uri (package-source package)))))
(false-if-ftp-error
(latest-ftp-release
- (or (assoc-ref (package-properties package) 'upstream-name)
- (package-name package))
+ (package-upstream-name package)
#:server "mirrors.mit.edu"
#:directory
(string-append "/kde" (dirname (dirname (uri-path uri))))
diff --git a/guix/grafts.scm b/guix/grafts.scm
index 2006d3908e..11885db226 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -78,11 +78,12 @@
(define* (graft-derivation/shallow store drv grafts
#:key
(name (derivation-name drv))
+ (outputs (derivation-output-names drv))
(guile (%guile-for-build))
(system (%current-system)))
- "Return a derivation called NAME, based on DRV but with all the GRAFTS
-applied. This procedure performs \"shallow\" grafting in that GRAFTS are not
-recursively applied to dependencies of DRV."
+ "Return a derivation called NAME, which applies GRAFTS to the specified
+OUTPUTS of DRV. This procedure performs \"shallow\" grafting in that GRAFTS
+are not recursively applied to dependencies of DRV."
;; XXX: Someday rewrite using gexps.
(define mapping
;; List of store item pairs.
@@ -96,14 +97,12 @@ recursively applied to dependencies of DRV."
target))))
grafts))
- (define outputs
- (map (match-lambda
- ((name . output)
- (cons name (derivation-output-path output))))
- (derivation-outputs drv)))
-
- (define output-names
- (derivation-output-names drv))
+ (define output-pairs
+ (map (lambda (output)
+ (cons output
+ (derivation-output-path
+ (assoc-ref (derivation-outputs drv) output))))
+ outputs))
(define build
`(begin
@@ -111,7 +110,7 @@ recursively applied to dependencies of DRV."
(guix build utils)
(ice-9 match))
- (let* ((old-outputs ',outputs)
+ (let* ((old-outputs ',output-pairs)
(mapping (append ',mapping
(map (match-lambda
((name . file)
@@ -143,10 +142,10 @@ recursively applied to dependencies of DRV."
(guix build utils))
#:inputs `(,@(map (lambda (out)
`("x" ,drv ,out))
- output-names)
+ outputs)
,@(append (map add-label sources)
(map add-label targets)))
- #:outputs output-names
+ #:outputs outputs
#:local-build? #t)))))
(define (item->deriver store item)
"Return two values: the derivation that led to ITEM (a store item), and the
@@ -217,13 +216,15 @@ available."
(define-syntax-rule (with-cache key exp ...)
"Cache the value of monadic expression EXP under KEY."
(mlet %state-monad ((cache (current-state)))
- (match (vhash-assq key cache)
+ (match (vhash-assoc key cache)
((_ . result) ;cache hit
(return result))
(#f ;cache miss
- (mlet %state-monad ((result (begin exp ...)))
- (set-current-state (vhash-consq key result cache))
- (return result))))))
+ (mlet %state-monad ((result (begin exp ...))
+ (cache (current-state)))
+ (mbegin %state-monad
+ (set-current-state (vhash-cons key result cache))
+ (return result)))))))
(define* (cumulative-grafts store drv grafts
references
@@ -263,7 +264,7 @@ derivations to the corresponding set of grafts."
#:system system))
(state-return grafts))))
- (with-cache drv
+ (with-cache (cons (derivation-file-name drv) outputs)
(match (non-self-references references drv outputs)
(() ;no dependencies
(return grafts))
@@ -280,29 +281,27 @@ derivations to the corresponding set of grafts."
;; applicable to DRV, to avoid creating several identical
;; grafted variants of DRV.
(let* ((new (graft-derivation/shallow store drv applicable
+ #:outputs outputs
#:guile guile
#:system system))
-
- ;; Replace references to any of the outputs of DRV,
- ;; even if that's more than needed. This is so that
- ;; the result refers only to the outputs of NEW and
- ;; not to those of DRV.
(grafts (append (map (lambda (output)
(graft
(origin drv)
(origin-output output)
(replacement new)
(replacement-output output)))
- (derivation-output-names drv))
+ outputs)
grafts)))
(return grafts))))))))))
(define* (graft-derivation store drv grafts
- #:key (guile (%guile-for-build))
+ #:key
+ (guile (%guile-for-build))
+ (outputs (derivation-output-names drv))
(system (%current-system)))
- "Applied GRAFTS to DRV and all its dependencies, recursively. That is, if
-GRAFTS apply only indirectly to DRV, graft the dependencies of DRV, and graft
-DRV itself to refer to those grafted dependencies."
+ "Apply GRAFTS to the OUTPUTS of DRV and all their dependencies, recursively.
+That is, if GRAFTS apply only indirectly to DRV, graft the dependencies of
+DRV, and graft DRV itself to refer to those grafted dependencies."
;; First, pre-compute the dependency tree of the outputs of DRV. Do this
;; upfront to have as much parallelism as possible when querying substitute
@@ -312,6 +311,7 @@ DRV itself to refer to those grafted dependencies."
(match (run-with-state
(cumulative-grafts store drv grafts references
+ #:outputs outputs
#:guile guile #:system system)
vlist-null) ;the initial cache
((first . rest)
diff --git a/guix/http-client.scm b/guix/http-client.scm
index 0090783524..78d39a0208 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2012, 2015 Free Software Foundation, Inc.
;;;
@@ -223,13 +223,14 @@ or if EOF is reached."
'shutdown (const #f))
(define* (http-fetch uri #:key port (text? #f) (buffered? #t)
- keep-alive? (verify-certificate? #t))
+ keep-alive? (verify-certificate? #t)
+ (headers '((user-agent . "GNU Guile"))))
"Return an input port containing the data at URI, and the expected number of
bytes available or #f. If TEXT? is true, the data at URI is considered to be
textual. Follow any HTTP redirection. When BUFFERED? is #f, return an
unbuffered port, suitable for use in `filtered-port'. When KEEP-ALIVE? is
true, send a 'Connection: keep-alive' HTTP header, in which case PORT may be
-reused for future HTTP requests.
+reused for future HTTP requests. HEADERS is an alist of extra HTTP headers.
When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates.
@@ -240,13 +241,14 @@ Raise an '&http-get-error' condition if downloading fails."
(let ((port (or port (open-connection-for-uri uri
#:verify-certificate?
verify-certificate?)))
- (auth-header (match (uri-userinfo uri)
- ((? string? str)
- (list (cons 'Authorization
- (string-append "Basic "
- (base64-encode
- (string->utf8 str))))))
- (_ '()))))
+ (headers (match (uri-userinfo uri)
+ ((? string? str)
+ (cons (cons 'Authorization
+ (string-append "Basic "
+ (base64-encode
+ (string->utf8 str))))
+ headers))
+ (_ headers))))
(unless (or buffered? (not (file-port? port)))
(setvbuf port _IONBF))
(let*-values (((resp data)
@@ -254,10 +256,10 @@ Raise an '&http-get-error' condition if downloading fails."
(if (guile-version>? "2.0.7")
(http-get uri #:streaming? #t #:port port
#:keep-alive? #t
- #:headers auth-header) ; 2.0.9+
+ #:headers headers) ; 2.0.9+
(http-get* uri #:decode-body? text? ; 2.0.7
#:keep-alive? #t
- #:port port #:headers auth-header)))
+ #:port port #:headers headers)))
((code)
(response-code resp)))
(case code
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 463a25514e..40cdea029b 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016 Ricardo Wurmus <rekado@elephly.net>
-;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -27,7 +27,7 @@
#:use-module (srfi srfi-41)
#:use-module (ice-9 receive)
#:use-module (web uri)
- #:use-module (guix combinators)
+ #:use-module (guix memoization)
#:use-module (guix http-client)
#:use-module (guix hash)
#:use-module (guix store)
diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm
index 96cf5bbae6..c0b0c415cf 100644
--- a/guix/import/elpa.scm
+++ b/guix/import/elpa.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
-;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -35,7 +35,6 @@
#:use-module (guix base32)
#:use-module (guix upstream)
#:use-module (guix packages)
- #:use-module ((guix combinators) #:select (memoize))
#:use-module ((guix utils) #:select (call-with-temporary-output-file))
#:export (elpa->guix-package
%elpa-updater))
diff --git a/guix/import/github.scm b/guix/import/github.scm
index 01452b12e3..b249b39067 100644
--- a/guix/import/github.scm
+++ b/guix/import/github.scm
@@ -19,21 +19,38 @@
(define-module (guix import github)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-34)
#:use-module (json)
#:use-module (guix utils)
#:use-module ((guix download) #:prefix download:)
#:use-module (guix import utils)
- #:use-module (guix import json)
#:use-module (guix packages)
#:use-module (guix upstream)
+ #:use-module (guix http-client)
#:use-module (web uri)
#:export (%github-updater))
+(define (json-fetch* url)
+ "Return a representation of the JSON resource URL (a list or hash table), or
+#f if URL returns 403 or 404."
+ (guard (c ((and (http-get-error? c)
+ (let ((error (http-get-error-code c)))
+ (or (= 403 error)
+ (= 404 error))))
+ #f)) ;; "expected" if there is an authentification error (403),
+ ;; or if package is unknown (404).
+ ;; Note: github.com returns 403 if we omit a 'User-Agent' header.
+ (let* ((port (http-fetch url))
+ (result (json->scm port)))
+ (close-port port)
+ result)))
+
(define (find-extension url)
"Return the extension of the archive e.g. '.tar.gz' given a URL, or
false if none is recognized"
(find (lambda (x) (string-suffix? x url))
- (list ".tar.gz" ".tar.bz2" ".tar.xz" ".zip" ".tar" ".tgz" ".love")))
+ (list ".tar.gz" ".tar.bz2" ".tar.xz" ".zip" ".tar"
+ ".tgz" ".tbz" ".love")))
(define (updated-github-url old-package new-version)
;; Return a url for the OLD-PACKAGE with NEW-VERSION. If no source url in
@@ -41,7 +58,7 @@ false if none is recognized"
(define (updated-url url)
(if (string-prefix? "https://github.com/" url)
- (let ((ext (find-extension url))
+ (let ((ext (or (find-extension url) ""))
(name (package-name old-package))
(version (package-version old-package))
(prefix (string-append "https://github.com/"
@@ -125,7 +142,7 @@ the package e.g. 'bedtools2'. Return #f if there is no releases"
"https://api.github.com/repos/"
(github-user-slash-repository url)
"/releases"))
- (json (json-fetch
+ (json (json-fetch*
(if token
(string-append api-url "?access_token=" token)
api-url))))
diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
index 9af78ea888..2c9df073d3 100644
--- a/guix/import/hackage.scm
+++ b/guix/import/hackage.scm
@@ -21,6 +21,7 @@
(define-module (guix import hackage)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
+ #:use-module (srfi srfi-34)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-1)
@@ -37,7 +38,13 @@
#:use-module (guix packages)
#:use-module ((guix utils) #:select (call-with-temporary-output-file))
#:export (hackage->guix-package
- %hackage-updater))
+ %hackage-updater
+
+ guix-package->hackage-name
+ hackage-fetch
+ hackage-source-url
+ hackage-cabal-url
+ hackage-package?))
(define ghc-standard-libraries
;; List of libraries distributed with ghc (7.10.2). We include GHC itself as
@@ -109,12 +116,15 @@ version is returned."
"Return the Cabal file for the package NAME-VERSION, or #f on failure. If
the version part is omitted from the package name, then return the latest
version."
- (let-values (((name version) (package-name->name+version name-version)))
- (let* ((url (hackage-cabal-url name version))
- (port (http-fetch url))
- (result (read-cabal (canonical-newline-port port))))
- (close-port port)
- result)))
+ (guard (c ((and (http-get-error? c)
+ (= 404 (http-get-error-code c)))
+ #f)) ;"expected" if package is unknown
+ (let-values (((name version) (package-name->name+version name-version)))
+ (let* ((url (hackage-cabal-url name version))
+ (port (http-fetch url))
+ (result (read-cabal (canonical-newline-port port))))
+ (close-port port)
+ result))))
(define string->license
;; List of valid values from
diff --git a/guix/import/json.scm b/guix/import/json.scm
index 5940f5e48f..c76bc9313c 100644
--- a/guix/import/json.scm
+++ b/guix/import/json.scm
@@ -29,7 +29,8 @@
(guard (c ((and (http-get-error? c)
(= 404 (http-get-error-code c)))
#f)) ;"expected" if package is unknown
- (let* ((port (http-fetch url))
+ (let* ((port (http-fetch url #:headers '((user-agent . "GNU Guile")
+ (Accept . "application/json"))))
(result (hash-table->alist (json->scm port))))
(close-port port)
result)))
diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm
index 7cce0fc594..1e433e3fb3 100644
--- a/guix/import/pypi.scm
+++ b/guix/import/pypi.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2015 Cyril Roelandt <tipecaml@gmail.com>
-;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -89,9 +89,16 @@ package."
(define (guix-package->pypi-name package)
"Given a Python PACKAGE built from pypi.python.org, return the name of the
package on PyPI."
- (let ((source-url (and=> (package-source package) origin-uri)))
+ (define (url->pypi-name url)
(hyphen-package-name->name+version
- (basename (file-sans-extension source-url)))))
+ (basename (file-sans-extension url))))
+
+ (match (and=> (package-source package) origin-uri)
+ ((? string? url)
+ (url->pypi-name url))
+ ((lst ...)
+ (any url->pypi-name lst))
+ (#f #f)))
(define (wheel-url->extracted-directory wheel-url)
(match (string-split (basename wheel-url) #\-)
@@ -227,10 +234,8 @@ name/variable pairs describing the required inputs of this package."
(sort
(map (lambda (input)
(list input (list 'unquote (string->symbol input))))
- (append '("python-setuptools")
- ;; Argparse has been part of Python since 2.7.
- (remove (cut string=? "python-argparse" <>)
- (guess-requirements source-url wheel-url tarball))))
+ (remove (cut string=? "python-argparse" <>)
+ (guess-requirements source-url wheel-url tarball)))
(lambda args
(match args
(((a _ ...) (b _ ...))
diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm
new file mode 100644
index 0000000000..542b718083
--- /dev/null
+++ b/guix/import/stackage.scm
@@ -0,0 +1,135 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 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 import stackage)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (guix import json)
+ #:use-module (guix import hackage)
+ #:use-module (guix memoization)
+ #:use-module (guix packages)
+ #:use-module (guix upstream)
+ #:use-module (guix ui)
+ #:export (stackage->guix-package
+ %stackage-updater))
+
+
+;;;
+;;; Stackage info fetcher and access functions
+;;;
+
+(define %stackage-url "http://www.stackage.org")
+
+(define (lts-info-ghc-version lts-info)
+ "Retruns the version of the GHC compiler contained in LTS-INFO."
+ (match lts-info
+ ((("snapshot" ("ghc" . version) _ _) _) version)
+ (_ #f)))
+
+(define (lts-info-packages lts-info)
+ "Retruns the alist of packages contained in LTS-INFO."
+ (match lts-info
+ ((_ ("packages" pkg ...)) pkg)
+ (_ '())))
+
+(define stackage-lts-info-fetch
+ ;; "Retrieve the information about the LTS Stackage release VERSION."
+ (memoize
+ (lambda* (#:optional (version ""))
+ (let* ((url (if (string=? "" version)
+ (string-append %stackage-url "/lts")
+ (string-append %stackage-url "/lts-" version)))
+ (lts-info (json-fetch url)))
+ (if lts-info
+ (reverse lts-info)
+ (leave (_ "LTS release version not found: ~A~%") version))))))
+
+(define (stackage-package-name pkg-info)
+ (assoc-ref pkg-info "name"))
+
+(define (stackage-package-version pkg-info)
+ (assoc-ref pkg-info "version"))
+
+(define (lts-package-version pkgs-info name)
+ "Return the version of the package with upstream NAME included in PKGS-INFO."
+ (let ((pkg (find (lambda (pkg) (string=? (stackage-package-name pkg) name))
+ pkgs-info)))
+ (stackage-package-version pkg)))
+
+
+;;;
+;;; Importer entry point
+;;;
+
+(define (hackage-name-version name version)
+ (and version (string-append name "@" version)))
+
+(define* (stackage->guix-package package-name ; upstream name
+ #:key
+ (include-test-dependencies? #t)
+ (lts-version "")
+ (packages-info
+ (lts-info-packages
+ (stackage-lts-info-fetch lts-version))))
+ "Fetch Cabal file for PACKAGE-NAME from hackage.haskell.org. The retrieved
+vesion corresponds to the version of PACKAGE-NAME specified in the LTS-VERSION
+release at stackage.org. Return the `package' S-expression corresponding to
+that package, or #f on failure. PACKAGES-INFO is the alist with the packages
+included in the Stackage LTS release."
+ (let* ((version (lts-package-version packages-info package-name))
+ (name-version (hackage-name-version package-name version)))
+ (if name-version
+ (hackage->guix-package name-version
+ #:include-test-dependencies?
+ include-test-dependencies?)
+ (leave (_ "package not found: ~A~%") package-name))))
+
+
+;;;
+;;; Updater
+;;;
+
+(define latest-lts-release
+ (let ((pkgs-info (mlambda () (lts-info-packages (stackage-lts-info-fetch)))))
+ (lambda* (package)
+ "Return an <upstream-source> for the latest Stackage LTS release of
+PACKAGE or #f it the package is not inlucded in the Stackage LTS release."
+ (let* ((hackage-name (guix-package->hackage-name package))
+ (version (lts-package-version (pkgs-info) hackage-name))
+ (name-version (hackage-name-version hackage-name version)))
+ (match (and=> name-version hackage-fetch)
+ (#f (format (current-error-port)
+ "warning: failed to parse ~a~%"
+ (hackage-cabal-url hackage-name))
+ #f)
+ (_ (let ((url (hackage-source-url hackage-name version)))
+ (upstream-source
+ (package (package-name package))
+ (version version)
+ (urls (list url))))))))))
+
+(define %stackage-updater
+ (upstream-updater
+ (name 'stackage)
+ (description "Updater for Stackage LTS packages")
+ (pred hackage-package?)
+ (latest latest-lts-release)))
+
+;;; stackage.scm ends here
diff --git a/guix/licenses.scm b/guix/licenses.scm
index 1e19300586..7b2ac2d311 100644
--- a/guix/licenses.scm
+++ b/guix/licenses.scm
@@ -8,7 +8,7 @@
;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
;;; Copyright © 2016 Fabian Harfert <fhmgufs@web.de>
;;; Copyright © 2016 Rene Saavedra <rennes@openmailbox.org>
-;;; Copyright © 2016 ng0 <ngillmann@runbox.com>
+;;; Copyright © 2016, 2017 ng0 <ng0@libertad.pw>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -74,7 +74,8 @@
x11 x11-style
zpl2.1
zlib
- fsf-free))
+ fsf-free
+ wtfpl2))
(define-record-type <license>
(license name uri comment)
@@ -450,6 +451,11 @@ at URI, which may be a file:// URI pointing the package's tree."
"https://unlicense.org/"
"https://www.gnu.org/licenses/license-list.html#Unlicense"))
+(define wtfpl2
+ (license "WTFPL 2"
+ "http://www.wtfpl.net"
+ "http://www.wtfpl.net/about/"))
+
(define x11
(license "X11"
"http://directory.fsf.org/wiki/License:X11"
diff --git a/guix/memoization.scm b/guix/memoization.scm
new file mode 100644
index 0000000000..d64f60fe9c
--- /dev/null
+++ b/guix/memoization.scm
@@ -0,0 +1,114 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 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 memoization)
+ #:export (memoize
+ mlambda
+ mlambdaq))
+
+(define-syntax-rule (call/mv thunk)
+ (call-with-values thunk list))
+(define-syntax-rule (return/mv lst)
+ (apply values lst))
+
+(define-syntax-rule (call/1 thunk)
+ (thunk))
+(define-syntax-rule (return/1 value)
+ value)
+
+(define %nothing ;nothingness
+ (list 'this 'is 'nothing))
+
+(define-syntax define-cache-procedure
+ (syntax-rules ()
+ "Define a procedure NAME that implements a cache using HASH-REF and
+HASH-SET!. Use CALL to invoke the thunk and RETURN to return its value; CALL
+and RETURN are used to distinguish between multiple-value and single-value
+returns."
+ ((_ name hash-ref hash-set! call return)
+ (define (name cache key thunk)
+ "Cache the result of THUNK under KEY in CACHE, or return the
+already-cached result."
+ (let ((results (hash-ref cache key %nothing)))
+ (if (eq? results %nothing)
+ (let ((results (call thunk)))
+ (hash-set! cache key results)
+ (return results))
+ (return results)))))
+ ((_ name hash-ref hash-set!)
+ (define-cache-procedure name hash-ref hash-set!
+ call/mv return/mv))))
+
+(define-cache-procedure cached/mv hash-ref hash-set!)
+(define-cache-procedure cachedq/mv hashq-ref hashq-set!)
+(define-cache-procedure cached hash-ref hash-set! call/1 return/1)
+(define-cache-procedure cachedq hashq-ref hashq-set! call/1 return/1)
+
+(define (memoize proc)
+ "Return a memoizing version of PROC.
+
+This is a generic version of 'mlambda' what works regardless of the arity of
+'proc'. It is more expensive since the argument list is always allocated, and
+the result is returned via (apply values results)."
+ (let ((cache (make-hash-table)))
+ (lambda args
+ (cached/mv cache args
+ (lambda ()
+ (apply proc args))))))
+
+(define-syntax %mlambda
+ (syntax-rules ()
+ "Return a memoizing lambda. This is restricted to procedures that return
+exactly one value."
+ ((_ cached () body ...)
+ ;; The zero-argument case is equivalent to a promise.
+ (let ((result #f) (cached? #f))
+ (lambda ()
+ (unless cached?
+ (set! result (begin body ...))
+ (set! cached? #t))
+ result)))
+
+ ;; Optimize the fixed-arity case such that there's no argument list
+ ;; allocated. XXX: We can't really avoid the closure allocation since
+ ;; Guile 2.0's compiler will always keep it.
+ ((_ cached (arg) body ...) ;one argument
+ (let ((cache (make-hash-table))
+ (proc (lambda (arg) body ...)))
+ (lambda (arg)
+ (cached cache arg (lambda () (proc arg))))))
+ ((_ _ (args ...) body ...) ;two or more arguments
+ (let ((cache (make-hash-table))
+ (proc (lambda (args ...) body ...)))
+ (lambda (args ...)
+ ;; XXX: Always use 'cached', which uses 'equal?', to compare the
+ ;; argument lists.
+ (cached cache (list args ...)
+ (lambda ()
+ (proc args ...))))))))
+
+(define-syntax-rule (mlambda formals body ...)
+ "Define a memoizing lambda. The lambda's arguments are compared with
+'equal?', and BODY is expected to yield a single return value."
+ (%mlambda cached formals body ...))
+
+(define-syntax-rule (mlambdaq formals body ...)
+ "Define a memoizing lambda. If FORMALS lists a single argument, it is
+compared using 'eq?'; otherwise, the argument list is compared using 'equal?'.
+BODY is expected to yield a single return value."
+ (%mlambda cachedq formals body ...))
diff --git a/guix/modules.scm b/guix/modules.scm
index 24f613ff4e..8c63f21a97 100644
--- a/guix/modules.scm
+++ b/guix/modules.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -17,7 +17,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix modules)
- #:use-module ((guix utils) #:select (memoize))
+ #:use-module (guix memoization)
#:use-module (guix sets)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
@@ -71,18 +71,17 @@ CLAUSES."
result)))))
(define module-file-dependencies
- (memoize
- (lambda (file)
- "Return the list of the names of modules that the Guile module in FILE
+ (mlambda (file)
+ "Return the list of the names of modules that the Guile module in FILE
depends on."
- (call-with-input-file file
- (lambda (port)
- (match (read port)
- (('define-module name clauses ...)
- (extract-dependencies clauses))
- ;; XXX: R6RS 'library' form is ignored.
- (_
- '())))))))
+ (call-with-input-file file
+ (lambda (port)
+ (match (read port)
+ (('define-module name clauses ...)
+ (extract-dependencies clauses))
+ ;; XXX: R6RS 'library' form is ignored.
+ (_
+ '()))))))
(define (module-name->file-name module)
"Return the file name for MODULE."
diff --git a/guix/packages.scm b/guix/packages.scm
index beb958f156..4bc4b017f4 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
@@ -28,6 +28,7 @@
#:use-module (guix base32)
#:use-module (guix grafts)
#:use-module (guix derivations)
+ #:use-module (guix memoization)
#:use-module (guix build-system)
#:use-module (guix search-paths)
#:use-module (guix gexp)
@@ -62,6 +63,7 @@
package
package?
package-name
+ package-upstream-name
package-version
package-full-name
package-source
@@ -296,6 +298,12 @@ name of its URI."
package)
16)))))
+(define (package-upstream-name package)
+ "Return the upstream name of PACKAGE, which could be different from the name
+it has in Guix."
+ (or (assq-ref (package-properties package) 'upstream-name)
+ (package-name package)))
+
(define (hidden-package p)
"Return a \"hidden\" version of P--i.e., one that 'fold-packages' and thus,
user interfaces, ignores."
@@ -690,38 +698,19 @@ in INPUTS and their transitive propagated inputs."
`(assoc-ref ,alist ,(label input)))
(transitive-inputs inputs)))
-(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-memoized/v (package-transitive-supported-systems package)
- "Return the intersection of the systems supported by PACKAGE and those
+(define package-transitive-supported-systems
+ (mlambdaq (package)
+ "Return the intersection of the systems supported by PACKAGE and those
supported by its dependencies."
- (fold (lambda (input systems)
- (match input
- ((label (? package? p) . _)
- (lset-intersection
- string=? systems (package-transitive-supported-systems p)))
- (_
- systems)))
- (package-supported-systems package)
- (bag-direct-inputs (package->bag package))))
+ (fold (lambda (input systems)
+ (match input
+ ((label (? package? p) . _)
+ (lset-intersection
+ string=? systems (package-transitive-supported-systems p)))
+ (_
+ systems)))
+ (package-supported-systems package)
+ (bag-direct-inputs (package->bag package)))))
(define* (supported-package? package #:optional (system (%current-system)))
"Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its
@@ -768,14 +757,15 @@ package and returns its new name after rewrite."
(_
input)))
- (define-memoized/v (replace p)
- "Return a variant of P with its inputs rewritten."
- (package
- (inherit p)
- (name (rewrite-name (package-name p)))
- (inputs (map rewrite (package-inputs p)))
- (native-inputs (map rewrite (package-native-inputs p)))
- (propagated-inputs (map rewrite (package-propagated-inputs p)))))
+ (define replace
+ (mlambdaq (p)
+ ;; Return a variant of P with its inputs rewritten.
+ (package
+ (inherit p)
+ (name (rewrite-name (package-name p)))
+ (inputs (map rewrite (package-inputs p)))
+ (native-inputs (map rewrite (package-native-inputs p)))
+ (propagated-inputs (map rewrite (package-propagated-inputs p))))))
replace)
diff --git a/guix/profiles.scm b/guix/profiles.scm
index e7707b6543..de82eae348 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -92,6 +92,7 @@
profile-manifest
package->manifest-entry
packages->manifest
+ ca-certificate-bundle
%default-profile-hooks
profile-derivation
@@ -738,7 +739,7 @@ for both major versions of GTK+."
(mlet %store-monad ((gtk+ (manifest-lookup-package manifest "gtk+" "3"))
(gtk+-2 (manifest-lookup-package manifest "gtk+" "2")))
- (define (build gtk gtk-version)
+ (define (build gtk gtk-version query)
(let ((major (string-take gtk-version 1)))
(with-imported-modules '((guix build utils)
(guix build union)
@@ -755,8 +756,6 @@ for both major versions of GTK+."
(let* ((prefix (string-append "/lib/gtk-" #$major ".0/"
#$gtk-version))
- (query (string-append #$gtk "/bin/gtk-query-immodules-"
- #$major ".0"))
(destdir (string-append #$output prefix))
(moddirs (cons (string-append #$gtk prefix "/immodules")
(filter file-exists?
@@ -767,7 +766,7 @@ for both major versions of GTK+."
;; Generate a new immodules cache file.
(mkdir-p (string-append #$output prefix))
- (let ((pipe (apply open-pipe* OPEN_READ query modules))
+ (let ((pipe (apply open-pipe* OPEN_READ #$query modules))
(outfile (string-append #$output prefix
"/immodules-gtk" #$major ".cache")))
(dynamic-wind
@@ -782,9 +781,23 @@ for both major versions of GTK+."
(close-pipe pipe)))))))))
;; Don't run the hook when there's nothing to do.
- (let ((gexp #~(begin
- #$(if gtk+ (build gtk+ "3.0.0") #t)
- #$(if gtk+-2 (build gtk+-2 "2.10.0") #t))))
+ (let* ((pkg-gtk+ (module-ref ; lazy reference
+ (resolve-interface '(gnu packages gtk)) 'gtk+))
+ (gexp #~(begin
+ #$(if gtk+
+ (build
+ gtk+ "3.0.0"
+ ;; Use 'gtk-query-immodules-3.0' from the 'bin'
+ ;; output of latest gtk+ package.
+ #~(string-append
+ #$pkg-gtk+:bin "/bin/gtk-query-immodules-3.0"))
+ #t)
+ #$(if gtk+-2
+ (build
+ gtk+-2 "2.10.0"
+ #~(string-append
+ #$gtk+-2 "/bin/gtk-query-immodules-2.0"))
+ #t))))
(if (or gtk+ gtk+-2)
(gexp->derivation "gtk-im-modules" gexp
#:local-build? #t
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index ccb4c275fc..68402fda18 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
@@ -24,7 +24,6 @@
#:use-module (guix derivations)
#:use-module (guix packages)
#:use-module (guix grafts)
- #:use-module (guix combinators)
;; Use the procedure that destructures "NAME-VERSION" forms.
#:use-module ((guix utils) #:hide (package-name->name+version))
@@ -99,8 +98,10 @@ found. Return #f if no build log was found."
(define (register-root store paths root)
"Register ROOT as an indirect GC root for all of PATHS."
- (let* ((root (string-append (canonicalize-path (dirname root))
- "/" root)))
+ (let* ((root (if (string-prefix? "/" root)
+ root
+ (string-append (canonicalize-path (dirname root))
+ "/" root))))
(catch 'system-error
(lambda ()
(match paths
@@ -344,8 +345,8 @@ options handled by 'set-build-options-from-command-line', and listed in
#:keep-failed? (assoc-ref opts 'keep-failed?)
#:keep-going? (assoc-ref opts 'keep-going?)
#:rounds (assoc-ref opts 'rounds)
- #:build-cores (or (assoc-ref opts 'cores) 0)
- #:max-build-jobs (or (assoc-ref opts 'max-jobs) 1)
+ #:build-cores (assoc-ref opts 'cores)
+ #:max-build-jobs (assoc-ref opts 'max-jobs)
#:fallback? (assoc-ref opts 'fallback?)
#:use-substitutes? (assoc-ref opts 'substitutes?)
#:substitute-urls (assoc-ref opts 'substitute-urls)
@@ -462,7 +463,6 @@ options handled by 'set-build-options-from-command-line', and listed in
(substitutes? . #t)
(build-hook? . #t)
(print-build-trace? . #t)
- (max-silent-time . 3600)
(verbosity . 0)))
(define (show-help)
@@ -487,6 +487,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(display (_ "
--check rebuild items to check for non-determinism issues"))
(display (_ "
+ --repair repair the specified items"))
+ (display (_ "
-r, --root=FILE make FILE a symlink to the result, and register it
as a garbage collector root"))
(display (_ "
@@ -536,6 +538,12 @@ must be one of 'package', 'all', or 'transitive'~%")
(alist-cons 'build-mode (build-mode check)
result)
rest)))
+ (option '("repair") #f #f
+ (lambda (opt name arg result . rest)
+ (apply values
+ (alist-cons 'build-mode (build-mode repair)
+ result)
+ rest)))
(option '(#\s "system") #t #f
(lambda (opt name arg result)
(alist-cons 'system arg
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index 9ab4fbe2a9..815bb789c3 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -37,12 +37,17 @@
#:use-module (ice-9 vlist)
#:use-module (ice-9 format)
#:use-module (web uri)
- #:export (discrepancies
+ #:export (compare-contents
- discrepancy?
- discrepancy-item
- discrepancy-local-sha256
- discrepancy-narinfos
+ comparison-report?
+ comparison-report-item
+ comparison-report-result
+ comparison-report-local-sha256
+ comparison-report-narinfos
+
+ comparison-report-match?
+ comparison-report-mismatch?
+ comparison-report-inconclusive?
guix-challenge))
@@ -61,13 +66,38 @@
(define ensure-store-item ;XXX: move to (guix ui)?
(@@ (guix scripts size) ensure-store-item))
-;; Representation of a hash mismatch for ITEM.
-(define-record-type <discrepancy>
- (discrepancy item local-sha256 narinfos)
- discrepancy?
- (item discrepancy-item) ;string, /gnu/store/… item
- (local-sha256 discrepancy-local-sha256) ;bytevector | #f
- (narinfos discrepancy-narinfos)) ;list of <narinfo>
+;; Representation of a comparison report for ITEM.
+(define-record-type <comparison-report>
+ (%comparison-report item result local-sha256 narinfos)
+ comparison-report?
+ (item comparison-report-item) ;string, /gnu/store/… item
+ (result comparison-report-result) ;'match | 'mismatch | 'inconclusive
+ (local-sha256 comparison-report-local-sha256) ;bytevector | #f
+ (narinfos comparison-report-narinfos)) ;list of <narinfo>
+
+(define-syntax comparison-report
+ ;; Some sort of a an enum to make sure 'result' is correct.
+ (syntax-rules (match mismatch inconclusive)
+ ((_ item 'match rest ...)
+ (%comparison-report item 'match rest ...))
+ ((_ item 'mismatch rest ...)
+ (%comparison-report item 'mismatch rest ...))
+ ((_ item 'inconclusive rest ...)
+ (%comparison-report item 'inconclusive rest ...))))
+
+(define (comparison-report-predicate result)
+ "Return a predicate that returns true when pass a REPORT that has RESULT."
+ (lambda (report)
+ (eq? (comparison-report-result report) result)))
+
+(define comparison-report-mismatch?
+ (comparison-report-predicate 'mismatch))
+
+(define comparison-report-match?
+ (comparison-report-predicate 'match))
+
+(define comparison-report-inconclusive?
+ (comparison-report-predicate 'inconclusive))
(define (locally-built? store item)
"Return true if ITEM was built locally."
@@ -88,10 +118,10 @@ Otherwise return #f."
(define-syntax-rule (report args ...)
(format (current-error-port) args ...))
-(define (discrepancies items servers)
+(define (compare-contents items servers)
"Challenge the substitute servers whose URLs are listed in SERVERS by
comparing the hash of the substitutes of ITEMS that they serve. Return the
-list of discrepancies.
+list of <comparison-report> objects.
This procedure does not authenticate narinfos from SERVERS, nor does it verify
that they are signed by an authorized public keys. The reason is that, by
@@ -100,11 +130,7 @@ taken since we do not import the archives."
(define (compare item reference)
;; Return a procedure to compare the hash of ITEM with REFERENCE.
(lambda (narinfo url)
- (if (not narinfo)
- (begin
- (warning (_ "~a: no substitute at '~a'~%")
- item url)
- #t)
+ (or (not narinfo)
(let ((value (narinfo-hash->sha256 (narinfo-hash narinfo))))
(bytevector=? reference value)))))
@@ -116,9 +142,7 @@ taken since we do not import the archives."
((url urls ...)
(if (not first)
(select-reference item narinfos urls)
- (narinfo-hash->sha256 (narinfo-hash first))))))
- (()
- (warning (_ "no substitutes for '~a'; cannot conclude~%") item))))
+ (narinfo-hash->sha256 (narinfo-hash first))))))))
(mlet* %store-monad ((local (mapm %store-monad
query-locally-built-hash items))
@@ -130,42 +154,61 @@ taken since we do not import the archives."
vhash))
vlist-null
remote)))
- (return (filter-map (lambda (item local)
- (let ((narinfos (vhash-fold* cons '() item narinfos)))
- (define reference
- (or local
- (begin
- (warning (_ "no local build for '~a'~%") item)
- (select-reference item narinfos servers))))
-
- (if (every (compare item reference)
- narinfos servers)
- #f
- (discrepancy item local narinfos))))
- items
- local))))
-
-(define* (summarize-discrepancy discrepancy
- #:key (hash->string
- bytevector->nix-base32-string))
- "Write to the current error port a summary of DISCREPANCY, a <discrepancy>
-object that denotes a hash mismatch."
- (match discrepancy
- (($ <discrepancy> item local (narinfos ...))
+ (return (map (lambda (item local)
+ (match (vhash-fold* cons '() item narinfos)
+ (() ;no substitutes
+ (comparison-report item 'inconclusive local '()))
+ ((narinfo)
+ (if local
+ (if ((compare item local) narinfo (first servers))
+ (comparison-report item 'match
+ local (list narinfo))
+ (comparison-report item 'mismatch
+ local (list narinfo)))
+ (comparison-report item 'inconclusive
+ local (list narinfo))))
+ ((narinfos ...)
+ (let ((reference
+ (or local (select-reference item narinfos
+ servers))))
+ (if (every (compare item reference) narinfos servers)
+ (comparison-report item 'match
+ local narinfos)
+ (comparison-report item 'mismatch
+ local narinfos))))))
+ items
+ local))))
+
+(define* (summarize-report comparison-report
+ #:key
+ (hash->string bytevector->nix-base32-string)
+ verbose?)
+ "Write to the current error port a summary of REPORT, a <comparison-report>
+object. When VERBOSE?, display matches in addition to mismatches and
+inconclusive reports."
+ (define (report-hashes item local narinfos)
+ (if local
+ (report (_ " local hash: ~a~%") (hash->string local))
+ (report (_ " no local build for '~a'~%") item))
+ (for-each (lambda (narinfo)
+ (report (_ " ~50a: ~a~%")
+ (uri->string (narinfo-uri narinfo))
+ (hash->string
+ (narinfo-hash->sha256 (narinfo-hash narinfo)))))
+ narinfos))
+
+ (match comparison-report
+ (($ <comparison-report> item 'mismatch local (narinfos ...))
(report (_ "~a contents differ:~%") item)
- (if local
- (report (_ " local hash: ~a~%") (hash->string local))
- (warning (_ "no local build for '~a'~%") item))
-
- (for-each (lambda (narinfo)
- (if narinfo
- (report (_ " ~50a: ~a~%")
- (uri->string (narinfo-uri narinfo))
- (hash->string
- (narinfo-hash->sha256 (narinfo-hash narinfo))))
- (report (_ " ~50a: unavailable~%")
- (uri->string (narinfo-uri narinfo)))))
- narinfos))))
+ (report-hashes item local narinfos))
+ (($ <comparison-report> item 'inconclusive #f narinfos)
+ (warning (_ "could not challenge '~a': no local build~%") item))
+ (($ <comparison-report> item 'inconclusive locals ())
+ (warning (_ "could not challenge '~a': no substitutes~%") item))
+ (($ <comparison-report> item 'match local (narinfos ...))
+ (when verbose?
+ (report (_ "~a contents match:~%") item)
+ (report-hashes item local narinfos)))))
;;;
@@ -178,6 +221,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
(display (_ "
--substitute-urls=URLS
compare build results with those at URLS"))
+ (display (_ "
+ -v, --verbose show details about successful comparisons"))
(newline)
(display (_ "
-h, --help display this help and exit"))
@@ -201,6 +246,11 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
(alist-cons 'substitute-urls
(string-tokenize arg)
(alist-delete 'substitute-urls result))
+ rest)))
+ (option '("verbose" #\v) #f #f
+ (lambda (opt name arg result . rest)
+ (apply values
+ (alist-cons 'verbose? #t result)
rest)))))
(define %default-options
@@ -220,7 +270,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
(_ #f))
opts))
(system (assoc-ref opts 'system))
- (urls (assoc-ref opts 'substitute-urls)))
+ (urls (assoc-ref opts 'substitute-urls))
+ (verbose? (assoc-ref opts 'verbose?)))
(leave-on-EPIPE
(with-store store
;; Disable grafts since substitute servers normally provide only
@@ -236,13 +287,15 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
#:use-substitutes? #f)
(run-with-store store
- (mlet* %store-monad ((items (mapm %store-monad
- ensure-store-item files))
- (issues (discrepancies items urls)))
- (for-each summarize-discrepancy issues)
- (unless (null? issues)
- (exit 2))
- (return (null? issues)))
+ (mlet* %store-monad ((items (mapm %store-monad
+ ensure-store-item files))
+ (reports (compare-contents items urls)))
+ (for-each (cut summarize-report <> #:verbose? verbose?)
+ reports)
+
+ (exit (cond ((any comparison-report-mismatch? reports) 2)
+ ((every comparison-report-match? reports) 0)
+ (else 1))))
#:system system))))))))
;;; challenge.scm ends here
diff --git a/guix/scripts/container/exec.scm b/guix/scripts/container/exec.scm
index 10e70568cc..d6d267daff 100644
--- a/guix/scripts/container/exec.scm
+++ b/guix/scripts/container/exec.scm
@@ -74,7 +74,14 @@ and the other containing arguments for the command to be executed."
(let* ((opts (parse-command-line args %options '(())
#:argument-handler
handle-argument))
- (pid (assoc-ref opts 'pid)))
+ (pid (assoc-ref opts 'pid))
+ (environment (filter-map (lambda (name)
+ (let ((value (getenv name)))
+ (and value (cons name value))))
+ ;; Pass through the TERM environment
+ ;; variable to inform processes about
+ ;; the capabilities of the terminal.
+ '("TERM"))))
(unless pid
(leave (_ "no pid specified~%")))
@@ -89,6 +96,10 @@ and the other containing arguments for the command to be executed."
(lambda ()
(match command
((program . program-args)
+ (for-each (match-lambda
+ ((name . value)
+ (setenv name value)))
+ environment)
(apply execlp program program program-args)))))))
(unless (zero? result)
(leave (_ "exec failed with status ~d~%") result)))))))
diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm
index 9ae204e6c6..624ef73e96 100644
--- a/guix/scripts/copy.scm
+++ b/guix/scripts/copy.scm
@@ -63,8 +63,8 @@ Throw an error on failure."
(match (connect! session)
('ok
- ;; Let the SSH agent authenticate us to the server.
- (match (userauth-agent! session)
+ ;; Use public key authentication, via the SSH agent if it's available.
+ (match (userauth-public-key/auto! session)
('success
session)
(x
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 1d3be6a84f..44f490043c 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015 David Thompson <davet@gnu.org>
-;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -60,12 +60,6 @@ directories in PROFILE, the store path of a profile."
(define %default-shell
(or (getenv "SHELL") "/bin/sh"))
-(define %network-configuration-files
- '("/etc/resolv.conf"
- "/etc/nsswitch.conf"
- "/etc/services"
- "/etc/hosts"))
-
(define (purify-environment)
"Unset almost all environment variables. A small number of variables such
as 'HOME' and 'USER' are left untouched."
@@ -408,21 +402,7 @@ host file systems to mount inside the container."
;; When in Rome, do as Nix build.cc does: Automagically
;; map common network configuration files.
(if network?
- (filter-map (lambda (file)
- (and (file-exists? file)
- (file-system-mapping
- (source file)
- (target file)
- ;; XXX: On some GNU/Linux
- ;; systems, /etc/resolv.conf is a
- ;; symlink to a file in a tmpfs
- ;; which, for an unknown reason,
- ;; cannot be bind mounted
- ;; read-only within the
- ;; container.
- (writable?
- (string=? "/etc/resolv.conf")))))
- %network-configuration-files)
+ %network-file-mappings
'())
;; Mappings for the union closure of all inputs.
(map (lambda (dir)
@@ -432,7 +412,8 @@ host file systems to mount inside the container."
(writable? #f)))
reqs)))
(file-systems (append %container-file-systems
- (map mapping->file-system mappings))))
+ (map file-system-mapping->bind-mount
+ mappings))))
(exit/status
(call-with-container file-systems
(lambda ()
@@ -531,8 +512,10 @@ message if any test fails."
(define (register-gc-root target root)
"Make ROOT an indirect root to TARGET. This is procedure is idempotent."
- (let* ((root (string-append (canonicalize-path (dirname root))
- "/" root)))
+ (let* ((root (if (string-prefix? "/" root)
+ root
+ (string-append (canonicalize-path (dirname root))
+ "/" root))))
(catch 'system-error
(lambda ()
(symlink target root)
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 79ce503a2e..9804d41929 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -21,12 +21,12 @@
#:use-module (guix graph)
#:use-module (guix grafts)
#:use-module (guix scripts)
- #:use-module (guix combinators)
#:use-module (guix packages)
#:use-module (guix monads)
#:use-module (guix store)
#:use-module (guix gexp)
#:use-module (guix derivations)
+ #:use-module (guix memoization)
#:use-module ((guix build-system gnu) #:select (standard-packages))
#:use-module (gnu packages)
#:use-module (guix sets)
@@ -191,12 +191,11 @@ Dependencies may include packages, origin, and file names."
%store-monad))))
(define standard-package-set
- (memoize
- (lambda ()
- "Return the set of standard packages provided by GNU-BUILD-SYSTEM."
- (match (standard-packages)
- (((labels packages . output) ...)
- (list->setq packages))))))
+ (mlambda ()
+ "Return the set of standard packages provided by GNU-BUILD-SYSTEM."
+ (match (standard-packages)
+ (((labels packages . output) ...)
+ (list->setq packages)))))
(define (bag-node-edges-sans-bootstrap thing)
"Like 'bag-node-edges', but pretend that the standard packages of
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index 4d07e0fd69..8c2f705738 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -73,7 +73,8 @@ rather than \\n."
;;; Entry point.
;;;
-(define importers '("gnu" "nix" "pypi" "cpan" "hackage" "elpa" "gem" "cran" "crate"))
+(define importers '("gnu" "nix" "pypi" "cpan" "hackage" "stackage" "elpa" "gem"
+ "cran" "crate"))
(define (resolve-importer name)
(let ((module (resolve-interface
diff --git a/guix/scripts/import/stackage.scm b/guix/scripts/import/stackage.scm
new file mode 100644
index 0000000000..cf47bff259
--- /dev/null
+++ b/guix/scripts/import/stackage.scm
@@ -0,0 +1,115 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 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 scripts import stackage)
+ #:use-module (guix ui)
+ #:use-module (guix utils)
+ #:use-module (guix packages)
+ #:use-module (guix scripts)
+ #:use-module (guix import stackage)
+ #:use-module (guix scripts import)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-37)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 format)
+ #:export (guix-import-stackage))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+ `((lts-version . "")
+ (include-test-dependencies? . #t)))
+
+(define (show-help)
+ (display (_ "Usage: guix import stackage PACKAGE-NAME
+Import and convert the LTS Stackage package for PACKAGE-NAME.\n"))
+ (display (_ "
+ -r VERSION, --lts-version=VERSION
+ specify the LTS version to use"))
+ (display (_ "
+ -h, --help display this help and exit"))
+ (display (_ "
+ -t, --no-test-dependencies don't include test-only dependencies"))
+ (display (_ "
+ -V, --version display version information and exit"))
+ (newline)
+ (show-bug-report-information))
+
+(define %options
+ ;; Specification of the command-line options.
+ (cons* (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda args
+ (show-version-and-exit "guix import stackage")))
+ (option '(#\t "no-test-dependencies") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'include-test-dependencies? #f
+ (alist-delete 'include-test-dependencies?
+ result))))
+ (option '(#\r "lts-version") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'lts-version arg
+ (alist-delete 'lts-version
+ result))))
+ %standard-import-options))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-import-stackage . args)
+ (define (parse-options)
+ ;; Return the alist of option values.
+ (args-fold* args %options
+ (lambda (opt name arg result)
+ (leave (_ "~A: unrecognized option~%") name))
+ (lambda (arg result)
+ (alist-cons 'argument arg result))
+ %default-options))
+
+ (let* ((opts (parse-options))
+ (args (filter-map (match-lambda
+ (('argument . value)
+ value)
+ (_ #f))
+ (reverse opts))))
+ (match args
+ ((package-name)
+ (let ((sexp (stackage->guix-package
+ package-name
+ #:include-test-dependencies?
+ (assoc-ref opts 'include-test-dependencies?)
+ #:lts-version (assoc-ref opts 'lts-version))))
+ (unless sexp
+ (leave (_ "failed to download cabal file for package '~a'~%")
+ package-name))
+ sexp))
+ (()
+ (leave (_ "too few arguments~%")))
+ ((many ...)
+ (leave (_ "too many arguments~%"))))))
+
+;;; stackage.scm ends here
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 9b991786c3..776e7332c5 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org>
;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
@@ -32,7 +32,7 @@
#:use-module (guix records)
#:use-module (guix ui)
#:use-module (guix utils)
- #:use-module (guix combinators)
+ #:use-module (guix memoization)
#:use-module (guix scripts)
#:use-module (guix gnu-maintenance)
#:use-module (guix monads)
@@ -90,9 +90,9 @@
;; provided MESSAGE.
(let ((loc (or (package-field-location package field)
(package-location package))))
- (format (guix-warning-port) "~a: ~a: ~a~%"
+ (format (guix-warning-port) "~a: ~a@~a: ~a~%"
(location->string loc)
- (package-full-name package)
+ (package-name package) (package-version package)
message)))
(define (call-with-accumulated-warnings thunk)
@@ -559,12 +559,11 @@ patch could not be found."
str)))
(define official-gnu-packages*
- (memoize
- (lambda ()
- "A memoizing version of 'official-gnu-packages' that returns the empty
+ (mlambda ()
+ "A memoizing version of 'official-gnu-packages' that returns the empty
list when something goes wrong, such as a networking issue."
- (let ((gnus (false-if-exception (official-gnu-packages))))
- (or gnus '())))))
+ (let ((gnus (false-if-exception (official-gnu-packages))))
+ (or gnus '()))))
(define (check-gnu-synopsis+description package)
"Make sure that, if PACKAGE is a GNU package, it uses the synopsis and
@@ -959,12 +958,12 @@ or a list thereof")
(define* (run-checkers package #:optional (checkers %checkers))
"Run the given CHECKERS on PACKAGE."
- (let ((tty? (isatty? (current-error-port)))
- (name (package-full-name package)))
+ (let ((tty? (isatty? (current-error-port))))
(for-each (lambda (checker)
(when tty?
- (format (current-error-port) "checking ~a [~a]...\x1b[K\r"
- name (lint-checker-name checker))
+ (format (current-error-port) "checking ~a@~a [~a]...\x1b[K\r"
+ (package-name package) (package-version package)
+ (lint-checker-name checker))
(force-output (current-error-port)))
((lint-checker-check checker) package))
checkers)
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index 0dd7eee974..4d3c695aaf 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -205,6 +205,7 @@ unavailable optional dependencies such as Guile-JSON."
%elpa-updater
%cran-updater
%bioconductor-updater
+ ((guix import stackage) => %stackage-updater)
%hackage-updater
((guix import cpan) => %cpan-updater)
((guix import pypi) => %pypi-updater)
diff --git a/guix/serialization.scm b/guix/serialization.scm
index 5953b84616..4cab5910f7 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -30,7 +30,7 @@
#:export (write-int read-int
write-long-long read-long-long
write-padding
- write-string
+ write-bytevector write-string
read-string read-latin1-string read-maybe-utf8-string
write-string-list read-string-list
write-string-pairs
@@ -102,15 +102,17 @@
(or (zero? m)
(put-bytevector p zero 0 (- 8 m)))))))
-(define (write-string s p)
- (let* ((s (string->utf8 s))
- (l (bytevector-length s))
+(define (write-bytevector s p)
+ (let* ((l (bytevector-length s))
(m (modulo l 8))
(b (make-bytevector (+ 8 l (if (zero? m) 0 (- 8 m))))))
(bytevector-u32-set! b 0 l (endianness little))
(bytevector-copy! s 0 b 8 l)
(put-bytevector p b)))
+(define (write-string s p)
+ (write-bytevector (string->utf8 s) p))
+
(define (read-byte-string p)
(let* ((len (read-int p))
(m (modulo len 8))
diff --git a/guix/store.scm b/guix/store.scm
index 49549d0771..cce460f3ce 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -19,7 +19,7 @@
(define-module (guix store)
#:use-module (guix utils)
#:use-module (guix config)
- #:use-module (guix combinators)
+ #:use-module (guix memoization)
#:use-module (guix serialization)
#:use-module (guix monads)
#:autoload (guix base32) (bytevector->base32-string)
@@ -67,6 +67,7 @@
query-path-hash
hash-part->path
query-path-info
+ add-data-to-store
add-text-to-store
add-to-store
build-things
@@ -138,7 +139,7 @@
direct-store-path
log-file))
-(define %protocol-version #x10f)
+(define %protocol-version #x161)
(define %worker-magic-1 #x6e697863) ; "nixc"
(define %worker-magic-2 #x6478696f) ; "dxio"
@@ -266,12 +267,15 @@
(path-info deriver hash refs registration-time nar-size)))
(define-syntax write-arg
- (syntax-rules (integer boolean string string-list string-pairs
+ (syntax-rules (integer boolean bytevector
+ string string-list string-pairs
store-path store-path-list base16)
((_ integer arg p)
(write-int arg p))
((_ boolean arg p)
(write-int (if arg 1 0) p))
+ ((_ bytevector arg p)
+ (write-bytevector arg p))
((_ string arg p)
(write-string arg p))
((_ string-list arg p)
@@ -537,14 +541,14 @@ encoding conversion errors."
#:key keep-failed? keep-going? fallback?
(verbosity 0)
rounds ;number of build rounds
- (max-build-jobs 1)
+ max-build-jobs
timeout
- (max-silent-time 3600)
+ max-silent-time
(use-build-hook? #t)
(build-verbosity 0)
(log-type 0)
(print-build-trace #t)
- (build-cores (current-processor-count))
+ build-cores
(use-substitutes? #t)
;; Client-provided substitute URLs. If it is #f,
@@ -570,21 +574,37 @@ encoding conversion errors."
...)))))
(write-int (operation-id set-options) socket)
(send (boolean keep-failed?) (boolean keep-going?)
- (boolean fallback?) (integer verbosity)
- (integer max-build-jobs) (integer max-silent-time))
+ (boolean fallback?) (integer verbosity))
+ (when (< (nix-server-minor-version server) #x61)
+ (let ((max-build-jobs (or max-build-jobs 1))
+ (max-silent-time (or max-silent-time 3600)))
+ (send (integer max-build-jobs) (integer max-silent-time))))
(when (>= (nix-server-minor-version server) 2)
(send (boolean use-build-hook?)))
(when (>= (nix-server-minor-version server) 4)
(send (integer build-verbosity) (integer log-type)
(boolean print-build-trace)))
- (when (>= (nix-server-minor-version server) 6)
- (send (integer build-cores)))
+ (when (and (>= (nix-server-minor-version server) 6)
+ (< (nix-server-minor-version server) #x61))
+ (let ((build-cores (or build-cores (current-processor-count))))
+ (send (integer build-cores))))
(when (>= (nix-server-minor-version server) 10)
(send (boolean use-substitutes?)))
(when (>= (nix-server-minor-version server) 12)
(let ((pairs `(,@(if timeout
`(("build-timeout" . ,(number->string timeout)))
'())
+ ,@(if max-silent-time
+ `(("build-max-silent-time"
+ . ,(number->string max-silent-time)))
+ '())
+ ,@(if max-build-jobs
+ `(("build-max-jobs"
+ . ,(number->string max-build-jobs)))
+ '())
+ ,@(if build-cores
+ `(("build-cores" . ,(number->string build-cores)))
+ '())
,@(if substitute-urls
`(("substitute-urls"
. ,(string-join substitute-urls)))
@@ -653,25 +673,31 @@ string). Raise an error if no such path exists."
"Return the info (hash, references, etc.) for PATH."
path-info)
-(define add-text-to-store
+(define add-data-to-store
;; A memoizing version of `add-to-store', to avoid repeated RPCs with
;; the very same arguments during a given session.
(let ((add-text-to-store
- (operation (add-text-to-store (string name) (string text)
+ (operation (add-text-to-store (string name) (bytevector text)
(string-list references))
#f
store-path)))
- (lambda* (server name text #:optional (references '()))
- "Add TEXT under file NAME in the store, and return its store path.
+ (lambda* (server name bytes #:optional (references '()))
+ "Add BYTES under file NAME in the store, and return its store path.
REFERENCES is the list of store paths referred to by the resulting store
path."
- (let ((args `(,text ,name ,references))
- (cache (nix-server-add-text-to-store-cache server)))
+ (let* ((args `(,bytes ,name ,references))
+ (cache (nix-server-add-text-to-store-cache server)))
(or (hash-ref cache args)
- (let ((path (add-text-to-store server name text references)))
+ (let ((path (add-text-to-store server name bytes references)))
(hash-set! cache args path)
path))))))
+(define* (add-text-to-store store name text #:optional (references '()))
+ "Add TEXT under file NAME in the store, and return its store path.
+REFERENCES is the list of store paths referred to by the resulting store
+path."
+ (add-data-to-store store name (string->utf8 text) references))
+
(define true
;; Define it once and for all since we use it as a default value for
;; 'add-to-store' and want to make sure two default values are 'eq?' for the
@@ -1266,11 +1292,10 @@ valid inputs."
(define store-regexp*
;; The substituter makes repeated calls to 'store-path-hash-part', hence
;; this optimization.
- (memoize
- (lambda (store)
- "Return a regexp matching a file in STORE."
- (make-regexp (string-append "^" (regexp-quote store)
- "/([0-9a-df-np-sv-z]{32})-([^/]+)$")))))
+ (mlambda (store)
+ "Return a regexp matching a file in STORE."
+ (make-regexp (string-append "^" (regexp-quote store)
+ "/([0-9a-df-np-sv-z]{32})-([^/]+)$"))))
(define (store-path-package-name path)
"Return the package name part of PATH, a file name in the store."
diff --git a/guix/ui.scm b/guix/ui.scm
index 7d4c437354..6247944068 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -332,39 +332,39 @@ Report bugs to: ~a.") %guix-bug-report-address)
General help using GNU software: <http://www.gnu.org/gethelp/>"))
(newline))
+(define (augmented-system-error-handler file)
+ "Return a 'system-error' handler that mentions FILE in its message."
+ (lambda (key proc fmt args errno)
+ ;; Augment the FMT and ARGS with information about TARGET (this
+ ;; information is missing as of Guile 2.0.11, making the exception
+ ;; uninformative.)
+ (apply throw key proc "~A: ~S"
+ (list (strerror (car errno)) file)
+ (list errno))))
+
+(define-syntax-rule (error-reporting-wrapper proc (args ...) file)
+ "Wrap PROC such that its 'system-error' exceptions are augmented to mention
+FILE."
+ (let ((real-proc (@ (guile) proc)))
+ (lambda (args ...)
+ (catch 'system-error
+ (lambda ()
+ (real-proc args ...))
+ (augmented-system-error-handler file)))))
+
(set! symlink
;; We 'set!' the global binding because (gnu build ...) modules and similar
;; typically don't use (guix ui).
- (let ((real-symlink (@ (guile) symlink)))
- (lambda (target link)
- "This is a 'symlink' replacement that provides proper error reporting."
- (catch 'system-error
- (lambda ()
- (real-symlink target link))
- (lambda (key proc fmt args errno)
- ;; Augment the FMT and ARGS with information about LINK (this
- ;; information is missing as of Guile 2.0.11, making the exception
- ;; uninformative.)
- (apply throw key proc "~A: ~S"
- (list (strerror (car errno)) link)
- (list errno)))))))
+ (error-reporting-wrapper symlink (source target) target))
(set! copy-file
;; Note: here we use 'set!', not #:replace, because UIs typically use
;; 'copy-recursively', which doesn't use (guix ui).
- (let ((real-copy-file (@ (guile) copy-file)))
- (lambda (source target)
- "This is a 'copy-file' replacement that provides proper error reporting."
- (catch 'system-error
- (lambda ()
- (real-copy-file source target))
- (lambda (key proc fmt args errno)
- ;; Augment the FMT and ARGS with information about TARGET (this
- ;; information is missing as of Guile 2.0.11, making the exception
- ;; uninformative.)
- (apply throw key proc "~A: ~S"
- (list (strerror (car errno)) target)
- (list errno)))))))
+ (error-reporting-wrapper copy-file (source target) target))
+
+(set! canonicalize-path
+ (error-reporting-wrapper canonicalize-path (file) file))
+
(define (make-regexp* regexp . flags)
"Like 'make-regexp' but error out if REGEXP is invalid, reporting the error
diff --git a/guix/utils.scm b/guix/utils.scm
index ee06e47fe9..72dc0687a4 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -33,7 +33,7 @@
#:use-module (ice-9 binary-ports)
#:autoload (rnrs io ports) (make-custom-binary-input-port)
#:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
- #:use-module (guix combinators)
+ #:use-module (guix memoization)
#:use-module ((guix build utils) #:select (dump-port))
#:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync))
#:use-module (ice-9 vlist)
@@ -771,11 +771,10 @@ be determined."
(column location-column)) ; 0-indexed column
(define location
- (memoize
- (lambda (file line column)
- "Return the <location> object for the given FILE, LINE, and COLUMN."
- (and line column file
- (make-location file line column)))))
+ (mlambda (file line column)
+ "Return the <location> object for the given FILE, LINE, and COLUMN."
+ (and line column file
+ (make-location file line column))))
(define (source-properties->location loc)
"Return a location object based on the info in LOC, an alist as returned