From 4f3811f6bbdfba817601eb3168f5b3e0d2f1c3f6 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 9 Sep 2018 11:42:29 +0200 Subject: guix: copy-linux-headers: Extract procedure, add headers. * guix/build/make-bootstrap.scm (copy-linux-headers): New procedure; extract from make-stripped-libc and add headers for Mes bootstrap. (make-stripped-libc): Use it. --- guix/build/make-bootstrap.scm | 72 +++++++++++++++++++++++++++++++------------ 1 file changed, 53 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/build/make-bootstrap.scm b/guix/build/make-bootstrap.scm index 48799f7e90..e5ef1d6d2b 100644 --- a/guix/build/make-bootstrap.scm +++ b/guix/build/make-bootstrap.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2017 Manolis Fragkiskos Ragkousis ;;; Copyright © 2015, 2019 Ludovic Courtès +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,7 +24,8 @@ #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (guix build utils) - #:export (make-stripped-libc)) + #:export (copy-linux-headers + make-stripped-libc)) ;; Commentary: ;; @@ -31,6 +33,53 @@ ;; ;; Code: +(define (copy-linux-headers output kernel-headers) + "Copy to OUTPUT the subset of KERNEL-HEADERS that is needed when producing a +bootstrap libc." + + (let* ((incdir (string-append output "/include"))) + (mkdir-p incdir) + + ;; Copy some of the Linux-Libre headers that glibc headers + ;; refer to. + (mkdir (string-append incdir "/linux")) + (for-each (lambda (file) + (install-file (pk 'src (string-append kernel-headers "/include/linux/" file)) + (pk 'dest (string-append incdir "/linux")))) + '( + "a.out.h" ; for 2.2.5 + "atalk.h" ; for 2.2.5 + "errno.h" + "falloc.h" + "if_addr.h" ; for 2.16.0 + "if_ether.h" ; for 2.2.5 + "if_link.h" ; for 2.16.0 + "ioctl.h" + "kernel.h" + "limits.h" + "neighbour.h" ; for 2.16.0 + "netlink.h" ; for 2.16.0 + "param.h" + "prctl.h" ; for 2.16.0 + "posix_types.h" + "rtnetlink.h" ; for 2.16.0 + "socket.h" + "stddef.h" + "swab.h" ; for 2.2.5 + "sysctl.h" + "sysinfo.h" ; for 2.2.5 + "types.h" + "version.h" ; for 2.2.5 + )) + + (copy-recursively (string-append kernel-headers "/include/asm") + (string-append incdir "/asm")) + (copy-recursively (string-append kernel-headers "/include/asm-generic") + (string-append incdir "/asm-generic")) + (copy-recursively (string-append kernel-headers "/include/linux/byteorder") + (string-append incdir "/linux/byteorder")) + #t)) + (define (make-stripped-libc output libc kernel-headers) "Copy to OUTPUT the subset of LIBC and KERNEL-HEADERS that is needed when producing a bootstrap libc." @@ -43,25 +92,10 @@ when producing a bootstrap libc." (string-append incdir "/mach")) #t)) - (define (copy-linux-headers output kernel-headers) + (define (copy-libc+linux-headers output kernel-headers) (let* ((incdir (string-append output "/include"))) (copy-recursively (string-append libc "/include") incdir) - - ;; Copy some of the Linux-Libre headers that glibc headers - ;; refer to. - (mkdir (string-append incdir "/linux")) - (for-each (lambda (file) - (install-file (string-append kernel-headers "/include/linux/" file) - (string-append incdir "/linux"))) - '("limits.h" "errno.h" "socket.h" "kernel.h" - "sysctl.h" "param.h" "ioctl.h" "types.h" - "posix_types.h" "stddef.h" "falloc.h")) - - (copy-recursively (string-append kernel-headers "/include/asm") - (string-append incdir "/asm")) - (copy-recursively (string-append kernel-headers "/include/asm-generic") - (string-append incdir "/asm-generic")) - #t)) + (copy-linux-headers output kernel-headers))) (define %libc-object-files-rx "^(crt.*|ld.*|lib(c|m|dl|rt|pthread|nsl|\ util).*\\.so(\\..*)?|lib(machuser|hurduser).so.*|(libc(rt|)|libpthread)\ @@ -80,6 +114,6 @@ _nonshared\\.a)$") (if (directory-exists? (string-append kernel-headers "/include/mach")) (copy-mach-headers output kernel-headers) - (copy-linux-headers output kernel-headers))) + (copy-libc+linux-headers output kernel-headers))) -- cgit v1.2.3 From b908fcd8c02c26b1e6cdc636b63306a01a21b994 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 23 Aug 2019 17:45:17 +0200 Subject: pack: '-R' honors the requested output. Fixes . Reported by Jesse Gibbons . * guix/scripts/pack.scm (wrapped-package): Add 'output*' parameter. [build]: Define 'input' and 'target'; use them instead of #$package and #$output, respectively. (wrapped-manifest-entry): New procedure. (map-manifest-entries): Call PROC directly. (guix-pack): Pass WRAPPED-MANIFEST-ENTRY to 'map-manifest-entries'. --- guix/scripts/pack.scm | 49 ++++++++++++++++++++++++++++-------------- tests/guix-pack-relocatable.sh | 6 ++++++ 2 files changed, 39 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index fdb98983bf..794d2ee390 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -611,8 +611,13 @@ please email '~a'~%") ;;; (define* (wrapped-package package - #:optional (compiler (c-compiler)) + #:optional + (output* "out") + (compiler (c-compiler)) #:key proot?) + "Return the OUTPUT of PACKAGE with its binaries wrapped such that they are +relocatable. When PROOT? is true, include PRoot in the result and use it as a +last resort for relocation." (define runner (local-file (search-auxiliary-file "run-in-namespace.c"))) @@ -629,6 +634,14 @@ please email '~a'~%") (ice-9 ftw) (ice-9 match)) + (define input + ;; The OUTPUT* output of PACKAGE. + (ungexp package output*)) + + (define target + ;; The output we are producing. + (ungexp output output*)) + (define (strip-store-prefix file) ;; Given a file name like "/gnu/store/…-foo-1.2/bin/foo", return ;; "/bin/foo". @@ -648,7 +661,7 @@ please email '~a'~%") (("@STORE_DIRECTORY@") (%store-directory))) (let* ((base (strip-store-prefix program)) - (result (string-append #$output "/" base)) + (result (string-append target "/" base)) (proot #$(and proot? #~(string-drop #$(file-append (proot) "/bin/proot") @@ -667,18 +680,18 @@ please email '~a'~%") ;; Link the top-level files of PACKAGE so that search paths are ;; properly defined in PROFILE/etc/profile. - (mkdir #$output) + (mkdir target) (for-each (lambda (file) (unless (member file '("." ".." "bin" "sbin" "libexec")) - (let ((file* (string-append #$package "/" file))) - (symlink (relative-file-name #$output file*) - (string-append #$output "/" file))))) - (scandir #$package)) + (let ((file* (string-append input "/" file))) + (symlink (relative-file-name target file*) + (string-append target "/" file))))) + (scandir input)) (for-each build-wrapper - (append (find-files #$(file-append package "/bin")) - (find-files #$(file-append package "/sbin")) - (find-files #$(file-append package "/libexec"))))))) + (append (find-files (string-append input "/bin")) + (find-files (string-append input "/sbin")) + (find-files (string-append input "/libexec"))))))) (computed-file (string-append (cond ((package? package) @@ -691,14 +704,18 @@ please email '~a'~%") "R") build)) +(define (wrapped-manifest-entry entry . args) + (manifest-entry + (inherit entry) + (item (apply wrapped-package + (manifest-entry-item entry) + (manifest-entry-output entry) + args)))) + (define (map-manifest-entries proc manifest) "Apply PROC to all the entries of MANIFEST and return a new manifest." (make-manifest - (map (lambda (entry) - (manifest-entry - (inherit entry) - (item (proc (manifest-entry-item entry))))) - (manifest-entries manifest)))) + (map proc (manifest-entries manifest)))) ;;; @@ -960,7 +977,7 @@ Create a bundle of PACKAGE.\n")) ;; 'glibc-bootstrap' lacks 'libc.a'. (if relocatable? (map-manifest-entries - (cut wrapped-package <> #:proot? proot?) + (cut wrapped-manifest-entry <> #:proot? proot?) manifest) manifest))) (pack-format (assoc-ref opts 'format)) diff --git a/tests/guix-pack-relocatable.sh b/tests/guix-pack-relocatable.sh index ebada62c01..e93610eedc 100644 --- a/tests/guix-pack-relocatable.sh +++ b/tests/guix-pack-relocatable.sh @@ -78,3 +78,9 @@ else "$test_directory/Bin/sed" --version > "$test_directory/output" fi grep 'GNU sed' "$test_directory/output" +chmod -Rf +w "$test_directory"; rm -rf "$test_directory"/* + +# Ensure '-R' works with outputs other than "out". +tarball="`guix pack -R -S /share=share groff:doc`" +(cd "$test_directory"; tar xvf "$tarball") +test -d "$test_directory/share/doc/groff/html" -- cgit v1.2.3 From 90c98b5a89038c41a0db0add9e2a3d4d1a1b6102 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 23 Aug 2019 18:16:13 +0200 Subject: swh: 'swh-download' checks return value of 'vault-fetch'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Reported by Björn Höfling in . * guix/swh.scm (swh-download): Check whether 'vault-fetch' return false before calling 'dump-port'. --- guix/swh.scm | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/guix/swh.scm b/guix/swh.scm index df2a138f04..1c416c8dd5 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -547,19 +547,22 @@ wait until it becomes available, which could take several minutes." ((? revision? revision) (call-with-temporary-directory (lambda (directory) - (let ((input (vault-fetch (revision-directory revision) 'directory)) - (tar (open-pipe* OPEN_WRITE "tar" "-C" directory "-xzvf" "-"))) - (dump-port input tar) - (close-port input) - (let ((status (close-pipe tar))) - (unless (zero? status) - (error "tar extraction failure" status))) - - (match (scandir directory) - (("." ".." sub-directory) - (copy-recursively (string-append directory "/" sub-directory) - output - #:log (%make-void-port "w")) - #t)))))) + (match (vault-fetch (revision-directory revision) 'directory) + (#f + #f) + ((? port? input) + (let ((tar (open-pipe* OPEN_WRITE "tar" "-C" directory "-xzvf" "-"))) + (dump-port input tar) + (close-port input) + (let ((status (close-pipe tar))) + (unless (zero? status) + (error "tar extraction failure" status))) + + (match (scandir directory) + (("." ".." sub-directory) + (copy-recursively (string-append directory "/" sub-directory) + output + #:log (%make-void-port "w")) + #t)))))))) (#f #f))) -- cgit v1.2.3 From 6cef554be8926b026226b4bfd0bb2f37bd24aeae Mon Sep 17 00:00:00 2001 From: David Thompson Date: Thu, 1 Aug 2019 08:46:13 -0400 Subject: packages: Apply target triplet in bag-transitive-host-inputs. Fixes a bug where propagated inputs that should be cross-compiled are instead compiled for the host system. * guix/packages.scm (bag-transitive-host-inputs): Call transitive-inputs in the context of the bag's target system triplet. --- guix/packages.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index c94a651f27..143417b861 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -796,7 +796,8 @@ dependencies are known to build on SYSTEM." (define (bag-transitive-host-inputs bag) "Same as 'package-transitive-target-inputs', but applied to a bag." - (transitive-inputs (bag-host-inputs bag))) + (parameterize ((%current-target-system (bag-target bag))) + (transitive-inputs (bag-host-inputs bag)))) (define (bag-transitive-target-inputs bag) "Return the \"target inputs\" of BAG, recursively." -- cgit v1.2.3 From dd6976dd75ca97572e0e88a6be2e550fb0824c68 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Aug 2019 21:34:40 +0200 Subject: import: github: 'github-package?' uses 'package-upstream-name'. * guix/import/github.scm (updated-github-url): Use 'package-upstream-name' instead of 'package-name'. This allows 'github-package?' to match more packages, given an appropriate upstream name. --- guix/import/github.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/github.scm b/guix/import/github.scm index fa23fa4c06..55e1f72a42 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -49,7 +49,7 @@ false if none is recognized" (define (updated-url url) (if (string-prefix? "https://github.com/" url) (let ((ext (or (find-extension url) "")) - (name (package-name old-package)) + (name (package-upstream-name old-package)) (version (package-version old-package)) (prefix (string-append "https://github.com/" (github-user-slash-repository url))) -- cgit v1.2.3 From 2b7c89f4fcc5e1607e153939d54d32aeaf494ca9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 27 Aug 2019 11:02:14 +0200 Subject: docker: Take a list of directives instead of a list of symlinks. * guix/docker.scm (symlink-source, topmost-component): Remove. (directive-file): New procedure. (build-docker-image): Remove #:symlinks and add #:extra-files. Make a sub-directory "extra" and call 'evaluate-populate-directive' for EXTRA-FILES in that directory. * guix/scripts/pack.scm (docker-image)[build](symlink->directives, directives): New procedures. Pass #:extra-files instead of #:symlinks to 'build-docker-image'. --- guix/docker.scm | 68 ++++++++++++++++++++++++--------------------------- guix/scripts/pack.scm | 20 +++++++++++++-- 2 files changed, 50 insertions(+), 38 deletions(-) (limited to 'guix') diff --git a/guix/docker.scm b/guix/docker.scm index c598a073f6..757bdeb458 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -28,11 +28,13 @@ invoke)) #:use-module (gnu build install) #:use-module (json) ;guile-json + #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module ((texinfo string-utils) #:select (escape-special-chars)) #:use-module (rnrs bytevectors) + #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:export (build-docker-image)) @@ -99,21 +101,18 @@ '("--sort=name" "--mtime=@1" "--owner=root:0" "--group=root:0")) -(define symlink-source +(define directive-file + ;; Return the file or directory created by a 'evaluate-populate-directive' + ;; directive. (match-lambda ((source '-> target) - (string-trim source #\/)))) - -(define (topmost-component file) - "Return the topmost component of FILE. For instance, if FILE is \"/a/b/c\", -return \"a\"." - (match (string-tokenize file (char-set-complement (char-set #\/))) - ((first rest ...) - first))) + (string-trim source #\/)) + (('directory name _ ...) + (string-trim name #\/)))) (define* (build-docker-image image paths prefix #:key - (symlinks '()) + (extra-files '()) (transformations '()) (system (utsname:machine (uname))) database @@ -133,8 +132,9 @@ entry point in the Docker image JSON structure. ENVIRONMENT must be a list of name/value pairs. It specifies the environment variables that must be defined in the resulting image. -SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be -created in the image, where each TARGET is relative to PREFIX. +EXTRA-FILES must be a list of directives for 'evaluate-populate-directive' +describing non-store files that must be created in the image. + TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to transform the PATHS. Any path in PATHS that begins with OLD will be rewritten in the Docker image so that it begins with NEW instead. If a path is a @@ -199,25 +199,27 @@ SRFI-19 time-utc object, as the creation time in metadata." (with-output-to-file "json" (lambda () (scm->json (image-description id time)))) - ;; Create SYMLINKS. - (for-each (match-lambda - ((source '-> target) - (let ((source (string-trim source #\/))) - (mkdir-p (dirname source)) - (symlink (string-append prefix "/" target) - source)))) - symlinks) + ;; Create a directory for the non-store files that need to go into the + ;; archive. + (mkdir "extra") + + (with-directory-excursion "extra" + ;; Create non-store files. + (for-each (cut evaluate-populate-directive <> "./") + extra-files) - (when database - ;; Initialize /var/guix, assuming PREFIX points to a profile. - (install-database-and-gc-roots "." database prefix)) + (when database + ;; Initialize /var/guix, assuming PREFIX points to a profile. + (install-database-and-gc-roots "." database prefix)) + + (apply invoke "tar" "-cf" "../layer.tar" + `(,@transformation-options + ,@%tar-determinism-options + ,@paths + ,@(scandir "." + (lambda (file) + (not (member file '("." "..")))))))) - (apply invoke "tar" "-cf" "layer.tar" - `(,@transformation-options - ,@%tar-determinism-options - ,@paths - ,@(if database '("var") '()) - ,@(map symlink-source symlinks))) ;; It is possible for "/" to show up in the archive, especially when ;; applying transformations. For example, the transformation ;; "s,^/a,," will (perhaps surprisingly) cause GNU tar to transform @@ -231,13 +233,7 @@ SRFI-19 time-utc object, as the creation time in metadata." (lambda () (system* "tar" "--delete" "/" "-f" "layer.tar"))) - (for-each delete-file-recursively - (map (compose topmost-component symlink-source) - symlinks)) - - ;; Delete /var/guix. - (when database - (delete-file-recursively "var"))) + (delete-file-recursively "extra")) (with-output-to-file "config.json" (lambda () diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 794d2ee390..a15530ad70 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -490,7 +490,8 @@ the image." #~(begin (use-modules (guix docker) (guix build store-copy) (guix profiles) (guix search-paths) - (srfi srfi-19) (ice-9 match)) + (srfi srfi-1) (srfi srfi-19) + (ice-9 match)) (define environment (map (match-lambda @@ -499,6 +500,21 @@ the image." value))) (profile-search-paths #$profile))) + (define symlink->directives + ;; Return "populate directives" to make the given symlink and its + ;; parent directories. + (match-lambda + ((source '-> target) + (let ((target (string-append #$profile "/" target)) + (parent (dirname source))) + `((directory ,parent) + (,source -> ,target)))))) + + (define directives + ;; Fully-qualified symlinks. + (append-map symlink->directives '#$symlinks)) + + (setenv "PATH" (string-append #$archiver "/bin")) (build-docker-image #$output @@ -513,7 +529,7 @@ the image." #$(and entry-point #~(list (string-append #$profile "/" #$entry-point))) - #:symlinks '#$symlinks + #:extra-files directives #:compressor '#$(compressor-command compressor) #:creation-time (make-time time-utc 0 1)))))) -- cgit v1.2.3 From 7979a287f8eb84cbbfa44629951572408939a756 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 27 Aug 2019 11:27:02 +0200 Subject: pack: Create /tmp in Docker images. Fixes . * guix/scripts/pack.scm (docker-image)[build]: Add a 'directory' entry for "/tmp" to DIRECTIVES. * tests/pack.scm ("docker-image + localstatedir"): Test the presence of /tmp. * gnu/tests/docker.scm (run-docker-test)["Load docker image and run it"]: Test the presence and permission bits of "/tmp". --- gnu/tests/docker.scm | 13 ++++++++++--- guix/scripts/pack.scm | 6 ++++-- tests/pack.scm | 1 + 3 files changed, 15 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm index 3ec5c3d6ee..3f98a1e316 100644 --- a/gnu/tests/docker.scm +++ b/gnu/tests/docker.scm @@ -100,7 +100,7 @@ inside %DOCKER-OS." marionette)) (test-equal "Load docker image and run it" - '("hello world" "hi!" "JSON!") + '("hello world" "hi!" "JSON!" #o1777) (marionette-eval `(begin (define slurp @@ -131,8 +131,15 @@ inside %DOCKER-OS." ,(string-append #$docker-cli "/bin/docker") "run" repository&tag "-c" "(use-modules (json)) - (display (json-string->scm (scm->json-string \"JSON!\")))"))) - (list response1 response2 response3))) + (display (json-string->scm (scm->json-string \"JSON!\")))")) + + ;; Check whether /tmp exists. + (response4 (slurp + ,(string-append #$docker-cli "/bin/docker") + "run" repository&tag "-c" + "(display (stat:perms (lstat \"/tmp\")))"))) + (list response1 response2 response3 + (string->number response4)))) marionette)) (test-end) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index a15530ad70..dd91a24284 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -511,8 +511,10 @@ the image." (,source -> ,target)))))) (define directives - ;; Fully-qualified symlinks. - (append-map symlink->directives '#$symlinks)) + ;; Create a /tmp directory, as some programs expect it, and + ;; create SYMLINKS. + `((directory "/tmp" ,(getuid) ,(getgid) #o1777) + ,@(append-map symlink->directives '#$symlinks))) (setenv "PATH" (string-append #$archiver "/bin")) diff --git a/tests/pack.scm b/tests/pack.scm index ea88cd89f2..71ff5aec18 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -169,6 +169,7 @@ (when (and (file-exists? (string-append bin "/guile")) (file-exists? "var/guix/db/db.sqlite") + (file-is-directory? "tmp") (string=? (string-append #$%bootstrap-guile "/bin") (pk 'binlink (readlink bin))) (string=? (string-append #$profile "/bin/guile") -- cgit v1.2.3 From 58d5f280a36e1cfddfa999d320c285726d8a8bc1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 27 Aug 2019 23:59:48 +0200 Subject: lint: Correct use of 'with-networking-fail-safe'. Fixes . Reported by Jonathan Brielmaier . * guix/lint.scm (check-for-updates): Make sure the first argument to 'with-networking-fail-safe' is the whole error message. --- guix/lint.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index 7a2bf5a347..212ff70d54 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -1008,8 +1008,8 @@ the NIST server non-fatal." (define (check-for-updates package) "Check if there is an update available for PACKAGE." (match (with-networking-fail-safe - (G_ "while retrieving upstream info for '~a'") - (list (package-name package)) + (format #f (G_ "while retrieving upstream info for '~a'") + (package-name package)) #f (package-latest-release* package (force %updaters))) ((? upstream-source? source) -- cgit v1.2.3 From 3762e31b6c8089928aad3186f70f157502950e3b Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Thu, 22 Aug 2019 16:21:26 +0300 Subject: build/cargo-build-system: Remove 'update-cargo-lock phase. * guix/build/cargo-build-system.scm (update-cargo-lock): Remove procedure. (configure): Delete Cargo.lock file if it exists. (%standard-phases): Remove 'update-cargo-lock. * doc/guix.texi (Build System)[cargo-build-system]: Remove references to the 'update-cargo-lock phase. --- doc/guix.texi | 9 ++++----- guix/build/cargo-build-system.scm | 19 ++++--------------- 2 files changed, 8 insertions(+), 20 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 90b2deb251..707c2ba700 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5854,11 +5854,10 @@ should be added to the package definition via the In its @code{configure} phase, this build system will make any source inputs specified in the @code{#:cargo-inputs} and @code{#:cargo-development-inputs} -parameters available to cargo. The @code{update-cargo-lock} phase will, -when there is a @code{Cargo.lock} file, update the @code{Cargo.lock} file -with the inputs and their versions available at build time. The -@code{install} phase installs any crate the binaries if they are defined by -the crate. +parameters available to cargo. It will also remove an included +@code{Cargo.lock} file to be recreated by @code{cargo} during the +@code{build} phase. The @code{install} phase installs any crate the binaries +if they are defined by the crate. @end defvr @cindex Clojure (programming language) diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 7d363a18a5..06ed14b89f 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -134,22 +134,12 @@ directory = '" port) ;; upgrading the compiler for example. (setenv "RUSTFLAGS" "--cap-lints allow") (setenv "CC" (string-append (assoc-ref inputs "gcc") "/bin/gcc")) - #t) -;; The Cargo.lock file tells the build system which crates are required for -;; building and hardcodes their version and checksum. In order to build with -;; the inputs we provide, we need to recreate the file with our inputs. -(define* (update-cargo-lock #:key - (vendor-dir "guix-vendor") - #:allow-other-keys) - "Regenerate the Cargo.lock file with the current build inputs." + ;; We don't use the Cargo.lock file to determine the package versions we use + ;; during building, and in any case if one is not present it is created + ;; during the 'build phase by cargo. (when (file-exists? "Cargo.lock") - (begin - ;; Unfortunately we can't generate a Cargo.lock file until the checksums - ;; are generated, so we have an extra round of generate-all-checksums here. - (generate-all-checksums vendor-dir) - (delete-file "Cargo.lock") - (invoke "cargo" "generate-lockfile"))) + (delete-file "Cargo.lock")) #t) ;; After the 'patch-generated-file-shebangs phase any vendored crates who have @@ -203,7 +193,6 @@ directory = '" port) (replace 'build build) (replace 'check check) (replace 'install install) - (add-after 'configure 'update-cargo-lock update-cargo-lock) (add-after 'patch-generated-file-shebangs 'patch-cargo-checksums patch-cargo-checksums))) (define* (cargo-build #:key inputs (phases %standard-phases) -- cgit v1.2.3 From b8815c5ec4ee70c535693031072447671c1b781f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Aug 2019 11:10:55 +0200 Subject: swh: 'swh-download' prints debugging info. * guix/git-download.scm (git-fetch): Print a message before calling 'swh-download'. * guix/swh.scm (swh-download): Add #:log-port. Write debugging messages to LOG-PORT. --- guix/git-download.scm | 7 +++++-- guix/swh.scm | 12 ++++++++++-- 2 files changed, 15 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/git-download.scm b/guix/git-download.scm index 8f84681d46..c62bb8ad0f 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -139,8 +139,11 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ;; As a last resort, attempt to download from Software Heritage. ;; XXX: Currently recursive checkouts are not supported. (and (not recursive?) - (swh-download (getenv "git url") (getenv "git commit") - #$output))))))) + (begin + (format (current-error-port) + "Trying to download from Software Heritage...~%") + (swh-download (getenv "git url") (getenv "git commit") + #$output)))))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "git-checkout") build diff --git a/guix/swh.scm b/guix/swh.scm index 1c416c8dd5..b72d1c311e 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -533,7 +533,8 @@ delete it when leaving the dynamic extent of this call." (lambda () (false-if-exception (delete-file-recursively tmp-dir)))))) -(define (swh-download url reference output) +(define* (swh-download url reference output + #:key (log-port (current-error-port))) "Download from Software Heritage a checkout of the Git tag or commit REFERENCE originating from URL, and unpack it in OUTPUT. Return #t on success and #f on failure. @@ -545,10 +546,17 @@ wait until it becomes available, which could take several minutes." (lookup-revision reference) (lookup-origin-revision url reference)) ((? revision? revision) + (format log-port "SWH: found revision ~a with directory at '~a'~%" + (revision-id revision) + (swh-url (revision-directory-url revision))) (call-with-temporary-directory (lambda (directory) - (match (vault-fetch (revision-directory revision) 'directory) + (match (vault-fetch (revision-directory revision) 'directory + #:log-port log-port) (#f + (format log-port + "SWH: directory ~a could not be fetched from the vault~%" + (revision-directory revision)) #f) ((? port? input) (let ((tar (open-pipe* OPEN_WRITE "tar" "-C" directory "-xzvf" "-"))) -- cgit v1.2.3 From 8146c48632d39670afa7a8ec08a8891cc78d2b38 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Aug 2019 11:31:18 +0200 Subject: swh: Correctly handle visits without a snapshot. As discussed at . * guix/swh.scm (string*): New procedure. ()[snapshot-url]: Pass 'string*' as the conversion procedure. [status]: Pass 'string->symbol' as the conversion procedure. (visit-snapshot): Return #f when 'visit-snapshot-url' returns #f. (lookup-origin-revision): Filter to visits for which 'visit-snapshot-url' is true. --- guix/swh.scm | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/swh.scm b/guix/swh.scm index b72d1c311e..c253e217da 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -190,6 +190,12 @@ Software Heritage." (ref 10)))))) str)) ;oops! +(define string* + ;; Converts "string or #nil" coming from JSON to "string or #f". + (match-lambda + ((? string? str) str) + ((? null?) #f))) + (define* (call url decode #:optional (method http-get) #:key (false-if-404? #t)) "Invoke the endpoint at URL using METHOD. Decode the resulting JSON body @@ -239,8 +245,8 @@ FALSE-IF-404? is true, return #f upon 404 responses." (date visit-date "date" string->date*) (origin visit-origin) (url visit-url "origin_visit_url") - (snapshot-url visit-snapshot-url "snapshot_url") - (status visit-status) + (snapshot-url visit-snapshot-url "snapshot_url" string*) ;string | #f + (status visit-status "status" string->symbol) ;'full | 'partial | 'ongoing (number visit-number "visit")) ;; @@ -378,9 +384,11 @@ FALSE-IF-404? is true, return #f upon 404 responses." (map json->visit (vector->list (json->scm port)))))) (define (visit-snapshot visit) - "Return the snapshot corresponding to VISIT." - (call (swh-url (visit-snapshot-url visit)) - json->snapshot)) + "Return the snapshot corresponding to VISIT or #f if no snapshot is +available." + (and (visit-snapshot-url visit) + (call (swh-url (visit-snapshot-url visit)) + json->snapshot))) (define (branch-target branch) "Return the target of BRANCH, either a or a ." @@ -396,7 +404,7 @@ FALSE-IF-404? is true, return #f upon 404 responses." "Return a corresponding to the given TAG for the repository coming from URL. Example: - (lookup-origin-release \"https://github.com/guix-mirror/guix/\" \"v0.8\") + (lookup-origin-revision \"https://github.com/guix-mirror/guix/\" \"v0.8\") => #< id: \"44941…\" …> The information is based on the latest visit of URL available. Return #f if @@ -404,7 +412,7 @@ URL could not be found." (match (lookup-origin url) (#f #f) (origin - (match (origin-visits origin) + (match (filter visit-snapshot-url (origin-visits origin)) ((visit . _) (let ((snapshot (visit-snapshot visit))) (match (and=> (find (lambda (branch) -- cgit v1.2.3 From 8f67a76a544a9ff7b60de64d5619a63296c9553e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Aug 2019 17:38:45 +0200 Subject: lint: Log diagnostics with 'info', not 'warning'. * guix/scripts/lint.scm (emit-warnings): Use 'info', not 'warning'. This removes the unhelpful "warning:" prefix that commit 3d33c93cef67d88bdc9409959f3c1f3857af09cf introduced. --- guix/scripts/lint.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index ee1c826d2e..1668d02992 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -46,9 +46,9 @@ (lambda (lint-warning) (let ((package (lint-warning-package lint-warning)) (loc (lint-warning-location lint-warning))) - (warning loc (G_ "~a@~a: ~a~%") - (package-name package) (package-version package) - (lint-warning-message lint-warning)))) + (info loc (G_ "~a@~a: ~a~%") + (package-name package) (package-version package) + (lint-warning-message lint-warning)))) warnings)) (define (run-checkers package checkers) -- cgit v1.2.3 From d229215051b87bfc4657e8416f0e7b87c3ed620e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Aug 2019 18:00:42 +0200 Subject: diagnostics: Avoid highlighting complete messages. * guix/diagnostics.scm (%highlight-argument): Don't highlight ARG if it contains white space. --- guix/diagnostics.scm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm index 380cfbb613..6c0753aef4 100644 --- a/guix/diagnostics.scm +++ b/guix/diagnostics.scm @@ -71,7 +71,12 @@ is a trivial format string." (define* (%highlight-argument arg #:optional (port (guix-warning-port))) "Highlight ARG, a format string argument, if PORT supports colors." (cond ((string? arg) - (highlight arg port)) + ;; If ARG contains white space, don't highlight it, on the grounds + ;; that it may be a complete message in its own, like those produced + ;; by 'guix lint. + (if (string-any char-set:whitespace arg) + arg + (highlight arg port))) ((symbol? arg) (highlight (symbol->string arg) port)) (else arg))) -- cgit v1.2.3 From e09c7f4ae4e1c634975874cc18fd65ae4c4af091 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Aug 2019 18:51:12 +0200 Subject: remote, ssh: Show the command exit status upon failure. * guix/remote.scm (remote-pipe-for-gexp): Show the exit status in error message. * guix/ssh.scm (remote-inferior): Likewise. --- guix/remote.scm | 12 ++++++++---- guix/ssh.scm | 14 +++++++------- 2 files changed, 15 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/remote.scm b/guix/remote.scm index d0c3d04a25..c00585de74 100644 --- a/guix/remote.scm +++ b/guix/remote.scm @@ -27,6 +27,7 @@ #:use-module (guix derivations) #:use-module (guix utils) #:use-module (ssh popen) + #:use-module (ssh channel) #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -68,10 +69,13 @@ BECOME-COMMAND is given, use that to invoke the remote Guile REPL." (let ((pipe (apply open-remote-pipe* session OPEN_READ repl-command))) (when (eof-object? (peek-char pipe)) - (raise (condition - (&message - (message (format #f (G_ "failed to run '~{~a~^ ~}'") - repl-command)))))) + (let ((status (channel-get-exit-status pipe))) + (close-port pipe) + (raise (condition + (&message + (message (format #f (G_ "remote command '~{~a~^ ~}' failed \ +with status ~a") + repl-command status))))))) pipe)) (define* (%remote-eval lowered session #:optional become-command) diff --git a/guix/ssh.scm b/guix/ssh.scm index 7bc499a2fe..b6b55bdfcb 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -106,14 +106,14 @@ given, use that to invoke the remote Guile REPL." (let* ((repl-command (append (or become-command '()) '("guix" "repl" "-t" "machine"))) (pipe (apply open-remote-pipe* session OPEN_BOTH repl-command))) - ;; XXX: 'channel-get-exit-status' would be better here, but hangs if the - ;; process does succeed. This doesn't reflect the documentation, so it's - ;; possible that it's a bug in guile-ssh. (when (eof-object? (peek-char pipe)) - (raise (condition - (&message - (message (format #f (G_ "failed to run '~{~a~^ ~}'") - repl-command)))))) + (let ((status (channel-get-exit-status pipe))) + (close-port pipe) + (raise (condition + (&message + (message (format #f (G_ "remote command '~{~a~^ ~}' failed \ +with status ~a") + repl-command status))))))) (port->inferior pipe))) (define* (inferior-remote-eval exp session #:optional become-command) -- cgit v1.2.3 From dae950ca50bca57c6d8c5fd8946de5eece614f0a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Aug 2019 18:51:49 +0200 Subject: deploy: Do not quote error messages. * guix/scripts/deploy.scm (guix-deploy): Do not quote the message. --- guix/scripts/deploy.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 6a67985c8b..329de41143 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -94,7 +94,7 @@ Perform the deployment specified by FILE.\n")) (machine-display-name machine)) (parameterize ((%graft? (assq-ref opts 'graft?))) (guard (c ((message-condition? c) - (report-error (G_ "failed to deploy ~a: '~a'~%") + (report-error (G_ "failed to deploy ~a: ~a~%") (machine-display-name machine) (condition-message c))) ((deploy-error? c) -- cgit v1.2.3 From 54ddd852209a0bd8500dc7dd5775d5dd87a9a017 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 28 Aug 2019 16:48:55 +0200 Subject: import: cran: guix-import-cran: Use (guix import utils). * guix/scripts/import/cran.scm (guix-import-cran): Use PACKAGE->DEFINITION from (guix import utils) instead of custom procedure. --- guix/scripts/import/cran.scm | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index 794fb710cd..b6592f78a9 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Eric Bavier -;;; Copyright © 2015, 2017 Ricardo Wurmus +;;; Copyright © 2015, 2017, 2019 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +22,7 @@ #:use-module (guix utils) #:use-module (guix scripts) #:use-module (guix import cran) + #:use-module (guix import utils) #:use-module (guix scripts import) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -96,11 +97,7 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) ((package-name) (if (assoc-ref opts 'recursive) ;; Recursive import - (map (match-lambda - ((and ('package ('name name) . rest) pkg) - `(define-public ,(string->symbol name) - ,pkg)) - (_ #f)) + (map package->definition (reverse (stream->list (cran-recursive-import package-name -- cgit v1.2.3 From ad553ec4b12f24a0bbd25b547bac885ddb84776a Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 28 Aug 2019 00:38:31 +0200 Subject: import: cran: Add support for git repositories. * guix/import/cran.scm (vcs-file?): New procedure. (download): Support downloading from git. (fetch-description): Add a clause for the 'git repository type. (files-match-pattern?): New procedure. (tarball-files-match-pattern?): Implement in terms of FILES-MATCH-PATTERN?. (directory-needs-fortran?, directory-needs-zlib?, directory-needs-pkg-config?): New procedures. (needs-fortran?, needs-zlib?, needs-pkg-config?): Rename these procedures... (tarball-needs-fortran?, tarball-needs-zlib?, tarball-needs-pkg-config?): ...to this, and use them. (file-hash): New procedure. (description->package): Handle the 'git repository type. * guix/import/utils.scm (package->definition): Handle package expression inside of a let. * guix/scripts/import.scm (guix-import): Handle let expressions. * doc/guix.texi (Invoking guix import): Document it. --- doc/guix.texi | 8 ++ guix/import/cran.scm | 254 ++++++++++++++++++++++++++++++++++-------------- guix/import/utils.scm | 5 +- guix/scripts/import.scm | 4 +- 4 files changed, 198 insertions(+), 73 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 5a64b89086..a87a8a3d9a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -8638,6 +8638,14 @@ R package: guix import cran --archive=bioconductor GenomicRanges @end example +Finally, you can also import R packages that have not yet been published on +CRAN or Bioconductor as long as they are in a git repository. Use +@code{--archive=git} followed by the URL of the git repository: + +@example +guix import cran --archive=git https://github.com/immunogenomics/harmony +@end example + @item texlive @cindex TeX Live @cindex CTAN diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 9c964701b1..51c7ea7b2f 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -24,6 +24,7 @@ #:use-module ((ice-9 rdelim) #:select (read-string read-line)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (ice-9 receive) @@ -32,11 +33,13 @@ #:use-module (guix http-client) #:use-module (gcrypt hash) #:use-module (guix store) + #:use-module ((guix serialization) #:select (write-file)) #:use-module (guix base32) #:use-module ((guix download) #:select (download-to-store)) #:use-module (guix import utils) #:use-module ((guix build utils) #:select (find-files)) #:use-module (guix utils) + #:use-module (guix git) #:use-module ((guix build-system r) #:select (cran-uri bioconductor-uri)) #:use-module (guix upstream) #:use-module (guix packages) @@ -166,11 +169,25 @@ bioconductor package NAME, or #F if the package is unknown." (bioconductor-packages-list type)) (cut assoc-ref <> "Version"))) +;; XXX taken from (guix scripts hash) +(define (vcs-file? file stat) + (case (stat:type stat) + ((directory) + (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS"))) + ((regular) + ;; Git sub-modules have a '.git' file that is a regular text file. + (string=? (basename file) ".git")) + (else + #f))) + ;; Little helper to download URLs only once. (define download (memoize - (lambda (url) - (with-store store (download-to-store store url))))) + (lambda* (url #:optional git) + (with-store store + (if git + (latest-repository-commit store url) + (download-to-store store url)))))) (define (fetch-description repository name) "Return an alist of the contents of the DESCRIPTION file for the R package @@ -211,7 +228,18 @@ from ~s: ~a (~s)~%" (string-append dir "/DESCRIPTION") read-string)) (lambda (meta) (if (boolean? type) meta - (cons `(bioconductor-type . ,type) meta)))))))))))) + (cons `(bioconductor-type . ,type) meta)))))))))) + ((git) + ;; Download the git repository at "NAME" + (call-with-values + (lambda () (download name #t)) + (lambda (dir commit) + (and=> (description->alist (with-input-from-file + (string-append dir "/DESCRIPTION") read-string)) + (lambda (meta) + (cons* `(git . ,name) + `(git-commit . ,commit) + meta)))))))) (define (listify meta field) "Look up FIELD in the alist META. If FIELD contains a comma-separated @@ -256,7 +284,7 @@ empty list when the FIELD cannot be found." (define cran-guix-name (cut guix-name "r-" <>)) -(define (needs-fortran? tarball) +(define (tarball-needs-fortran? tarball) "Check if the TARBALL contains Fortran source files." (define (check pattern) (parameterize ((current-error-port (%make-void-port "rw+")) @@ -266,69 +294,127 @@ empty list when the FIELD cannot be found." (check "*.f95") (check "*.f"))) +(define (directory-needs-fortran? dir) + "Check if the directory DIR contains Fortran source files." + (match (find-files dir "\\.f(90|95)?") + (() #f) + (_ #t))) + +(define (needs-fortran? thing tarball?) + "Check if the THING contains Fortran source files." + (if tarball? + (tarball-needs-fortran? thing) + (directory-needs-fortran? thing))) + +(define (files-match-pattern? directory regexp . file-patterns) + "Return #T if any of the files matching FILE-PATTERNS in the DIRECTORY match +the given REGEXP." + (let ((pattern (make-regexp regexp))) + (any (lambda (file) + (call-with-input-file file + (lambda (port) + (let loop () + (let ((line (read-line port))) + (cond + ((eof-object? line) #f) + ((regexp-exec pattern line) #t) + (else (loop)))))))) + (apply find-files directory file-patterns)))) + (define (tarball-files-match-pattern? tarball regexp . file-patterns) "Return #T if any of the files represented by FILE-PATTERNS in the TARBALL match the given REGEXP." (call-with-temporary-directory (lambda (dir) - (let ((pattern (make-regexp regexp))) - (parameterize ((current-error-port (%make-void-port "rw+"))) - (apply system* "tar" - "xf" tarball "-C" dir - `("--wildcards" ,@file-patterns))) - (any (lambda (file) - (call-with-input-file file - (lambda (port) - (let loop () - (let ((line (read-line port))) - (cond - ((eof-object? line) #f) - ((regexp-exec pattern line) #t) - (else (loop)))))))) - (find-files dir)))))) - -(define (needs-zlib? tarball) + (parameterize ((current-error-port (%make-void-port "rw+"))) + (apply system* "tar" + "xf" tarball "-C" dir + `("--wildcards" ,@file-patterns))) + (files-match-pattern? dir regexp)))) + +(define (directory-needs-zlib? dir) + "Return #T if any of the Makevars files in the src directory DIR contain a +zlib linker flag." + (files-match-pattern? dir "-lz" "(Makevars.*|configure.*)")) + +(define (tarball-needs-zlib? tarball) "Return #T if any of the Makevars files in the src directory of the TARBALL contain a zlib linker flag." (tarball-files-match-pattern? tarball "-lz" "*/src/Makevars*" "*/src/configure*" "*/configure*")) -(define (needs-pkg-config? tarball) +(define (needs-zlib? thing tarball?) + "Check if the THING contains files indicating a dependency on zlib." + (if tarball? + (tarball-needs-zlib? thing) + (directory-needs-zlib? thing))) + +(define (directory-needs-pkg-config? dir) + "Return #T if any of the Makevars files in the src directory DIR reference +the pkg-config tool." + (files-match-pattern? dir "pkg-config" + "(Makevars.*|configure.*)")) + +(define (tarball-needs-pkg-config? tarball) "Return #T if any of the Makevars files in the src directory of the TARBALL reference the pkg-config tool." (tarball-files-match-pattern? tarball "pkg-config" "*/src/Makevars*" "*/src/configure*" "*/configure*")) +(define (needs-pkg-config? thing tarball?) + "Check if the THING contains files indicating a dependency on pkg-config." + (if tarball? + (tarball-needs-pkg-config? thing) + (directory-needs-pkg-config? thing))) + +;; XXX adapted from (guix scripts hash) +(define (file-hash file select? recursive?) + ;; Compute the hash of FILE. + (if recursive? + (let-values (((port get-hash) (open-sha256-port))) + (write-file file port #:select? select?) + (force-output port) + (get-hash)) + (call-with-input-file file port-sha256))) + (define (description->package repository meta) "Return the `package' s-expression for an R package published on REPOSITORY from the alist META, which was derived from the R package's DESCRIPTION file." (let* ((base-url (case repository ((cran) %cran-url) - ((bioconductor) %bioconductor-url))) + ((bioconductor) %bioconductor-url) + ((git) #f))) (uri-helper (case repository ((cran) cran-uri) - ((bioconductor) bioconductor-uri))) + ((bioconductor) bioconductor-uri) + ((git) #f))) (name (assoc-ref meta "Package")) (synopsis (assoc-ref meta "Title")) (version (assoc-ref meta "Version")) (license (string->license (assoc-ref meta "License"))) ;; Some packages have multiple home pages. Some have none. - (home-page (match (listify meta "URL") - ((url rest ...) url) - (_ (string-append base-url name)))) - (source-url (match (apply uri-helper name version - (case repository - ((bioconductor) - (list (assoc-ref meta 'bioconductor-type))) - (else '()))) - ((url rest ...) url) - ((? string? url) url) - (_ #f))) - (tarball (download source-url)) + (home-page (case repository + ((git) (assoc-ref meta 'git)) + (else (match (listify meta "URL") + ((url rest ...) url) + (_ (string-append base-url name)))))) + (source-url (case repository + ((git) (assoc-ref meta 'git)) + (else + (match (apply uri-helper name version + (case repository + ((bioconductor) + (list (assoc-ref meta 'bioconductor-type))) + (else '()))) + ((url rest ...) url) + ((? string? url) url) + (_ #f))))) + (git? (assoc-ref meta 'git)) + (source (download source-url git?)) (sysdepends (append - (if (needs-zlib? tarball) '("zlib") '()) + (if (needs-zlib? source (not git?)) '("zlib") '()) (filter (lambda (name) (not (member name invalid-packages))) (map string-downcase (listify meta "SystemRequirements"))))) @@ -339,41 +425,67 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (listify meta "Imports") (listify meta "LinkingTo") (delete "R" - (listify meta "Depends")))))) + (listify meta "Depends"))))) + (package + `(package + (name ,(cran-guix-name name)) + (version ,(case repository + ((git) + `(git-version ,version revision commit)) + (else version))) + (source (origin + (method ,(if git? + 'git-fetch + 'url-fetch)) + (uri ,(case repository + ((git) + `(git-reference + (url ,(assoc-ref meta 'git)) + (commit commit))) + (else + `(,(procedure-name uri-helper) ,name version + ,@(or (and=> (assoc-ref meta 'bioconductor-type) + (lambda (type) + (list (list 'quote type)))) + '()))))) + ,@(if git? + '((file-name (git-file-name name version))) + '()) + (sha256 + (base32 + ,(bytevector->nix-base32-string + (case repository + ((git) + (file-hash source (negate vcs-file?) #t)) + (else (file-sha256 source)))))))) + ,@(if (not (and git? + (equal? (string-append "r-" name) + (cran-guix-name name)))) + `((properties ,`(,'quasiquote ((,'upstream-name . ,name))))) + '()) + (build-system r-build-system) + ,@(maybe-inputs sysdepends) + ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs) + ,@(maybe-inputs + `(,@(if (needs-fortran? source (not git?)) + '("gfortran") '()) + ,@(if (needs-pkg-config? source (not git?)) + '("pkg-config") '())) + 'native-inputs) + (home-page ,(if (string-null? home-page) + (string-append base-url name) + home-page)) + (synopsis ,synopsis) + (description ,(beautify-description (or (assoc-ref meta "Description") + ""))) + (license ,license)))) (values - `(package - (name ,(cran-guix-name name)) - (version ,version) - (source (origin - (method url-fetch) - (uri (,(procedure-name uri-helper) ,name version - ,@(or (and=> (assoc-ref meta 'bioconductor-type) - (lambda (type) - (list (list 'quote type)))) - '()))) - (sha256 - (base32 - ,(bytevector->nix-base32-string (file-sha256 tarball)))))) - ,@(if (not (equal? (string-append "r-" name) - (cran-guix-name name))) - `((properties ,`(,'quasiquote ((,'upstream-name . ,name))))) - '()) - (build-system r-build-system) - ,@(maybe-inputs sysdepends) - ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs) - ,@(maybe-inputs - `(,@(if (needs-fortran? tarball) - '("gfortran") '()) - ,@(if (needs-pkg-config? tarball) - '("pkg-config") '())) - 'native-inputs) - (home-page ,(if (string-null? home-page) - (string-append base-url name) - home-page)) - (synopsis ,synopsis) - (description ,(beautify-description (or (assoc-ref meta "Description") - ""))) - (license ,license)) + (case repository + ((git) + `(let ((commit ,(assoc-ref meta 'git-commit)) + (revision "1")) + ,package)) + (else package)) propagate))) (define cran->guix-package diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 2a3b7341fb..252875eeab 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2012, 2013, 2018, 2019 Ludovic Courtès ;;; Copyright © 2016 Jelle Licht ;;; Copyright © 2016 David Craven -;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2017, 2019 Ricardo Wurmus ;;; Copyright © 2018 Oleg Pykhalov ;;; Copyright © 2019 Robert Vollmert ;;; @@ -251,6 +251,9 @@ package definition." (define (package->definition guix-package) (match guix-package (('package ('name (? string? name)) _ ...) + `(define-public ,(string->symbol name) + ,guix-package)) + (('let anything ('package ('name (? string? name)) _ ...)) `(define-public ,(string->symbol name) ,guix-package)))) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 0b326e1049..c6cc93fad8 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès ;;; Copyright © 2014 David Thompson ;;; Copyright © 2018 Kyle Meyer +;;; Copyright © 2019 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -113,7 +114,8 @@ Run IMPORTER with ARGS.\n")) (pretty-print expr (newline-rewriting-port (current-output-port)))))) (match (apply (resolve-importer importer) args) - ((and expr ('package _ ...)) + ((and expr (or ('package _ ...) + ('let _ ...))) (print expr)) ((? list? expressions) (for-each (lambda (expr) -- cgit v1.2.3