summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/base16.scm44
-rw-r--r--guix/base32.scm23
-rw-r--r--guix/build-system/go.scm163
-rw-r--r--guix/build-system/linux-module.scm4
-rw-r--r--guix/build-system/renpy.scm2
-rw-r--r--guix/build/download.scm42
-rw-r--r--guix/build/emacs-utils.scm2
-rw-r--r--guix/build/go-build-system.scm20
-rw-r--r--guix/build/linux-module-build-system.scm9
-rw-r--r--guix/build/renpy-build-system.scm2
-rw-r--r--guix/build/syscalls.scm29
-rw-r--r--guix/channels.scm9
-rw-r--r--guix/cpio.scm21
-rw-r--r--guix/download.scm10
-rw-r--r--guix/git.scm92
-rw-r--r--guix/graph.scm45
-rw-r--r--guix/import/cabal.scm13
-rw-r--r--guix/import/elpa.scm2
-rw-r--r--guix/import/git.scm225
-rw-r--r--guix/import/go.scm9
-rw-r--r--guix/import/minetest.scm16
-rw-r--r--guix/import/stackage.scm17
-rw-r--r--guix/lint.scm6
-rw-r--r--guix/packages.scm84
-rw-r--r--guix/scripts/graph.scm11
-rw-r--r--guix/scripts/import.scm4
-rw-r--r--guix/store.scm41
-rw-r--r--guix/swh.scm131
-rw-r--r--guix/tests/git.scm7
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))
generated by cgit v1.2.3 (git 2.45.2) at 2024-08-29 14:30:08 +0000