diff options
| author | Efraim Flashner <efraim@flashner.co.il> | 2021-12-19 15:15:11 +0200 |
|---|---|---|
| committer | Efraim Flashner <efraim@flashner.co.il> | 2021-12-19 15:15:11 +0200 |
| commit | 6ccf8ea81f95963c0b7f945648106576008ee105 (patch) | |
| tree | f39f596e6c3e98ff1e9f1de0ad41c977e9dd37c1 /guix | |
| parent | fcaed5b81e893f34d77527fbef389ca628ca882d (diff) | |
| parent | 9f916d14765b00309c742fcbff0cfabdd10dcf05 (diff) | |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
90 files changed, 4353 insertions, 1190 deletions
diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index f043e6a7a2..a0f4634db0 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -151,7 +151,8 @@ set up using CL source package conventions." name)) (define (has-from-build-system? pkg) - (eq? from-build-system (package-build-system pkg))) + (and (package? pkg) + (eq? from-build-system (package-build-system pkg)))) (define (find-input-package pkg) (let* ((name (package-name pkg)) diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm index d500eccfde..2056c04153 100644 --- a/guix/build-system/cmake.scm +++ b/guix/build-system/cmake.scm @@ -158,6 +158,7 @@ provides a 'CMakeLists.txt' file as its build system." (gexp->derivation name build #:system system #:target #f + #:graft? #f #:substitutable? substitutable? #:guile-for-build guile))) @@ -248,6 +249,7 @@ build system." (gexp->derivation name builder #:system system #:target target + #:graft? #f #:substitutable? substitutable? #:guile-for-build guile))) diff --git a/guix/build-system/glib-or-gtk.scm b/guix/build-system/glib-or-gtk.scm index ec491ff0bd..aa9703829b 100644 --- a/guix/build-system/glib-or-gtk.scm +++ b/guix/build-system/glib-or-gtk.scm @@ -26,6 +26,8 @@ #:use-module (guix monads) #:use-module (guix derivations) #:use-module (guix search-paths) + #:use-module ((guix build glib-or-gtk-build-system) + #:select (%gdk-pixbuf-loaders-cache-file)) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix packages) @@ -33,7 +35,8 @@ #:export (%glib-or-gtk-build-system-modules glib-or-gtk-build glib-or-gtk-cross-build - glib-or-gtk-build-system)) + glib-or-gtk-build-system) + #:re-export (%gdk-pixbuf-loaders-cache-file)) ;for convenience ;; Commentary: ;; @@ -186,6 +189,7 @@ (gexp->derivation name build #:system system #:target #f + #:graft? #f #:allowed-references allowed-references #:disallowed-references disallowed-references #:guile-for-build guile))) @@ -279,6 +283,7 @@ (gexp->derivation name builder #:system system #:target target + #:graft? #f #:modules imported-modules #:allowed-references allowed-references #:disallowed-references disallowed-references diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index ea91be5bcd..651415098e 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -423,9 +423,12 @@ are allowed to refer to." (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) system #:graft? #f))) + ;; Note: Always pass #:graft? #f. Without it, ALLOWED-REFERENCES & + ;; co. would be interpreted as referring to grafted packages. (gexp->derivation name builder #:system system #:target #f + #:graft? #f #:substitutable? substitutable? #:allowed-references allowed-references #:disallowed-references disallowed-references @@ -560,6 +563,7 @@ platform." (gexp->derivation name builder #:system system #:target target + #:graft? #f #:modules imported-modules #:substitutable? substitutable? #:allowed-references allowed-references diff --git a/guix/build-system/go.scm b/guix/build-system/go.scm index b62f2a897b..18824c79d9 100644 --- a/guix/build-system/go.scm +++ b/guix/build-system/go.scm @@ -166,8 +166,8 @@ commit hash and its date rather than a proper release tag." (tests? #t) (allow-go-reference? #f) (system (%current-system)) - (goarch (first (go-target (%current-system)))) - (goos (last (go-target (%current-system)))) + (goarch #f) + (goos #f) (guile #f) (imported-modules %go-build-system-modules) (modules '((guix build go-build-system) @@ -201,11 +201,11 @@ commit hash and its date rather than a proper release tag." #:system system #:guile-for-build guile))) -(define* (go-cross-build store name +(define* (go-cross-build name #:key - target native-drvs target-drvs - (phases '(@ (guix build go-build-system) - %standard-phases)) + source target + build-inputs target-inputs host-inputs + (phases '%standard-phases) (outputs '("out")) (search-paths '()) (native-search-paths '()) @@ -213,7 +213,7 @@ commit hash and its date rather than a proper release tag." (import-path "") (unpack-path "") (build-flags ''()) - (tests? #f) ; nothing can be done + (tests? #f) ; nothing can be done (allow-go-reference? #f) (system (%current-system)) (goarch (first (go-target target))) @@ -225,73 +225,53 @@ commit hash and its date rather than a proper release tag." (guix build utils)))) "Cross-build NAME using GO, where TARGET is a GNU triplet and with INPUTS." (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)) + #~(begin + (use-modules #$@(sexp->gexp modules)) - (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)) + (define %build-host-inputs + #+(input-tuples->gexp build-inputs)) - (go-build #:name ,name - #:source ,(match (assoc-ref native-drvs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) - source) - (source - source)) - #:system ,system - #:phases ,phases - #:outputs %outputs - #:target ,target - #:goarch ,goarch - #:goos ,goos - #: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) - #:install-source? ,install-source? - #:import-path ,import-path - #:unpack-path ,unpack-path - #:build-flags ,build-flags - #:tests? ,tests? - #:allow-go-reference? ,allow-go-reference? - #:inputs %build-inputs)))) + (define %build-target-inputs + (append #$(input-tuples->gexp host-inputs) + #+(input-tuples->gexp target-inputs))) + + (define %build-inputs + (append %build-host-inputs %build-target-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))))) + (define %outputs + #$(outputs->gexp outputs)) - (build-expression->derivation store name builder - #:system system - #:inputs (append native-drvs target-drvs) - #:outputs outputs - #:modules imported-modules - #:guile-for-build guile-for-build)) + (go-build #:name #$name + #:source #+source + #:system #$system + #:phases #$phases + #:outputs %outputs + #:target #$target + #:goarch #$goarch + #:goos #$goos + #: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) + #:install-source? #$install-source? + #:import-path #$import-path + #:unpack-path #$unpack-path + #:build-flags #$build-flags + #:tests? #$tests? + #:allow-go-reference? #$allow-go-reference? + #:inputs %build-inputs))) + + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target target + #:graft? #f + #:substitutable? substitutable? + #:guile-for-build guile))) (define go-build-system (build-system diff --git a/guix/build-system/haskell.scm b/guix/build-system/haskell.scm index 3770304745..dc83512d30 100644 --- a/guix/build-system/haskell.scm +++ b/guix/build-system/haskell.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com> ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,7 +33,9 @@ #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) - #:export (%haskell-build-system-modules + #:export (hackage-uri + + %haskell-build-system-modules haskell-build haskell-build-system)) @@ -43,6 +46,12 @@ ;; ;; Code: +(define (hackage-uri name version) + "Return a URI string for the Haskell package hosted on Hackage corresponding +to NAME and VERSION." + (string-append "https://hackage.haskell.org/package/" name "/" + name "-" version ".tar.gz")) + (define %haskell-build-system-modules ;; Build-side modules imported by default. `((guix build haskell-build-system) diff --git a/guix/build-system/julia.scm b/guix/build-system/julia.scm index 5b824d7f0a..6261f8a55a 100644 --- a/guix/build-system/julia.scm +++ b/guix/build-system/julia.scm @@ -1,6 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Nicolò Balzarotti <nicolo@nixo.xyz> ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021 Jean-Baptiste Volatier <jbv@pm.me> +;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -78,12 +80,14 @@ (define* (julia-build name inputs #:key source (tests? #t) + (parallel-tests? #t) (phases '%standard-phases) (outputs '("out")) (search-paths '()) (system (%current-system)) (guile #f) (julia-package-name #f) + (julia-package-uuid #f) (imported-modules %julia-build-system-modules) (modules '((guix build julia-build-system) (guix build utils)))) @@ -96,13 +100,15 @@ #:source #+source #:system #$system #:tests? #$tests? + #:parallel-tests? #$parallel-tests? #:phases #$phases #:outputs #$(outputs->gexp outputs) #:search-paths '#$(sexp->gexp (map search-path-specification->sexp search-paths)) #:inputs #$(input-tuples->gexp inputs) - #:julia-package-name #$julia-package-name)))) + #:julia-package-name #$julia-package-name + #:julia-package-uuid #$julia-package-uuid)))) (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) system #:graft? #f))) diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm index 7bafee5a7a..57fce8e96e 100644 --- a/guix/build-system/linux-module.scm +++ b/guix/build-system/linux-module.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org> ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -158,6 +159,7 @@ (phases '%standard-phases) (outputs '("out")) (make-flags ''()) + (parallel-build? #t) (system (%current-system)) (source-directory ".") (guile #f) @@ -171,20 +173,22 @@ (with-imported-modules imported-modules #~(begin (use-modules #$@(sexp->gexp modules)) - (linux-module-build #:name #$name - #:source #+source - #:source-directory #$source-directory - #:search-paths '#$(sexp->gexp - (map search-path-specification->sexp - search-paths)) - #:phases #$phases - #:system #$system - #:target #$target - #:arch #$(system->arch (or target system)) - #:tests? #$tests? - #:outputs #$(outputs->gexp outputs) - #:make-flags #$make-flags - #:inputs #$(input-tuples->gexp inputs))))) + #$(with-build-variables inputs outputs + #~(linux-module-build #:name #$name + #:source #+source + #:source-directory #$source-directory + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:phases #$phases + #:system #$system + #:target #$target + #:arch #$(system->arch (or target system)) + #:tests? #$tests? + #:outputs #$(outputs->gexp outputs) + #:make-flags #$make-flags + #:parallel-build? #$parallel-build? + #:inputs #$(input-tuples->gexp inputs)))))) (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) system #:graft? #f))) @@ -201,6 +205,7 @@ (guile #f) (outputs '("out")) (make-flags ''()) + (parallel-build? #t) (search-paths '()) (native-search-paths '()) (tests? #f) diff --git a/guix/build-system/meson.scm b/guix/build-system/meson.scm index dcad3f322d..ba7441a3eb 100644 --- a/guix/build-system/meson.scm +++ b/guix/build-system/meson.scm @@ -169,7 +169,7 @@ TRIPLET." (search-paths '()) (build-type "debugoptimized") (tests? #t) - (test-target "test") + (test-options ''()) (glib-or-gtk? #f) (parallel-build? #t) (parallel-tests? #f) @@ -218,7 +218,7 @@ has a 'meson.build' file." configure-flags) #:build-type #$build-type #:tests? #$tests? - #:test-target #$test-target + #:test-options #$(sexp->gexp test-options) #:parallel-build? #$parallel-build? #:parallel-tests? #$parallel-tests? #:validate-runpath? #$validate-runpath? @@ -233,6 +233,7 @@ has a 'meson.build' file." (gexp->derivation name builder #:system system #:target #f + #:graft? #f #:substitutable? substitutable? #:allowed-references allowed-references #:disallowed-references disallowed-references @@ -250,7 +251,7 @@ has a 'meson.build' file." (build-type "debugoptimized") (tests? #f) - (test-target "test") + (test-options ''()) (glib-or-gtk? #f) (parallel-build? #t) (parallel-tests? #f) @@ -280,7 +281,7 @@ SOURCE has a 'meson.build' file." (if (null? target-inputs) (input-tuples->gexp host-inputs) #~(append #$(input-tuples->gexp host-inputs) - #+(input-tuples->gexp target-inputs)))) + #+(input-tuples->gexp target-inputs)))) (define builder (with-imported-modules imported-modules #~(begin @@ -305,7 +306,7 @@ SOURCE has a 'meson.build' file." #:native-inputs #+(input-tuples->gexp build-inputs) #:search-paths '#$(sexp->gexp (map search-path-specification->sexp - search-paths)) + search-paths)) #:native-search-paths '#$(sexp->gexp (map search-path-specification->sexp native-search-paths)) @@ -317,7 +318,7 @@ SOURCE has a 'meson.build' file." configure-flags)) #:build-type #$build-type #:tests? #$tests? - #:test-target #$test-target + #:test-options #$(sexp->gexp test-options) #:parallel-build? #$parallel-build? #:parallel-tests? #$parallel-tests? #:validate-runpath? #$validate-runpath? @@ -332,6 +333,7 @@ SOURCE has a 'meson.build' file." (gexp->derivation name builder #:system system #:target target + #:graft? #f #:substitutable? substitutable? #:allowed-references allowed-references #:disallowed-references disallowed-references diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index be6a600c28..2c82390ba6 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -61,7 +61,7 @@ release corresponding to NAME and VERSION." "/src/contrib/" name "_" version ".tar.gz") ;; TODO: use %bioconductor-version from (guix import cran) - (string-append "https://bioconductor.org/packages/3.13" + (string-append "https://bioconductor.org/packages/3.14" type-url-part "/src/contrib/" name "_" version ".tar.gz")))) diff --git a/guix/build-system/renpy.scm b/guix/build-system/renpy.scm index 0ee73ec969..f1070951ee 100644 --- a/guix/build-system/renpy.scm +++ b/guix/build-system/renpy.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Leo Prikler <leo.prikler@student.tugraz.at> ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021 Liliana Marie Prikler <liliana.prikler@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; diff --git a/guix/build-system/trivial.scm b/guix/build-system/trivial.scm index cd35c846ce..378ae481b9 100644 --- a/guix/build-system/trivial.scm +++ b/guix/build-system/trivial.scm @@ -61,6 +61,7 @@ ignored." (gexp->derivation name (with-build-variables inputs outputs builder) #:system system #:target #f + #:graft? #f #:modules modules #:allowed-references allowed-references #:guile-for-build guile))) @@ -85,6 +86,7 @@ ignored." builder) #:system system #:target target + #:graft? #f #:modules modules #:allowed-references allowed-references #:guile-for-build guile))) diff --git a/guix/build/download.scm b/guix/build/download.scm index c8ddadfdd4..7c310e94f1 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -36,7 +36,7 @@ #:use-module (srfi srfi-26) #:autoload (ice-9 ftw) (scandir) #:autoload (guix base16) (bytevector->base16-string) - #:autoload (guix swh) (swh-download-directory) + #:autoload (guix swh) (swh-download-directory %verify-swh-certificate?) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (open-socket-for-uri @@ -646,6 +646,8 @@ and write the output to FILE." #:verify-certificate? verify-certificate? #:timeout timeout))) + (format #t "Retrieving Disarchive spec from ~a ...~%" + (uri->string uri)) (let ((specification (read port))) (close-port port) specification)))) @@ -674,10 +676,23 @@ and write the output to FILE." (match (fetch-specification uris) (#f (format #t "could not find its Disarchive specification~%") #f) - (spec (parameterize ((%disarchive-log-port (current-output-port))) + (spec (parameterize ((%disarchive-log-port (current-output-port)) + (%verify-swh-certificate? verify-certificate?)) (false-if-exception* (disarchive-assemble spec file #:resolver resolve)))))))) +(define (internet-archive-uri uri) + "Return a URI corresponding to an Internet Archive backup of URI, or #f if +URI does not denote a Web URI." + (and (memq (uri-scheme uri) '(http https)) + (let* ((now (time-utc->date (current-time time-utc))) + (date (date->string now "~Y~m~d~H~M~S"))) + ;; Note: the date in the URL can be anything and web.archive.org + ;; automatically redirects to the closest date. + (build-uri 'https #:host "web.archive.org" + #:path (string-append "/web/" date "/" + (uri->string uri)))))) + (define* (url-fetch url file #:key (timeout 10) (verify-certificate? #t) @@ -769,7 +784,12 @@ otherwise simply ignore them." (setvbuf (current-error-port) 'line) - (let try ((uri (append uri content-addressed-uris))) + (let try ((uri (append uri content-addressed-uris + (match uri + ((first . _) + (or (and=> (internet-archive-uri first) list) + '())) + (() '()))))) (match uri ((uri tail ...) (or (fetch uri file) diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index ba2c1b4aad..ab77e57f33 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -53,8 +53,7 @@ ;; These are the default inclusion/exclusion regexps for the install phase. (define %default-include '("^[^/]*\\.el$" "^[^/]*\\.info$" "^doc/.*\\.info$")) -(define %default-exclude '("^\\.dir-locals\\.el$" "-pkg\\.el$" - "^[^/]*tests?\\.el$")) +(define %default-exclude '("^\\.dir-locals\\.el$" "^[^/]*tests?\\.el$")) (define gnu:unpack (assoc-ref gnu:%standard-phases 'unpack)) @@ -111,7 +110,7 @@ environment variable\n" source-directory)) (define* (build #:key outputs inputs #:allow-other-keys) "Compile .el files." - (let* ((emacs (string-append (assoc-ref inputs "emacs") "/bin/emacs")) + (let* ((emacs (search-input-file inputs "/bin/emacs")) (out (assoc-ref outputs "out"))) (setenv "SHELL" "sh") (parameterize ((%emacs emacs)) @@ -220,7 +219,7 @@ parallel. PARALLEL-TESTS? is ignored when using a non-make TEST-COMMAND." (define* (make-autoloads #:key outputs inputs #:allow-other-keys) "Generate the autoloads file." - (let* ((emacs (string-append (assoc-ref inputs "emacs") "/bin/emacs")) + (let* ((emacs (search-input-file inputs "/bin/emacs")) (out (assoc-ref outputs "out")) (elpa-name-ver (store-directory->elpa-name-version out)) (elpa-name (package-name->name+version elpa-name-ver)) diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm index 5f7ba71244..64ef40e25a 100644 --- a/guix/build/emacs-utils.scm +++ b/guix/build/emacs-utils.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2014, 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014 Alex Kost <alezost@gmail.com> ;;; Copyright © 2018, 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> -;;; Copyright © 2019 Leo Prikler <leo.prikler@student.tugraz.at> +;;; Copyright © 2019 Liliana Marie Prikler <liliana.prikler@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; diff --git a/guix/build/glib-or-gtk-build-system.scm b/guix/build/glib-or-gtk-build-system.scm index 8d3c3684d3..475a94ae4f 100644 --- a/guix/build/glib-or-gtk-build-system.scm +++ b/guix/build/glib-or-gtk-build-system.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,6 +29,8 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%standard-phases + %gdk-pixbuf-loaders-cache-file + generate-gdk-pixbuf-loaders-cache glib-or-gtk-build)) ;; Commentary: @@ -51,12 +54,24 @@ "Check for the existence of \"libdir/gtk-v.0\" in INPUTS. Return a list with all found directories." (let* ((version - (if (string-match "gtk\\+-3" - (or (assoc-ref inputs "gtk+") - (assoc-ref inputs "source") - "gtk+-3")) ; we default to version 3 - "3.0" - "2.0")) + (cond + ((string-match "gtk-4" + (or (assoc-ref inputs "gtk") + (assoc-ref inputs "source") + "")) + "4.0") + ((string-match "gtk\\+-3" + (or (assoc-ref inputs "gtk+") + (assoc-ref inputs "source") + "")) + "3.0") + ((string-match "gtk\\+-2" + (or (assoc-ref inputs "gtk+") + (assoc-ref inputs "source") + "")) + "2.0") + (else + "4.0"))) ; We default to version 4.0. (gtk-module (lambda (input prev) (let* ((in (match input @@ -144,68 +159,34 @@ add a dependency of that output on GLib and GTK+." (define (sh) (force %sh)) (define handle-output (match-lambda - ((output . directory) - (unless (member output glib-or-gtk-wrap-excluded-outputs) - (let* ((bindir (string-append directory "/bin")) - (libexecdir (string-append directory "/libexec")) - (bin-list (filter (negate wrapped-program?) - (append (find-files bindir ".*") - (find-files libexecdir ".*")))) - (datadirs (data-directories - (alist-cons output directory inputs))) - (gtk-mod-dirs (gtk-module-directories - (alist-cons output directory inputs))) - (gio-mod-dirs (gio-module-directories - (alist-cons output directory inputs))) - (data-env-var - (if (not (null? datadirs)) - `("XDG_DATA_DIRS" ":" prefix ,datadirs) - #f)) - (gtk-mod-env-var - (if (not (null? gtk-mod-dirs)) - `("GTK_PATH" ":" prefix ,gtk-mod-dirs) - #f)) - (gio-mod-env-var - (if (not (null? gio-mod-dirs)) - `("GIO_EXTRA_MODULES" ":" prefix ,gio-mod-dirs) - #f))) - (cond - ((and data-env-var gtk-mod-env-var gio-mod-env-var) - (for-each (cut wrap-program <> #:sh (sh) - data-env-var - gtk-mod-env-var - gio-mod-env-var) - bin-list)) - ((and data-env-var gtk-mod-env-var (not gio-mod-env-var)) - (for-each (cut wrap-program <> #:sh (sh) - data-env-var - gtk-mod-env-var) - bin-list)) - ((and data-env-var (not gtk-mod-env-var) gio-mod-env-var) - (for-each (cut wrap-program <> #:sh (sh) - data-env-var - gio-mod-env-var) - bin-list)) - ((and (not data-env-var) gtk-mod-env-var gio-mod-env-var) - (for-each (cut wrap-program <> #:sh (sh) - gio-mod-env-var - gtk-mod-env-var) - bin-list)) - ((and data-env-var (not gtk-mod-env-var) (not gio-mod-env-var)) - (for-each (cut wrap-program <> #:sh (sh) - data-env-var) - bin-list)) - ((and (not data-env-var) gtk-mod-env-var (not gio-mod-env-var)) - (for-each (cut wrap-program <> #:sh (sh) - gtk-mod-env-var) - bin-list)) - ((and (not data-env-var) (not gtk-mod-env-var) gio-mod-env-var) - (for-each (cut wrap-program <> #:sh (sh) - gio-mod-env-var) - bin-list)))))))) - - (for-each handle-output outputs) - #t) + ((output . directory) + (unless (member output glib-or-gtk-wrap-excluded-outputs) + (let* ((bindir (string-append directory "/bin")) + (libexecdir (string-append directory "/libexec")) + (bin-list (filter (negate wrapped-program?) + (append (find-files bindir ".*") + (find-files libexecdir ".*")))) + (datadirs (data-directories + (alist-cons output directory inputs))) + (gtk-mod-dirs (gtk-module-directories + (alist-cons output directory inputs))) + (gio-mod-dirs (gio-module-directories + (alist-cons output directory inputs))) + (env-vars `(,@(if (not (null? datadirs)) + (list `("XDG_DATA_DIRS" ":" prefix ,datadirs)) + '()) + ,@(if (not (null? gtk-mod-dirs)) + (list `("GTK_PATH" ":" prefix ,gtk-mod-dirs)) + '()) + ,@(if (not (null? gio-mod-dirs)) + (list `("GIO_EXTRA_MODULES" ":" + prefix ,gio-mod-dirs)) + '())))) + (for-each (lambda (program) + (apply wrap-program program #:sh (sh) env-vars)) + bin-list)))))) + + (for-each handle-output outputs)) (define* (compile-glib-schemas #:key outputs #:allow-other-keys) "Implement phase \"glib-or-gtk-compile-schemas\": compile \"glib\" schemas @@ -218,11 +199,58 @@ if needed." (not (file-exists? (string-append schemasdir "/gschemas.compiled")))) (invoke "glib-compile-schemas" schemasdir))))) - outputs) - #t) + outputs)) + +;; This file is to be generated by the +;; `generate-gdk-pixbuf-loaders-cache' build phase defined below. +(define %gdk-pixbuf-loaders-cache-file + "lib/gdk-pixbuf-2.0/2.10.0/loaders.cache") + +(define (generate-gdk-pixbuf-loaders-cache directories outputs) + "Generate the loaders.cache file used by gdk-pixbuf to locate the available +loaders among DIRECTORIES, and set the GDK_PIXBUF_MODULE_FILE environment +variable. The cache file is installed under OUTPUTS. Return the first cache +file name if one was created else #f." + (let* ((loaders (append-map + (cut find-files <> "^libpixbufloader-.*\\.so$") + directories)) + (outputs* (map (cut string-append <> "/" + %gdk-pixbuf-loaders-cache-file) + outputs)) + (loaders.cache (first outputs*)) + (loaders.cache-copies (cdr outputs*))) + (if (not (null? loaders)) + (begin + (mkdir-p (dirname loaders.cache)) + (setenv "GDK_PIXBUF_MODULE_FILE" loaders.cache) + (apply invoke "gdk-pixbuf-query-loaders" "--update-cache" loaders) + (for-each (lambda (f) + (mkdir-p (dirname f)) + (copy-file loaders.cache f)) + loaders.cache-copies) + loaders.cache) + #f))) + +(define* (generate-gdk-pixbuf-loaders-cache-file #:key inputs outputs + #:allow-other-keys) + "Build phase that Wraps the GENERATE-GDK-PIXBUF-LOADERS-CACHE procedure." + ;; Conditionally compute the cache file if the gdk-pixbuf command is + ;; available on PATH (it comes with gdk-pixbuf). + (when (which "gdk-pixbuf-query-loaders") + (let ((loaders.cache (generate-gdk-pixbuf-loaders-cache + (map cdr inputs) + (filter-map identity + (list + (assoc-ref outputs "out") + (assoc-ref outputs "bin") + (assoc-ref outputs "lib")))))) + (when loaders.cache + (format #t "GDK_PIXBUF_MODULE_FILE set to `~a'~%" loaders.cache))))) (define %standard-phases (modify-phases gnu:%standard-phases + (add-after 'unpack 'generate-gdk-pixbuf-loaders-cache-file + generate-gdk-pixbuf-loaders-cache-file) (add-after 'install 'glib-or-gtk-compile-schemas compile-glib-schemas) (add-after 'install 'glib-or-gtk-wrap wrap-all-programs))) diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm index 645d2fe680..4768ee8562 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -152,8 +152,10 @@ dependencies, so it should be self-contained." ;; Make sure we're building for the correct architecture and OS targets ;; that Guix targets. - (setenv "GOARCH" goarch) - (setenv "GOOS" goos) + (setenv "GOARCH" (or goarch + (getenv "GOHOSTARCH"))) + (setenv "GOOS" (or goos + (getenv "GOHOSTOS"))) (match goarch ("arm" (setenv "GOARM" "7")) diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index 28253ce2f0..ef6cb316ee 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2015 Paul van der Walt <paul@denknerd.org> ;;; Copyright © 2018, 2020 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com> +;;; Copyright © 2021 John Kehayias <john.kehayias@protonmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -63,13 +64,14 @@ ((file-exists? "Setup.lhs") "Setup.lhs") (else - #f)))) + #f))) + (pkgdb (string-append "-package-db=" %tmp-db-dir))) (if setup-file (begin (format #t "running \"runhaskell Setup.hs\" with command ~s \ and parameters ~s~%" command params) - (apply invoke "runhaskell" setup-file command params)) + (apply invoke "runhaskell" pkgdb setup-file command params)) (error "no Setup.hs nor Setup.lhs found")))) (define* (configure #:key outputs inputs tests? (configure-flags '()) @@ -141,17 +143,6 @@ and parameters ~s~%" (find-files lib "\\.a$")))) #t) -(define (grep rx port) - "Given a regular-expression RX including a group, read from PORT until the -first match and return the content of the group." - (let ((line (read-line port))) - (if (eof-object? line) - #f - (let ((rx-result (regexp-exec rx line))) - (if rx-result - (match:substring rx-result 1) - (grep rx port)))))) - (define* (setup-compiler #:key system inputs outputs #:allow-other-keys) "Setup the compiler environment." (let* ((haskell (assoc-ref inputs "haskell")) @@ -173,15 +164,8 @@ first match and return the content of the group." "Generate the GHC package database." (let* ((haskell (assoc-ref inputs "haskell")) (name-version (strip-store-file-name haskell)) - (input-dirs (match inputs - (((_ . dir) ...) - dir) - (_ '()))) ;; Silence 'find-files' (see 'evaluate-search-paths') - (conf-dirs (with-null-error-port - (search-path-as-list - `(,(string-append "lib/" name-version)) - input-dirs #:pattern ".*\\.conf.d$"))) + (conf-dirs (search-path-as-string->list (getenv "GHC_PACKAGE_PATH"))) (conf-files (append-map (cut find-files <> "\\.conf$") conf-dirs))) (mkdir-p %tmp-db-dir) (for-each (lambda (file) @@ -233,6 +217,8 @@ given Haskell package." (if (not (vhash-assoc id seen)) (let ((dep-conf (string-append src "/" id ".conf")) (dep-conf* (string-append dest "/" id ".conf"))) + (when (not (file-exists? dep-conf)) + (error (format #f "File ~a does not exist. This usually means the dependency ~a is missing. Was checking conf-file ~a." dep-conf id conf-file))) (copy-file dep-conf dep-conf*) ;XXX: maybe symlink instead? (loop (vhash-cons id #t seen) (append lst (conf-depends dep-conf)))) @@ -241,12 +227,13 @@ given Haskell package." (let* ((out (assoc-ref outputs "out")) (doc (assoc-ref outputs "doc")) (haskell (assoc-ref inputs "haskell")) - (name-verion (strip-store-file-name haskell)) + (name-version (strip-store-file-name haskell)) + (version (last (string-split name-version #\-))) (lib (string-append (or (assoc-ref outputs "lib") out) "/lib")) (config-dir (string-append lib - "/" name-verion + "/ghc-" version "/" name ".conf.d")) - (id-rx (make-regexp "^id: *(.*)$")) + (id-rx (make-regexp "^id:[ \n\t]+([^ \t\n]+)$" regexp/newline)) (config-file (string-append out "/" name ".conf")) (params (list (string-append "--gen-pkg-config=" config-file)))) @@ -254,8 +241,15 @@ given Haskell package." ;; The conf file is created only when there is a library to register. (when (file-exists? config-file) (mkdir-p config-dir) - (let ((config-file-name+id - (call-with-ascii-input-file config-file (cut grep id-rx <>)))) + (let* ((contents (call-with-input-file config-file read-string)) + (config-file-name+id (match:substring (first (list-matches id-rx contents)) 1))) + + (when (or + (and + (string? config-file-name+id) + (string-null? config-file-name+id)) + (not config-file-name+id)) + (error (format #f "The package id for ~a is empty. This is a bug." config-file))) ;; Remove reference to "doc" output from "lib" (or "out") by rewriting the ;; "haddock-interfaces" field and removing the optional "haddock-html" diff --git a/guix/build/julia-build-system.scm b/guix/build/julia-build-system.scm index d74acf2a05..b4e0044567 100644 --- a/guix/build/julia-build-system.scm +++ b/guix/build/julia-build-system.scm @@ -1,5 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019, 2020 Nicolò Balzarotti <nicolo@nixo.xyz> +;;; Copyright © 2021 Jean-Baptiste Volatier <jbv@pm.me> +;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,9 +22,11 @@ (define-module (guix build julia-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) #:use-module (guix build utils) + #:use-module (rnrs io ports) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 rdelim) + #:use-module (ice-9 popen) #:export (%standard-phases julia-create-package-toml julia-build)) @@ -37,7 +41,7 @@ (invoke "julia" "-e" code)) ;; subpath where we store the package content -(define %package-path "/share/julia/packages/") +(define %package-path "/share/julia/loadpath/") (define (project.toml->name file) "Look for Julia package name in the TOML file FILE (usually named @@ -51,6 +55,18 @@ Project.toml)." (if m (match:substring m 1) (loop (read-line in 'concat))))))))) +(define (project.toml->uuid file) + "Look for Julia package uuid in the TOML file FILE (usually named +Project.toml)." + (call-with-input-file file + (lambda (in) + (let loop ((line (read-line in 'concat))) + (if (eof-object? line) + #f + (let ((m (string-match "uuid\\s*=\\s*\"(.*)\"" line))) + (if m (match:substring m 1) + (loop (read-line in 'concat))))))))) + (define* (install #:key source inputs outputs julia-package-name #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) @@ -59,8 +75,7 @@ Project.toml)." julia-package-name (project.toml->name "Project.toml"))))) (mkdir-p package-dir) - (copy-recursively (getcwd) package-dir)) - #t) + (copy-recursively (getcwd) package-dir))) (define* (precompile #:key source inputs outputs julia-package-name #:allow-other-keys) @@ -73,7 +88,7 @@ Project.toml)." (setenv "JULIA_DEPOT_PATH" builddir) ;; Add new package dir to the load path. (setenv "JULIA_LOAD_PATH" - (string-append builddir "packages/" ":" + (string-append builddir "loadpath/" ":" (or (getenv "JULIA_LOAD_PATH") ""))) ;; Actual precompilation: @@ -84,27 +99,63 @@ Project.toml)." ;; element of DEPOT_PATH. Once the cache file exists, this hack is not ;; needed anymore (like in the check phase). If the user install new ;; packages, those will be installed and precompiled in the home dir. - (string-append "pushfirst!(DEPOT_PATH, pop!(DEPOT_PATH)); using " package))) - #t) + (string-append "pushfirst!(DEPOT_PATH, pop!(DEPOT_PATH)); using " + package)))) (define* (check #:key tests? source inputs outputs julia-package-name - #:allow-other-keys) + parallel-tests? #:allow-other-keys) (when tests? (let* ((out (assoc-ref outputs "out")) (package (or julia-package-name (project.toml->name "Project.toml"))) - (builddir (string-append out "/share/julia/"))) + (builddir (string-append out "/share/julia/")) + (job-count (if parallel-tests? + (parallel-job-count) + 1)) + ;; The --proc argument of Julia *adds* extra processors rather than + ;; specify the exact count to use, so zero must be specified to + ;; disable parallel processing... + (additional-procs (max 0 (1- job-count)))) ;; With a patch, SOURCE_DATE_EPOCH is honored (setenv "SOURCE_DATE_EPOCH" "1") (setenv "JULIA_DEPOT_PATH" builddir) (setenv "JULIA_LOAD_PATH" - (string-append builddir "packages/" ":" + (string-append builddir "loadpath/" ":" (or (getenv "JULIA_LOAD_PATH") ""))) + (setenv "JULIA_CPU_THREADS" (number->string job-count)) (setenv "HOME" "/tmp") - (invoke "julia" "--depwarn=yes" - (string-append builddir "packages/" - package "/test/runtests.jl")))) - #t) + (apply invoke "julia" + `("--depwarn=yes" + ,@(if parallel-tests? + ;; XXX: ... but '--procs' doesn't accept 0 as a valid + ;; value, so just omit the argument entirely. + (list (string-append "--procs=" + (number->string additional-procs))) + '()) + ,(string-append builddir "loadpath/" + package "/test/runtests.jl")))))) + +(define* (link-depot #:key source inputs outputs + julia-package-name julia-package-uuid #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (package-name (or + julia-package-name + (project.toml->name "Project.toml"))) + (package-dir (string-append out %package-path package-name)) + (uuid (or julia-package-uuid (project.toml->uuid "Project.toml"))) + (pipe (open-pipe* OPEN_READ "julia" "-e" + (format #f "using Pkg; +println(Base.version_slug(Base.UUID(\"~a\"), + Base.SHA1(Pkg.GitTools.tree_hash(\".\"))))" uuid))) + (slug (string-trim-right (get-string-all pipe)))) + ;; When installing a package, julia looks first at in the JULIA_DEPOT_PATH + ;; for a path like packages/PACKAGE/XXXX + ;; Where XXXX is a slug encoding the package UUID and SHA1 of the files + ;; Here we create a link with the correct path to enable julia to find the + ;; package + (mkdir-p (string-append out "/share/julia/packages/" package-name)) + (symlink package-dir (string-append out "/share/julia/packages/" + package-name "/" slug)))) (define (julia-create-package-toml outputs source name uuid version @@ -130,14 +181,14 @@ version = \"" version "\" (display (string-append (car (car dep)) " = \"" (cdr (car dep)) "\"\n") f)) deps)) - (close-port f)) - #t) + (close-port f))) (define %standard-phases (modify-phases gnu:%standard-phases (delete 'check) ; tests must be run after installation (replace 'install install) (add-after 'install 'precompile precompile) + (add-after 'unpack 'link-depot link-depot) (add-after 'install 'check check) ;; TODO: In the future we could add a "system-image-generation" phase ;; where we use PackageCompiler.jl to speed up package loading times @@ -146,11 +197,12 @@ version = \"" version "\" (delete 'patch-usr-bin-file) (delete 'build))) -(define* (julia-build #:key inputs julia-package-name +(define* (julia-build #:key inputs julia-package-name julia-package-uuid (phases %standard-phases) #:allow-other-keys #:rest args) "Build the given Julia package, applying all of PHASES in order." (apply gnu:gnu-build #:inputs inputs #:phases phases #:julia-package-name julia-package-name + #:julia-package-uuid julia-package-uuid args)) diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm index 729ab6154f..18ccf7cd8b 100644 --- a/guix/build/linux-module-build-system.scm +++ b/guix/build/linux-module-build-system.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org> ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,7 +34,7 @@ ;; ;; Code: -;; Copied from make-linux-libre's "configure" phase. +;; Similar to make-linux-libre's "configure" phase. (define* (configure #:key inputs target arch #:allow-other-keys) (setenv "KCONFIG_NOTIMESTAMP" "1") (setenv "KBUILD_BUILD_TIMESTAMP" (getenv "SOURCE_DATE_EPOCH")) @@ -42,23 +43,28 @@ (format #t "`ARCH' set to `~a'~%" (getenv "ARCH")) (when target + ;; TODO? (setenv "EXTRA_VERSION" ,extra-version) + ;; TODO? kernel ".config". (setenv "CROSS_COMPILE" (string-append target "-")) (format #t "`CROSS_COMPILE' set to `~a'~%" - (getenv "CROSS_COMPILE"))) - ; TODO: (setenv "EXTRA_VERSION" ,extra-version) - ; TODO: kernel ".config". - #t) + (getenv "CROSS_COMPILE")))) -(define* (build #:key inputs make-flags (source-directory ".") #:allow-other-keys) +(define* (build #:key (make-flags '()) (parallel-build? #t) + (source-directory ".") + inputs + #:allow-other-keys) (apply invoke "make" "-C" (string-append (assoc-ref inputs "linux-module-builder") "/lib/modules/build") - (string-append "M=" (getcwd) "/" source-directory) - (or make-flags '()))) + (string-append "M=" (canonicalize-path source-directory)) + `(,@(if parallel-build? + `("-j" ,(number->string (parallel-job-count))) + '()) + ,@make-flags))) -;; This block was copied from make-linux-libre--only took the "modules_install" -;; part. -(define* (install #:key make-flags (source-directory ".") +;; Similar to the "modules_install" part of make-linux-libre. +(define* (install #:key (make-flags '()) (parallel-build? #t) + (source-directory ".") inputs native-inputs outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) @@ -68,7 +74,7 @@ (apply invoke "make" "-C" (string-append (assoc-ref inputs "linux-module-builder") "/lib/modules/build") - (string-append "M=" (getcwd) "/" source-directory) + (string-append "M=" (canonicalize-path source-directory)) ;; Disable depmod because the Guix system's module directory ;; is an union of potentially multiple packages. It is not ;; possible to use depmod to usefully calculate a dependency @@ -79,7 +85,10 @@ (string-append "INSTALL_MOD_PATH=" out) "INSTALL_MOD_STRIP=1" "modules_install" - (or make-flags '())))) + `(,@(if parallel-build? + `("-j" ,(number->string (parallel-job-count))) + '()) + ,@make-flags)))) (define %standard-phases (modify-phases gnu:%standard-phases diff --git a/guix/build/meson-build-system.scm b/guix/build/meson-build-system.scm index cc2ba83889..61ce45367d 100644 --- a/guix/build/meson-build-system.scm +++ b/guix/build/meson-build-system.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2017 Peter Mikkelsen <petermikkelsen10@gmail.com> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -63,16 +64,17 @@ (number->string (parallel-job-count)) "1"))) -(define* (check #:key test-target parallel-tests? tests? +(define* (check #:key tests? test-options parallel-tests? #:allow-other-keys) - (setenv "MESON_TESTTHREADS" - (if parallel-tests? - (number->string (parallel-job-count)) - "1")) (if tests? - (invoke "ninja" test-target) - (format #t "test suite not run~%")) - #t) + (begin + (setenv "MESON_TESTTHREADS" + (if parallel-tests? + (number->string (parallel-job-count)) + "1")) + ;; Always provide "-t 0" to disable the 30 s default timeout. + (apply invoke "meson" "test" "--print-errorlogs" "-t" "0" test-options)) + (format #t "test suite not run~%"))) (define* (install #:rest args) (invoke "ninja" "install")) diff --git a/guix/build/minetest-build-system.scm b/guix/build/minetest-build-system.scm index 5d7d8d2292..4a7a87ab83 100644 --- a/guix/build/minetest-build-system.scm +++ b/guix/build/minetest-build-system.scm @@ -23,6 +23,7 @@ #:use-module (ice-9 rdelim) #:use-module (ice-9 receive) #:use-module (ice-9 regex) + #:use-module (ice-9 exceptions) #:use-module ((guix build gnu-build-system) #:prefix gnu:) #:use-module ((guix build copy-build-system) #:prefix copy:) #:export (%standard-phases @@ -40,7 +41,7 @@ ;; See <https://github.com/minetest/minetest/blob/master/doc/lua_api.txt> ;; for an incomple list of files that can be found in mods. #:include ("mod.conf" "modpack.conf" "settingtypes.txt" "depends.txt" - "description.txt") + "description.txt" "config.txt" "_config.txt") #:include-regexp (".lua$" ".png$" ".ogg$" ".obj$" ".b3d$" ".tr$" ".mts$")))) @@ -190,20 +191,24 @@ auth_backend = sqlite3 (define (stop? line) (and (string? line) (string-contains line "ACTION[Server]: singleplayer [127.0.0.1] joins game."))) - (let loop () - (match (read-line port) - ((? error? line) - (error "minetest raised an error: ~a" line)) - ((? stop?) + (let loop ((has-errors? #f)) + (match `(,(read-line port) ,has-errors?) + (((? error? line) _) + (display line) + (newline) + (loop #t)) + (((? stop?) #f) (kill pid SIGINT) (close-port port) (waitpid pid)) - ((? string? line) + (((? eof-object?) #f) + (error "minetest didn't start")) + (((or (? stop?) (? eof-object?)) #t) + (error "minetest raised an error")) + (((? string? line) has-error?) (display line) (newline) - (loop)) - ((? eof-object?) - (error "minetest didn't start")))))))) + (loop has-error?)))))))) (define %standard-phases (modify-phases gnu:%standard-phases diff --git a/guix/build/po.scm b/guix/build/po.scm index eb9690ad1a..7f88164cd8 100644 --- a/guix/build/po.scm +++ b/guix/build/po.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> +;;; Copyright © 2019, 2021 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -20,17 +20,23 @@ (define-module (guix build po) #:use-module (ice-9 match) #:use-module (ice-9 peg) + #:use-module (ice-9 regex) #:use-module (ice-9 textual-ports) - #:export (read-po-file)) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:export (read-po-file + translate-cross-references)) ;; A small parser for po files -(define-peg-pattern po-file body (* (or comment entry whitespace))) +(define-peg-pattern po-file body (* (or entry whitespace))) (define-peg-pattern whitespace body (or " " "\t" "\n")) (define-peg-pattern comment-chr body (range #\space #\頋)) (define-peg-pattern comment none (and "#" (* comment-chr) "\n")) +(define-peg-pattern flags all (and (ignore "#, ") (* comment-chr) (ignore "\n"))) (define-peg-pattern entry all - (and (ignore (* whitespace)) (ignore "msgid ") msgid - (ignore (* whitespace)) (ignore "msgstr ") msgstr)) + (and (* (or flags comment (ignore (* whitespace)))) + (ignore "msgid ") msgid (ignore (* whitespace)) + (ignore "msgstr ") msgstr)) (define-peg-pattern escape body (or "\\\\" "\\\"" "\\n")) (define-peg-pattern str-chr body (or " " "!" (and (ignore "\\") "\"") "\\n" (and (ignore "\\") "\\") @@ -53,7 +59,24 @@ (append (list "\n" prefix) result))))))) (define (parse-tree->assoc parse-tree) - "Converts a po PARSE-TREE to an association list." + "Converts a po PARSE-TREE to an association list, where the key is the msgid +and the value is the msgstr. The result only contains non fuzzy strings." + (define (comments->flags comments) + (match comments + (('flags flags) + (map (lambda (flag) (string->symbol (string-trim-both flag #\space))) + (string-split flags #\,))) + ((? list? comments) + (fold + (lambda (comment res) + (match comment + ((? string? _) res) + (flags + (append (comments->flags flags) + res)))) + '() + comments)))) + (match parse-tree (() '()) ((entry . parse-tree) @@ -66,10 +89,22 @@ ;; empty msgstr (('entry ('msgid msgid) 'msgstr) (parse-tree->assoc parse-tree)) + (('entry _ ('msgid msgid) 'msgstr) + (parse-tree->assoc parse-tree)) + (('entry ('msgid msgid) ('msgstr msgstr)) + (acons (interpret-newline-escape msgid) + (interpret-newline-escape msgstr) + (parse-tree->assoc parse-tree))) (('entry ('msgid msgid) ('msgstr msgstr)) (acons (interpret-newline-escape msgid) (interpret-newline-escape msgstr) - (parse-tree->assoc parse-tree))))))) + (parse-tree->assoc parse-tree))) + (('entry comments ('msgid msgid) ('msgstr msgstr)) + (if (member 'fuzzy (comments->flags comments)) + (parse-tree->assoc parse-tree) + (acons (interpret-newline-escape msgid) + (interpret-newline-escape msgstr) + (parse-tree->assoc parse-tree)))))))) (define (read-po-file port) "Read a .po file from PORT and return an alist of msgid and msgstr." @@ -77,3 +112,71 @@ po-file (get-string-all port))))) (parse-tree->assoc tree))) + +(define (canonicalize-whitespace str) + "Change whitespace (newlines, etc.) in STR to @code{#\\space}." + (string-map (lambda (chr) + (if (char-set-contains? char-set:whitespace chr) + #\space + chr)) + str)) + +(define xref-regexp + ;; Texinfo cross-reference regexp. + (make-regexp "@(px|x)?ref\\{([^,}]+)")) + +(define (translate-cross-references texi pofile) + "Translate the cross-references that appear in @var{texi}, the initial +translation of a Texinfo file, using the msgid/msgstr pairs from @var{pofile}." + (define translations + (call-with-input-file pofile read-po-file)) + + (define content + (call-with-input-file texi get-string-all)) + + (define matches + (list-matches xref-regexp content)) + + (define translation-map + (fold (match-lambda* + (((msgid . str) result) + (vhash-cons msgid str result))) + vlist-null + translations)) + + (define translated + ;; Iterate over MATCHES and replace cross-references with their + ;; translation found in TRANSLATION-MAP. (We can't use + ;; 'substitute*' because matches can span multiple lines.) + (let loop ((matches matches) + (offset 0) + (result '())) + (match matches + (() + (string-concatenate-reverse + (cons (string-drop content offset) result))) + ((head . tail) + (let ((prefix (match:substring head 1)) + (ref (canonicalize-whitespace (match:substring head 2)))) + (define translated + (string-append "@" (or prefix "") + "ref{" + (match (vhash-assoc ref translation-map) + (#f ref) + ((_ . str) str)))) + + (loop tail + (match:end head) + (append (list translated + (string-take + (string-drop content offset) + (- (match:start head) offset))) + result))))))) + + (format (current-error-port) + "translated ~a cross-references in '~a'~%" + (length matches) texi) + + (call-with-output-file texi + (lambda (port) + (display translated port)))) diff --git a/guix/build/qt-utils.scm b/guix/build/qt-utils.scm index 97145a116d..b9c5a76f34 100644 --- a/guix/build/qt-utils.scm +++ b/guix/build/qt-utils.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2021 Brendan Tildesley <mail@brendan.scot> ;;; ;;; This file is part of GNU Guix. ;;; @@ -109,7 +110,7 @@ (define* (wrap-qt-program program-name #:key (sh (which "bash")) inputs output (qt-wrap-excluded-inputs %qt-wrap-excluded-inputs)) - "Wrap the specified programm (which must reside in the OUTPUT's \"/bin\" + "Wrap the specified program (which must reside in the OUTPUT's \"/bin\" directory) with suitably set environment variables. This is like qt-build-systems's phase \"qt-wrap\", but only the named program @@ -134,7 +135,10 @@ add a dependency of that output on Qt." (define (find-files-to-wrap output-dir) (append-map (lambda (dir) - (if (directory-exists? dir) (find-files dir ".*") (list))) + (if (directory-exists? dir) + (find-files dir (lambda (file stat) + (not (wrapped-program? file)))) + (list))) (list (string-append output-dir "/bin") (string-append output-dir "/sbin") (string-append output-dir "/libexec") diff --git a/guix/build/renpy-build-system.scm b/guix/build/renpy-build-system.scm index 66683971c5..e4a88456be 100644 --- a/guix/build/renpy-build-system.scm +++ b/guix/build/renpy-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2021 Leo Prikler <leo.prikler@student.tugraz.at> +;;; Copyright © 2021 Liliana Marie Prikler <liliana.prikler@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index ac1b0c2eea..45f95c509d 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com> +;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -56,6 +57,9 @@ restart-on-EINTR + device-number + device-number->major+minor + mount? mount-device-number mount-source @@ -67,6 +71,11 @@ mounts mount-points + SWAP_FLAG_PREFER + SWAP_FLAG_PRIO_MASK + SWAP_FLAG_PRIO_SHIFT + SWAP_FLAG_DISCARD + swapon swapoff @@ -116,6 +125,8 @@ with-file-lock with-file-lock/no-wait + set-child-subreaper! + set-thread-name thread-name @@ -176,6 +187,8 @@ terminal-window-size terminal-columns terminal-rows + openpty + login-tty utmpx? utmpx-login-type @@ -418,15 +431,21 @@ expansion-time error is raised if FIELD does not exist in TYPE." "Evaluate EXPR and restart upon EINTR. Return the value of EXPR." (call-with-restart-on-EINTR (lambda () expr))) -(define (syscall->procedure return-type name argument-types) +(define* (syscall->procedure return-type name argument-types + #:key library) "Return a procedure that wraps the C function NAME using the dynamic FFI, -and that returns two values: NAME's return value, and errno. +and that returns two values: NAME's return value, and errno. When LIBRARY is +specified, look up NAME in that library rather than in the global symbol name +space. If an error occurs while creating the binding, defer the error report until the returned procedure is called." (catch #t (lambda () - (let ((ptr (dynamic-func name (dynamic-link)))) + (let ((ptr (dynamic-func name + (if library + (dynamic-link library) + (dynamic-link))))) ;; The #:return-errno? facility was introduced in Guile 2.0.12. (pointer->procedure return-type ptr argument-types #:return-errno? #t))) @@ -450,6 +469,29 @@ the returned procedure is called." ;;; +;;; Block devices. +;;; + +;; Convert between major:minor pairs and packed ‘device number’ representation. +;; XXX These aren't syscalls, but if you squint very hard they are part of the +;; FFI or however you want to justify me not finding a better fit… :-) +(define (device-number major minor) ; see glibc's <sys/sysmacros.h> + "Return the device number for the device with MAJOR and MINOR, for use as +the last argument of `mknod'." + (logior (ash (logand #x00000fff major) 8) + (ash (logand #xfffff000 major) 32) + (logand #x000000ff minor) + (ash (logand #xffffff00 minor) 12))) + +(define (device-number->major+minor device) ; see glibc's <sys/sysmacros.h> + "Return two values: the major and minor device numbers that make up DEVICE." + (values (logior (ash (logand #x00000000000fff00 device) -8) + (ash (logand #xfffff00000000000 device) -32)) + (logior (logand #x00000000000000ff device) + (ash (logand #x00000ffffff00000 device) -12)))) + + +;;; ;;; File systems. ;;; @@ -628,7 +670,7 @@ current process." (define (string->device-number str) (match (string-split str #\:) (((= string->number major) (= string->number minor)) - (+ (* major 256) minor)))) + (device-number major minor)))) (call-with-input-file "/proc/self/mountinfo" (lambda (port) @@ -650,6 +692,13 @@ current process." "Return the mounts points for currently mounted file systems." (map mount-point (mounts))) +;; Pulled from glibc's sysdeps/unix/sysv/linux/sys/swap.h + +(define SWAP_FLAG_PREFER #x8000) ;; Set if swap priority is specified. +(define SWAP_FLAG_PRIO_MASK #x7fff) +(define SWAP_FLAG_PRIO_SHIFT 0) +(define SWAP_FLAG_DISCARD #x10000) ;; Discard swap cluster after use. + (define swapon (let ((proc (syscall->procedure int "swapon" (list '* int)))) (lambda* (device #:optional (flags 0)) @@ -1386,6 +1435,11 @@ handler if the lock is already held by another process." (define PR_SET_NAME 15) ;<linux/prctl.h> (define PR_GET_NAME 16) +(define PR_SET_CHILD_SUBREAPER 36) + +(define (set-child-subreaper!) + "Set the CHILD_SUBREAPER capability for the current process." + (%prctl PR_SET_CHILD_SUBREAPER 1 0 0 0)) (define %max-thread-name-length ;; Maximum length in bytes of the process name, including the terminating @@ -2259,6 +2313,41 @@ PORT, trying to guess a reasonable value if all else fails. The result is always a positive integer." (terminal-dimension window-size-rows port (const 25))) +(define openpty + (let ((proc (syscall->procedure int "openpty" '(* * * * *) + #:library "libutil"))) + (lambda () + "Return two file descriptors: one for the pseudo-terminal control side, +and one for the controlled side." + (let ((head (make-bytevector (sizeof int))) + (inferior (make-bytevector (sizeof int)))) + (let-values (((ret err) + (proc (bytevector->pointer head) + (bytevector->pointer inferior) + %null-pointer %null-pointer %null-pointer))) + (unless (zero? ret) + (throw 'system-error "openpty" "~A" + (list (strerror err)) + (list err)))) + + (let ((* (lambda (bv) + (bytevector-sint-ref bv 0 (native-endianness) + (sizeof int))))) + (values (* head) (* inferior))))))) + +(define login-tty + (let* ((proc (syscall->procedure int "login_tty" (list int) + #:library "libutil"))) + (lambda (fd) + "Make FD the controlling terminal of the current process (with the +TIOCSCTTY ioctl), redirect standard input, standard output and standard error +output to this terminal, and close FD." + (let-values (((ret err) (proc fd))) + (unless (zero? ret) + (throw 'system-error "login-pty" "~A" + (list (strerror err)) + (list err))))))) + ;;; ;;; utmpx. diff --git a/guix/build/union.scm b/guix/build/union.scm index 961ac3298b..bf75c67c52 100644 --- a/guix/build/union.scm +++ b/guix/build/union.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com> ;;; @@ -99,8 +99,9 @@ identical, #f otherwise." ;; a warning doesn't make sense. For example, "icon-theme.cache" is ;; regenerated by a profile hook which shadows the file provided by ;; individual packages, and "gschemas.compiled" is made available to - ;; applications via 'glib-or-gtk-build-system'. - '("icon-theme.cache" "gschemas.compiled")) + ;; applications via 'glib-or-gtk-build-system'; "etc/ld.so.cache" is created + ;; for most packages. + '("icon-theme.cache" "gschemas.compiled" "ld.so.cache")) (define (warn-about-collision files) "Handle the collision among FILES by emitting a warning and choosing the diff --git a/guix/cache.scm b/guix/cache.scm index 0401a9d428..51009809bd 100644 --- a/guix/cache.scm +++ b/guix/cache.scm @@ -101,7 +101,13 @@ CLEANUP-PERIOD denotes the minimum time between two cache cleanups." #:now now #:entry-expiration entry-expiration #:delete-entry delete-entry) - (call-with-output-file expiry-file - (cute write (time-second now) <>)))) + (catch 'system-error + (lambda () + (call-with-output-file expiry-file + (cute write (time-second now) <>))) + (lambda args + ;; ENOENT means CACHE does not exist. + (unless (= ENOENT (system-error-errno args)) + (apply throw args)))))) ;;; cache.scm ends here diff --git a/guix/channels.scm b/guix/channels.scm index 476d62e1f4..e4e0428eb5 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -1089,8 +1089,13 @@ cannot be found." (if (channel-news-entry-commit entry) entry (let* ((tag (channel-news-entry-tag entry)) - (reference (string-append "refs/tags/" tag)) - (oid (reference-name->oid repository reference))) + (reference (reference-lookup repository + (string-append "refs/tags/" tag))) + (target (reference-target reference)) + (oid (let ((obj (object-lookup repository target))) + (if (= OBJ-TAG (object-type obj)) ;annotated tag? + (tag-target-id (tag-lookup repository target)) + target)))) (channel-news-entry (oid->string oid) tag (channel-news-entry-title entry) (channel-news-entry-body entry))))) diff --git a/guix/cpio.scm b/guix/cpio.scm index 8038a11f3c..d4a7d5f1e0 100644 --- a/guix/cpio.scm +++ b/guix/cpio.scm @@ -18,6 +18,8 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix cpio) + #:use-module ((guix build syscalls) #:select (device-number + device-number->major+minor)) #:use-module ((guix build utils) #:select (dump-port)) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) @@ -129,8 +131,8 @@ (nlink 1) (mtime 0) (size 0) (dev 0) (rdev 0) (name-size 0)) "Return a new cpio file header." - (let-values (((major minor) (device->major+minor dev)) - ((rmajor rminor) (device->major+minor rdev))) + (let-values (((major minor) (device-number->major+minor dev)) + ((rmajor rminor) (device-number->major+minor rdev))) (%make-cpio-header MAGIC inode mode uid gid nlink mtime @@ -154,21 +156,6 @@ denotes, similar to 'stat:type'." (else (error "unsupported file type" mode))))) -(define (device-number major minor) ; see glibc's <sys/sysmacros.h> - "Return the device number for the device with MAJOR and MINOR, for use as -the last argument of `mknod'." - (logior (ash (logand #x00000fff major) 8) - (ash (logand #xfffff000 major) 32) - (logand #x000000ff minor) - (ash (logand #xffffff00 minor) 12))) - -(define (device->major+minor device) ; see glibc's <sys/sysmacros.h> - "Return two values: the major and minor device numbers that make up DEVICE." - (values (logior (ash (logand #x00000000000fff00 device) -8) - (ash (logand #xfffff00000000000 device) -32)) - (logior (logand #x00000000000000ff device) - (ash (logand #x00000ffffff00000 device) -12)))) - (define* (file->cpio-header file #:optional (file-name file) #:key (stat lstat)) "Return a cpio header corresponding to the info returned by STAT for FILE, diff --git a/guix/derivations.scm b/guix/derivations.scm index 33f4dc5d9d..f77ea179f4 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -1243,20 +1243,21 @@ MODULES are compiled." (hash-set! %module-cache key result) result))) -(define* (build-expression->derivation store name exp ;deprecated - #:key - (system (%current-system)) - (inputs '()) - (outputs '("out")) - hash hash-algo recursive? - (env-vars '()) - (modules '()) - guile-for-build - references-graphs - allowed-references - disallowed-references - local-build? (substitutable? #t) - (properties '())) +(define-deprecated (build-expression->derivation store name exp + #:key + (system (%current-system)) + (inputs '()) + (outputs '("out")) + hash hash-algo recursive? + (env-vars '()) + (modules '()) + guile-for-build + references-graphs + allowed-references + disallowed-references + local-build? (substitutable? #t) + (properties '())) + gexp->derivation ;unbound, but that's okay "Return a derivation that executes Scheme expression EXP as a builder for derivation NAME. INPUTS must be a list of (NAME DRV-PATH SUB-DRV) tuples; when SUB-DRV is omitted, \"out\" is assumed. MODULES is a list diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm index 6a792febd4..337a73c1a2 100644 --- a/guix/diagnostics.scm +++ b/guix/diagnostics.scm @@ -54,7 +54,9 @@ condition-fix-hint guix-warning-port - program-name)) + program-name + + define-with-syntax-properties)) ;;; Commentary: ;;; @@ -331,3 +333,37 @@ number of arguments in ARGS matches the escapes in FORMAT." (define program-name ;; Name of the command-line program currently executing, or #f. (make-parameter #f)) + + +(define-syntax define-with-syntax-properties + (lambda (x) + "Define BINDING to be a syntax form replacing each VALUE-IDENTIFIER and +SYNTAX-PROPERTIES-IDENTIFIER in body by the syntax and syntax-properties, +respectively, of each ensuing syntax object." + (syntax-case x () + ((_ (binding (value-identifier syntax-properties-identifier) + ...) + body ...) + (and (and-map identifier? #'(value-identifier ...)) + (and-map identifier? #'(syntax-properties-identifier ...))) + #'(define-syntax binding + (lambda (y) + (with-ellipsis ::: + (syntax-case y () + ((_ value-identifier ...) + (with-syntax ((syntax-properties-identifier + #`'#,(datum->syntax y + (syntax-source + #'value-identifier))) + ...) + #'(begin body ...))) + (_ + (syntax-violation #f (format #f + "Expected (~a~{ ~a~})" + 'binding + '(value-identifier ...)) + y))))))) + (_ + (syntax-violation #f "Expected a definition of the form \ +(define-with-syntax-properties (binding (value syntax-properties) \ +...) body ...)" x))))) diff --git a/guix/discovery.scm b/guix/discovery.scm index b84b9ff370..81d4ca600f 100644 --- a/guix/discovery.scm +++ b/guix/discovery.scm @@ -107,19 +107,25 @@ name and the exception key and arguments." (define prefix-len (string-length directory)) - (filter-map (lambda (file) - (let* ((relative (string-drop file prefix-len)) - (module (file-name->module-name relative))) - (catch #t - (lambda () - (resolve-interface module)) - (lambda args - ;; Report the error, but keep going. - (warn file module args) - #f)))) - (scheme-files (if sub-directory - (string-append directory "/" sub-directory) - directory)))) + ;; Hide Guile warnings such as "source file [...] newer than compiled" when + ;; loading user code, unless we're hacking on Guix proper. See + ;; <https://issues.guix.gnu.org/43747>. + (parameterize ((current-warning-port (if (getenv "GUIX_UNINSTALLED") + (current-warning-port) + (%make-void-port "w")))) + (filter-map (lambda (file) + (let* ((relative (string-drop file prefix-len)) + (module (file-name->module-name relative))) + (catch #t + (lambda () + (resolve-interface module)) + (lambda args + ;; Report the error, but keep going. + (warn file module args) + #f)))) + (scheme-files (if sub-directory + (string-append directory "/" sub-directory) + directory))))) (define* (scheme-modules* directory #:optional sub-directory) "Return the list of module names found under SUB-DIRECTORY in DIRECTORY. diff --git a/guix/docker.scm b/guix/docker.scm index a6f73d423c..5e6460f43f 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -214,10 +214,11 @@ SRFI-19 time-utc object, as the creation time in metadata." (else (error "unsupported system" system))))))) - (cond* ("x86_64" "amd64") - ("i686" "386") - ("arm" "arm") - ("mips64" "mips64le"))))) + (cond* ("x86_64" "amd64") + ("i686" "386") + ("arm" "arm") + ("aarch64" "arm64") + ("mips64" "mips64le"))))) ;; Make sure we start with a fresh, empty working directory. (mkdir directory) (with-directory-excursion directory diff --git a/guix/download.scm b/guix/download.scm index 85b97a4766..4e219c9f49 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -36,6 +36,7 @@ #:use-module (srfi srfi-26) #:export (%mirrors %disarchive-mirrors + %download-fallback-test (url-fetch* . url-fetch) url-fetch/executable url-fetch/tarbomb @@ -399,14 +400,23 @@ (plain-file "content-addressed-mirrors" (object->string %content-addressed-mirrors))) +(define %no-mirrors-file + ;; File specifying an empty list of mirrors, for fallback tests. + (plain-file "no-content-addressed-mirrors" (object->string ''()))) + (define %disarchive-mirrors ;; TODO: Eventually turn into a procedure that takes a hash algorithm ;; (symbol) and hash (bytevector). - '("https://disarchive.ngyro.com/")) + '("https://disarchive.guix.gnu.org/" + "https://disarchive.ngyro.com/")) (define %disarchive-mirror-file (plain-file "disarchive-mirrors" (object->string %disarchive-mirrors))) +(define %no-disarchive-mirrors-file + ;; File specifying an empty list of Disarchive mirrors, for fallback tests. + (plain-file "no-disarchive-mirrors" (object->string '()))) + (define built-in-builders* (store-lift built-in-builders)) @@ -455,6 +465,24 @@ download by itself using its own dependencies." ;; for that built-in is widespread. #:local-build? #t))) +(define %download-fallback-test + ;; Define whether to test one of the download fallback mechanism. Possible + ;; values are: + ;; + ;; - #f, to use the normal download methods, not trying to exercise the + ;; fallback mechanism; + ;; + ;; - 'none, to disable all the fallback mechanisms; + ;; + ;; - 'content-addressed-mirrors, to purposefully attempt to download from + ;; a content-addressed mirror; + ;; + ;; - 'disarchive-mirrors, to download from Disarchive + Software Heritage. + ;; + ;; This is meant to be used for testing purposes. + (make-parameter (and=> (getenv "GUIX_DOWNLOAD_FALLBACK_TEST") + string->symbol))) + (define* (url-fetch* url hash-algo hash #:optional name #:key (system (%current-system)) @@ -490,7 +518,10 @@ name in the store." (unless (member "download" builtins) (error "'guix-daemon' is too old, please upgrade" builtins)) - (built-in-download (or name file-name) url + (built-in-download (or name file-name) + (match (%download-fallback-test) + ((or #f 'none) url) + (_ "https://example.org/does-not-exist")) #:guile guile #:system system #:hash-algo hash-algo @@ -498,9 +529,15 @@ name in the store." #:executable? executable? #:mirrors %mirror-file #:content-addressed-mirrors - %content-addressed-mirror-file + (match (%download-fallback-test) + ((or #f 'content-addressed-mirrors) + %content-addressed-mirror-file) + (_ %no-mirrors-file)) #:disarchive-mirrors - %disarchive-mirror-file))))) + (match (%download-fallback-test) + ((or #f 'disarchive-mirrors) + %disarchive-mirror-file) + (_ %no-disarchive-mirrors-file))))))) (define* (url-fetch/executable url hash-algo hash #:optional name diff --git a/guix/extracting-download.scm b/guix/extracting-download.scm new file mode 100644 index 0000000000..4b7dcc7e83 --- /dev/null +++ b/guix/extracting-download.scm @@ -0,0 +1,179 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org> +;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> +;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> +;;; Copyright © 2020 Hartmut Goebel <h.goebel@crazy-compilers.com> +;;; +;;; 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 extracting-download) + #:use-module (ice-9 match) + #:use-module (ice-9 popen) + #:use-module ((guix build download) #:prefix build:) + #:use-module ((guix build utils) #:hide (delete)) + #:use-module (guix gexp) + #:use-module (guix modules) + #:use-module (guix monads) + #:use-module (guix packages) ;; for %current-system + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (srfi srfi-26) + #:export (http-fetch/extract + download-to-store/extract)) + +;;; +;;; Produce fixed-output derivations with data extracted from n archive +;;; fetched over HTTP or FTP. +;;; +;;; This is meant to be used for package repositories where the actual source +;;; archive is packed into another archive, eventually carrying meta-data. +;;; Using this derivation saves both storing the outer archive and extracting +;;; the actual one at build time. The hash is calculated on the actual +;;; archive to ease validating the stored file. +;;; + +(define* (http-fetch/extract url filename-to-extract hash-algo hash + #:optional name + #:key (system (%current-system)) (guile (default-guile))) + "Return a fixed-output derivation that fetches an archive at URL, and +extracts FILE_TO_EXTRACT from the archive. The FILE_TO_EXTRACT is expected to +have hash HASH of type HASH-ALGO (a symbol). By default, the file name is the +base name of URL; optionally, NAME can specify a different file name." + (define file-name + (match url + ((head _ ...) + (basename head)) + (_ + (basename url)))) + + (define guile-zlib + (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) + + (define guile-json + (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4)) + + (define gnutls + (module-ref (resolve-interface '(gnu packages tls)) 'gnutls)) + + (define inputs + `(("tar" ,(module-ref (resolve-interface '(gnu packages base)) + 'tar)))) + + (define config.scm + (scheme-file "config.scm" + #~(begin + (define-module (guix config) + #:export (%system)) + + (define %system + #$(%current-system))))) + + (define modules + (cons `((guix config) => ,config.scm) + (delete '(guix config) + (source-module-closure '((guix build download) + (guix build utils) + (guix utils) + (web uri)))))) + + (define build + (with-imported-modules modules + (with-extensions (list guile-json gnutls ;for (guix swh) + guile-zlib) + #~(begin + (use-modules (guix build download) + (guix build utils) + (guix utils) + (web uri) + (ice-9 match) + (ice-9 popen)) + ;; The code below expects tar to be in $PATH. + (set-path-environment-variable "PATH" '("bin") + (match '#+inputs + (((names dirs outputs ...) ...) + dirs))) + + (setvbuf (current-output-port) 'line) + (setvbuf (current-error-port) 'line) + + (call-with-temporary-directory + (lambda (directory) + ;; TODO: Support different archive types, based on content-type + ;; or archive name extention. + (let* ((file-to-extract (getenv "extract filename")) + (port (http-fetch (string->uri (getenv "download url")) + #:verify-certificate? #f)) + (tar (open-pipe* OPEN_WRITE "tar" "-C" directory + "-xf" "-" file-to-extract))) + (dump-port port tar) + (close-port port) + (let ((status (close-pipe tar))) + (unless (zero? status) + (error "tar extraction failure" status))) + (copy-file (string-append directory "/" + (getenv "extract filename")) + #$output)))))))) + + (mlet %store-monad ((guile (package->derivation guile system))) + (gexp->derivation (or name file-name) build + + ;; Use environment variables and a fixed script name so + ;; there's only one script in store for all the + ;; downloads. + #:script-name "extract-download" + #:env-vars + `(("download url" . ,url) + ("extract filename" . ,filename-to-extract)) + #:leaked-env-vars '("http_proxy" "https_proxy" + "LC_ALL" "LC_MESSAGES" "LANG" + "COLUMNS") + #:system system + #:local-build? #t ; don't offload download + #:hash-algo hash-algo + #:hash hash + #:guile-for-build guile))) + + +(define* (download-to-store/extract store url filename-to-extract + #:optional (name (basename url)) + #:key (log (current-error-port)) + (verify-certificate? #t)) + "Download an archive from URL, and extracts FILE_TO_EXTRACT from the archive +to STORE, either under NAME or URL's basename if omitted. Write progress +reports to LOG. VERIFY-CERTIFICATE? determines whether or not to validate +HTTPS server certificates." + (call-with-temporary-output-file + (lambda (temp port) + (let ((result + (parameterize ((current-output-port log)) + (build:url-fetch url temp + ;;#:mirrors %mirrors + #:verify-certificate? + verify-certificate?)))) + (close port) + (and result + (call-with-temporary-output-file + (lambda (contents port) + (let ((tar (open-pipe* OPEN_READ + "tar" ;"--auto-compress" + "-xf" temp "--to-stdout" filename-to-extract))) + (dump-port tar port) + (close-port port) + (let ((status (close-pipe tar))) + (unless (zero? status) + (error "tar extraction failure" status))) + (add-to-store store name #f "sha256" contents))))))))) diff --git a/guix/gexp.scm b/guix/gexp.scm index ff5ede2857..01dca902f7 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -685,7 +685,8 @@ SUFFIX." expander => (lambda (obj lowered output) (match obj (($ <file-append> base suffix) - (let* ((expand (lookup-expander base)) + (let* ((expand (or (lookup-expander base) + (lookup-expander lowered))) (base (expand base lowered output))) (string-append base (string-concatenate suffix))))))) @@ -923,9 +924,8 @@ corresponding <derivation-input> or store item." (match graphs (((file-names . inputs) ...) - (mlet %store-monad ((inputs (without-grafting - (lower-inputs (map tuple->gexp-input inputs) - system target)))) + (mlet %store-monad ((inputs (lower-inputs (map tuple->gexp-input inputs) + system target))) (return (map cons file-names inputs)))))) (define* (lower-references lst #:key system target) @@ -938,15 +938,13 @@ names and file names suitable for the #:allowed-references argument to ((? string? output) (return output)) (($ <gexp-input> thing output native?) - (mlet %store-monad ((drv (without-grafting - (lower-object thing system - #:target (if native? - #f target))))) + (mlet %store-monad ((drv (lower-object thing system + #:target (if native? + #f target)))) (return (derivation->output-path drv output)))) (thing - (mlet %store-monad ((drv (without-grafting - (lower-object thing system - #:target target)))) + (mlet %store-monad ((drv (lower-object thing system + #:target target))) (return (derivation->output-path drv)))))) (mapm/accumulate-builds lower lst))) diff --git a/guix/git.scm b/guix/git.scm index acc48fd12f..dc2ca1be84 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -34,8 +34,9 @@ #:use-module (guix records) #:use-module (guix gexp) #:use-module (guix sets) - #:use-module ((guix diagnostics) #:select (leave)) + #:use-module ((guix diagnostics) #:select (leave warning)) #:use-module (guix progress) + #:autoload (guix swh) (swh-download commit-id?) #:use-module (rnrs bytevectors) #:use-module (ice-9 format) #:use-module (ice-9 match) @@ -57,6 +58,8 @@ commit-difference commit-relation + remote-refs + git-checkout git-checkout? git-checkout-url @@ -180,6 +183,13 @@ the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables." (lambda args (make-fetch-options auth-method))))) +(define GITERR_HTTP + ;; Guile-Git <= 0.5.2 lacks this constant. + (let ((errors (resolve-interface '(git errors)))) + (if (module-defined? errors 'GITERR_HTTP) + (module-ref errors 'GITERR_HTTP) + 34))) + (define (clone* url directory) "Clone git repository at URL into DIRECTORY. Upon failure, make sure no empty directory is left behind." @@ -332,7 +342,8 @@ dynamic extent of EXP." "Return true if REF, a reference such as '(commit . \"cabba9e\"), is definitely available in REPOSITORY, false otherwise." (match ref - (('commit . commit) + ((or ('commit . commit) + ('tag-or-commit . (? commit-id? commit))) (let ((len (string-length commit)) (oid (string->oid commit))) (false-if-git-not-found @@ -342,6 +353,42 @@ definitely available in REPOSITORY, false otherwise." (_ #f))) +(define (clone-from-swh url tag-or-commit output) + "Attempt to clone TAG-OR-COMMIT (a string), which originates from URL, using +a copy archived at Software Heritage." + (call-with-temporary-directory + (lambda (bare) + (and (swh-download url tag-or-commit bare + #:archive-type 'git-bare) + (let ((repository (clone* bare output))) + (remote-set-url! repository "origin" url) + repository))))) + +(define (clone/swh-fallback url ref cache-directory) + "Like 'clone', but fallback to Software Heritage if the repository cannot be +found at URL." + (define (inaccessible-url-error? err) + (let ((class (git-error-class err)) + (code (git-error-code err))) + (or (= class GITERR_HTTP) ;404 or similar + (= class GITERR_NET)))) ;unknown host, etc. + + (catch 'git-error + (lambda () + (clone* url cache-directory)) + (lambda (key err) + (match ref + (((or 'commit 'tag-or-commit) . commit) + (if (inaccessible-url-error? err) + (or (clone-from-swh url commit cache-directory) + (begin + (warning (G_ "revision ~a of ~a \ +could not be fetched from Software Heritage~%") + commit url) + (throw key err))) + (throw key err))) + (_ (throw key err)))))) + (define cached-checkout-expiration ;; Return the expiration time procedure for a cached checkout. ;; TODO: Honor $GUIX_GIT_CACHE_EXPIRATION. @@ -408,7 +455,7 @@ it unchanged." (let* ((cache-exists? (openable-repository? cache-directory)) (repository (if cache-exists? (repository-open cache-directory) - (clone* url cache-directory)))) + (clone/swh-fallback url ref cache-directory)))) ;; Only fetch remote if it has not been cloned just before. (when (and cache-exists? (not (reference-available? repository ref))) @@ -571,6 +618,45 @@ objects: 'ancestor (meaning that OLD is an ancestor of NEW), 'descendant, or (if (set-contains? oldest new) 'descendant 'unrelated)))))) + +;; +;;; Remote operations. +;;; + +(define* (remote-refs url #:key tags?) + "Return the list of references advertised at Git repository URL. If TAGS? +is true, limit to only refs/tags." + (define (ref? ref) + ;; Like `git ls-remote --refs', only show actual references. + (and (string-prefix? "refs/" ref) + (not (string-suffix? "^{}" ref)))) + + (define (tag? ref) + (string-prefix? "refs/tags/" ref)) + + (define (include? ref) + (and (ref? ref) + (or (not tags?) (tag? ref)))) + + (define (remote-head->ref remote) + (let ((name (remote-head-name remote))) + (and (include? name) + name))) + + (with-libgit2 + (call-with-temporary-directory + (lambda (cache-directory) + (let* ((repository (repository-init cache-directory)) + ;; Create an in-memory remote so we don't touch disk. + (remote (remote-create-anonymous repository url))) + (remote-connect remote) + + (let* ((remote-heads (remote-ls remote)) + (refs (filter-map remote-head->ref remote-heads))) + ;; Wait until we're finished with the repository before closing it. + (remote-disconnect remote) + (repository-close! repository) + refs)))))) ;;; diff --git a/guix/gnupg.scm b/guix/gnupg.scm index 5fae24b325..088bebc0de 100644 --- a/guix/gnupg.scm +++ b/guix/gnupg.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -56,9 +57,9 @@ "/gpg/trustedkeys.kbx"))) (define %openpgp-key-server - ;; The default key server. Note that keys.gnupg.net appears to be - ;; unreliable. - (make-parameter "pool.sks-keyservers.net")) + ;; The default key server. It defaults to #f, which causes GnuPG to use the + ;; one it is configured with. + (make-parameter #f)) ;; Regexps for status lines. See file `doc/DETAILS' in GnuPG. @@ -182,22 +183,26 @@ missing key or its key id if the fingerprint is unavailable." (_ #f))) status)) -(define* (gnupg-receive-keys fingerprint/key-id server - #:optional (keyring (current-keyring))) - "Download FINGERPRINT/KEY-ID from SERVER, a key server, and add it to -KEYRING." +(define* (gnupg-receive-keys fingerprint/key-id + #:key server (keyring (current-keyring))) + "Download FINGERPRINT/KEY-ID from SERVER if specified, otherwise from +GnuPG's default/configured one. The key is added to KEYRING." (unless (file-exists? keyring) (mkdir-p (dirname keyring)) - (call-with-output-file keyring (const #t))) ;create an empty keybox + (call-with-output-file keyring (const #t))) ;create an empty keybox - (zero? (system* (%gpg-command) "--keyserver" server - "--no-default-keyring" "--keyring" keyring - "--recv-keys" fingerprint/key-id))) + (zero? (apply system* + `(,(%gpg-command) + ,@(if server + (list "--keyserver" server) + '()) + "--no-default-keyring" "--keyring" ,keyring + "--recv-keys" ,fingerprint/key-id)))) (define* (gnupg-verify* sig file #:key (key-download 'interactive) - (server (%openpgp-key-server)) + server (keyring (current-keyring))) "Like `gnupg-verify', but try downloading the public key if it's missing. Return two values: 'valid-signature and a fingerprint/name pair upon success, @@ -215,7 +220,7 @@ fingerprint/user name pair on success and #f otherwise." (let ((missing (gnupg-status-missing-key? status))) (define (download-and-try-again) ;; Download the missing key and try again. - (if (gnupg-receive-keys missing server keyring) + (if (gnupg-receive-keys missing #:server server #:keyring keyring) (match (gnupg-status-good-signature? (gnupg-verify sig file keyring)) (#f diff --git a/guix/graph.scm b/guix/graph.scm index 0d4cd83667..3a1cab244b 100644 --- a/guix/graph.scm +++ b/guix/graph.scm @@ -337,11 +337,12 @@ nodeArray.push(nodes[\"~a\"]);~%" (define* (export-graph sinks port #:key - reverse-edges? node-type + reverse-edges? node-type (max-depth +inf.0) (backend %graphviz-backend)) "Write to PORT the representation of the DAG with the given SINKS, using the given BACKEND. Use NODE-TYPE to traverse the DAG. When REVERSE-EDGES? is -true, draw reverse arrows." +true, draw reverse arrows. Do not represent nodes whose distance to one of +the SINKS is greater than MAX-DEPTH." (match backend (($ <graph-backend> _ _ emit-prologue emit-epilogue emit-node emit-edge) (emit-prologue (node-type-name node-type) port) @@ -349,6 +350,7 @@ true, draw reverse arrows." (match node-type (($ <node-type> node-identifier node-label node-edges) (let loop ((nodes sinks) + (depths (make-list (length sinks) 0)) (visited (set))) (match nodes (() @@ -356,20 +358,29 @@ true, draw reverse arrows." (emit-epilogue port) (store-return #t))) ((head . tail) - (mlet %store-monad ((id (node-identifier head))) - (if (set-contains? visited id) - (loop tail visited) - (mlet* %store-monad ((dependencies (node-edges head)) - (ids (mapm %store-monad - node-identifier - dependencies))) - (emit-node id (node-label head) port) - (for-each (lambda (dependency dependency-id) - (if reverse-edges? - (emit-edge dependency-id id port) - (emit-edge id dependency-id port))) - dependencies ids) - (loop (append dependencies tail) - (set-insert id visited))))))))))))) + (match depths + ((depth . depths) + (mlet %store-monad ((id (node-identifier head))) + (if (set-contains? visited id) + (loop tail depths visited) + (mlet* %store-monad ((dependencies + (if (= depth max-depth) + (return '()) + (node-edges head))) + (ids + (mapm %store-monad + node-identifier + dependencies))) + (emit-node id (node-label head) port) + (for-each (lambda (dependency dependency-id) + (if reverse-edges? + (emit-edge dependency-id id port) + (emit-edge id dependency-id port))) + dependencies ids) + (loop (append dependencies tail) + (append (make-list (length dependencies) + (+ 1 depth)) + depths) + (set-insert id visited))))))))))))))) ;;; graph.scm ends here diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 510882bc00..1389576cad 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -34,6 +34,8 @@ #:use-module (web uri) #:use-module (guix memoization) #:use-module (guix http-client) + #:use-module (guix diagnostics) + #:use-module (guix i18n) #:use-module (gcrypt hash) #:use-module (guix store) #:use-module ((guix serialization) #:select (write-file)) @@ -153,9 +155,9 @@ package definition." (define %cran-canonical-url "https://cran.r-project.org/package=") (define %bioconductor-url "https://bioconductor.org/packages/") -;; The latest Bioconductor release is 3.13. Bioconductor packages should be +;; The latest Bioconductor release is 3.14. Bioconductor packages should be ;; updated together. -(define %bioconductor-version "3.13") +(define %bioconductor-version "3.14") (define* (bioconductor-packages-list-url #:optional type) (string-append "https://bioconductor.org/packages/" @@ -171,11 +173,11 @@ package definition." release." (let ((url (string->uri (bioconductor-packages-list-url type)))) (guard (c ((http-get-error? c) - (format (current-error-port) - "error: failed to retrieve list of packages from ~s: ~a (~s)~%" - (uri->string (http-get-error-uri c)) - (http-get-error-code c) - (http-get-error-reason c)) + (warning (G_ "failed to retrieve list of packages \ +from ~a: ~a (~a)~%") + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) #f)) ;; Split the big list on empty lines, then turn each chunk into an ;; alist of attributes. @@ -227,27 +229,61 @@ bioconductor package NAME, or #F if the package is unknown." (let ((store-directory (add-to-store store (basename url) #t "sha256" dir))) (values store-directory changeset))))))) - (else (download-to-store store url))))))) - -(define (fetch-description repository name) + (else + (match url + ((? string?) + (download-to-store store url)) + ((urls ...) + ;; Try all the URLs. A use case where this is useful is when one + ;; of the URLs is the /Archive CRAN URL. + (any (cut download-to-store store <>) urls))))))))) + +(define (fetch-description-from-tarball url) + "Fetch the tarball at URL, extra its 'DESCRIPTION' file, parse it, and +return the resulting alist." + (match (download url) + (#f #f) + (tarball + (call-with-temporary-directory + (lambda (dir) + (parameterize ((current-error-port (%make-void-port "rw+")) + (current-output-port (%make-void-port "rw+"))) + (and (zero? (system* "tar" "--wildcards" "-x" + "--strip-components=1" + "-C" dir + "-f" tarball "*/DESCRIPTION")) + (description->alist + (call-with-input-file (string-append dir "/DESCRIPTION") + read-string))))))))) + +(define* (fetch-description repository name #:optional version) "Return an alist of the contents of the DESCRIPTION file for the R package -NAME in the given REPOSITORY, or #f in case of failure. NAME is +NAME at VERSION in the given REPOSITORY, or #f in case of failure. NAME is case-sensitive." (case repository ((cran) - (let ((url (string-append %cran-url name "/DESCRIPTION"))) - (guard (c ((http-get-error? c) - (format (current-error-port) - "error: failed to retrieve package information \ -from ~s: ~a (~s)~%" - (uri->string (http-get-error-uri c)) - (http-get-error-code c) - (http-get-error-reason c)) - #f)) - (let* ((port (http-fetch url)) - (result (description->alist (read-string port)))) - (close-port port) - result)))) + (guard (c ((http-get-error? c) + (warning (G_ "failed to retrieve package information \ +from ~a: ~a (~a)~%") + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) + #f)) + ;; When VERSION is true, we have to download the tarball to get at its + ;; 'DESCRIPTION' file; only the latest one is directly accessible over + ;; HTTP. + (if version + (let ((urls (list (string-append "mirror://cran/src/contrib/" + name "_" version ".tar.gz") + (string-append "mirror://cran/src/contrib/Archive/" + name "/" + name "_" version ".tar.gz")))) + (fetch-description-from-tarball urls)) + (let* ((url (string-append %cran-url name "/DESCRIPTION")) + (port (http-fetch url)) + (result (description->alist (read-string port)))) + (close-port port) + result)))) ((bioconductor) ;; Currently, the bioconductor project does not offer a way to access a ;; package's DESCRIPTION file over HTTP, so we determine the version, @@ -256,22 +292,13 @@ from ~s: ~a (~s)~%" (and (latest-bioconductor-package-version name) #t) (and (latest-bioconductor-package-version name 'annotation) 'annotation) (and (latest-bioconductor-package-version name 'experiment) 'experiment))) + ;; TODO: Honor VERSION. (version (latest-bioconductor-package-version name type)) (url (car (bioconductor-uri name version type))) - (tarball (download url))) - (call-with-temporary-directory - (lambda (dir) - (parameterize ((current-error-port (%make-void-port "rw+")) - (current-output-port (%make-void-port "rw+"))) - (and (zero? (system* "tar" "--wildcards" "-x" - "--strip-components=1" - "-C" dir - "-f" tarball "*/DESCRIPTION")) - (and=> (description->alist (with-input-from-file - (string-append dir "/DESCRIPTION") read-string)) - (lambda (meta) - (if (boolean? type) meta - (cons `(bioconductor-type . ,type) meta)))))))))) + (meta (fetch-description-from-tarball url))) + (if (boolean? type) + meta + (cons `(bioconductor-type . ,type) meta)))) ((git) (and (string-prefix? "http" name) ;; Download the git repository at "NAME" @@ -484,7 +511,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file." ((bioconductor) (list (assoc-ref meta 'bioconductor-type))) (else '()))) - ((url rest ...) url) + ((urls ...) urls) ((? string? url) url) (_ #f))))) (git? (assoc-ref meta 'git)) @@ -591,7 +618,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (lambda* (package-name #:key (repo 'cran) version) "Fetch the metadata for PACKAGE-NAME from REPO and return the `package' s-expression corresponding to that package, or #f on failure." - (let ((description (fetch-description repo package-name))) + (let ((description (fetch-description repo package-name version))) (if description (description->package repo description) (case repo @@ -609,8 +636,9 @@ s-expression corresponding to that package, or #f on failure." (&message (message "couldn't find meta-data for R package"))))))))))) -(define* (cran-recursive-import package-name #:key (repo 'cran)) +(define* (cran-recursive-import package-name #:key (repo 'cran) version) (recursive-import package-name + #:version version #:repo repo #:repo->guix-package cran->guix-package #:guix-name cran-guix-name)) diff --git a/guix/import/crate.scm b/guix/import/crate.scm index 287ffd2536..c76d7e9c1a 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 David Craven <david@craven.ch> -;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2019, 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Nicolas Goaziou <mail@nicolasgoaziou.fr> ;;; @@ -79,7 +79,10 @@ (number crate-version-number "num") ;string (download-path crate-version-download-path "dl_path") ;string (readme-path crate-version-readme-path "readme_path") ;string - (license crate-version-license "license") ;string + (license crate-version-license "license" ;string | #f + (match-lambda + ('null #f) + ((? string? str) str))) (links crate-version-links)) ;alist ;; Crate dependency. Each dependency (each edge in the graph) is annotated as @@ -198,6 +201,7 @@ and LICENSE." (description ,(beautify-description description)) (license ,(match license (() #f) + (#f #f) ((license) license) (_ `(list ,@license))))))) (close-port port) diff --git a/guix/import/egg.scm b/guix/import/egg.scm index 75b7659944..0b88020554 100644 --- a/guix/import/egg.scm +++ b/guix/import/egg.scm @@ -52,10 +52,10 @@ ;;; ;;; The following happens under the hood: ;;; -;;; * <git://code.call-cc.org/eggs-5-latest> is a Git repository that contains -;;; the latest version of all CHICKEN eggs. We look clone this repository -;;; and retrieve the latest version number, and the PACKAGE.egg file, which -;;; contains a list of lists containing metadata about the egg. +;;; * <git://code.call-cc.org/eggs-5-all> is a Git repository that contains +;;; all versions of all CHICKEN eggs. We look clone this repository and, by +;;; default, retrieve the latest version number, and the PACKAGE.egg file, +;;; which contains a list of lists containing metadata about the egg. ;;; ;;; * All the eggs are stored as tarballs at ;;; <https://code.call-cc.org/egg-tarballs/5>, so we grab the tarball for @@ -97,7 +97,7 @@ NAME." (define (eggs-repository) "Update or fetch the latest version of the eggs repository and return the path to the repository." - (let* ((url "git://code.call-cc.org/eggs-5-latest") + (let* ((url "git://code.call-cc.org/eggs-5-all") (directory commit _ (update-cached-checkout url))) directory)) @@ -113,12 +113,13 @@ to the repository." (last directory) #f))) -(define* (egg-metadata name #:optional file) - "Return the package metadata file for the egg NAME, or if FILE is specified, -return the package metadata in FILE." +(define* (egg-metadata name #:key (version #f) (file #f)) + "Return the package metadata file for the egg NAME at version VERSION, or if +FILE is specified, return the package metadata in FILE." (call-with-input-file (or file (string-append (egg-directory name) "/" - (find-latest-version name) + (or version + (find-latest-version name)) "/" name ".egg")) read)) @@ -174,10 +175,11 @@ return the package metadata in FILE." ;;; Egg importer. ;;; -(define* (egg->guix-package name #:key (file #f) (source #f)) - "Import a CHICKEN egg called NAME from either the given .egg FILE, or from -the latest NAME metadata downloaded from the official repository if FILE is #f. -Return a <package> record or #f on failure. +(define* (egg->guix-package name version #:key (file #f) (source #f)) + "Import a CHICKEN egg called NAME from either the given .egg FILE, or from the +latest NAME metadata downloaded from the official repository if FILE is #f. +Return a <package> record or #f on failure. If VERSION is specified, import +the particular version from the egg repository. SOURCE is a ``file-like'' object containing the source code corresponding to the egg. If SOURCE is not specified, the latest tarball for egg NAME will be @@ -187,8 +189,8 @@ Specifying the SOURCE argument is mainly useful for developing a CHICKEN egg locally. Note that if FILE and SOURCE are specified, recursive import will not work." (define egg-content (if file - (egg-metadata name file) - (egg-metadata name))) + (egg-metadata name #:file file) + (egg-metadata name #:version version))) (if (not egg-content) (values #f '()) ; egg doesn't exist (let* ((version* (or (assoc-ref egg-content 'version) @@ -324,10 +326,11 @@ not work." (define egg->guix-package/m ;memoized variant (memoize egg->guix-package)) -(define (egg-recursive-import package-name) +(define* (egg-recursive-import package-name #:optional version) (recursive-import package-name + #:version version #:repo->guix-package (lambda* (name #:key version repo) - (egg->guix-package/m name)) + (egg->guix-package/m name version)) #:guix-name egg-name->guix-name)) diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index 05b4a45f2f..edabb88b7a 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -46,6 +46,7 @@ #:use-module (guix packages) #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:export (elpa->guix-package + guix-package->elpa-name %elpa-updater elpa-recursive-import)) @@ -337,9 +338,10 @@ the package named PACKAGE-NAME." type '<elpa-package>'." (define melpa-recipe - (if (eq? repo 'melpa) - (package-name->melpa-recipe (elpa-package-name pkg)) - #f)) + ;; XXX: Call 'identity' to work around a Guile 3.0.[5-7] compiler bug: + ;; <https://bugs.gnu.org/48368>. + (and (eq? (identity repo) 'melpa) + (package-name->melpa-recipe (elpa-package-name pkg)))) (define name (elpa-package-name pkg)) @@ -387,7 +389,7 @@ type '<elpa-package>'." '()) (home-page ,(elpa-package-home-page pkg)) (synopsis ,(elpa-package-synopsis pkg)) - (description ,(elpa-package-description pkg)) + (description ,(beautify-description (elpa-package-description pkg))) (license ,license)) dependencies-names)) @@ -411,13 +413,17 @@ type '<elpa-package>'." ;;; Updates. ;;; +(define (guix-package->elpa-name package) + "Given a Guix package, PACKAGE, return the upstream name on ELPA." + (or (and=> (package-properties package) + (cut assq-ref <> 'upstream-name)) + (if (string-prefix? "emacs-" (package-name package)) + (string-drop (package-name package) 6) + (package-name package)))) + (define (latest-release package) "Return an <upstream-release> for the latest release of PACKAGE." - (define name - (if (string-prefix? "emacs-" (package-name package)) - (string-drop (package-name package) 6) - (package-name package))) - + (define name (guix-package->elpa-name package)) (define repo 'gnu) (match (elpa-package-info name repo) diff --git a/guix/import/git.scm b/guix/import/git.scm new file mode 100644 index 0000000000..1eb219f3fe --- /dev/null +++ b/guix/import/git.scm @@ -0,0 +1,225 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> +;;; +;;; 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 git) + #:use-module (guix build utils) + #:use-module (guix diagnostics) + #:use-module (guix git) + #:use-module (guix git-download) + #:use-module (guix i18n) + #:use-module (guix packages) + #:use-module (guix upstream) + #:use-module (guix utils) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:export (%generic-git-updater + + ;; For tests. + latest-git-tag-version)) + +;;; Commentary: +;;; +;;; This module provides a generic package updater for packages hosted on Git +;;; repositories. +;;; +;;; It tries to be smart about tag names, but if it is not automatically able +;;; to parse the tag names correctly, users can set the `release-tag-prefix', +;;; `release-tag-suffix' and `release-tag-version-delimiter' properties of the +;;; package to make the updater parse the Git tag name correctly. +;;; +;;; Possible improvements: +;;; +;;; * More robust method for trying to guess the delimiter. Maybe look at the +;;; previous version/tag combo to determine the delimiter. +;;; +;;; * Differentiate between "normal" versions, e.g., 1.2.3, and dates, e.g., +;;; 2021.12.31. Honor a `release-tag-date-scheme?' property? +;;; +;;; Code: + +;;; Errors & warnings + +(define-condition-type &git-no-valid-tags-error &error + git-no-valid-tags-error?) + +(define (git-no-valid-tags-error) + (raise (condition (&message (message "no valid tags found")) + (&git-no-valid-tags-error)))) + +(define-condition-type &git-no-tags-error &error + git-no-tags-error?) + +(define (git-no-tags-error) + (raise (condition (&message (message "no tags were found")) + (&git-no-tags-error)))) + + +;;; Updater + +(define %pre-release-words + '("alpha" "beta" "rc" "dev" "test" "pre")) + +(define %pre-release-rx + (map (lambda (word) + (make-regexp (string-append ".+" word) regexp/icase)) + %pre-release-words)) + +(define* (version-mapping tags #:key prefix suffix delim pre-releases?) + "Given a list of Git TAGS, return an association list where the car is the +version corresponding to the tag, and the cdr is the name of the tag." + (define (guess-delimiter) + (let ((total (length tags)) + (dots (reduce + 0 (map (cut string-count <> #\.) tags))) + (dashes (reduce + 0 (map (cut string-count <> #\-) tags))) + (underscores (reduce + 0 (map (cut string-count <> #\_) tags)))) + (cond + ((>= dots (* total 0.35)) ".") + ((>= dashes (* total 0.8)) "-") + ((>= underscores (* total 0.8)) "_") + (else "")))) + + (define delim-rx (regexp-quote (or delim (guess-delimiter)))) + (define suffix-rx (string-append (or suffix "") "$")) + (define prefix-rx (string-append "^" (or prefix "[^[:digit:]]*"))) + (define pre-release-rx + (if pre-releases? + (string-append "(.*(" (string-join %pre-release-words "|") ").*)") + "")) + + (define tag-rx + (string-append prefix-rx "([[:digit:]][^" delim-rx "[:punct:]]*" + "(" delim-rx "[^[:punct:]" delim-rx "]+)" + ;; If there are no delimiters, it could mean that the + ;; version just contains one number (e.g., "2"), thus, use + ;; "*" instead of "+" to match zero or more numbers. + (if (string=? delim-rx "") "*" "+") ")" + ;; We don't want the pre-release stuff (e.g., "-alpha") be + ;; part of the first group; otherwise, the "-" in "-alpha" + ;; might be interpreted as a delimiter, and thus replaced + ;; with "." + pre-release-rx suffix-rx)) + + + + (define (get-version tag) + (let ((tag-match (regexp-exec (make-regexp tag-rx) tag))) + (and=> (and tag-match + (regexp-substitute/global + #f delim-rx (match:substring tag-match 1) + ;; If there were no delimiters, don't insert ".". + 'pre (if (string=? delim-rx "") "" ".") 'post)) + (lambda (version) + (if pre-releases? + (string-append version (match:substring tag-match 3)) + version))))) + + (define (entry<? a b) + (eq? (version-compare (car a) (car b)) '<)) + + (stable-sort (filter-map (lambda (tag) + (let ((version (get-version tag))) + (and version (cons version tag)))) + tags) + entry<?)) + +(define* (latest-tag url #:key prefix suffix delim pre-releases?) + "Return the latest version and corresponding tag available from the Git +repository at URL." + (define (pre-release? tag) + (any (cut regexp-exec <> tag) + %pre-release-rx)) + + (let* ((tags (map (cut string-drop <> (string-length "refs/tags/")) + (remote-refs url #:tags? #t))) + (versions->tags + (version-mapping (if pre-releases? + tags + (filter (negate pre-release?) tags)) + #:prefix prefix + #:suffix suffix + #:delim delim + #:pre-releases? pre-releases?))) + (cond + ((null? tags) + (git-no-tags-error)) + ((null? versions->tags) + (git-no-valid-tags-error)) + (else + (match (last versions->tags) + ((version . tag) + (values version tag))))))) + +(define (latest-git-tag-version package) + "Given a PACKAGE, return the latest version of it, or #f if the latest version +could not be determined." + (guard (c ((or (git-no-tags-error? c) (git-no-valid-tags-error? c)) + (warning (or (package-field-location package 'source) + (package-location package)) + (G_ "~a for ~a~%") + (condition-message c) + (package-name package)) + #f) + ((eq? (exception-kind c) 'git-error) + (warning (or (package-field-location package 'source) + (package-location package)) + (G_ "failed to fetch Git repository for ~a~%") + (package-name package)) + #f)) + (let* ((source (package-source package)) + (url (git-reference-url (origin-uri source))) + (property (cute assq-ref (package-properties package) <>))) + (latest-tag url + #:prefix (property 'release-tag-prefix) + #:suffix (property 'release-tag-suffix) + #:delim (property 'release-tag-version-delimiter) + #:pre-releases? (property 'accept-pre-releases?))))) + +(define (git-package? package) + "Return true if PACKAGE is hosted on a Git repository." + (match (package-source package) + ((? origin? origin) + (and (eq? (origin-method origin) git-fetch) + (git-reference? (origin-uri origin)))) + (_ #f))) + +(define (latest-git-release package) + "Return an <upstream-source> for the latest release of PACKAGE." + (let* ((name (package-name package)) + (old-version (package-version package)) + (url (git-reference-url (origin-uri (package-source package)))) + (new-version (latest-git-tag-version package))) + + (and new-version + (upstream-source + (package name) + (version new-version) + (urls (list url)))))) + +(define %generic-git-updater + (upstream-updater + (name 'generic-git) + (description "Updater for packages hosted on Git repositories") + (pred git-package?) + (latest latest-git-release))) diff --git a/guix/import/gnu.scm b/guix/import/gnu.scm index 51d5b77d34..2b9b71feb0 100644 --- a/guix/import/gnu.scm +++ b/guix/import/gnu.scm @@ -100,7 +100,8 @@ download policy (see 'download-tarball' for details.)" (file-sha256 tarball)))))) (build-system gnu-build-system) (synopsis ,(gnu-package-doc-summary package)) - (description ,(gnu-package-doc-description package)) + (description ,(beautify-description + (gnu-package-doc-description package))) (home-page ,(match (gnu-package-doc-urls package) ((head . tail) (qualified-url head)))) (license find-by-yourself!))) diff --git a/guix/import/go.scm b/guix/import/go.scm index c6ecdbaffd..26dbc34b63 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -474,13 +474,13 @@ Optionally include a VERSION string to append to the name." because goproxy servers don't currently provide all the information needed to build a package." (define (go-import->module-meta content-text) - (match (string-split content-text #\space) + (match (string-tokenize content-text char-set:graphic) ((root-path vcs repo-url) (make-module-meta root-path (string->symbol vcs) (strip-.git-suffix/maybe repo-url))))) ;; <meta name="go-import" content="import-prefix vcs repo-root"> (let* ((meta-data (http-fetch* (format #f "https://~a?go-get=1" module-path))) - (select (sxpath `(// head (meta (@ (equal? (name "go-import")))) + (select (sxpath `(// (meta (@ (equal? (name "go-import")))) // content)))) (match (select (html->sxml meta-data #:strict? #t)) (() #f) ;nothing selected @@ -612,6 +612,8 @@ hint: use one of the following available versions ~a\n" (dependencies (if pin-versions? dependencies+versions (map car dependencies+versions))) + (module-path-sans-suffix + (match:prefix (string-match "([\\./]v[0-9]+)?$" module-path))) (guix-name (go-module->guix-package-name module-path)) (root-module-path (module-path->repository-root module-path)) ;; The VCS type and URL are not included in goproxy information. For @@ -619,7 +621,7 @@ hint: use one of the following available versions ~a\n" (meta-data (fetch-module-meta-data root-module-path)) (vcs-type (module-meta-vcs meta-data)) (vcs-repo-url (module-meta-data-repo-url meta-data goproxy)) - (synopsis (go-package-synopsis root-module-path)) + (synopsis (go-package-synopsis module-path)) (description (go-package-description module-path)) (licenses (go-package-licenses module-path))) (values @@ -630,7 +632,10 @@ hint: use one of the following available versions ~a\n" ,(vcs->origin vcs-type vcs-repo-url version*)) (build-system go-build-system) (arguments - '(#:import-path ,root-module-path)) + '(#:import-path ,module-path + ,@(if (string=? module-path-sans-suffix root-module-path) + '() + `(#:unpack-path ,root-module-path)))) ,@(maybe-propagated-inputs (map (match-lambda ((name version) diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 7c6d9d0a22..b94f4169d4 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -33,7 +33,7 @@ #:use-module ((guix utils) #:select (package-name->name+version canonical-newline-port)) #:use-module (guix http-client) - #:use-module ((guix import utils) #:select (factorize-uri recursive-import)) + #:use-module (guix import utils) #:use-module (guix import cabal) #:use-module (guix store) #:use-module (gcrypt hash) @@ -41,6 +41,7 @@ #:use-module (guix memoization) #:use-module (guix upstream) #:use-module (guix packages) + #:autoload (guix build-system haskell) (hackage-uri) #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:export (%hackage-url hackage->guix-package @@ -55,8 +56,8 @@ hackage-package?)) (define ghc-standard-libraries - ;; List of libraries distributed with ghc (8.6.5). - ;; Contents of ...-ghc-8.6.5/lib/ghc-8.6.5. + ;; List of libraries distributed with ghc (as of 8.10.7). + ;; Contents of …-ghc-8.10.7/lib/ghc-8.10.7 '("ghc" "cabal" ;; in the output of `ghc-pkg list` Cabal is uppercased, but ;; hackage-name->package-name takes this into account. @@ -68,6 +69,7 @@ "containers" "deepseq" "directory" + "exceptions" "filepath" "ghc" "ghc-boot" @@ -121,12 +123,12 @@ version is returned." (string-append package-name-prefix (string-downcase name)))) (define guix-package->hackage-name - (let ((uri-rx (make-regexp "https?://hackage.haskell.org/package/([^/]+)/.*")) + (let ((uri-rx (make-regexp "(https?://hackage.haskell.org|mirror://hackage)/package/([^/]+)/.*")) (name-rx (make-regexp "(.*)-[0-9\\.]+"))) (lambda (package) "Given a Guix package name, return the corresponding Hackage name." (let* ((source-url (and=> (package-source package) origin-uri)) - (name (match:substring (regexp-exec uri-rx source-url) 1))) + (name (match:substring (regexp-exec uri-rx source-url) 2))) (match (regexp-exec name-rx name) (#f name) (m (match:substring m 1))))))) @@ -301,7 +303,7 @@ the hash of the Cabal file." (version ,version) (source (origin (method url-fetch) - (uri (string-append ,@(factorize-uri source-url version))) + (uri (hackage-uri ,name version)) (sha256 (base32 ,(if tarball @@ -313,7 +315,7 @@ the hash of the Cabal file." ,@(maybe-arguments) (home-page ,(cabal-package-home-page cabal)) (synopsis ,(cabal-package-synopsis cabal)) - (description ,(cabal-package-description cabal)) + (description ,(beautify-description (cabal-package-description cabal))) (license ,(string->license (cabal-package-license cabal)))) (append hackage-dependencies hackage-native-dependencies)))) @@ -351,7 +353,7 @@ respectively." #:guix-name hackage-name->package-name)) (define hackage-package? - (let ((hackage-rx (make-regexp "https?://hackage.haskell.org"))) + (let ((hackage-rx (make-regexp "(https?://hackage.haskell.org|mirror://hackage/)"))) (url-predicate (cut regexp-exec hackage-rx <>)))) (define (latest-release package) @@ -365,7 +367,7 @@ respectively." (hackage-cabal-url hackage-name)) #f) ((_ *** ("version" (version))) - (let ((url (hackage-source-url hackage-name version))) + (let ((url (hackage-uri hackage-name version))) (upstream-source (package (package-name package)) (version version) diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm index e1f8487b75..abddd885ee 100644 --- a/guix/import/minetest.scm +++ b/guix/import/minetest.scm @@ -25,6 +25,8 @@ #:use-module (srfi srfi-2) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module ((guix packages) #:prefix package:) + #:use-module (guix upstream) #:use-module (guix utils) #:use-module (guix ui) #:use-module (guix i18n) @@ -36,15 +38,19 @@ #:use-module (json) #:use-module (guix base32) #:use-module (guix git) + #:use-module ((guix git-download) #:prefix download:) #:use-module (guix store) #:export (%default-sort-key %contentdb-api json->package contentdb-fetch elaborate-contentdb-name + minetest-package? + latest-minetest-release minetest->guix-package minetest-recursive-import - sort-packages)) + sort-packages + %minetest-updater)) ;; The ContentDB API is documented at ;; <https://content.minetest.net>. @@ -203,7 +209,7 @@ raise an exception." (match correctly-named ((one) (package-keys-full-name one)) ((too . many) - (warning (G_ "~a is ambigious, presuming ~a (other options include: ~a)~%") + (warning (G_ "~a is ambiguous, presuming ~a (other options include: ~a)~%") name (package-keys-full-name too) (map package-keys-full-name many)) (package-keys-full-name too)) @@ -256,7 +262,7 @@ and possibly some other packages as well, or #f on failure." (order "desc")) "Search ContentDB for Q (a string). Sort by SORT, in ascending order if ORDER is \"asc\" or descending order if ORDER is \"desc\". TYPE must -be \"mod\", \"game\" or \"txp\", restricting thes search results to +be \"mod\", \"game\" or \"txp\", restricting the search results to respectively mods, games and texture packs. Limit to at most LIMIT results. The return value is a list of <package-keys> records." ;; XXX does Guile have something for constructing (and, when necessary, @@ -316,7 +322,7 @@ MEDIA-LICENSE and LICENSE." ,@(maybe-propagated-inputs (map contentdb->package-name inputs)) (home-page ,home-page) (synopsis ,(delete-cr synopsis)) - (description ,(delete-cr description)) + (description ,(beautify-description (delete-cr description))) (license ,(if (eq? media-license license) license `(list ,media-license ,license))) @@ -337,6 +343,25 @@ official Minetest forum and the Git repository (if any)." (and=> (package-forums package) topic->url-sexp) (package-repository package))) +(define (release-version release) + "Guess the version of RELEASE from the release title." + (define title (release-title release)) + (if (string-prefix? "v" title) + ;; Remove "v" prefix from release titles like ‘v1.0.1’. + (substring title 1) + title)) + +(define (version-style version) + "Determine the kind of version number VERSION is -- a date, or a conventional +conventional version number." + (define dots? (->bool (string-index version #\.))) + (define hyphens? (->bool (string-index version #\-))) + (match (cons dots? hyphens?) + ((#true . #false) 'regular) ; something like "0.1" + ((#false . #false) 'regular) ; single component version number + ((#true . #true) 'regular) ; result of 'git-version' + ((#false . #true) 'date))) ; something like "2021-01-25" + ;; If the default sort key is changed, make sure to modify 'show-help' ;; in (guix scripts import minetest) appropriately as well. (define %default-sort-key "score") @@ -371,7 +396,11 @@ official Minetest forum and the Git repository (if any)." DEPENDENCIES as a list of AUTHOR/NAME strings." (define dependency-list (assoc-ref dependencies author/name)) - (filter-map + ;; A mod can have multiple dependencies implemented by the same mod, + ;; so remove duplicate mod names. + (define (filter-deduplicate-map f list) + (delete-duplicates (filter-map f list))) + (filter-deduplicate-map (lambda (dependency) (and (not (dependency-optional? dependency)) (not (builtin-mod? (dependency-name dependency))) @@ -432,7 +461,7 @@ list of AUTHOR/NAME strings." (define important-upstream-dependencies (important-dependencies dependencies author/name #:sort sort)) (values (make-minetest-sexp author/name - (release-title release) ; version + (release-version release) (package-repository package) (release-commit release) important-upstream-dependencies @@ -454,3 +483,37 @@ list of AUTHOR/NAME strings." (recursive-import author/name #:repo->guix-package minetest->guix-package* #:guix-name contentdb->package-name)) + +(define (minetest-package? pkg) + "Is PKG a Minetest mod on ContentDB?" + (and (string-prefix? "minetest-" (package:package-name pkg)) + (assq-ref (package:package-properties pkg) 'upstream-name))) + +(define (latest-minetest-release pkg) + "Return an <upstream-source> for the latest release of the package PKG, +or #false if the latest release couldn't be determined." + (define author/name + (assq-ref (package:package-properties pkg) 'upstream-name)) + (define contentdb-package (contentdb-fetch author/name)) ; TODO warn if #f? + (define release (latest-release author/name)) + (define source (package:package-source pkg)) + (and contentdb-package release + (release-commit release) ; not always set + ;; Only continue if both the old and new version number are both + ;; dates or regular version numbers, as two different styles confuses + ;; the logic for determining which version is newer. + (eq? (version-style (release-version release)) + (version-style (package:package-version pkg))) + (upstream-source + (package (package:package-name pkg)) + (version (release-version release)) + (urls (list (download:git-reference + (url (package-repository contentdb-package)) + (commit (release-commit release)))))))) + +(define %minetest-updater + (upstream-updater + (name 'minetest) + (description "Updater for Minetest packages on ContentDB") + (pred minetest-package?) + (latest latest-minetest-release))) diff --git a/guix/import/opam.scm b/guix/import/opam.scm index f8402ff5ba..a6f6fe8c9f 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -231,7 +231,8 @@ path to the repository." (('list-pat . stuff) stuff) (('string-pat stuff) stuff) (('multiline-string stuff) stuff) - (('dict records ...) records)) + (('dict records ...) records) + (_ #f)) acc)))) #f file)) @@ -317,7 +318,7 @@ path to the repository." (_ others))) #f (filter-map get-opam-repository repositories-specs)) - (leave (G_ "package '~a' not found~%") name))) + (warning (G_ "opam: package '~a' not found~%") name))) (define* (opam->guix-package name #:key (repo 'opam) version) "Import OPAM package NAME from REPOSITORY (a directory name) or, if @@ -370,7 +371,8 @@ or #f on failure." ,(list 'quasiquote `((upstream-name . ,name)))))) (home-page ,(metadata-ref opam-content "homepage")) (synopsis ,(metadata-ref opam-content "synopsis")) - (description ,(metadata-ref opam-content "description")) + (description ,(beautify-description + (metadata-ref opam-content "description"))) (license ,(spdx-string->license (metadata-ref opam-content "license")))) (filter diff --git a/guix/import/print.scm b/guix/import/print.scm index c1739f35e3..66016145cb 100644 --- a/guix/import/print.scm +++ b/guix/import/print.scm @@ -26,6 +26,7 @@ #:use-module (guix build-system) #:use-module (gnu packages) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (guix import utils) #:use-module (ice-9 control) #:use-module (ice-9 match) @@ -39,9 +40,6 @@ (_ #f)) inputs)) -;; FIXME: the quasiquoted arguments field may contain embedded package -;; objects, e.g. in #:disallowed-references; they will just be printed with -;; their usual #<package ...> representation, not as variable names. (define (package->code package) "Return an S-expression representing the source code that produces PACKAGE when evaluated." @@ -81,6 +79,11 @@ when evaluated." (file-type (quote ,(search-path-specification-file-type spec))) (file-pattern ,(search-path-specification-file-pattern spec)))) + (define (factorized-uri-code uri version) + (match (factorize-uri uri version) + ((? string? uri) uri) + ((factorized ...) `(string-append ,@factorized)))) + (define (source->code source version) (let ((uri (origin-uri source)) (method (origin-method source)) @@ -98,9 +101,14 @@ when evaluated." (guix hg-download) (guix svn-download))) (procedure-name method))) - (uri (string-append ,@(match (factorize-uri uri version) - ((? string? uri) (list uri)) - (factorized factorized)))) + (uri ,(if version + (match uri + ((? string? uri) + (factorized-uri-code uri version)) + ((lst ...) + `(list + ,@(map (cut factorized-uri-code <> version) uri)))) + uri)) ,(if (equal? (content-hash-algorithm hash) 'sha256) `(sha256 (base32 ,(bytevector->nix-base32-string (content-hash-value hash)))) @@ -110,36 +118,62 @@ when evaluated." ;; FIXME: in order to be able to throw away the directory prefix, ;; we just assume that the patch files can be found with ;; "search-patches". - ,@(if (null? patches) '() - `((patches (search-patches ,@(map basename patches)))))))) + ,@(cond ((null? patches) + '()) + ((every string? patches) + `((patches (search-patches ,@(map basename patches))))) + (else + `((patches (list ,@(map (match-lambda + ((? string? file) + `(search-patch ,file)) + ((? origin? origin) + (source->code origin #f))) + patches))))))))) + + (define (variable-reference module name) + ;; FIXME: using '@ certainly isn't pretty, but it avoids having to import + ;; the individual package modules. + (list '@ module name)) + + (define (object->code obj quoted?) + (match obj + ((? package? package) + (let* ((module (package-module-name package)) + (name (variable-name package module))) + (if quoted? + (list 'unquote (variable-reference module name)) + (variable-reference module name)))) + ((? origin? origin) + (let ((code (source->code origin #f))) + (if quoted? + (list 'unquote code) + code))) + ((lst ...) + (let ((lst (map (cut object->code <> #t) lst))) + (if quoted? + lst + (list 'quasiquote lst)))) + (obj + obj))) (define (inputs->code inputs) (if (redundant-input-labels? inputs) `(list ,@(map (match-lambda ;no need for input labels ("new style") ((_ package) - (let ((module (package-module-name package))) - `(@ ,module ,(variable-name package module)))) + (let* ((module (package-module-name package)) + (name (variable-name package module))) + (variable-reference module name))) ((_ package output) - (let ((module (package-module-name package))) + (let* ((module (package-module-name package)) + (name (variable-name package module))) (list 'quasiquote (list (list 'unquote - `(@ ,module - ,(variable-name package module))) + (variable-reference module name)) output))))) inputs)) (list 'quasiquote ;preserve input labels (deprecated) - (map (match-lambda - ((label pkg . out) - (let ((mod (package-module-name pkg))) - (cons* label - ;; FIXME: using '@ certainly isn't pretty, but it - ;; avoids having to import the individual package - ;; modules. - (list 'unquote - (list '@ mod (variable-name pkg mod))) - out)))) - inputs)))) + (object->code inputs #t)))) (let ((name (package-name package)) (version (package-version package)) @@ -175,7 +209,8 @@ when evaluated." '-build-system))) ,@(match arguments (() '()) - (args `((arguments ,(list 'quasiquote args))))) + (_ `((arguments + ,(list 'quasiquote (object->code arguments #t)))))) ,@(match outputs (("out") '()) (outs `((outputs (list ,@outs))))) diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index f3619dcd9e..b4284f5c33 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -9,6 +9,8 @@ ;;; Copyright © 2020 Lars-Dominik Braun <ldb@leibniz-psychology.org> ;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Marius Bakke <marius@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -112,7 +114,7 @@ (url distribution-url) ;string (digests distribution-digests) ;list of string pairs (file-name distribution-file-name "filename") ;string - (has-signature? distribution-has-signature? "hash_sig") ;Boolean + (has-signature? distribution-has-signature? "has_sig") ;Boolean (package-type distribution-package-type "packagetype") ;"bdist_wheel" | ... (python-version distribution-package-python-version "python_version")) @@ -127,27 +129,30 @@ missing-source-error? (package missing-source-error-package)) -(define (latest-source-release pypi-package) - "Return the latest source release for PYPI-PACKAGE." - (let ((releases (assoc-ref (pypi-project-releases pypi-package) - (project-info-version - (pypi-project-info pypi-package))))) +(define (latest-version project) + "Return the latest version of PROJECT, a <pypi-project> record." + (project-info-version (pypi-project-info project))) + +(define* (source-release pypi-package + #:optional (version (latest-version pypi-package))) + "Return the source release of VERSION for PYPI-PACKAGE, a <pypi-project> +record, by default the latest version." + (let ((releases (or (assoc-ref (pypi-project-releases pypi-package) version) + '()))) (or (find (lambda (release) (string=? "sdist" (distribution-package-type release))) releases) (raise (condition (&missing-source-error (package pypi-package))))))) -(define (latest-wheel-release pypi-package) +(define* (wheel-release pypi-package + #:optional (version (latest-version pypi-package))) "Return the url of the wheel for the latest release of pypi-package, or #f if there isn't any." - (let ((releases (assoc-ref (pypi-project-releases pypi-package) - (project-info-version - (pypi-project-info pypi-package))))) - (or (find (lambda (release) - (string=? "bdist_wheel" (distribution-package-type release))) - releases) - #f))) + (let ((releases (assoc-ref (pypi-project-releases pypi-package) version))) + (find (lambda (release) + (string=? "bdist_wheel" (distribution-package-type release))) + releases))) (define (python->package-name name) "Given the NAME of a package on PyPI, return a Guix-compliant name for the @@ -163,12 +168,13 @@ package on PyPI." (hyphen-package-name->name+version (basename (file-sans-extension url)))) - (match (and=> (package-source package) origin-uri) - ((? string? url) - (url->pypi-name url)) - ((lst ...) - (any url->pypi-name lst)) - (#f #f))) + (or (assoc-ref (package-properties package) 'upstream-name) + (match (and=> (package-source package) origin-uri) + ((? string? url) + (url->pypi-name url)) + ((lst ...) + (any url->pypi-name lst)) + (#f #f)))) (define (wheel-url->extracted-directory wheel-url) (match (string-split (basename wheel-url) #\-) @@ -416,6 +422,11 @@ return the unaltered list of upstream dependency names." description license) "Return the `package' s-expression for a python package with the given NAME, VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." + (define (maybe-upstream-name name) + (if (string-match ".*\\-[0-9]+" name) + `((properties ,`'(("upstream-name" . ,name)))) + '())) + (call-with-temporary-output-file (lambda (temp port) (and (url-fetch source-url temp) @@ -454,12 +465,13 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (sha256 (base32 ,(guix-hash-url temp))))) + ,@(maybe-upstream-name name) (build-system python-build-system) ,@(maybe-inputs required-inputs 'propagated-inputs) ,@(maybe-inputs native-inputs 'native-inputs) (home-page ,home-page) (synopsis ,synopsis) - (description ,description) + (description ,(beautify-description description)) (license ,(license->symbol license))) upstream-dependencies)))))))) @@ -469,18 +481,17 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." "Fetch the metadata for PACKAGE-NAME from pypi.org, and return the `package' s-expression corresponding to that package, or #f on failure." (let* ((project (pypi-fetch package-name)) - (info (and project (pypi-project-info project)))) + (info (and=> project pypi-project-info)) + (version (or version (and=> project latest-version)))) (and project (guard (c ((missing-source-error? c) (let ((package (missing-source-error-package c))) (leave (G_ "no source release for pypi package ~a ~a~%") - (project-info-name info) - (project-info-version info))))) - (make-pypi-sexp (project-info-name info) - (project-info-version info) - (and=> (latest-source-release project) + (project-info-name info) version)))) + (make-pypi-sexp (project-info-name info) version + (and=> (source-release project version) distribution-url) - (and=> (latest-wheel-release project) + (and=> (wheel-release project version) distribution-url) (project-info-home-page info) (project-info-summary info) @@ -488,8 +499,9 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (string->license (project-info-license info))))))))) -(define (pypi-recursive-import package-name) +(define* (pypi-recursive-import package-name #:optional version) (recursive-import package-name + #:version version #:repo->guix-package pypi->guix-package #:guix-name python->package-name)) @@ -522,12 +534,19 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (guard (c ((missing-source-error? c) #f)) (let* ((info (pypi-project-info pypi-package)) (version (project-info-version info)) - (url (distribution-url - (latest-source-release pypi-package)))) + (dist (source-release pypi-package)) + (url (distribution-url dist))) (upstream-source + (urls (list url)) + (signature-urls + (if (distribution-has-signature? dist) + (list (string-append url ".asc")) + #f)) + (input-changes + (changed-inputs package + (pypi->guix-package pypi-name))) (package (package-name package)) - (version version) - (urls (list url)))))))) + (version version))))))) (define %pypi-updater (upstream-updater diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index bbd903a2cd..49be982a7f 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -2,6 +2,8 @@ ;;; Copyright © 2017 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> +;;; Copyright © 2021 Xinglu Chem <public@yoctocell.xyz> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,9 +22,8 @@ (define-module (guix import stackage) #:use-module (ice-9 match) - #:use-module (ice-9 regex) + #:use-module (json) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (guix import json) @@ -31,6 +32,8 @@ #:use-module (guix memoization) #:use-module (guix packages) #:use-module (guix upstream) + #:use-module (guix diagnostics) + #:use-module (guix i18n) #:export (%stackage-url stackage->guix-package stackage-recursive-import @@ -44,15 +47,31 @@ (define %stackage-url (make-parameter "https://www.stackage.org")) -;; Latest LTS version compatible with GHC 8.6.5. -(define %default-lts-version "14.27") - -(define (lts-info-packages lts-info) - "Returns the alist of packages contained in LTS-INFO." - (or (assoc-ref lts-info "packages") '())) - -(define (leave-with-message fmt . args) - (raise (condition (&message (message (apply format #f fmt args)))))) +;; Latest LTS version compatible with current GHC. +(define %default-lts-version "18.14") + +(define-json-mapping <stackage-lts> make-stackage-lts + stackage-lts? + json->stackage-lts + (snapshot stackage-lts-snapshot "snapshot" json->snapshot) + (packages stackage-lts-packages "packages" + (lambda (vector) + (map json->stackage-package (vector->list vector))))) + +(define-json-mapping <snapshot> make-snapshot + stackage-snapshot? + json->snapshot + (name snapshot-name) + (ghc-version snapshot-ghc-version) + (compiler snapshot-compiler)) + +(define-json-mapping <stackage-package> make-stackage-package + stackage-package? + json->stackage-package + (origin stackage-package-origin) + (name stackage-package-name) + (version stackage-package-version) + (synopsis stackage-package-synopsis)) (define stackage-lts-info-fetch ;; "Retrieve the information about the LTS Stackage release VERSION." @@ -62,21 +81,15 @@ "/lts-" (if (string-null? version) %default-lts-version version))) - (lts-info (json-fetch url))) - (if lts-info - (reverse lts-info) - (leave-with-message "LTS release version not found: ~a" version)))))) - -(define (stackage-package-name pkg-info) - (assoc-ref pkg-info "name")) - -(define (stackage-package-version pkg-info) - (assoc-ref pkg-info "version")) + (lts-info (and=> (json-fetch url) json->stackage-lts))) + (or lts-info + (raise (formatted-message (G_ "LTS release version not found: ~a") + version))))))) -(define (lts-package-version pkgs-info name) - "Return the version of the package with upstream NAME included in PKGS-INFO." +(define (lts-package-version packages name) + "Return the version of the package with upstream NAME included in PACKAGES." (let ((pkg (find (lambda (pkg) (string=? (stackage-package-name pkg) name)) - (vector->list pkgs-info)))) + packages))) (stackage-package-version pkg))) @@ -93,21 +106,22 @@ #:key (include-test-dependencies? #t) (lts-version %default-lts-version) - (packages-info - (lts-info-packages + (packages + (stackage-lts-packages (stackage-lts-info-fetch lts-version)))) "Fetch Cabal file for PACKAGE-NAME from hackage.haskell.org. The retrieved version corresponds to the version of PACKAGE-NAME specified in the LTS-VERSION release at stackage.org. Return the `package' S-expression corresponding to that package, or #f on failure. PACKAGES-INFO is the alist with the packages included in the Stackage LTS release." - (let* ((version (lts-package-version packages-info package-name)) + (let* ((version (lts-package-version packages package-name)) (name-version (hackage-name-version package-name version))) (if name-version (hackage->guix-package name-version #:include-test-dependencies? include-test-dependencies?) - (leave-with-message "~a: Stackage package not found" package-name)))))) + (raise (formatted-message (G_ "~a: Stackage package not found") + package-name))))))) (define (stackage-recursive-import package-name . args) (recursive-import package-name @@ -121,31 +135,46 @@ included in the Stackage LTS release." ;;; (define latest-lts-release - (let ((pkgs-info - (mlambda () (lts-info-packages - (stackage-lts-info-fetch %default-lts-version))))) - (lambda* (package) + (let ((packages + (mlambda () + (stackage-lts-packages + (stackage-lts-info-fetch %default-lts-version))))) + (lambda* (pkg) "Return an <upstream-source> for the latest Stackage LTS release of PACKAGE or #f if the package is not included in the Stackage LTS release." - (let* ((hackage-name (guix-package->hackage-name package)) - (version (lts-package-version (pkgs-info) hackage-name)) + (let* ((hackage-name (guix-package->hackage-name pkg)) + (version (lts-package-version (packages) hackage-name)) (name-version (hackage-name-version hackage-name version))) (match (and=> name-version hackage-fetch) - (#f (format (current-error-port) - "warning: failed to parse ~a~%" - (hackage-cabal-url hackage-name)) - #f) + (#f + (warning (G_ "failed to parse ~a~%") + (hackage-cabal-url hackage-name)) + #f) (_ (let ((url (hackage-source-url hackage-name version))) (upstream-source - (package (package-name package)) + (package (package-name pkg)) (version version) - (urls (list url)))))))))) + (urls (list url)) + (input-changes + (changed-inputs + pkg + (stackage->guix-package hackage-name #:packages (packages)))))))))))) + +(define (stackage-lts-package? package) + "Return whether PACKAGE is available on the default Stackage LTS release." + (and (hackage-package? package) + (let ((packages (stackage-lts-packages + (stackage-lts-info-fetch %default-lts-version))) + (hackage-name (guix-package->hackage-name package))) + (find (lambda (package) + (string=? (stackage-package-name package) hackage-name)) + packages)))) (define %stackage-updater (upstream-updater (name 'stackage) (description "Updater for Stackage LTS packages") - (pred hackage-package?) + (pred stackage-lts-package?) (latest latest-lts-release))) ;;; stackage.scm ends here diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm index 18d8b95ee0..bdef9f58b0 100644 --- a/guix/import/texlive.scm +++ b/guix/import/texlive.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017, 2021 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -19,18 +19,16 @@ (define-module (guix import texlive) #:use-module (ice-9 match) - #:use-module (sxml simple) - #:use-module (sxml xpath) - #:use-module (srfi srfi-11) + #:use-module (ice-9 rdelim) #: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 (web uri) - #:use-module (guix diagnostics) - #:use-module (guix i18n) - #:use-module (guix http-client) #:use-module (gcrypt hash) + #:use-module (guix derivations) #:use-module (guix memoization) + #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix base32) #:use-module (guix serialization) @@ -39,24 +37,15 @@ #:use-module (guix utils) #:use-module (guix upstream) #:use-module (guix packages) - #:use-module (gnu packages) #:use-module (guix build-system texlive) #:export (texlive->guix-package - - fetch-sxml - sxml->package)) + texlive-recursive-import)) ;;; Commentary: ;;; -;;; Generate a package declaration template for the latest version of a -;;; package on CTAN, using the XML output produced by the XML API to the CTAN -;;; database at http://www.ctan.org/xml/1.2/ -;;; -;;; Instead of taking the packages from CTAN, however, we fetch the sources -;;; from the SVN repository of the Texlive project. We do this because CTAN -;;; only keeps a single version of each package whereas we can access any -;;; version via SVN. Unfortunately, this means that the importer is really -;;; just a Texlive importer, not a generic CTAN importer. +;;; Generate a package declaration template for corresponding package in the +;;; Tex Live Package Database (tlpdb). We fetch all sources from different +;;; locations in the SVN repository of the Texlive project. ;;; ;;; Code: @@ -79,6 +68,8 @@ ("bsd4" 'bsd-4) ("opl" 'opl1.0+) ("ofl" 'silofl1.1) + + ("lpplgpl" `(list lppl gpl1+)) ("lppl" 'lppl) ("lppl1" 'lppl1.0+) ; usually means "or later" ("lppl1.2" 'lppl1.2+) ; usually means "or later" @@ -107,91 +98,170 @@ ("cc-by-nc-nd-4" 'non-free) ((x) (string->license x)) ((lst ...) `(list ,@(map string->license lst))) - (_ #f))) - -(define (fetch-sxml name) - "Return an sxml representation of the package information contained in the -XML description of the CTAN package or #f in case of failure." - ;; This API always returns the latest release of the module. - (let ((url (string-append "http://www.ctan.org/xml/1.2/pkg/" name))) - (guard (c ((http-get-error? c) - (format (current-error-port) - "error: failed to retrieve package information \ -from ~s: ~a (~s)~%" - (uri->string (http-get-error-uri c)) - (http-get-error-code c) - (http-get-error-reason c)) - #f)) - (xml->sxml (http-fetch url) - #:trim-whitespace? #t)))) - -(define (guix-name component name) + (x `(error unknown-license ,x)))) + +(define (guix-name name) "Return a Guix package name for a given Texlive package NAME." - (string-append "texlive-" component "-" + (string-append "texlive-" (string-map (match-lambda (#\_ #\-) (#\. #\-) (chr (char-downcase chr))) name))) -(define* (sxml->package sxml #:optional (component "latex")) - "Return the `package' s-expression for a Texlive package from the SXML -expression describing it." - (define (sxml-value path) - (match ((sxpath path) sxml) - (() #f) - ((val) val))) +(define (tlpdb-file) + (define texlive-bin + ;; Resolve this variable lazily so that (gnu packages ...) does not end up + ;; in the closure of this module. + (module-ref (resolve-interface '(gnu packages tex)) + 'texlive-bin)) + (with-store store - (let* ((id (sxml-value '(entry @ id *text*))) - (synopsis (sxml-value '(entry caption *text*))) - (version (or (sxml-value '(entry version @ number *text*)) - (sxml-value '(entry version @ date *text*)))) - (license (match ((sxpath '(entry license @ type *text*)) sxml) - ((license) (string->license license)) - ((lst ...) (map string->license lst)))) - (home-page (string-append "http://www.ctan.org/pkg/" id)) - (ref (texlive-ref component id)) - (checkout (download-svn-to-store store ref))) - (unless checkout - (warning (G_ "Could not determine source location. \ -Please manually specify the source field.~%"))) - `(package - (name ,(guix-name component id)) - (version ,version) - (source ,(if checkout - `(origin - (method svn-fetch) - (uri (texlive-ref ,component ,id)) - (sha256 - (base32 - ,(bytevector->nix-base32-string - (let-values (((port get-hash) (open-sha256-port))) - (write-file checkout port) - (force-output port) - (get-hash)))))) - #f)) - (build-system texlive-build-system) - (arguments ,`(,'quote (#:tex-directory ,(string-join (list component id) "/")))) - (home-page ,home-page) - (synopsis ,synopsis) - (description ,(string-trim-both - (string-join - (map string-trim-both - (string-split - (beautify-description - (sxml->string (or (sxml-value '(entry description)) - '()))) - #\newline))))) - (license ,(match license - ((lst ...) `(list ,@lst)) - (license license))))))) + (run-with-store store + (mlet* %store-monad + ((drv (lower-object texlive-bin)) + (built (built-derivations (list drv)))) + (match (derivation->output-paths drv) + (((names . items) ...) + (return (string-append (first items) + "/share/tlpkg/texlive.tlpdb")))))))) + +(define tlpdb + (memoize + (lambda () + (let ((file (tlpdb-file)) + (fields + '((name . string) + (shortdesc . string) + (longdesc . string) + (catalogue-license . string) + (catalogue-ctan . string) + (srcfiles . list) + (runfiles . list) + (docfiles . list) + (depend . simple-list))) + (record + (lambda* (key value alist #:optional (type 'string)) + (let ((new + (or (and=> (assoc-ref alist key) + (lambda (existing) + (cond + ((eq? type 'string) + (string-append existing " " value)) + ((or (eq? type 'list) (eq? type 'simple-list)) + (cons value existing))))) + (cond + ((eq? type 'string) + value) + ((or (eq? type 'list) (eq? type 'simple-list)) + (list value)))))) + (acons key new (alist-delete key alist)))))) + (call-with-input-file file + (lambda (port) + (let loop ((all (list)) + (current (list)) + (last-property #false)) + (let ((line (read-line port))) + (cond + ((eof-object? line) all) + + ;; End of record. + ((string-null? line) + (loop (cons (cons (assoc-ref current 'name) current) + all) + (list) #false)) + + ;; Continuation of a list + ((and (zero? (string-index line #\space)) last-property) + ;; Erase optional second part of list values like + ;; "details=Readme" for files + (let ((plain-value (first + (string-split + (string-trim-both line) #\space)))) + (loop all (record last-property + plain-value + current + 'list) + last-property))) + (else + (or (and-let* ((space (string-index line #\space)) + (key (string->symbol (string-take line space))) + (value (string-drop line (1+ space))) + (field-type (assoc-ref fields key))) + ;; Erase second part of list keys like "size=29" + (cond + ((eq? field-type 'list) + (loop all current key)) + (else + (loop all (record key value current field-type) key)))) + (loop all current #false)))))))))))) + +(define (files->directories files) + (map (cut string-join <> "/" 'suffix) + (delete-duplicates (map (lambda (file) + (drop-right (string-split file #\/) 1)) + files) + equal?))) + +(define (tlpdb->package name package-database) + (and-let* ((data (assoc-ref package-database name)) + (dirs (files->directories + (map (lambda (dir) + (string-drop dir (string-length "texmf-dist/"))) + (append (or (assoc-ref data 'docfiles) (list)) + (or (assoc-ref data 'runfiles) (list)) + (or (assoc-ref data 'srcfiles) (list)))))) + (name (guix-name name)) + (version (number->string %texlive-revision)) + (ref (svn-multi-reference + (url (string-append "svn://www.tug.org/texlive/tags/" + %texlive-tag "/Master/texmf-dist")) + (locations dirs) + (revision %texlive-revision))) + (source (with-store store + (download-multi-svn-to-store + store ref (string-append name "-svn-multi-checkout"))))) + (values + `(package + (inherit (simple-texlive-package + ,name + (list ,@dirs) + (base32 + ,(bytevector->nix-base32-string + (let-values (((port get-hash) (open-sha256-port))) + (write-file source port) + (force-output port) + (get-hash)))) + ,@(if (assoc-ref data 'srcfiles) '() '(#:trivial? #true)))) + ,@(or (and=> (assoc-ref data 'depend) + (lambda (inputs) + `((propagated-inputs + ,(map (lambda (tex-name) + (let ((name (guix-name tex-name))) + (list name (list 'unquote (string->symbol name))))) + inputs))))) + '()) + ,@(or (and=> (assoc-ref data 'catalogue-ctan) + (lambda (url) + `((home-page ,(string-append "https://ctan.org" url))))) + '((home-page "https://www.tug.org/texlive/"))) + (synopsis ,(assoc-ref data 'shortdesc)) + (description ,(beautify-description + (assoc-ref data 'longdesc))) + (license ,(string->license + (assoc-ref data 'catalogue-license)))) + (or (assoc-ref data 'depend) (list))))) (define texlive->guix-package (memoize - (lambda* (package-name #:optional (component "latex")) - "Fetch the metadata for PACKAGE-NAME from REPO and return the `package' + (lambda* (name #:key repo version (package-database tlpdb)) + "Find the metadata for NAME in the tlpdb and return the `package' s-expression corresponding to that package, or #f on failure." - (and=> (fetch-sxml package-name) - (cut sxml->package <> component))))) + (tlpdb->package name (package-database))))) + +(define (texlive-recursive-import name) + (recursive-import name + #:repo->guix-package texlive->guix-package + #:guix-name guix-name)) -;;; ctan.scm ends here +;;; texlive.scm ends here diff --git a/guix/import/utils.scm b/guix/import/utils.scm index a180742ca3..1c3cfa3e0b 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -9,6 +9,7 @@ ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; ;;; This file is part of GNU Guix. ;;; @@ -39,6 +40,7 @@ #:use-module (guix store) #:use-module (guix download) #:use-module (guix sets) + #:use-module (guix ui) #:use-module (gnu packages) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) @@ -152,6 +154,7 @@ of the string VERSION is replaced by the symbol 'version." ("CC0-1.0" 'license:cc0) ("CC-BY-2.0" 'license:cc-by2.0) ("CC-BY-3.0" 'license:cc-by3.0) + ("CC-BY-4.0" 'license:cc-by4.0) ("CC-BY-SA-2.0" 'license:cc-by-sa2.0) ("CC-BY-SA-3.0" 'license:cc-by-sa3.0) ("CC-BY-SA-4.0" 'license:cc-by-sa4.0) @@ -163,6 +166,7 @@ of the string VERSION is replaced by the symbol 'version." ("EPL-1.0" 'license:epl1.0) ("MIT" 'license:expat) ("FTL" 'license:freetype) + ("Freetype" 'license:freetype) ("GFDL-1.1" 'license:fdl1.1+) ("GFDL-1.2" 'license:fdl1.2+) ("GFDL-1.3" 'license:fdl1.3+) @@ -179,6 +183,7 @@ of the string VERSION is replaced by the symbol 'version." ("GPL-3.0-only" 'license:gpl3) ("GPL-3.0+" 'license:gpl3+) ("GPL-3.0-or-later" 'license:gpl3+) + ("HPND" 'license:hpnd) ("ISC" 'license:isc) ("IJG" 'license:ijg) ("Imlib2" 'license:imlib2) @@ -231,9 +236,10 @@ to in the (guix licenses) module, or #f if there is no such known license." with dashes." (string-join (string-split (string-downcase str) #\_) "-")) -(define (beautify-description description) - "Improve the package DESCRIPTION by turning a beginning sentence fragment -into a proper sentence and by using two spaces between sentences." +(define* (beautify-description description #:optional (length 80)) + "Improve the package DESCRIPTION by turning a beginning sentence fragment into +a proper sentence and by using two spaces between sentences, and wrap lines at +LENGTH characters." (let ((cleaned (cond ((string-prefix? "A " description) (string-append "This package provides a" @@ -248,8 +254,9 @@ into a proper sentence and by using two spaces between sentences." (string-length "Functions")))) (else description)))) ;; Use double spacing between sentences - (regexp-substitute/global #f "\\. \\b" - cleaned 'pre ". " 'post))) + (fill-paragraph (regexp-substitute/global #f "\\. \\b" + cleaned 'pre ". " 'post) + length))) (define* (package-names->package-inputs names #:optional (output #f)) "Given a list of PACKAGE-NAMES or (PACKAGE-NAME VERSION) pairs, and an diff --git a/guix/inferior.scm b/guix/inferior.scm index 81958baaa5..febac29766 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -785,6 +785,9 @@ determines whether CHANNELS are authenticated." (define add-indirect-root* (store-lift add-indirect-root)) + (define add-temp-root* + (store-lift add-temp-root)) + (mkdir-p cache-directory) (maybe-remove-expired-cache-entries cache-directory cache-entries @@ -805,11 +808,15 @@ determines whether CHANNELS are authenticated." ;; what's going to be built. (built-derivations (list profile)) - ;; Note: Caching is fine even when AUTHENTICATE? is false because - ;; we always call 'latest-channel-instances?'. - (symlink* (derivation->output-path profile) cached) - (add-indirect-root* cached) - (return cached)))))) + ;; Cache if and only if AUTHENTICATE? is true. + (if authenticate? + (mbegin %store-monad + (symlink* (derivation->output-path profile) cached) + (add-indirect-root* cached) + (return cached)) + (mbegin %store-monad + (add-temp-root* profile) + (return profile)))))))) (define* (inferior-for-channels channels #:key diff --git a/guix/licenses.scm b/guix/licenses.scm index c071aae4a9..82ca44f42e 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -308,6 +308,8 @@ at URI, which may be a file:// URI pointing the package's tree." "https://directory.fsf.org/wiki/License:EUPL-1.2" "https://www.gnu.org/licenses/license-list#EUPL-1.2")) +;; Some people call it the MIT license. For clarification see: +;; https://www.gnu.org/licenses/license-list.html#Expat (define expat (license "Expat" "http://directory.fsf.org/wiki/License:Expat" diff --git a/guix/lint.scm b/guix/lint.scm index 2a703f9b6d..74b9a304d9 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -322,6 +322,21 @@ markup is valid return a plain-text version of DESCRIPTION, otherwise #f." (G_ "Texinfo markup in description is invalid") #:field 'description)))) + (define (check-description-typo description typo-corrections) + "Check that DESCRIPTION does not contain typo, with optional correction" + (append-map + (match-lambda + ((typo . correction) + (if (string-contains description typo) + (list + (make-warning package + (G_ + (format #false + "description contains typo '~a'~@[, should be '~a'~]" + typo correction)))) + '()))) + typo-corrections)) + (define (check-trademarks description) "Check that DESCRIPTION does not contain '™' or '®' characters. See http://www.gnu.org/prep/standards/html_node/Trademarks.html." @@ -402,6 +417,10 @@ by two spaces; possible infraction~p at ~{~a~^, ~}") (check-not-empty description) (check-quotes description) (check-trademarks description) + (check-description-typo description '(("This packages" . "This package") + ("This modules" . "This module") + ("allows to" . #f) + ("permits to" . #f))) ;; Use raw description for this because Texinfo rendering ;; automatically fixes end of sentence space. (check-end-of-sentence-space description) @@ -459,6 +478,7 @@ of a package, and INPUT-NAMES, a list of package specifications such as "help2man" "intltool" "itstool" + "kdoctools" "libtool" "m4" "qttools" @@ -967,8 +987,12 @@ patch could not be found." ;; Check whether we're reaching tar's maximum file name length. (let ((prefix (string-length (%distro-directory))) - (margin (string-length "guix-2.0.0rc3-10000-1234567890/")) - (max 99)) + ;; Margin approximating the largest path that "make dist" might + ;; create, with a release candidate version, 123456 commits, and + ;; git commit hash abcde0. + (margin (string-length "guix-92.0.0rc3-123456-abcde0/")) + ;; Tested maximum patch file length for ustar format. + (max 151)) (filter-map (match-lambda ((? string? patch) (if (> (+ margin (if (string-prefix? (%distro-directory) @@ -978,7 +1002,7 @@ patch could not be found." max) (make-warning package - (G_ "~a: file name is too long") + (G_ "~a: file name is too long, which may break 'make dist'") (list (basename patch)) #:field 'patch-file-names) #f)) @@ -1585,7 +1609,7 @@ Heritage and missing from the Disarchive database") (#f '()) (id (list (make-warning package - (G_ " + (G_ "\ Disarchive entry refers to non-existent SWH directory '~a'") (list id) #:field 'source))))))) diff --git a/guix/narinfo.scm b/guix/narinfo.scm index 72e0f75fda..4fc550aa6c 100644 --- a/guix/narinfo.scm +++ b/guix/narinfo.scm @@ -144,7 +144,9 @@ must contain the original contents of a narinfo file." (map (lambda (url) (or (string->uri url) (string->uri - (string-append cache-url "/" url)))) + (if (string-suffix? "/" cache-url) + (string-append cache-url url) + (string-append cache-url "/" url))))) urls) compressions (match file-sizes diff --git a/guix/packages.scm b/guix/packages.scm index 863c12d528..b00fa2f702 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2014, 2015, 2017, 2018 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2014, 2015, 2017, 2018, 2019 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2017, 2019, 2020 Efraim Flashner <efraim@flashner.co.il> @@ -52,6 +52,7 @@ #:use-module (srfi srfi-35) #:use-module (rnrs bytevectors) #:use-module (web uri) + #:autoload (texinfo) (texi-fragment->stexi) #:re-export (%current-system %current-target-system search-path-specification) ;for convenience @@ -169,6 +170,7 @@ bag-transitive-host-inputs bag-transitive-build-inputs bag-transitive-target-inputs + package-development-inputs package-closure default-guile @@ -363,6 +365,27 @@ name of its URI." ;; git, svn, cvs, etc. reference #f)))) +;; Work around limitations in the 'snippet' mechanism. It is not possible for +;; a 'snippet' to produce a tarball with a different base name than the +;; original downloaded source. Moreover, cherry picking dozens of upsteam +;; patches and applying them suddenly is often impractical; especially when a +;; comprehensive code reformatting is done upstream. Mainly designed for +;; Linux and IceCat packages. +;; XXXX: do not make part of public API (export) such radical capability +;; before a detailed review process. +(define* (computed-origin-method gexp-promise hash-algo hash + #:optional (name "source") + #:key (system (%current-system)) + (guile (default-guile))) + "Return a derivation that executes the G-expression that results +from forcing GEXP-PROMISE." + (mlet %store-monad ((guile (package->derivation guile system))) + (gexp->derivation (or name "computed-origin") + (force gexp-promise) + #:graft? #f ;nothing to graft + #:system system + #:guile-for-build guile))) + (define %supported-systems ;; This is the list of system types that are supported. By default, we @@ -444,6 +467,49 @@ lexical scope of its body." (lambda (s) #,location))) body ...)))))) +(define-syntax validate-texinfo + (let ((validate? (getenv "GUIX_UNINSTALLED"))) + (define ensure-thread-safe-texinfo-parser! + ;; Work around <https://issues.guix.gnu.org/51264> for Guile <= 3.0.7. + (let ((patched? (or (> (string->number (major-version)) 3) + (> (string->number (minor-version)) 0) + (> (string->number (micro-version)) 7))) + (next-token-of/thread-safe + (lambda (pred port) + (let loop ((chars '())) + (match (read-char port) + ((? eof-object?) + (list->string (reverse! chars))) + (chr + (let ((chr* (pred chr))) + (if chr* + (loop (cons chr* chars)) + (begin + (unread-char chr port) + (list->string (reverse! chars))))))))))) + (lambda () + (unless patched? + (set! (@@ (texinfo) next-token-of) next-token-of/thread-safe) + (set! patched? #t))))) + + (lambda (s) + "Raise a syntax error when passed a literal string that is not valid +Texinfo. Otherwise, return the string." + (syntax-case s () + ((_ str) + (string? (syntax->datum #'str)) + (if validate? + (catch 'parser-error + (lambda () + (ensure-thread-safe-texinfo-parser!) + (texi-fragment->stexi (syntax->datum #'str)) + #'str) + (lambda _ + (syntax-violation 'package "invalid Texinfo markup" #'str))) + #'str)) + ((_ obj) + #'obj))))) + ;; A package. (define-record-type* <package> package make-package @@ -481,9 +547,11 @@ lexical scope of its body." (replacement package-replacement ; package | #f (default #f) (thunked) (innate)) - (synopsis package-synopsis) ; one-line description - (description package-description) ; one or two paragraphs - (license package-license) + (synopsis package-synopsis + (sanitize validate-texinfo)) ; one-line description + (description package-description + (sanitize validate-texinfo)) ; one or two paragraphs + (license package-license) ; (list of) <license> (home-page package-home-page) (supported-systems package-supported-systems ; list of strings (default %supported-systems)) @@ -913,10 +981,10 @@ specifies modules in scope when evaluating SNIPPET." ((file-is-directory? #+source) (copy-recursively directory #$output #:log (%make-void-port "w"))) - ((not #+comp) - (copy-file file #$output)) - (else - (repack directory #$output))))))) + ((or #+comp (tarball? #+source)) + (repack directory #$output)) + (else ;single uncompressed file + (copy-file file #$output))))))) (let ((name (if (or (checkout? original-file-name) (not (compressor original-file-name))) @@ -1015,13 +1083,6 @@ otherwise." otherwise." (lookup-input (package-direct-inputs package) name)) -(define (inputs-sans-labels inputs) - "Return INPUTS stripped of any input labels." - (map (match-lambda - ((label obj) obj) - ((label obj output) `(,obj ,output))) - inputs)) - (define (replace-input name replacement inputs) "Replace input NAME by REPLACEMENT within INPUTS." (map (lambda (input) @@ -1056,7 +1117,10 @@ inputs of Coreutils and adds libcap: (delete \"gmp\" \"acl\") (append libcap)) -Other types of clauses include 'prepend' and 'replace'." +Other types of clauses include 'prepend' and 'replace'. + +The first argument must be a labeled input list; the result is also a labeled +input list." ;; Note: This macro hides the fact that INPUTS, as returned by ;; 'package-inputs' & co., is actually an alist with labels. Eventually, ;; it will operate on list of inputs without labels. @@ -1067,10 +1131,10 @@ Other types of clauses include 'prepend' and 'replace'." (modify-inputs (fold alist-delete inputs (list names ...)) clauses ...)) ((_ inputs (prepend lst ...) clauses ...) - (modify-inputs (append (list lst ...) (inputs-sans-labels inputs)) + (modify-inputs (append (map add-input-label (list lst ...)) inputs) clauses ...)) ((_ inputs (append lst ...) clauses ...) - (modify-inputs (append (inputs-sans-labels inputs) (list lst ...)) + (modify-inputs (append inputs (map add-input-label (list lst ...))) clauses ...)) ((_ inputs (replace name replacement) clauses ...) (modify-inputs (replace-input name replacement inputs) @@ -1155,23 +1219,36 @@ in INPUTS and their transitive propagated inputs." (define package-transitive-supported-systems (let () - (define supported-systems - (mlambda (package system) - (parameterize ((%current-system system)) - (fold (lambda (input systems) - (match input - ((label (? package? package) . _) - (lset-intersection string=? systems - (supported-systems package system))) - (_ - systems))) - (package-supported-systems package) - (bag-direct-inputs (package->bag package)))))) + (define (supported-systems-procedure system) + (define supported-systems + (mlambdaq (package) + (parameterize ((%current-system system)) + (fold (lambda (input systems) + (match input + ((label (? package? package) . _) + (lset-intersection string=? systems + (supported-systems package))) + (_ + systems))) + (package-supported-systems package) + (bag-direct-inputs (package->bag package)))))) + + supported-systems) + + (define procs + ;; Map system strings to one-argument procedures. This allows these + ;; procedures to have fast 'eq?' memoization on their argument. + (make-hash-table)) (lambda* (package #:optional (system (%current-system))) "Return the intersection of the systems supported by PACKAGE and those supported by its dependencies." - (supported-systems package system)))) + (match (hash-ref procs system) + (#f + (hash-set! procs system (supported-systems-procedure system)) + (package-transitive-supported-systems package system)) + (proc + (proc package)))))) (define* (supported-package? package #:optional (system (%current-system))) "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its @@ -1208,6 +1285,15 @@ dependencies are known to build on SYSTEM." (%current-system (bag-system bag))) (transitive-inputs (bag-target-inputs bag)))) +(define* (package-development-inputs package + #:optional (system (%current-system)) + #:key target) + "Return the list of inputs required by PACKAGE for development purposes on +SYSTEM. When TARGET is true, return the inputs needed to cross-compile +PACKAGE from SYSTEM to TRIPLET, where TRIPLET is a triplet such as +\"aarch64-linux-gnu\"." + (bag-transitive-inputs (package->bag package system target))) + (define* (package-closure packages #:key (system (%current-system))) "Return the closure of PACKAGES on SYSTEM--i.e., PACKAGES and the list of packages they depend on, recursively." @@ -1770,7 +1856,7 @@ This is an internal procedure." (return drv)) (grafts (mlet %store-monad ((guile (package->derivation - (default-guile) + (guile-for-grafts) system #:graft? #f))) (graft-derivation* drv grafts #:system system @@ -1793,7 +1879,7 @@ system identifying string)." (return drv)) (grafts (mlet %store-monad ((guile (package->derivation - (default-guile) + (guile-for-grafts) system #:graft? #f))) (graft-derivation* drv grafts #:system system diff --git a/guix/profiles.scm b/guix/profiles.scm index 9494684228..1d354ecb78 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -7,7 +7,7 @@ ;;; Copyright © 2016, 2018, 2019, 2021 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com> -;;; Copyright © 2017 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2017, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2019 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org> @@ -124,6 +124,7 @@ profile-manifest package->manifest-entry + package->development-manifest packages->manifest ca-certificate-bundle %default-profile-hooks @@ -400,6 +401,24 @@ file name." (properties properties)))) entry)) +(define* (package->development-manifest package + #:optional + (system (%current-system)) + #:key target) + "Return a manifest for the \"development inputs\" of PACKAGE for SYSTEM, +optionally when cross-compiling to TARGET. Development inputs include both +explicit and implicit inputs of PACKAGE." + (manifest + (filter-map (match-lambda + ((label (? package? package)) + (package->manifest-entry package)) + ((label (? package? package) output) + (package->manifest-entry package output)) + ;; TODO: Support <inferior-package>. + (_ + #f)) + (package-development-inputs package system #:target target)))) + (define (packages->manifest packages) "Return a list of manifest entries, one for each item listed in PACKAGES. Elements of PACKAGES can be either package objects or package/string tuples @@ -1161,6 +1180,52 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx." `((type . profile-hook) (hook . emacs-subdirs)))) +(define (gdk-pixbuf-loaders-cache-file manifest) + "Return a derivation that produces a loaders cache file for every gdk-pixbuf +loaders discovered in MANIFEST." + (define gdk-pixbuf ;lazy reference + (module-ref (resolve-interface '(gnu packages gtk)) 'gdk-pixbuf)) + + (mlet* %store-monad + ((gdk-pixbuf (manifest-lookup-package manifest "gdk-pixbuf")) + (librsvg (manifest-lookup-package manifest "librsvg")) + (gdk-pixbuf-bin -> (if (string? gdk-pixbuf) + (string-append gdk-pixbuf "/bin") + (file-append gdk-pixbuf "/bin")))) + + (define build + (with-imported-modules (source-module-closure + '((guix build glib-or-gtk-build-system))) + #~(begin + (use-modules (guix build glib-or-gtk-build-system)) + (setenv "PATH" (string-append #$gdk-pixbuf-bin ":" (getenv "PATH"))) + + (generate-gdk-pixbuf-loaders-cache + ;; XXX: MANIFEST-LOOKUP-PACKAGE transitively searches through + ;; every input referenced by the manifest, while MANIFEST-INPUTS + ;; only retrieves the immediate inputs as well as their + ;; propagated inputs; to avoid causing an empty output derivation + ;; we must ensure that the inputs contain at least one + ;; loaders.cache file. This is why we include gdk-pixbuf or + ;; librsvg when they are transitively found. + (list #$@(if gdk-pixbuf + (list gdk-pixbuf) + '()) + #$@(if librsvg + (list librsvg) + '()) + #$@(manifest-inputs manifest)) + (list #$output))))) + + (if gdk-pixbuf + (gexp->derivation "gdk-pixbuf-loaders-cache-file" build + #:local-build? #t + #:substitutable? #f + #:properties + '((type . profile-hook) + (hook . gdk-pixbuf-loaders-cache-file))) + (return #f)))) + (define (glib-schemas manifest) "Return a derivation that unions all schemas from manifest entries and creates the Glib 'gschemas.compiled' file." @@ -1663,15 +1728,124 @@ the entries in MANIFEST." `((type . profile-hook) (hook . manual-database)))) +(define (manual-database/optional manifest) + "Return a derivation to build the manual database of MANIFEST, but only if +MANIFEST contains the \"man-db\" package. Otherwise, return #f." + ;; Building the man database (for "man -k") is expensive and rarely used. + ;; Build it only if the profile also contains "man-db". + (mlet %store-monad ((man-db (manifest-lookup-package manifest "man-db"))) + (if man-db + (manual-database manifest) + (return #f)))) + +(define (texlive-configuration manifest) + "Return a derivation that builds a TeXlive configuration for the entries in +MANIFEST." + (define entry->texlive-input + (match-lambda + (($ <manifest-entry> name version output thing deps) + (if (string-prefix? "texlive-" name) + (cons (gexp-input thing output) + (append-map entry->texlive-input deps)) + '())))) + (define texlive-bin + (module-ref (resolve-interface '(gnu packages tex)) 'texlive-bin)) + (define coreutils + (module-ref (resolve-interface '(gnu packages base)) 'coreutils)) + (define sed + (module-ref (resolve-interface '(gnu packages base)) 'sed)) + (define updmap.cfg + (module-ref (resolve-interface '(gnu packages tex)) + 'texlive-default-updmap.cfg)) + (define build + (with-imported-modules '((guix build utils) + (guix build union)) + #~(begin + (use-modules (guix build utils) + (guix build union) + (ice-9 popen)) + + ;; Build a modifiable union of all texlive inputs. We do this so + ;; that TeX live can resolve the parent and grandparent directories + ;; correctly. There might be a more elegant way to accomplish this. + (union-build #$output + '#$(append-map entry->texlive-input + (manifest-entries manifest)) + #:create-all-directories? #t + #:log-port (%make-void-port "w")) + (let ((texmf.cnf (string-append + #$output + "/share/texmf-dist/web2c/texmf.cnf"))) + (when (file-exists? texmf.cnf) + (substitute* texmf.cnf + (("^TEXMFROOT = .*") + (string-append "TEXMFROOT = " #$output "/share\n")) + (("^TEXMF = .*") + "TEXMF = $TEXMFROOT/share/texmf-dist\n")) + + ;; XXX: This is annoying, but it's necessary because texlive-bin + ;; does not provide wrapped executables. + (setenv "PATH" + (string-append #$(file-append coreutils "/bin") + ":" + #$(file-append sed "/bin"))) + (setenv "PERL5LIB" #$(file-append texlive-bin "/share/tlpkg")) + (setenv "TEXMF" (string-append #$output "/share/texmf-dist")) + + ;; Remove invalid maps from config file. + (let* ((web2c (string-append #$output "/share/texmf-config/web2c/")) + (maproot (string-append #$output "/share/texmf-dist/fonts/map/")) + (updmap.cfg (string-append web2c "updmap.cfg"))) + (mkdir-p web2c) + + ;; Some profiles may already have this file, which prevents us + ;; from copying it. Since we need to generate it from scratch + ;; anyway, we delete it here. + (when (file-exists? updmap.cfg) + (delete-file updmap.cfg)) + (copy-file #$updmap.cfg updmap.cfg) + (make-file-writable updmap.cfg) + (let* ((port (open-pipe* OPEN_WRITE + #$(file-append texlive-bin "/bin/updmap-sys") + "--syncwithtrees" + "--nohash" + "--force" + (string-append "--cnffile=" web2c "updmap.cfg")))) + (display "Y\n" port) + (when (not (zero? (status:exit-val (close-pipe port)))) + (error "failed to filter updmap.cfg"))) + + ;; Generate font maps. + (invoke #$(file-append texlive-bin "/bin/updmap-sys") + (string-append "--cnffile=" web2c "updmap.cfg") + (string-append "--dvipdfmxoutputdir=" + maproot "updmap/dvipdfmx/") + (string-append "--dvipsoutputdir=" + maproot "updmap/dvips/") + (string-append "--pdftexoutputdir=" + maproot "updmap/pdftex/"))))) + #t))) + + (mlet %store-monad ((texlive-base (manifest-lookup-package manifest "texlive-base"))) + (if texlive-base + (gexp->derivation "texlive-configuration" build + #:substitutable? #f + #:local-build? #t + #:properties + `((type . profile-hook) + (hook . texlive-configuration))) + (return #f)))) + (define %default-profile-hooks ;; This is the list of derivation-returning procedures that are called by ;; default when making a non-empty profile. (list info-dir-file - manual-database + manual-database/optional fonts-dir-file ghc-package-cache-file ca-certificate-bundle emacs-subdirs + gdk-pixbuf-loaders-cache-file glib-schemas gtk-icon-themes gtk-im-modules diff --git a/guix/progress.scm b/guix/progress.scm index 0cbc804ec1..4f8e98edc0 100644 --- a/guix/progress.scm +++ b/guix/progress.scm @@ -270,19 +270,25 @@ ABBREVIATION used to shorten FILE for display." tasks is performed. Write PREFIX at the beginning of the line." (define done 0) + (define (draw-bar) + (let* ((ratio (* 100. (/ done total)))) + (erase-current-line port) + (if (string-null? prefix) + (display (progress-bar ratio (current-terminal-columns)) port) + (let ((width (- (current-terminal-columns) + (string-length prefix) 3))) + (display prefix port) + (display " " port) + (display (progress-bar ratio width) port))) + (force-output port))) + + (define draw-bar/rate-limited + (rate-limited draw-bar %progress-interval)) + (define (report-progress) (set! done (+ 1 done)) (unless (> done total) - (let* ((ratio (* 100. (/ done total)))) - (erase-current-line port) - (if (string-null? prefix) - (display (progress-bar ratio (current-terminal-columns)) port) - (let ((width (- (current-terminal-columns) - (string-length prefix) 3))) - (display prefix port) - (display " " port) - (display (progress-bar ratio width) port))) - (force-output port)))) + (draw-bar/rate-limited))) (progress-reporter (start (lambda () diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 69c2781abb..c29d5105ae 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -35,10 +35,10 @@ #:use-module (gcrypt hash) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (ice-9 format) @@ -196,65 +196,68 @@ taken since we do not import the archives." (define (port-sha256* port size) ;; Like 'port-sha256', but limited to SIZE bytes. - (let-values (((out get) (open-sha256-port))) + (let ((out get (open-sha256-port))) (dump-port* port out size) (close-port out) (get))) (define (archive-contents port) - "Return a list representing the files contained in the nar read from PORT." - (fold-archive (lambda (file type contents result) - (match type - ((or 'regular 'executable) - (match contents - ((port . size) - (cons `(,file ,type ,(port-sha256* port size)) - result)))) - ('directory result) - ('directory-complete result) - ('symlink - (cons `(,file ,type ,contents) result)))) - '() - port - "")) + "Return a list representing the files contained in the nar read from PORT. +The list is sorted in canonical order--i.e., the order in which entries appear +in the nar." + (reverse + (fold-archive (lambda (file type contents result) + (match type + ((or 'regular 'executable) + (match contents + ((port . size) + (cons `(,file ,type ,(port-sha256* port size)) + result)))) + ('directory result) + ('directory-complete result) + ('symlink + (cons `(,file ,type ,contents) result)))) + '() + port + ""))) (define (store-item-contents item) "Return a list of files and contents for ITEM in the same format as 'archive-contents'." - (file-system-fold (const #t) ;enter? - (lambda (file stat result) ;leaf - (define short - (string-drop file (string-length item))) - - (match (stat:type stat) - ('regular - (let ((size (stat:size stat)) - (type (if (zero? (logand (stat:mode stat) - #o100)) - 'regular - 'executable))) - (cons `(,short ,type - ,(call-with-input-file file - (cut port-sha256* <> size))) - result))) - ('symlink - (cons `(,short symlink ,(readlink file)) - result)))) - (lambda (directory stat result) result) ;down - (lambda (directory stat result) result) ;up - (lambda (file stat result) result) ;skip - (lambda (file stat errno result) result) ;error - '() - item - lstat)) + (let loop ((file item)) + (define stat + (lstat file)) + + (define short + (string-drop file (string-length item))) + + (match (stat:type stat) + ('regular + (let ((size (stat:size stat)) + (type (if (zero? (logand (stat:mode stat) + #o100)) + 'regular + 'executable))) + `((,short ,type + ,(call-with-input-file file + (cut port-sha256* <> size)))))) + ('symlink + `((,short symlink ,(readlink file)))) + ('directory + (append-map (match-lambda + ((or "." "..") + '()) + (entry + (loop (string-append file "/" entry)))) + ;; Traverse entries in canonical order, the same as the + ;; order of entries in nars. + (scandir file (const #t) string<?)))))) (define (call-with-nar narinfo proc) "Call PROC with an input port from which it can read the nar pointed to by NARINFO." - (let*-values (((uri compression size) - (narinfo-best-uri narinfo)) - ((port actual-size) - (http-fetch uri))) + (let* ((uri compression size (narinfo-best-uri narinfo)) + (port actual-size (http-fetch uri))) (define reporter (progress-reporter/file (narinfo-path narinfo) (and size diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 6958bd6238..510cee727f 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -34,23 +34,33 @@ #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (guix transformations) - #:use-module (gnu build linux-container) - #:use-module (gnu build accounts) - #:use-module ((guix build syscalls) #:select (set-network-interface-up)) - #:use-module (gnu system linux-container) + #:autoload (ice-9 ftw) (scandir) + #:autoload (gnu build linux-container) (call-with-container %namespaces + user-namespace-supported? + unprivileged-user-namespace-supported? + setgroups-supported?) + #:autoload (gnu build accounts) (password-entry group-entry + password-entry-name password-entry-directory + write-passwd write-group) + #:autoload (guix build syscalls) (set-network-interface-up openpty login-tty) #:use-module (gnu system file-systems) - #:use-module (gnu packages) - #:use-module (gnu packages bash) - #:use-module ((gnu packages bootstrap) - #:select (bootstrap-executable %bootstrap-guile)) + #:autoload (gnu packages) (specification->package+output) + #:autoload (gnu packages bash) (bash) + #:autoload (gnu packages bootstrap) (bootstrap-executable %bootstrap-guile) #:use-module (ice-9 match) + #:autoload (ice-9 rdelim) (read-line) + #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (srfi srfi-98) #:export (assert-container-features - guix-environment)) + guix-environment + guix-environment* + show-environment-options-help + (%options . %environment-options) + (%default-options . %environment-default-options))) (define %default-shell (or (getenv "SHELL") "/bin/sh")) @@ -66,41 +76,18 @@ do not augment existing environment variables with additional search paths." (newline))) (profile-search-paths profile manifest))) -(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->manifest-entry package)) - ((_ (? package? package) output) - (package->manifest-entry package output)) - (_ - #f))) - -(define (package-environment-inputs package) - "Return a list of manifest entries corresponding to the transitive input -packages for PACKAGE." - ;; Remove non-package inputs such as origin records. - (filter-map input->manifest-entry - (bag-transitive-inputs (package->bag package)))) - -(define (show-help) - (display (G_ "Usage: guix environment [OPTION]... PACKAGE... [-- COMMAND...] -Build an environment that includes the dependencies of PACKAGE and execute -COMMAND or an interactive shell in that environment.\n")) +(define (show-environment-options-help) + "Print help about options shared between 'guix environment' and 'guix +shell'." (display (G_ " -e, --expression=EXPR create environment for the package that EXPR evaluates to")) (display (G_ " - -l, --load=FILE create environment for the package that the code within - FILE evaluates to")) - (display (G_ " -m, --manifest=FILE create environment with the manifest from FILE")) (display (G_ " -p, --profile=PATH create environment from profile at PATH")) (display (G_ " - --ad-hoc include all specified packages in the environment instead - of only their inputs")) + --check check if the shell clobbers environment variables")) (display (G_ " --pure unset existing environment variables")) (display (G_ " @@ -136,7 +123,24 @@ COMMAND or an interactive shell in that environment.\n")) (display (G_ " -v, --verbosity=LEVEL use the given verbosity LEVEL")) (display (G_ " - --bootstrap use bootstrap binaries to build the environment")) + --bootstrap use bootstrap binaries to build the environment"))) + +(define (show-help) + (display (G_ "Usage: guix environment [OPTION]... PACKAGE... [-- COMMAND...] +Build an environment that includes the dependencies of PACKAGE and execute +COMMAND or an interactive shell in that environment.\n")) + (warning (G_ "This command is deprecated in favor of 'guix shell'.\n")) + (newline) + + ;; These two options are left out in 'guix shell'. + (display (G_ " + -l, --load=FILE create environment for the package that the code within + FILE evaluates to")) + (display (G_ " + --ad-hoc include all specified packages in the environment instead + of only their inputs")) + + (show-environment-options-help) (newline) (show-build-options-help) (newline) @@ -179,6 +183,9 @@ COMMAND or an interactive shell in that environment.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix environment"))) + (option '("check") #f #f + (lambda (opt name arg result) + (alist-cons 'check? #t result))) (option '("pure") #f #f (lambda (opt name arg result) (alist-cons 'pure #t result))) @@ -297,11 +304,11 @@ for the corresponding packages." ((? package? package) (if (eq? mode 'ad-hoc-package) (list (package->manifest-entry* package)) - (package-environment-inputs package))) + (manifest-entries (package->development-manifest package)))) (((? package? package) (? string? output)) (if (eq? mode 'ad-hoc-package) (list (package->manifest-entry* package output)) - (package-environment-inputs package))) + (manifest-entries (package->development-manifest package)))) ((lst ...) (append-map (cut packages->outputs <> mode) lst)))) @@ -313,8 +320,9 @@ for the corresponding packages." (specification->package+output spec))) (list (package->manifest-entry* package output)))) (('package 'package (? string? spec)) - (package-environment-inputs - (transform (specification->package+output spec)))) + (manifest-entries + (package->development-manifest + (transform (specification->package+output spec))))) (('expression mode str) ;; Add all the outputs of the package STR evaluates to. (packages->outputs (read/eval str) mode)) @@ -394,7 +402,193 @@ regexps in WHITE-LIST." (match command ((program . args) - (apply execlp program program args)))) + (catch 'system-error + (lambda () + (apply execlp program program args)) + (lambda _ + ;; Following established convention, exit with 127 upon ENOENT. + (primitive-_exit 127)))))) + +(define (child-shell-environment shell profile manifest) + "Create a child process, load PROFILE and MANIFEST, and then run SHELL in +interactive mode in it. Return a name/value vhash for all the variables shown +by running 'set' in the shell." + (define-values (controller inferior) + (openpty)) + + (define script + ;; Script to obtain the list of environment variable values. On a POSIX + ;; shell we can rely on 'set', but on fish we have to use 'env' (fish's + ;; 'set' truncates values and prints them in a different format.) + "env || /usr/bin/env || set; echo GUIX-CHECK-DONE; read x; exit\n") + + (define lines + (match (primitive-fork) + (0 + (catch #t + (lambda () + (load-profile profile manifest #:pure? #t) + (setenv "GUIX_ENVIRONMENT" profile) + (close-fdes controller) + (login-tty inferior) + (execl shell shell)) + (lambda _ + (primitive-exit 127)))) + (pid + (close-fdes inferior) + (let* ((port (fdopen controller "r+l")) + (result (begin + (display script port) + (let loop ((lines '())) + (match (read-line port) + ((? eof-object?) (reverse lines)) + ("GUIX-CHECK-DONE\r" + (display "done\n" port) + (reverse lines)) + (line + ;; Drop the '\r' from LINE. + (loop (cons (string-drop-right line 1) + lines)))))))) + (close-port port) + (waitpid pid) + result)))) + + (fold (lambda (line table) + ;; Note: 'set' in fish outputs "NAME VALUE" instead of "NAME=VALUE" + ;; but it also truncates values anyway, so don't try to support it. + (let ((index (string-index line #\=))) + (if index + (vhash-cons (string-take line index) + (string-drop line (+ 1 index)) + table) + table))) + vlist-null + lines)) + +(define* (validate-child-shell-environment profile manifest + #:optional (shell %default-shell)) + "Run SHELL in interactive mode in an environment for PROFILE and MANIFEST +and report clobbered environment variables." + (define warned? #f) + (define-syntax-rule (warn exp ...) + (begin + (set! warned? #t) + (warning exp ...))) + + (info (G_ "checking the environment variables visible from shell '~a'...~%") + shell) + (let ((actual (child-shell-environment shell profile manifest))) + (when (vlist-null? actual) + (leave (G_ "failed to determine environment of shell '~a'~%") + shell)) + (for-each (match-lambda + ((spec . expected) + (let ((name (search-path-specification-variable spec))) + (match (vhash-assoc name actual) + (#f + (warn (G_ "variable '~a' is missing from shell \ +environment~%") + name)) + ((_ . actual) + (cond ((string=? expected actual) + #t) + ((string-prefix? expected actual) + (warn (G_ "variable '~a' has unexpected \ +suffix '~a'~%") + name + (string-drop actual + (string-length expected)))) + (else + (warn (G_ "variable '~a' is clobbered: '~a'~%") + name actual)))))))) + (profile-search-paths profile manifest)) + + ;; Special case. + (match (vhash-assoc "GUIX_ENVIRONMENT" actual) + (#f + (warn (G_ "'GUIX_ENVIRONMENT' is missing from the shell \ +environment~%"))) + ((_ . value) + (unless (string=? value profile) + (warn (G_ "'GUIX_ENVIRONMENT' is set to '~a' instead of '~a'~%") + value profile)))) + + ;; Check the prompt unless we have more important warnings. + (unless warned? + (match (vhash-assoc "PS1" actual) + (#f #f) + ((_ . str) + (when (and (getenv "PS1") (string=? str (getenv "PS1"))) + (warning (G_ "'PS1' is the same in sub-shell~%")) + (display-hint (G_ "Consider setting a different prompt for +environment shells to make them distinguishable. + +If you are using Bash, you can do that by adding these lines to +@file{~/.bashrc}: + +@example +if [ -n \"$GUIX_ENVIRONMENT\" ] +then + export PS1=\"\\u@@\\h \\w [env]\\$ \" +fi +@end example +")))))) + + (if warned? + (begin + (display-hint (G_ "One or more environment variables have a +different value in the shell than the one we set. This means that you may +find yourself running code in an environment different from the one you asked +Guix to prepare. + +This usually indicates that your shell startup files are unexpectedly +modifying those environment variables. For example, if you are using Bash, +make sure that environment variables are set or modified in +@file{~/.bash_profile} and @emph{not} in @file{~/.bashrc}. For more +information on Bash startup files, run: + +@example +info \"(bash) Bash Startup Files\" +@end example + +Alternatively, you can avoid the problem by passing the @option{--container} +or @option{-C} option. That will give you a fully isolated environment +running in a \"container\", immune to the issue described above.")) + (exit 1)) + (info (G_ "All is good! The shell gets correct environment \ +variables.~%"))))) + +(define (suggest-command-name profile command) + "COMMAND was not found in PROFILE so display a hint suggesting the closest +command name." + (define not-dot? + (match-lambda + ((or "." "..") #f) + (_ #t))) + + (match (scandir (string-append profile "/bin") not-dot?) + ((or #f ()) #f) + (available + (match command + ((executable _ ...) + ;; Look for a suggestion with a high threshold: a suggestion is + ;; usually better than no suggestion. + (let ((closest (string-closest executable available + #:threshold 12))) + (unless (or (not closest) (string=? closest executable)) + (display-hint (format #f (G_ "Did you mean '~a'?~%") + closest))))))))) + +(define (validate-exit-status profile command status) + "When STATUS, an integer as returned by 'waitpid', is 127, raise a \"command +not found\" error. Otherwise return STATUS." + ;; Most likely, exit value 127 means ENOENT. + (when (eqv? (status:exit-val status) 127) + (report-error (G_ "~a: command not found~%") + (first command)) + (suggest-command-name profile command) + (exit 1)) + status) (define* (launch-environment/fork command profile manifest #:key pure? (white-list '())) @@ -407,7 +601,8 @@ regexps in WHITE-LIST." #:pure? pure? #:white-list white-list)) (pid (match (waitpid pid) - ((_ . status) status))))) + ((_ . status) + (validate-exit-status profile command status)))))) (define* (launch-environment/container #:key command bash user user-mappings profile manifest link-profile? network? @@ -428,6 +623,9 @@ WHILE-LIST." (and (file-exists? (file-system-mapping-source mapping)) (file-system-mapping->bind-mount mapping))) + (define (exit/status* status) + (exit/status (validate-exit-status profile command status))) + (mlet %store-monad ((reqs (inputs->requisites (list (direct-store-path bash) profile)))) (return @@ -484,7 +682,7 @@ WHILE-LIST." '()) (map file-system-mapping->bind-mount mappings)))) - (exit/status + (exit/status* (call-with-container file-systems (lambda () ;; Setup global shell. @@ -666,11 +864,15 @@ message if any test fails." (define-command (guix-environment . args) (category development) - (synopsis "spawn one-off software environments") + (synopsis "spawn one-off software environments (deprecated)") + + (guix-environment* (parse-args args))) +(define (guix-environment* opts) + "Run the 'guix environment' command on OPTS, an alist resulting for +command-line option processing with 'parse-command-line'." (with-error-handling - (let* ((opts (parse-args args)) - (pure? (assoc-ref opts 'pure)) + (let* ((pure? (assoc-ref opts 'pure)) (container? (assoc-ref opts 'container?)) (link-prof? (assoc-ref opts 'link-profile?)) (network? (assoc-ref opts 'network?)) @@ -690,6 +892,26 @@ message if any test fails." (mappings (pick-all opts 'file-system-mapping)) (white-list (pick-all opts 'inherit-regexp))) + (define store-needed? + ;; Whether connecting to the daemon is needed. + (or container? (not profile))) + + (define-syntax-rule (with-store/maybe store exp ...) + ;; Evaluate EXP... with STORE bound to a connection, unless + ;; STORE-NEEDED? is false, in which case STORE is bound to #f. + (let ((proc (lambda (store) exp ...))) + (if store-needed? + (with-store s + (set-build-options-from-command-line s opts) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity) + #:dry-run? + (assoc-ref opts 'dry-run?)) + (proc s))) + (proc #f)))) + (when container? (assert-container-features)) (when (and (not container?) link-prof?) @@ -700,85 +922,89 @@ message if any test fails." (leave (G_ "--no-cwd cannot be used without --container~%"))) - (with-store store - (with-build-handler (build-notifier #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:verbosity - (assoc-ref opts 'verbosity) - #:dry-run? - (assoc-ref opts 'dry-run?)) - (with-status-verbosity (assoc-ref opts 'verbosity) - (define manifest-from-opts - (options/resolve-packages store opts)) - - (define manifest - (if profile - (profile-manifest profile) - manifest-from-opts)) - - (when (and profile - (> (length (manifest-entries manifest-from-opts)) 0)) - (leave (G_ "'--profile' cannot be used with package options~%"))) - - (when (null? (manifest-entries manifest)) - (warning (G_ "no packages specified; creating an empty environment~%"))) - - (set-build-options-from-command-line store opts) - - ;; Use the bootstrap Guile when requested. - (parameterize ((%graft? (assoc-ref opts 'graft?)) - (%guile-for-build - (package-derivation - store - (if bootstrap? - %bootstrap-guile - (default-guile))))) - (run-with-store store - ;; Containers need a Bourne shell at /bin/sh. - (mlet* %store-monad ((bash (environment-bash container? - bootstrap? - system)) - (prof-drv (manifest->derivation - manifest system bootstrap?)) - (profile -> (if profile + (with-store/maybe store + (with-status-verbosity (assoc-ref opts 'verbosity) + (define manifest-from-opts + (options/resolve-packages store opts)) + + (define manifest + (if profile + (profile-manifest profile) + manifest-from-opts)) + + (when (and profile + (> (length (manifest-entries manifest-from-opts)) 0)) + (leave (G_ "'--profile' cannot be used with package options~%"))) + + (when (null? (manifest-entries manifest)) + (warning (G_ "no packages specified; creating an empty environment~%"))) + + ;; Use the bootstrap Guile when requested. + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%guile-for-build + (and store-needed? + (package-derivation + store + (if bootstrap? + %bootstrap-guile + (default-guile)))))) + (run-with-store store + ;; Containers need a Bourne shell at /bin/sh. + (mlet* %store-monad ((bash (environment-bash container? + bootstrap? + system)) + (prof-drv (if profile + (return #f) + (manifest->derivation + manifest system bootstrap?))) + (profile -> (if profile (readlink* profile) (derivation->output-path prof-drv))) - (gc-root -> (assoc-ref opts 'gc-root))) - - ;; First build the inputs. This is necessary even for - ;; --search-paths. Additionally, we might need to build bash for - ;; a container. - (mbegin %store-monad - (built-derivations (if (derivation? bash) - (list prof-drv bash) - (list prof-drv))) - (mwhen gc-root - (register-gc-root profile gc-root)) - - (cond - ((assoc-ref opts 'search-paths) - (show-search-paths profile manifest #:pure? pure?) - (return #t)) - (container? - (let ((bash-binary - (if bootstrap? - (derivation->output-path bash) - (string-append (derivation->output-path bash) - "/bin/sh")))) - (launch-environment/container #:command command - #:bash bash-binary - #:user user - #:user-mappings mappings - #:profile profile - #:manifest manifest - #:white-list white-list - #:link-profile? link-prof? - #:network? network? - #:map-cwd? (not no-cwd?)))) - - (else - (return - (exit/status - (launch-environment/fork command profile manifest - #:white-list white-list - #:pure? pure?))))))))))))))) + (gc-root -> (assoc-ref opts 'gc-root))) + + ;; First build the inputs. This is necessary even for + ;; --search-paths. Additionally, we might need to build bash for + ;; a container. + (mbegin %store-monad + (mwhen store-needed? + (built-derivations (append + (if prof-drv (list prof-drv) '()) + (if (derivation? bash) (list bash) '())))) + (mwhen gc-root + (register-gc-root profile gc-root)) + + (mwhen (assoc-ref opts 'check?) + (return + (validate-child-shell-environment profile manifest))) + + (cond + ((assoc-ref opts 'search-paths) + (show-search-paths profile manifest #:pure? pure?) + (return #t)) + (container? + (let ((bash-binary + (if bootstrap? + (derivation->output-path bash) + (string-append (derivation->output-path bash) + "/bin/sh")))) + (launch-environment/container #:command command + #:bash bash-binary + #:user user + #:user-mappings mappings + #:profile profile + #:manifest manifest + #:white-list white-list + #:link-profile? link-prof? + #:network? network? + #:map-cwd? (not no-cwd?)))) + + (else + (return + (exit/status + (launch-environment/fork command profile manifest + #:white-list white-list + #:pure? pure?)))))))))))))) + +;;; Local Variables: +;;; eval: (put 'with-store/maybe 'scheme-indent-function 1) +;;; End: diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 66de824ef4..8943e87099 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -500,6 +500,10 @@ package modules, while attempting to retain user package modules." (lambda (opt name arg result) (alist-cons 'backend (lookup-backend arg) result))) + (option '(#\M "max-depth") #t #f + (lambda (opt name arg result) + (alist-cons 'max-depth (string->number* arg) + result))) (option '("list-backends") #f #f (lambda (opt name arg result) (list-backends) @@ -538,6 +542,8 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (display (G_ " --list-types list the available graph types")) (display (G_ " + -M, --max-depth=DEPTH limit to nodes within distance DEPTH")) + (display (G_ " --path display the shortest path between the given nodes")) (display (G_ " -e, --expression=EXPR consider the package EXPR evaluates to")) @@ -559,6 +565,7 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (define %default-options `((node-type . ,%package-node-type) (backend . ,%graphviz-backend) + (max-depth . +inf.0) (system . ,(%current-system)))) @@ -582,6 +589,7 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (with-store store (let* ((transform (options->transformation opts)) + (max-depth (assoc-ref opts 'max-depth)) (items (filter-map (match-lambda (('argument . (? store-path? item)) item) @@ -613,7 +621,8 @@ nodes (given ~a)~%") (export-graph (concatenate nodes) (current-output-port) #:node-type type - #:backend backend))) + #:backend backend + #:max-depth max-depth))) #:system (assq-ref opts 'system))))) #t) diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index b8622373cc..d73e3d13dd 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2018 Tim Gesthuizen <tim.gesthuizen@yahoo.de> +;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -34,17 +35,53 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) + #:autoload (disarchive git-hash) (git-hash-file git-hash-directory) #:export (guix-hash)) ;;; +;;; Serializers +;;; + +(define* (nar-hash file #:optional + (algorithm (assoc-ref %default-options 'hash-algorithm)) + select?) + (let-values (((port get-hash) + (open-hash-port algorithm))) + (write-file file port #:select? select?) + (force-output port) + (get-hash))) + +(define* (default-hash file #:optional + (algorithm (assoc-ref %default-options 'hash-algorithm)) + select?) + (match file + ("-" (port-hash algorithm (current-input-port))) + (_ + (call-with-input-file file + (cute port-hash algorithm <>))))) + +(define* (git-hash file #:optional + (algorithm (assoc-ref %default-options 'hash-algorithm)) + select?) + (define directory? + (case (stat:type (stat file)) + ((directory) #t) + (else #f))) + (if directory? + (git-hash-directory file algorithm) + (git-hash-file file algorithm))) + + +;;; ;;; Command-line options. ;;; (define %default-options ;; Alist of default option values. `((format . ,bytevector->nix-base32-string) - (hash-algorithm . ,(hash-algorithm sha256)))) + (hash-algorithm . ,(hash-algorithm sha256)) + (serializer . ,default-hash))) (define (show-help) (display (G_ "Usage: guix hash [OPTION] FILE @@ -60,7 +97,7 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (format #t (G_ " -f, --format=FMT write the hash in the given format")) (format #t (G_ " - -r, --recursive compute the hash on FILE recursively")) + -S, --serializer=TYPE compute the hash on FILE according to TYPE serialization")) (newline) (display (G_ " -h, --help display this help and exit")) @@ -101,7 +138,26 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (alist-delete 'format result)))) (option '(#\r "recursive") #f #f (lambda (opt name arg result) - (alist-cons 'recursive? #t result))) + (warning (G_ "'--recursive' is deprecated, \ +use '--serializer' instead~%")) + (alist-cons 'serializer nar-hash + (alist-delete 'serializer result)))) + (option '(#\S "serializer") #t #f + (lambda (opt name arg result) + (define serializer-proc + (match arg + ("none" + default-hash) + ("nar" + nar-hash) + ("git" + git-hash) + (x + (leave (G_ "unsupported serializer type: ~a~%") + arg)))) + + (alist-cons 'serializer serializer-proc + (alist-delete 'serializer result)))) (option '(#\h "help") #f #f (lambda args (show-help) @@ -144,32 +200,29 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (fmt (assq-ref opts 'format)) (select? (if (assq-ref opts 'exclude-vcs?) (negate vcs-file?) - (const #t)))) + (const #t))) + (algorithm (assoc-ref opts 'hash-algorithm)) + (serializer (assoc-ref opts 'serializer))) (define (file-hash file) ;; Compute the hash of FILE. - ;; Catch and gracefully report possible '&nar-error' conditions. - (with-error-handling - (if (assoc-ref opts 'recursive?) - (let-values (((port get-hash) - (open-hash-port (assoc-ref opts 'hash-algorithm)))) - (write-file file port #:select? select?) - (force-output port) - (get-hash)) - (match file - ("-" (port-hash (assoc-ref opts 'hash-algorithm) - (current-input-port))) - (_ (call-with-input-file file - (cute port-hash (assoc-ref opts 'hash-algorithm) - <>))))))) + ;; Catch and gracefully report possible error + (catch 'system-error + (lambda _ + (with-error-handling + (serializer file algorithm select?))) + (lambda args + (leave (G_ "~a ~a~%") + file + (strerror (system-error-errno args)))))) + + (define (formatted-hash thing) + (fmt (file-hash thing))) (match args - ((file) - (catch 'system-error - (lambda () - (format #t "~a~%" (fmt (file-hash file)))) - (lambda args - (leave (G_ "~a~%") - (strerror (system-error-errno args)))))) - (x - (leave (G_ "wrong number of arguments~%")))))) + (() + (leave (G_ "no arguments specified~%"))) + (_ + (for-each + (compose (cute format #t "~a~%" <>) formatted-hash) + args))))) diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm new file mode 100644 index 0000000000..afc7d8b39c --- /dev/null +++ b/guix/scripts/home.scm @@ -0,0 +1,538 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Andrew Tropin <andrew@trop.in> +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Pierre Langlois <pierre.langlois@gmx.com> +;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com> +;;; +;;; 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 home) + #:use-module (gnu packages admin) + #:use-module ((gnu services) #:hide (delete)) + #:use-module (gnu packages) + #:use-module (gnu home) + #:use-module (gnu home services) + #:use-module (guix channels) + #:use-module (guix derivations) + #:use-module (guix ui) + #:use-module (guix grafts) + #:use-module (guix packages) + #:use-module (guix profiles) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix scripts package) + #:use-module (guix scripts build) + #:use-module (guix scripts system search) + #:autoload (guix scripts pull) (channel-commit-hyperlink) + #:use-module (guix scripts home import) + #:use-module ((guix status) #:select (with-status-verbosity)) + #:use-module ((guix build utils) #:select (mkdir-p)) + #:use-module (guix gexp) + #:use-module (guix monads) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-35) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:export (guix-home)) + + +;;; +;;; Options. +;;; + +(define %user-module + (make-user-module '((gnu home)))) + +(define %guix-home + (string-append %profile-directory "/guix-home")) + +(define (show-help) + (display (G_ "Usage: guix home [OPTION ...] ACTION [ARG ...] [FILE] +Build the home environment declared in FILE according to ACTION. +Some ACTIONS support additional ARGS.\n")) + (newline) + (display (G_ "The valid values for ACTION are:\n")) + (newline) + (display (G_ "\ + search search for existing service types\n")) + (display (G_ "\ + reconfigure switch to a new home environment configuration\n")) + (display (G_ "\ + roll-back switch to the previous home environment configuration\n")) + (display (G_ "\ + describe describe the current home environment\n")) + (display (G_ "\ + list-generations list the home environment generations\n")) + (display (G_ "\ + switch-generation switch to an existing home environment configuration\n")) + (display (G_ "\ + delete-generations delete old home environment generations\n")) + (display (G_ "\ + build build the home environment without installing anything\n")) + (display (G_ "\ + import generates a home environment definition from dotfiles\n")) + + (show-build-options-help) + (display (G_ " + -e, --expression=EXPR consider the home-environment EXPR evaluates to + instead of reading FILE, when applicable")) + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (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 (verbosity-level opts) + "Return the verbosity level based on OPTS, the alist of parsed options." + (or (assoc-ref opts 'verbosity) + (if (eq? (assoc-ref opts 'action) 'build) + 2 1))) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t result))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix show"))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) + %standard-build-options)) + +(define %default-options + `((build-mode . ,(build-mode normal)) + (graft? . #t) + (substitutes? . #t) + (offload? . #t) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) + (verbosity . 3) + (debug . 0))) + + +;;; +;;; Actions. +;;; + +(define* (perform-action action he + #:key + dry-run? + derivations-only? + use-substitutes?) + "Perform ACTION for home environment. " + + (define println + (cut format #t "~a~%" <>)) + + (mlet* %store-monad + ((he-drv (home-environment-derivation he)) + (drvs (mapm/accumulate-builds lower-object (list he-drv))) + (% (if derivations-only? + (return + (for-each (compose println derivation-file-name) drvs)) + (built-derivations drvs))) + + (he-out-path -> (derivation->output-path he-drv))) + (if (or dry-run? derivations-only?) + (return #f) + (begin + (for-each (compose println derivation->output-path) drvs) + + (case action + ((reconfigure) + (let* ((number (generation-number %guix-home)) + (generation (generation-file-name + %guix-home (+ 1 number)))) + + (switch-symlinks generation he-out-path) + (switch-symlinks %guix-home generation) + (setenv "GUIX_NEW_HOME" he-out-path) + (primitive-load (string-append he-out-path "/activate")) + (setenv "GUIX_NEW_HOME" #f) + (return he-out-path))) + (else + (newline) + (return he-out-path))))))) + +(define (process-action action args opts) + "Process ACTION, a sub-command, with the arguments are listed in ARGS. +ACTION must be one of the sub-commands that takes a home environment +declaration as an argument (a file name.) OPTS is the raw alist of options +resulting from command-line parsing." + (define (ensure-home-environment file-or-exp obj) + (ensure-profile-directory) + (unless (home-environment? obj) + (leave (G_ "'~a' does not return a home environment ~%") + file-or-exp)) + obj) + + (let* ((file (match args + (() #f) + ((x . _) x))) + (expr (assoc-ref opts 'expression)) + (system (assoc-ref opts 'system)) + + (transform (lambda (obj) + (home-environment-with-provenance obj file))) + + (home-environment + (transform + (ensure-home-environment + (or file expr) + (cond + ((and expr file) + (leave + (G_ "both file and expression cannot be specified~%"))) + (expr + (read/eval expr)) + (file + (load* file %user-module + #:on-error (assoc-ref opts 'on-error))) + (else + (leave (G_ "no configuration specified~%"))))))) + + (dry? (assoc-ref opts 'dry-run?))) + + (with-store store + (set-build-options-from-command-line store opts) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:verbosity + (verbosity-level opts) + #:dry-run? + (assoc-ref opts 'dry-run?)) + + (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + + (case action + (else + (perform-action action home-environment + #:dry-run? dry? + #:derivations-only? (assoc-ref opts 'derivations-only?) + #:use-substitutes? (assoc-ref opts 'substitutes?)) + )))))) + (warn-about-disk-space))) + + +(define (process-command command args opts) + "Process COMMAND, one of the 'guix home' sub-commands. ARGS is its +argument list and OPTS is the option alist." + (define-syntax-rule (with-store* store exp ...) + (with-store store + (set-build-options-from-command-line store opts) + exp ...)) + (case command + ;; The following commands do not need to use the store, and they do not need + ;; an home environment file. + ((search) + (apply search args)) + ((import) + (let* ((profiles (delete-duplicates + (match (filter-map (match-lambda + (('profile . p) p) + (_ #f)) + opts) + (() (list %current-profile)) + (lst (reverse lst))))) + (manifest (concatenate-manifests + (map profile-manifest profiles))) + (destination (match args + ((destination) destination) + (_ (leave (G_ "wrong number of arguments~%")))))) + (unless (file-exists? destination) + (mkdir-p destination)) + (call-with-output-file + (string-append destination "/home-configuration.scm") + (cut import-manifest manifest destination <>)) + (info (G_ "'~a' populated with all the Home configuration files~%") + destination) + (display-hint (format #f (G_ "\ +Run @command{guix home reconfigure ~a/home-configuration.scm} to effectively +deploy the home environment described by these files.\n") + destination)))) + ((describe) + (match (generation-number %guix-home) + (0 + (error (G_ "no home environment generation, nothing to describe~%"))) + (generation + (display-home-environment-generation generation)))) + ((list-generations) + (let ((pattern (match args + (() #f) + ((pattern) pattern) + (x (leave (G_ "wrong number of arguments~%")))))) + (list-generations pattern))) + ((switch-generation) + (let ((pattern (match args + ((pattern) pattern) + (x (leave (G_ "wrong number of arguments~%")))))) + (with-store* store + (switch-to-home-environment-generation store pattern)))) + ((roll-back) + (let ((pattern (match args + (() "") + (x (leave (G_ "wrong number of arguments~%")))))) + (with-store* store + (roll-back-home-environment store)))) + ((delete-generations) + (let ((pattern (match args + (() #f) + ((pattern) pattern) + (x (leave (G_ "wrong number of arguments~%")))))) + (with-store* + store + (delete-matching-generations store %guix-home pattern)))) + (else (process-action command args opts)))) + +(define-command (guix-home . args) + (synopsis "build and deploy home environments") + + (define (parse-sub-command arg result) + ;; Parse sub-command ARG and augment RESULT accordingly. + (if (assoc-ref result 'action) + (alist-cons 'argument arg result) + (let ((action (string->symbol arg))) + (case action + ((build + reconfigure + extension-graph shepherd-graph + list-generations describe + delete-generations roll-back + switch-generation search + import) + (alist-cons 'action action result)) + (else (leave (G_ "~a: unknown action~%") action)))))) + + (define (match-pair car) + ;; Return a procedure that matches a pair with CAR. + (match-lambda + ((head . tail) + (and (eq? car head) tail)) + (_ #f))) + + (define (option-arguments opts) + ;; Extract the plain arguments from OPTS. + (let* ((args (reverse (filter-map (match-pair 'argument) opts))) + (count (length args)) + (action (assoc-ref opts 'action)) + (expr (assoc-ref opts 'expression))) + (define (fail) + (leave (G_ "wrong number of arguments for action '~a'~%") + action)) + + (unless action + (format (current-error-port) + (G_ "guix home: missing command name~%")) + (format (current-error-port) + (G_ "Try 'guix home --help' for more information.~%")) + (exit 1)) + + (case action + ((build reconfigure) + (unless (or (= count 1) + (and expr (= count 0))) + (fail))) + ((init) + (unless (= count 2) + (fail)))) + args)) + + (with-error-handling + (let* ((opts (parse-command-line args %options + (list %default-options) + #:argument-handler + parse-sub-command)) + (args (option-arguments opts)) + (command (assoc-ref opts 'action))) + (parameterize ((%graft? (assoc-ref opts 'graft?))) + (with-status-verbosity (verbosity-level opts) + (process-command command args opts)))))) + + +;;; +;;; Searching. +;;; + +(define service-type-name* + (compose symbol->string service-type-name)) + +(define (service-type-description-string type) + "Return the rendered and localised description of TYPE, a service type." + (and=> (service-type-description type) + (compose texi->plain-text P_))) + +(define %service-type-metrics + ;; Metrics used to estimate the relevance of a search result. + `((,service-type-name* . 3) + (,service-type-description-string . 2) + (,(lambda (type) + (match (and=> (service-type-location type) location-file) + ((? string? file) + (basename file ".scm")) + (#f + ""))) + . 1))) + +(define (find-service-types regexps) + "Return a list of service type/score pairs: service types whose name or +description matches REGEXPS sorted by relevance, and their score." + (let ((matches (fold-home-service-types + (lambda (type result) + (match (relevance type regexps + %service-type-metrics) + ((? zero?) + result) + (score + (cons (cons type score) result)))) + '()))) + (sort matches + (lambda (m1 m2) + (match m1 + ((type1 . score1) + (match m2 + ((type2 . score2) + (if (= score1 score2) + (string>? (service-type-name* type1) + (service-type-name* type2)) + (> score1 score2)))))))))) + +(define (search . args) + (with-error-handling + (let* ((regexps (map (cut make-regexp* <> regexp/icase) args)) + (matches (find-service-types regexps))) + (leave-on-EPIPE + (display-search-results matches (current-output-port) + #:print service-type->recutils + #:command "guix home search"))))) + + +;;; +;;; Generations. +;;; + +(define* (display-home-environment-generation + number + #:optional (profile %guix-home)) + "Display a summary of home-environment generation NUMBER in a +human-readable format." + (define (display-channel channel) + (format #t " ~a:~%" (channel-name channel)) + (format #t (G_ " repository URL: ~a~%") (channel-url channel)) + (when (channel-branch channel) + (format #t (G_ " branch: ~a~%") (channel-branch channel))) + (format #t (G_ " commit: ~a~%") + (if (supports-hyperlinks?) + (channel-commit-hyperlink channel) + (channel-commit channel)))) + + (unless (zero? number) + (let* ((generation (generation-file-name profile number))) + (define-values (channels config-file) + ;; The function will work for home environments too, we just + ;; need to keep provenance file. + (system-provenance generation)) + + (display-generation profile number) + (format #t (G_ " file name: ~a~%") generation) + (format #t (G_ " canonical file name: ~a~%") (readlink* generation)) + ;; TRANSLATORS: Please preserve the two-space indentation. + + (unless (null? channels) + ;; TRANSLATORS: Here "channel" is the same terminology as used in + ;; "guix describe" and "guix pull --channels". + (format #t (G_ " channels:~%")) + (for-each display-channel channels)) + (when config-file + (format #t (G_ " configuration file: ~a~%") + (if (supports-hyperlinks?) + (file-hyperlink config-file) + config-file)))))) + +(define* (list-generations pattern #:optional (profile %guix-home)) + "Display in a human-readable format all the home environment +generations matching PATTERN, a string. When PATTERN is #f, display +all the home environment generations." + (cond ((not (file-exists? profile)) ; XXX: race condition + (raise (condition (&profile-not-found-error + (profile profile))))) + ((not pattern) + (for-each display-home-environment-generation (profile-generations profile))) + ((matching-generations pattern profile) + => + (lambda (numbers) + (if (null-list? numbers) + (exit 1) + (leave-on-EPIPE + (for-each display-home-environment-generation numbers))))))) + + +;;; +;;; Switch generations. +;;; + +;; TODO: Make it public in (guix scripts system) +(define-syntax-rule (unless-file-not-found exp) + (catch 'system-error + (lambda () + exp) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args))))) + +(define (switch-to-home-environment-generation store spec) + "Switch the home-environment profile to the generation specified by +SPEC. STORE is an open connection to the store." + (let* ((number (relative-generation-spec->number %guix-home spec)) + (generation (generation-file-name %guix-home number)) + (activate (string-append generation "/activate"))) + (if number + (begin + (setenv "GUIX_NEW_HOME" (readlink generation)) + (switch-to-generation* %guix-home number) + (unless-file-not-found (primitive-load activate)) + (setenv "GUIX_NEW_HOME" #f)) + (leave (G_ "cannot switch to home environment generation '~a'~%") spec)))) + + +;;; +;;; Roll-back. +;;; + +(define (roll-back-home-environment store) + "Roll back the home-environment profile to its previous generation. +STORE is an open connection to the store." + (switch-to-home-environment-generation store "-1")) diff --git a/guix/scripts/home/import.scm b/guix/scripts/home/import.scm new file mode 100644 index 0000000000..fbf89069a7 --- /dev/null +++ b/guix/scripts/home/import.scm @@ -0,0 +1,186 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Andrew Tropin <andrew@trop.in> +;;; Copyright © 2021 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 home import) + #:use-module (guix profiles) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix packages) + #:autoload (guix scripts package) (manifest-entry-version-prefix) + #:use-module (gnu packages) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (ice-9 popen) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (import-manifest + + ;; For tests. + manifest+configuration-files->code)) + +;;; Commentary: +;;; +;;; This module provides utilities for generating home service +;;; configurations from existing "dotfiles". +;;; +;;; Code: + +(define (basename+remove-dots file-name) + "Remove the dot from the dotfile FILE-NAME; replace the other dots in +FILE-NAME with \"-\", and return the basename of it." + (string-map (match-lambda + (#\. #\-) + (c c)) + (let ((base (basename file-name))) + (if (string-prefix? "." base) + (string-drop base 1) + base)))) + +(define (generate-bash-configuration+modules destination-directory) + (define (destination-append path) + (string-append destination-directory "/" path)) + + (define (bash-alias->pair line) + (if (string-prefix? "alias" line) + (let ((matched (string-match "alias (.+)=\"?'?([^\"']+)\"?'?" line))) + `(,(match:substring matched 1) . ,(match:substring matched 2))) + '())) + + (define (parse-aliases input) + (let loop ((line (read-line input)) + (result '())) + (if (eof-object? line) + (reverse result) + (loop (read-line input) + (cons (bash-alias->pair line) result))))) + + (let ((rc (destination-append ".bashrc")) + (profile (destination-append ".bash_profile")) + (logout (destination-append ".bash_logout"))) + `((service home-bash-service-type + (home-bash-configuration + ,@(if (file-exists? rc) + `((aliases + ',(let* ((port (open-pipe* OPEN_READ "bash" "-i" "-c" "alias")) + (alist (parse-aliases port))) + (close-port port) + (filter (negate null?) alist)))) + '()) + ,@(if (file-exists? rc) + `((bashrc + (list (local-file ,rc + ,(basename+remove-dots rc))))) + '()) + ,@(if (file-exists? profile) + `((bash-profile + (list (local-file ,profile + ,(basename+remove-dots profile))))) + '()) + ,@(if (file-exists? logout) + `((bash-logout + (list (local-file ,logout + ,(basename+remove-dots logout))))) + '()))) + (guix gexp) + (gnu home services shells)))) + +(define %files+configurations-alist + `((".bashrc" . ,generate-bash-configuration+modules) + (".bash_profile" . ,generate-bash-configuration+modules) + (".bash_logout" . ,generate-bash-configuration+modules))) + +(define (configurations+modules configuration-directory) + "Return a list of procedures which when called, generate code for a home +service declaration. Copy configuration files to CONFIGURATION-DIRECTORY; the +generated service declarations will refer to those files that have been saved +in CONFIGURATION-DIRECTORY." + (define configurations + (delete-duplicates + (filter-map (match-lambda + ((file . proc) + (let ((absolute-path (string-append (getenv "HOME") + "/" file))) + (and (file-exists? absolute-path) + (begin + (copy-file absolute-path + (string-append + configuration-directory "/" file)) + proc))))) + %files+configurations-alist) + eq?)) + + (map (lambda (proc) (proc configuration-directory)) configurations)) + +(define (manifest+configuration-files->code manifest + configuration-directory) + "Read MANIFEST and the user's configuration files listed in +%FILES+CONFIGURATIONS-ALIST, and return a 'home-environment' sexp. Copy the +user's files to CONFIGURATION-DIRECTORY; the generated sexp refers to them." + (match (manifest->code manifest + #:entry-package-version + manifest-entry-version-prefix) + (('begin ('use-modules profile-modules ...) + definitions ... ('packages->manifest packages)) + (match (configurations+modules configuration-directory) + (((services . modules) ...) + `(begin + (use-modules (gnu home) + (gnu packages) + (gnu services) + ,@(delete-duplicates + (append profile-modules (concatenate modules)))) + + ,@definitions + + (home-environment + (packages ,packages) + (services (list ,@services))))))) + (('begin ('specifications->manifest packages)) + (match (configurations+modules configuration-directory) + (((services . modules) ...) + `(begin + (use-modules (gnu home) + (gnu packages) + (gnu services) + ,@(delete-duplicates (concatenate modules))) + + (home-environment + (packages (map specification->package ,packages)) + (services (list ,@services))))))))) + +(define* (import-manifest + manifest destination-directory + #:optional (port (current-output-port))) + "Write to PORT a <home-environment> corresponding to MANIFEST." + (match (manifest+configuration-files->code manifest + destination-directory) + (('begin exp ...) + (format port (G_ "\ +;; This \"home-environment\" file can be passed to 'guix home reconfigure' +;; to reproduce the content of your profile. This is \"symbolic\": it only +;; specifies package names. To reproduce the exact same profile, you also +;; need to capture the channels being used, as returned by \"guix describe\". +;; See the \"Replicating Guix\" section in the manual.\n")) + (for-each (lambda (exp) + (newline port) + (pretty-print exp port)) + exp)))) diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index 3e4b038cc4..2934d4300a 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -27,8 +27,8 @@ #:use-module (guix import utils) #:use-module (guix scripts import) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-cran)) @@ -98,21 +98,24 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (reverse opts)))) (parameterize ((%input-style (assoc-ref opts 'style))) (match args - ((package-name) - (if (assoc-ref opts 'recursive) - ;; Recursive import - (with-error-handling - (map package->definition - (filter identity - (cran-recursive-import package-name - #:repo (or (assoc-ref opts 'repo) 'cran))))) - ;; Single import - (let ((sexp (cran->guix-package package-name - #:repo (or (assoc-ref opts 'repo) 'cran)))) - (unless sexp - (leave (G_ "failed to download description for package '~a'~%") - package-name)) - sexp))) + ((spec) + (let ((name version (package-name->name+version spec))) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (with-error-handling + (map package->definition + (filter identity + (cran-recursive-import name + #:version version + #:repo (or (assoc-ref opts 'repo) 'cran))))) + ;; Single import + (let ((sexp (cran->guix-package name + #:version version + #:repo (or (assoc-ref opts 'repo) 'cran)))) + (unless sexp + (leave (G_ "failed to download description for package '~a'~%") + name)) + sexp)))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/import/egg.scm b/guix/scripts/import/egg.scm index 829cdc2ca0..6a9657d12c 100644 --- a/guix/scripts/import/egg.scm +++ b/guix/scripts/import/egg.scm @@ -26,6 +26,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-egg)) @@ -83,21 +84,24 @@ Import and convert the egg package for PACKAGE-NAME.\n")) (_ #f)) (reverse opts)))) (match args - ((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)) - (egg-recursive-import package-name)) - ;; Single import - (let ((sexp (egg->guix-package package-name))) - (unless sexp - (leave (G_ "failed to download meta-data for package '~a'~%") - package-name)) - sexp))) + ((spec) + (let ((name version (package-name->name+version spec))) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (egg-recursive-import name version)) + ;; Single import + (let ((sexp (egg->guix-package name version))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + (if version + (string-append name "@" version) + name))) + sexp)))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/import/pypi.scm b/guix/scripts/import/pypi.scm index 9170a0b359..a52cd95c93 100644 --- a/guix/scripts/import/pypi.scm +++ b/guix/scripts/import/pypi.scm @@ -27,6 +27,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-pypi)) @@ -83,21 +84,22 @@ Import and convert the PyPI package for PACKAGE-NAME.\n")) (_ #f)) (reverse opts)))) (match args - ((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)) - (pypi-recursive-import package-name)) - ;; Single import - (let ((sexp (pypi->guix-package package-name))) - (unless sexp - (leave (G_ "failed to download meta-data for package '~a'~%") - package-name)) - sexp))) + ((spec) + (let ((name version (package-name->name+version spec))) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (pypi-recursive-import name version)) + ;; Single import + (let ((sexp (pypi->guix-package name #:version version))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + name)) + sexp)))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/import/texlive.scm b/guix/scripts/import/texlive.scm index 6f0818e274..4aeaa79eef 100644 --- a/guix/scripts/import/texlive.scm +++ b/guix/scripts/import/texlive.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017, 2021 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. @@ -43,8 +43,6 @@ (display (G_ "Usage: guix import texlive PACKAGE-NAME Import and convert the Texlive package for PACKAGE-NAME.\n")) (display (G_ " - -a, --archive=ARCHIVE specify the archive repository")) - (display (G_ " -h, --help display this help and exit")) (display (G_ " -V, --version display version information and exit")) @@ -60,10 +58,6 @@ Import and convert the Texlive package for PACKAGE-NAME.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix import texlive"))) - (option '(#\a "archive") #t #f - (lambda (opt name arg result) - (alist-cons 'component arg - (alist-delete 'component result)))) %standard-import-options)) @@ -84,13 +78,11 @@ Import and convert the Texlive package for PACKAGE-NAME.\n")) (_ #f)) (reverse opts)))) (match args - ((package-name) - (let ((sexp (texlive->guix-package package-name - (or (assoc-ref opts 'component) - "latex")))) + ((name) + (let ((sexp (texlive->guix-package name))) (unless sexp (leave (G_ "failed to download description for package '~a'~%") - package-name)) + name)) sexp)) (() (leave (G_ "too few arguments~%"))) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 835078cb97..9ddf458c13 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014-2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu> @@ -20,21 +20,26 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix scripts offload) - #:use-module (ssh key) - #:use-module (ssh auth) - #:use-module (ssh session) - #:use-module (ssh channel) - #:use-module (ssh popen) - #:use-module (ssh version) + #:autoload (ssh key) (private-key-from-file + public-key-from-file) + #:autoload (ssh auth) (userauth-public-key!) + #:autoload (ssh session) (make-session + connect! get-error + disconnect! session-set!) + #:autoload (ssh version) (zlib-support?) #:use-module (guix config) #:use-module (guix records) - #:use-module (guix ssh) + #:autoload (guix ssh) (authenticate-server* + connect-to-remote-daemon + send-files retrieve-files retrieve-files* + remote-inferior report-guile-error) #:use-module (guix store) - #:use-module (guix inferior) - #:use-module (guix derivations) - #:use-module ((guix serialization) - #:select (nar-error? nar-error-file)) - #:use-module (guix nar) + #:autoload (guix inferior) (inferior-eval close-inferior inferior?) + #:autoload (guix derivations) (read-derivation-from-file + derivation-file-name + build-derivations) + #:autoload (guix serialization) (nar-error? nar-error-file) + #:autoload (guix nar) (restore-file-set) #:use-module ((guix utils) #:select (%current-system)) #:use-module ((guix build syscalls) #:select (fcntl-flock set-thread-name)) @@ -47,12 +52,10 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) - #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 format) - #:use-module (ice-9 binary-ports) #:export (build-machine build-machine? build-machine-name @@ -560,6 +563,15 @@ expired." If TIMEOUT is #f, simply evaluate EXP..." (call-with-timeout timeout drv (lambda () exp ...))) +(define (check-ssh-zlib-support) + "Warn once if libssh lacks zlib support." + ;; We rely on protocol-level compression from libssh to optimize large data + ;; transfers. Warn if it's missing. + (unless (zlib-support?) + (warning (G_ "Guile-SSH lacks zlib support")) + (warning (G_ "data transfers will *not* be compressed!"))) + (set! check-ssh-zlib-support (const #t))) + (define* (process-request wants-local? system drv features #:key print-build-trace? (max-silent-time 3600) @@ -584,7 +596,9 @@ If TIMEOUT is #f, simply evaluate EXP..." (lambda () ;; Offload DRV to MACHINE. (display "# accept\n") - (let ((inputs (string-tokenize (read-line))) + (check-ssh-zlib-support) + (let ((drv (read-derivation-from-file drv)) + (inputs (string-tokenize (read-line))) (outputs (string-tokenize (read-line)))) ;; Even if BUILD-TIMEOUT is honored by MACHINE, there can ;; be issues with the connection or deadlocks that could @@ -782,12 +796,6 @@ machine." (and=> (passwd:dir (getpw (getuid))) (cut setenv "HOME" <>)) - ;; We rely on protocol-level compression from libssh to optimize large data - ;; transfers. Warn if it's missing. - (unless (zlib-support?) - (warning (G_ "Guile-SSH lacks zlib support")) - (warning (G_ "data transfers will *not* be compressed!"))) - (match args ((system max-silent-time print-build-trace? build-timeout) (let ((max-silent-time (string->number max-silent-time)) @@ -803,8 +811,7 @@ machine." (with-error-handling (process-request (equal? (match:substring match 1) "1") (match:substring match 2) ; system - (read-derivation-from-file - (match:substring match 3)) + (match:substring match 3) (string-tokenize (match:substring match 4) not-coma) #:print-build-trace? print-build-trace? diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index a34ecdcb54..4b9c5f210d 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -68,6 +68,7 @@ guix-package search-path-environment-variables + manifest-entry-version-prefix transaction-upgrade-entry ;mostly for testing @@ -327,31 +328,35 @@ Alternately, see @command{guix package --search-paths -p ~s}.") ;;; Export a manifest. ;;; +(define (manifest-entry-version-prefix entry) + "Search among all the versions of ENTRY's package that are available, and +return the shortest unambiguous version prefix for this package. If only one +version of ENTRY's package is available, return the empty string." + (let ((name (manifest-entry-name entry))) + (match (map package-version (find-packages-by-name name)) + ((_) + ;; A single version of NAME is available, so do not specify the + ;; version number, even if the available version doesn't match ENTRY. + "") + (versions + ;; If ENTRY uses the latest version, don't specify any version. + ;; Otherwise return the shortest unique version prefix. Note that + ;; this is based on the currently available packages, which could + ;; differ from the packages available in the revision that was used + ;; to build MANIFEST. + (let ((current (manifest-entry-version entry))) + (if (every (cut version>? current <>) + (delete current versions)) + "" + (version-unique-prefix (manifest-entry-version entry) + versions))))))) + (define* (export-manifest manifest #:optional (port (current-output-port))) "Write to PORT a manifest corresponding to MANIFEST." - (define (version-spec entry) - (let ((name (manifest-entry-name entry))) - (match (map package-version (find-packages-by-name name)) - ((_) - ;; A single version of NAME is available, so do not specify the - ;; version number, even if the available version doesn't match ENTRY. - "") - (versions - ;; If ENTRY uses the latest version, don't specify any version. - ;; Otherwise return the shortest unique version prefix. Note that - ;; this is based on the currently available packages, which could - ;; differ from the packages available in the revision that was used - ;; to build MANIFEST. - (let ((current (manifest-entry-version entry))) - (if (every (cut version>? current <>) - (delete current versions)) - "" - (version-unique-prefix (manifest-entry-version entry) - versions))))))) - (match (manifest->code manifest - #:entry-package-version version-spec) + #:entry-package-version + manifest-entry-version-prefix) (('begin exp ...) (format port (G_ "\ ;; This \"manifest\" file can be passed to 'guix package -m' to reproduce diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 25846b7dc2..6e2b4368da 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -25,6 +25,7 @@ #:use-module ((system repl server) #:prefix repl:) #:use-module (ice-9 binary-ports) #:use-module (ice-9 format) + #:use-module (ice-9 iconv) #:use-module (ice-9 match) #:use-module (ice-9 poll) #:use-module (ice-9 regex) @@ -400,15 +401,18 @@ appropriate duration. NAR-PATH specifies the prefix for nar URLs." (let ((store-path (hash-part->path store hash))) (if (string-null? store-path) (not-found request #:phrase "" #:ttl negative-ttl) - (values `((content-type . (application/x-nix-narinfo)) + (values `((content-type . (application/x-nix-narinfo + (charset . "UTF-8"))) + (x-nar-path . ,nar-path) + (x-narinfo-compressions . ,compressions) ,@(if ttl `((cache-control (max-age . ,ttl))) '())) - (cut display - (narinfo-string store store-path - #:nar-path nar-path - #:compressions compressions) - <>))))) + ;; Do not call narinfo-string directly here as it is an + ;; expensive call that could potentially block the main + ;; thread. Instead, create the narinfo string in the + ;; http-write procedure. + store-path)))) (define* (nar-cache-file directory item #:key (compression %no-compression)) @@ -663,19 +667,38 @@ requested using POOL." (link narinfo other))) others)))))) +(define (compression->sexp compression) + "Return the SEXP representation of COMPRESSION." + (match compression + (($ <compression> type level) + `(compression ,type ,level)))) + +(define (sexp->compression sexp) + "Turn the given SEXP into a <compression> record and return it." + (match sexp + (('compression type level) + (compression type level)))) + ;; XXX: Declare the 'X-Nar-Compression' HTTP header, which is in fact for ;; internal consumption: it allows us to pass the compression info to ;; 'http-write', as part of the workaround to <http://bugs.gnu.org/21093>. (declare-header! "X-Nar-Compression" (lambda (str) - (match (call-with-input-string str read) - (('compression type level) - (compression type level)))) + (sexp->compression + (call-with-input-string str read))) compression? (lambda (compression port) - (match compression - (($ <compression> type level) - (write `(compression ,type ,level) port))))) + (write (compression->sexp compression) port))) + +;; This header is used to pass the supported compressions to http-write in +;; order to format on-the-fly narinfo responses. +(declare-header! "X-Narinfo-Compressions" + (lambda (str) + (map sexp->compression + (call-with-input-string str read))) + (cut every compression? <>) + (lambda (compressions port) + (write (map compression->sexp compressions) port))) (define* (render-nar store request store-item #:key (compression %no-compression)) @@ -830,7 +853,8 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." "Return RESPONSE's headers minus 'Content-Length' and our internal headers." (fold alist-delete (response-headers response) - '(content-length x-raw-file x-nar-compression))) + '(content-length x-raw-file x-nar-compression + x-narinfo-compressions x-nar-path))) (define (sans-content-length response) "Return RESPONSE without its 'content-length' header." @@ -964,6 +988,38 @@ blocking." (unless keep-alive? (close-port client))) (values)))))) + (('application/x-nix-narinfo . _) + (let ((compressions (assoc-ref (response-headers response) + 'x-narinfo-compressions)) + (nar-path (assoc-ref (response-headers response) + 'x-nar-path))) + (if nar-path + (begin + (when (keep-alive? response) + (keep-alive client)) + (call-with-new-thread + (lambda () + (set-thread-name "publish narinfo") + (let* ((narinfo + (with-store store + (narinfo-string store (utf8->string body) + #:nar-path nar-path + #:compressions compressions))) + (narinfo-bv (string->bytevector narinfo "UTF-8")) + (narinfo-length + (bytevector-length narinfo-bv)) + (response (write-response + (with-content-length response + narinfo-length) + client)) + (output (response-port response))) + (configure-socket client) + (put-bytevector output narinfo-bv) + (force-output output) + (unless (keep-alive? response) + (close-port output)) + (values))))) + (%http-write server client response body)))) (_ (match (assoc-ref (response-headers response) 'x-raw-file) ((? string? file) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index fb6c52a567..8806f0f740 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> @@ -329,23 +329,39 @@ warn about packages that have no matching updater." (package-version package) version) (for-each (lambda (change) - (format (current-error-port) - (match (list (upstream-input-change-action change) - (upstream-input-change-type change)) - (('add 'regular) - (G_ "~a: consider adding this input: ~a~%")) - (('add 'native) - (G_ "~a: consider adding this native input: ~a~%")) - (('add 'propagated) - (G_ "~a: consider adding this propagated input: ~a~%")) - (('remove 'regular) - (G_ "~a: consider removing this input: ~a~%")) - (('remove 'native) - (G_ "~a: consider removing this native input: ~a~%")) - (('remove 'propagated) - (G_ "~a: consider removing this propagated input: ~a~%"))) - (package-name package) - (upstream-input-change-name change))) + (define field + (match (upstream-input-change-type change) + ('native 'native-inputs) + ('propagated 'propagated-inputs) + (_ 'inputs))) + + (define name + (package-name package)) + (define loc + (package-field-location package field)) + (define change-name + (upstream-input-change-name change)) + + (match (list (upstream-input-change-action change) + (upstream-input-change-type change)) + (('add 'regular) + (info loc (G_ "~a: consider adding this input: ~a~%") + name change-name)) + (('add 'native) + (info loc (G_ "~a: consider adding this native input: ~a~%") + name change-name)) + (('add 'propagated) + (info loc (G_ "~a: consider adding this propagated input: ~a~%") + name change-name)) + (('remove 'regular) + (info loc (G_ "~a: consider removing this input: ~a~%") + name change-name)) + (('remove 'native) + (info loc (G_ "~a: consider removing this native input: ~a~%") + name change-name)) + (('remove 'propagated) + (info loc (G_ "~a: consider removing this propagated input: ~a~%") + name change-name)))) (upstream-source-input-changes source)) (let ((hash (call-with-input-file tarball port-sha256))) diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm new file mode 100644 index 0000000000..546639818f --- /dev/null +++ b/guix/scripts/shell.scm @@ -0,0 +1,399 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 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 shell) + #:use-module (guix ui) + #:use-module ((guix diagnostics) #:select (location)) + #:use-module (guix scripts environment) + #:autoload (guix scripts build) (show-build-options-help) + #:autoload (guix transformations) (show-transformation-options-help) + #:use-module (guix scripts) + #:use-module (guix packages) + #:use-module (guix profiles) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) + #:use-module (ice-9 match) + #:autoload (ice-9 rdelim) (read-line) + #:autoload (guix base32) (bytevector->base32-string) + #:autoload (rnrs bytevectors) (string->utf8) + #:autoload (guix utils) (config-directory cache-directory) + #:autoload (guix describe) (current-channels) + #:autoload (guix channels) (channel-commit) + #:autoload (gcrypt hash) (sha256) + #:use-module ((guix build utils) #:select (mkdir-p)) + #:use-module (guix cache) + #:use-module ((ice-9 ftw) #:select (scandir)) + #:export (guix-shell)) + +(define (show-help) + (display (G_ "Usage: guix shell [OPTION] PACKAGES... [-- COMMAND...] +Build an environment that includes PACKAGES and execute COMMAND or an +interactive shell in that environment.\n")) + (newline) + + ;; These two options differ from 'guix environment'. + (display (G_ " + -D, --development include the development inputs of the next package")) + (display (G_ " + -f, --file=FILE add to the environment the package FILE evaluates to")) + (display (G_ " + -q inhibit loading of 'guix.scm' and 'manifest.scm'")) + (display (G_ " + --rebuild-cache rebuild cached environment, if any")) + + (show-environment-options-help) + (newline) + (show-build-options-help) + (newline) + (show-transformation-options-help) + (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 (tag-package-arg opts arg) + "Return a two-element list with the form (TAG ARG) that tags ARG with either +'ad-hoc' in OPTS has the 'ad-hoc?' key set to #t, or 'inputs' otherwise." + (if (assoc-ref opts 'ad-hoc?) + `(ad-hoc-package ,arg) + `(package ,arg))) + +(define (ensure-ad-hoc alist) + (if (assq-ref alist 'ad-hoc?) + alist + `((ad-hoc? . #t) ,@alist))) + +(define (wrapped-option opt) + "Wrap OPT, a SRFI-37 option, such that its processor always adds the +'ad-hoc?' flag to the resulting alist." + (option (option-names opt) + (option-required-arg? opt) + (option-optional-arg? opt) + (compose ensure-ad-hoc (option-processor opt)))) + +(define %options + ;; Specification of the command-line options. + (let ((to-remove '("ad-hoc" "inherit" "load" "help" "version"))) + (append + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix shell"))) + + (option '(#\D "development") #f #f + (lambda (opt name arg result) + ;; Temporarily remove the 'ad-hoc?' flag from result. + ;; The next option will put it back thanks to + ;; 'wrapped-option'. + (alist-delete 'ad-hoc? result))) + + ;; For consistency with 'guix package', support '-f' rather than + ;; '-l' like 'guix environment' does. + (option '(#\f "file") #t #f + (lambda (opt name arg result) + (alist-cons 'load (tag-package-arg result arg) + (ensure-ad-hoc result)))) + (option '(#\q) #f #f + (lambda (opt name arg result) + (alist-cons 'explicit-loading? #t result))) + (option '("rebuild-cache") #f #f + (lambda (opt name arg result) + (alist-cons 'rebuild-cache? #t result)))) + (filter-map (lambda (opt) + (and (not (any (lambda (name) + (member name to-remove)) + (option-names opt))) + (wrapped-option opt))) + %environment-options)))) + +(define %default-options + `((ad-hoc? . #t) ;always true + ,@%environment-default-options)) + +(define (parse-args args) + "Parse the list of command line arguments ARGS." + (define (handle-argument arg result) + (alist-cons 'package (tag-package-arg result arg) + (ensure-ad-hoc result))) + + ;; The '--' token is used to separate the command to run from the rest of + ;; the operands. + (let ((args command (break (cut string=? "--" <>) args))) + (let ((opts (parse-command-line args %options (list %default-options) + #:argument-handler handle-argument))) + (options-with-caching + (auto-detect-manifest + (match command + (() opts) + (("--") opts) + (("--" command ...) (alist-cons 'exec command opts)))))))) + +(define (find-file-in-parent-directories candidates) + "Find one of CANDIDATES in the current directory or one of its ancestors." + (define start (getcwd)) + (define device (stat:dev (stat start))) + + (let loop ((directory start)) + (let ((stat (stat directory))) + (and (= (stat:uid stat) (getuid)) + (= (stat:dev stat) device) + (or (any (lambda (candidate) + (let ((candidate (string-append directory "/" candidate))) + (and (file-exists? candidate) candidate))) + candidates) + (and (not (string=? directory "/")) + (loop (dirname directory)))))))) ;lexical ".." resolution + +(define (authorized-directory-file) + "Return the name of the file listing directories for which 'guix shell' may +automatically load 'guix.scm' or 'manifest.scm' files." + (string-append (config-directory) "/shell-authorized-directories")) + +(define (authorized-shell-directory? directory) + "Return true if DIRECTORY is among the authorized directories for automatic +loading. The list of authorized directories is read from +'authorized-directory-file'; each line must be either: an absolute file name, +a hash-prefixed comment, or a blank line." + (catch 'system-error + (lambda () + (call-with-input-file (authorized-directory-file) + (lambda (port) + (let loop () + (match (read-line port) + ((? eof-object?) #f) + ((= string-trim line) + (cond ((string-prefix? "#" line) ;comment + (loop)) + ((string-prefix? "/" line) ;absolute file name + (or (string=? line directory) + (loop))) + ((string-null? (string-trim-right line)) ;blank line + (loop)) + (else ;bogus line + (let ((loc (location (port-filename port) + (port-line port) + (port-column port)))) + (warning loc (G_ "ignoring invalid file name: '~a'~%") + line)))))))))) + (const #f))) + +(define (options-with-caching opts) + "If OPTS contains exactly one 'load' or one 'manifest' key, automatically +add a 'profile' key (when a profile for that file is already in cache) or a +'gc-root' key (to add the profile to cache)." + (define (single-file-for-caching opts) + (let loop ((opts opts) + (file #f)) + (match opts + (() file) + ((('package . _) . _) #f) + ((('load . ('package candidate)) . rest) + (and (not file) (loop rest candidate))) + ((('manifest . candidate) . rest) + (and (not file) (loop rest candidate))) + ((('expression . _) . _) #f) + ((_ . rest) (loop rest file))))) + + ;; Check whether there's a single 'load' or 'manifest' option. When that is + ;; the case, arrange to automatically cache the resulting profile. + (match (single-file-for-caching opts) + (#f opts) + (file + (let* ((root (profile-cached-gc-root file)) + (stat (and root (false-if-exception (lstat root))))) + (if (and (not (assoc-ref opts 'rebuild-cache?)) + stat + (<= (stat:mtime ((@ (guile) stat) file)) + (stat:mtime stat))) + (let ((now (current-time))) + ;; Update the atime on ROOT to reflect usage. + (utime root + now (stat:mtime stat) 0 (stat:mtimensec stat) + AT_SYMLINK_NOFOLLOW) + (alist-cons 'profile root + (remove (match-lambda + (('load . _) #t) + (('manifest . _) #t) + (_ #f)) + opts))) ;load right away + (if (and root (not (assq-ref opts 'gc-root))) + (begin + (if stat + (delete-file root) + (mkdir-p (dirname root))) + (alist-cons 'gc-root root opts)) + opts)))))) + +(define (auto-detect-manifest opts) + "If OPTS do not specify packages or a manifest, load a \"guix.scm\" or +\"manifest.scm\" file from the current directory or one of its ancestors. +Return the modified OPTS." + (define (options-contain-payload? opts) + (match opts + (() #f) + ((('package . _) . _) #t) + ((('load . _) . _) #t) + ((('manifest . _) . _) #t) + ((('expression . _) . _) #t) + ((_ . rest) (options-contain-payload? rest)))) + + (define interactive? + (not (assoc-ref opts 'exec))) + + (define disallow-implicit-load? + (assoc-ref opts 'explicit-loading?)) + + (if (or (not interactive?) + disallow-implicit-load? + (options-contain-payload? opts)) + opts + (match (find-file-in-parent-directories '("manifest.scm" "guix.scm")) + (#f + (warning (G_ "no packages specified; creating an empty environment~%")) + opts) + (file + (if (authorized-shell-directory? (dirname file)) + (begin + (info (G_ "loading environment from '~a'...~%") file) + (match (basename file) + ("guix.scm" (alist-cons 'load `(package ,file) opts)) + ("manifest.scm" (alist-cons 'manifest file opts)))) + (begin + (report-error + (G_ "not loading '~a' because not authorized to do so~%") + file) + (display-hint (format #f (G_ "To allow automatic loading of +@file{~a} when running @command{guix shell}, you must explicitly authorize its +directory, like so: + +@example +echo ~a >> ~a +@end example\n") + file + (dirname file) + (authorized-directory-file))) + (exit 1))))))) + + +;;; +;;; Profile cache. +;;; + +(define %profile-cache-directory + ;; Directory where profiles created by 'guix shell' alone (without extra + ;; options) are cached. + (make-parameter (string-append (cache-directory #:ensure? #f) + "/profiles"))) + +(define (profile-cache-key file) + "Return the cache key for the profile corresponding to FILE, a 'guix.scm' or +'manifest.scm' file, or #f if we lack channel information." + (match (current-channels) + (() #f) + (((= channel-commit commits) ...) + (let ((stat (stat file))) + (bytevector->base32-string + ;; Since FILE is not canonicalized, only include the device/inode + ;; numbers. XXX: In some rare cases involving Btrfs and NFS, this can + ;; be insufficient: <https://lwn.net/Articles/866582/>. + (sha256 (string->utf8 + (string-append (string-join commits) ":" + (number->string (stat:dev stat)) ":" + (number->string (stat:ino stat)))))))))) + +(define (profile-cached-gc-root file) + "Return the cached GC root for FILE, a 'guix.scm' or 'manifest.scm' file, or +#f if we lack information to cache it." + (match (profile-cache-key file) + (#f #f) + (key (string-append (%profile-cache-directory) "/" key)))) + + +;;; +;;; One-time hints. +;;; + +(define (hint-directory) + "Return the directory name where previously given hints are recorded." + (string-append (cache-directory #:ensure? #f) "/hints")) + +(define (hint-file hint) + "Return the name of the file that marks HINT as already printed." + (string-append (hint-directory) "/" (symbol->string hint))) + +(define (record-hint hint) + "Mark HINT as already given." + (let ((file (hint-file hint))) + (mkdir-p (dirname file)) + (close-fdes (open-fdes file (logior O_CREAT O_WRONLY))))) + +(define (hint-given? hint) + "Return true if HINT was already given." + (file-exists? (hint-file hint))) + + +(define-command (guix-shell . args) + (category development) + (synopsis "spawn one-off software environments") + + (define (cache-entries directory) + (filter-map (match-lambda + ((or "." "..") #f) + (file (string-append directory "/" file))) + (or (scandir directory) '()))) + + (define* (entry-expiration file) + ;; Return the time at which FILE, a cached profile, is considered expired. + (match (false-if-exception (lstat file)) + (#f 0) ;FILE may have been deleted in the meantime + (st (+ (stat:atime st) (* 60 60 24 7))))) + + (define opts + (parse-args args)) + + (define interactive? + (not (assoc-ref opts 'exec))) + + (if (assoc-ref opts 'check?) + (record-hint 'shell-check) + (when (and interactive? + (not (hint-given? 'shell-check)) + (not (assoc-ref opts 'container?)) + (not (assoc-ref opts 'search-paths))) + (display-hint (G_ "Consider passing the @option{--check} option once +to make sure your shell does not clobber environment variables."))) ) + + ;; Clean the cache in EXIT-HOOK so that (1) it happens after potential use + ;; of cached profiles, and (2) cleanup actually happens, even when + ;; 'guix-environment*' calls 'exit'. + (add-hook! exit-hook + (lambda _ + (maybe-remove-expired-cache-entries + (%profile-cache-directory) + cache-entries + #:entry-expiration entry-expiration))) + + (guix-environment* opts)) diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm index 3c100197a7..3b246e9c66 100644 --- a/guix/scripts/style.scm +++ b/guix/scripts/style.scm @@ -382,13 +382,33 @@ bailing out~%") package) str))) +(define (edit-expression/dry-run properties rewrite-string) + "Like 'edit-expression' but display what would be edited without actually +doing it." + (edit-expression properties + (lambda (str) + (unless (string=? (rewrite-string str) str) + (info (source-properties->location properties) + (G_ "would be edited~%"))) + str))) + +(define (absolute-location loc) + "Replace the file name in LOC by an absolute location." + (location (if (string-prefix? "/" (location-file loc)) + (location-file loc) + (search-path %load-path (location-file loc))) + (location-line loc) + (location-column loc))) + (define* (simplify-package-inputs package - #:key (policy 'silent)) + #:key (policy 'silent) + (edit-expression edit-expression)) "Edit the source code of PACKAGE to simplify its inputs field if needed. POLICY is a symbol that defines whether to simplify inputs; it can one of 'silent (change only if the resulting derivation is the same), 'safe (change only if semantics are known to be unaffected), and 'always (fearlessly -simplify inputs!)." +simplify inputs!). Call EDIT-EXPRESSION to actually edit the source of +PACKAGE." (for-each (lambda (field-name field) (match (field package) (() @@ -401,7 +421,7 @@ simplify inputs!)." #f) (location (edit-expression - (location->source-properties location) + (location->source-properties (absolute-location location)) (lambda (str) (define matches? (match policy @@ -419,7 +439,7 @@ simplify inputs!)." label-matches?)) ('always ;; Assume it's gonna be alright. - (const #f)))) + (const #t)))) (simplify-inputs location (package-name package) @@ -449,6 +469,9 @@ simplify inputs!)." (member "load-path" (option-names option))) %standard-build-options) + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t result))) (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) @@ -473,6 +496,8 @@ simplify inputs!)." (display (G_ "Usage: guix style [OPTION]... [PACKAGE]... Update package definitions to the latest style.\n")) (display (G_ " + -n, --dry-run display files that would be edited but do nothing")) + (display (G_ " -L, --load-path=DIR prepend DIR to the package module search path")) (display (G_ " -e, --expression=EXPR consider the package EXPR evaluates to")) @@ -514,14 +539,19 @@ Update package definitions to the latest style.\n")) (read/eval str)) (_ #f)) opts)) + (edit (if (assoc-ref opts 'dry-run?) + edit-expression/dry-run + edit-expression)) (policy (assoc-ref opts 'input-simplification-policy))) - (for-each (lambda (package) - (simplify-package-inputs package #:policy policy)) - ;; Sort package by source code location so that we start editing - ;; files from the bottom and going upward. That way, the - ;; 'location' field of <package> records is not invalidated as - ;; we modify files. - (sort (if (null? packages) - (fold-packages cons '() #:select? (const #t)) - packages) - (negate package-location<?))))) + (with-error-handling + (for-each (lambda (package) + (simplify-package-inputs package #:policy policy + #:edit-expression edit)) + ;; Sort package by source code location so that we start editing + ;; files from the bottom and going upward. That way, the + ;; 'location' field of <package> records is not invalidated as + ;; we modify files. + (sort (if (null? packages) + (fold-packages cons '() #:select? (const #t)) + packages) + (negate package-location<?)))))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 65eb98e4b2..1db788a534 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -64,6 +64,7 @@ (device-module-aliases matching-modules) #:use-module (gnu system linux-initrd) #:use-module (gnu image) + #:use-module (gnu platform) #:use-module (gnu system) #:use-module (gnu bootloader) #:use-module (gnu system file-systems) @@ -253,7 +254,7 @@ the ownership of '~a' may be incorrect!~%") (install-bootloader local-eval bootloader bootcfg #:target target) (return - (info (G_ "bootloader successfully installed on '~a'~%") + (info (G_ "bootloader successfully installed on~{ ~a~}~%") (bootloader-configuration-targets bootloader)))))))) @@ -688,6 +689,7 @@ checking this by themselves in their 'check' procedure." (define* (system-derivation-for-action image action #:key full-boot? + (graphic? #t) container-shared-network? mappings) "Return as a monadic value the derivation for IMAGE according to ACTION." @@ -705,6 +707,7 @@ checking this by themselves in their 'check' procedure." ((vm) (system-qemu-image/shared-store-script os #:full-boot? full-boot? + #:graphic? graphic? #:disk-image-size (if full-boot? image-size @@ -771,6 +774,7 @@ and TARGET arguments." dry-run? derivations-only? use-substitutes? target full-boot? + (graphic? #t) container-shared-network? (mappings '()) (gc-root #f)) @@ -824,6 +828,7 @@ static checks." (mlet* %store-monad ((sys (system-derivation-for-action image action #:full-boot? full-boot? + #:graphic? graphic? #:container-shared-network? container-shared-network? #:mappings mappings)) @@ -1012,6 +1017,8 @@ Some ACTIONS support additional ARGS.\n")) (display (G_ " --full-boot for 'vm', make a full boot sequence")) (display (G_ " + --no-graphic for 'vm', use the tty that we are started in for IO")) + (display (G_ " --skip-checks skip file system and initrd module safety checks")) (display (G_ " --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) @@ -1080,6 +1087,9 @@ Some ACTIONS support additional ARGS.\n")) (option '("full-boot") #f #f (lambda (opt name arg result) (alist-cons 'full-boot? #t result))) + (option '("no-graphic") #f #f + (lambda (opt name arg result) + (alist-cons 'no-graphic? #t result))) (option '("save-provenance") #f #f (lambda (opt name arg result) (alist-cons 'save-provenance? #t result))) @@ -1212,13 +1222,11 @@ resulting from command-line parsing." (base-image (if (operating-system? obj) (os->image obj #:type image-type) - obj)) - (base-target (image-target base-image))) + obj))) (image (inherit (if label (image-with-label base-image label) base-image)) - (target (or base-target target)) (size image-size) (volatile-root? volatile?)))) (os (image-operating-system image)) @@ -1267,6 +1275,7 @@ resulting from command-line parsing." #:validate-reconfigure (assoc-ref opts 'validate-reconfigure) #:full-boot? (assoc-ref opts 'full-boot?) + #:graphic? (not (assoc-ref opts 'no-graphic?)) #:container-shared-network? (assoc-ref opts 'container-shared-network?) #:mappings (filter-map (match-lambda diff --git a/guix/self.scm b/guix/self.scm index 79d93357a2..bd9a71de45 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -316,81 +316,23 @@ the result to OUTPUT." chr)) str)) - (define xref-regexp - ;; Texinfo cross-reference regexp. - (make-regexp "@(px|x)?ref\\{([^,}]+)")) - - (define (translate-cross-references texi translations) - ;; Translate the cross-references that appear in TEXI, a Texinfo - ;; file, using the msgid/msgstr pairs from TRANSLATIONS. - (define content - (call-with-input-file texi get-string-all)) - - (define matches - (list-matches xref-regexp content)) - - (define translation-map - (fold (match-lambda* - (((msgid . str) result) - (vhash-cons msgid str result))) - vlist-null - translations)) - - (define translated - ;; Iterate over MATCHES and replace cross-references with their - ;; translation found in TRANSLATION-MAP. (We can't use - ;; 'substitute*' because matches can span multiple lines.) - (let loop ((matches matches) - (offset 0) - (result '())) - (match matches - (() - (string-concatenate-reverse - (cons (string-drop content offset) result))) - ((head . tail) - (let ((prefix (match:substring head 1)) - (ref (canonicalize-whitespace (match:substring head 2)))) - (define translated - (string-append "@" (or prefix "") - "ref{" - (match (vhash-assoc ref translation-map) - (#f ref) - ((_ . str) str)))) - - (loop tail - (match:end head) - (append (list translated - (string-take - (string-drop content offset) - (- (match:start head) offset))) - result))))))) - - (format (current-error-port) - "translated ~a cross-references in '~a'~%" - (length matches) texi) - (call-with-output-file texi - (lambda (port) - (display translated port)))) - (define* (translate-texi prefix po lang #:key (extras '())) "Translate the manual for one language LANG using the PO file. PREFIX must be the prefix of the manual, 'guix' or 'guix-cookbook'. EXTRAS is a list of extra files, such as '(\"contributing\")." - (let ((translations (call-with-input-file po read-po-file))) - (for-each (lambda (file) - (translate-tmp-texi po (string-append file ".texi") - (string-append file "." lang - ".texi.tmp"))) - (cons prefix extras)) - - (for-each (lambda (file) - (let* ((texi (string-append file "." lang ".texi")) - (tmp (string-append texi ".tmp"))) - (copy-file tmp texi) - (translate-cross-references texi - translations))) - (cons prefix extras)))) + (for-each (lambda (file) + (translate-tmp-texi po (string-append file ".texi") + (string-append file "." lang + ".texi.tmp"))) + (cons prefix extras)) + + (for-each (lambda (file) + (let* ((texi (string-append file "." lang ".texi")) + (tmp (string-append texi ".tmp"))) + (copy-file tmp texi) + (translate-cross-references texi po))) + (cons prefix extras))) (define (available-translations directory domain) ;; Return the list of available translations under DIRECTORY for @@ -958,13 +900,42 @@ itself." #:guile-for-build guile-for-build)) + (define *home-modules* + (scheme-node "guix-home" + `((gnu home) + (gnu home services) + ,@(scheme-modules* source "gnu/home/services")) + (list *core-package-modules* *package-modules* + *extra-modules* *core-modules* *system-modules*) + #:extensions dependencies + #:guile-for-build guile-for-build)) + + (define *core-cli-modules* + ;; Core command-line interface modules that do not depend on (gnu system + ;; …) or (gnu home …), and not even on *PACKAGE-MODULES*. + (scheme-node "guix-cli-core" + (remove (match-lambda + (('guix 'scripts 'system . _) #t) + (('guix 'scripts 'environment) #t) + (('guix 'scripts 'container . _) #t) + (('guix 'scripts 'deploy) #t) + (('guix 'scripts 'home . _) #t) + (('guix 'scripts 'import . _) #t) + (('guix 'pack) #t) + (_ #f)) + (scheme-modules* source "guix/scripts")) + (list *core-modules* *extra-modules* + *core-package-modules*) + #:extensions dependencies + #:guile-for-build guile-for-build)) + (define *cli-modules* (scheme-node "guix-cli" (append (scheme-modules* source "/guix/scripts") `((gnu ci))) (list *core-modules* *extra-modules* *core-package-modules* *package-modules* - *system-modules*) + *core-cli-modules* *system-modules* *home-modules*) #:extensions dependencies #:guile-for-build guile-for-build)) @@ -1010,8 +981,10 @@ itself." ;; comes with *CORE-MODULES*. (list *config* *cli-modules* + *core-cli-modules* *system-test-modules* *system-modules* + *home-modules* *package-modules* *core-package-modules* *extra-modules* diff --git a/guix/status.scm b/guix/status.scm index f351a56d92..eefe18365f 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -381,6 +381,8 @@ the current build phase." (G_ "building CA certificate bundle...")) ('emacs-subdirs (G_ "listing Emacs sub-directories...")) + ('gdk-pixbuf-loaders-cache-file + (G_ "generating GdkPixbuf loaders cache...")) ('glib-schemas (G_ "generating GLib schema cache...")) ('gtk-icon-themes diff --git a/guix/store.scm b/guix/store.scm index 89a719bcfc..a93e9596d9 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1349,11 +1349,18 @@ on the build output of a previous derivation." (things unresolved-things) (continuation unresolved-continuation)) -(define (build-accumulator continue store things mode) - "This build handler accumulates THINGS and returns an <unresolved> object." - (if (= mode (build-mode normal)) - (unresolved things continue) - (continue #t))) +(define (build-accumulator expected-store) + "Return a build handler that accumulates THINGS and returns an <unresolved> +object, only for build requests on EXPECTED-STORE." + (lambda (continue store things mode) + ;; Note: Do not compare STORE and EXPECTED-STORE with 'eq?' because + ;; 'cache-object-mapping' and similar functional "setters" change the + ;; store's object identity. + (if (and (eq? (store-connection-socket store) + (store-connection-socket expected-store)) + (= mode (build-mode normal))) + (unresolved things continue) + (continue #t)))) (define* (map/accumulate-builds store proc lst #:key (cutoff 30)) @@ -1366,13 +1373,16 @@ CUTOFF is the threshold above which we stop accumulating unresolved nodes." ;; stumbling upon the same .drv build requests with many incoming edges. ;; See <https://bugs.gnu.org/49439>. + (define accumulator + (build-accumulator store)) + (define-values (result rest) (let loop ((lst lst) (result '()) (unresolved 0)) (match lst ((head . tail) - (match (with-build-handler build-accumulator + (match (with-build-handler accumulator (proc head)) ((? unresolved? obj) (if (>= unresolved cutoff) diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index cd9660174c..370df4a74c 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org> -;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018-2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,12 +22,13 @@ (define-module (guix store deduplication) #:use-module (gcrypt hash) - #:use-module (guix build utils) + #:use-module ((guix build utils) #:hide (dump-port)) #:use-module (guix build syscalls) #:use-module (guix base32) #:use-module (srfi srfi-11) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (ice-9 ftw) #:use-module (ice-9 match) @@ -37,6 +38,31 @@ dump-file/deduplicate copy-file/deduplicate)) +;; TODO: Remove once 'dump-port' in (guix build utils) has an optional 'len' +;; parameter. +(define* (dump-port in out + #:optional len + #:key (buffer-size 16384)) + "Read LEN bytes from IN (or as much as possible if LEN is #f) and write it +to OUT, using chunks of BUFFER-SIZE bytes." + (define buffer + (make-bytevector buffer-size)) + + (let loop ((total 0) + (bytes (get-bytevector-n! in buffer 0 + (if len + (min len buffer-size) + buffer-size)))) + (or (eof-object? bytes) + (and len (= total len)) + (let ((total (+ total bytes))) + (put-bytevector out buffer 0 bytes) + (loop total + (get-bytevector-n! in buffer 0 + (if len + (min (- len total) buffer-size) + buffer-size))))))) + (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))) @@ -127,11 +153,27 @@ Note: TARGET, TO-REPLACE, and SWAP-DIRECTORY must be on the same file system." (unless (= EMLINK (system-error-errno args)) (apply throw args))))))) +(define %deduplication-minimum-size + ;; Size below which files are not deduplicated. This avoids adding too many + ;; entries to '.links', which would slow down 'removeUnusedLinks' while + ;; saving little space. Keep in sync with optimize-store.cc. + 8192) + (define* (deduplicate path hash #:key (store (%store-directory))) "Check if a store item with sha256 hash HASH already exists. If so, replace PATH with a hardlink to the already-existing one. If not, register PATH so that future duplicates can hardlink to it. PATH is assumed to be under STORE." + ;; Lightweight promises. + (define-syntax-rule (delay exp) + (let ((value #f)) + (lambda () + (unless value + (set! value exp)) + value))) + (define-syntax-rule (force promise) + (promise)) + (define links-directory (string-append store "/.links")) @@ -144,13 +186,18 @@ under STORE." ((file . properties) (unless (member file '("." "..")) (let* ((file (string-append path "/" file)) + (st (delay (lstat file))) (type (match (assoc-ref properties 'type) ((or 'unknown #f) - (stat:type (lstat file))) + (stat:type (force st))) (type type)))) - (loop file type - (and (not (eq? 'directory type)) - (nar-sha256 file))))))) + (when (or (eq? 'directory type) + (and (eq? 'regular type) + (>= (stat:size (force st)) + %deduplication-minimum-size))) + (loop file type + (and (not (eq? 'directory type)) + (nar-sha256 file)))))))) (scandir* path)) (let ((link-file (string-append links-directory "/" (bytevector->nix-base32-string hash)))) @@ -222,9 +269,9 @@ OUTPUT as it goes." This procedure is suitable as a #:dump-file argument to 'restore-file'. When used that way, it deduplicates files on the fly as they are restored, thereby -removing the need to a deduplication pass that would re-read all the files +removing the need for a deduplication pass that would re-read all the files down the road." - (define hash + (define (dump-and-compute-hash) (call-with-output-file file (lambda (output) (let-values (((hash-port get-hash) @@ -236,7 +283,11 @@ down the road." (close-port hash-port) (get-hash))))) - (deduplicate file hash #:store store)) + (if (>= size %deduplication-minimum-size) + (deduplicate file (dump-and-compute-hash) #:store store) + (call-with-output-file file + (lambda (output) + (dump-port input output size))))) (define* (copy-file/deduplicate source target #:key (store (%store-directory))) diff --git a/guix/substitutes.scm b/guix/substitutes.scm index a5c554acff..9014cf61ec 100644 --- a/guix/substitutes.scm +++ b/guix/substitutes.scm @@ -156,7 +156,11 @@ indicates that PATH is unavailable at CACHE-URL." (define (narinfo-request cache-url path) "Return an HTTP request for the narinfo of PATH at CACHE-URL." - (let* ((base (string->uri cache-url)) + ;; Ensure BASE has a trailing slash so that REF is correct regardless of + ;; whether the user-provided CACHE-URL has a trailing slash. + (let* ((base (string->uri (if (string-suffix? "/" cache-url) + cache-url + (string-append cache-url "/")))) (ref (build-relative-ref #:path (string-append (store-path-hash-part path) ".narinfo"))) (url (resolve-uri-reference ref base)) diff --git a/guix/svn-download.scm b/guix/svn-download.scm index 28ad49977b..55ce0d7351 100644 --- a/guix/svn-download.scm +++ b/guix/svn-download.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016, 2019, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in> -;;; Copyright © 2017, 2019 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017, 2019, 2021 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,7 +26,9 @@ #:use-module (guix packages) #:use-module (guix utils) #:use-module ((guix build svn) #:prefix build:) + #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (ice-9 match) + #:use-module (srfi srfi-1) #:export (svn-reference svn-reference? svn-reference-url @@ -41,7 +43,8 @@ svn-multi-reference-revision svn-multi-reference-locations svn-multi-reference-recursive? - svn-multi-fetch)) + svn-multi-fetch + download-multi-svn-to-store)) ;;; Commentary: ;;; @@ -166,4 +169,28 @@ reports to LOG." (add-to-store store name #t "sha256" (string-append temp "/svn"))))))) +(define* (download-multi-svn-to-store store ref + #:optional (name (basename (svn-multi-reference-url ref))) + #:key (log (current-error-port))) + "Download from REF, a <svn-multi-reference> object to STORE. Write progress +reports to LOG." + (call-with-temporary-directory + (lambda (temp) + (and (every (lambda (location) + (let ((dir (string-append temp "/" (dirname location)))) + (mkdir-p dir)) + (parameterize ((current-output-port log)) + (build:svn-fetch (string-append (svn-multi-reference-url ref) + "/" location) + (svn-multi-reference-revision ref) + (if (string-suffix? "/" location) + (string-append temp "/" location) + (string-append temp "/" (dirname location))) + #:recursive? + (svn-multi-reference-recursive? ref) + #:user-name (svn-multi-reference-user-name ref) + #:password (svn-multi-reference-password ref)))) + (svn-multi-reference-locations ref)) + (add-to-store store name #t "sha256" temp))))) + ;;; svn-download.scm ends here diff --git a/guix/swh.scm b/guix/swh.scm index a62567dd58..c7c1c873a2 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -136,6 +137,12 @@ ;; Whether to verify the X.509 HTTPS certificate for %SWH-BASE-URL. (make-parameter #t)) +;; Token from an account to the Software Heritage Authentication service +;; <https://archive.softwareheritage.org/api/> +(define %swh-token + (make-parameter (and=> (getenv "GUIX_SWH_TOKEN") + string->symbol))) + (define (swh-url path . rest) ;; URLs returned by the API may be relative or absolute. This has changed ;; without notice before. Handle both cases by detecting whether the path @@ -246,6 +253,10 @@ FALSE-IF-404? is true, return #f upon 404 responses." (and ((%allow-request?) url method) (let*-values (((response port) (method url #:streaming? #t + #:headers + (if (%swh-token) + `((authorization . (Bearer ,(%swh-token)))) + '()) #:verify-certificate? (%verify-swh-certificate?)))) ;; See <https://archive.softwareheritage.org/api/#rate-limiting>. @@ -645,20 +656,29 @@ delete it when leaving the dynamic extent of this call." (lambda () (false-if-exception (delete-file-recursively tmp-dir)))))) -(define* (swh-download-directory id output - #:key (log-port (current-error-port))) - "Download from Software Heritage the directory with the given ID, and -unpack it to OUTPUT. Return #t on success and #f on failure" +(define* (swh-download-archive swhid output + #:key + (archive-type 'flat) + (log-port (current-error-port))) + "Download from Software Heritage the directory or revision with the given +SWID, in the ARCHIVE-TYPE format (one of 'flat or 'git-bare), and unpack it to +OUTPUT. Return #t on success and #f on failure." (call-with-temporary-directory (lambda (directory) - (match (vault-fetch id 'directory #:log-port log-port) + (match (vault-fetch swhid + #:archive-type archive-type + #:log-port log-port) (#f (format log-port - "SWH: directory ~a could not be fetched from the vault~%" - id) + "SWH: object ~a could not be fetched from the vault~%" + swhid) #f) ((? port? input) - (let ((tar (open-pipe* OPEN_WRITE "tar" "-C" directory "-xzvf" "-"))) + (let ((tar (open-pipe* OPEN_WRITE "tar" "-C" directory + (match archive-type + ('flat "-xzvf") ;gzipped + ('git-bare "-xvf")) ;uncompressed + "-"))) (dump-port input tar) (close-port input) (let ((status (close-pipe tar))) @@ -672,6 +692,14 @@ unpack it to OUTPUT. Return #t on success and #f on failure" #:log (%make-void-port "w")) #t)))))))) +(define* (swh-download-directory id output + #:key (log-port (current-error-port))) + "Download from Software Heritage the directory with the given ID, and +unpack it to OUTPUT. Return #t on success and #f on failure." + (swh-download-archive (string-append "swh:1:dir:" id) output + #:archive-type 'flat + #:log-port log-port)) + (define (commit-id? reference) "Return true if REFERENCE is likely a commit ID, false otherwise---e.g., if it is a tag name. This is based on a simple heuristic so use with care!" @@ -679,8 +707,11 @@ it is a tag name. This is based on a simple heuristic so use with care!" (string-every char-set:hex-digit reference))) (define* (swh-download url reference output - #:key (log-port (current-error-port))) - "Download from Software Heritage a checkout of the Git tag or commit + #:key + (archive-type 'flat) + (log-port (current-error-port))) + "Download from Software Heritage a checkout (if ARCHIVE-TYPE is 'flat) or a +full Git repository (if ARCHIVE-TYPE is 'git-bare) of the Git tag or commit REFERENCE originating from URL, and unpack it in OUTPUT. Return #t on success and #f on failure. @@ -694,8 +725,16 @@ wait until it becomes available, which could take several minutes." (format log-port "SWH: found revision ~a with directory at '~a'~%" (revision-id revision) (swh-url (revision-directory-url revision))) - (swh-download-directory (revision-directory revision) output - #:log-port log-port)) + (swh-download-archive (match archive-type + ('flat + (string-append + "swh:1:dir:" (revision-directory revision))) + ('git-bare + (string-append + "swh:1:rev:" (revision-id revision)))) + output + #:archive-type archive-type + #:log-port log-port)) (#f (format log-port "SWH: revision ~s originating from ~a could not be found~%" diff --git a/guix/tests.scm b/guix/tests.scm index 063b20183d..4cd1ad6cf9 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -189,18 +189,22 @@ too expensive to build entirely in the test store." (loop (1+ i))) bv)))) -(define (file=? a b) - "Return true if files A and B have the same type and same content." - (and (eq? (stat:type (lstat a)) (stat:type (lstat b))) - (case (stat:type (lstat a)) - ((regular) - (equal? - (call-with-input-file a get-bytevector-all) - (call-with-input-file b get-bytevector-all))) - ((symlink) - (string=? (readlink a) (readlink b))) - (else - (error "what?" (lstat a)))))) +(define* (file=? a b #:optional (stat lstat)) + "Return true if files A and B have the same type and same content. Call +STAT to obtain file metadata." + (let ((sta (stat a)) (stb (stat b))) + (and (eq? (stat:type sta) (stat:type stb)) + (case (stat:type sta) + ((regular) + (or (and (= (stat:ino sta) (stat:ino stb)) + (= (stat:dev sta) (stat:dev stb))) + (equal? + (call-with-input-file a get-bytevector-all) + (call-with-input-file b get-bytevector-all)))) + ((symlink) + (string=? (readlink a) (readlink b))) + (else + (error "what?" (stat a))))))) (define (canonical-file? file) "Return #t if FILE is in the store, is read-only, and its mtime is 1." diff --git a/guix/tests/git.scm b/guix/tests/git.scm index b8e5f7e643..69960284d9 100644 --- a/guix/tests/git.scm +++ b/guix/tests/git.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; ;;; This file is part of GNU Guix. ;;; @@ -53,6 +54,7 @@ Return DIRECTORY on success." (with-environment-variables `(("GIT_CONFIG_NOSYSTEM" "1") ("GIT_ATTR_NOSYSTEM" "1") + ("GIT_CONFIG_GLOBAL" ,(string-append home "/.gitconfig")) ("HOME" ,home)) (apply invoke (git-command) "-C" directory command args))))) @@ -88,6 +90,9 @@ Return DIRECTORY on success." ((('tag name) rest ...) (git "tag" name) (loop rest)) + ((('tag name text) rest ...) + (git "tag" "-m" text name) + (loop rest)) ((('branch name) rest ...) (git "branch" name) (loop rest)) diff --git a/guix/ui.scm b/guix/ui.scm index 1428c254b3..bd999103ff 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -377,7 +377,8 @@ ARGS is the list of arguments received by the 'throw' handler." (+ 2 (string-contains message ": "))))) (format (current-error-port) (G_ "~amissing closing parenthesis~%") location)) - (apply throw args))) + (report-error (G_ "read error while loading '~a': ~a~%") + file (apply format #f message args)))) (('syntax-error proc message properties form subform . rest) (let ((loc (source-properties->location properties))) (report-error loc (G_ "~s: ~a~%") @@ -1431,10 +1432,22 @@ converted to a space; sequences of more than one line break are preserved." (with-fluids ((%default-port-encoding "UTF-8")) (stexi->plain-text (texi-fragment->stexi str)))) +(define (texi->plain-text* package str) + "Same as 'texi->plain-text', but gracefully handle Texinfo errors." + (catch 'parser-error + (lambda () + (texi->plain-text str)) + (lambda args + (warning (package-location package) + (G_ "~a: invalid Texinfo markup~%") + (package-full-name package)) + str))) + (define (package-field-string package field-accessor) "Return a plain-text representation of PACKAGE field." (and=> (field-accessor package) - (compose texi->plain-text P_))) + (lambda (str) + (texi->plain-text* package (P_ str))))) (define (package-description-string package) "Return a plain-text representation of PACKAGE description field." @@ -1555,7 +1568,8 @@ HYPERLINKS? is true, emit hyperlink escape sequences when appropriate." (parameterize ((%text-width width*)) ;; Call 'texi->plain-text' on the concatenated string to account ;; for the width of "description:" in paragraph filling. - (texi->plain-text + (texi->plain-text* + p (string-append "description: " (or (and=> (package-description p) P_) "")))) @@ -2085,10 +2099,17 @@ contain a 'define-command' form." (lambda (command) (eq? category (command-category command)))) - (format #t (G_ "Usage: guix COMMAND ARGS... -Run COMMAND with ARGS.\n")) + (display (G_ "Usage: guix OPTION | COMMAND ARGS... +Run COMMAND with ARGS, if given.\n")) + + (display (G_ " + -h, --help display this helpful text again and exit")) + (display (G_ " + -V, --version display version and copyright information and exit")) + (newline) + (newline) - (format #t (G_ "COMMAND must be one of the sub-commands listed below:\n")) + (display (G_ "COMMAND must be one of the sub-commands listed below:\n")) (let ((commands (commands)) (categories (module-ref (resolve-interface '(guix scripts)) diff --git a/guix/utils.scm b/guix/utils.scm index 3f253d6cd8..9596ff8582 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -97,6 +97,7 @@ target-ppc32? target-ppc64le? target-powerpc? + target-riscv64? target-64bit? cc-for-target cxx-for-target @@ -704,6 +705,11 @@ architecture (x86_64)?" (%current-system)))) (string-prefix? "powerpc" target)) +(define* (target-riscv64? #:optional (target (or (%current-target-system) + (%current-system)))) + "Is the architecture of TARGET a 'riscv64' machine?" + (string-prefix? "riscv64" target)) + (define* (target-64bit? #:optional (system (or (%current-target-system) (%current-system)))) (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "powerpc64"))) |