diff options
| author | Marius Bakke <mbakke@fastmail.com> | 2018-07-24 19:56:35 +0200 |
|---|---|---|
| committer | Marius Bakke <mbakke@fastmail.com> | 2018-07-24 19:56:35 +0200 |
| commit | 706ae8e15c8d36b0aee7c19c54c143d3e17f5784 (patch) | |
| tree | e9fe8ebfb1417d30979b5413165599f066a1c504 /guix | |
| parent | 3e95125e9bd0676d4a9add9105217ad3eaef3ff0 (diff) | |
| parent | 8440db459a10daa24282038f35bc0b6771bd51ab (diff) | |
| download | gnu-guix-706ae8e15c8d36b0aee7c19c54c143d3e17f5784.tar gnu-guix-706ae8e15c8d36b0aee7c19c54c143d3e17f5784.tar.gz | |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
43 files changed, 2115 insertions, 549 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-system/meson.scm b/guix/build-system/meson.scm index 529a2b8b0f..e894e1472d 100644 --- a/guix/build-system/meson.scm +++ b/guix/build-system/meson.scm @@ -148,8 +148,7 @@ has a 'meson.build' file." #:search-paths ',(map search-path-specification->sexp search-paths) #:phases - (if (string-prefix? "arm" ,(or (%current-target-system) - (%current-system))) + (if (string-prefix? "arm" ,system) (modify-phases build-phases (delete 'fix-runpath)) build-phases) #:configure-flags ,configure-flags diff --git a/guix/build/ant-build-system.scm b/guix/build/ant-build-system.scm index d081a2b313..d79b4d503b 100644 --- a/guix/build/ant-build-system.scm +++ b/guix/build/ant-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2016, 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -68,14 +68,11 @@ (target (@ (name "manifest")) (mkdir (@ (dir "${manifest.dir}"))) - (echo (@ (file "${manifest.file}") - (message ,(string-append - (if main-class - (string-append - "Main-Class: " main-class - "${line.separator}") - "") - ""))))) + (manifest (@ (file "${manifest.file}")) + ,(if main-class + `(attribute (@ (name "Main-Class") + (value ,main-class))) + ""))) (target (@ (name "compile")) (mkdir (@ (dir "${classes.dir}"))) @@ -150,7 +147,8 @@ to the default GNU unpack strategy." (begin (mkdir "src") (with-directory-excursion "src" - (zero? (system* "jar" "-xf" source)))) + (invoke "jar" "-xf" source)) + #t) ;; Use GNU unpack strategy for things that aren't jar archives. ((assq-ref gnu:%standard-phases 'unpack) #:source source))) @@ -171,7 +169,7 @@ to the default GNU unpack strategy." (define* (build #:key (make-flags '()) (build-target "jar") #:allow-other-keys) - (zero? (apply system* `("ant" ,build-target ,@make-flags)))) + (apply invoke `("ant" ,build-target ,@make-flags))) (define* (generate-jar-indices #:key outputs #:allow-other-keys) "Generate file \"META-INF/INDEX.LIST\". This file does not use word wraps @@ -181,10 +179,11 @@ grafting works - and so that the garbage collector doesn't collect dependencies of this jar file." (define (generate-index jar) (invoke "jar" "-i" jar)) - (every (match-lambda - ((output . directory) - (every generate-index (find-files directory "\\.jar$")))) - outputs)) + (for-each (match-lambda + ((output . directory) + (for-each generate-index (find-files directory "\\.jar$")))) + outputs) + #t) (define* (strip-jar-timestamps #:key outputs #:allow-other-keys) @@ -194,50 +193,49 @@ repack them. This is necessary to ensure that archives are reproducible." (format #t "repacking ~a\n" jar) (let* ((dir (mkdtemp! "jar-contents.XXXXXX")) (manifest (string-append dir "/META-INF/MANIFEST.MF"))) - (and (with-directory-excursion dir - (zero? (system* "jar" "xf" jar))) - (delete-file jar) - ;; XXX: copied from (gnu build install) - (for-each (lambda (file) - (let ((s (lstat file))) - (unless (eq? (stat:type s) 'symlink) - (utime file 0 0 0 0)))) - (find-files dir #:directories? #t)) + (with-directory-excursion dir + (invoke "jar" "xf" jar)) + (delete-file jar) + ;; XXX: copied from (gnu build install) + (for-each (lambda (file) + (let ((s (lstat file))) + (unless (eq? (stat:type s) 'symlink) + (utime file 0 0 0 0)))) + (find-files dir #:directories? #t)) - ;; The jar tool will always set the timestamp on the manifest file - ;; and the containing directory to the current time, even when we - ;; reuse an existing manifest file. To avoid this we use "zip" - ;; instead of "jar". It is important that the manifest appears - ;; first. - (with-directory-excursion dir - (let* ((files (find-files "." ".*" #:directories? #t)) - ;; To ensure that the reference scanner can detect all - ;; store references in the jars we disable compression - ;; with the "-0" option. - (command (if (file-exists? manifest) - `("zip" "-0" "-X" ,jar ,manifest ,@files) - `("zip" "-0" "-X" ,jar ,@files)))) - (unless (zero? (apply system* command)) - (error "'zip' failed")))) - (utime jar 0 0) - #t))) + ;; The jar tool will always set the timestamp on the manifest file + ;; and the containing directory to the current time, even when we + ;; reuse an existing manifest file. To avoid this we use "zip" + ;; instead of "jar". It is important that the manifest appears + ;; first. + (with-directory-excursion dir + (let* ((files (find-files "." ".*" #:directories? #t)) + ;; To ensure that the reference scanner can detect all + ;; store references in the jars we disable compression + ;; with the "-0" option. + (command (if (file-exists? manifest) + `("zip" "-0" "-X" ,jar ,manifest ,@files) + `("zip" "-0" "-X" ,jar ,@files)))) + (apply invoke command))) + (utime jar 0 0) + #t)) - (every (match-lambda - ((output . directory) - (every repack-archive (find-files directory "\\.jar$")))) - outputs)) + (for-each (match-lambda + ((output . directory) + (for-each repack-archive (find-files directory "\\.jar$")))) + outputs) + #t) (define* (check #:key target (make-flags '()) (tests? (not target)) (test-target "check") #:allow-other-keys) (if tests? - (zero? (apply system* `("ant" ,test-target ,@make-flags))) - (begin - (format #t "test suite not run~%") - #t))) + (apply invoke `("ant" ,test-target ,@make-flags)) + (format #t "test suite not run~%")) + #t) (define* (install #:key (make-flags '()) #:allow-other-keys) - (zero? (apply system* `("ant" "install" ,@make-flags)))) + (apply invoke `("ant" "install" ,@make-flags))) (define %standard-phases (modify-phases gnu:%standard-phases 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/java-utils.scm b/guix/build/java-utils.scm index 402d377bf8..128be1edeb 100644 --- a/guix/build/java-utils.scm +++ b/guix/build/java-utils.scm @@ -31,7 +31,7 @@ (define* (ant-build-javadoc #:key (target "javadoc") (make-flags '()) #:allow-other-keys) - (zero? (apply system* `("ant" ,target ,@make-flags)))) + (apply invoke `("ant" ,target ,@make-flags))) (define* (install-jars jar-directory) "Install jar files from JAR-DIRECTORY to the default target directory. This diff --git a/guix/build/meson-build-system.scm b/guix/build/meson-build-system.scm index 6dac007a6d..9724764424 100644 --- a/guix/build/meson-build-system.scm +++ b/guix/build/meson-build-system.scm @@ -59,17 +59,14 @@ (mkdir build-dir) (chdir build-dir) - (apply invoke "meson" args) - #t)) + (apply invoke "meson" args))) (define* (build #:key parallel-build? #:allow-other-keys) "Build a given meson package." - (apply invoke "ninja" - (if parallel-build? - `("-j" ,(number->string (parallel-job-count))) - '("-j" "1"))) - #t) + (invoke "ninja" "-j" (if parallel-build? + (number->string (parallel-job-count)) + "1"))) (define* (check #:key test-target parallel-tests? tests? #:allow-other-keys) @@ -83,8 +80,7 @@ #t) (define* (install #:rest args) - (invoke "ninja" "install") - #t) + (invoke "ninja" "install")) (define* (fix-runpath #:key (elf-directories '("lib" "lib64" "libexec" "bin" "sbin")) 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..a346e9fb8e 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))) @@ -104,7 +105,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 +114,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 +139,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 +302,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/build/syscalls.scm b/guix/build/syscalls.scm index 25726b885e..74cb675fcf 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -46,6 +46,14 @@ MNT_DETACH MNT_EXPIRE UMOUNT_NOFOLLOW + + AT_FDCWD + AT_SYMLINK_NOFOLLOW + AT_REMOVEDIR + AT_SYMLINK_FOLLOW + AT_NO_AUTOMOUNT + AT_EMPTY_PATH + restart-on-EINTR mount-points swapon @@ -667,6 +675,15 @@ mounted at FILE." (* (file-system-block-size fs) (file-system-blocks-available fs)))) +;; Flags for the *at command, notably the 'utime' procedure of libguile. +;; From <fcntl.h>. +(define AT_FDCWD -100) +(define AT_SYMLINK_NOFOLLOW #x100) +(define AT_REMOVEDIR #x200) +(define AT_SYMLINK_FOLLOW #x400) +(define AT_NO_AUTOMOUNT #x800) +(define AT_EMPTY_PATH #x1000) + ;;; ;;; Containers. 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..4b2bfd4a25 100644 --- a/guix/import/cabal.scm +++ b/guix/import/cabal.scm @@ -139,8 +139,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 +150,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 +173,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 +213,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 +355,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 +371,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 +405,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 +451,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 +465,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 +536,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 +553,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)) @@ -658,6 +683,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 +725,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 +754,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 +768,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 +794,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))) @@ -795,12 +836,15 @@ See the manual for limitations."))))))) (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 +887,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/elpa.scm b/guix/import/elpa.scm index 65e0be45ab..c37afaf8e6 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -187,7 +187,9 @@ include VERSION." (url (package-source-url kind name ver repo))) (make-elpa-package name ver (ensure-list reqs) synopsis kind - (package-home-page (first rest)) + (package-home-page (match rest + (() #f) + ((one) one))) (fetch-package-description kind name repo) url))) (_ #f)))) 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/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 cc1f11ace2..3d9f281b74 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -641,6 +641,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 ebd7da2a24..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. @@ -703,6 +713,8 @@ MANIFEST." (module-ref (resolve-interface '(gnu packages texinfo)) 'texinfo)) (define gzip ;lazy reference (module-ref (resolve-interface '(gnu packages compression)) 'gzip)) + (define glibc-utf8-locales ;lazy reference + (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales)) (define build (with-imported-modules '((guix build utils)) @@ -720,11 +732,31 @@ MANIFEST." (map (cut string-append infodir "/" <>) (or (scandir infodir info-file?) '())))) + (define (info-file-language file) + (let* ((base (if (string-suffix? ".gz" file) + (basename file ".info.gz") + (basename file ".info"))) + (dot (string-rindex base #\.))) + (if dot + (string-drop base (+ 1 dot)) + "en"))) + (define (install-info info) - (setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files - (zero? - (system* (string-append #+texinfo "/bin/install-info") "--silent" - info (string-append #$output "/share/info/dir")))) + (let ((language (info-file-language info))) + ;; We need to choose a valid locale for $LANGUAGE to be honored. + (setenv "LC_ALL" "en_US.utf8") + (setenv "LANGUAGE" language) + (zero? + (system* #+(file-append texinfo "/bin/install-info") + "--silent" info + (apply string-append #$output "/share/info/dir" + (if (string=? "en" language) + '("") + `("." ,language))))))) + + (setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales "/lib/locale")) (mkdir-p (string-append #$output "/share/info")) (exit (every install-info @@ -1345,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? @@ -1370,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)) @@ -1477,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/container.scm b/guix/scripts/container.scm index 10aed2be75..8041d64b6b 100644 --- a/guix/scripts/container.scm +++ b/guix/scripts/container.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson <davet@gnu.org> +;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -54,7 +55,7 @@ Build and manipulate Linux containers.\n")) ((or ("-h") ("--help")) (show-help) (exit 0)) - (("--version") + ((or ("-V") ("--version")) (show-version-and-exit "guix container")) ((action args ...) (if (member action %actions) 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 67bc7a7553..0b326e1049 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 David Thompson <davet@gnu.org> +;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -74,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 @@ -104,7 +105,7 @@ Run IMPORTER with ARGS.\n")) ((or ("-h") ("--help")) (show-help) (exit 0)) - (("--version") + ((or ("-V") ("--version")) (show-version-and-exit "guix import")) ((importer args ...) (if (member importer importers) 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 7f087a3a3c..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 @@ -722,6 +721,7 @@ Create a bundle of PACKAGE.\n")) (if (assoc-ref opts 'bootstrap?) %bootstrap-guile (canonical-package guile-2.2)) + (assoc-ref opts 'system) #:graft? (assoc-ref opts 'graft?)))) (let* ((dry-run? (assoc-ref opts 'dry-run?)) (relocatable? (assoc-ref opts 'relocatable?)) 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/scripts/size.scm b/guix/scripts/size.scm index b7b53e43fb..344be40883 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -53,15 +53,6 @@ (define substitutable-path-info* (store-lift substitutable-path-info)) -(define (query-path-info* item) - "Monadic version of 'query-path-info' that returns #f when ITEM is not in -the store." - (lambda (store) - (guard (c ((nix-protocol-error? c) - ;; ITEM is not in the store; return #f. - (values #f store))) - (values (query-path-info store item) store)))) - (define (file-size item) "Return the size in bytes of ITEM, resorting to information from substitutes if ITEM is not in the store." diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index d0beacc8ea..7634bb37f6 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> +;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -1108,7 +1109,7 @@ default value." (process-substitution store-path destination #:cache-urls (substitute-urls) #:acl (current-acl)))) - (("--version") + ((or ("-V") ("--version")) (show-version-and-exit "guix substitute")) (("--help") (show-help)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 14aedceac1..69bd05b516 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -126,7 +126,11 @@ REFERENCES as its set of references." ;; Remove DEST if it exists to make sure that (1) we do not fail badly ;; while trying to overwrite it (see <http://bugs.gnu.org/20722>), and ;; (2) we end up with the right contents. - (when (file-exists? dest) + (when (false-if-exception (lstat dest)) + (for-each make-file-writable + (find-files dest (lambda (file stat) + (eq? 'directory (stat:type stat))) + #:directories? #t)) (delete-file-recursively dest)) (copy-recursively item dest @@ -148,12 +152,18 @@ REFERENCES as its set of references." "Copy ITEM and all its dependencies to the store under root directory TARGET, and register them." (mlet* %store-monad ((to-copy (topologically-sorted* (list item))) - (refs (mapm %store-monad references* to-copy))) + (refs (mapm %store-monad references* to-copy)) + (info (mapm %store-monad query-path-info* + (delete-duplicates + (append to-copy (concatenate refs))))) + (size -> (reduce + 0 (map path-info-nar-size info)))) (define progress-bar (progress-reporter/bar (length to-copy) (format #f (G_ "copying to '~a'...") target))) + (check-available-space size target) + (call-with-progress-reporter progress-bar (lambda (report) (let ((void (%make-void-port "w"))) diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index d7c2fbea10..98b7338fb9 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -269,7 +270,7 @@ Report the availability of substitutes.\n")) (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix challenge"))) + (show-version-and-exit "guix weather"))) (option '("substitute-urls") #t #f (lambda (opt name arg result . rest) diff --git a/guix/self.scm b/guix/self.scm index 89c5428039..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) @@ -343,7 +364,7 @@ DOMAIN, a gettext domain." (define* (guix-command modules #:optional compiled-modules #:key source (dependencies '()) - (guile-version (effective-version))) + guile (guile-version (effective-version))) "Return the 'guix' command such that it adds MODULES and DEPENDENCIES in its load path." (program-file "guix-command" @@ -383,15 +404,17 @@ load path." ;; XXX: It would be more convenient to change it to: ;; (exit (apply guix-main (command-line))) - (apply guix-main (command-line)))))) + (apply guix-main (command-line)))) + #:guile guile)) (define* (whole-package name modules dependencies #:key (guile-version (effective-version)) compiled-modules - info daemon + info daemon guile (command (guix-command modules #:dependencies dependencies + #:guile guile #:guile-version guile-version))) "Return the whole Guix package NAME that uses MODULES, a derivation of all the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the @@ -630,10 +653,12 @@ assumed to be part of MODULES." (command (guix-command modules compiled #:source source #:dependencies dependencies + #:guile guile-for-build #:guile-version guile-version))) (whole-package name modules dependencies #:compiled-modules compiled #:command command + #:guile guile-for-build ;; Include 'guix-daemon'. XXX: Here we inject an ;; older snapshot of guix-daemon, but that's a good @@ -762,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 '()) @@ -903,8 +896,10 @@ running Guile." (module-ref (resolve-interface '(gnu packages guile)) 'guile-2.2.2)) ("2.2" + ;; Use the latest version, which has fixes for + ;; <https://bugs.gnu.org/30602> and VM stack-marking issues. (canonical-package (module-ref (resolve-interface '(gnu packages guile)) - 'guile-2.2/fixed))) + 'guile-2.2.4))) ("2.0" (module-ref (resolve-interface '(gnu packages guile)) 'guile-2.0)))) 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 3bf56573bf..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 @@ -107,6 +110,7 @@ references references/substitutes references* + query-path-info* requisites referrers optimize-store @@ -134,6 +138,7 @@ set-current-system text-file interned-file + interned-file-tree %store-prefix store-path @@ -948,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)) @@ -1361,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 @@ -1388,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)) @@ -1398,6 +1512,15 @@ where FILE is the entry's absolute file name and STAT is the result of (define references* (store-lift references)) +(define (query-path-info* item) + "Monadic version of 'query-path-info' that returns #f when ITEM is not in +the store." + (lambda (store) + (guard (c ((nix-protocol-error? c) + ;; ITEM is not in the store; return #f. + (values #f store))) + (values (query-path-info store item) store)))) + (define-inlinable (current-system) ;; Consult the %CURRENT-SYSTEM fluid at bind time. This is equivalent to ;; (lift0 %current-system %store-monad), but inlinable, thus avoiding diff --git a/guix/store/database.scm b/guix/store/database.scm index 05b2ba6c3f..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,12 +211,10 @@ it's a directory. While at it, canonicalize file permissions." (type type)))))) (scandir* parent)))) ((symlink) - ;; FIXME: Implement bindings for 'futime' to reset the timestamps on - ;; symlinks. - #f) + (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 d3139eb904..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 @@ -88,28 +90,27 @@ LINK-PREFIX." (lambda args (if (= (system-error-errno args) EEXIST) (try (tempname-in link-prefix)) - (throw 'system-error args)))))) + (apply throw args)))))) ;; There are 3 main kinds of errors we can get from hardlinking: "Too many ;; things link to this" (EMLINK), "this link already exists" (EEXIST), and ;; "can't fit more stuff in this directory" (ENOSPC). -(define (replace-with-link target to-replace) - "Atomically replace the file TO-REPLACE with a link to TARGET. Note: TARGET -and TO-REPLACE must be on the same file system." - (let ((temp-link (get-temp-link target (dirname to-replace)))) - (rename-file temp-link to-replace))) +(define* (replace-with-link target to-replace + #:key (swap-directory (dirname target))) + "Atomically replace the file TO-REPLACE with a link to TARGET. Use +SWAP-DIRECTORY as the directory to store temporary hard links. -(define-syntax-rule (false-if-system-error (errors ...) exp ...) - "Given ERRORS, a list of system error codes to ignore, evaluates EXP... and -return #f if any of the system error codes in the given list are thrown." - (catch 'system-error - (lambda () - exp ...) - (lambda args - (if (member (system-error-errno args) (list errors ...)) - #f - (apply throw args))))) +Note: TARGET, TO-REPLACE, and SWAP-DIRECTORY must be on the same file system." + (let ((temp-link (get-temp-link target swap-directory))) + (make-file-writable (dirname to-replace)) + (catch 'system-error + (lambda () + (rename-file temp-link to-replace)) + (lambda args + (delete-file temp-link) + (unless (= EMLINK (system-error-errno args)) + (apply throw args)))))) (define* (deduplicate path hash #:key (store %store-directory)) "Check if a store item with sha256 hash HASH already exists. If so, @@ -131,8 +132,8 @@ under STORE." #:store store)))) (scandir path)) (if (file-exists? link-file) - (false-if-system-error (EMLINK) - (replace-with-link link-file path)) + (replace-with-link link-file path + #:swap-directory links-directory) (catch 'system-error (lambda () (link path link-file)) @@ -141,8 +142,8 @@ under STORE." (cond ((= errno EEXIST) ;; Someone else put an entry for PATH in ;; LINKS-DIRECTORY before we could. Let's use it. - (false-if-system-error (EMLINK) - (replace-with-link path link-file))) + (replace-with-link path link-file + #:swap-directory links-directory)) ((= errno ENOSPC) ;; There's not enough room in the directory index for ;; more entries in .links, but that's fine: we can diff --git a/guix/ui.scm b/guix/ui.scm index ec709450d8..29c0b2b9ce 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -9,6 +9,7 @@ ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2016 Roel Janssen <roel@gnu.org> ;;; Copyright © 2016 Benz Schenk <benz.schenk@uzh.ch> +;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -87,6 +88,7 @@ leave-on-EPIPE read/eval read/eval-package-expression + check-available-space location->string fill-paragraph %text-width @@ -519,6 +521,9 @@ FILE." (set! canonicalize-path (error-reporting-wrapper canonicalize-path (file) file)) +(set! delete-file + (error-reporting-wrapper delete-file (file) file)) + (define (make-regexp* regexp . flags) "Like 'make-regexp' but error out if REGEXP is invalid, reporting the error @@ -795,16 +800,17 @@ error." (derivation->output-path derivation out-name))) (derivation-outputs derivation)))) -(define (check-available-space need) - "Make sure at least NEED bytes are available in the store. Otherwise emit a +(define* (check-available-space need + #:optional (directory (%store-prefix))) + "Make sure at least NEED bytes are available in DIRECTORY. Otherwise emit a warning." (let ((free (catch 'system-error (lambda () - (free-disk-space (%store-prefix))) + (free-disk-space directory)) (const #f)))) (when (and free (>= need free)) (warning (G_ "at least ~,1h MB needed but only ~,1h MB available in ~a~%") - (/ need 1e6) (/ free 1e6) (%store-prefix))))) + (/ need 1e6) (/ free 1e6) directory)))) (define* (show-what-to-build store drv #:key dry-run? (use-substitutes? #t) @@ -1222,11 +1228,14 @@ field in the final score. A score of zero means that OBJ does not match any of REGEXPS. The higher the score, the more relevant OBJ is to REGEXPS." (define (score str) - (let ((counts (filter-map (lambda (regexp) - (match (regexp-exec regexp str) - (#f #f) - (m (match:count m)))) - regexps))) + (let ((counts (map (lambda (regexp) + (match (fold-matches regexp str '() cons) + (() 0) + ((m) (if (string=? (match:substring m) str) + 5 ;exact match + 1)) + (lst (length lst)))) + regexps))) ;; Compute a score that's proportional to the number of regexps matched ;; and to the number of matches for each regexp. (* (length counts) (reduce + 0 counts)))) @@ -1419,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))) @@ -1590,7 +1599,7 @@ and signal handling has already been set up." (show-guix-usage)) ((or ("-h") ("--help")) (show-guix-help)) - (("--version") + ((or ("-V") ("--version")) (show-version-and-exit "guix")) (((? option? o) args ...) (format (current-error-port) diff --git a/guix/utils.scm b/guix/utils.scm index a5de9605e7..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. @@ -773,22 +773,28 @@ be determined." (line location-line) ; 1-indexed line (column location-column)) ; 0-indexed column -(define location - (mlambda (file line column) - "Return the <location> object for the given FILE, LINE, and COLUMN." - (and line column file - (make-location file line column)))) +(define (location file line column) + "Return the <location> object for the given FILE, LINE, and COLUMN." + (and line column file + (make-location file line column))) (define (source-properties->location loc) "Return a location object based on the info in LOC, an alist as returned by Guile's `source-properties', `frame-source', `current-source-location', etc." - (let ((file (assq-ref loc 'filename)) - (line (assq-ref loc 'line)) - (col (assq-ref loc 'column))) - ;; In accordance with the GCS, start line and column numbers at 1. Note - ;; that unlike LINE and `port-column', COL is actually 1-indexed here... - (location file (and line (+ line 1)) col))) + ;; In accordance with the GCS, start line and column numbers at 1. Note + ;; that unlike LINE and `port-column', COL is actually 1-indexed here... + (match loc + ((('line . line) ('column . col) ('filename . file)) ;common case + (and file line col + (make-location file (+ line 1) col))) + (#f + #f) + (_ + (let ((file (assq-ref loc 'filename)) + (line (assq-ref loc 'line)) + (col (assq-ref loc 'column))) + (location file (and line (+ line 1)) col))))) (define (location->source-properties loc) "Return the source property association list based on the info in LOC, |