diff options
author | Ludovic Courtès <ludo@gnu.org> | 2022-06-22 18:48:00 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2022-06-22 18:48:00 +0200 |
commit | 8655a714457dbf1cde45979507012d9515614028 (patch) | |
tree | 7712625328f45794ccda9baa730a4825bb2efb47 /guix | |
parent | a589049e141588ebcf4079116e378d60b779f6b4 (diff) | |
parent | 2af3f5eef045f7d177cc394c89be069bac895688 (diff) |
Merge branch master into core-updates
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build-system/rebar.scm | 158 | ||||
-rw-r--r-- | guix/build/emacs-utils.scm | 39 | ||||
-rw-r--r-- | guix/build/rebar-build-system.scm | 147 | ||||
-rw-r--r-- | guix/build/renpy-build-system.scm | 19 | ||||
-rw-r--r-- | guix/channels.scm | 9 | ||||
-rw-r--r-- | guix/extracting-download.scm | 179 | ||||
-rw-r--r-- | guix/import/hexpm.scm | 347 | ||||
-rw-r--r-- | guix/least-authority.scm | 2 | ||||
-rw-r--r-- | guix/packages.scm | 16 | ||||
-rw-r--r-- | guix/platform.scm | 2 | ||||
-rw-r--r-- | guix/scripts/challenge.scm | 48 | ||||
-rw-r--r-- | guix/scripts/import.scm | 2 | ||||
-rw-r--r-- | guix/scripts/import/hexpm.scm | 105 | ||||
-rw-r--r-- | guix/scripts/pull.scm | 34 | ||||
-rw-r--r-- | guix/scripts/refresh.scm | 15 | ||||
-rw-r--r-- | guix/scripts/shell.scm | 3 | ||||
-rw-r--r-- | guix/self.scm | 2 | ||||
-rw-r--r-- | guix/ssh.scm | 10 | ||||
-rw-r--r-- | guix/ui.scm | 14 | ||||
-rw-r--r-- | guix/upstream.scm | 47 | ||||
-rw-r--r-- | guix/utils.scm | 3 |
21 files changed, 961 insertions, 240 deletions
diff --git a/guix/build-system/rebar.scm b/guix/build-system/rebar.scm new file mode 100644 index 0000000000..6ca5abe4d6 --- /dev/null +++ b/guix/build-system/rebar.scm @@ -0,0 +1,158 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.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 build-system rebar) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix gexp) + #:use-module (guix packages) + #:use-module (guix monads) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (ice-9 match) + #:use-module (srfi srfi-26) + #:export (hexpm-uri + hexpm-package-url + %rebar-build-system-modules + rebar-build + rebar-build-system)) + +;;; +;;; Definitions for the hex.pm repository, +;;; + +;; URL and paths from +;; https://github.com/hexpm/specifications/blob/master/endpoints.md +(define %hexpm-repo-url + (make-parameter "https://repo.hex.pm")) + +(define hexpm-package-url + (string-append (%hexpm-repo-url) "/tarballs/")) + +(define (hexpm-uri name version) + "Return a URI string for the package hosted at hex.pm corresponding to NAME +and VERSION." + (string-append hexpm-package-url name "-" version ".tar")) + +;; +;; Standard build procedure for Erlang packages using Rebar. +;; + +(define %rebar-build-system-modules + ;; Build-side modules imported by default. + `((guix build rebar-build-system) + ,@%gnu-build-system-modules)) + +(define (default-rebar3) + "Return the default Rebar3 package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((erlang-mod (resolve-interface '(gnu packages erlang)))) + (module-ref erlang-mod 'rebar3))) + +(define (default-erlang) + "Return the default Erlang package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((erlang-mod (resolve-interface '(gnu packages erlang)))) + (module-ref erlang-mod 'erlang))) + +(define* (lower name + #:key source inputs native-inputs outputs system target + (rebar (default-rebar3)) + (erlang (default-erlang)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME from the given arguments." + (define private-keywords + '(#:target #:rebar #:erlang #:inputs #:native-inputs)) + + (and (not target) ;XXX: no cross-compilation + (bag + (name name) + (system system) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs)) + (build-inputs `(("rebar" ,rebar) + ("erlang" ,erlang) ;; for escriptize + ,@native-inputs + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (outputs outputs) + (build rebar-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define* (rebar-build name inputs + #:key + guile source + (rebar-flags ''("skip_deps=true" "-vv")) + (tests? #t) + (test-target "eunit") + ;; TODO: install-name ; default: based on guix package name + (install-profile "default") + (phases '(@ (guix build rebar-build-system) + %standard-phases)) + (outputs '("out")) + (search-paths '()) + (native-search-paths '()) + (system (%current-system)) + (imported-modules %rebar-build-system-modules) + (modules '((guix build rebar-build-system) + (guix build utils)))) + "Build SOURCE with INPUTS." + + (define builder + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + + #$(with-build-variables inputs outputs + #~(rebar-build #:source #+source + #:system #$system + #:name #$name + #:rebar-flags #$rebar-flags + #:tests? #$tests? + #:test-target #$test-target + ;; TODO: #:install-name #$install-name + #:install-profile #$install-profile + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:outputs %outputs + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs %build-inputs))))) + + (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 + #:guile-for-build guile))) + +(define rebar-build-system + (build-system + (name 'rebar) + (description "The standard Rebar build system") + (lower lower))) diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm index 60a754b9e9..8ee547f2b3 100644 --- a/guix/build/emacs-utils.scm +++ b/guix/build/emacs-utils.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2014 Alex Kost <alezost@gmail.com> ;;; Copyright © 2018, 2020, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2019 Liliana Marie Prikler <liliana.prikler@gmail.com> +;;; Copyright © 2022 Fredrik Salomonsson <plattfot@posteo.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,12 +23,22 @@ (define-module (guix build emacs-utils) #:use-module (guix build utils) #:use-module (ice-9 format) + #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:export (%emacs emacs-batch-eval emacs-batch-edit-file emacs-batch-disable-compilation + emacs-batch-script + + emacs-batch-error? + emacs-batch-error-message + emacs-generate-autoloads emacs-byte-compile-directory + emacs-header-parse as-display emacs-substitute-sexps @@ -69,6 +80,26 @@ true, evaluate using dynamic scoping." (add-file-local-variable 'no-byte-compile t) (basic-save-buffer)))) +(define-condition-type &emacs-batch-error &error + emacs-batch-error? + (message emacs-batch-error-message)) + +(define (emacs-batch-script expr) + "Execute the Elisp code EXPR in Emacs batch mode and return output." + (let* ((error-pipe (pipe)) + (port (parameterize ((current-error-port (cdr error-pipe))) + (open-pipe* + OPEN_READ + (%emacs) "--quick" "--batch" + (string-append "--eval=" (expr->string expr))))) + (output (read-string port)) + (status (close-pipe port))) + (close-port (cdr error-pipe)) + (unless (zero? status) + (raise (condition (&emacs-batch-error + (message (read-string (car error-pipe))))))) + output)) + (define (emacs-generate-autoloads name directory) "Generate autoloads for Emacs package NAME placed in DIRECTORY." (let* ((file (string-append directory "/" name "-autoloads.el")) @@ -84,6 +115,14 @@ true, evaluate using dynamic scoping." (byte-recompile-directory (file-name-as-directory ,dir) 0 1)))) (emacs-batch-eval expr))) +(define (emacs-header-parse section file) + "Parse the header SECTION in FILE and return it as a string." + (emacs-batch-script + `(progn + (require 'lisp-mnt) + (find-file ,file) + (princ (lm-header ,section))))) + (define as-display ;syntactic keyword for 'emacs-substitute-sexps' '(as display)) diff --git a/guix/build/rebar-build-system.scm b/guix/build/rebar-build-system.scm new file mode 100644 index 0000000000..fb66422877 --- /dev/null +++ b/guix/build/rebar-build-system.scm @@ -0,0 +1,147 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016, 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2019 Björn Höfling <bjoern.hoefling@bjoernhoefling.de> +;;; Copyright © 2020, 2022 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 build rebar-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module ((guix build utils) #:hide (delete)) + #:use-module (ice-9 match) + #:use-module (ice-9 ftw) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (rebar-build + %standard-phases)) + +;; +;; Builder-side code of the standard build procedure for Erlang packages using +;; rebar3. +;; +;; TODO: Think about whether bindir ("ebin"), libdir ("priv") and includedir +;; "(include") need to be configurable + +(define %erlang-libdir "/lib/erlang/lib") + +(define* (erlang-depends #:key inputs #:allow-other-keys) + (define input-directories + (match inputs + (((_ . dir) ...) + dir))) + (mkdir-p "_checkouts") + + (for-each + (lambda (input-dir) + (let ((elibdir (string-append input-dir %erlang-libdir))) + (when (directory-exists? elibdir) + (for-each + (lambda (dirname) + (let ((dest (string-append elibdir "/" dirname)) + (link (string-append "_checkouts/" dirname))) + (when (not (file-exists? link)) + ;; RETHINK: Maybe better copy and make writable to avoid some + ;; error messages e.g. when using with rebar3-git-vsn. + (symlink dest link)))) + (list-directories elibdir))))) + input-directories)) + +(define* (unpack #:key source #:allow-other-keys) + "Unpack SOURCE in the working directory, and change directory within the +source. When SOURCE is a directory, copy it in a sub-directory of the current +working directory." + (let ((gnu-unpack (assoc-ref gnu:%standard-phases 'unpack))) + (gnu-unpack #:source source) + ;; Packages from hex.pm typically have a contents.tar.gz containing the + ;; actual source. If this tar file exists, extract it. + (when (file-exists? "contents.tar.gz") + (invoke "tar" "xvf" "contents.tar.gz")))) + +(define* (build #:key (rebar-flags '()) #:allow-other-keys) + (apply invoke `("rebar3" "compile" ,@rebar-flags))) + +(define* (check #:key target (rebar-flags '()) (tests? (not target)) + (test-target "eunit") + #:allow-other-keys) + (if tests? + (apply invoke `("rebar3" ,test-target ,@rebar-flags)) + (format #t "test suite not run~%"))) + +(define (erlang-package? name) + "Check if NAME correspond to the name of an Erlang package." + (string-prefix? "erlang-" name)) + +(define (package-name-version->erlang-name name+ver) + "Convert the Guix package NAME-VER to the corresponding Erlang name-version +format. Essentially drop the prefix used in Guix and replace dashes by +underscores." + (let* ((name- (package-name->name+version name+ver))) + (string-join + (string-split + (if (erlang-package? name-) ; checks for "erlang-" prefix + (string-drop name- (string-length "erlang-")) + name-) + #\-) + "_"))) + +(define (list-directories directory) + "Return file names of the sub-directory of DIRECTORY." + (scandir directory + (lambda (file) + (and (not (member file '("." ".."))) + (file-is-directory? (string-append directory "/" file)))))) + +(define* (install #:key name outputs + (install-name (package-name-version->erlang-name name)) + (install-profile "default") ; build profile outputs to install + #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (pkg-dir (string-append out %erlang-libdir "/" install-name))) + (let ((bin-dir (string-append "_build/" install-profile "/bin")) + (lib-dir (string-append "_build/" install-profile "/lib"))) + ;; install _build/PROFILE/bin + (when (file-exists? bin-dir) + (copy-recursively bin-dir out #:follow-symlinks? #t)) + ;; install _build/PROFILE/lib/*/{ebin,include,priv} + (for-each + (lambda (*) + (for-each + (lambda (dirname) + (let ((src-dir (string-append lib-dir "/" * "/" dirname)) + (dst-dir (string-append pkg-dir "/" dirname))) + (when (file-exists? src-dir) + (copy-recursively src-dir dst-dir #:follow-symlinks? #t)) + (false-if-exception + (delete-file (string-append dst-dir "/.gitignore"))))) + '("ebin" "include" "priv"))) + (list-directories lib-dir)) + (false-if-exception + (delete-file (string-append pkg-dir "/priv/Run-eunit-loop.expect")))))) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (replace 'unpack unpack) + (delete 'bootstrap) + (delete 'configure) + (add-before 'build 'erlang-depends erlang-depends) + (replace 'build build) + (replace 'check check) + (replace 'install install))) + +(define* (rebar-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given Erlang package, applying all of PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) diff --git a/guix/build/renpy-build-system.scm b/guix/build/renpy-build-system.scm index e4a88456be..7c15d52f19 100644 --- a/guix/build/renpy-build-system.scm +++ b/guix/build/renpy-build-system.scm @@ -37,10 +37,9 @@ game ;; should be "compile", but renpy wants to compile itself really ;; badly if we do - "quit") - #t) + "quit")) -(define* (install #:key outputs game (output "out") #:allow-other-keys) +(define* (install #:key inputs outputs game (output "out") #:allow-other-keys) (let* ((out (assoc-ref outputs output)) (json-dump (call-with-input-file (string-append game "/renpy-build.json") @@ -58,13 +57,12 @@ (call-with-output-file launcher (lambda (port) (format port "#!~a~%~a ~s \"$@\"" - (which "bash") - (which "renpy") + (search-input-file inputs "/bin/sh") + (search-input-file inputs "/bin/renpy") data))) - (chmod launcher #o755))) - #t) + (chmod launcher #o755)))) -(define* (install-desktop-file #:key outputs game (output "out") +(define* (install-desktop-file #:key inputs outputs game (output "out") #:allow-other-keys) (let* ((out (assoc-ref outputs output)) (json-dump (call-with-input-file (string-append game @@ -78,10 +76,9 @@ #:name (assoc-ref json-dump "name") #:generic-name (assoc-ref build "display_name") #:exec (format #f "~a ~s" - (which "renpy") + (search-input-file inputs "/bin/renpy") (string-append out "/share/renpy/" directory-name)) - #:categories '("Game" "Visual Novel"))) - #t) + #:categories '("Game" "Visual Novel")))) (define %standard-phases (modify-phases gnu:%standard-phases diff --git a/guix/channels.scm b/guix/channels.scm index 5f47834c10..ce1a60436f 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -907,7 +907,14 @@ be used as a profile hook." (format (current-error-port) "Generating package cache for '~a'...~%" #$profile) - (generate-package-cache #$output)) + ;; This script runs through (primitive-load), which by default + ;; doesn't print backtraces when it encounters an exception, + ;; so manually do it. Use with-throw-handler because it is + ;; supported by all Guile versions. + (with-throw-handler #t + (lambda () (generate-package-cache #$output)) + (lambda (key . args) + (backtrace)))) (mkdir #$output)))) (gexp->derivation-in-inferior "guix-package-cache" build diff --git a/guix/extracting-download.scm b/guix/extracting-download.scm deleted file mode 100644 index 4b7dcc7e83..0000000000 --- a/guix/extracting-download.scm +++ /dev/null @@ -1,179 +0,0 @@ -;;; 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/import/hexpm.scm b/guix/import/hexpm.scm new file mode 100644 index 0000000000..2a7a9f3d82 --- /dev/null +++ b/guix/import/hexpm.scm @@ -0,0 +1,347 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Cyril Roelandt <tipecaml@gmail.com> +;;; Copyright © 2016 David Craven <david@craven.ch> +;;; Copyright © 2017, 2019-2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019 Martin Becze <mjbecze@riseup.net> +;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2020-2022 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 import hexpm) + #:use-module (guix base32) + #:use-module ((guix download) #:prefix download:) + #:use-module (gcrypt hash) + #:use-module (guix http-client) + #:use-module (json) + #:use-module (guix import utils) + #:use-module ((guix import json) #:select (json-fetch)) + #:use-module ((guix build utils) + #:select ((package-name->name+version + . hyphen-package-name->name+version) + dump-port)) + #:use-module ((guix licenses) #:prefix license:) + #:use-module (guix monads) + #:use-module (guix packages) + #:use-module (guix upstream) + #:use-module (guix utils) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 popen) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) + #:use-module (srfi srfi-26) + #:use-module (guix build-system rebar) + #:export (hexpm->guix-package + guix-package->hexpm-name + strings->licenses ;; why used here? + hexpm-recursive-import + %hexpm-updater)) + +;;; +;;; Interface to https://hex.pm/api, version 2. +;;; REST-API end-points: +;;; https://github.com/hexpm/specifications/blob/master/apiary.apib +;;; Repository end-points: +;;; https://github.com/hexpm/specifications/blob/master/endpoints.md +;;; + +(define %hexpm-api-url + (make-parameter "https://hex.pm/api")) + +(define (package-url name) + (string-append (%hexpm-api-url) "/packages/" name)) + +;; +;; Hexpm Package. /packages/${name} +;; https://github.com/hexpm/specifications/blob/master/apiary.apib#Package +;; +;; Each package can have several "releases", each of which has its own set of +;; requirements, build-tool, etc. - see <hexpm-release> below. +(define-json-mapping <hexpm-pkgdef> make-hexpm-pkgdef hexpm-pkgdef? + json->hexpm + (name hexpm-name) ; string + (html-url hexpm-html-url "html_url") ; string + (docs-html-url hexpm-docs-html-url "docs_html_url") ; string | 'null + (meta hexpm-meta "meta" json->hexpm-meta) + (versions hexpm-versions "releases" ; list of <hexpm-version> + (lambda (vector) + (map json->hexpm-version + (vector->list vector)))) + ;; "latest_version" and "latest_stable_version" are not named in the + ;; specification, butt seen in practice. + (latest-version hexpm-latest-version "latest_version") ; string + (latest-stable hexpm-latest-stable "latest_stable_version")) ; string + +;; Hexpm package metadata. +(define-json-mapping <hexpm-meta> make-hexpm-meta hexpm-meta? + json->hexpm-meta + (description hexpm-meta-description) ;string + (licenses hexpm-meta-licenses "licenses" ;list of strings + (lambda (vector) + (or (and vector (vector->list vector)) + #f)))) + +;; Hexpm package versions. +(define-json-mapping <hexpm-version> make-hexpm-version hexpm-version? + json->hexpm-version + (number hexpm-version-number "version") ;string + (url hexpm-version-url)) ;string + + +(define (lookup-hexpm name) + "Look up NAME on hex.pm and return the corresopnding <hexpm> record +or #f if it was not found." + (and=> (json-fetch (package-url name)) + json->hexpm)) + +;; +;; Hexpm release. /packages/${name}/releases/${version} +;; https://github.com/hexpm/specifications/blob/master/apiary.apib#Release +;; +(define-json-mapping <hexpm-release> make-hexpm-release hexpm-release? + json->hexpm-release + (version hexpm-release-version) ; string + (url hexpm-release-url) ; string + (meta hexpm-release-meta "meta" json->hexpm-release-meta) + ;; Specification names the next fields "dependencies", but in practice it is + ;; "requirements". + (dependencies hexpm-requirements "requirements")) ; list of <hexpm-dependency> + +;; Hexpm release meta. +;; https://github.com/hexpm/specifications/blob/main/package_metadata.md +(define-json-mapping <hexpm-release-meta> + make-hexpm-release-meta hexpm-release-meta? + json->hexpm-release-meta + (app hexpm-release-meta-app) ; string + (elixir hexpm-release-meta-elixir) ; string + (build-tools hexpm-release-meta-build-tools "build_tools" ; list of strings + (lambda (vector) + (or (and vector (vector->list vector)) + (list))))) + +;; Hexpm dependency. Each requirement has information about the required +;; version, such as "~> 2.1.2" or ">= 2.1.2 and < 2.2.0", see +;; <https://hexdocs.pm/elixir/Version.html#module-requirements>, and whether +;; the dependency is optional. +(define-json-mapping <hexpm-dependency> make-hexpm-dependency + hexpm-dependency? + json->hexpm-dependency + (name hexpm-dependency-name "app") ; string + (requirement hexpm-dependency-requirement) ; string + (optional hexpm-dependency-optional)) ; bool + +(define (hexpm-release-dependencies release) + "Return the list of dependency names of RELEASE, a <hexpm-release>." + (let ((reqs (or (hexpm-requirements release) '#()))) + (map first reqs))) ;; TODO: also return required version + + +(define (lookup-hexpm-release version*) + "Look up RELEASE on hexpm-version-url and return the corresopnding +<hexpm-release> record or #f if it was not found." + (and=> (json-fetch (hexpm-version-url version*)) + json->hexpm-release)) + + +;;; +;;; Converting hex.pm packages to Guix packages. +;;; + +(define (maybe-inputs package-inputs input-type) + "Given a list of PACKAGE-INPUTS, tries to generate the 'inputs' field of a +package definition. INPUT-TYPE, a symbol, is used to populate the name of +the input field." + (match package-inputs + (() + '()) + ((package-inputs ...) + `((,input-type (list ,@package-inputs)))))) + +(define (dependencies->package-names names) + "Given a list of hexpm package NAMES, returns a list of guix package names +as symbols." + ;; TODO: Base name on language of dependency. + ;; The language used for implementing the dependency is not know without + ;; recursing the dependencies. So for now assume more packages are based on + ;; Erlang and prefix all dependencies with "erlang-" (the default). + (map string->symbol + (map hexpm-name->package-name + (sort names string-ci<?)))) + +(define* (make-hexpm-sexp #:key name version tarball-url + home-page synopsis description license + language build-system dependencies + #:allow-other-keys) + "Return the `package' s-expression for a hexpm package with the given NAME, +VERSION, TARBALL-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE. The +created package's name will stem from LANGUAGE. BUILD-SYSTEM defined the +build-system, and DEPENDENCIES the inputs for the package." + (call-with-temporary-output-file + (lambda (temp port) + (and (url-fetch tarball-url temp) + (values + `(package + (name ,(hexpm-name->package-name name language)) + (version ,version) + (source (origin + (method url-fetch) + (uri (hexpm-uri ,name version)) + (sha256 (base32 ,(guix-hash-url temp))))) + (build-system ,build-system) + ,@(maybe-inputs (dependencies->package-names dependencies) 'inputs) + (synopsis ,synopsis) + (description ,(beautify-description description)) + (home-page ,(match home-page + (() "") + (_ home-page))) + (license ,(match license + (() #f) + ((license) license) + (_ `(list ,@license)))))))))) + +(define (strings->licenses strings) + "Convert the list of STRINGS into a list of license objects." + (filter-map (lambda (license) + (and (not (string-null? license)) + (not (any (lambda (elem) (string=? elem license)) + '("AND" "OR" "WITH"))) + (or (spdx-string->license license) + license))) + strings)) + +(define (hexpm-latest-release package) + "Return the version string for the latest stable release of PACKAGE." + ;; Use latest-stable if specified (see comment in hexpm-pkgdef above), + ;; otherwise compare the lists of release versions. + (let ((latest-stable (hexpm-latest-stable package))) + (if (not (unspecified? latest-stable)) + latest-stable + (let ((versions (map hexpm-version-number (hexpm-versions package)))) + (fold (lambda (a b) + (if (version>? a b) a b)) (car versions) versions))))) + +(define* (hexpm->guix-package package-name #:key repo version) + "Fetch the metadata for PACKAGE-NAME from hexpms.io, and return the +`package' s-expression corresponding to that package, or #f on failure. +When VERSION is specified, attempt to fetch that version; otherwise fetch the +latest version of PACKAGE-NAME." + + (define package + (lookup-hexpm package-name)) + + (define version-number + (and package + (or version + (hexpm-latest-release package)))) + + (define version* + (and package + (find (lambda (version) + (string=? (hexpm-version-number version) + version-number)) + (hexpm-versions package)))) + + (define release + (and package version* + (lookup-hexpm-release version*))) + + (define release-meta + (and package version* + (hexpm-release-meta release))) + + (define build-system + (and package version* + (let ((build-tools (hexpm-release-meta-build-tools release-meta))) + (cond + ((member "rebar3" build-tools) 'rebar-build-system) + ((member "mix" build-tools) 'mix-build-system) + ((member "make" build-tools) 'gnu-build-system) + (else #f))))) + + (define language + (and package version* + (let ((elixir (hexpm-release-meta-elixir release-meta))) + (cond + ((and (string? elixir) (not (string-null? elixir))) "elixir") + (else "erlang"))))) + + (and package version* + (let ((dependencies (hexpm-release-dependencies release)) + (pkg-meta (hexpm-meta package)) + (docs-html-url (hexpm-docs-html-url package))) + (values + (make-hexpm-sexp + #:language language + #:build-system build-system + #:name package-name + #:version version-number + #:dependencies dependencies + #:home-page (or (and (not (eq? docs-html-url 'null)) + docs-html-url) + ;; TODO: Homepage? + (hexpm-html-url package)) + #:synopsis (hexpm-meta-description pkg-meta) + #:description (hexpm-meta-description pkg-meta) + #:license (or (and=> (hexpm-meta-licenses pkg-meta) + strings->licenses)) + #:tarball-url (hexpm-uri package-name version-number)) + dependencies)))) + +(define* (hexpm-recursive-import pkg-name #:optional version) + (recursive-import pkg-name + #:version version + #:repo->guix-package hexpm->guix-package + #:guix-name hexpm-name->package-name)) + +(define (guix-package->hexpm-name package) + "Return the hex.pm name of PACKAGE." + (define (url->hexpm-name url) + (hyphen-package-name->name+version + (basename (file-sans-extension url)))) + + (match (and=> (package-source package) origin-uri) + ((? string? url) + (url->hexpm-name url)) + ((lst ...) + (any url->hexpm-name lst)) + (#f #f))) + +(define* (hexpm-name->package-name name #:optional (language "erlang")) + (string-append language "-" (string-join (string-split name #\_) "-"))) + + +;;; +;;; Updater +;;; + +(define (latest-release package) + "Return an <upstream-source> for the latest release of PACKAGE." + (let* ((hexpm-name (guix-package->hexpm-name package)) + (hexpm (lookup-hexpm hexpm-name)) + (version (hexpm-latest-release hexpm)) + (url (hexpm-uri hexpm-name version))) + (upstream-source + (package (package-name package)) + (version version) + (urls (list url))))) + +(define %hexpm-updater + (upstream-updater + (name 'hexpm) + (description "Updater for hex.pm packages") + (pred (url-prefix-predicate hexpm-package-url)) + (latest latest-release))) diff --git a/guix/least-authority.scm b/guix/least-authority.scm index d871816fca..bfd7275e7c 100644 --- a/guix/least-authority.scm +++ b/guix/least-authority.scm @@ -51,7 +51,7 @@ "Return a wrapper of PROGRAM that executes it with the least authority. PROGRAM is executed in separate namespaces according to NAMESPACES, a list of -symbols; it turns with GUEST-UID and GUEST-GID. MAPPINGS is a list of +symbols; it runs with GUEST-UID and GUEST-GID. MAPPINGS is a list of <file-system-mapping> records indicating directories mirrored inside the execution environment of PROGRAM. DIRECTORY is the working directory of the wrapped process. Each environment listed in PRESERVED-ENVIRONMENT-VARIABLES diff --git a/guix/packages.scm b/guix/packages.scm index 7425389618..94e464cd01 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -3,7 +3,7 @@ ;;; 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> +;;; Copyright © 2017, 2019, 2020, 2022 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com> ;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com> @@ -149,6 +149,8 @@ transitive-input-references + %32bit-supported-systems + %64bit-supported-systems %supported-systems %hurd-systems %cuirass-supported-systems @@ -400,11 +402,19 @@ from forcing GEXP-PROMISE." #:guile-for-build guile))) +(define %32bit-supported-systems + ;; This is the list of 32-bit system types that are supported. + '("i686-linux" "armhf-linux" "i586-gnu" "powerpc-linux")) + +(define %64bit-supported-systems + ;; This is the list of 64-bit system types that are supported. + '("x86_64-linux" "mips64el-linux" "aarch64-linux" "powerpc64le-linux" + "riscv64-linux")) + (define %supported-systems ;; This is the list of system types that are supported. By default, we ;; expect all packages to build successfully here. - '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "mips64el-linux" "i586-gnu" - "powerpc64le-linux" "powerpc-linux" "riscv64-linux")) + (append %64bit-supported-systems %32bit-supported-systems)) (define %hurd-systems ;; The GNU/Hurd systems for which support is being developed. diff --git a/guix/platform.scm b/guix/platform.scm index 361241cb2e..19d4527e29 100644 --- a/guix/platform.scm +++ b/guix/platform.scm @@ -121,7 +121,7 @@ otherwise." (define (platform-target->system target) "Return the system matching the given TARGET if it exists or false otherwise." - (let ((platform (lookup-platform-by-target system))) + (let ((platform (lookup-platform-by-target target))) (and=> platform platform-system))) diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index c29d5105ae..5c0f837d13 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015-2017, 2019-2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,6 +18,7 @@ (define-module (guix scripts challenge) #:use-module (guix ui) + #:use-module (guix colors) #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix utils) @@ -32,6 +33,7 @@ #:use-module (rnrs bytevectors) #:autoload (guix http-client) (http-fetch) #:use-module ((guix build syscalls) #:select (terminal-columns)) + #:autoload (guix build utils) (make-file-writable) #:use-module (gcrypt hash) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -310,6 +312,23 @@ specified in COMPARISON-REPORT." (length files))) (format #t "~{ ~a~%~}" files)))) +(define (make-directory-writable directory) + "Recurse into DIRECTORY and make each entry writable, similar to +'chmod -R +w DIRECTORY'." + (file-system-fold (const #t) + (lambda (file stat _) ;leaf + (unless (eq? 'symlink (stat:type stat)) + (make-file-writable file))) + (lambda (directory stat _) ;down + (make-file-writable directory)) + (const #t) ;up + (const #f) ;skip + (lambda (file stat errno _) ;error + (leave (G_ "failed to delete '~a': ~a~%") + file (strerror errno))) + #t + directory)) + (define (call-with-mismatches comparison-report proc) "Call PROC with two directories containing the mismatching store items." (define local-hash @@ -318,6 +337,13 @@ specified in COMPARISON-REPORT." (define narinfos (comparison-report-narinfos comparison-report)) + (define (restore-file* port directory) + ;; Since 'restore-file' sets "canonical" file permissions (read-only), + ;; make an extra traversal to make DIRECTORY writable so it can be deleted + ;; when the dynamic extent of 'call-with-temporary-directory' is left. + (restore-file port directory) + (make-directory-writable directory)) + (call-with-temporary-directory (lambda (directory1) (call-with-temporary-directory @@ -338,10 +364,10 @@ specified in COMPARISON-REPORT." narinfos))) (rmdir directory1) - (call-with-nar narinfo1 (cut restore-file <> directory1)) + (call-with-nar narinfo1 (cut restore-file* <> directory1)) (when narinfo2 (rmdir directory2) - (call-with-nar narinfo2 (cut restore-file <> directory2))) + (call-with-nar narinfo2 (cut restore-file* <> directory2))) (proc directory1 (if local-hash (comparison-report-item comparison-report) @@ -363,6 +389,11 @@ COMPARISON-REPORT." (append command (list directory1 directory2)))))) +(define good-news + (coloring-procedure (color BOLD GREEN))) +(define bad-news + (coloring-procedure (color BOLD RED))) + (define* (summarize-report comparison-report #:key (report-differences (const #f)) @@ -385,7 +416,7 @@ with COMPARISON-REPORT." (match comparison-report (($ <comparison-report> item 'mismatch local (narinfos ...)) - (report (G_ "~a contents differ:~%") item) + (report (bad-news (G_ "~a contents differ:~%")) item) (report-hashes item local narinfos) (report-differences comparison-report)) (($ <comparison-report> item 'inconclusive #f narinfos) @@ -394,7 +425,7 @@ with COMPARISON-REPORT." (warning (G_ "could not challenge '~a': no substitutes~%") item)) (($ <comparison-report> item 'match local (narinfos ...)) (when verbose? - (report (G_ "~a contents match:~%") item) + (report (good-news (G_ "~a contents match:~%")) item) (report-hashes item local narinfos))))) (define (summarize-report-list reports) @@ -403,10 +434,11 @@ with COMPARISON-REPORT." (inconclusive (count comparison-report-inconclusive? reports)) (matches (count comparison-report-match? reports)) (discrepancies (count comparison-report-mismatch? reports))) - (report (G_ "~h store items were analyzed:~%") total) - (report (G_ " - ~h (~,1f%) were identical~%") + (report (highlight (G_ "~h store items were analyzed:~%")) total) + (report (highlight (G_ " - ~h (~,1f%) were identical~%")) matches (* 100. (/ matches total))) - (report (G_ " - ~h (~,1f%) differed~%") + (report ((if (zero? discrepancies) good-news bad-news) + (G_ " - ~h (~,1f%) differed~%")) discrepancies (* 100. (/ discrepancies total))) (report (G_ " - ~h (~,1f%) were inconclusive~%") inconclusive (* 100. (/ inconclusive total))))) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 62aa7bdbc5..71ab4b4fed 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -50,7 +50,7 @@ (define importers '("gnu" "pypi" "cpan" "hackage" "stackage" "egg" "elpa" "gem" "go" "cran" "crate" "texlive" "json" "opam" - "minetest" "elm")) + "minetest" "elm" "hexpm")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/hexpm.scm b/guix/scripts/import/hexpm.scm new file mode 100644 index 0000000000..eb9a1b0af5 --- /dev/null +++ b/guix/scripts/import/hexpm.scm @@ -0,0 +1,105 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020, 2022 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 scripts import hexpm) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix import hexpm) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-import-hexpm)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (G_ "Usage: guix import hexpm PACKAGE-NAME +Import and convert the hex.pm package for PACKAGE-NAME.\n")) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (display (G_ " + -r, --recursive import packages recursively")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix import hexpm"))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-hexpm . args) + (define (parse-options) + ;; Return the alist of option values. + (parse-command-line args %options (list %default-options) + #:build-options? #f)) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((spec) + (with-error-handling + (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)) + (hexpm-recursive-import name version)) + ;; Single import + (let ((sexp (hexpm->guix-package name #:version version))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + spec)) + sexp))))) + (() + (leave (G_ "too few arguments~%"))) + ((many ...) + (leave (G_ "too many arguments~%")))))) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index f01764637b..b0cc459d63 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -20,6 +20,7 @@ (define-module (guix scripts pull) #:use-module ((guix ui) #:hide (display-profile-content)) + #:use-module (guix diagnostics) #:use-module (guix colors) #:use-module (guix utils) #:use-module ((guix status) #:select (with-status-verbosity)) @@ -786,6 +787,35 @@ Use '~/.config/guix/channels.scm' instead.")) channels)) channels))) +(define (validate-cache-directory-ownership) + "Bail out if the cache directory is not owned by the current user." + (let ((stats dir + (let loop ((dir (cache-directory))) + (let ((stats (stat dir #f))) + (if stats + (values stats dir) + (loop (dirname dir))))))) + (let ((dir:uid (stat:uid stats)) + (our:uid (getuid))) + (unless (= dir:uid our:uid) + (let* ((user (lambda (uid) ;handle the unthinkable invalid UID + (or (false-if-exception (passwd:name + (getpwuid uid))) + uid))) + (our:user (user our:uid)) + (dir:user (user dir:uid))) + (raise + (make-compound-condition + (formatted-message + (G_ "directory '~a' is not owned by user ~a") + dir our:user) + (condition + (&fix-hint + (hint + (format #f (G_ "You should run this command as ~a; use \ +@command{sudo -i} or equivalent if you really want to pull as ~a.") + dir:user our:user))))))))))) + (define-command (guix-pull . args) (synopsis "pull the latest revision of Guix") @@ -810,6 +840,10 @@ Use '~/.config/guix/channels.scm' instead.")) ((assoc-ref opts 'generation) (process-generation-change opts profile)) (else + ;; Bail out early when users accidentally run, e.g., ’sudo guix pull’. + ;; If CACHE-DIRECTORY doesn't yet exist, test where it would end up. + (validate-cache-directory-ownership) + (with-store store (with-status-verbosity (assoc-ref opts 'verbosity) (parameterize ((%current-system (assoc-ref opts 'system)) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 68bb9040d8..4d52200b84 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, 2021, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2022 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> @@ -46,9 +46,9 @@ #:use-module (ice-9 vlist) #:use-module (ice-9 format) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) #:use-module (ice-9 binary-ports) #:export (guix-refresh)) @@ -315,12 +315,11 @@ KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed values: 'interactive' (default), 'always', and 'never'. When WARN? is true, warn about packages that have no matching updater." (if (lookup-updater package updaters) - (let-values (((version output source) - (package-update store package updaters - #:key-download key-download)) - ((loc) - (or (package-field-location package 'version) - (package-location package)))) + (let ((version output source + (package-update store package updaters + #:key-download key-download)) + (loc (or (package-field-location package 'version) + (package-location package)))) (when version (if (and=> output file-exists?) (begin diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm index 1a6df98829..004ed7af2e 100644 --- a/guix/scripts/shell.scm +++ b/guix/scripts/shell.scm @@ -256,6 +256,7 @@ Return the modified OPTS." ((('package . _) . _) #t) ((('load . _) . _) #t) ((('manifest . _) . _) #t) + ((('profile . _) . _) #t) ((('expression . _) . _) #t) ((_ . rest) (options-contain-payload? rest)))) @@ -465,6 +466,8 @@ concatenates MANIFESTS, a list of expressions." (filter-map (match-lambda (('manifest . file) (load-manifest file)) + (('profile . file) + (profile-manifest file)) (_ #f)) opts))))) (display (G_ "\ diff --git a/guix/self.scm b/guix/self.scm index 9a64051c32..36ada4d171 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -569,10 +569,12 @@ instead of 'C'." (filter package? packages)))) ":")) (setenv "LIBRARY_PATH" #$(file-append gcc "/lib")) + (setenv "GUIX_LD_WRAPPER_DISABLE_RPATH" "1") (invoke "gcc" #$(local-file source) "-Wall" "-g0" "-O2" "-I" #$(file-append guile "/include/guile/" effective) "-L" #$(file-append guile "/lib") + "-Wl,-rpath" #$(file-append guile "/lib") #$(string-append "-lguile-" effective) "-o" (string-append #$output "/bin/guile"))))) diff --git a/guix/ssh.scm b/guix/ssh.scm index 232b6bfe94..a6f0f2eb96 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -102,7 +102,8 @@ actual key does not match." (define* (open-ssh-session host #:key user port identity host-key (compression %compression) - (timeout 3600)) + (timeout 3600) + (connection-timeout 10)) "Open an SSH session for HOST and return it. IDENTITY specifies the file name of a private key to use for authenticating with the host. When USER, PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config' @@ -112,15 +113,16 @@ When HOST-KEY is true, it must be a string like \"ssh-ed25519 AAAAC3Nz… root@example.org\"; the server is authenticated and an error is raised if its host key is different from HOST-KEY. -Install TIMEOUT as the maximum time in seconds after which a read or write -operation on a channel of the returned session is considered as failing. +Error out if connection establishment takes more than CONNECTION-TIMEOUT +seconds. Install TIMEOUT as the maximum time in seconds after which a read or +write operation on a channel of the returned session is considered as failing. Throw an error on failure." (let ((session (make-session #:user user #:identity identity #:host host #:port port - #:timeout 10 ;seconds + #:timeout connection-timeout ;; #:log-verbosity 'protocol ;; Prevent libssh from reading diff --git a/guix/ui.scm b/guix/ui.scm index cb68a07c6c..a7acd41440 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -17,6 +17,7 @@ ;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2018 Steve Sprang <scs@stevesprang.com> +;;; Copyright © 2022 Taiju HIGASHI <higashi@taiju.info> ;;; ;;; This file is part of GNU Guix. ;;; @@ -1672,11 +1673,18 @@ return the underlying port. Otherwise return #f." (_ #f))) +(define (find-available-pager) + "Return the program name of an available pager or the empty string if none is +available." + (or (getenv "GUIX_PAGER") + (getenv "PAGER") + (which "less") + (which "more") + "")) + (define* (call-with-paginated-output-port proc #:key (less-options "FrX")) - (let ((pager-command-line (or (getenv "GUIX_PAGER") - (getenv "PAGER") - "less"))) + (let ((pager-command-line (find-available-pager))) ;; Setting PAGER to the empty string conventionally disables paging. (if (and (not (string-null? pager-command-line)) (isatty?* (current-output-port))) diff --git a/guix/upstream.scm b/guix/upstream.scm index 6666803a92..dac8153905 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2010-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; Copyright © 2019, 2022 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> @@ -464,6 +464,7 @@ SOURCE, an <upstream-source>." #:key-download key-download))) (values version tarball source)))))) + (define* (package-update/git-fetch store package source #:key key-download) "Return the version, checkout, and SOURCE, to update PACKAGE to SOURCE, an <upstream-source>." @@ -487,30 +488,36 @@ SOURCE, an <upstream-source>." #:optional (updaters (force %updaters)) #:key (key-download 'interactive)) "Return the new version, the file name of the new version tarball, and input -changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date. +changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date; +raise an error when the updater could not determine available releases. KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed values: 'always', 'never', and 'interactive' (default)." - (match (package-latest-release* package updaters) + (match (package-latest-release package updaters) ((? upstream-source? source) - (let ((method (match (package-source package) - ((? origin? origin) - (origin-method origin)) - (_ - #f)))) - (match (assq method %method-updates) - (#f - (raise (make-compound-condition - (formatted-message (G_ "cannot download for \ + (if (version>? (upstream-source-version source) + (package-version package)) + (let ((method (match (package-source package) + ((? origin? origin) + (origin-method origin)) + (_ + #f)))) + (match (assq method %method-updates) + (#f + (raise (make-compound-condition + (formatted-message (G_ "cannot download for \ this method: ~s") - method) - (condition - (&error-location - (location (package-location package))))))) - ((_ . update) - (update store package source - #:key-download key-download))))) + method) + (condition + (&error-location + (location (package-location package))))))) + ((_ . update) + (update store package source + #:key-download key-download)))) + (values #f #f #f))) (#f - (values #f #f #f)))) + (raise (formatted-message + (G_ "updater failed to determine available releases for ~a~%") + (package-name package)))))) (define* (update-package-source package source hash) "Modify the source file that defines PACKAGE to refer to SOURCE, an diff --git a/guix/utils.scm b/guix/utils.scm index 37b2e29800..5c36b15cfe 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -13,6 +13,7 @@ ;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2018 Steve Sprang <scs@stevesprang.com> +;;; Copyright © 2022 Taiju HIGASHI <higashi@taiju.info> ;;; ;;; This file is part of GNU Guix. ;;; @@ -158,6 +159,8 @@ (dynamic-wind (lambda () (for-each (match-lambda + ((variable #false) + (unsetenv variable)) ((variable value) (setenv variable value))) variables)) |