diff options
Diffstat (limited to 'guix')
-rw-r--r-- | guix/base16.scm | 44 | ||||
-rw-r--r-- | guix/base32.scm | 23 | ||||
-rw-r--r-- | guix/build-system/go.scm | 163 | ||||
-rw-r--r-- | guix/build-system/linux-module.scm | 4 | ||||
-rw-r--r-- | guix/build-system/renpy.scm | 2 | ||||
-rw-r--r-- | guix/build/download.scm | 42 | ||||
-rw-r--r-- | guix/build/emacs-utils.scm | 2 | ||||
-rw-r--r-- | guix/build/go-build-system.scm | 20 | ||||
-rw-r--r-- | guix/build/linux-module-build-system.scm | 9 | ||||
-rw-r--r-- | guix/build/renpy-build-system.scm | 2 | ||||
-rw-r--r-- | guix/build/syscalls.scm | 29 | ||||
-rw-r--r-- | guix/channels.scm | 9 | ||||
-rw-r--r-- | guix/cpio.scm | 21 | ||||
-rw-r--r-- | guix/download.scm | 10 | ||||
-rw-r--r-- | guix/git.scm | 92 | ||||
-rw-r--r-- | guix/graph.scm | 45 | ||||
-rw-r--r-- | guix/import/cabal.scm | 13 | ||||
-rw-r--r-- | guix/import/elpa.scm | 2 | ||||
-rw-r--r-- | guix/import/git.scm | 225 | ||||
-rw-r--r-- | guix/import/go.scm | 9 | ||||
-rw-r--r-- | guix/import/minetest.scm | 16 | ||||
-rw-r--r-- | guix/import/stackage.scm | 17 | ||||
-rw-r--r-- | guix/lint.scm | 6 | ||||
-rw-r--r-- | guix/packages.scm | 84 | ||||
-rw-r--r-- | guix/scripts/graph.scm | 11 | ||||
-rw-r--r-- | guix/scripts/import.scm | 4 | ||||
-rw-r--r-- | guix/store.scm | 41 | ||||
-rw-r--r-- | guix/swh.scm | 131 | ||||
-rw-r--r-- | guix/tests/git.scm | 7 |
29 files changed, 904 insertions, 179 deletions
diff --git a/guix/base16.scm b/guix/base16.scm index 6c15a9f588..9ac964dff0 100644 --- a/guix/base16.scm +++ b/guix/base16.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2014, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,27 +33,28 @@ (define (bytevector->base16-string bv) "Return the hexadecimal representation of BV's contents." - (define len - (bytevector-length bv)) - - (let-syntax ((base16-chars (lambda (s) - (syntax-case s () - (_ - (let ((v (list->vector - (unfold (cut > <> 255) - (lambda (n) - (format #f "~2,'0x" n)) - 1+ - 0)))) - v)))))) - (define chars base16-chars) - (let loop ((i len) - (r '())) - (if (zero? i) - (string-concatenate r) - (let ((i (- i 1))) - (loop i - (cons (vector-ref chars (bytevector-u8-ref bv i)) r))))))) + (define len (bytevector-length bv)) + (define utf8 (make-bytevector (* len 2))) + (let-syntax ((base16-octet-pairs + (lambda (s) + (syntax-case s () + (_ + (string->utf8 + (string-concatenate + (unfold (cut > <> 255) + (lambda (n) + (format #f "~2,'0x" n)) + 1+ + 0)))))))) + (define octet-pairs base16-octet-pairs) + (let loop ((i 0)) + (when (< i len) + (bytevector-u16-native-set! + utf8 (* 2 i) + (bytevector-u16-native-ref octet-pairs + (* 2 (bytevector-u8-ref bv i)))) + (loop (+ i 1)))) + (utf8->string utf8))) (define base16-string->bytevector (let ((chars->value (fold (lambda (i r) diff --git a/guix/base32.scm b/guix/base32.scm index 49f191ba26..8f097d4e77 100644 --- a/guix/base32.scm +++ b/guix/base32.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2015, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2015, 2017, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -42,6 +42,27 @@ ;;; ;;; Code: +(define-syntax bit-field + (lambda (s) + ;; This inline version of 'bit-field' assumes that START and END are + ;; literals and pre-computes the mask. In an ideal world, using 'define' + ;; or 'define-inlinable' would be enough, but as of 3.0.7, peval doesn't + ;; expand calls to 'expt' (and 'bit-field' is a subr.) + (syntax-case s () + ((_ n start end) + (let* ((s (syntax->datum #'start)) + (e (syntax->datum #'end)) + (mask (- (expt 2 (- e s)) 1))) + ;; The baseline compiler in Guile <= 3.0.7 miscompiles (ash x N) as + ;; (ash x (- N)) when N is a literal: <https://bugs.gnu.org/50696>. + ;; Here we take advantage of another bug in the baseline compiler, + ;; fixed in Guile commit 330c6ea83f492672578b62d0683acbb532d1a5d9: we + ;; introduce 'minus-start' such that it has a different source + ;; location, which in turn means that the baseline compiler pattern + ;; for (ash x N) doesn't match, thus avoiding the bug (!). + (with-syntax ((minus-start (datum->syntax #'start (- s)))) + #`(logand (ash n minus-start) #,mask))))))) + (define bytevector-quintet-ref (let* ((ref bytevector-u8-ref) (ref+ (lambda (bv offset) diff --git a/guix/build-system/go.scm b/guix/build-system/go.scm index 8f55796e86..4c1a732107 100644 --- a/guix/build-system/go.scm +++ b/guix/build-system/go.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2016 Petter <petter@mykolab.ch> ;;; Copyright © 2017 Leo Famulari <leo@famulari.name> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> +;;; Copyright © 2021 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +28,7 @@ #:use-module (guix packages) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) #:export (%go-build-system-modules go-build go-build-system @@ -78,6 +80,24 @@ present) if a pseudo-version pattern is not recognized." commit hash and its date rather than a proper release tag." (regexp-exec %go-pseudo-version-rx version)) +(define (go-target target) + ;; Parse the nix-system equivalent of the target and set the + ;; target for compilation accordingly. + (match (string-split (gnu-triplet->nix-system target) #\-) + ((arch os) + (list (match arch + ("aarch64" "arm64") + ("armhf" "arm") + ("powerpc64le" "ppc64le") + ("powerpc64" "ppc64") + ("i686" "386") + ("x86_64" "amd64") + ("mips64el" "mips64le") + (_ arch)) + (match os + ((or "mingw32" "cygwin") "windows") + (_ os)))))) + (define %go-build-system-modules ;; Build-side modules imported and used by default. `((guix build go-build-system) @@ -98,22 +118,37 @@ commit hash and its date rather than a proper release tag." (define private-keywords '(#:source #:target #:go #:inputs #:native-inputs)) - (and (not target) ;XXX: no cross-compilation - (bag - (name name) - (system system) - (host-inputs `(,@(if source - `(("source" ,source)) - '()) - ,@inputs - - ;; Keep the standard inputs of 'gnu-build-system'. - ,@(standard-packages))) - (build-inputs `(("go" ,go) - ,@native-inputs)) - (outputs outputs) - (build go-build) - (arguments (strip-keyword-arguments private-keywords arguments))))) + (bag + (name name) + (system system) + (target target) + (build-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@`(("go" ,go)) + ,@native-inputs + ,@(if target '() inputs) + ,@(if target + ;; Use the standard cross inputs of + ;; 'gnu-build-system'. + (standard-cross-packages target 'host) + '()) + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (host-inputs (if target inputs '())) + + ;; The cross-libc is really a target package, but for bootstrapping + ;; reasons, we can't put it in 'host-inputs'. Namely, 'cross-gcc' is a + ;; native package, so it would end up using a "native" variant of + ;; 'cross-libc' (built with 'gnu-build'), whereas all the other packages + ;; would use a target variant (built with 'gnu-cross-build'.) + (target-inputs (if target + (standard-cross-packages target 'target) + '())) + + (outputs outputs) + (build (if target go-cross-build go-build)) + (arguments (strip-keyword-arguments private-keywords arguments)))) (define* (go-build store name inputs #:key @@ -128,6 +163,8 @@ commit hash and its date rather than a proper release tag." (tests? #t) (allow-go-reference? #f) (system (%current-system)) + (goarch (first (go-target (%current-system)))) + (goos (last (go-target (%current-system)))) (guile #f) (imported-modules %go-build-system-modules) (modules '((guix build go-build-system) @@ -147,6 +184,8 @@ commit hash and its date rather than a proper release tag." #:system ,system #:phases ,phases #:outputs %outputs + #:goarch ,goarch + #:goos ,goos #:search-paths ',(map search-path-specification->sexp search-paths) #:install-source? ,install-source? @@ -174,6 +213,98 @@ commit hash and its date rather than a proper release tag." #:outputs outputs #:guile-for-build guile-for-build)) +(define* (go-cross-build store name + #:key + target native-drvs target-drvs + (phases '(@ (guix build go-build-system) + %standard-phases)) + (outputs '("out")) + (search-paths '()) + (native-search-paths '()) + (install-source? #t) + (import-path "") + (unpack-path "") + (build-flags ''()) + (tests? #f) ; nothing can be done + (allow-go-reference? #f) + (system (%current-system)) + (goarch (first (go-target target))) + (goos (last (go-target target))) + (guile #f) + (imported-modules %go-build-system-modules) + (modules '((guix build go-build-system) + (guix build union) + (guix build utils)))) + "Cross-build NAME using GO, where TARGET is a GNU triplet and with INPUTS." + (define builder + `(begin + (use-modules ,@modules) + (let () + (define %build-host-inputs + ',(map (match-lambda + ((name (? derivation? drv) sub ...) + `(,name . ,(apply derivation->output-path drv sub))) + ((name path) + `(,name . ,path))) + native-drvs)) + + (define %build-target-inputs + ',(map (match-lambda + ((name (? derivation? drv) sub ...) + `(,name . ,(apply derivation->output-path drv sub))) + ((name (? package? pkg) sub ...) + (let ((drv (package-cross-derivation store pkg + target system))) + `(,name . ,(apply derivation->output-path drv sub)))) + ((name path) + `(,name . ,path))) + target-drvs)) + + (go-build #:name ,name + #:source ,(match (assoc-ref native-drvs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:system ,system + #:phases ,phases + #:outputs %outputs + #:target ,target + #:goarch ,goarch + #:goos ,goos + #:inputs %build-target-inputs + #:native-inputs %build-host-inputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:native-search-paths ',(map + search-path-specification->sexp + native-search-paths) + #:install-source? ,install-source? + #:import-path ,import-path + #:unpack-path ,unpack-path + #:build-flags ,build-flags + #:tests? ,tests? + #:allow-go-reference? ,allow-go-reference? + #:inputs %build-inputs)))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:system system + #:inputs (append native-drvs target-drvs) + #:outputs outputs + #:modules imported-modules + #:guile-for-build guile-for-build)) + (define go-build-system (build-system (name 'go) diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm index fc3d959ce7..33bc8c95df 100644 --- a/guix/build-system/linux-module.scm +++ b/guix/build-system/linux-module.scm @@ -158,6 +158,7 @@ (outputs '("out")) (make-flags ''()) (system (%current-system)) + (source-directory ".") (guile #f) (substitutable? #t) (imported-modules @@ -175,7 +176,8 @@ ((source) source) (source - source)) + source)) + #:source-directory ,source-directory #:search-paths ',(map search-path-specification->sexp search-paths) #:phases ,phases diff --git a/guix/build-system/renpy.scm b/guix/build-system/renpy.scm index 35edc0056d..5ed59bf5a5 100644 --- a/guix/build-system/renpy.scm +++ b/guix/build-system/renpy.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/download.scm b/guix/build/download.scm index 54627eefa2..1ed623034b 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -678,6 +678,18 @@ and write the output to FILE." (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) @@ -747,15 +759,20 @@ otherwise simply ignore them." content-addressed-mirrors)) (define disarchive-uris - (append-map (match-lambda - ((? string? mirror) - (map (match-lambda - ((hash-algo . hash) - (string->uri - (string-append mirror - (symbol->string hash-algo) "/" - (bytevector->base16-string hash))))) - hashes))) + (append-map (lambda (mirror) + (let ((make-url (match mirror + ((? string?) + (lambda (hash-algo hash) + (string-append + mirror + (symbol->string hash-algo) "/" + (bytevector->base16-string hash)))) + ((? procedure?) + mirror)))) + (map (match-lambda + ((hash-algo . hash) + (string->uri (make-url hash-algo hash)))) + hashes))) disarchive-mirrors)) ;; Make this unbuffered so 'progress-report/file' works as expected. 'line @@ -764,7 +781,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/go-build-system.scm b/guix/build/go-build-system.scm index 227df820db..645d2fe680 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -4,7 +4,7 @@ ;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2020 Jack Hill <jackhill@jackhill.us> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> -;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2020, 2021 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -131,7 +131,7 @@ ;; ;; Code: -(define* (setup-go-environment #:key inputs outputs #:allow-other-keys) +(define* (setup-go-environment #:key inputs outputs goos goarch #:allow-other-keys) "Prepare a Go build environment for INPUTS and OUTPUTS. Build a file system union of INPUTS. Export GOPATH, which helps the compiler find the source code of the package being built and its dependencies, and GOBIN, which determines @@ -149,6 +149,22 @@ dependencies, so it should be self-contained." ;; GOPATH behavior. (setenv "GO111MODULE" "off") (setenv "GOBIN" (string-append (assoc-ref outputs "out") "/bin")) + + ;; Make sure we're building for the correct architecture and OS targets + ;; that Guix targets. + (setenv "GOARCH" goarch) + (setenv "GOOS" goos) + (match goarch + ("arm" + (setenv "GOARM" "7")) + ((or "mips" "mipsel") + (setenv "GOMIPS" "hardfloat")) + ((or "mips64" "mips64le") + (setenv "GOMIPS64" "hardfloat")) + ((or "ppc64" "ppc64le") + (setenv "GOPPC64" "power8")) + (_ #t)) + (let ((tmpdir (tmpnam))) (match (go-inputs inputs) (((names . directories) ...) diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm index d51d76f94b..729ab6154f 100644 --- a/guix/build/linux-module-build-system.scm +++ b/guix/build/linux-module-build-system.scm @@ -49,16 +49,17 @@ ; TODO: kernel ".config". #t) -(define* (build #:key inputs make-flags #:allow-other-keys) +(define* (build #:key inputs make-flags (source-directory ".") #:allow-other-keys) (apply invoke "make" "-C" (string-append (assoc-ref inputs "linux-module-builder") "/lib/modules/build") - (string-append "M=" (getcwd)) + (string-append "M=" (getcwd) "/" source-directory) (or make-flags '()))) ;; This block was copied from make-linux-libre--only took the "modules_install" ;; part. -(define* (install #:key make-flags inputs native-inputs outputs +(define* (install #:key make-flags (source-directory ".") + inputs native-inputs outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) (moddir (string-append out "/lib/modules"))) @@ -67,7 +68,7 @@ (apply invoke "make" "-C" (string-append (assoc-ref inputs "linux-module-builder") "/lib/modules/build") - (string-append "M=" (getcwd)) + (string-append "M=" (getcwd) "/" 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 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/download.scm b/guix/download.scm index d60c898c57..85b97a4766 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -369,7 +369,7 @@ ;; procedure that takes a file name, an algorithm (symbol) and a hash ;; (bytevector), and returns a URL or #f. '(begin - (use-modules (guix base32)) + (use-modules (guix base16) (guix base32)) (define (guix-publish host) (lambda (file algo hash) @@ -379,12 +379,6 @@ file "/" (symbol->string algo) "/" (bytevector->nix-base32-string hash)))) - ;; XXX: (guix base16) appeared in March 2017 (and thus 0.13.0) so old - ;; installations of the daemon might lack it. Thus, load it lazily to - ;; avoid gratuitous errors. See <https://bugs.gnu.org/33542>. - (module-autoload! (current-module) - '(guix base16) '(bytevector->base16-string)) - (list (guix-publish "ci.guix.gnu.org") (lambda (file algo hash) ;; 'tarballs.nixos.org' supports several algorithms. @@ -406,6 +400,8 @@ (object->string %content-addressed-mirrors))) (define %disarchive-mirrors + ;; TODO: Eventually turn into a procedure that takes a hash algorithm + ;; (symbol) and hash (bytevector). '("https://disarchive.ngyro.com/")) (define %disarchive-mirror-file 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/cabal.scm b/guix/import/cabal.scm index e9a0179b3d..98d7234098 100644 --- a/guix/import/cabal.scm +++ b/guix/import/cabal.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; ;;; This file is part of GNU Guix. ;;; @@ -399,14 +400,20 @@ matching a string against the created regexp." (define (is-or s) (string=? s "||")) -(define (is-id s port) +(define (is-id s port loc) (let ((cabal-reserved-words '("if" "else" "library" "flag" "executable" "test-suite" "custom-setup" "source-repository" "benchmark" "common")) (spaces (read-while (cut char-set-contains? char-set:blank <>) port)) (c (peek-char port))) (unread-string spaces port) - (and (every (cut string-ci<> s <>) cabal-reserved-words) + ;; Sometimes the name of an identifier is the same as one of the reserved + ;; words, which would normally lead to an error, see + ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=25138>. Unless the word + ;; is at the beginning of a line (excluding whitespace), treat is as just + ;; another identifier instead of a reserved word. + (and (or (not (= (source-location-column loc) (current-indentation))) + (every (cut string-ci<> s <>) cabal-reserved-words)) (and (not (char=? (last (string->list s)) #\:)) (not (char=? #\: c)))))) @@ -568,7 +575,7 @@ LOC is the current port location." ((is-none w) (lex-none loc)) ((is-and w) (lex-and loc)) ((is-or w) (lex-or loc)) - ((is-id w port) (lex-id w loc)) + ((is-id w port loc) (lex-id w loc)) (else (unread-string w port) #f)))) (define (lex-line port loc) diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index fb59acc9e3..96ebc17af1 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -259,7 +259,7 @@ RECIPE." ((assoc-ref recipe #:commit) => (lambda (commit) (cons 'commit commit))) (else - '(branch . "master")))) + '()))) (let-values (((directory commit) (download-git-repository url ref))) `(origin 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..9769b557ae 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -480,7 +480,7 @@ build a package." (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 @@ -619,7 +619,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 +630,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 root-module-path) + '() + `(#:unpack-path ,root-module-path)))) ,@(maybe-propagated-inputs (map (match-lambda ((name version) diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm index e1f8487b75..29bf12d123 100644 --- a/guix/import/minetest.scm +++ b/guix/import/minetest.scm @@ -337,6 +337,14 @@ 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)) + ;; 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 +379,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 +444,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 diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index bbd903a2cd..731e69651e 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -2,6 +2,7 @@ ;;; 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> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,10 +22,12 @@ (define-module (guix import stackage) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (ice-9 control) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (srfi srfi-43) #:use-module (guix import json) #:use-module (guix import hackage) #:use-module (guix import utils) @@ -141,11 +144,23 @@ PACKAGE or #f if the package is not included in the Stackage LTS release." (version version) (urls (list url)))))))))) +(define (stackage-package? package) + "Whether PACKAGE is available on the default Stackage LTS release." + (and (hackage-package? package) + (let ((packages (lts-info-packages + (stackage-lts-info-fetch %default-lts-version))) + (hackage-name (guix-package->hackage-name package))) + (vector-any identity + (vector-map + (lambda (_ metadata) + (string=? (cdr (list-ref metadata 2)) hackage-name)) + packages))))) + (define %stackage-updater (upstream-updater (name 'stackage) (description "Updater for Stackage LTS packages") - (pred hackage-package?) + (pred stackage-package?) (latest latest-lts-release))) ;;; stackage.scm ends here diff --git a/guix/lint.scm b/guix/lint.scm index ffd3f7007e..527fda165a 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -1562,7 +1562,11 @@ Disarchive entry refers to non-existent SWH directory '~a'") #:field 'source))))))) ((? content?) '()))) - '())))) + '())) + (_ + (list (make-warning package + (G_ "unsupported source type") + #:field 'source))))) (match-lambda* (('swh-error url method response) (response->warning url method response)) diff --git a/guix/packages.scm b/guix/packages.scm index c825f427d8..ad7937b4fb 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -52,6 +52,7 @@ #:re-export (%current-system %current-target-system search-path-specification) ;for convenience + #:replace ((define-public* . define-public)) #:export (content-hash content-hash? content-hash-algorithm @@ -99,6 +100,7 @@ package-supported-systems package-properties package-location + package-definition-location hidden-package hidden-package? package-superseded @@ -360,6 +362,59 @@ name of its URI." ;; <https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00790.html>. (fold delete %supported-systems '("mips64el-linux"))) +(define-syntax current-location-vector + (lambda (s) + "Like 'current-source-location' but expand to a literal vector with +one-indexed line numbers." + ;; Storing a literal vector in .go files is more efficient than storing an + ;; alist: less initialization code, fewer relocations, etc. + (syntax-case s () + ((_) + (match (syntax-source s) + (#f #f) + (properties + (let ((file (assq-ref properties 'filename)) + (line (assq-ref properties 'line)) + (column (assq-ref properties 'column))) + (and file line column + #`#(#,file #,(+ 1 line) #,column))))))))) + +(define-inlinable (sanitize-location loc) + ;; Convert LOC to a vector or to #f. + (cond ((vector? loc) loc) + ((not loc) loc) + (else (vector (location-file loc) + (location-line loc) + (location-column loc))))) + +(define-syntax-parameter current-definition-location + ;; Location of the encompassing 'define-public'. + (const #f)) + +(define-syntax define-public* + (lambda (s) + "Like 'define-public' but set 'current-definition-location' for the +lexical scope of its body." + (define location + (match (syntax-source s) + (#f #f) + (properties + (let ((line (assq-ref properties 'line)) + (column (assq-ref properties 'column))) + ;; Don't repeat the file name since it's redundant with 'location'. + ;; Encode the whole thing so that it fits in a fixnum on 32-bit + ;; platforms, which leaves us 29 bits: 7 bits for COLUMN (which is + ;; almost always zero), and 22 bits for LINE. + (and line column + (logior (ash (logand #x7f column) 22) + (logand (- (expt 2 22) 1) (+ 1 line)))))))) + + (syntax-case s () + ((_ prototype body ...) + #`(define-public prototype + (syntax-parameterize ((current-definition-location + (lambda (s) #,location))) + body ...)))))) ;; A package. (define-record-type* <package> @@ -404,10 +459,12 @@ name of its URI." (properties package-properties (default '())) ; alist for anything else - (location package-location - (default (and=> (current-source-location) - source-properties->location)) - (innate))) + (location package-location-vector + (default (current-location-vector)) + (innate) (sanitize sanitize-location)) + (definition-location package-definition-location-code + (default (current-definition-location)) + (innate))) (set-record-type-printer! <package> (lambda (package port) @@ -425,6 +482,25 @@ name of its URI." package) 16))))) +(define (package-location package) + "Return the source code location of PACKAGE as a <location> record, or #f if +it is not known." + (match (package-location-vector package) + (#f #f) + (#(file line column) (location file line column)))) + +(define (package-definition-location package) + "Like 'package-location', but return the location of the definition +itself--i.e., that of the enclosing 'define-public' form, if any, or #f." + (match (package-definition-location-code package) + (#f #f) + (code + (let ((column (bit-extract code 22 29)) + (line (bit-extract code 0 21))) + (match (package-location-vector package) + (#f #f) + (#(file _ _) (location file line column))))))) + (define-syntax-rule (package/inherit p overrides ...) "Like (package (inherit P) OVERRIDES ...), except that the same transformation is done to the package P's replacement, if any. P must be a bare 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/import.scm b/guix/scripts/import.scm index 11e94769bb..40fa6759ae 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; ;;; This file is part of GNU Guix. ;;; @@ -118,7 +119,8 @@ Run IMPORTER with ARGS.\n")) (if (member importer importers) (let ((print (lambda (expr) (pretty-print expr (newline-rewriting-port - (current-output-port)))))) + (current-output-port)) + #:max-expr-width 80)))) (match (apply (resolve-importer importer) args) ((and expr (or ('package _ ...) ('let _ ...) diff --git a/guix/store.scm b/guix/store.scm index 0463b0e8fa..89a719bcfc 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1355,14 +1355,16 @@ on the build output of a previous derivation." (unresolved things continue) (continue #t))) -(define (map/accumulate-builds store proc lst) +(define* (map/accumulate-builds store proc lst + #:key (cutoff 30)) "Apply PROC over each element of LST, accumulating 'build-things' calls and -coalescing them into a single call." - (define accumulation-cutoff - ;; Threshold above which we stop accumulating unresolved nodes to avoid - ;; pessimal behavior where we keep stumbling upon the same .drv build - ;; requests with many incoming edges. See <https://bugs.gnu.org/49439>. - 30) +coalescing them into a single call. + +CUTOFF is the threshold above which we stop accumulating unresolved nodes." + + ;; The CUTOFF parameter helps avoid pessimal behavior where we keep + ;; stumbling upon the same .drv build requests with many incoming edges. + ;; See <https://bugs.gnu.org/49439>. (define-values (result rest) (let loop ((lst lst) @@ -1373,7 +1375,7 @@ coalescing them into a single call." (match (with-build-handler build-accumulator (proc head)) ((? unresolved? obj) - (if (> unresolved accumulation-cutoff) + (if (>= unresolved cutoff) (values (reverse (cons obj result)) tail) (loop tail (cons obj result) (+ 1 unresolved)))) (obj @@ -1390,17 +1392,20 @@ coalescing them into a single call." ;; REST is necessarily empty. result) (to-build - ;; We've accumulated things TO-BUILD. Actually build them and resume the - ;; corresponding continuations. + ;; We've accumulated things TO-BUILD; build them. (build-things store (delete-duplicates to-build)) - (map/accumulate-builds store - (lambda (obj) - (if (unresolved? obj) - ;; Pass #f because 'build-things' is now - ;; unnecessary. - ((unresolved-continuation obj) #f) - obj)) - (append result rest))))) + + ;; Resume the continuations corresponding to TO-BUILD, and then process + ;; REST. + (append (map/accumulate-builds store + (lambda (obj) + (if (unresolved? obj) + ;; Pass #f because 'build-things' is now + ;; unnecessary. + ((unresolved-continuation obj) #f) + obj)) + result #:cutoff cutoff) + (map/accumulate-builds store proc rest #:cutoff cutoff))))) (define build-things (let ((build (operation (build-things (string-list things) diff --git a/guix/swh.scm b/guix/swh.scm index 76234b4358..5c41685a24 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -538,35 +538,57 @@ directory entries; if it has type 'file, return its <content> object." (path "/api/1/origin/save" type "url" url) json->save-reply) -(define-query (query-vault id kind) - "Ask the availability of object ID and KIND to the vault, where KIND is -'directory or 'revision. Return #f if it could not be found, or a -<vault-reply> on success." - ;; <https://docs.softwareheritage.org/devel/swh-vault/api.html#vault-api-ref> - ;; There's a single format supported for directories and revisions and for - ;; now, the "/format" bit of the URL *must* be omitted. - (path "/api/1/vault" (symbol->string kind) id) - json->vault-reply) - -(define (request-cooking id kind) - "Request the cooking of object ID and KIND (one of 'directory or 'revision) -to the vault. Return a <vault-reply>." - (call (swh-url "/api/1/vault" (symbol->string kind) id) +(define* (vault-url id kind #:optional (archive-type 'flat)) + "Return the vault query/cooking URL for ID and KIND. Normally, ID is an +SWHID and KIND is #f; the deprecated convention is to set ID to a raw +directory or revision ID and KIND to 'revision or 'directory." + ;; Note: /api/1/vault/directory/ID was deprecated in favor of + ;; /api/1/vault/flat/SWHID; this procedure "converts" automatically. + (let ((id (match kind + ('directory (string-append "swh:1:dir:" id)) + ('revision (string-append "swh:1:rev:" id)) + (#f id)))) + (swh-url "/api/1/vault" (symbol->string archive-type) id))) + +(define* (query-vault id #:optional kind #:key (archive-type 'flat)) + "Ask the availability of object ID (an SWHID) to the vault. Return #f if it +could not be found, or a <vault-reply> on success. ARCHIVE-TYPE can be 'flat +for a tarball containing a directory, or 'git-bare for a tarball containing a +bare Git repository corresponding to a revision. + +Passing KIND (one of 'directory or 'revision) together with a raw revision or +directory identifier is deprecated." + (call (vault-url id kind archive-type) + json->vault-reply)) + +(define* (request-cooking id #:optional kind #:key (archive-type 'flat)) + "Request the cooking of object ID, an SWHID. Return a <vault-reply>. +ARCHIVE-TYPE can be 'flat for a tarball containing a directory, or 'git-bare +for a tarball containing a bare Git repository corresponding to a revision. + +Passing KIND (one of 'directory or 'revision) together with a raw revision or +directory identifier is deprecated." + (call (vault-url id kind archive-type) json->vault-reply http-post*)) -(define* (vault-fetch id kind - #:key (log-port (current-error-port))) - "Return an input port from which a bundle of the object with the given ID -and KIND (one of 'directory or 'revision) can be retrieved, or #f if the -object could not be found. - -For a directory, the returned stream is a gzip-compressed tarball. For a -revision, it is a gzip-compressed stream for 'git fast-import'." - (let loop ((reply (query-vault id kind))) +(define* (vault-fetch id + #:optional kind + #:key + (archive-type 'flat) + (log-port (current-error-port))) + "Return an input port from which a bundle of the object with the given ID, +an SWHID, or #f if the object could not be found. + +ARCHIVE-TYPE can be 'flat for a tarball containing a directory, or 'git-bare +for a tarball containing a bare Git repository corresponding to a revision." + (let loop ((reply (query-vault id kind + #:archive-type archive-type))) (match reply (#f - (and=> (request-cooking id kind) loop)) + (and=> (request-cooking id kind + #:archive-type archive-type) + loop)) (_ (match (vault-reply-status reply) ('done @@ -586,7 +608,8 @@ revision, it is a gzip-compressed stream for 'git fast-import'." (format log-port "SWH vault: failure: ~a~%" (vault-reply-progress-message reply)) (format log-port "SWH vault: retrying...~%") - (loop (request-cooking id kind))) + (loop (request-cooking id kind + #:archive-type archive-type))) ((and (or 'new 'pending) status) ;; Wait until the bundle shows up. (let ((message (vault-reply-progress-message reply))) @@ -601,7 +624,8 @@ requested bundle cooking, waiting for completion...~%")) ;; requests per hour per IP address.) (sleep (if (eq? status 'new) 60 30)) - (loop (query-vault id kind))))))))) + (loop (query-vault id kind + #:archive-type archive-type))))))))) ;;; @@ -621,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))) @@ -648,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!" @@ -655,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. @@ -670,7 +714,18 @@ 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~%" + reference url) #f))) 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)) |