summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2018-07-28 18:34:59 +0200
committerMarius Bakke <mbakke@fastmail.com>2018-07-28 18:34:59 +0200
commit1af575f04df6cfb6e5e3f3273271383b6ee355a8 (patch)
tree0f1dfaed352dcdb9c827ed32db267bc7ed3d8203 /guix
parent3b6f8a45d725dd7592634a34e8ffbc14a3bd31cc (diff)
parent48d7ac175f69fea587eaa0358eddb5c76205e8ad (diff)
Merge branch 'master' into staging
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/guile.scm202
-rw-r--r--guix/build/go-build-system.scm38
-rw-r--r--guix/build/guile-build-system.scm153
-rw-r--r--guix/build/haskell-build-system.scm5
-rw-r--r--guix/build/profiles.scm2
-rw-r--r--guix/build/ruby-build-system.scm111
-rw-r--r--guix/gexp.scm155
-rw-r--r--guix/git.scm26
-rw-r--r--guix/gnu-maintenance.scm26
-rw-r--r--guix/hash.scm7
-rw-r--r--guix/import/cabal.scm85
-rw-r--r--guix/import/gem.scm48
-rw-r--r--guix/import/hackage.scm53
-rw-r--r--guix/import/opam.scm193
-rw-r--r--guix/import/pypi.scm10
-rw-r--r--guix/inferior.scm197
-rw-r--r--guix/packages.scm3
-rw-r--r--guix/profiles.scm28
-rw-r--r--guix/scripts/environment.scm210
-rw-r--r--guix/scripts/import.scm2
-rw-r--r--guix/scripts/import/gem.scm27
-rw-r--r--guix/scripts/import/opam.scm92
-rw-r--r--guix/scripts/pack.scm5
-rw-r--r--guix/scripts/package.scm2
-rw-r--r--guix/scripts/pull.scm140
-rw-r--r--guix/scripts/repl.scm199
-rw-r--r--guix/self.scm57
-rw-r--r--guix/serialization.scm140
-rw-r--r--guix/store.scm115
-rw-r--r--guix/store/database.scm8
-rw-r--r--guix/store/deduplication.scm54
-rw-r--r--guix/ui.scm2
-rw-r--r--guix/utils.scm12
33 files changed, 1969 insertions, 438 deletions
diff --git a/guix/build-system/guile.scm b/guix/build-system/guile.scm
new file mode 100644
index 0000000000..77a5f00b01
--- /dev/null
+++ b/guix/build-system/guile.scm
@@ -0,0 +1,202 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build-system guile)
+ #:use-module (guix store)
+ #:use-module (guix utils)
+ #:use-module (guix packages)
+ #:use-module (guix derivations)
+ #:use-module (guix search-paths)
+ #:use-module (guix build-system)
+ #:use-module (guix build-system gnu)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-26)
+ #:export (%guile-build-system-modules
+ guile-build-system))
+
+(define %guile-build-system-modules
+ ;; Build-side modules imported by default.
+ `((guix build guile-build-system)
+ ,@%gnu-build-system-modules))
+
+(define* (lower name
+ #:key source inputs native-inputs outputs system target
+ #:allow-other-keys
+ #:rest arguments)
+ "Return a bag for NAME."
+
+ ;; Note: There's no #:guile argument (unlike, for instance,
+ ;; 'ocaml-build-system' which has #:ocaml.) This is so we can keep
+ ;; procedures like 'package-for-guile-2.0' unchanged and simple.
+
+ (define private-keywords
+ '(#:target #:inputs #:native-inputs))
+
+ (bag
+ (name name)
+ (system system) (target target)
+ (host-inputs `(
+ ,@inputs))
+ (build-inputs `(,@(if source
+ `(("source" ,source))
+ '())
+ ,@native-inputs
+ ,@(map (cute assoc <> (standard-packages))
+ '("tar" "gzip" "bzip2" "xz" "locales"))))
+ (outputs outputs)
+ (build (if target guile-cross-build guile-build))
+ (arguments (strip-keyword-arguments private-keywords arguments))))
+
+(define %compile-flags
+ ;; Flags passed to 'guild compile' by default. We choose a common
+ ;; denominator between Guile 2.0 and 2.2.
+ ''("-Wunbound-variable" "-Warity-mismatch" "-Wformat"))
+
+(define* (guile-build store name inputs
+ #:key source
+ (guile #f)
+ (phases '%standard-phases)
+ (outputs '("out"))
+ (search-paths '())
+ (system (%current-system))
+ (source-directory ".")
+ (compile-flags %compile-flags)
+ (imported-modules %guile-build-system-modules)
+ (modules '((guix build guile-build-system)
+ (guix build utils))))
+ "Build SOURCE using Guile taken from the native inputs, and with INPUTS."
+ (define builder
+ `(begin
+ (use-modules ,@modules)
+ (guile-build #:name ,name
+ #:source ,(match (assoc-ref inputs "source")
+ (((? derivation? source))
+ (derivation->output-path source))
+ ((source)
+ source)
+ (source
+ source))
+ #:source-directory ,source-directory
+ #:compile-flags ,compile-flags
+ #:phases ,phases
+ #:system ,system
+ #: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* (guile-cross-build store name
+ #:key
+ (system (%current-system)) target
+ native-drvs target-drvs
+ (guile #f)
+ source
+ (outputs '("out"))
+ (search-paths '())
+ (native-search-paths '())
+
+ (phases '%standard-phases)
+ (source-directory ".")
+ (compile-flags %compile-flags)
+ (imported-modules %guile-build-system-modules)
+ (modules '((guix build guile-build-system)
+ (guix build utils))))
+ (define builder
+ `(begin
+ (use-modules ,@modules)
+
+ (let ()
+ (define %build-host-inputs
+ ',(map (match-lambda
+ ((name (? derivation? drv) sub ...)
+ `(,name . ,(apply derivation->output-path drv sub)))
+ ((name path)
+ `(,name . ,path)))
+ native-drvs))
+
+ (define %build-target-inputs
+ ',(map (match-lambda
+ ((name (? derivation? drv) sub ...)
+ `(,name . ,(apply derivation->output-path drv sub)))
+ ((name (? package? pkg) sub ...)
+ (let ((drv (package-cross-derivation store pkg
+ target system)))
+ `(,name . ,(apply derivation->output-path drv sub))))
+ ((name path)
+ `(,name . ,path)))
+ target-drvs))
+
+ (guile-build #:source ,(match (assoc-ref native-drvs "source")
+ (((? derivation? source))
+ (derivation->output-path source))
+ ((source)
+ source)
+ (source
+ source))
+ #:system ,system
+ #:target ,target
+ #:outputs %outputs
+ #:source-directory ,source-directory
+ #:compile-flags ,compile-flags
+ #:inputs %build-target-inputs
+ #:native-inputs %build-host-inputs
+ #:search-paths ',(map search-path-specification->sexp
+ search-paths)
+ #:native-search-paths ',(map
+ search-path-specification->sexp
+ native-search-paths)
+ #:phases ,phases))))
+
+ (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
+ #:system system
+ #:inputs (append native-drvs target-drvs)
+ #:outputs outputs
+ #:modules imported-modules
+ #:substitutable? substitutable?
+ #:guile-for-build guile-for-build))
+
+(define guile-build-system
+ (build-system
+ (name 'guile)
+ (description "The build system for simple Guile packages")
+ (lower lower)))
diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm
index 7c833a616f..6be0167063 100644
--- a/guix/build/go-build-system.scm
+++ b/guix/build/go-build-system.scm
@@ -125,17 +125,17 @@ unset. When SOURCE is a directory, copy it instead of unpacking."
(copy-recursively source dest #:keep-mtime? #t)
#t)
(if (string-suffix? ".zip" source)
- (zero? (system* "unzip" "-d" dest source))
- (zero? (system* "tar" "-C" dest "-xvf" source))))))
+ (invoke "unzip" "-d" dest source)
+ (invoke "tar" "-C" dest "-xvf" source)))))
(define* (install-source #:key install-source? outputs #:allow-other-keys)
"Install the source code to the output directory."
(let* ((out (assoc-ref outputs "out"))
(source "src")
(dest (string-append out "/" source)))
- (if install-source?
- (copy-recursively source dest #:keep-mtime? #t)
- #t)))
+ (when install-source?
+ (copy-recursively source dest #:keep-mtime? #t))
+ #t))
(define (go-package? name)
(string-prefix? "go-" name))
@@ -178,24 +178,26 @@ respectively."
(define* (build #:key import-path #:allow-other-keys)
"Build the package named by IMPORT-PATH."
- (or
- (zero? (system* "go" "install"
- "-v" ; print the name of packages as they are compiled
- "-x" ; print each command as it is invoked
- ;; Respectively, strip the symbol table and debug
- ;; information, and the DWARF symbol table.
- "-ldflags=-s -w"
- import-path))
- (begin
+ (with-throw-handler
+ #t
+ (lambda _
+ (invoke "go" "install"
+ "-v" ; print the name of packages as they are compiled
+ "-x" ; print each command as it is invoked
+ ;; Respectively, strip the symbol table and debug
+ ;; information, and the DWARF symbol table.
+ "-ldflags=-s -w"
+ import-path))
+ (lambda (key . args)
(display (string-append "Building '" import-path "' failed.\n"
"Here are the results of `go env`:\n"))
- (system* "go" "env")
- #f)))
+ (invoke "go" "env"))))
(define* (check #:key tests? import-path #:allow-other-keys)
"Run the tests for the package named by IMPORT-PATH."
- (if tests?
- (zero? (system* "go" "test" import-path))))
+ (when tests?
+ (invoke "go" "test" import-path))
+ #t)
(define* (install #:key outputs #:allow-other-keys)
"Install the compiled libraries. `go install` installs these files to
diff --git a/guix/build/guile-build-system.scm b/guix/build/guile-build-system.scm
new file mode 100644
index 0000000000..0bed049436
--- /dev/null
+++ b/guix/build/guile-build-system.scm
@@ -0,0 +1,153 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build guile-build-system)
+ #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+ #:use-module (guix build utils)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 rdelim)
+ #:use-module (guix build utils)
+ #:export (target-guile-effective-version
+ %standard-phases
+ guile-build))
+
+(define* (target-guile-effective-version #:optional guile)
+ "Return the effective version of GUILE or whichever 'guile' is in $PATH.
+Return #false if it cannot be determined."
+ (let* ((pipe (open-pipe* OPEN_READ
+ (if guile
+ (string-append guile "/bin/guile")
+ "guile")
+ "-c" "(display (effective-version))"))
+ (line (read-line pipe)))
+ (and (zero? (close-pipe pipe))
+ (string? line)
+ line)))
+
+(define (file-sans-extension file) ;TODO: factorize
+ "Return the substring of FILE without its extension, if any."
+ (let ((dot (string-rindex file #\.)))
+ (if dot
+ (substring file 0 dot)
+ file)))
+
+(define %scheme-file-regexp
+ ;; Regexp to match Scheme files.
+ "\\.(scm|sls)$")
+
+(define %documentation-file-regexp
+ ;; Regexp to match README files and the likes.
+ "^(README.*|.*\\.html|.*\\.org|.*\\.md)$")
+
+(define* (set-locale-path #:key inputs native-inputs
+ #:allow-other-keys)
+ "Set 'GUIX_LOCPATH'."
+ (match (assoc-ref (or native-inputs inputs) "locales")
+ (#f #t)
+ (locales
+ (setenv "GUIX_LOCPATH" (string-append locales "/lib/locale"))
+ #t)))
+
+(define* (build #:key outputs inputs native-inputs
+ (source-directory ".")
+ (compile-flags '())
+ (scheme-file-regexp %scheme-file-regexp)
+ target
+ #:allow-other-keys)
+ "Build files in SOURCE-DIRECTORY that match SCHEME-FILE-REGEXP."
+ (let* ((out (assoc-ref outputs "out"))
+ (guile (assoc-ref (or native-inputs inputs) "guile"))
+ (effective (target-guile-effective-version guile))
+ (module-dir (string-append out "/share/guile/site/"
+ effective))
+ (go-dir (string-append out "/lib/guile/"
+ effective "/site-ccache/"))
+ (guild (string-append guile "/bin/guild"))
+ (flags (if target
+ (cons (string-append "--target=" target)
+ compile-flags)
+ compile-flags)))
+ (if target
+ (format #t "Cross-compiling for '~a' with Guile ~a...~%"
+ target effective)
+ (format #t "Compiling with Guile ~a...~%" effective))
+ (format #t "compile flags: ~s~%" flags)
+
+ ;; Make installation directories.
+ (mkdir-p module-dir)
+ (mkdir-p go-dir)
+
+ ;; Compile .scm files and install.
+ (setenv "GUILE_AUTO_COMPILE" "0")
+ (setenv "GUILE_LOAD_COMPILED_PATH"
+ (string-append go-dir
+ (match (getenv "GUILE_LOAD_COMPILED_PATH")
+ (#f "")
+ (path (string-append ":" path)))))
+ (for-each (lambda (file)
+ (let* ((go (string-append go-dir
+ (file-sans-extension file)
+ ".go")))
+ ;; Install source module.
+ (install-file (string-append source-directory "/" file)
+ (string-append module-dir
+ "/" (dirname file)))
+
+ ;; Install and compile module.
+ (apply invoke guild "compile" "-L" source-directory
+ "-o" go
+ (string-append source-directory "/" file)
+ flags)))
+
+ ;; Arrange to strip SOURCE-DIRECTORY from file names.
+ (with-directory-excursion source-directory
+ (find-files "." scheme-file-regexp)))
+ #t))
+
+(define* (install-documentation #:key outputs
+ (documentation-file-regexp
+ %documentation-file-regexp)
+ #:allow-other-keys)
+ "Install files that mactch DOCUMENTATION-FILE-REGEXP."
+ (let* ((out (assoc-ref outputs "out"))
+ (doc (string-append out "/share/doc/"
+ (strip-store-file-name out))))
+ (for-each (cut install-file <> doc)
+ (find-files "." documentation-file-regexp))
+ #t))
+
+(define %standard-phases
+ (modify-phases gnu:%standard-phases
+ (delete 'bootstrap)
+ (delete 'configure)
+ (add-before 'install-locale 'set-locale-path
+ set-locale-path)
+ (replace 'build build)
+ (add-after 'build 'install-documentation
+ install-documentation)
+ (delete 'check)
+ (delete 'strip)
+ (delete 'validate-runpath)
+ (delete 'install)))
+
+(define* (guile-build #:key (phases %standard-phases)
+ #:allow-other-keys #:rest args)
+ "Build the given Guile package, applying all of PHASES in order."
+ (apply gnu:gnu-build #:phases phases args))
diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm
index 268d59c1be..26519ce5a6 100644
--- a/guix/build/haskell-build-system.scm
+++ b/guix/build/haskell-build-system.scm
@@ -66,7 +66,7 @@
(format #t "running \"runhaskell Setup.hs\" with command ~s \
and parameters ~s~%"
command params)
- (zero? (apply system* "runhaskell" setup-file command params)))
+ (apply invoke "runhaskell" setup-file command params))
(error "no Setup.hs nor Setup.lhs found"))))
(define* (configure #:key outputs inputs tests? (configure-flags '())
@@ -114,7 +114,8 @@ and parameters ~s~%"
(setenv "CONFIG_SHELL" "sh"))
(run-setuphs "configure" params)
- (setenv "GHC_PACKAGE_PATH" ghc-path)))
+ (setenv "GHC_PACKAGE_PATH" ghc-path)
+ #t))
(define* (build #:rest empty)
"Build a given Haskell package."
diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm
index 819688a913..df785c85a7 100644
--- a/guix/build/profiles.scm
+++ b/guix/build/profiles.scm
@@ -89,7 +89,7 @@ definitions for all the SEARCH-PATHS."
# When GUIX_PROFILE is undefined, the various environment variables refer
# to this specific profile generation.
\n" port)
- (let ((variables (evaluate-search-paths (cons $PATH search-paths)
+ (let ((variables (evaluate-search-paths search-paths
(list output))))
(for-each (write-environment-variable-definition port)
(map (abstract-profile output) variables))))))
diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm
index abef6937bc..3a658e2557 100644
--- a/guix/build/ruby-build-system.scm
+++ b/guix/build/ruby-build-system.scm
@@ -52,18 +52,19 @@ directory."
(define* (unpack #:key source #:allow-other-keys)
"Unpack the gem SOURCE and enter the resulting directory."
(if (gem-archive? source)
- (and (zero? (system* "gem" "unpack" source))
- ;; The unpacked gem directory is named the same as the archive,
- ;; sans the ".gem" extension. It is renamed to simply "gem" in an
- ;; effort to keep file names shorter to avoid UNIX-domain socket
- ;; file names and shebangs that exceed the system's fixed maximum
- ;; length when running test suites.
- (let ((dir (match:substring (string-match "^(.*)\\.gem$"
- (basename source))
- 1)))
- (rename-file dir "gem")
- (chdir "gem")
- #t))
+ (begin
+ (invoke "gem" "unpack" source)
+ ;; The unpacked gem directory is named the same as the archive,
+ ;; sans the ".gem" extension. It is renamed to simply "gem" in an
+ ;; effort to keep file names shorter to avoid UNIX-domain socket
+ ;; file names and shebangs that exceed the system's fixed maximum
+ ;; length when running test suites.
+ (let ((dir (match:substring (string-match "^(.*)\\.gem$"
+ (basename source))
+ 1)))
+ (rename-file dir "gem")
+ (chdir "gem"))
+ #t)
;; Use GNU unpack strategy for things that aren't gem archives.
(gnu:unpack #:source source)))
@@ -77,7 +78,8 @@ operation is not deterministic, we replace it with `find`."
(when (not (gem-archive? source))
(let ((gemspec (first-gemspec)))
(substitute* gemspec
- (("`git ls-files`") "`find . -type f |sort`"))))
+ (("`git ls-files`") "`find . -type f |sort`")
+ (("`git ls-files -z`") "`find . -type f -print0 |sort -z`"))))
#t)
(define* (extract-gemspec #:key source #:allow-other-keys)
@@ -104,7 +106,8 @@ generate the files list."
(write-char (read-char pipe) out))))
#t)
(lambda ()
- (close-pipe pipe)))))))
+ (close-pipe pipe)))))
+ #t))
(define* (build #:key source #:allow-other-keys)
"Build a new gem using the gemspec from the SOURCE gem."
@@ -112,13 +115,13 @@ generate the files list."
;; Build a new gem from the current working directory. This also allows any
;; dynamic patching done in previous phases to be present in the installed
;; gem.
- (zero? (system* "gem" "build" (first-gemspec))))
+ (invoke "gem" "build" (first-gemspec)))
(define* (check #:key tests? test-target #:allow-other-keys)
"Run the gem's test suite rake task TEST-TARGET. Skip the tests if TESTS?
is #f."
(if tests?
- (zero? (system* "rake" test-target))
+ (invoke "rake" test-target)
#t))
(define* (install #:key inputs outputs (gem-flags '())
@@ -137,43 +140,42 @@ GEM-FLAGS are passed to the 'gem' invokation, if present."
0
(- (string-length gem-file-basename) 4))))
(setenv "GEM_VENDOR" vendor-dir)
- (and (let ((install-succeeded?
- (zero?
- (apply system* "gem" "install" gem-file
- "--local" "--ignore-dependencies" "--vendor"
- ;; Executables should go into /bin, not
- ;; /lib/ruby/gems.
- "--bindir" (string-append out "/bin")
- gem-flags))))
- (or install-succeeded?
- (begin
- (simple-format #t "installation failed\n")
- (let ((failed-output-dir (string-append (getcwd) "/out")))
- (mkdir failed-output-dir)
- (copy-recursively out failed-output-dir))
- #f)))
- (begin
- ;; Remove the cached gem file as this is unnecessary and contains
- ;; timestamped files rendering builds not reproducible.
- (let ((cached-gem (string-append vendor-dir "/cache/" gem-file)))
- (log-file-deletion cached-gem)
- (delete-file cached-gem))
- ;; For gems with native extensions, several Makefile-related files
- ;; are created that contain timestamps or other elements making
- ;; them not reproducible. They are unnecessary so we remove them.
- (if (file-exists? (string-append vendor-dir "/ext"))
- (begin
- (for-each (lambda (file)
- (log-file-deletion file)
- (delete-file file))
- (append
- (find-files (string-append vendor-dir "/doc")
- "page-Makefile.ri")
- (find-files (string-append vendor-dir "/extensions")
- "gem_make.out")
- (find-files (string-append vendor-dir "/ext")
- "Makefile")))))
- #t))))
+
+ (or (zero?
+ (apply system* "gem" "install" gem-file
+ "--local" "--ignore-dependencies" "--vendor"
+ ;; Executables should go into /bin, not
+ ;; /lib/ruby/gems.
+ "--bindir" (string-append out "/bin")
+ gem-flags))
+ (begin
+ (let ((failed-output-dir (string-append (getcwd) "/out")))
+ (mkdir failed-output-dir)
+ (copy-recursively out failed-output-dir))
+ (error "installation failed")))
+
+ ;; Remove the cached gem file as this is unnecessary and contains
+ ;; timestamped files rendering builds not reproducible.
+ (let ((cached-gem (string-append vendor-dir "/cache/" gem-file)))
+ (log-file-deletion cached-gem)
+ (delete-file cached-gem))
+
+ ;; For gems with native extensions, several Makefile-related files
+ ;; are created that contain timestamps or other elements making
+ ;; them not reproducible. They are unnecessary so we remove them.
+ (when (file-exists? (string-append vendor-dir "/ext"))
+ (for-each (lambda (file)
+ (log-file-deletion file)
+ (delete-file file))
+ (append
+ (find-files (string-append vendor-dir "/doc")
+ "page-Makefile.ri")
+ (find-files (string-append vendor-dir "/extensions")
+ "gem_make.out")
+ (find-files (string-append vendor-dir "/ext")
+ "Makefile"))))
+
+ #t))
(define* (wrap-ruby-program prog #:key (gem-clear-paths #t) #:rest vars)
"Make a wrapper for PROG. VARS should look like this:
@@ -301,7 +303,8 @@ extended with definitions for VARS."
(let ((files (list-of-files dir)))
(for-each (cut wrap-ruby-program <> var)
files)))
- bindirs)))
+ bindirs))
+ #t)
(define (log-file-deletion file)
(display (string-append "deleting '" file "' for reproducibility\n")))
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 153b29bd42..ffc976d61b 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -23,6 +24,7 @@
#:use-module (guix derivations)
#:use-module (guix grafts)
#:use-module (guix utils)
+ #:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
@@ -334,7 +336,7 @@ appears."
(%plain-file name content references)
plain-file?
(name plain-file-name) ;string
- (content plain-file-content) ;string
+ (content plain-file-content) ;string or bytevector
(references plain-file-references)) ;list (currently unused)
(define (plain-file name content)
@@ -349,8 +351,10 @@ This is the declarative counterpart of 'text-file'."
(define-gexp-compiler (plain-file-compiler (file <plain-file>) system target)
;; "Compile" FILE by adding it to the store.
(match file
- (($ <plain-file> name content references)
- (text-file name content references))))
+ (($ <plain-file> name (and (? string?) content) references)
+ (text-file name content references))
+ (($ <plain-file> name (and (? bytevector?) content) references)
+ (binary-file name content references))))
(define-record-type <computed-file>
(%computed-file name gexp guile options)
@@ -597,6 +601,12 @@ names and file names suitable for the #:allowed-references argument to
allowed-references disallowed-references
leaked-env-vars
local-build? (substitutable? #t)
+
+ ;; TODO: This parameter is transitional; it's here
+ ;; to avoid a full rebuild. Remove it on the next
+ ;; rebuild cycle.
+ import-creates-derivation?
+
deprecation-warnings
(script-name (string-append name "-builder")))
"Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
@@ -691,6 +701,8 @@ The other arguments are as for 'derivation'."
extensions))
(modules (if (pair? %modules)
(imported-modules %modules
+ #:derivation?
+ import-creates-derivation?
#:system system
#:module-path module-path
#:guile guile-for-build
@@ -699,6 +711,8 @@ The other arguments are as for 'derivation'."
(return #f)))
(compiled (if (pair? %modules)
(compiled-modules %modules
+ #:derivation?
+ import-creates-derivation?
#:system system
#:module-path module-path
#:extensions extensions
@@ -731,7 +745,9 @@ The other arguments are as for 'derivation'."
"/bin/guile")
`("--no-auto-compile"
,@(if (pair? %modules)
- `("-L" ,(derivation->output-path modules)
+ `("-L" ,(if (derivation? modules)
+ (derivation->output-path modules)
+ modules)
"-C" ,(derivation->output-path compiled))
'())
,@(append-map extension-flags exts)
@@ -1009,6 +1025,49 @@ execution environment."
;;; Module handling.
;;;
+(define %not-slash
+ (char-set-complement (char-set #\/)))
+
+(define (file-mapping->tree mapping)
+ "Convert MAPPING, an alist like:
+
+ ((\"guix/build/utils.scm\" . \"…/utils.scm\"))
+
+to a tree suitable for 'interned-file-tree'."
+ (let ((mapping (map (match-lambda
+ ((destination . source)
+ (cons (string-tokenize destination
+ %not-slash)
+ source)))
+ mapping)))
+ (fold (lambda (pair result)
+ (match pair
+ ((destination . source)
+ (let loop ((destination destination)
+ (result result))
+ (match destination
+ ((file)
+ (let* ((mode (stat:mode (stat source)))
+ (type (if (zero? (logand mode #o100))
+ 'regular
+ 'executable)))
+ (alist-cons file
+ `(,type (file ,source))
+ result)))
+ ((file rest ...)
+ (let ((directory (assoc-ref result file)))
+ (alist-cons file
+ `(directory
+ ,@(loop rest
+ (match directory
+ (('directory . entries) entries)
+ (#f '()))))
+ (if directory
+ (alist-delete file result)
+ result)))))))))
+ '()
+ mapping)))
+
(define %utils-module
;; This file provides 'mkdir-p', needed to implement 'imported-files' and
;; other primitives below. Note: We give the file name relative to this
@@ -1017,22 +1076,24 @@ execution environment."
(local-file "build/utils.scm"
"build-utils.scm"))
-(define* (imported-files files
- #:key (name "file-import")
- (system (%current-system))
- (guile (%guile-for-build))
-
- ;; XXX: The only reason we have
- ;; #:deprecation-warnings is because (guix build
- ;; utils), which we use here, relies on _IO*, which
- ;; is deprecated in 2.2. On the next full-rebuild
- ;; cycle, we should disable such warnings
- ;; unconditionally.
- (deprecation-warnings #f))
+(define* (imported-files/derivation files
+ #:key (name "file-import")
+ (symlink? #f)
+ (system (%current-system))
+ (guile (%guile-for-build))
+
+ ;; XXX: The only reason we have
+ ;; #:deprecation-warnings is because (guix
+ ;; build utils), which we use here, relies
+ ;; on _IO*, which is deprecated in 2.2. On
+ ;; the next full-rebuild cycle, we should
+ ;; disable such warnings unconditionally.
+ (deprecation-warnings #f))
"Return a derivation that imports FILES into STORE. FILES must be a list
of (FINAL-PATH . FILE) pairs. Each FILE is mapped to FINAL-PATH in the
resulting store path. FILE can be either a file name, or a file-like object,
-as returned by 'local-file' for example."
+as returned by 'local-file' for example. If SYMLINK? is true, create symlinks
+to the source files instead of copying them."
(define file-pair
(match-lambda
((final-path . (? string? file-name))
@@ -1055,7 +1116,8 @@ as returned by 'local-file' for example."
(for-each (match-lambda
((final-path store-path)
(mkdir-p (dirname final-path))
- (symlink store-path final-path)))
+ ((ungexp (if symlink? 'symlink 'copy-file))
+ store-path final-path)))
'(ungexp files)))))
;; TODO: Pass FILES as an environment variable so that BUILD remains
@@ -1077,8 +1139,39 @@ as returned by 'local-file' for example."
(else
'())))))
+(define* (imported-files files
+ #:key (name "file-import")
+
+ ;; TODO: Remove this parameter on the next rebuild
+ ;; cycle.
+ (derivation? #f)
+
+ ;; The following parameters make sense when creating
+ ;; an actual derivation.
+ (system (%current-system))
+ (guile (%guile-for-build))
+ (deprecation-warnings #f))
+ "Import FILES into the store and return the resulting derivation or store
+file name (a derivation is created if and only if some elements of FILES are
+file-like objects and not local file names.) FILES must be a list
+of (FINAL-PATH . FILE) pairs. Each FILE is mapped to FINAL-PATH in the
+resulting store path. FILE can be either a file name, or a file-like object,
+as returned by 'local-file' for example."
+ (if (or derivation?
+ (any (match-lambda
+ ((_ . (? struct? source)) #t)
+ (_ #f))
+ files))
+ (imported-files/derivation files #:name name
+ #:symlink? derivation?
+ #:system system #:guile guile
+ #:deprecation-warnings deprecation-warnings)
+ (interned-file-tree `(,name directory
+ ,@(file-mapping->tree files)))))
+
(define* (imported-modules modules
#:key (name "module-import")
+ (derivation? #f) ;TODO: remove on next rebuild
(system (%current-system))
(guile (%guile-for-build))
(module-path %load-path)
@@ -1094,24 +1187,23 @@ by an arrow followed by a file-like object. For example:
In this example, the first two modules are taken from MODULE-PATH, and the
last one is created from the given <scheme-file> object."
- (mlet %store-monad ((files
- (mapm %store-monad
- (match-lambda
- (((module ...) '=> file)
- (return
- (cons (module->source-file-name module)
- file)))
- ((module ...)
- (let ((f (module->source-file-name module)))
- (return
- (cons f (search-path* module-path f))))))
- modules)))
- (imported-files files #:name name #:system system
+ (let ((files (map (match-lambda
+ (((module ...) '=> file)
+ (cons (module->source-file-name module)
+ file))
+ ((module ...)
+ (let ((f (module->source-file-name module)))
+ (cons f (search-path* module-path f)))))
+ modules)))
+ (imported-files files #:name name
+ #:derivation? derivation?
+ #:system system
#:guile guile
#:deprecation-warnings deprecation-warnings)))
(define* (compiled-modules modules
#:key (name "module-import-compiled")
+ (derivation? #f) ;TODO: remove on next rebuild
(system (%current-system))
(guile (%guile-for-build))
(module-path %load-path)
@@ -1131,6 +1223,7 @@ they can refer to each other."
(not (equal? module-path %load-path))))
(mlet %store-monad ((modules (imported-modules modules
+ #:derivation? derivation?
#:system system
#:guile guile
#:module-path
diff --git a/guix/git.scm b/guix/git.scm
index 9e89cc0062..193e2df111 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -114,7 +114,8 @@ OID (roughly the commit hash) corresponding to REF."
#:key
(ref '(branch . "origin/master"))
(cache-directory
- (%repository-cache-directory)))
+ (url-cache-directory
+ url (%repository-cache-directory))))
"Update the cached checkout of URL to REF in CACHE-DIRECTORY. Return two
values: the cache directory name, and the SHA1 commit (a string) corresponding
to REF.
@@ -122,11 +123,10 @@ to REF.
REF is pair whose key is [branch | commit | tag] and value the associated
data, respectively [<branch name> | <sha1> | <tag name>]."
(with-libgit2
- (let* ((cache-dir (url-cache-directory url cache-directory))
- (cache-exists? (openable-repository? cache-dir))
+ (let* ((cache-exists? (openable-repository? cache-directory))
(repository (if cache-exists?
- (repository-open cache-dir)
- (clone* url cache-dir))))
+ (repository-open cache-directory)
+ (clone* url cache-directory))))
;; Only fetch remote if it has not been cloned just before.
(when cache-exists?
(remote-fetch (remote-lookup repository "origin")))
@@ -138,7 +138,7 @@ data, respectively [<branch name> | <sha1> | <tag name>]."
'repository-close!)
(repository-close! repository))
- (values cache-dir (oid->string oid))))))
+ (values cache-directory (oid->string oid))))))
(define* (latest-repository-commit store url
#:key
@@ -157,12 +157,14 @@ Git repositories are kept in the cache directory specified by
(and (string=? (basename file) ".git")
(eq? 'directory (stat:type stat))))
- (let*-values (((checkout commit)
- (update-cached-checkout url
- #:ref ref
- #:cache-directory cache-directory))
- ((name)
- (url+commit->name url commit)))
+ (let*-values
+ (((checkout commit)
+ (update-cached-checkout url
+ #:ref ref
+ #:cache-directory
+ (url-cache-directory url cache-directory)))
+ ((name)
+ (url+commit->name url commit)))
(values (add-to-store store name #t "sha256" checkout
#:select? (negate dot-git?))
commit)))
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index c2a7a33b6a..3634f4bb27 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; This file is part of GNU Guix.
@@ -82,13 +82,14 @@
(define %package-list-url
(string->uri
- (string-append %gnumaint-base-url "gnupackages.txt")))
+ (string-append %gnumaint-base-url "rec/gnupackages.rec")))
(define %package-description-url
;; This file contains package descriptions in recutils format.
- ;; See <https://lists.gnu.org/archive/html/guix-devel/2013-10/msg00071.html>.
+ ;; See <https://lists.gnu.org/archive/html/guix-devel/2013-10/msg00071.html>
+ ;; and <https://lists.gnu.org/archive/html/guix-devel/2018-06/msg00362.html>.
(string->uri
- (string-append %gnumaint-base-url "pkgblurbs.txt")))
+ (string-append %gnumaint-base-url "rec/pkgblurbs.rec")))
(define-record-type* <gnu-package-descriptor>
gnu-package-descriptor
@@ -121,7 +122,12 @@ to fetch the list of GNU packages over HTTP."
(if (null? alist)
(reverse result)
(loop (recutils->alist port)
- (cons alist result)))))
+
+ ;; Ignore things like "%rec" (info "(recutils) Record
+ ;; Descriptors").
+ (if (assoc-ref alist "package")
+ (cons alist result)
+ result)))))
(define official-description
(let ((db (read-records (fetch %package-description-url #:text? #t))))
@@ -148,12 +154,12 @@ to fetch the list of GNU packages over HTTP."
(alist->record `(("description" . ,(official-description name))
,@alist)
make-gnu-package-descriptor
- (list "package" "mundane-name" "copyright-holder"
+ (list "package" "mundane_name" "copyright_holder"
"savannah" "fsd" "language" "logo"
- "doc-category" "doc-summary" "description"
- "doc-url"
- "download-url")
- '("doc-url" "language"))))
+ "doc_category" "doc_summary" "description"
+ "doc_url"
+ "download_url")
+ '("doc_url" "language"))))
(let* ((port (fetch %package-list-url #:text? #t))
(lst (read-records port)))
(close-port port)
diff --git a/guix/hash.scm b/guix/hash.scm
index 39834043e1..8d7ba21425 100644
--- a/guix/hash.scm
+++ b/guix/hash.scm
@@ -101,6 +101,7 @@ output port."
(open-sha256-md))
(define digest #f)
+ (define position 0)
(define (finalize!)
(let ((ptr (md-read sha256-md 0)))
@@ -114,14 +115,18 @@ output port."
0)
(let ((ptr (bytevector->pointer bv offset)))
(md-write sha256-md ptr len)
+ (set! position (+ position len))
len)))
+ (define (get-position)
+ position)
+
(define (close)
(unless digest
(finalize!)))
(values (make-custom-binary-output-port "sha256"
- write! #f #f
+ write! get-position #f
close)
(lambda ()
(unless digest
diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm
index 09130e4498..1b8bda6f4e 100644
--- a/guix/import/cabal.scm
+++ b/guix/import/cabal.scm
@@ -34,6 +34,8 @@
#:export (read-cabal
eval-cabal
+ cabal-custom-setup-dependencies
+
cabal-package?
cabal-package-name
cabal-package-version
@@ -47,6 +49,7 @@
cabal-package-test-suites
cabal-package-flags
cabal-package-eval-environment
+ cabal-package-custom-setup
cabal-source-repository?
cabal-source-repository-use-case
@@ -139,8 +142,8 @@ to the stack."
"Generate a parser for Cabal files."
(lalr-parser
;; --- token definitions
- (CCURLY VCCURLY OPAREN CPAREN TEST ID VERSION RELATION TRUE FALSE
- (right: IF FLAG EXEC TEST-SUITE SOURCE-REPO BENCHMARK LIB OCURLY)
+ (CCURLY VCCURLY OPAREN CPAREN TEST ID VERSION RELATION TRUE FALSE -ANY -NONE
+ (right: IF FLAG EXEC TEST-SUITE CUSTOM-SETUP SOURCE-REPO BENCHMARK LIB OCURLY)
(left: OR)
(left: PROPERTY AND)
(right: ELSE NOT))
@@ -150,6 +153,7 @@ to the stack."
(sections source-repo) : (append $1 (list $2))
(sections executables) : (append $1 $2)
(sections test-suites) : (append $1 $2)
+ (sections custom-setup) : (append $1 $2)
(sections benchmarks) : (append $1 $2)
(sections lib-sec) : (append $1 (list $2))
() : '())
@@ -172,6 +176,7 @@ to the stack."
(ts-sec) : (list $1))
(ts-sec (TEST-SUITE OCURLY exprs CCURLY) : `(section test-suite ,$1 ,$3)
(TEST-SUITE open exprs close) : `(section test-suite ,$1 ,$3))
+ (custom-setup (CUSTOM-SETUP exprs) : (list `(section custom-setup ,$1 ,$2)))
(benchmarks (benchmarks bm-sec) : (append $1 (list $2))
(bm-sec) : (list $1))
(bm-sec (BENCHMARK OCURLY exprs CCURLY) : `(section benchmark ,$1 ,$3)
@@ -211,6 +216,10 @@ to the stack."
(FALSE) : 'false
(TEST OPAREN ID RELATION VERSION CPAREN)
: `(,$1 ,(string-append $3 " " $4 " " $5))
+ (TEST OPAREN ID -ANY CPAREN)
+ : `(,$1 ,(string-append $3 " -any"))
+ (TEST OPAREN ID -NONE CPAREN)
+ : `(,$1 ,(string-append $3 " -none"))
(TEST OPAREN ID RELATION VERSION AND RELATION VERSION CPAREN)
: `(and (,$1 ,(string-append $3 " " $4 " " $5))
(,$1 ,(string-append $3 " " $7 " " $8)))
@@ -349,6 +358,9 @@ matching a string against the created regexp."
(define is-test-suite (make-rx-matcher "^test-suite +([a-z0-9_-]+)"
regexp/icase))
+(define is-custom-setup (make-rx-matcher "^(custom-setup)"
+ regexp/icase))
+
(define is-benchmark (make-rx-matcher "^benchmark +([a-z0-9_-]+)"
regexp/icase))
@@ -362,13 +374,17 @@ matching a string against the created regexp."
(define (is-false s) (string-ci=? s "false"))
+(define (is-any s) (string-ci=? s "-any"))
+
+(define (is-none s) (string-ci=? s "-none"))
+
(define (is-and s) (string=? s "&&"))
(define (is-or s) (string=? s "||"))
(define (is-id s port)
(let ((cabal-reserved-words
- '("if" "else" "library" "flag" "executable" "test-suite"
+ '("if" "else" "library" "flag" "executable" "test-suite" "custom-setup"
"source-repository" "benchmark"))
(spaces (read-while (cut char-set-contains? char-set:blank <>) port))
(c (peek-char port)))
@@ -392,8 +408,11 @@ matching a string against the created regexp."
(define (lex-version loc port)
(make-lexical-token 'VERSION loc
- (read-while char-numeric? port
- (cut char=? #\. <>) char-numeric?)))
+ (read-while (lambda (x)
+ (or (char-numeric? x)
+ (char=? x #\*)
+ (char=? x #\.)))
+ port)))
(define* (read-while is? port #:optional
(is-if-followed-by? (lambda (c) #f))
@@ -435,6 +454,8 @@ string with the read characters."
(define (lex-test-suite ts-rx-res loc) (lex-rx-res ts-rx-res 'TEST-SUITE loc))
+(define (lex-custom-setup ts-rx-res loc) (lex-rx-res ts-rx-res 'CUSTOM-SETUP loc))
+
(define (lex-benchmark bm-rx-res loc) (lex-rx-res bm-rx-res 'BENCHMARK loc))
(define (lex-lib loc) (make-lexical-token 'LIB loc #f))
@@ -447,6 +468,10 @@ string with the read characters."
(define (lex-false loc) (make-lexical-token 'FALSE loc #f))
+(define (lex-any loc) (make-lexical-token '-ANY loc #f))
+
+(define (lex-none loc) (make-lexical-token '-NONE loc #f))
+
(define (lex-and loc) (make-lexical-token 'AND loc #f))
(define (lex-or loc) (make-lexical-token 'OR loc #f))
@@ -514,6 +539,8 @@ LOC is the current port location."
((is-test w port) (lex-test w loc))
((is-true w) (lex-true loc))
((is-false w) (lex-false loc))
+ ((is-any w) (lex-any loc))
+ ((is-none w) (lex-none loc))
((is-and w) (lex-and loc))
((is-or w) (lex-or loc))
((is-id w port) (lex-id w loc))
@@ -529,6 +556,7 @@ the current port location."
((is-src-repo s) => (cut lex-src-repo <> loc))
((is-exec s) => (cut lex-exec <> loc))
((is-test-suite s) => (cut lex-test-suite <> loc))
+ ((is-custom-setup s) => (cut lex-custom-setup <> loc))
((is-benchmark s) => (cut lex-benchmark <> loc))
((is-lib s) (lex-lib loc))
((is-else s) (lex-else loc))
@@ -591,7 +619,7 @@ If #f use the function 'port-filename' to obtain it."
(make-cabal-package name version license home-page source-repository
synopsis description
executables lib test-suites
- flags eval-environment)
+ flags eval-environment custom-setup)
cabal-package?
(name cabal-package-name)
(version cabal-package-version)
@@ -604,7 +632,8 @@ If #f use the function 'port-filename' to obtain it."
(lib cabal-package-library) ; 'library' is a Scheme keyword
(test-suites cabal-package-test-suites)
(flags cabal-package-flags)
- (eval-environment cabal-package-eval-environment)) ; alist
+ (eval-environment cabal-package-eval-environment) ; alist
+ (custom-setup cabal-package-custom-setup))
(set-record-type-printer! <cabal-package>
(lambda (package port)
@@ -658,6 +687,12 @@ If #f use the function 'port-filename' to obtain it."
(name cabal-test-suite-name)
(dependencies cabal-test-suite-dependencies)) ; list of <cabal-dependency>
+(define-record-type <cabal-custom-setup>
+ (make-cabal-custom-setup name dependencies)
+ cabal-custom-setup?
+ (name cabal-custom-setup-name)
+ (dependencies cabal-custom-setup-dependencies)) ; list of <cabal-dependency>
+
(define (cabal-flags->alist flag-list)
"Retrun an alist associating the flag name to its default value from a
list of <cabal-flag> objects."
@@ -694,13 +729,20 @@ the ordering operation and the version."
(let* ((with-ver-matcher-fn (make-rx-matcher
"([a-zA-Z0-9_-]+) *([<>=]+) *([0-9.]+) *"))
(without-ver-matcher-fn (make-rx-matcher "([a-zA-Z0-9_-]+)"))
+ (without-ver-matcher-fn-2 (make-rx-matcher "([a-zA-Z0-9_-]+) (-any|-none)"))
(name (or (and=> (with-ver-matcher-fn spec)
(cut match:substring <> 1))
+ (and=> (without-ver-matcher-fn-2 spec)
+ (cut match:substring <> 1))
(match:substring (without-ver-matcher-fn spec) 1)))
- (operator (and=> (with-ver-matcher-fn spec)
- (cut match:substring <> 2)))
- (version (and=> (with-ver-matcher-fn spec)
- (cut match:substring <> 3))))
+ (operator (or (and=> (with-ver-matcher-fn spec)
+ (cut match:substring <> 2))
+ (and=> (without-ver-matcher-fn-2 spec)
+ (cut match:substring <> 2))))
+ (version (or (and=> (with-ver-matcher-fn spec)
+ (cut match:substring <> 3))
+ (and=> (without-ver-matcher-fn-2 spec)
+ (cut match:substring <> 2)))))
(values name operator version)))
(define (impl haskell)
@@ -716,6 +758,8 @@ the ordering operation and the version."
((string= spec-op ">") (version>? comp-ver spec-ver))
((string= spec-op "<=") (not (version>? comp-ver spec-ver)))
((string= spec-op "<") (not (version>=? comp-ver spec-ver)))
+ ((string= spec-op "-any") #t)
+ ((string= spec-op "-none") #f)
(else
(raise (condition
(&message (message "Failed to evaluate 'impl' test."))))))
@@ -728,7 +772,6 @@ the ordering operation and the version."
(let ((value (or (assoc-ref env name)
(assoc-ref (cabal-flags->alist (cabal-flags)) name))))
(if (eq? value 'false) #f #t)))
-
(define (eval sexp)
(match sexp
(() '())
@@ -755,6 +798,8 @@ the ordering operation and the version."
;; no need to evaluate flag parameters
(('section 'flag name parameters)
(list 'section 'flag name parameters))
+ (('section 'custom-setup parameters)
+ (list 'section 'custom-setup parameters))
;; library does not have a name parameter
(('section 'library parameters)
(list 'section 'library (eval parameters)))
@@ -785,22 +830,28 @@ See the manual for limitations.")))))))
(lib (make-cabal-section evaluated-sexp 'library))
(test-suites (make-cabal-section evaluated-sexp 'test-suite))
(flags (make-cabal-section evaluated-sexp 'flag))
- (eval-environment '()))
+ (eval-environment '())
+ (custom-setup (match
+ (make-cabal-section evaluated-sexp 'custom-setup)
+ ((x) x))))
(make-cabal-package name version license home-page-or-hackage
source-repository synopsis description executables lib
- test-suites flags eval-environment)))
+ test-suites flags eval-environment custom-setup)))
((compose cabal-evaluated-sexp->package eval) cabal-sexp))
(define (make-cabal-section sexp section-type)
"Given an SEXP as produced by 'read-cabal', produce a list of objects
pertaining to SECTION-TYPE sections. SECTION-TYPE must be one of:
-'executable, 'flag, 'test-suite, 'source-repository or 'library."
+'executable, 'flag, 'test-suite, 'custom-setup, 'source-repository or
+'library."
(filter-map (cut match <>
(('section (? (cut equal? <> section-type)) name parameters)
(case section-type
((test-suite) (make-cabal-test-suite
name (dependencies parameters)))
+ ((custom-setup) (make-cabal-custom-setup
+ name (dependencies parameters "setup-depends")))
((executable) (make-cabal-executable
name (dependencies parameters)))
((source-repository) (make-cabal-source-repository
@@ -843,10 +894,10 @@ to be added between the values found in different key/value pairs."
(define dependency-name-version-rx
(make-regexp "([a-zA-Z0-9_-]+) *(.*)"))
-(define (dependencies key-values-list)
+(define* (dependencies key-values-list #:optional (key "build-depends"))
"Return a list of 'cabal-dependency' objects for the dependencies found in
KEY-VALUES-LIST."
- (let ((deps (string-tokenize (lookup-join key-values-list "build-depends" ",")
+ (let ((deps (string-tokenize (lookup-join key-values-list key ",")
(char-set-complement (char-set #\,)))))
(map (lambda (d)
(let ((rx-result (regexp-exec dependency-name-version-rx d)))
diff --git a/guix/import/gem.scm b/guix/import/gem.scm
index 646163fb7b..ea576b5e4a 100644
--- a/guix/import/gem.scm
+++ b/guix/import/gem.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
+;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -33,7 +34,8 @@
#:use-module (guix base32)
#:use-module (guix build-system ruby)
#:export (gem->guix-package
- %gem-updater))
+ %gem-updater
+ gem-recursive-import))
(define (rubygems-fetch name)
"Return an alist representation of the RubyGems metadata for the package NAME,
@@ -115,29 +117,30 @@ VERSION, HASH, HOME-PAGE, DESCRIPTION, DEPENDENCIES, and LICENSES."
((license) (license->symbol license))
(_ `(list ,@(map license->symbol licenses)))))))
-(define* (gem->guix-package package-name #:optional version)
+(define* (gem->guix-package package-name #:optional (repo 'rubygems) version)
"Fetch the metadata for PACKAGE-NAME from rubygems.org, and return the
`package' s-expression corresponding to that package, or #f on failure."
(let ((package (rubygems-fetch package-name)))
(and package
- (let ((name (assoc-ref package "name"))
- (version (assoc-ref package "version"))
- (hash (assoc-ref package "sha"))
- (synopsis (assoc-ref package "info")) ; nothing better to use
- (description (beautify-description
- (assoc-ref package "info")))
- (home-page (assoc-ref package "homepage_uri"))
- (dependencies (map (lambda (dep)
- (let ((name (assoc-ref dep "name")))
- (if (string=? name "bundler")
- "bundler" ; special case, no prefix
- (ruby-package-name name))))
- (assoc-ref* package "dependencies"
- "runtime")))
- (licenses (map string->license
- (assoc-ref package "licenses"))))
- (make-gem-sexp name version hash home-page synopsis
- description dependencies licenses)))))
+ (let* ((name (assoc-ref package "name"))
+ (version (assoc-ref package "version"))
+ (hash (assoc-ref package "sha"))
+ (synopsis (assoc-ref package "info")) ; nothing better to use
+ (description (beautify-description
+ (assoc-ref package "info")))
+ (home-page (assoc-ref package "homepage_uri"))
+ (dependencies-names (map (lambda (dep) (assoc-ref dep "name"))
+ (assoc-ref* package "dependencies" "runtime")))
+ (dependencies (map (lambda (dep)
+ (if (string=? dep "bundler")
+ "bundler" ; special case, no prefix
+ (ruby-package-name dep)))
+ dependencies-names))
+ (licenses (map string->license
+ (assoc-ref package "licenses"))))
+ (values (make-gem-sexp name version hash home-page synopsis
+ description dependencies licenses)
+ dependencies-names)))))
(define (guix-package->gem-name package)
"Given a PACKAGE built from rubygems.org, return the name of the
@@ -192,3 +195,8 @@ package on RubyGems."
(description "Updater for RubyGem packages")
(pred gem-package?)
(latest latest-release)))
+
+(define* (gem-recursive-import package-name #:optional version)
+ (recursive-import package-name '()
+ #:repo->guix-package gem->guix-package
+ #:guix-name ruby-package-name))
diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
index eb9e1d7d82..6f80d84b70 100644
--- a/guix/import/hackage.scm
+++ b/guix/import/hackage.scm
@@ -150,10 +150,9 @@ version."
(_ #f)))
-(define (cabal-dependencies->names cabal include-test-dependencies?)
- "Return the list of dependencies names from the CABAL package object. If
-INCLUDE-TEST-DEPENDENCIES? is #f, do not include dependencies required by test
-suites."
+(define (cabal-dependencies->names cabal)
+ "Return the list of dependencies names from the CABAL package object,
+not including test suite dependencies or custom-setup dependencies."
(let* ((lib (cabal-package-library cabal))
(lib-deps (if (pair? lib)
(map cabal-dependency-name
@@ -163,15 +162,25 @@ suites."
(exe-deps (if (pair? exe)
(map cabal-dependency-name
(append-map cabal-executable-dependencies exe))
- '()))
- (ts (cabal-package-test-suites cabal))
- (ts-deps (if (pair? ts)
- (map cabal-dependency-name
- (append-map cabal-test-suite-dependencies ts))
'())))
- (if include-test-dependencies?
- (delete-duplicates (append lib-deps exe-deps ts-deps))
- (delete-duplicates (append lib-deps exe-deps)))))
+ (delete-duplicates (append lib-deps exe-deps))))
+
+(define (cabal-test-dependencies->names cabal)
+ "Return the list of test suite dependencies from the CABAL package
+object."
+ (let* ((ts (cabal-package-test-suites cabal))
+ (ts-deps (if (pair? ts)
+ (map cabal-dependency-name
+ (append-map cabal-test-suite-dependencies ts))
+ '())))
+ ts-deps))
+
+(define (cabal-custom-setup-dependencies->names cabal)
+ "Return the list of custom-setup dependencies from the CABAL package
+object."
+ (let* ((custom-setup-dependencies (and=> (cabal-package-custom-setup cabal)
+ cabal-custom-setup-dependencies)))
+ (map cabal-dependency-name custom-setup-dependencies)))
(define (filter-dependencies dependencies own-name)
"Filter the dependencies included with the GHC compiler from DEPENDENCIES, a
@@ -199,8 +208,23 @@ representation of a Cabal file as produced by 'read-cabal'."
(map hackage-name->package-name
((compose (cut filter-dependencies <>
(cabal-package-name cabal))
- (cut cabal-dependencies->names <>
- include-test-dependencies?))
+ (cut cabal-dependencies->names <>))
+ cabal))))
+ (map (lambda (name)
+ (list name (list 'unquote (string->symbol name))))
+ names)))
+
+ (define native-dependencies
+ (let ((names
+ (map hackage-name->package-name
+ ((compose (cut filter-dependencies <>
+ (cabal-package-name cabal))
+ ;; FIXME: Check include-test-dependencies?
+ (lambda (cabal)
+ (append (if include-test-dependencies?
+ (cabal-test-dependencies->names cabal)
+ '())
+ (cabal-custom-setup-dependencies->names cabal))))
cabal))))
(map (lambda (name)
(list name (list 'unquote (string->symbol name))))
@@ -234,6 +258,7 @@ representation of a Cabal file as produced by 'read-cabal'."
"failed to download tar archive")))))
(build-system haskell-build-system)
,@(maybe-inputs 'inputs dependencies)
+ ,@(maybe-inputs 'native-inputs native-dependencies)
,@(maybe-arguments)
(home-page ,(cabal-package-home-page cabal))
(synopsis ,(cabal-package-synopsis cabal))
diff --git a/guix/import/opam.scm b/guix/import/opam.scm
new file mode 100644
index 0000000000..f252bdc31a
--- /dev/null
+++ b/guix/import/opam.scm
@@ -0,0 +1,193 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
+;;;
+;;; 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 opam)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 vlist)
+ #:use-module ((ice-9 rdelim) #:select (read-line))
+ #:use-module (srfi srfi-1)
+ #:use-module (web uri)
+ #:use-module (guix http-client)
+ #:use-module (guix utils)
+ #:use-module (guix import utils)
+ #:use-module ((guix licenses) #:prefix license:)
+ #:export (opam->guix-package))
+
+(define (opam-urls)
+ "Fetch the urls.txt file from the opam repository and returns the list of
+URLs it contains."
+ (let ((port (http-fetch/cached (string->uri "https://opam.ocaml.org/urls.txt"))))
+ (let loop ((result '()))
+ (let ((line (read-line port)))
+ (if (eof-object? line)
+ (begin
+ (close port)
+ result)
+ (loop (cons line result)))))))
+
+(define (vhash-ref hashtable key default)
+ (match (vhash-assoc key hashtable)
+ (#f default)
+ ((_ . x) x)))
+
+(define (hashtable-update hashtable line)
+ "Parse @var{line} to get the name and version of the package and adds them
+to the hashtable."
+ (let* ((line (string-split line #\ )))
+ (match line
+ ((url foo ...)
+ (if (equal? url "repo")
+ hashtable
+ (match (string-split url #\/)
+ ((type name1 versionstr foo ...)
+ (if (equal? type "packages")
+ (match (string-split versionstr #\.)
+ ((name2 versions ...)
+ (let ((version (string-join versions ".")))
+ (if (equal? name1 name2)
+ (let ((curr (vhash-ref hashtable name1 '())))
+ (vhash-cons name1 (cons version curr) hashtable))
+ hashtable)))
+ (_ hashtable))
+ hashtable))
+ (_ hashtable))))
+ (_ hashtable))))
+
+(define (urls->hashtable urls)
+ "Transform urls.txt in a hashtable whose keys are package names and values
+the list of available versions."
+ (let ((hashtable vlist-null))
+ (let loop ((urls urls) (hashtable hashtable))
+ (match urls
+ (() hashtable)
+ ((url rest ...) (loop rest (hashtable-update hashtable url)))))))
+
+(define (latest-version versions)
+ "Find the most recent version from a list of versions."
+ (match versions
+ ((first rest ...)
+ (let loop ((versions rest) (m first))
+ (match versions
+ (() m)
+ ((first rest ...)
+ (loop rest (if (version>? m first) m first))))))))
+
+(define (fetch-package-url uri)
+ "Fetch and parse the url file. Return the URL the package can be downloaded
+from."
+ (let ((port (http-fetch uri)))
+ (let loop ((result #f))
+ (let ((line (read-line port)))
+ (if (eof-object? line)
+ (begin
+ (close port)
+ result)
+ (let* ((line (string-split line #\ )))
+ (match line
+ ((key value rest ...)
+ (if (member key '("archive:" "http:"))
+ (loop (string-trim-both value #\"))
+ (loop result))))))))))
+
+(define (fetch-package-metadata uri)
+ "Fetch and parse the opam file. Return an association list containing the
+homepage, the license and the list of inputs."
+ (let ((port (http-fetch uri)))
+ (let loop ((result '()) (dependencies? #f))
+ (let ((line (read-line port)))
+ (if (eof-object? line)
+ (begin
+ (close port)
+ result)
+ (let* ((line (string-split line #\ )))
+ (match line
+ ((key value ...)
+ (let ((dependencies?
+ (if dependencies?
+ (not (equal? key "]"))
+ (equal? key "depends:")))
+ (val (string-trim-both (string-join value "") #\")))
+ (cond
+ ((equal? key "homepage:")
+ (loop (cons `("homepage" . ,val) result) dependencies?))
+ ((equal? key "license:")
+ (loop (cons `("license" . ,val) result) dependencies?))
+ ((and dependencies? (not (equal? val "[")))
+ (match (string-split val #\{)
+ ((val rest ...)
+ (let ((curr (assoc-ref result "inputs"))
+ (new (string-trim-both
+ val (list->char-set '(#\] #\[ #\")))))
+ (loop (cons `("inputs" . ,(cons new (if curr curr '()))) result)
+ (if (string-contains val "]") #f dependencies?))))))
+ (else (loop result dependencies?))))))))))))
+
+(define (string->license str)
+ (cond
+ ((equal? str "MIT") '(license:expat))
+ ((equal? str "GPL2") '(license:gpl2))
+ ((equal? str "LGPLv2") '(license:lgpl2))
+ (else `())))
+
+(define (ocaml-name->guix-name name)
+ (cond
+ ((equal? name "ocamlfind") "ocaml-findlib")
+ ((string-prefix? "ocaml" name) name)
+ ((string-prefix? "conf-" name) (substring name 5))
+ (else (string-append "ocaml-" name))))
+
+(define (dependencies->inputs dependencies)
+ "Transform the list of dependencies in a list of inputs."
+ (if (not dependencies)
+ '()
+ (map (lambda (input)
+ (list input (list 'unquote (string->symbol input))))
+ (map ocaml-name->guix-name dependencies))))
+
+(define (opam->guix-package name)
+ (let* ((hashtable (urls->hashtable (opam-urls)))
+ (versions (vhash-ref hashtable name #f)))
+ (unless (eq? versions #f)
+ (let* ((version (latest-version versions))
+ (package-url (string-append "https://opam.ocaml.org/packages/" name
+ "/" name "." version "/"))
+ (url-url (string-append package-url "url"))
+ (opam-url (string-append package-url "opam"))
+ (source-url (fetch-package-url url-url))
+ (metadata (fetch-package-metadata opam-url))
+ (dependencies (assoc-ref metadata "inputs"))
+ (inputs (dependencies->inputs dependencies)))
+ (call-with-temporary-output-file
+ (lambda (temp port)
+ (and (url-fetch source-url temp)
+ `(package
+ (name ,(ocaml-name->guix-name name))
+ (version ,version)
+ (source
+ (origin
+ (method url-fetch)
+ (uri ,source-url)
+ (sha256 (base32 ,(guix-hash-url temp)))))
+ (build-system ocaml-build-system)
+ ,@(if (null? inputs)
+ '()
+ `((inputs ,(list 'quasiquote inputs))))
+ (home-page ,(assoc-ref metadata "homepage"))
+ (synopsis "")
+ (description "")
+ (license ,@(string->license (assoc-ref metadata "license")))))))))))
diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm
index 6beab6b010..25560bac46 100644
--- a/guix/import/pypi.scm
+++ b/guix/import/pypi.scm
@@ -51,8 +51,7 @@
(define (pypi-fetch name)
"Return an alist representation of the PyPI metadata for the package NAME,
or #f on failure."
- (json-fetch-alist (string-append "https://pypi.python.org/pypi/"
- name "/json")))
+ (json-fetch-alist (string-append "https://pypi.org/pypi/" name "/json")))
;; For packages found on PyPI that lack a source distribution.
(define-condition-type &missing-source-error &error
@@ -87,7 +86,7 @@ package."
(string-append "python-" (snake-case name))))
(define (guix-package->pypi-name package)
- "Given a Python PACKAGE built from pypi.python.org, return the name of the
+ "Given a Python PACKAGE built from pypi.org, return the name of the
package on PyPI."
(define (url->pypi-name url)
(hyphen-package-name->name+version
@@ -269,7 +268,7 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
(license ,(license->symbol license)))))))
(define (pypi->guix-package package-name)
- "Fetch the metadata for PACKAGE-NAME from pypi.python.org, and return the
+ "Fetch the metadata for PACKAGE-NAME from pypi.org, and return the
`package' s-expression corresponding to that package, or #f on failure."
(let ((package (pypi-fetch package-name)))
(and package
@@ -304,7 +303,8 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
"Return true if PACKAGE is a Python package from PyPI."
(define (pypi-url? url)
- (or (string-prefix? "https://pypi.python.org/" url)
+ (or (string-prefix? "https://pypi.org/" url)
+ (string-prefix? "https://pypi.python.org/" url)
(string-prefix? "https://pypi.io/packages" url)))
(let ((source-url (and=> (package-source package) origin-uri))
diff --git a/guix/inferior.scm b/guix/inferior.scm
new file mode 100644
index 0000000000..629c2c4313
--- /dev/null
+++ b/guix/inferior.scm
@@ -0,0 +1,197 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 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 inferior)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
+ #:export (inferior?
+ open-inferior
+ close-inferior
+ inferior-eval
+ inferior-object?
+
+ inferior-package?
+ inferior-package-name
+ inferior-package-version
+
+ inferior-packages
+ inferior-package-synopsis
+ inferior-package-description))
+
+;;; Commentary:
+;;;
+;;; This module provides a way to spawn Guix "inferior" processes and to talk
+;;; to them. It allows us, from one instance of Guix, to interact with
+;;; another instance of Guix coming from a different commit.
+;;;
+;;; Code:
+
+;; Inferior Guix process.
+(define-record-type <inferior>
+ (inferior pid socket version)
+ inferior?
+ (pid inferior-pid)
+ (socket inferior-socket)
+ (version inferior-version)) ;REPL protocol version
+
+(define (inferior-pipe directory command)
+ "Return an input/output pipe on the Guix instance in DIRECTORY. This runs
+'DIRECTORY/COMMAND repl' if it exists, or falls back to some other method if
+it's an old Guix."
+ (let ((pipe (with-error-to-port (%make-void-port "w")
+ (lambda ()
+ (open-pipe* OPEN_BOTH
+ (string-append directory "/" command)
+ "repl" "-t" "machine")))))
+ (if (eof-object? (peek-char pipe))
+ (begin
+ (close-pipe pipe)
+
+ ;; Older versions of Guix didn't have a 'guix repl' command, so
+ ;; emulate it.
+ (open-pipe* OPEN_BOTH "guile"
+ "-L" (string-append directory "/share/guile/site/"
+ (effective-version))
+ "-C" (string-append directory "/share/guile/site/"
+ (effective-version))
+ "-C" (string-append directory "/lib/guile/"
+ (effective-version) "/site-ccache")
+ "-c"
+ (object->string
+ `(begin
+ (primitive-load ,(search-path %load-path
+ "guix/scripts/repl.scm"))
+ ((@ (guix scripts repl) machine-repl))))))
+ pipe)))
+
+(define* (open-inferior directory #:key (command "bin/guix"))
+ "Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or
+equivalent. Return #f if the inferior could not be launched."
+ (define pipe
+ (inferior-pipe directory command))
+
+ (setvbuf pipe _IOLBF)
+ (match (read pipe)
+ (('repl-version 0 rest ...)
+ (let ((result (inferior 'pipe pipe (cons 0 rest))))
+ (inferior-eval '(use-modules (guix)) result)
+ (inferior-eval '(use-modules (gnu)) result)
+ (inferior-eval '(define %package-table (make-hash-table))
+ result)
+ result))
+ (_
+ #f)))
+
+(define (close-inferior inferior)
+ "Close INFERIOR."
+ (close-pipe (inferior-socket inferior)))
+
+;; Non-self-quoting object of the inferior.
+(define-record-type <inferior-object>
+ (inferior-object address appearance)
+ inferior-object?
+ (address inferior-object-address)
+ (appearance inferior-object-appearance))
+
+(define (write-inferior-object object port)
+ (match object
+ (($ <inferior-object> _ appearance)
+ (format port "#<inferior-object ~a>" appearance))))
+
+(set-record-type-printer! <inferior-object> write-inferior-object)
+
+(define (inferior-eval exp inferior)
+ "Evaluate EXP in INFERIOR."
+ (define sexp->object
+ (match-lambda
+ (('value value)
+ value)
+ (('non-self-quoting address string)
+ (inferior-object address string))))
+
+ (write exp (inferior-socket inferior))
+ (newline (inferior-socket inferior))
+ (match (read (inferior-socket inferior))
+ (('values objects ...)
+ (apply values (map sexp->object objects)))
+ (('exception key objects ...)
+ (apply throw key (map sexp->object objects)))))
+
+
+;;;
+;;; Inferior packages.
+;;;
+
+(define-record-type <inferior-package>
+ (inferior-package inferior name version id)
+ inferior-package?
+ (inferior inferior-package-inferior)
+ (name inferior-package-name)
+ (version inferior-package-version)
+ (id inferior-package-id))
+
+(define (write-inferior-package package port)
+ (match package
+ (($ <inferior-package> _ name version)
+ (format port "#<inferior-package ~a@~a ~a>"
+ name version
+ (number->string (object-address package) 16)))))
+
+(set-record-type-printer! <inferior-package> write-inferior-package)
+
+(define (inferior-packages inferior)
+ "Return the list of packages known to INFERIOR."
+ (let ((result (inferior-eval
+ '(fold-packages (lambda (package result)
+ (let ((id (object-address package)))
+ (hashv-set! %package-table id package)
+ (cons (list (package-name package)
+ (package-version package)
+ id)
+ result)))
+ '())
+ inferior)))
+ (map (match-lambda
+ ((name version id)
+ (inferior-package inferior name version id)))
+ result)))
+
+(define (inferior-package-field package getter)
+ "Return the field of PACKAGE, an inferior package, accessed with GETTER."
+ (let ((inferior (inferior-package-inferior package))
+ (id (inferior-package-id package)))
+ (inferior-eval `(,getter (hashv-ref %package-table ,id))
+ inferior)))
+
+(define* (inferior-package-synopsis package #:key (translate? #t))
+ "Return the Texinfo synopsis of PACKAGE, an inferior package. When
+TRANSLATE? is true, translate it to the current locale's language."
+ (inferior-package-field package
+ (if translate?
+ '(compose (@ (guix ui) P_) package-synopsis)
+ 'package-synopsis)))
+
+(define* (inferior-package-description package #:key (translate? #t))
+ "Return the Texinfo description of PACKAGE, an inferior package. When
+TRANSLATE? is true, translate it to the current locale's language."
+ (inferior-package-field package
+ (if translate?
+ '(compose (@ (guix ui) P_) package-description)
+ 'package-description)))
diff --git a/guix/packages.scm b/guix/packages.scm
index c762fa7c39..a220b9c476 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -646,6 +646,9 @@ specifies modules in scope when evaluating SNIPPET."
(let ((name (tarxz-name original-file-name)))
(gexp->derivation name build
+ ;; TODO: Remove this on the next rebuild cycle.
+ #:import-creates-derivation? #t
+
#:graft? #f
#:system system
#:deprecation-warnings #t ;to avoid a rebuild
diff --git a/guix/profiles.scm b/guix/profiles.scm
index e6b77e8d38..f34f4fcff6 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -91,6 +91,7 @@
manifest-lookup
manifest-installed?
manifest-matching-entries
+ manifest-search-paths
manifest-transaction
manifest-transaction?
@@ -109,6 +110,7 @@
ca-certificate-bundle
%default-profile-hooks
profile-derivation
+ profile-search-paths
generation-number
generation-numbers
@@ -545,6 +547,14 @@ no match.."
(filter matches? (manifest-entries manifest)))
+(define (manifest-search-paths manifest)
+ "Return the list of search path specifications that apply to MANIFEST,
+including the search path specification for $PATH."
+ (delete-duplicates
+ (cons $PATH
+ (append-map manifest-entry-search-paths
+ (manifest-entries manifest)))))
+
;;;
;;; Manifest transactions.
@@ -1367,8 +1377,7 @@ are cross-built for TARGET."
(map sexp->search-path-specification
(delete-duplicates
'#$(map search-path-specification->sexp
- (append-map manifest-entry-search-paths
- (manifest-entries manifest))))))
+ (manifest-search-paths manifest)))))
(build-profile #$output '#$inputs
#:symlink #$(if relative-symlinks?
@@ -1392,6 +1401,19 @@ are cross-built for TARGET."
;; to have no substitute to offer.
#:substitutable? #f)))
+(define* (profile-search-paths profile
+ #:optional (manifest (profile-manifest profile))
+ #:key (getenv (const #f)))
+ "Read the manifest of PROFILE and evaluate the values of search path
+environment variables required by PROFILE; return a list of
+specification/value pairs. If MANIFEST is not #f, it is assumed to be the
+manifest of PROFILE, which avoids rereading it.
+
+Use GETENV to determine the current settings and report only settings not
+already effective."
+ (evaluate-search-paths (manifest-search-paths manifest)
+ (list profile) getenv))
+
(define (profile-regexp profile)
"Return a regular expression that matches PROFILE's name and number."
(make-regexp (string-append "^" (regexp-quote (basename profile))
@@ -1499,7 +1521,7 @@ the generation that was current before switching."
(profile profile)
(generation number)))))
(else
- (switch-symlinks profile generation)
+ (switch-symlinks profile (basename generation))
current))))
(define (switch-to-previous-generation profile)
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index f8a9702b30..1c04800e42 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, 2018 David Thompson <davet@gnu.org>
-;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org>
;;;
;;; This file is part of GNU Guix.
@@ -49,11 +49,6 @@
#:use-module (srfi srfi-98)
#:export (guix-environment))
-(define (evaluate-profile-search-paths profile search-paths)
- "Evaluate SEARCH-PATHS, a list of search-path specifications, for the
-directories in PROFILE, the store path of a profile."
- (evaluate-search-paths search-paths (list profile)))
-
;; Protect some env vars from purification. Borrowed from nix-shell.
(define %precious-variables
'("HOME" "USER" "LOGNAME" "DISPLAY" "TERM" "TZ" "PAGER"))
@@ -70,8 +65,8 @@ as 'HOME' and 'USER' are left untouched."
(((names . _) ...)
names)))))
-(define (create-environment profile paths pure?)
- "Set the environment variables specified by PATHS for PROFILE. When PURE?
+(define* (create-environment profile manifest #:key pure?)
+ "Set the environment variables specified by MANIFEST for PROFILE. When PURE?
is #t, unset the variables in the current environment. Otherwise, augment
existing environment variables with additional search paths."
(when pure? (purify-environment))
@@ -84,53 +79,41 @@ existing environment variables with additional search paths."
(string-append value separator current)
value)
value)))))
- (evaluate-profile-search-paths profile paths))
+ (profile-search-paths profile manifest))
;; Give users a way to know that they're in 'guix environment', so they can
;; adjust 'PS1' accordingly, for instance. Set it to PROFILE so users can
;; conveniently access its contents.
(setenv "GUIX_ENVIRONMENT" profile))
-(define (show-search-paths profile search-paths pure?)
- "Display SEARCH-PATHS applied to PROFILE. When PURE? is #t, do not augment
-existing environment variables with additional search paths."
+(define* (show-search-paths profile manifest #:key pure?)
+ "Display the search paths of MANIFEST applied to PROFILE. When PURE? is #t,
+do not augment existing environment variables with additional search paths."
(for-each (match-lambda
((search-path . value)
(display
(search-path-definition search-path value
#:kind (if pure? 'exact 'prefix)))
(newline)))
- (evaluate-profile-search-paths profile search-paths)))
+ (profile-search-paths profile manifest)))
-(define (strip-input-name input)
- "Remove the name element from the tuple INPUT."
+(define (input->manifest-entry input)
+ "Return a manifest entry for INPUT, or #f if INPUT does not correspond to a
+package."
(match input
- ((_ package) package)
- ((_ package output)
- (list package output))))
-
-(define (package+propagated-inputs package output)
- "Return the union of PACKAGE's OUTPUT and its transitive propagated inputs."
- (cons (list package output)
- (map strip-input-name
- (package-transitive-propagated-inputs package))))
-
-(define (package-or-package+output? expr)
- "Return #t if EXPR is a package or a 2 element list consisting of a package
-and an output string."
- (match expr
- ((or (? package?) ; bare package object
- ((? package?) (? string?))) ; package+output tuple
- #t)
- (_ #f)))
+ ((_ (? package? package))
+ (package->manifest-entry package))
+ ((_ (? package? package) output)
+ (package->manifest-entry package output))
+ (_
+ #f)))
(define (package-environment-inputs package)
- "Return a list of the transitive input packages for PACKAGE."
+ "Return a list of manifest entries corresponding to the transitive input
+packages for PACKAGE."
;; Remove non-package inputs such as origin records.
- (filter package-or-package+output?
- (map strip-input-name
- (bag-transitive-inputs
- (package->bag package)))))
+ (filter-map input->manifest-entry
+ (bag-transitive-inputs (package->bag package))))
(define (show-help)
(display (G_ "Usage: guix environment [OPTION]... PACKAGE... [-- COMMAND...]
@@ -287,55 +270,50 @@ COMMAND or an interactive shell in that environment.\n"))
(_ memo)))
'() alist))
-(define (compact lst)
- "Remove all #f elements from LST."
- (filter identity lst))
-
(define (options/resolve-packages opts)
- "Return OPTS with package specification strings replaced by actual
-packages."
- (define (package->output package mode)
- (match package
- ((? package?)
- (list mode package "out"))
- (((? package? package) (? string? output))
- (list mode package output))))
+ "Return OPTS with package specification strings replaced by manifest entries
+for the corresponding packages."
+ (define (manifest-entry=? e1 e2)
+ (and (eq? (manifest-entry-item e1) (manifest-entry-item e2))
+ (string=? (manifest-entry-output e1)
+ (manifest-entry-output e2))))
(define (packages->outputs packages mode)
(match packages
- ((? package-or-package+output? package) ; single package
- (list (package->output package mode)))
- (((? package-or-package+output?) ...) ; many packages
- (map (cut package->output <> mode) packages))))
-
- (define (manifest->outputs manifest)
- (map (lambda (entry)
- (cons 'ad-hoc-package ; manifests are implicitly ad-hoc
- (if (package? (manifest-entry-item entry))
- (list (manifest-entry-item entry)
- (manifest-entry-output entry))
- ;; Direct store paths have no output.
- (list (manifest-entry-item entry)))))
- (manifest-entries manifest)))
-
- (compact
- (append-map (match-lambda
- (('package mode (? string? spec))
- (let-values (((package output)
- (specification->package+output spec)))
- (list (list mode package output))))
- (('expression mode str)
- ;; Add all the outputs of the package STR evaluates to.
- (packages->outputs (read/eval str) mode))
- (('load mode file)
- ;; Add all the outputs of the package defined in FILE.
- (let ((module (make-user-module '())))
- (packages->outputs (load* file module) mode)))
- (('manifest . file)
- (let ((module (make-user-module '((guix profiles) (gnu)))))
- (manifest->outputs (load* file module))))
- (_ '(#f)))
- opts)))
+ ((? package? package)
+ (if (eq? mode 'ad-hoc-package)
+ (list (package->manifest-entry package))
+ (package-environment-inputs package)))
+ (((? package? package) (? string? output))
+ (if (eq? mode 'ad-hoc-package)
+ (list (package->manifest-entry package output))
+ (package-environment-inputs package)))
+ ((lst ...)
+ (append-map (cut packages->outputs <> mode) lst))))
+
+ (manifest
+ (delete-duplicates
+ (append-map (match-lambda
+ (('package 'ad-hoc-package (? string? spec))
+ (let-values (((package output)
+ (specification->package+output spec)))
+ (list (package->manifest-entry package output))))
+ (('package 'package (? string? spec))
+ (package-environment-inputs
+ (specification->package+output spec)))
+ (('expression mode str)
+ ;; Add all the outputs of the package STR evaluates to.
+ (packages->outputs (read/eval str) mode))
+ (('load mode file)
+ ;; Add all the outputs of the package defined in FILE.
+ (let ((module (make-user-module '())))
+ (packages->outputs (load* file module) mode)))
+ (('manifest . file)
+ (let ((module (make-user-module '((guix profiles) (gnu)))))
+ (manifest-entries (load* file module))))
+ (_ '()))
+ opts)
+ manifest-entry=?)))
(define* (build-environment derivations opts)
"Build the DERIVATIONS required by the environment using the build options
@@ -350,11 +328,10 @@ in OPTS."
(return #f)
(built-derivations derivations)))))
-(define (inputs->profile-derivation inputs system bootstrap?)
- "Return the derivation for a profile consisting of INPUTS for SYSTEM.
-BOOTSTRAP? specifies whether to use the bootstrap Guile to build the
-profile."
- (profile-derivation (packages->manifest inputs)
+(define (manifest->derivation manifest system bootstrap?)
+ "Return the derivation for a profile of MANIFEST.
+BOOTSTRAP? specifies whether to use the bootstrap Guile to build the profile."
+ (profile-derivation manifest
#:system system
;; Packages can have conflicting inputs, or explicit
@@ -397,32 +374,34 @@ and suitable for 'exit'."
(define exit/status (compose exit status->exit-code))
(define primitive-exit/status (compose primitive-exit status->exit-code))
-(define (launch-environment command inputs paths pure?)
+(define* (launch-environment command profile manifest
+ #:key pure?)
"Run COMMAND in a new environment containing INPUTS, using the native search
paths defined by the list PATHS. When PURE?, pre-existing environment
variables are cleared before setting the new ones."
;; Properly handle SIGINT, so pressing C-c in an interactive terminal
;; application works.
(sigaction SIGINT SIG_DFL)
- (create-environment inputs paths pure?)
+ (create-environment profile manifest #:pure? pure?)
(match command
((program . args)
(apply execlp program program args))))
-(define (launch-environment/fork command inputs paths pure?)
- "Run COMMAND in a new process with an environment containing INPUTS, using
-the native search paths defined by the list PATHS. When PURE?, pre-existing
-environment variables are cleared before setting the new ones."
+(define* (launch-environment/fork command profile manifest #:key pure?)
+ "Run COMMAND in a new process with an environment containing PROFILE, with
+the search paths specified by MANIFEST. When PURE?, pre-existing environment
+variables are cleared before setting the new ones."
(match (primitive-fork)
- (0 (launch-environment command inputs paths pure?))
+ (0 (launch-environment command profile manifest
+ #:pure? pure?))
(pid (match (waitpid pid)
((_ . status) status)))))
(define* (launch-environment/container #:key command bash user user-mappings
- profile paths link-profile? network?)
+ profile manifest link-profile? network?)
"Run COMMAND within a container that features the software in PROFILE.
-Environment variables are set according to PATHS, a list of native search
-paths. The global shell is BASH, a file name for a GNU Bash binary in the
+Environment variables are set according to the search paths of MANIFEST.
+The global shell is BASH, a file name for a GNU Bash binary in the
store. When NETWORK?, access to the host system network is permitted.
USER-MAPPINGS, a list of file system mappings, contains the user-specified
host file systems to mount inside the container. If USER is not #f, each
@@ -514,7 +493,7 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from
(primitive-exit/status
;; A container's environment is already purified, so no need to
;; request it be purified again.
- (launch-environment command profile paths #f)))
+ (launch-environment command profile manifest #:pure? #f)))
#:namespaces (if network?
(delq 'net %namespaces) ; share host network
%namespaces)))))))
@@ -671,25 +650,8 @@ message if any test fails."
;; within the container.
'("/bin/sh")
(list %default-shell))))
- (packages (options/resolve-packages opts))
- (mappings (pick-all opts 'file-system-mapping))
- (inputs (delete-duplicates
- (append-map (match-lambda
- (('ad-hoc-package package output)
- (package+propagated-inputs package
- output))
- (('package package _)
- (package-environment-inputs package)))
- packages)))
- (paths (delete-duplicates
- (cons $PATH
- (append-map (match-lambda
- ((or ((? package? p) _ ...)
- (? package? p))
- (package-native-search-paths p))
- (_ '()))
- inputs))
- eq?)))
+ (manifest (options/resolve-packages opts))
+ (mappings (pick-all opts 'file-system-mapping)))
(when container? (assert-container-features))
@@ -714,8 +676,8 @@ message if any test fails."
(mlet* %store-monad ((bash (environment-bash container?
bootstrap?
system))
- (prof-drv (inputs->profile-derivation
- inputs system bootstrap?))
+ (prof-drv (manifest->derivation
+ manifest system bootstrap?))
(profile -> (derivation->output-path prof-drv))
(gc-root -> (assoc-ref opts 'gc-root)))
@@ -734,7 +696,7 @@ message if any test fails."
((assoc-ref opts 'dry-run?)
(return #t))
((assoc-ref opts 'search-paths)
- (show-search-paths profile paths pure?)
+ (show-search-paths profile manifest #:pure? pure?)
(return #t))
(container?
(let ((bash-binary
@@ -747,11 +709,11 @@ message if any test fails."
#:user user
#:user-mappings mappings
#:profile profile
- #:paths paths
+ #:manifest manifest
#:link-profile? link-prof?
#:network? network?)))
(else
(return
(exit/status
- (launch-environment/fork command profile
- paths pure?)))))))))))))
+ (launch-environment/fork command profile manifest
+ #:pure? pure?)))))))))))))
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index f8cb85700d..0b326e1049 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -75,7 +75,7 @@ rather than \\n."
;;;
(define importers '("gnu" "nix" "pypi" "cpan" "hackage" "stackage" "elpa" "gem"
- "cran" "crate" "texlive" "json"))
+ "cran" "crate" "texlive" "json" "opam"))
(define (resolve-importer name)
(let ((module (resolve-interface
diff --git a/guix/scripts/import/gem.scm b/guix/scripts/import/gem.scm
index 349a0a072a..b6d9ccaae4 100644
--- a/guix/scripts/import/gem.scm
+++ b/guix/scripts/import/gem.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -25,6 +26,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-37)
+ #:use-module (srfi srfi-41)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:export (guix-import-gem))
@@ -44,6 +46,9 @@ Import and convert the RubyGems package for PACKAGE-NAME.\n"))
-h, --help display this help and exit"))
(display (G_ "
-V, --version display version information and exit"))
+ (display (G_ "
+ -r, --recursive generate package expressions for all Gem packages\
+ that are not yet in Guix"))
(newline)
(show-bug-report-information))
@@ -56,6 +61,9 @@ Import and convert the RubyGems package for PACKAGE-NAME.\n"))
(option '(#\V "version") #f #f
(lambda args
(show-version-and-exit "guix import pypi")))
+ (option '(#\r "recursive") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'recursive #t result)))
%standard-import-options))
@@ -81,11 +89,20 @@ Import and convert the RubyGems package for PACKAGE-NAME.\n"))
(reverse opts))))
(match args
((package-name)
- (let ((sexp (gem->guix-package package-name)))
- (unless sexp
- (leave (G_ "failed to download meta-data for package '~a'~%")
- package-name))
- sexp))
+ (if (assoc-ref opts 'recursive)
+ (map (match-lambda
+ ((and ('package ('name name) . rest) pkg)
+ `(define-public ,(string->symbol name)
+ ,pkg))
+ (_ #f))
+ (reverse
+ (stream->list
+ (gem-recursive-import package-name 'rubygems))))
+ (let ((sexp (gem->guix-package package-name)))
+ (unless sexp
+ (leave (G_ "failed to download meta-data for package '~a'~%")
+ package-name))
+ sexp)))
(()
(leave (G_ "too few arguments~%")))
((many ...)
diff --git a/guix/scripts/import/opam.scm b/guix/scripts/import/opam.scm
new file mode 100644
index 0000000000..b549878742
--- /dev/null
+++ b/guix/scripts/import/opam.scm
@@ -0,0 +1,92 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
+;;;
+;;; 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 opam)
+ #:use-module (guix ui)
+ #:use-module (guix utils)
+ #:use-module (guix scripts)
+ #:use-module (guix import opam)
+ #: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-opam))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+ '())
+
+(define (show-help)
+ (display (G_ "Usage: guix import opam PACKAGE-NAME
+Import and convert the opam package for PACKAGE-NAME.\n"))
+ (display (G_ "
+ -h, --help display this help and exit"))
+ (display (G_ "
+ -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 opam")))
+ %standard-import-options))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-import-opam . args)
+ (define (parse-options)
+ ;; Return the alist of option values.
+ (args-fold* args %options
+ (lambda (opt name arg result)
+ (leave (G_ "~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 (opam->guix-package package-name)))
+ (unless sexp
+ (leave (G_ "failed to download meta-data for package '~a'~%")
+ package-name))
+ sexp))
+ (()
+ (leave (G_ "too few arguments~%")))
+ ((many ...)
+ (leave (G_ "too many arguments~%"))))))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 6d5d745bc8..729850839b 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -1,6 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net>
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
@@ -69,7 +68,7 @@
(compressor "lzip" ".lz"
#~(#+(file-append lzip "/bin/lzip") "-9"))
(compressor "xz" ".xz"
- #~(#+(file-append xz "/bin/xz") "-e -T0"))
+ #~(#+(file-append xz "/bin/xz") "-e"))
(compressor "bzip2" ".bz2"
#~(#+(file-append bzip2 "/bin/bzip2") "-9"))
(compressor "none" "" #f)))
@@ -77,7 +76,7 @@
;; This one is only for use in this module, so don't put it in %compressors.
(define bootstrap-xz
(compressor "bootstrap-xz" ".xz"
- #~(#+(file-append %bootstrap-coreutils&co "/bin/xz") "-e -T0")))
+ #~(#+(file-append %bootstrap-coreutils&co "/bin/xz") "-e")))
(define (lookup-compressor name)
"Return the compressor object called NAME. Error out if it could not be
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 29829f52c8..b38a55d01c 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -190,7 +190,7 @@ do not treat collisions in MANIFEST as an error."
(let* ((entries (manifest-entries manifest))
(count (length entries)))
(switch-symlinks name prof)
- (switch-symlinks profile name)
+ (switch-symlinks profile (basename name))
(unless (string=? profile %current-profile)
(register-gc-root store name))
(format #t (N_ "~a package in profile~%"
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 7202e3cc16..433502b5de 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -28,9 +28,12 @@
#:use-module (guix profiles)
#:use-module (guix gexp)
#:use-module (guix grafts)
+ #:use-module (guix memoization)
#:use-module (guix monads)
+ #:autoload (guix inferior) (open-inferior)
#:use-module (guix scripts build)
#:autoload (guix self) (whole-package)
+ #:use-module (gnu packages)
#:autoload (gnu packages ssh) (guile-ssh)
#:autoload (gnu packages tls) (gnutls)
#:use-module ((guix scripts package) #:select (build-and-use-profile))
@@ -45,9 +48,11 @@
#:use-module ((gnu packages certs) #:select (le-certs))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
#:use-module (ice-9 match)
+ #:use-module (ice-9 vlist)
#:export (guix-pull))
(module-autoload! (resolve-module '(guix scripts pull))
@@ -230,12 +235,32 @@ URL, BRANCH, and COMMIT as a property in the manifest entry."
(branch ,branch)
(commit ,commit))))))))))
+(define (display-profile-news profile)
+ "Display what's up in PROFILE--new packages, and all that."
+ (match (memv (generation-number profile)
+ (reverse (profile-generations profile)))
+ ((current previous _ ...)
+ (newline)
+ (let ((old (fold-packages (lambda (package result)
+ (alist-cons (package-name package)
+ (package-version package)
+ result))
+ '()))
+ (new (profile-package-alist
+ (generation-file-name profile current))))
+ (display-new/upgraded-packages old new
+ #:heading (G_ "New in this revision:\n"))))
+ (_ #t)))
+
(define* (build-and-install source config-dir
#:key verbose? url branch commit)
"Build the tool from SOURCE, and install it in CONFIG-DIR."
(define update-profile
(store-lift build-and-use-profile))
+ (define profile
+ (string-append config-dir "/current"))
+
(mlet* %store-monad ((drv (build-from-source source
#:commit commit
#:verbose? verbose?))
@@ -243,8 +268,9 @@ URL, BRANCH, and COMMIT as a property in the manifest entry."
#:url url
#:branch branch
#:commit commit)))
- (update-profile (string-append config-dir "/current")
- (manifest (list entry)))))
+ (mbegin %store-monad
+ (update-profile profile (manifest (list entry)))
+ (return (display-profile-news profile)))))
(define (honor-lets-encrypt-certificates! store)
"Tell Guile-Git to use the Let's Encrypt certificates."
@@ -289,6 +315,7 @@ certificates~%"))
(define (display-profile-content profile number)
"Display the packages in PROFILE, generation NUMBER, in a human-readable
way and displaying details about the channel's source code."
+ (display-generation profile number)
(for-each (lambda (entry)
(format #t " ~a ~a~%"
(manifest-entry-name entry)
@@ -310,6 +337,90 @@ way and displaying details about the channel's source code."
(manifest-entries
(profile-manifest (generation-file-name profile number))))))
+(define (indented-string str indent)
+ "Return STR with each newline preceded by IDENT spaces."
+ (define indent-string
+ (make-list indent #\space))
+
+ (list->string
+ (string-fold-right (lambda (chr result)
+ (if (eqv? chr #\newline)
+ (cons chr (append indent-string result))
+ (cons chr result)))
+ '()
+ str)))
+
+(define profile-package-alist
+ (mlambda (profile)
+ "Return a name/version alist representing the packages in PROFILE."
+ (fold (lambda (package lst)
+ (alist-cons (inferior-package-name package)
+ (inferior-package-version package)
+ lst))
+ '()
+ (let* ((inferior (open-inferior profile))
+ (packages (inferior-packages inferior)))
+ (close-inferior inferior)
+ packages))))
+
+(define* (display-new/upgraded-packages alist1 alist2
+ #:key (heading ""))
+ "Given the two package name/version alists ALIST1 and ALIST2, display the
+list of new and upgraded packages going from ALIST1 to ALIST2. When ALIST1
+and ALIST2 differ, display HEADING upfront."
+ (let* ((old (fold (match-lambda*
+ (((name . version) table)
+ (vhash-cons name version table)))
+ vlist-null
+ alist1))
+ (new (remove (match-lambda
+ ((name . _)
+ (vhash-assoc name old)))
+ alist2))
+ (upgraded (filter-map (match-lambda
+ ((name . new-version)
+ (match (vhash-fold* cons '() name old)
+ (() #f)
+ ((= (cut sort <> version>?) old-versions)
+ (and (version>? new-version
+ (first old-versions))
+ (string-append name "@"
+ new-version))))))
+ alist2)))
+ (unless (and (null? new) (null? upgraded))
+ (display heading))
+
+ (match (length new)
+ (0 #t)
+ (count
+ (format #t (N_ " ~h new package: ~a~%"
+ " ~h new packages: ~a~%" count)
+ count
+ (indented-string
+ (fill-paragraph (string-join (sort (map first new) string<?)
+ ", ")
+ (- (%text-width) 4) 30)
+ 4))))
+ (match (length upgraded)
+ (0 #t)
+ (count
+ (format #t (N_ " ~h package upgraded: ~a~%"
+ " ~h packages upgraded: ~a~%" count)
+ count
+ (indented-string
+ (fill-paragraph (string-join (sort upgraded string<?) ", ")
+ (- (%text-width) 4) 35)
+ 4))))))
+
+(define (display-profile-content-diff profile gen1 gen2)
+ "Display the changes in PROFILE GEN2 compared to generation GEN1."
+ (define (package-alist generation)
+ (profile-package-alist (generation-file-name profile generation)))
+
+ (display-profile-content profile gen2)
+ (display-new/upgraded-packages (package-alist gen1)
+ (package-alist gen2)))
+
(define (process-query opts)
"Process any query specified by OPTS."
(define profile
@@ -317,29 +428,32 @@ way and displaying details about the channel's source code."
(match (assoc-ref opts 'query)
(('list-generations pattern)
- (define (list-generation display-function number)
- (unless (zero? number)
- (display-generation profile number)
- (display-function profile number)
- (newline)))
+ (define (list-generations profile numbers)
+ (match numbers
+ ((first rest ...)
+ (display-profile-content profile first)
+ (let loop ((numbers numbers))
+ (match numbers
+ ((first second rest ...)
+ (display-profile-content-diff profile
+ first second)
+ (loop (cons second rest)))
+ ((_) #t)
+ (() #t))))))
(leave-on-EPIPE
(cond ((not (file-exists? profile)) ; XXX: race condition
(raise (condition (&profile-not-found-error
(profile profile)))))
((string-null? pattern)
- (for-each (lambda (generation)
- (list-generation display-profile-content generation))
- (profile-generations profile)))
+ (list-generations profile (profile-generations profile)))
((matching-generations pattern profile)
=>
(match-lambda
(()
(exit 1))
((numbers ...)
- (for-each (lambda (generation)
- (list-generation display-profile-content generation))
- numbers)))))))))
+ (list-generations profile numbers)))))))))
(define (guix-pull . args)
diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm
new file mode 100644
index 0000000000..b157833a49
--- /dev/null
+++ b/guix/scripts/repl.scm
@@ -0,0 +1,199 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 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 scripts repl)
+ #:use-module (guix ui)
+ #:use-module (guix scripts)
+ #:use-module (guix utils)
+ #:use-module (guix packages)
+ #:use-module (gnu packages)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-37)
+ #:use-module (ice-9 match)
+ #:use-module (rnrs bytevectors)
+ #:autoload (system repl repl) (start-repl)
+ #:autoload (system repl server)
+ (make-tcp-server-socket make-unix-domain-server-socket)
+ #:export (machine-repl
+ guix-repl))
+
+;;; Commentary:
+;;;
+;;; This command provides a Guile REPL
+
+(define %default-options
+ `((type . guile)))
+
+(define %options
+ (list (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda args
+ (show-version-and-exit "guix repl")))
+ (option '(#\t "type") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'type (string->symbol arg) result)))
+ (option '("listen") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'listen arg result)))))
+
+
+(define (show-help)
+ (display (G_ "Usage: guix repl [OPTIONS...]
+Start a Guile REPL in the Guix execution environment.\n"))
+ (display (G_ "
+ -t, --type=TYPE start a REPL of the given TYPE"))
+ (newline)
+ (display (G_ "
+ -h, --help display this help and exit"))
+ (display (G_ "
+ -V, --version display version information and exit"))
+ (newline)
+ (show-bug-report-information))
+
+(define (self-quoting? x)
+ "Return #t if X is self-quoting."
+ (letrec-syntax ((one-of (syntax-rules ()
+ ((_) #f)
+ ((_ pred rest ...)
+ (or (pred x)
+ (one-of rest ...))))))
+ (one-of symbol? string? pair? null? vector?
+ bytevector? number? boolean?)))
+
+(define user-module
+ ;; Module where we execute user code.
+ (let ((module (resolve-module '(guix-user) #f #f #:ensure #t)))
+ (beautify-user-module! module)
+ module))
+
+(define* (machine-repl #:optional
+ (input (current-input-port))
+ (output (current-output-port)))
+ "Run a machine-usable REPL over ports INPUT and OUTPUT.
+
+The protocol of this REPL is meant to be machine-readable and provides proper
+support to represent multiple-value returns, exceptions, objects that lack a
+read syntax, and so on. As such it is more convenient and robust than parsing
+Guile's REPL prompt."
+ (define (value->sexp value)
+ (if (self-quoting? value)
+ `(value ,value)
+ `(non-self-quoting ,(object-address value)
+ ,(object->string value))))
+
+ (write `(repl-version 0 0) output)
+ (newline output)
+ (force-output output)
+
+ (let loop ()
+ (match (read input)
+ ((? eof-object?) #t)
+ (exp
+ (catch #t
+ (lambda ()
+ (let ((results (call-with-values
+ (lambda ()
+
+ (primitive-eval exp))
+ list)))
+ (write `(values ,@(map value->sexp results))
+ output)
+ (newline output)
+ (force-output output)))
+ (lambda (key . args)
+ (write `(exception ,key ,@(map value->sexp args)))
+ (newline output)
+ (force-output output)))
+ (loop)))))
+
+(define (call-with-connection spec thunk)
+ "Dynamically-bind the current input and output ports according to SPEC and
+call THUNK."
+ (if (not spec)
+ (thunk)
+
+ ;; Note: the "PROTO:" prefix in SPEC is here so that we can eventually
+ ;; parse things like "fd:123" in a non-ambiguous way.
+ (match (string-index spec #\:)
+ (#f
+ (leave (G_ "~A: invalid listen specification~%") spec))
+ (index
+ (let ((protocol (string-take spec index))
+ (address (string-drop spec (+ index 1))))
+ (define socket
+ (match protocol
+ ("tcp"
+ (make-tcp-server-socket #:port (string->number address)))
+ ("unix"
+ (make-unix-domain-server-socket #:path address))
+ (_
+ (leave (G_ "~A: unsupported protocol family~%")
+ protocol))))
+
+ (listen socket 10)
+ (let loop ()
+ (match (accept socket)
+ ((connection . address)
+ (if (= AF_UNIX (sockaddr:fam address))
+ (info (G_ "accepted connection~%"))
+ (info (G_ "accepted connection from ~a~%")
+ (inet-ntop (sockaddr:fam address)
+ (sockaddr:addr address))))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (parameterize ((current-input-port connection)
+ (current-output-port connection))
+ (thunk)))
+ (lambda ()
+ (false-if-exception (close-port connection))
+ (info (G_ "connection closed~%"))))))
+ (loop)))))))
+
+
+(define (guix-repl . args)
+ (define opts
+ ;; Return the list of package names.
+ (args-fold* args %options
+ (lambda (opt name arg result)
+ (leave (G_ "~A: unrecognized option~%") name))
+ (lambda (arg result)
+ (leave (G_ "~A: extraneous argument~%") arg))
+ %default-options))
+
+ (with-error-handling
+ (let ((type (assoc-ref opts 'type)))
+ (call-with-connection (assoc-ref opts 'listen)
+ (lambda ()
+ (case type
+ ((guile)
+ (save-module-excursion
+ (lambda ()
+ (set-current-module user-module)
+ (start-repl))))
+ ((machine)
+ (machine-repl))
+ (else
+ (leave (G_ "~a: unknown type of REPL~%") type))))))))
+
+;; Local Variables:
+;; eval: (put 'call-with-connection 'scheme-indent-function 1)
+;; End:
diff --git a/guix/self.scm b/guix/self.scm
index c9c7138e65..5ad644b1df 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -112,6 +112,27 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches."
(dependencies node-dependencies) ;list of nodes
(compiled node-compiled)) ;node -> lowerable object
+;; File mappings are essentially an alist as passed to 'imported-files'.
+(define-record-type <file-mapping>
+ (file-mapping name alist)
+ file-mapping?
+ (name file-mapping-name)
+ (alist file-mapping-alist))
+
+(define-gexp-compiler (file-mapping-compiler (mapping <file-mapping>)
+ system target)
+ ;; Here we use 'imported-files', which can arrange to directly import all
+ ;; the files instead of creating a derivation, when possible.
+ (imported-files (map (match-lambda
+ ((destination (? local-file? file))
+ (cons destination
+ (local-file-absolute-file-name file)))
+ ((destination source)
+ (cons destination source))) ;silliness
+ (file-mapping-alist mapping))
+ #:name (file-mapping-name mapping)
+ #:system system))
+
(define (node-fold proc init nodes)
(let loop ((nodes nodes)
(visited (setq))
@@ -166,8 +187,8 @@ must be present in the search path."
(closure modules
(node-modules/recursive dependencies))))
(module-files (map module->import modules))
- (source (imported-files (string-append name "-source")
- (append module-files extra-files))))
+ (source (file-mapping (string-append name "-source")
+ (append module-files extra-files))))
(node name modules source dependencies
(compiled-modules name source
(map car module-files)
@@ -766,38 +787,6 @@ assumed to be part of MODULES."
;;; Building.
;;;
-(define (imported-files name files)
- ;; This is a non-monadic, simplified version of 'imported-files' from (guix
- ;; gexp).
- (define same-target?
- (match-lambda*
- (((file1 . _) (file2 . _))
- (string=? file1 file2))))
-
- (define build
- (with-imported-modules (source-module-closure
- '((guix build utils)))
- #~(begin
- (use-modules (ice-9 match)
- (guix build utils))
-
- (mkdir (ungexp output)) (chdir (ungexp output))
- (for-each (match-lambda
- ((final-path store-path)
- (mkdir-p (dirname final-path))
-
- ;; Note: We need regular files to be regular files, not
- ;; symlinks, as this makes a difference for
- ;; 'add-to-store'.
- (copy-file store-path final-path)))
- '#$(delete-duplicates files same-target?)))))
-
- ;; We're just copying files around, no need to substitute or offload it.
- (computed-file name build
- #:options '(#:local-build? #t
- #:substitutable? #f
- #:env-vars (("COLUMNS" . "200")))))
-
(define* (compiled-modules name module-tree module-files
#:optional
(dependencies '())
diff --git a/guix/serialization.scm b/guix/serialization.scm
index b41a0a09d1..129374f541 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -47,6 +47,7 @@
nar-read-error-token
write-file
+ write-file-tree
restore-file))
;;; Comment:
@@ -211,14 +212,19 @@ substitute invalid byte sequences with question marks. This is a
(lambda ()
(close-port port))))))
- (write-string "contents" p)
- (write-long-long size p)
(call-with-binary-input-file file
- ;; Use 'sendfile' when P is a file port.
- (if (file-port? p)
- (cut sendfile p <> size 0)
- (cut dump <> p size)))
- (write-padding size p))
+ (lambda (input)
+ (write-contents-from-port input p size))))
+
+(define (write-contents-from-port input output size)
+ "Write SIZE bytes from port INPUT to port OUTPUT."
+ (write-string "contents" output)
+ (write-long-long size output)
+ ;; Use 'sendfile' when both OUTPUT and INPUT are file ports.
+ (if (and (file-port? output) (file-port? input))
+ (sendfile output input size 0)
+ (dump input output size))
+ (write-padding size output))
(define (read-contents in out)
"Read the contents of a file from the Nar at IN, write it to OUT, and return
@@ -263,47 +269,113 @@ the size in bytes."
sub-directories of FILE as needed. For each directory entry, call (SELECT?
FILE STAT), where FILE is the entry's absolute file name and STAT is the
result of 'lstat'; exclude entries for which SELECT? does not return true."
+ (write-file-tree file port
+ #:file-type+size
+ (lambda (file)
+ (let* ((stat (lstat file))
+ (size (stat:size stat)))
+ (case (stat:type stat)
+ ((directory)
+ (values 'directory size))
+ ((regular)
+ (values (if (zero? (logand (stat:mode stat)
+ #o100))
+ 'regular
+ 'executable)
+ size))
+ (else
+ (values (stat:type stat) size))))) ;bah!
+ #:file-port (cut open-file <> "r0b")
+ #:symlink-target readlink
+
+ #:directory-entries
+ (lambda (directory)
+ ;; 'scandir' defaults to 'string-locale<?' to sort files,
+ ;; but this happens to be case-insensitive (at least in
+ ;; 'en_US' locale on libc 2.18.) Conversely, we want
+ ;; files to be sorted in a case-sensitive fashion.
+ (define basenames
+ (scandir directory (negate (cut member <> '("." "..")))
+ string<?))
+
+ (filter-map (lambda (base)
+ (let ((file (string-append directory
+ "/" base)))
+ (and (not (member base '("." "..")))
+ (select? file (lstat file))
+ base)))
+ basenames))
+
+ ;; The 'scandir' call above gives us filtered and sorted
+ ;; entries, so no post-processing is needed.
+ #:postprocess-entries identity))
+
+(define (filter/sort-directory-entries lst)
+ "Remove dot and dot-dot entries from LST, and sort it in lexicographical
+order."
+ (delete-duplicates
+ (sort (remove (cute member <> '("." "..")) lst)
+ string<?)
+ string=?))
+
+(define* (write-file-tree file port
+ #:key
+ file-type+size
+ file-port
+ symlink-target
+ directory-entries
+ (postprocess-entries filter/sort-directory-entries))
+ "Write the contents of FILE to PORT in Nar format, recursing into
+sub-directories of FILE as needed.
+
+This procedure does not make any file-system I/O calls. Instead, it calls the
+user-provided FILE-TYPE+SIZE, FILE-PORT, SYMLINK-TARGET, and DIRECTORY-ENTRIES
+procedures, which roughly correspond to 'lstat', 'readlink', and 'scandir'.
+POSTPROCESS-ENTRIES ensures that directory entries are valid; leave it as-is
+unless you know that DIRECTORY-ENTRIES provide filtered and sorted entries, in
+which case you can use 'identity'."
(define p port)
(write-string %archive-version-1 p)
- (let dump ((f file) (s (lstat file)))
+ (let dump ((f file))
+ (define-values (type size)
+ (file-type+size f))
+
(write-string "(" p)
- (case (stat:type s)
- ((regular)
+ (case type
+ ((regular executable)
(write-string "type" p)
(write-string "regular" p)
- (if (not (zero? (logand (stat:mode s) #o100)))
- (begin
- (write-string "executable" p)
- (write-string "" p)))
- (write-contents f p (stat:size s)))
+ (when (eq? 'executable type)
+ (write-string "executable" p)
+ (write-string "" p))
+ (let ((input (file-port f)))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (write-contents-from-port input p size))
+ (lambda ()
+ (close-port input)))))
((directory)
(write-string "type" p)
(write-string "directory" p)
- (let ((entries
- ;; 'scandir' defaults to 'string-locale<?' to sort files, but
- ;; this happens to be case-insensitive (at least in 'en_US'
- ;; locale on libc 2.18.) Conversely, we want files to be
- ;; sorted in a case-sensitive fashion.
- (scandir f (negate (cut member <> '("." ".."))) string<?)))
+ (let ((entries (postprocess-entries (directory-entries f))))
(for-each (lambda (e)
- (let* ((f (string-append f "/" e))
- (s (lstat f)))
- (when (select? f s)
- (write-string "entry" p)
- (write-string "(" p)
- (write-string "name" p)
- (write-string e p)
- (write-string "node" p)
- (dump f s)
- (write-string ")" p))))
+ (let* ((f (string-append f "/" e)))
+ (write-string "entry" p)
+ (write-string "(" p)
+ (write-string "name" p)
+ (write-string e p)
+ (write-string "node" p)
+ (dump f)
+ (write-string ")" p)))
entries)))
((symlink)
(write-string "type" p)
(write-string "symlink" p)
(write-string "target" p)
- (write-string (readlink f) p))
+ (write-string (symlink-target f) p))
(else
(raise (condition (&message (message "unsupported file type"))
(&nar-error (file f) (port port))))))
@@ -379,4 +451,8 @@ Restore it as FILE."
(&message (message "unsupported nar entry type"))
(&nar-read-error (port port) (file file) (token x)))))))))
+;;; Local Variables:
+;;; eval: (put 'call-with-binary-input-file 'scheme-indent-function 1)
+;;; End:
+
;;; serialization.scm ends here
diff --git a/guix/store.scm b/guix/store.scm
index bac42f2738..f41a1e2690 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -77,6 +78,8 @@
add-data-to-store
add-text-to-store
add-to-store
+ add-file-tree-to-store
+ binary-file
build-things
build
query-failed-paths
@@ -135,6 +138,7 @@
set-current-system
text-file
interned-file
+ interned-file-tree
%store-prefix
store-path
@@ -949,6 +953,101 @@ where FILE is the entry's absolute file name and STAT is the result of
(hash-set! cache args path)
path))))))
+(define %not-slash
+ (char-set-complement (char-set #\/)))
+
+(define* (add-file-tree-to-store server tree
+ #:key
+ (hash-algo "sha256")
+ (recursive? #t))
+ "Add the given TREE to the store on SERVER. TREE must be an entry such as:
+
+ (\"my-tree\" directory
+ (\"a\" regular (data \"hello\"))
+ (\"b\" symlink \"a\")
+ (\"c\" directory
+ (\"d\" executable (file \"/bin/sh\"))))
+
+This is a generalized version of 'add-to-store'. It allows you to reproduce
+an arbitrary directory layout in the store without creating a derivation."
+
+ ;; Note: The format of TREE was chosen to allow trees to be compared with
+ ;; 'equal?', which in turn allows us to memoize things.
+
+ (define root
+ ;; TREE is a single entry.
+ (list tree))
+
+ (define basename
+ (match tree
+ ((name . _) name)))
+
+ (define (lookup file)
+ (let loop ((components (string-tokenize file %not-slash))
+ (tree root))
+ (match components
+ ((basename)
+ (assoc basename tree))
+ ((head . rest)
+ (loop rest
+ (match (assoc-ref tree head)
+ (('directory . entries) entries)))))))
+
+ (define (file-type+size file)
+ (match (lookup file)
+ ((_ (and type (or 'directory 'symlink)) . _)
+ (values type 0))
+ ((_ type ('file file))
+ (values type (stat:size (stat file))))
+ ((_ type ('data (? string? data)))
+ (values type (string-length data)))
+ ((_ type ('data (? bytevector? data)))
+ (values type (bytevector-length data)))))
+
+ (define (file-port file)
+ (match (lookup file)
+ ((_ (or 'regular 'executable) content)
+ (match content
+ (('file (? string? file))
+ (open-file file "r0b"))
+ (('data (? string? str))
+ (open-input-string str))
+ (('data (? bytevector? bv))
+ (open-bytevector-input-port bv))))))
+
+ (define (symlink-target file)
+ (match (lookup file)
+ ((_ 'symlink target) target)))
+
+ (define (directory-entries directory)
+ (match (lookup directory)
+ ((_ 'directory (names . _) ...) names)))
+
+ (define cache
+ (nix-server-add-to-store-cache server))
+
+ (or (hash-ref cache tree)
+ (begin
+ ;; We don't use the 'operation' macro so we can use 'write-file-tree'
+ ;; instead of 'write-file'.
+ (record-operation 'add-to-store/tree)
+ (let ((port (nix-server-socket server)))
+ (write-int (operation-id add-to-store) port)
+ (write-string basename port)
+ (write-int 1 port) ;obsolete, must be #t
+ (write-int (if recursive? 1 0) port)
+ (write-string hash-algo port)
+ (write-file-tree basename port
+ #:file-type+size file-type+size
+ #:file-port file-port
+ #:symlink-target symlink-target
+ #:directory-entries directory-entries)
+ (let loop ((done? (process-stderr server)))
+ (or done? (loop (process-stderr server))))
+ (let ((result (read-store-path port)))
+ (hash-set! cache tree result)
+ result)))))
+
(define build-things
(let ((build (operation (build-things (string-list things)
(integer mode))
@@ -1362,7 +1461,18 @@ taking the store as its first argument."
;; Store monad operators.
;;
-(define* (text-file name text
+(define* (binary-file name
+ data ;bytevector
+ #:optional (references '()))
+ "Return as a monadic value the absolute file name in the store of the file
+containing DATA, a bytevector. REFERENCES is a list of store items that the
+resulting text file refers to; it defaults to the empty list."
+ (lambda (store)
+ (values (add-data-to-store store name data references)
+ store)))
+
+(define* (text-file name
+ text ;string
#:optional (references '()))
"Return as a monadic value the absolute file name in the store of the file
containing TEXT, a string. REFERENCES is a list of store items that the
@@ -1389,6 +1499,9 @@ where FILE is the entry's absolute file name and STAT is the result of
#:select? select?)
store)))
+(define interned-file-tree
+ (store-lift add-file-tree-to-store))
+
(define build
;; Monadic variant of 'build-things'.
(store-lift build-things))
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 8f35b63e37..0879a95d0b 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -190,12 +190,14 @@ Every store item in REFERENCES must already be registered."
(define (reset-timestamps file)
"Reset the modification time on FILE and on all the files it contains, if
it's a directory. While at it, canonicalize file permissions."
+ ;; Note: We're resetting to one second after the Epoch like 'guix-daemon'
+ ;; has always done.
(let loop ((file file)
(type (stat:type (lstat file))))
(case type
((directory)
(chmod file #o555)
- (utime file 0 0 0 0)
+ (utime file 1 1 0 0)
(let ((parent file))
(for-each (match-lambda
(("." . _) #f)
@@ -209,10 +211,10 @@ it's a directory. While at it, canonicalize file permissions."
(type type))))))
(scandir* parent))))
((symlink)
- (utime file 0 0 0 0 AT_SYMLINK_NOFOLLOW))
+ (utime file 1 1 0 0 AT_SYMLINK_NOFOLLOW))
(else
(chmod file (if (executable-file? file) #o555 #o444))
- (utime file 0 0 0 0)))))
+ (utime file 1 1 0 0)))))
(define* (register-path path
#:key (references '()) deriver prefix
diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm
index 6ff4a50de5..8c19d7309e 100644
--- a/guix/store/deduplication.scm
+++ b/guix/store/deduplication.scm
@@ -31,37 +31,39 @@
#:export (nar-sha256
deduplicate))
-;; Would it be better to just make WRITE-FILE give size as well? I question
-;; the general utility of this approach.
+;; XXX: This port is used as a workaround on Guile <= 2.2.4 where
+;; 'port-position' throws to 'out-of-range' when the offset is great than or
+;; equal to 2^32: <https://bugs.gnu.org/32161>.
(define (counting-wrapper-port output-port)
- "Some custom ports don't implement GET-POSITION at all. But if we want to
-figure out how many bytes are being written, we will want to use that. So this
-makes a wrapper around a port which implements GET-POSITION."
+ "Return two values: an output port that wraps OUTPUT-PORT, and a thunk to
+retrieve the number of bytes written to OUTPUT-PORT."
(let ((byte-count 0))
- (make-custom-binary-output-port "counting-wrapper"
- (lambda (bytes offset count)
- (set! byte-count
- (+ byte-count count))
- (put-bytevector output-port bytes
- offset count)
- count)
- (lambda ()
- byte-count)
- #f
- (lambda ()
- (close-port output-port)))))
+ (values (make-custom-binary-output-port "counting-wrapper"
+ (lambda (bytes offset count)
+ (put-bytevector output-port bytes
+ offset count)
+ (set! byte-count
+ (+ byte-count count))
+ count)
+ (lambda ()
+ byte-count)
+ #f
+ (lambda ()
+ (close-port output-port)))
+ (lambda ()
+ byte-count))))
(define (nar-sha256 file)
"Gives the sha256 hash of a file and the size of the file in nar form."
- (let-values (((port get-hash) (open-sha256-port)))
- (let ((wrapper (counting-wrapper-port port)))
- (write-file file wrapper)
- (force-output wrapper)
- (force-output port)
- (let ((hash (get-hash))
- (size (port-position wrapper)))
- (close-port wrapper)
- (values hash size)))))
+ (let*-values (((port get-hash) (open-sha256-port))
+ ((wrapper get-size) (counting-wrapper-port port)))
+ (write-file file wrapper)
+ (force-output wrapper)
+ (force-output port)
+ (let ((hash (get-hash))
+ (size (get-size)))
+ (close-port wrapper)
+ (values hash size))))
(define (tempname-in directory)
"Gives an unused temporary name under DIRECTORY. Not guaranteed to still be
diff --git a/guix/ui.scm b/guix/ui.scm
index 6a5feaa953..29c0b2b9ce 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -1428,7 +1428,7 @@ DURATION-RELATION with the current time."
(format #t "~a~%" header)))))
(define (display-profile-content-diff profile gen1 gen2)
- "Display the changed packages in PROFILE GEN2 compared to generation GEN2."
+ "Display the changed packages in PROFILE GEN2 compared to generation GEN1."
(define (equal-entry? first second)
(string= (manifest-entry-item first) (manifest-entry-item second)))
diff --git a/guix/utils.scm b/guix/utils.scm
index f934b6ed13..9bad06d52f 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -5,7 +5,6 @@
;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net>
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2015 David Thompson <davet@gnu.org>
-;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com>
;;;
@@ -33,10 +32,11 @@
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-39)
#:use-module (ice-9 binary-ports)
+ #:use-module (ice-9 ftw)
#:autoload (rnrs io ports) (make-custom-binary-input-port)
#:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
#:use-module (guix memoization)
- #:use-module ((guix build utils) #:select (dump-port mkdir-p))
+ #:use-module ((guix build utils) #:select (dump-port mkdir-p delete-file-recursively))
#:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync))
#:use-module (ice-9 format)
#:autoload (ice-9 popen) (open-pipe*)
@@ -175,7 +175,7 @@ a symbol such as 'xz."
(match compression
((or #f 'none) (values input '()))
('bzip2 (filtered-port `(,%bzip2 "-dc") input))
- ('xz (filtered-port `(,%xz "-dc" "-T0") input))
+ ('xz (filtered-port `(,%xz "-dc") input))
('gzip (filtered-port `(,%gzip "-dc") input))
(else (error "unsupported compression scheme" compression))))
@@ -185,7 +185,7 @@ a symbol such as 'xz."
(match compression
((or #f 'none) (values input '()))
('bzip2 (filtered-port `(,%bzip2 "-c") input))
- ('xz (filtered-port `(,%xz "-c" "-T0") input))
+ ('xz (filtered-port `(,%xz "-c") input))
('gzip (filtered-port `(,%gzip "-c") input))
(else (error "unsupported compression scheme" compression))))
@@ -242,7 +242,7 @@ program--e.g., '(\"--fast\")."
(match compression
((or #f 'none) (values output '()))
('bzip2 (filtered-output-port `(,%bzip2 "-c" ,@options) output))
- ('xz (filtered-output-port `(,%xz "-c" "-T0" ,@options) output))
+ ('xz (filtered-output-port `(,%xz "-c" ,@options) output))
('gzip (filtered-output-port `(,%gzip "-c" ,@options) output))
(else (error "unsupported compression scheme" compression))))
@@ -631,7 +631,7 @@ delete it when leaving the dynamic extent of this call."
(lambda ()
(proc tmp-dir))
(lambda ()
- (false-if-exception (rmdir tmp-dir))))))
+ (false-if-exception (delete-file-recursively tmp-dir))))))
(define (with-atomic-file-output file proc)
"Call PROC with an output port for the file that is going to replace FILE.