diff options
Diffstat (limited to 'guix')
30 files changed, 1750 insertions, 192 deletions
diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm index 7bafee5a7a..0eab919deb 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) @@ -184,6 +186,7 @@ #: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)) @@ -201,6 +204,7 @@ (guile #f) (outputs '("out")) (make-flags ''()) + (parallel-build? #t) (search-paths '()) (native-search-paths '()) (tests? #f) 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/download.scm b/guix/build/download.scm index c8ddadfdd4..fd8fe69901 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -674,10 +674,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 +782,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-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/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/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/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..99a3b45004 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 @@ -450,6 +454,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 +655,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) 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/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/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/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/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/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/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/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..d73fbe6a81 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -55,8 +55,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 +68,7 @@ "containers" "deepseq" "directory" + "exceptions" "filepath" "ghc" "ghc-boot" @@ -121,12 +122,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))))))) @@ -351,7 +352,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) diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm index e1f8487b75..0f3ab473ca 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, @@ -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/pypi.scm b/guix/import/pypi.scm index f3619dcd9e..e2314820d0 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -9,6 +9,7 @@ ;;; 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> ;;; ;;; This file is part of GNU Guix. ;;; @@ -163,12 +164,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 +418,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]+" (pk name)) + `((properties ,`'(("upstream-name" . ,name)))) + '())) + (call-with-temporary-output-file (lambda (temp port) (and (url-fetch source-url temp) @@ -454,6 +461,7 @@ 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) diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index bbd903a2cd..f58c6b163d 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.10") + +(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/packages.scm b/guix/packages.scm index 3953b7f79b..fa23cc39b3 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> @@ -363,6 +363,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 diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 66de824ef4..439fae0b52 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_ " + --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/home.scm b/guix/scripts/home.scm new file mode 100644 index 0000000000..55e7b436c1 --- /dev/null +++ b/guix/scripts/home.scm @@ -0,0 +1,524 @@ +;;; 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 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)))) + (import-manifest manifest (current-output-port)))) + ((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..611f580e85 --- /dev/null +++ b/guix/scripts/home/import.scm @@ -0,0 +1,243 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Andrew Tropin <andrew@trop.in> +;;; +;;; 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) + #:use-module (gnu packages) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (import-manifest)) + +;;; Commentary: +;;; +;;; This module provides utilities for generating home service +;;; configurations from existing "dotfiles". +;;; +;;; Code: + + +(define (generate-bash-module+configuration) + (let ((rc (string-append (getenv "HOME") "/.bashrc")) + (profile (string-append (getenv "HOME") "/.bash_profile")) + (logout (string-append (getenv "HOME") "/.bash_logout"))) + `((gnu home services bash) + (service home-bash-service-type + (home-bash-configuration + ,@(if (file-exists? rc) + `((bashrc + (list (local-file ,rc)))) + '()) + ,@(if (file-exists? profile) + `((bash-profile + (list (local-file ,profile)))) + '()) + ,@(if (file-exists? logout) + `((bash-logout + (list (local-file ,logout)))) + '())))))) + + +(define %files-configurations-alist + `((".bashrc" . ,generate-bash-module+configuration) + (".bash_profile" . ,generate-bash-module+configuration) + (".bash_logout" . ,generate-bash-module+configuration))) + +(define (modules+configurations) + (let ((configurations (delete-duplicates + (filter-map (match-lambda + ((file . proc) + (if (file-exists? + (string-append (getenv "HOME") "/" file)) + proc + #f))) + %files-configurations-alist) + (lambda (x y) + (equal? (procedure-name x) (procedure-name y)))))) + (map (lambda (proc) (proc)) configurations))) + +;; Based on `manifest->code' from (guix profiles) +;; MAYBE: Upstream it? +(define* (manifest->code manifest + #:key + (entry-package-version (const "")) + (home-environment? #f)) + "Return an sexp representing code to build an approximate version of +MANIFEST; the code is wrapped in a top-level 'begin' form. If +HOME-ENVIRONMENT? is #t, return an <home-environment> definition. +Call ENTRY-PACKAGE-VERSION to determine the version number to use in +the spec for a given entry; it can be set to 'manifest-entry-version' +for fully-specified version numbers, or to some other procedure to +disambiguate versions for packages for which several versions are +available." + (define (entry-transformations entry) + ;; Return the transformations that apply to ENTRY. + (assoc-ref (manifest-entry-properties entry) 'transformations)) + + (define transformation-procedures + ;; List of transformation options/procedure name pairs. + (let loop ((entries (manifest-entries manifest)) + (counter 1) + (result '())) + (match entries + (() result) + ((entry . tail) + (match (entry-transformations entry) + (#f + (loop tail counter result)) + (options + (if (assoc-ref result options) + (loop tail counter result) + (loop tail (+ 1 counter) + (alist-cons options + (string->symbol + (format #f "transform~a" counter)) + result))))))))) + + (define (qualified-name entry) + ;; Return the name of ENTRY possibly with "@" followed by a version. + (match (entry-package-version entry) + ("" (manifest-entry-name entry)) + (version (string-append (manifest-entry-name entry) + "@" version)))) + + (if (null? transformation-procedures) + (let ((specs (map (lambda (entry) + (match (manifest-entry-output entry) + ("out" (qualified-name entry)) + (output (string-append (qualified-name entry) + ":" output)))) + (manifest-entries manifest)))) + (if home-environment? + (let ((modules+configurations (modules+configurations))) + `(begin + (use-modules (gnu home) + (gnu packages) + ,@(map first modules+configurations)) + ,(home-environment-template + #:specs specs + #:services (map second modules+configurations)))) + `(begin + (use-modules (gnu packages)) + + (specifications->manifest + (list ,@specs))))) + (let* ((transform (lambda (options exp) + (if (not options) + exp + (let ((proc (assoc-ref transformation-procedures + options))) + `(,proc ,exp))))) + (packages (map (lambda (entry) + (define options + (entry-transformations entry)) + + (define name + (qualified-name entry)) + + (match (manifest-entry-output entry) + ("out" + (transform options + `(specification->package ,name))) + (output + `(list ,(transform + options + `(specification->package ,name)) + ,output)))) + (manifest-entries manifest))) + (transformations (map (match-lambda + ((options . name) + `(define ,name + (options->transformation ',options)))) + transformation-procedures))) + (if home-environment? + (let ((modules+configurations (modules+configurations))) + `(begin + (use-modules (guix transformations) + (gnu home) + (gnu packages) + ,@(map first modules+configurations)) + + ,@transformations + + ,(home-environment-template + #:packages packages + #:services (map second modules+configurations)))) + `(begin + (use-modules (guix transformations) + (gnu packages)) + + ,@transformations + + (packages->manifest + (list ,@packages))))))) + +(define* (home-environment-template #:key (packages #f) (specs #f) services) + "Return an S-exp containing a <home-environment> declaration +containing PACKAGES, or SPECS (package specifications), and SERVICES." + `(home-environment + (packages + ,@(if packages + `((list ,@packages)) + `((map specification->package + (list ,@specs))))) + (services (list ,@services)))) + +(define* (import-manifest + manifest + #:optional (port (current-output-port))) + "Write to PORT a <home-environment> 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 + #:home-environment? #t) + (('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/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/system.scm b/guix/scripts/system.scm index 65eb98e4b2..7faa92fd7d 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)))))))) @@ -1212,13 +1213,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)) diff --git a/guix/self.scm b/guix/self.scm index 79d93357a2..61ff423086 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -958,13 +958,23 @@ 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 *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*) + *system-modules* *home-modules*) #:extensions dependencies #:guile-for-build guile-for-build)) @@ -1012,6 +1022,7 @@ itself." *cli-modules* *system-test-modules* *system-modules* + *home-modules* *package-modules* *core-package-modules* *extra-modules* diff --git a/guix/swh.scm b/guix/swh.scm index a62567dd58..5c41685a24 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -645,20 +645,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 +681,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 +696,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 +714,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/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)) |