summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/cargo.scm5
-rw-r--r--guix/build-system/go.scm35
-rw-r--r--guix/build-system/node.scm2
-rw-r--r--guix/build-system/python.scm6
-rw-r--r--guix/build/cargo-build-system.scm76
-rw-r--r--guix/build/download.scm40
-rw-r--r--guix/build/syscalls.scm78
-rw-r--r--guix/channels.scm2
-rw-r--r--guix/download.scm49
-rw-r--r--guix/git-download.scm11
-rw-r--r--guix/gnu-maintenance.scm162
-rw-r--r--guix/http-client.scm11
-rw-r--r--guix/import/gnome.scm12
-rw-r--r--guix/import/go.scm547
-rw-r--r--guix/import/utils.scm1
-rw-r--r--guix/inferior.scm19
-rw-r--r--guix/licenses.scm7
-rw-r--r--guix/narinfo.scm27
-rw-r--r--guix/packages.scm4
-rw-r--r--guix/scripts/build.scm4
-rw-r--r--guix/scripts/describe.scm2
-rw-r--r--guix/scripts/import.scm2
-rw-r--r--guix/scripts/import/go.scm118
-rw-r--r--guix/scripts/package.scm5
-rwxr-xr-xguix/scripts/substitute.scm122
-rw-r--r--guix/scripts/system.scm8
-rw-r--r--guix/scripts/time-machine.scm5
-rw-r--r--guix/scripts/weather.scm20
-rw-r--r--guix/self.scm6
-rw-r--r--guix/status.scm5
-rw-r--r--guix/substitutes.scm49
-rw-r--r--guix/tests.scm4
-rw-r--r--guix/tests/http.scm38
-rw-r--r--guix/utils.scm20
34 files changed, 1301 insertions, 201 deletions
diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm
index ed69746a3b..0c76ba9355 100644
--- a/guix/build-system/cargo.scm
+++ b/guix/build-system/cargo.scm
@@ -5,6 +5,7 @@
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
+;;; Copyright © 2021 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -77,8 +78,10 @@ to NAME and VERSION."
(vendor-dir "guix-vendor")
(cargo-build-flags ''("--release"))
(cargo-test-flags ''("--release"))
+ (cargo-package-flags ''("--no-metadata" "--no-verify"))
(features ''())
(skip-build? #f)
+ (install-source? #t)
(phases '(@ (guix build cargo-build-system)
%standard-phases))
(outputs '("out"))
@@ -106,8 +109,10 @@ to NAME and VERSION."
#:vendor-dir ,vendor-dir
#:cargo-build-flags ,cargo-build-flags
#:cargo-test-flags ,cargo-test-flags
+ #:cargo-package-flags ,cargo-package-flags
#:features ,features
#:skip-build? ,skip-build?
+ #:install-source? ,install-source?
#:tests? ,(and tests? (not skip-build?))
#:phases ,phases
#:outputs %outputs
diff --git a/guix/build-system/go.scm b/guix/build-system/go.scm
index f8ebaefb27..0e2c1cd2ee 100644
--- a/guix/build-system/go.scm
+++ b/guix/build-system/go.scm
@@ -26,9 +26,12 @@
#:use-module (guix build-system gnu)
#:use-module (guix packages)
#:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
#:export (%go-build-system-modules
go-build
- go-build-system))
+ go-build-system
+
+ go-version->git-ref))
;; Commentary:
;;
@@ -37,6 +40,36 @@
;;
;; Code:
+(define %go-version-rx
+ (make-regexp (string-append
+ "(v?[0-9]\\.[0-9]\\.[0-9])" ;"v" prefix can be omitted in version prefix
+ "(-|-pre\\.0\\.|-0\\.)" ;separator
+ "([0-9]{14})-" ;timestamp
+ "([0-9A-Fa-f]{12})"))) ;commit hash
+
+(define (go-version->git-ref version)
+ "Parse VERSION, a \"pseudo-version\" as defined at
+<https://golang.org/ref/mod#pseudo-versions>, and extract the commit hash from
+it, defaulting to full VERSION if a pseudo-version pattern is not recognized."
+ ;; A module version like v1.2.3 is introduced by tagging a revision in the
+ ;; underlying source repository. Untagged revisions can be referred to
+ ;; using a "pseudo-version" like v0.0.0-yyyymmddhhmmss-abcdefabcdef, where
+ ;; the time is the commit time in UTC and the final suffix is the prefix of
+ ;; the commit hash (see: https://golang.org/ref/mod#pseudo-versions).
+ (let* ((version
+ ;; If a source code repository has a v2.0.0 or later tag for a file
+ ;; tree with no go.mod, the version is considered to be part of the
+ ;; v1 module's available versions and is given an +incompatible
+ ;; suffix
+ ;; (see:https://golang.org/cmd/go/#hdr-Module_compatibility_and_semantic_versioning).
+ (if (string-suffix? "+incompatible" version)
+ (string-drop-right version 13)
+ version))
+ (match (regexp-exec %go-version-rx version)))
+ (if match
+ (match:substring match 4)
+ version)))
+
(define %go-build-system-modules
;; Build-side modules imported and used by default.
`((guix build go-build-system)
diff --git a/guix/build-system/node.scm b/guix/build-system/node.scm
index 05c24c47d5..a8c5eed09b 100644
--- a/guix/build-system/node.scm
+++ b/guix/build-system/node.scm
@@ -18,8 +18,6 @@
(define-module (guix build-system node)
#:use-module (guix store)
- #:use-module (guix build json)
- #:use-module (guix build union)
#:use-module (guix utils)
#:use-module (guix packages)
#:use-module (guix derivations)
diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm
index 2bb6fa87ca..9f3159a960 100644
--- a/guix/build-system/python.scm
+++ b/guix/build-system/python.scm
@@ -105,8 +105,7 @@ pre-defined variants."
;; Otherwise build the new package object graph.
((eq? (package-build-system p) python-build-system)
- (package
- (inherit p)
+ (package/inherit p
(location (package-location p))
(name (let ((name (package-name p)))
(string-append new-prefix
@@ -138,8 +137,7 @@ pre-defined variants."
(define (strip-python2-variant p)
"Remove the 'python2-variant' property from P."
- (package
- (inherit p)
+ (package/inherit p
(properties (alist-delete 'python2-variant (package-properties p)))))
(define* (lower name
diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm
index 1d21b33895..0a95672b00 100644
--- a/guix/build/cargo-build-system.scm
+++ b/guix/build/cargo-build-system.scm
@@ -2,7 +2,7 @@
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com>
-;;; Copyright © 2019, 2020 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2019, 2020, 2021 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
;;; Copyright © 2020 Marius Bakke <marius@gnu.org>
;;;
@@ -73,6 +73,44 @@ Cargo.toml file present at its root."
" | cut -d/ -f2"
" | grep -q '^Cargo.toml$'")))))
+(define* (unpack-rust-crates #:key inputs vendor-dir #:allow-other-keys)
+ (define (inputs->rust-inputs inputs)
+ "Filter using the label part from INPUTS."
+ (filter (lambda (input)
+ (match input
+ ((name . _) (rust-package? name))))
+ inputs))
+ (define (inputs->directories inputs)
+ "Extract the directory part from INPUTS."
+ (match inputs
+ (((names . directories) ...)
+ directories)))
+
+ (let ((rust-inputs (inputs->directories (inputs->rust-inputs inputs))))
+ (unless (null? rust-inputs)
+ (mkdir-p "target/package")
+ (mkdir-p vendor-dir)
+ ;; TODO: copy only regular inputs to target/package, not native-inputs.
+ (for-each
+ (lambda (input-crate)
+ (for-each
+ (lambda (packaged-crate)
+ (unless
+ (file-exists?
+ (string-append "target/package/" (basename packaged-crate)))
+ (install-file packaged-crate "target/package/")))
+ (find-files
+ (string-append input-crate "/share/cargo/registry") "\\.crate$")))
+ (delete-duplicates rust-inputs))
+
+ (for-each (lambda (crate)
+ (invoke "tar" "xzf" crate "-C" vendor-dir))
+ (find-files "target/package" "\\.crate$"))))
+ #t)
+
+(define (rust-package? name)
+ (string-prefix? "rust-" name))
+
(define* (configure #:key inputs
(vendor-dir "guix-vendor")
#:allow-other-keys)
@@ -170,9 +208,27 @@ directory = '" port)
(apply invoke "cargo" "test" cargo-test-flags)
#t))
-(define* (install #:key inputs outputs skip-build? features #:allow-other-keys)
+(define* (package #:key
+ install-source?
+ (cargo-package-flags '("--no-metadata" "--no-verify"))
+ #:allow-other-keys)
+ "Run 'cargo-package' for a given Cargo package."
+ (if install-source?
+ (apply invoke `("cargo" "package" ,@cargo-package-flags))
+ (format #t "Not installing cargo sources, skipping `cargo package`.~%"))
+ #t)
+
+(define* (install #:key
+ inputs
+ outputs
+ skip-build?
+ install-source?
+ features
+ #:allow-other-keys)
"Install a given Cargo package."
- (let* ((out (assoc-ref outputs "out")))
+ (let* ((out (assoc-ref outputs "out"))
+ (registry (string-append out "/share/cargo/registry"))
+ (sources (string-append out "/share/cargo/src")))
(mkdir-p out)
;; Make cargo reuse all the artifacts we just built instead
@@ -186,6 +242,18 @@ directory = '" port)
(invoke "cargo" "install" "--no-track" "--path" "." "--root" out
"--features" (string-join features)))
+ (when install-source?
+ ;; Install crate tarballs and unpacked sources for later use.
+ ;; TODO: Is there a better format/directory for these files?
+ (mkdir-p sources)
+ (for-each (lambda (crate)
+ (install-file crate registry))
+ (find-files "target/package" "\\.crate$"))
+
+ (for-each (lambda (crate)
+ (invoke "tar" "xzf" crate "-C" sources))
+ (find-files registry "\\.crate$")))
+
#t))
(define %standard-phases
@@ -195,6 +263,8 @@ directory = '" port)
(replace 'build build)
(replace 'check check)
(replace 'install install)
+ (add-after 'build 'package package)
+ (add-after 'unpack 'unpack-rust-crates unpack-rust-crates)
(add-after 'patch-generated-file-shebangs 'patch-cargo-checksums patch-cargo-checksums)))
(define* (cargo-build #:key inputs (phases %standard-phases)
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 46af149b2f..a22d4064ca 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
@@ -28,7 +28,6 @@
#:use-module (guix build utils)
#:use-module (guix progress)
#:use-module (rnrs io ports)
- #:use-module ((ice-9 binary-ports) #:select (unget-bytevector))
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
@@ -306,14 +305,22 @@ host name without trailing dot."
(let ((record (session-record-port session)))
(define (read! bv start count)
- (define read-bv (get-bytevector-some record))
- (if (eof-object? read-bv)
- 0 ; read! returns 0 on eof-object
- (let ((read-bv-len (bytevector-length read-bv)))
- (bytevector-copy! read-bv 0 bv start (min read-bv-len count))
- (when (< count read-bv-len)
- (unget-bytevector record bv count (- read-bv-len count)))
- read-bv-len)))
+ (define read
+ (catch 'gnutls-error
+ (lambda ()
+ (get-bytevector-n! record bv start count))
+ (lambda (key err proc . rest)
+ ;; When responding to "Connection: close" requests, some
+ ;; servers close the connection abruptly after sending the
+ ;; response body, without doing a proper TLS connection
+ ;; termination. Treat it as EOF.
+ (if (eq? err error/premature-termination)
+ the-eof-object
+ (apply throw key err proc rest)))))
+
+ (if (eof-object? read)
+ 0
+ read))
(define (write! bv start count)
(put-bytevector record bv start count)
(force-output record)
@@ -328,17 +335,24 @@ host name without trailing dot."
(unless (port-closed? record)
(close-port record)))
+ (define (unbuffered port)
+ (setvbuf port 'none)
+ port)
+
(setvbuf record 'block)
;; Return a port that wraps RECORD to ensure that closing it also
;; closes PORT, the actual socket port, and its file descriptor.
+ ;; Make sure it does not introduce extra buffering (custom ports
+ ;; are buffered by default as of Guile 3.0.5).
;; XXX: This wrapper would be unnecessary if GnuTLS could
;; automatically close SESSION's file descriptor when RECORD is
;; closed, but that doesn't seem to be possible currently (as of
;; 3.6.9).
- (make-custom-binary-input/output-port "gnutls wrapped port" read! write!
- get-position set-position!
- close))))
+ (unbuffered
+ (make-custom-binary-input/output-port "gnutls wrapped port" read! write!
+ get-position set-position!
+ close)))))
(define (ensure-uri uri-or-string) ;XXX: copied from (web http)
(cond
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 552343a481..8886fc0fb9 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -6,6 +6,7 @@
;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -82,6 +83,21 @@
file-system-fragment-size
file-system-mount-flags
statfs
+
+ ST_RDONLY
+ ST_NOSUID
+ ST_NODEV
+ ST_NOEXEC
+ ST_SYNCHRONOUS
+ ST_MANDLOCK
+ ST_WRITE
+ ST_APPEND
+ ST_IMMUTABLE
+ ST_NOATIME
+ ST_NODIRATIME
+ ST_RELATIME
+ statfs-flags->mount-flags
+
free-disk-space
device-in-use?
add-to-entropy-count
@@ -621,8 +637,9 @@ current process."
(if (eof-object? line)
(reverse result)
(match (string-tokenize line)
+ ;; See the proc(5) man page for a description of the columns.
((id parent-id major:minor root mount-point
- options _ type source _ ...)
+ options _ ... "-" type source _)
(let ((devno (string->device-number major:minor)))
(loop (cons (%mount (octal-decode source)
(octal-decode mount-point)
@@ -754,6 +771,56 @@ fdatasync(2) on the underlying file descriptor."
(define-syntax fsword ;fsword_t
(identifier-syntax long))
+(define linux? (string-contains %host-type "linux-gnu"))
+
+(define-syntax define-statfs-flags
+ (syntax-rules (linux hurd)
+ "Define the statfs mount flags."
+ ((_ (name (linux linux-value) (hurd hurd-value)) rest ...)
+ (begin
+ (define name
+ (if linux? linux-value hurd-value))
+ (define-statfs-flags rest ...)))
+ ((_ (name value) rest ...)
+ (begin
+ (define name value)
+ (define-statfs-flags rest ...)))
+ ((_) #t)))
+
+(define-statfs-flags ;<bits/statfs.h>
+ (ST_RDONLY 1)
+ (ST_NOSUID 2)
+ (ST_NODEV (linux 4) (hurd 0))
+ (ST_NOEXEC 8)
+ (ST_SYNCHRONOUS 16)
+ (ST_MANDLOCK (linux 64) (hurd 0))
+ (ST_WRITE (linux 128) (hurd 0))
+ (ST_APPEND (linux 256) (hurd 0))
+ (ST_IMMUTABLE (linux 512) (hurd 0))
+ (ST_NOATIME (linux 1024) (hurd 32))
+ (ST_NODIRATIME (linux 2048) (hurd 0))
+ (ST_RELATIME (linux 4096) (hurd 64)))
+
+(define (statfs-flags->mount-flags flags)
+ "Convert FLAGS, a logical or of ST_* constants as returned by
+'file-system-mount-flags', to the corresponding logical or of MS_* constants."
+ (letrec-syntax ((match-flags (syntax-rules (=>)
+ ((_ (statfs => mount) rest ...)
+ (logior (if (zero? (logand flags statfs))
+ 0
+ mount)
+ (match-flags rest ...)))
+ ((_)
+ 0))))
+ (match-flags
+ (ST_RDONLY => MS_RDONLY)
+ (ST_NOSUID => MS_NOSUID)
+ (ST_NODEV => MS_NODEV)
+ (ST_NOEXEC => MS_NOEXEC)
+ (ST_NOATIME => MS_NOATIME)
+ (ST_NODIRATIME => 0) ;FIXME
+ (ST_RELATIME => MS_RELATIME))))
+
(define-c-struct %statfs ;<bits/statfs.h>
sizeof-statfs ;slightly overestimated
file-system
@@ -769,7 +836,7 @@ fdatasync(2) on the underlying file descriptor."
(identifier (array int 2))
(name-length fsword)
(fragment-size fsword)
- (mount-flags fsword)
+ (mount-flags fsword) ;ST_*
(spare (array fsword 4)))
(define statfs
@@ -876,7 +943,11 @@ backend device."
;;;
;; From <uapi/linux/random.h>.
-(define RNDADDTOENTCNT #x40045201)
+(define RNDADDTOENTCNT
+ ;; Avoid using %current-system here to avoid depending on host-side code.
+ (if (string-prefix? "powerpc64le" %host-type)
+ #x80045201
+ #x40045201))
(define (add-to-entropy-count port-or-fd n)
"Add N to the kernel's entropy count (the value that can be read from
@@ -955,6 +1026,7 @@ Turning finalization off shuts down the finalization thread as a side effect."
("mips64" 5055)
("armv7l" 120)
("aarch64" 220)
+ ("ppc64le" 120)
(_ #f))))
(lambda (flags)
"Create a new child process by duplicating the current parent process.
diff --git a/guix/channels.scm b/guix/channels.scm
index 05226e766b..b812c1b6e5 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -86,6 +86,7 @@
latest-channel-instances
checkout->channel-instance
latest-channel-derivation
+ channel-instance->sexp
channel-instances->manifest
%channel-profile-hooks
channel-instances->derivation
@@ -948,6 +949,7 @@ does not have the expected structure."
(#f name)
(('name name) name)))
(url url)
+ (branch branch)
(commit commit)
(introduction
(match (assq 'introduction rest)
diff --git a/guix/download.scm b/guix/download.scm
index 579996f090..30f69c0325 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -27,7 +27,7 @@
#:use-module (guix derivations)
#:use-module (guix packages)
#:use-module (guix store)
- #:use-module ((guix build download) #:prefix build:)
+ #:autoload (guix build download) (url-fetch)
#:use-module (guix monads)
#:use-module (guix gexp)
#:use-module (guix utils)
@@ -35,7 +35,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (%mirrors
- url-fetch
+ (url-fetch* . url-fetch)
url-fetch/executable
url-fetch/tarbomb
url-fetch/zipbomb
@@ -449,11 +449,11 @@ download by itself using its own dependencies."
;; for that built-in is widespread.
#:local-build? #t)))
-(define* (url-fetch url hash-algo hash
- #:optional name
- #:key (system (%current-system))
- (guile (default-guile))
- executable?)
+(define* (url-fetch* url hash-algo hash
+ #:optional name
+ #:key (system (%current-system))
+ (guile (default-guile))
+ executable?)
"Return a fixed-output derivation that fetches data from URL (a string, or a
list of strings denoting alternate URLs), which is expected to have hash HASH
of type HASH-ALGO (a symbol). By default, the file name is the base name of
@@ -499,10 +499,10 @@ name in the store."
#:key (system (%current-system))
(guile (default-guile)))
"Like 'url-fetch', but make the downloaded file executable."
- (url-fetch url hash-algo hash name
- #:system system
- #:guile guile
- #:executable? #t))
+ (url-fetch* url hash-algo hash name
+ #:system system
+ #:guile guile
+ #:executable? #t))
(define* (url-fetch/tarbomb url hash-algo hash
#:optional name
@@ -521,11 +521,11 @@ own. This helper makes it easier to deal with \"tar bombs\"."
(define tar
(module-ref (resolve-interface '(gnu packages base)) 'tar))
- (mlet %store-monad ((drv (url-fetch url hash-algo hash
- (string-append "tarbomb-"
- (or name file-name))
- #:system system
- #:guile guile))
+ (mlet %store-monad ((drv (url-fetch* url hash-algo hash
+ (string-append "tarbomb-"
+ (or name file-name))
+ #:system system
+ #:guile guile))
(guile (package->derivation guile system)))
;; Take the tar bomb, and simply unpack it as a directory.
;; Use ungrafted tar/gzip so that the resulting tarball doesn't depend on
@@ -559,11 +559,11 @@ own. This helper makes it easier to deal with \"zip bombs\"."
(define unzip
(module-ref (resolve-interface '(gnu packages compression)) 'unzip))
- (mlet %store-monad ((drv (url-fetch url hash-algo hash
- (string-append "zipbomb-"
- (or name file-name))
- #:system system
- #:guile guile))
+ (mlet %store-monad ((drv (url-fetch* url hash-algo hash
+ (string-append "zipbomb-"
+ (or name file-name))
+ #:system system
+ #:guile guile))
(guile (package->derivation guile system)))
;; Take the zip bomb, and simply unpack it as a directory.
;; Use ungrafted unzip so that the resulting tarball doesn't depend on
@@ -598,10 +598,9 @@ whether or not to validate HTTPS server certificates."
(lambda (temp port)
(let ((result
(parameterize ((current-output-port log))
- (build:url-fetch url temp
- #:mirrors %mirrors
- #:verify-certificate?
- verify-certificate?))))
+ (url-fetch url temp
+ #:mirrors %mirrors
+ #:verify-certificate? verify-certificate?))))
(close port)
(and result
(add-to-store store name recursive? "sha256" temp)))))))
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 8e575e3b5f..425184717a 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
@@ -27,7 +27,14 @@
#:use-module (guix packages)
#:use-module (guix modules)
#:autoload (guix build-system gnu) (standard-packages)
- #:use-module (git)
+ #:autoload (git repository) (repository-open
+ repository-close!
+ repository-discover
+ repository-head
+ repository-working-directory)
+ #:autoload (git commit) (commit-lookup commit-tree)
+ #:autoload (git reference) (reference-target)
+ #:autoload (git tree) (tree-list)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-1)
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 0da6fc19b6..031a899a6c 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;;
@@ -28,6 +28,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
#:use-module (rnrs io ports)
#:use-module (system foreign)
#:use-module (guix http-client)
@@ -37,7 +38,8 @@
#:use-module (guix records)
#:use-module (guix upstream)
#:use-module (guix packages)
- #:use-module (zlib)
+ #:autoload (zlib) (call-with-gzip-input-port)
+ #:autoload (htmlprag) (html->sxml) ;from Guile-Lib
#:export (gnu-package-name
gnu-package-mundane-name
gnu-package-copyright-holder
@@ -65,7 +67,8 @@
%gnu-ftp-updater
%savannah-updater
%xorg-updater
- %kernel.org-updater))
+ %kernel.org-updater
+ %generic-html-updater))
;;; Commentary:
;;;
@@ -238,7 +241,8 @@ network to check in GNU's database."
;; The .zip extensions is notably used for freefont-ttf.
;; The "-src" pattern is for "TeXmacs-1.0.7.9-src.tar.gz".
;; The "-gnu[0-9]" pattern is for "icecat-38.4.0-gnu1.tar.bz2".
- (make-regexp "^([^.]+)-([0-9]|[^-])+(-(src|gnu[0-9]))?\\.(tar\\.|zip$)"))
+ ;; Accept underscores as in "PKG_1.2.tar.gz" for some non-GNU packages.
+ (make-regexp "^([^.]+)[-_]([0-9]|[^-])+(-(src|gnu[0-9]))?\\.(tar\\.|zip$)"))
(define %alpha-tarball-rx
(make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|RC|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
@@ -246,7 +250,9 @@ network to check in GNU's database."
(define (release-file? project file)
"Return #f if FILE is not a release tarball of PROJECT, otherwise return
true."
- (and (not (member (file-extension file) '("sig" "sign" "asc")))
+ (and (not (member (file-extension file)
+ '("sig" "sign" "asc"
+ "md5sum" "sha1sum" "sha256sum")))
(and=> (regexp-exec %tarball-rx file)
(lambda (match)
;; Filter out unrelated files, like `guile-www-1.1.1'.
@@ -322,16 +328,11 @@ name/directory pairs."
#:key
(server "ftp.gnu.org")
(directory (string-append "/gnu/" project))
- (keep-file? (const #t))
- (file->signature (cut string-append <> ".sig"))
- (ftp-open ftp-open) (ftp-close ftp-close))
+ (file->signature (cut string-append <> ".sig")))
"Return an <upstream-source> for the latest release of PROJECT on SERVER
under DIRECTORY, or #f. Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP
connections; this can be useful to reuse connections.
-KEEP-FILE? is a predicate to decide whether to enter a directory and to
-consider a given file (source tarball) as a valid candidate based on its name.
-
FILE->SIGNATURE must be a procedure; it is passed a source file URL and must
return the corresponding signature URL, or #f it signatures are unavailable."
(define (latest a b)
@@ -345,7 +346,7 @@ return the corresponding signature URL, or #f it signatures are unavailable."
;; Return #t for patch directory names such as 'bash-4.2-patches'.
(cut string-suffix? "patches" <>))
- (define conn (ftp-open server))
+ (define conn (ftp-open server #:timeout 5))
(define (file->url directory file)
(string-append "ftp://" server directory "/" file))
@@ -389,7 +390,6 @@ return the corresponding signature URL, or #f it signatures are unavailable."
(releases (filter-map (match-lambda
((file 'file . _)
(and (release-file? project file)
- (keep-file? file)
(file->source directory file)))
(_ #f))
entries)))
@@ -447,18 +447,6 @@ hosted on ftp.gnu.org, or not under that name (this is the case for
;;; Latest HTTP release.
;;;
-(define (html->sxml port)
- "Read HTML from PORT and return the corresponding SXML tree."
- (let ((str (get-string-all port)))
- (catch #t
- (lambda ()
- ;; XXX: This is the poor developer's HTML-to-XML converter. It's good
- ;; enough for directory listings at <https://kernel.org/pub> but if
- ;; needed we could resort to (htmlprag) from Guile-Lib.
- (call-with-input-string (string-replace-substring str "<hr>" "<hr />")
- xml->sxml))
- (const '(html))))) ;parse error
-
(define (html-links sxml)
"Return the list of links found in SXML, the SXML tree of an HTML page."
(let loop ((sxml sxml)
@@ -479,33 +467,47 @@ hosted on ftp.gnu.org, or not under that name (this is the case for
#:key
(base-url "https://kernel.org/pub")
(directory (string-append "/" package))
- (file->signature (cut string-append <> ".sig")))
+ file->signature)
"Return an <upstream-source> for the latest release of PACKAGE (a string) on
SERVER under DIRECTORY, or #f. BASE-URL should be the URL of an HTML page,
typically a directory listing as found on 'https://kernel.org/pub'.
-FILE->SIGNATURE must be a procedure; it is passed a source file URL and must
-return the corresponding signature URL, or #f it signatures are unavailable."
- (let* ((uri (string->uri (string-append base-url directory "/")))
- (port (http-fetch/cached uri #:ttl 3600))
- (sxml (html->sxml port)))
+When FILE->SIGNATURE is omitted or #f, guess the detached signature file name,
+if any. Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
+file URL and must return the corresponding signature URL, or #f it signatures
+are unavailable."
+ (let* ((uri (string->uri (if (string-null? directory)
+ base-url
+ (string-append base-url directory "/"))))
+ (port (http-fetch/cached uri #:ttl 3600))
+ (sxml (html->sxml port))
+ (links (delete-duplicates (html-links sxml))))
+ (define (file->signature/guess url)
+ (let ((base (basename url)))
+ (any (lambda (link)
+ (any (lambda (extension)
+ (and (string=? (string-append base extension)
+ (basename link))
+ (string-append url extension)))
+ '(".asc" ".sig" ".sign")))
+ links)))
+
(define (url->release url)
- (and (string=? url (basename url)) ;relative reference?
- (release-file? package url)
- (let-values (((name version)
- (package-name->name+version
- (tarball-sans-extension url)
- #\-)))
- (upstream-source
- (package name)
- (version version)
- (urls (list (string-append base-url directory "/" url)))
- (signature-urls
- (list (file->signature
- (string-append base-url directory "/" url))))))))
+ (let* ((base (basename url))
+ (url (if (string=? base url)
+ (string-append base-url directory "/" url)
+ url)))
+ (and (release-file? package base)
+ (let ((version (tarball->version base)))
+ (upstream-source
+ (package package)
+ (version version)
+ (urls (list url))
+ (signature-urls
+ (list ((or file->signature file->signature/guess) url))))))))
(define candidates
- (filter-map url->release (html-links sxml)))
+ (filter-map url->release links))
(close-port port)
(match candidates
@@ -593,7 +595,7 @@ list available from %GNU-FILE-LIST-URI over HTTP(S)."
(define %package-name-rx
;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses
;; "TeXmacs-X.Y-src", the `-src' suffix is allowed.
- (make-regexp "^(.*)-(([0-9]|\\.)+)(-src)?"))
+ (make-regexp "^(.*)[-_](([0-9]|\\.)+)(-src)?"))
(define (gnu-package-name->name+version name+version)
"Return the package name and version number extracted from NAME+VERSION."
@@ -608,11 +610,12 @@ list available from %GNU-FILE-LIST-URI over HTTP(S)."
(define (pure-gnu-package? package)
"Return true if PACKAGE is a non-Emacs and non-GNOME GNU package. This
excludes AucTeX, for instance, whose releases are now uploaded to
-elpa.gnu.org, and all the GNOME packages; EMMS is included though, because its
-releases are on gnu.org."
+elpa.gnu.org, GNU Radio, which has releases at www.gnuradio.org, and all the
+GNOME packages; EMMS is included though, because its releases are on gnu.org."
(and (or (not (string-prefix? "emacs-" (package-name package)))
(gnu-hosted? package))
(not (gnome-package? package))
+ (not (string-prefix? "gnuradio" (package-name package)))
(gnu-package? package)))
(define gnu-hosted?
@@ -621,7 +624,7 @@ releases are on gnu.org."
(define (url-prefix-rewrite old new)
"Return a one-argument procedure that rewrites URL prefix OLD to NEW."
(lambda (url)
- (if (string-prefix? old url)
+ (if (and url (string-prefix? old url))
(string-append new (string-drop url (string-length old)))
url)))
@@ -653,9 +656,8 @@ releases are on gnu.org."
(directory (dirname (uri-path uri)))
(rewrite (url-prefix-rewrite %savannah-base
"mirror://savannah")))
- ;; Note: We use the default 'file->signature', which adds ".sig", but not
- ;; all projects on Savannah follow that convention: some use ".asc" and
- ;; perhaps some lack signatures altogether.
+ ;; Note: We use the default 'file->signature', which adds ".sig", ".asc",
+ ;; or whichever detached signature naming scheme PACKAGE uses.
(and=> (latest-html-release package
#:base-url %savannah-base
#:directory directory)
@@ -695,6 +697,55 @@ releases are on gnu.org."
#:file->signature file->signature)
(cut adjusted-upstream-source <> rewrite))))
+(define html-updatable-package?
+ ;; Return true if the given package may be handled by the generic HTML
+ ;; updater.
+ (let ((hosting-sites '("github.com" "github.io" "gitlab.com"
+ "notabug.org" "sr.ht"
+ "gforge.inria.fr" "gitlab.inria.fr"
+ "ftp.gnu.org" "download.savannah.gnu.org"
+ "pypi.org" "crates.io" "rubygems.org"
+ "bioconductor.org")))
+ (url-predicate (lambda (url)
+ (match (string->uri url)
+ (#f #f)
+ (uri
+ (let ((scheme (uri-scheme uri))
+ (host (uri-host uri)))
+ (and (memq scheme '(http https))
+ (not (member host hosting-sites))))))))))
+
+(define (latest-html-updatable-release package)
+ "Return the latest release of PACKAGE. Do that by crawling the HTML page of
+the directory containing its source tarball."
+ (let* ((uri (string->uri
+ (match (origin-uri (package-source package))
+ ((? string? url) url)
+ ((url _ ...) url))))
+ (custom (assoc-ref (package-properties package)
+ 'release-monitoring-url))
+ (base (or custom
+ (string-append (symbol->string (uri-scheme uri))
+ "://" (uri-host uri))))
+ (directory (if custom
+ ""
+ (dirname (uri-path uri))))
+ (package (package-upstream-name package)))
+ (catch #t
+ (lambda ()
+ (guard (c ((http-get-error? c) #f))
+ (latest-html-release package
+ #:base-url base
+ #:directory directory)))
+ (lambda (key . args)
+ ;; Return false and move on upon connection failures and bogus HTTP
+ ;; servers.
+ (unless (memq key '(gnutls-error tls-certificate-error
+ system-error
+ bad-header bad-header-component))
+ (apply throw key args))
+ #f))))
+
(define %gnu-updater
;; This is for everything at ftp.gnu.org.
(upstream-updater
@@ -735,4 +786,11 @@ releases are on gnu.org."
(pred (url-prefix-predicate "mirror://kernel.org/"))
(latest latest-kernel.org-release)))
+(define %generic-html-updater
+ (upstream-updater
+ (name 'generic-html)
+ (description "Updater that crawls HTML pages.")
+ (pred html-updatable-package?)
+ (latest latest-html-updatable-release)))
+
;;; gnu-maintenance.scm ends here
diff --git a/guix/http-client.scm b/guix/http-client.scm
index 2d7458a56e..4b4c14ed0b 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -79,6 +79,7 @@
(keep-alive? #f)
(verify-certificate? #t)
(headers '((user-agent . "GNU Guile")))
+ (log-port (current-error-port))
timeout)
"Return an input port containing the data at URI, and the expected number of
bytes available or #f. If TEXT? is true, the data at URI is considered to be
@@ -94,6 +95,8 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates.
TIMEOUT specifies the timeout in seconds for connection establishment; when
TIMEOUT is #f, connection establishment never times out.
+Write information about redirects to LOG-PORT.
+
Raise an '&http-get-error' condition if downloading fails."
(let loop ((uri (if (string? uri)
(string->uri uri)
@@ -128,7 +131,7 @@ Raise an '&http-get-error' condition if downloading fails."
308) ; permanent redirection
(let ((uri (resolve-uri-reference (response-location resp) uri)))
(close-port port)
- (format (current-error-port) (G_ "following redirection to `~a'...~%")
+ (format log-port (G_ "following redirection to `~a'...~%")
(uri->string uri))
(loop uri)))
(else
@@ -276,6 +279,7 @@ returning."
(define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text?
(write-cache dump-port)
(cache-miss (const #t))
+ (log-port (current-error-port))
(timeout 10))
"Like 'http-fetch', return an input port, but cache its contents in
~/.cache/guix. The cache remains valid for TTL seconds.
@@ -284,7 +288,9 @@ Call WRITE-CACHE with the HTTP input port and the cache output port to write
the data to cache. Call CACHE-MISS with URI just before fetching data from
URI.
-TIMEOUT specifies the timeout in seconds for connection establishment."
+TIMEOUT specifies the timeout in seconds for connection establishment.
+
+Write information about redirects to LOG-PORT."
(let ((file (cache-file-for-uri uri)))
(define (update-cache cache-port)
(define cache-time
@@ -306,6 +312,7 @@ TIMEOUT specifies the timeout in seconds for connection establishment."
cache-port)
(raise c))))
(let ((port (http-fetch uri #:text? text?
+ #:log-port log-port
#:headers headers #:timeout timeout)))
(cache-miss uri)
(mkdir-p (dirname file))
diff --git a/guix/import/gnome.scm b/guix/import/gnome.scm
index 436ec88ef9..43966c1028 100644
--- a/guix/import/gnome.scm
+++ b/guix/import/gnome.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -64,8 +64,9 @@ not be determined."
(match (string-tokenize version %not-dot)
(((= string->number major) (= string->number minor) . rest)
(and minor (even? minor)))
- (_
- #t))) ;cross fingers
+ (((= string->number major) . _)
+ ;; It should at last start with a digit.
+ major)))
(define upstream-name
;; Some packages like "NetworkManager" have camel-case names.
@@ -82,7 +83,10 @@ not be determined."
;; ftp.gnome.org supports 'if-Modified-Since', so the local
;; cache can expire early.
- #:ttl (* 60 10)))
+ #:ttl (* 60 10)
+
+ ;; Hide messages about URL redirects.
+ #:log-port (%make-void-port "w")))
(json (json->scm port)))
(close-port port)
(match json
diff --git a/guix/import/go.scm b/guix/import/go.scm
new file mode 100644
index 0000000000..7452b4c903
--- /dev/null
+++ b/guix/import/go.scm
@@ -0,0 +1,547 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Katherine Cox-Buday <cox.katherine.e@gmail.com>
+;;; Copyright © 2020 Helio Machado <0x2b3bfa0+guix@googlemail.com>
+;;; Copyright © 2021 François Joulaud <francois.joulaud@radiofrance.com>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix import go)
+ #:use-module (guix build-system go)
+ #:use-module (guix git)
+ #:use-module (guix i18n)
+ #:use-module (guix diagnostics)
+ #:use-module (guix import utils)
+ #:use-module (guix import json)
+ #:use-module (guix packages)
+ #:use-module ((guix utils) #:select (string-replace-substring))
+ #:use-module (guix http-client)
+ #:use-module ((guix licenses) #:prefix license:)
+ #:use-module (guix memoization)
+ #:autoload (htmlprag) (html->sxml) ;from Guile-Lib
+ #:autoload (guix git) (update-cached-checkout)
+ #:autoload (gcrypt hash) (open-hash-port hash-algorithm sha256)
+ #:autoload (guix serialization) (write-file)
+ #:autoload (guix base32) (bytevector->nix-base32-string)
+ #:autoload (guix build utils) (mkdir-p)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 regex)
+ #:use-module ((rnrs io ports) #:select (call-with-port))
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (sxml xpath)
+ #:use-module (web client)
+ #:use-module (web response)
+ #:use-module (web uri)
+
+ #:export (go-path-escape
+ go-module->guix-package
+ go-module-recursive-import))
+
+;;; Commentary:
+;;;
+;;; (guix import go) attempts to make it easier to create Guix package
+;;; declarations for Go modules.
+;;;
+;;; Modules in Go are a "collection of related Go packages" which are "the
+;;; unit of source code interchange and versioning". Modules are generally
+;;; hosted in a repository.
+;;;
+;;; At this point it should handle correctly modules which have only Go
+;;; dependencies and are accessible from proxy.golang.org (or configured via
+;;; GOPROXY).
+;;;
+;;; We want it to work more or less this way:
+;;; - get latest version for the module from GOPROXY
+;;; - infer VCS root repo from which we will check-out source by
+;;; + recognising known patterns (like github.com)
+;;; + or recognizing .vcs suffix
+;;; + or parsing meta tag in HTML served at the URL
+;;; + or (TODO) if nothing else works by using zip file served by GOPROXY
+;;; - get go.mod from GOPROXY (which is able to synthetize one if needed)
+;;; - extract list of dependencies from this go.mod
+;;;
+;;; The Go module paths are translated to a Guix package name under the
+;;; assumption that there will be no collision.
+
+;;; TODO list
+;;; - get correct hash in vcs->origin
+;;; - print partial result during recursive imports (need to catch
+;;; exceptions)
+
+;;; Code:
+
+(define (go-path-escape path)
+ "Escape a module path by replacing every uppercase letter with an
+exclamation mark followed with its lowercase equivalent, as per the module
+Escaped Paths specification (see:
+https://godoc.org/golang.org/x/mod/module#hdr-Escaped_Paths)."
+ (define (escape occurrence)
+ (string-append "!" (string-downcase (match:substring occurrence))))
+ (regexp-substitute/global #f "[A-Z]" path 'pre escape 'post))
+
+(define (go-module-latest-version goproxy-url module-path)
+ "Fetch the version number of the latest version for MODULE-PATH from the
+given GOPROXY-URL server."
+ (assoc-ref (json-fetch (format #f "~a/~a/@latest" goproxy-url
+ (go-path-escape module-path)))
+ "Version"))
+
+
+(define (go-package-licenses name)
+ "Retrieve the list of licenses that apply to NAME, a Go package or module
+name (e.g. \"github.com/golang/protobuf/proto\"). The data is scraped from
+the https://pkg.go.dev/ web site."
+ (let*-values (((url) (string-append "https://pkg.go.dev/" name
+ "?tab=licenses"))
+ ((response body) (http-get url))
+ ;; Extract the text contained in a h2 child node of any
+ ;; element marked with a "License" class attribute.
+ ((select) (sxpath `(// (* (@ (equal? (class "License"))))
+ h2 // *text*))))
+ (and (eq? (response-code response) 200)
+ (match (select (html->sxml body))
+ (() #f) ;nothing selected
+ (licenses licenses)))))
+
+(define (go.pkg.dev-info name)
+ (http-get (string-append "https://pkg.go.dev/" name)))
+(define go.pkg.dev-info*
+ (memoize go.pkg.dev-info))
+
+(define (go-package-description name)
+ "Retrieve a short description for NAME, a Go package name,
+e.g. \"google.golang.org/protobuf/proto\". The data is scraped from the
+https://pkg.go.dev/ web site."
+ (let*-values (((response body) (go.pkg.dev-info* name))
+ ;; Extract the text contained in a h2 child node of any
+ ;; element marked with a "License" class attribute.
+ ((select) (sxpath
+ `(// (section
+ (@ (equal? (class "Documentation-overview"))))
+ (p 1)))))
+ (and (eq? (response-code response) 200)
+ (match (select (html->sxml body))
+ (() #f) ;nothing selected
+ (((p . strings))
+ ;; The paragraph text is returned as a list of strings embedding
+ ;; newline characters. Join them and strip the newline
+ ;; characters.
+ (string-delete #\newline (string-join strings)))))))
+
+(define (go-package-synopsis module-name)
+ "Retrieve a short synopsis for a Go module named MODULE-NAME,
+e.g. \"google.golang.org/protobuf\". The data is scraped from
+the https://pkg.go.dev/ web site."
+ ;; Note: Only the *module* (rather than package) page has the README title
+ ;; used as a synopsis on the https://pkg.go.dev web site.
+ (let*-values (((response body) (go.pkg.dev-info* module-name))
+ ;; Extract the text contained in a h2 child node of any
+ ;; element marked with a "License" class attribute.
+ ((select) (sxpath
+ `(// (div (@ (equal? (class "UnitReadme-content"))))
+ // h3 *text*))))
+ (and (eq? (response-code response) 200)
+ (match (select (html->sxml body))
+ (() #f) ;nothing selected
+ ((title more ...) ;title is the first string of the list
+ (string-trim-both title))))))
+
+(define (list->licenses licenses)
+ "Given a list of LICENSES mostly following the SPDX conventions, return the
+corresponding Guix license or 'unknown-license!"
+ (filter-map (lambda (license)
+ (and (not (string-null? license))
+ (not (any (cut string=? <> license)
+ '("AND" "OR" "WITH")))
+ ;; Adjust the license names scraped from
+ ;; https://pkg.go.dev to an equivalent SPDX identifier,
+ ;; if they differ (see: https://github.com/golang/pkgsite
+ ;; /internal/licenses/licenses.go#L174).
+ (or (spdx-string->license
+ (match license
+ ("BlueOak-1.0" "BlueOak-1.0.0")
+ ("BSD-0-Clause" "0BSD")
+ ("BSD-2-Clause" "BSD-2-Clause-FreeBSD")
+ ("GPL2" "GPL-2.0")
+ ("GPL3" "GPL-3.0")
+ ("NIST" "NIST-PD")
+ (_ license)))
+ 'unknown-license!)))
+ licenses))
+
+(define (fetch-go.mod goproxy-url module-path version)
+ "Fetches go.mod from the given GOPROXY-URL server for the given MODULE-PATH
+and VERSION."
+ (let ((url (format #f "~a/~a/@v/~a.mod" goproxy-url
+ (go-path-escape module-path)
+ (go-path-escape version))))
+ (http-fetch url)))
+
+(define %go.mod-require-directive-rx
+ ;; A line in a require directive is composed of a module path and
+ ;; a version separated by whitespace and an optionnal '//' comment at
+ ;; the end.
+ (make-regexp
+ (string-append
+ "^[[:blank:]]*"
+ "([^[:blank:]]+)[[:blank:]]+([^[:blank:]]+)"
+ "([[:blank:]]+//.*)?")))
+
+(define %go.mod-replace-directive-rx
+ ;; ReplaceSpec = ModulePath [ Version ] "=>" FilePath newline
+ ;; | ModulePath [ Version ] "=>" ModulePath Version newline .
+ (make-regexp
+ (string-append
+ "([^[:blank:]]+)([[:blank:]]+([^[:blank:]]+))?"
+ "[[:blank:]]+" "=>" "[[:blank:]]+"
+ "([^[:blank:]]+)([[:blank:]]+([^[:blank:]]+))?")))
+
+(define (parse-go.mod port)
+ "Parse the go.mod file accessible via the input PORT, returning a list of
+requirements."
+ (define-record-type <results>
+ (make-results requirements replacements)
+ results?
+ (requirements results-requirements)
+ (replacements results-replacements))
+ ;; We parse only a subset of https://golang.org/ref/mod#go-mod-file-grammar
+ ;; which we think necessary for our use case.
+ (define (toplevel results)
+ "Main parser, RESULTS is a pair of alist serving as accumulator for
+ all encountered requirements and replacements."
+ (let ((line (read-line port)))
+ (cond
+ ((eof-object? line)
+ ;; parsing ended, give back the result
+ results)
+ ((string=? line "require (")
+ ;; a require block begins, delegate parsing to IN-REQUIRE
+ (in-require results))
+ ((string=? line "replace (")
+ ;; a replace block begins, delegate parsing to IN-REPLACE
+ (in-replace results))
+ ((string-prefix? "require " line)
+ ;; a standalone require directive
+ (let* ((stripped-line (string-drop line 8))
+ (new-results (require-directive results stripped-line)))
+ (toplevel new-results)))
+ ((string-prefix? "replace " line)
+ ;; a standalone replace directive
+ (let* ((stripped-line (string-drop line 8))
+ (new-results (replace-directive results stripped-line)))
+ (toplevel new-results)))
+ (#t
+ ;; unrecognised line, ignore silently
+ (toplevel results)))))
+
+ (define (in-require results)
+ (let ((line (read-line port)))
+ (cond
+ ((eof-object? line)
+ ;; this should never happen here but we ignore silently
+ results)
+ ((string=? line ")")
+ ;; end of block, coming back to toplevel
+ (toplevel results))
+ (#t
+ (in-require (require-directive results line))))))
+
+ (define (in-replace results)
+ (let ((line (read-line port)))
+ (cond
+ ((eof-object? line)
+ ;; this should never happen here but we ignore silently
+ results)
+ ((string=? line ")")
+ ;; end of block, coming back to toplevel
+ (toplevel results))
+ (#t
+ (in-replace (replace-directive results line))))))
+
+ (define (replace-directive results line)
+ "Extract replaced modules and new requirements from replace directive
+ in LINE and add to RESULTS."
+ (match results
+ (($ <results> requirements replaced)
+ (let* ((rx-match (regexp-exec %go.mod-replace-directive-rx line))
+ (module-path (match:substring rx-match 1))
+ (version (match:substring rx-match 3))
+ (new-module-path (match:substring rx-match 4))
+ (new-version (match:substring rx-match 6))
+ (new-replaced (alist-cons module-path version replaced))
+ (new-requirements
+ (if (string-match "^\\.?\\./" new-module-path)
+ requirements
+ (alist-cons new-module-path new-version requirements))))
+ (make-results new-requirements new-replaced)))))
+ (define (require-directive results line)
+ "Extract requirement from LINE and add it to RESULTS."
+ (let* ((rx-match (regexp-exec %go.mod-require-directive-rx line))
+ (module-path (match:substring rx-match 1))
+ ;; we saw double-quoted string in the wild without escape
+ ;; sequences so we just trim the quotes
+ (module-path (string-trim-both module-path #\"))
+ (version (match:substring rx-match 2)))
+ (match results
+ (($ <results> requirements replaced)
+ (make-results (alist-cons module-path version requirements) replaced)))))
+
+ (let ((results (toplevel (make-results '() '()))))
+ (match results
+ (($ <results> requirements replaced)
+ ;; At last we remove replaced modules from the requirements list
+ (fold
+ (lambda (replacedelem requirements)
+ (alist-delete! (car replacedelem) requirements))
+ requirements
+ replaced)))))
+
+;; Prevent inlining of this procedure, which is accessed by unit tests.
+(set! parse-go.mod parse-go.mod)
+
+(define-record-type <vcs>
+ (%make-vcs url-prefix root-regex type)
+ vcs?
+ (url-prefix vcs-url-prefix)
+ (root-regex vcs-root-regex)
+ (type vcs-type))
+(define (make-vcs prefix regexp type)
+ (%make-vcs prefix (make-regexp regexp) type))
+(define known-vcs
+ ;; See the following URL for the official Go equivalent:
+ ;; https://github.com/golang/go/blob/846dce9d05f19a1f53465e62a304dea21b99f910/src/cmd/go/internal/vcs/vcs.go#L1026-L1087
+ (list
+ (make-vcs
+ "github.com"
+ "^(github\\.com/[A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+)(/[A-Za-z0-9_.\\-]+)*$"
+ 'git)
+ (make-vcs
+ "bitbucket.org"
+ "^(bitbucket\\.org/([A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+))(/[A-Za-z0-9_.\\-]+)*$"
+ 'unknown)
+ (make-vcs
+ "hub.jazz.net/git/"
+ "^(hub\\.jazz\\.net/git/[a-z0-9]+/[A-Za-z0-9_.\\-]+)(/[A-Za-z0-9_.\\-]+)*$"
+ 'git)
+ (make-vcs
+ "git.apache.org"
+ "^(git\\.apache\\.org/[a-z0-9_.\\-]+\\.git)(/[A-Za-z0-9_.\\-]+)*$"
+ 'git)
+ (make-vcs
+ "git.openstack.org"
+ "^(git\\.openstack\\.org/[A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+)(\\.git)?\
+(/[A-Za-z0-9_.\\-]+)*$"
+ 'git)))
+
+(define (module-path->repository-root module-path)
+ "Infer the repository root from a module path. Go modules can be
+defined at any level of a repository tree, but querying for the meta tag
+usually can only be done from the web page at the root of the repository,
+hence the need to derive this information."
+
+ ;; For reference, see: https://golang.org/ref/mod#vcs-find.
+ (define vcs-qualifiers '(".bzr" ".fossil" ".git" ".hg" ".svn"))
+
+ (define (vcs-qualified-module-path->root-repo-url module-path)
+ (let* ((vcs-qualifiers-group (string-join vcs-qualifiers "|"))
+ (pattern (format #f "^(.*(~a))(/|$)" vcs-qualifiers-group))
+ (m (string-match pattern module-path)))
+ (and=> m (cut match:substring <> 1))))
+
+ (or (and=> (find (lambda (vcs)
+ (string-prefix? (vcs-url-prefix vcs) module-path))
+ known-vcs)
+ (lambda (vcs)
+ (match:substring (regexp-exec (vcs-root-regex vcs)
+ module-path) 1)))
+ (vcs-qualified-module-path->root-repo-url module-path)
+ module-path))
+
+(define (go-module->guix-package-name module-path)
+ "Converts a module's path to the canonical Guix format for Go packages."
+ (string-downcase (string-append "go-" (string-replace-substring
+ (string-replace-substring
+ module-path
+ "." "-")
+ "/" "-"))))
+
+(define-record-type <module-meta>
+ (make-module-meta import-prefix vcs repo-root)
+ module-meta?
+ (import-prefix module-meta-import-prefix)
+ (vcs module-meta-vcs) ;a symbol
+ (repo-root module-meta-repo-root))
+
+(define (fetch-module-meta-data module-path)
+ "Retrieve the module meta-data from its landing page. This is necessary
+because goproxy servers don't currently provide all the information needed to
+build a package."
+ ;; <meta name="go-import" content="import-prefix vcs repo-root">
+ (let* ((port (http-fetch (format #f "https://~a?go-get=1" module-path)))
+ (select (sxpath `(// head (meta (@ (equal? (name "go-import"))))
+ // content))))
+ (match (select (call-with-port port html->sxml))
+ (() #f) ;nothing selected
+ (((content content-text))
+ (match (string-split content-text #\space)
+ ((root-path vcs repo-url)
+ (make-module-meta root-path (string->symbol vcs) repo-url)))))))
+
+(define (module-meta-data-repo-url meta-data goproxy-url)
+ "Return the URL where the fetcher which will be used can download the
+source."
+ (if (member (module-meta-vcs meta-data) '(fossil mod))
+ goproxy-url
+ (module-meta-repo-root meta-data)))
+
+;; XXX: Copied from (guix scripts hash).
+(define (vcs-file? file stat)
+ (case (stat:type stat)
+ ((directory)
+ (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
+ ((regular)
+ ;; Git sub-modules have a '.git' file that is a regular text file.
+ (string=? (basename file) ".git"))
+ (else
+ #f)))
+
+;; XXX: Adapted from 'file-hash' in (guix scripts hash).
+(define* (file-hash file #:optional (algorithm (hash-algorithm sha256)))
+ ;; Compute the hash of FILE.
+ (let-values (((port get-hash) (open-hash-port algorithm)))
+ (write-file file port #:select? (negate vcs-file?))
+ (force-output port)
+ (get-hash)))
+
+(define* (git-checkout-hash url reference algorithm)
+ "Return the ALGORITHM hash of the checkout of URL at REFERENCE, a commit or
+tag."
+ (define cache
+ (string-append (or (getenv "TMPDIR") "/tmp")
+ "/guix-import-go-"
+ (passwd:name (getpwuid (getuid)))))
+
+ ;; Use a custom cache to avoid cluttering the default one under
+ ;; ~/.cache/guix, but choose one under /tmp so that it's persistent across
+ ;; subsequent "guix import" invocations.
+ (mkdir-p cache)
+ (chmod cache #o700)
+ (let-values (((checkout commit _)
+ (parameterize ((%repository-cache-directory cache))
+ (update-cached-checkout url
+ #:ref
+ `(tag-or-commit . ,reference)))))
+ (file-hash checkout algorithm)))
+
+(define (vcs->origin vcs-type vcs-repo-url version)
+ "Generate the `origin' block of a package depending on what type of source
+control system is being used."
+ (case vcs-type
+ ((git)
+ (let ((plain-version? (string=? version (go-version->git-ref version)))
+ (v-prefixed? (string-prefix? "v" version)))
+ `(origin
+ (method git-fetch)
+ (uri (git-reference
+ (url ,vcs-repo-url)
+ (commit ,(if (and plain-version? v-prefixed?)
+ '(string-append "v" version)
+ '(go-version->git-ref version)))))
+ (file-name (git-file-name name version))
+ (sha256
+ (base32
+ ,(bytevector->nix-base32-string
+ (git-checkout-hash vcs-repo-url (go-version->git-ref version)
+ (hash-algorithm sha256))))))))
+ ((hg)
+ `(origin
+ (method hg-fetch)
+ (uri (hg-reference
+ (url ,vcs-repo-url)
+ (changeset ,version)))
+ (file-name (string-append name "-" version "-checkout"))
+ (sha256
+ (base32
+ ;; FIXME: populate hash for hg repo checkout
+ "0000000000000000000000000000000000000000000000000000"))))
+ ((svn)
+ `(origin
+ (method svn-fetch)
+ (uri (svn-reference
+ (url ,vcs-repo-url)
+ (revision (string->number version))))
+ (file-name (string-append name "-" version "-checkout"))
+ (sha256
+ (base32
+ ;; FIXME: populate hash for svn repo checkout
+ "0000000000000000000000000000000000000000000000000000"))))
+ (else
+ (raise
+ (formatted-message (G_ "unsupported vcs type '~a' for package '~a'")
+ vcs-type vcs-repo-url)))))
+
+(define* (go-module->guix-package module-path #:key
+ (goproxy-url "https://proxy.golang.org"))
+ (let* ((latest-version (go-module-latest-version goproxy-url module-path))
+ (port (fetch-go.mod goproxy-url module-path latest-version))
+ (dependencies (map car (call-with-port port parse-go.mod)))
+ (guix-name (go-module->guix-package-name module-path))
+ (root-module-path (module-path->repository-root module-path))
+ ;; The VCS type and URL are not included in goproxy information. For
+ ;; this we need to fetch it from the official module page.
+ (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-url))
+ (synopsis (go-package-synopsis root-module-path))
+ (description (go-package-description module-path))
+ (licenses (go-package-licenses module-path)))
+ (values
+ `(package
+ (name ,guix-name)
+ ;; Elide the "v" prefix Go uses
+ (version ,(string-trim latest-version #\v))
+ (source
+ ,(vcs->origin vcs-type vcs-repo-url latest-version))
+ (build-system go-build-system)
+ (arguments
+ '(#:import-path ,root-module-path))
+ ,@(maybe-inputs (map go-module->guix-package-name dependencies))
+ (home-page ,(format #f "https://~a" root-module-path))
+ (synopsis ,synopsis)
+ (description ,description)
+ (license ,(match (and=> licenses list->licenses)
+ ((license) license)
+ ((licenses ...) `(list ,@licenses))
+ (x x))))
+ dependencies)))
+
+(define go-module->guix-package* (memoize go-module->guix-package))
+
+(define* (go-module-recursive-import package-name
+ #:key (goproxy-url "https://proxy.golang.org"))
+ (recursive-import
+ package-name
+ #:repo->guix-package (lambda* (name . _)
+ (go-module->guix-package*
+ name
+ #:goproxy-url goproxy-url))
+ #:guix-name go-module->guix-package-name))
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 2f5ccf7cea..64d1385164 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -136,6 +136,7 @@ of the string VERSION is replaced by the symbol 'version."
("Apache-1.1" 'license:asl1.1)
("Apache-2.0" 'license:asl2.0)
("BSL-1.0" 'license:boost1.0)
+ ("0BSD" 'license:bsd-0)
("BSD-2-Clause-FreeBSD" 'license:bsd-2)
("BSD-3-Clause" 'license:bsd-3)
("BSD-4-Clause" 'license:bsd-4)
diff --git a/guix/inferior.scm b/guix/inferior.scm
index 0990696e6c..eb457f81f9 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -120,6 +120,15 @@
(packages inferior-package-promise) ;promise of inferior packages
(table inferior-package-table)) ;promise of vhash
+(define (write-inferior inferior port)
+ (match inferior
+ (($ <inferior> pid _ _ version)
+ (format port "#<inferior ~a ~a ~a>"
+ pid version
+ (number->string (object-address inferior) 16)))))
+
+(set-record-type-printer! <inferior> write-inferior)
+
(define* (inferior-pipe directory command error-port)
"Return an input/output pipe on the Guix instance in DIRECTORY. This runs
'DIRECTORY/COMMAND repl' if it exists, or falls back to some other method if
@@ -740,8 +749,16 @@ determines whether CHANNELS are authenticated."
(string-append directory "/" file))
(scandir directory base32-encoded-sha256?)))
+ (define (symlink/safe old new)
+ (catch 'system-error
+ (lambda ()
+ (symlink old new))
+ (lambda args
+ (unless (= EEXIST (system-error-errno args))
+ (apply throw args)))))
+
(define symlink*
- (lift2 symlink %store-monad))
+ (lift2 symlink/safe %store-monad))
(define add-indirect-root*
(store-lift add-indirect-root))
diff --git a/guix/licenses.scm b/guix/licenses.scm
index 1091eee67c..0a36067387 100644
--- a/guix/licenses.scm
+++ b/guix/licenses.scm
@@ -39,7 +39,7 @@
apsl2
asl1.1 asl2.0
boost1.0
- bsd-2 bsd-3 bsd-4
+ bsd-0 bsd-2 bsd-3 bsd-4
non-copyleft
cc0
cc-by2.0 cc-by3.0 cc-by4.0
@@ -159,6 +159,11 @@
"http://directory.fsf.org/wiki/License:Boost1.0"
"https://www.gnu.org/licenses/license-list#boost"))
+(define bsd-0
+ (license "Zero-Clause BSD"
+ "https://spdx.org/licenses/0BSD.html"
+ "https://opensource.org/licenses/0BSD"))
+
(define bsd-2
(license "FreeBSD"
"http://directory.fsf.org/wiki/License:FreeBSD"
diff --git a/guix/narinfo.scm b/guix/narinfo.scm
index 2d06124017..72e0f75fda 100644
--- a/guix/narinfo.scm
+++ b/guix/narinfo.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
;;;
@@ -297,9 +297,21 @@ this is a rough approximation."
(_ (or (string=? compression2 "none")
(string=? compression2 "gzip")))))
-(define (narinfo-best-uri narinfo)
+(define (decompresses-faster? compression1 compression2)
+ "Return true if COMPRESSION1 generally has a higher decompression throughput
+than COMPRESSION2."
+ (match compression1
+ ("none" #t)
+ ("zstd" #t)
+ ("gzip" (string=? compression2 "lzip"))
+ (_ #f)))
+
+(define* (narinfo-best-uri narinfo #:key fast-decompression?)
"Select the \"best\" URI to download NARINFO's nar, and return three values:
-the URI, its compression method (a string), and the compressed file size."
+the URI, its compression method (a string), and the compressed file size.
+When FAST-DECOMPRESSION? is true, prefer substitutes with faster
+decompression (typically zstd) rather than substitutes with a higher
+compression ratio (typically lzip)."
(define choices
(filter (match-lambda
((uri compression file-size)
@@ -321,6 +333,13 @@ the URI, its compression method (a string), and the compressed file size."
(compresses-better? compression1 compression2))))
(_ #f))) ;we can't tell
- (match (sort choices file-size<?)
+ (define (speed<? c1 c2)
+ (match c1
+ ((uri1 compression1 . _)
+ (match c2
+ ((uri2 compression2 . _)
+ (decompresses-faster? compression2 compression1))))))
+
+ (match (sort choices (if fast-decompression? (negate speed<?) file-size<?))
(((uri compression file-size) _ ...)
(values uri compression file-size))))
diff --git a/guix/packages.scm b/guix/packages.scm
index dd1d473fca..56173e1204 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -6,6 +6,7 @@
;;; Copyright © 2017, 2019, 2020 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -348,7 +349,8 @@ name of its URI."
(define %supported-systems
;; This is the list of system types that are supported. By default, we
;; expect all packages to build successfully here.
- '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "mips64el-linux" "i586-gnu"))
+ '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "mips64el-linux" "i586-gnu"
+ "powerpc64le-linux"))
(define %hurd-systems
;; The GNU/Hurd systems for which support is being developed.
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index a959cb827d..fa1bbf867d 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
@@ -22,7 +22,7 @@
(define-module (guix scripts build)
#:use-module (guix ui)
#:use-module (guix scripts)
- #:use-module (guix import json)
+ #:autoload (guix import json) (json->scheme-file)
#:use-module (guix store)
#:use-module (guix derivations)
#:use-module (guix packages)
diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm
index 6f8d9aceec..be2279d254 100644
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.scm
@@ -28,7 +28,7 @@
#:use-module (guix profiles)
#:autoload (guix openpgp) (openpgp-format-fingerprint)
#:use-module (git)
- #:use-module (json)
+ #:autoload (json builder) (scm->json-string)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-37)
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index 0a3863f965..1d2b45d942 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -77,7 +77,7 @@ rather than \\n."
;;;
(define importers '("gnu" "nix" "pypi" "cpan" "hackage" "stackage" "elpa" "gem"
- "cran" "crate" "texlive" "json" "opam"))
+ "go" "cran" "crate" "texlive" "json" "opam"))
(define (resolve-importer name)
(let ((module (resolve-interface
diff --git a/guix/scripts/import/go.scm b/guix/scripts/import/go.scm
new file mode 100644
index 0000000000..afdba4e8f1
--- /dev/null
+++ b/guix/scripts/import/go.scm
@@ -0,0 +1,118 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Katherine Cox-Buday <cox.katherine.e@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts import go)
+ #:use-module (guix ui)
+ #:use-module (guix utils)
+ #:use-module (guix scripts)
+ #:use-module (guix import go)
+ #:use-module (guix scripts import)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-37)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 format)
+ #:export (guix-import-go))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+ '())
+
+(define (show-help)
+ (display (G_ "Usage: guix import go PACKAGE-PATH
+Import and convert the Go module for PACKAGE-PATH.\n"))
+ (display (G_ "
+ -h, --help display this help and exit"))
+ (display (G_ "
+ -V, --version display version information and exit"))
+ (display (G_ "
+ -r, --recursive generate package expressions for all Go modules\
+ that are not yet in Guix"))
+ (display (G_ "
+ -p, --goproxy=GOPROXY specify which goproxy server to use"))
+ (newline)
+ (show-bug-report-information))
+
+(define %options
+ ;; Specification of the command-line options.
+ (cons* (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda args
+ (show-version-and-exit "guix import go")))
+ (option '(#\r "recursive") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'recursive #t result)))
+ (option '(#\p "goproxy") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'goproxy
+ (string->symbol arg)
+ (alist-delete 'goproxy result))))
+ %standard-import-options))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-import-go . args)
+ (define (parse-options)
+ ;; Return the alist of option values.
+ (args-fold* args %options
+ (lambda (opt name arg result)
+ (leave (G_ "~A: unrecognized option~%") name))
+ (lambda (arg result)
+ (alist-cons 'argument arg result))
+ %default-options))
+
+ (let* ((opts (parse-options))
+ (args (filter-map (match-lambda
+ (('argument . value)
+ value)
+ (_ #f))
+ (reverse opts))))
+ (match args
+ ((module-name)
+ (if (assoc-ref opts 'recursive)
+ (map (match-lambda
+ ((and ('package ('name name) . rest) pkg)
+ `(define-public ,(string->symbol name)
+ ,pkg))
+ (_ #f))
+ (go-module-recursive-import module-name
+ #:goproxy-url
+ (or (assoc-ref opts 'goproxy)
+ "https://proxy.golang.org")))
+ (let ((sexp (go-module->guix-package module-name
+ #:goproxy-url
+ (or (assoc-ref opts 'goproxy)
+ "https://proxy.golang.org"))))
+ (unless sexp
+ (leave (G_ "failed to download meta-data for module '~a'~%")
+ module-name))
+ sexp)))
+ (()
+ (leave (G_ "too few arguments~%")))
+ ((many ...)
+ (leave (G_ "too many arguments~%"))))))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index fc5bf8137b..e3d40d5142 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -35,14 +35,15 @@
#:use-module (guix packages)
#:use-module (guix profiles)
#:use-module (guix search-paths)
- #:use-module (guix import json)
+ #:autoload (guix import json) (json->scheme-file)
#:use-module (guix monads)
#:use-module (guix utils)
#:use-module (guix config)
#:use-module (guix scripts)
#:use-module (guix scripts build)
#:use-module (guix transformations)
- #:use-module (guix describe)
+ #:autoload (guix describe) (manifest-entry-provenance
+ manifest-entry-with-provenance)
#:autoload (guix channels) (channel-name channel-commit channel->code)
#:autoload (guix store roots) (gc-roots user-owned?)
#:use-module ((guix build utils)
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 5866b8bb0a..46323c7216 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -45,6 +45,7 @@
#:select (uri-abbreviation nar-uri-abbreviation
(open-connection-for-uri
. guix:open-connection-for-uri)))
+ #:autoload (gnutls) (error/invalid-session)
#:use-module (guix progress)
#:use-module ((guix build syscalls)
#:select (set-thread-name))
@@ -257,6 +258,27 @@ Internal tool to substitute a pre-built binary to a local build.\n"))
;;; Daemon/substituter protocol.
;;;
+(define %prefer-fast-decompression?
+ ;; Whether to prefer fast decompression over good compression ratios. This
+ ;; serves in particular to choose between lzip (high compression ratio but
+ ;; low decompression throughput) and zstd (lower compression ratio but high
+ ;; decompression throughput).
+ #f)
+
+(define (call-with-cpu-usage-monitoring proc)
+ (let ((before (times)))
+ (proc)
+ (let ((after (times)))
+ (if (= (tms:clock after) (tms:clock before))
+ 0
+ (/ (- (tms:utime after) (tms:utime before))
+ (- (tms:clock after) (tms:clock before))
+ 1.)))))
+
+(define-syntax-rule (with-cpu-usage-monitoring exp ...)
+ "Evaluate EXP... Return its CPU usage as a fraction between 0 and 1."
+ (call-with-cpu-usage-monitoring (lambda () exp ...)))
+
(define (display-narinfo-data narinfo)
"Write to the current output port the contents of NARINFO in the format
expected by the daemon."
@@ -269,7 +291,10 @@ expected by the daemon."
(for-each (cute format #t "~a/~a~%" (%store-prefix) <>)
(narinfo-references narinfo))
- (let-values (((uri compression file-size) (narinfo-best-uri narinfo)))
+ (let-values (((uri compression file-size)
+ (narinfo-best-uri narinfo
+ #:fast-decompression?
+ %prefer-fast-decompression?)))
(format #t "~a\n~a\n"
(or file-size 0)
(or (narinfo-size narinfo) 0))))
@@ -288,12 +313,30 @@ authorized substitutes."
(lambda (obj)
(valid-narinfo? obj acl))))
+ (define* (make-progress-reporter total #:key url)
+ (define done 0)
+
+ (define (report-progress)
+ (erase-current-line (current-error-port)) ;erase current line
+ (force-output (current-error-port))
+ (format (current-error-port)
+ (G_ "updating substitutes from '~a'... ~5,1f%")
+ url (* 100. (/ done total)))
+ (set! done (+ 1 done)))
+
+ (progress-reporter
+ (start report-progress)
+ (report report-progress)
+ (stop (lambda ()
+ (newline (current-error-port))))))
+
(match (string-tokenize command)
(("have" paths ..1)
;; Return the subset of PATHS available in CACHE-URLS.
(let ((substitutable (lookup-narinfos/diverse
cache-urls paths valid?
- #:open-connection open-connection-for-uri/cached)))
+ #:open-connection open-connection-for-uri/cached
+ #:make-progress-reporter make-progress-reporter)))
(for-each (lambda (narinfo)
(format #t "~a~%" (narinfo-path narinfo)))
substitutable)
@@ -302,7 +345,8 @@ authorized substitutes."
;; Reply info about PATHS if it's in CACHE-URLS.
(let ((substitutable (lookup-narinfos/diverse
cache-urls paths valid?
- #:open-connection open-connection-for-uri/cached)))
+ #:open-connection open-connection-for-uri/cached
+ #:make-progress-reporter make-progress-reporter)))
(for-each display-narinfo-data substitutable)
(newline)))
(wtf
@@ -358,6 +402,32 @@ server certificates."
(drain-input socket)
socket))))))))
+(define (call-with-cached-connection uri proc)
+ (let ((port (open-connection-for-uri/cached uri
+ #:verify-certificate? #f)))
+ (catch #t
+ (lambda ()
+ (proc port))
+ (lambda (key . args)
+ ;; If PORT was cached and the server closed the connection in the
+ ;; meantime, we get EPIPE. In that case, open a fresh connection
+ ;; and retry. We might also get 'bad-response or a similar
+ ;; exception from (web response) later on, once we've sent the
+ ;; request, or a ERROR/INVALID-SESSION from GnuTLS.
+ (if (or (and (eq? key 'system-error)
+ (= EPIPE (system-error-errno `(,key ,@args))))
+ (and (eq? key 'gnutls-error)
+ (eq? (first args) error/invalid-session))
+ (memq key '(bad-response bad-header bad-header-component)))
+ (proc (open-connection-for-uri/cached uri
+ #:verify-certificate? #f
+ #:fresh? #t))
+ (apply throw key args))))))
+
+(define-syntax-rule (with-cached-connection uri port exp ...)
+ "Bind PORT with EXP... to a socket connected to URI."
+ (call-with-cached-connection uri (lambda (port) exp ...)))
+
(define* (process-substitution store-item destination
#:key cache-urls acl
deduplicate? print-build-trace?)
@@ -402,14 +472,11 @@ the current output port."
(warning (G_ "while fetching ~a: server is somewhat slow~%")
(uri->string uri))
(warning (G_ "try `--no-substitutes' if the problem persists~%")))
- (call-with-connection-error-handling
- uri
- (lambda ()
- (http-fetch uri #:text? #f
- #:open-connection open-connection-for-uri/cached
- #:keep-alive? #t
- #:buffered? #f
- #:verify-certificate? #f))))))
+ (with-cached-connection uri port
+ (http-fetch uri #:text? #f
+ #:port port
+ #:keep-alive? #t
+ #:buffered? #f)))))
(else
(leave (G_ "unsupported substitute URI scheme: ~a~%")
(uri->string uri)))))
@@ -419,7 +486,9 @@ the current output port."
store-item))
(let-values (((uri compression file-size)
- (narinfo-best-uri narinfo)))
+ (narinfo-best-uri narinfo
+ #:fast-decompression?
+ %prefer-fast-decompression?)))
(unless print-build-trace?
(format (current-error-port)
(G_ "Downloading ~a...~%") (uri->string uri)))
@@ -457,11 +526,28 @@ the current output port."
((hashed get-hash)
(open-hash-input-port algorithm input)))
;; Unpack the Nar at INPUT into DESTINATION.
- (restore-file hashed destination
- #:dump-file (if (and destination-in-store?
- deduplicate?)
- dump-file/deduplicate*
- dump-file))
+ (define cpu-usage
+ (with-cpu-usage-monitoring
+ (restore-file hashed destination
+ #:dump-file (if (and destination-in-store?
+ deduplicate?)
+ dump-file/deduplicate*
+ dump-file))))
+
+ ;; Create a hysteresis: depending on CPU usage, favor compression
+ ;; methods with faster decompression (like ztsd) or methods with better
+ ;; compression ratios (like lzip). This stems from the observation that
+ ;; substitution can be CPU-bound when high-speed networks are used:
+ ;; <https://lists.gnu.org/archive/html/guix-devel/2020-12/msg00177.html>.
+ ;; To simulate "slow" networking or changing conditions, run:
+ ;; sudo tc qdisc add dev eno1 root tbf rate 512kbit latency 50ms burst 1540
+ ;; and then cancel with:
+ ;; sudo tc qdisc del dev eno1 root
+ (when (> cpu-usage .8)
+ (set! %prefer-fast-decompression? #t))
+ (when (< cpu-usage .2)
+ (set! %prefer-fast-decompression? #f))
+
(close-port hashed)
(close-port input)
@@ -696,6 +782,8 @@ if needed, as expected by the daemon's agent."
;;; Local Variables:
;;; eval: (put 'with-timeout 'scheme-indent-function 1)
;;; eval: (put 'with-redirected-error-port 'scheme-indent-function 0)
+;;; eval: (put 'with-cached-connection 'scheme-indent-function 2)
+;;; eval: (put 'call-with-cached-connection 'scheme-indent-function 1)
;;; End:
;;; substitute.scm ends here
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index e3cf99acc6..c226f08371 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -8,6 +8,7 @@
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -363,11 +364,14 @@ connection to the store."
"Switch the system profile to the generation specified by SPEC, and
re-install bootloader with a configuration file that uses the specified system
generation as its default entry. STORE is an open connection to the store."
- (let ((number (relative-generation-spec->number %system-profile spec)))
+ (let* ((number (relative-generation-spec->number %system-profile spec))
+ (generation (generation-file-name %system-profile number))
+ (activate (string-append generation "/activate")))
(if number
(begin
(reinstall-bootloader store number)
- (switch-to-generation* %system-profile number))
+ (switch-to-generation* %system-profile number)
+ (unless-file-not-found (primitive-load activate)))
(leave (G_ "cannot switch to system generation '~a'~%") spec))))
(define* (system-bootloader-name #:optional (system %system-profile))
diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm
index 0d27414702..4aafd432e8 100644
--- a/guix/scripts/time-machine.scm
+++ b/guix/scripts/time-machine.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Konrad Hinsen <konrad.hinsen@fastmail.net>
;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -118,6 +119,10 @@ Execute COMMAND ARGS... in an older version of Guix.\n"))
(let-values (((args command) (break (cut string=? "--" <>) args)))
(let ((opts (parse-command-line args %options
(list %default-options))))
+ (when (assoc-ref opts 'argument)
+ (leave (G_ "~A: extraneous argument~%")
+ (assoc-ref opts 'argument)))
+
(match command
(() opts)
(("--") opts)
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index 9e94bff5a3..5164fe0494 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -117,8 +117,8 @@ values."
(end (current-time time-monotonic)))
(apply kont (time-difference end start) result)))
-(define-syntax-rule (let/time ((time result exp)) body ...)
- (call-with-time (lambda () exp) (lambda (time result) body ...)))
+(define-syntax-rule (let/time ((time result ... exp)) body ...)
+ (call-with-time (lambda () exp) (lambda (time result ...) body ...)))
(define (histogram field proc seed lst)
"Return an alist giving a histogram of all the values of FIELD for elements
@@ -181,7 +181,12 @@ Return the coverage ratio, an exact number between 0 and 1."
(format #t (G_ "looking for ~h store items on ~a...~%")
(length items) server)
- (let/time ((time narinfos (lookup-narinfos server items)))
+ (let/time ((time narinfos requests-made
+ (lookup-narinfos
+ server items
+ #:make-progress-reporter
+ (lambda* (total #:key url #:allow-other-keys)
+ (progress-reporter/bar total)))))
(format #t "~a~%" server)
(let ((obtained (length narinfos))
(requested (length items))
@@ -207,10 +212,11 @@ Return the coverage ratio, an exact number between 0 and 1."
total)))))
(format #t (G_ " ~,1h MiB on disk (uncompressed)~%")
(/ (reduce + 0 (map narinfo-size narinfos)) MiB))
- (format #t (G_ " ~,3h seconds per request (~,1h seconds in total)~%")
- (/ time requested 1.) time)
- (format #t (G_ " ~,1h requests per second~%")
- (/ requested time 1.))
+ (when (> requests-made 0)
+ (format #t (G_ " ~,3h seconds per request (~,1h seconds in total)~%")
+ (/ time requests-made 1.) time)
+ (format #t (G_ " ~,1h requests per second~%")
+ (/ requests-made time 1.)))
(guard (c ((http-get-error? c)
(if (= 404 (http-get-error-code c))
diff --git a/guix/self.scm b/guix/self.scm
index 35fba1152d..3154d180ac 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -56,6 +56,7 @@
("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh))
("guile-git" (ref '(gnu packages guile) 'guile-git))
("guile-semver" (ref '(gnu packages guile-xyz) 'guile-semver))
+ ("guile-lib" (ref '(gnu packages guile-xyz) 'guile-lib))
("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3))
("guile-zlib" (ref '(gnu packages guile) 'guile-zlib))
("guile-lzlib" (ref '(gnu packages guile) 'guile-lzlib))
@@ -814,6 +815,9 @@ itself."
(define guile-ssh
(specification->package "guile-ssh"))
+ (define guile-lib
+ (specification->package "guile-lib"))
+
(define guile-git
(specification->package "guile-git"))
@@ -842,7 +846,7 @@ itself."
(append-map transitive-package-dependencies
(list guile-gcrypt gnutls guile-git guile-avahi
guile-json guile-semver guile-ssh guile-sqlite3
- guile-zlib guile-lzlib guile-zstd)))
+ guile-lib guile-zlib guile-lzlib guile-zstd)))
(define *core-modules*
(scheme-node "guix-core"
diff --git a/guix/status.scm b/guix/status.scm
index 9ca6d92470..d47bf1700c 100644
--- a/guix/status.scm
+++ b/guix/status.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
@@ -23,8 +23,7 @@
#:use-module (guix colors)
#:use-module (guix progress)
#:autoload (guix build syscalls) (terminal-columns)
- #:use-module ((guix build download)
- #:select (nar-uri-abbreviation))
+ #:autoload (guix build download) (nar-uri-abbreviation)
#:use-module (guix store)
#:use-module (guix derivations)
#:use-module (guix memoization)
diff --git a/guix/substitutes.scm b/guix/substitutes.scm
index dc94ccc8e4..08f8c24efd 100644
--- a/guix/substitutes.scm
+++ b/guix/substitutes.scm
@@ -173,18 +173,14 @@ if file doesn't exist, and the narinfo otherwise."
(apply throw args)))))
(define* (fetch-narinfos url paths
- #:key (open-connection guix:open-connection-for-uri))
+ #:key
+ (open-connection guix:open-connection-for-uri)
+ (make-progress-reporter
+ (const progress-reporter/silent)))
"Retrieve all the narinfos for PATHS from the cache at URL and return them."
- (define update-progress!
- (let ((done 0)
- (total (length paths)))
- (lambda ()
- (display "\r\x1b[K" (current-error-port)) ;erase current line
- (force-output (current-error-port))
- (format (current-error-port)
- (G_ "updating substitutes from '~a'... ~5,1f%")
- url (* 100. (/ done total)))
- (set! done (+ 1 done)))))
+ (define progress-reporter
+ (make-progress-reporter (length paths)
+ #:url url))
(define hash-part->path
(let ((mapping (fold (lambda (path result)
@@ -206,7 +202,7 @@ if file doesn't exist, and the narinfo otherwise."
(len (response-content-length response))
(cache (response-cache-control response))
(ttl (and cache (assoc-ref cache 'max-age))))
- (update-progress!)
+ (progress-reporter-report! progress-reporter)
;; Make sure to read no more than LEN bytes since subsequent bytes may
;; belong to the next response.
@@ -238,7 +234,7 @@ if file doesn't exist, and the narinfo otherwise."
;; narinfos, which provides a much stronger guarantee.
(let* ((requests (map (cut narinfo-request url <>) paths))
(result (begin
- (update-progress!)
+ (start-progress-reporter! progress-reporter)
(call-with-connection-error-handling
uri
(lambda ()
@@ -247,7 +243,7 @@ if file doesn't exist, and the narinfo otherwise."
requests
#:open-connection open-connection
#:verify-certificate? #f))))))
- (newline (current-error-port))
+ (stop-progress-reporter! progress-reporter)
result))
((file #f)
(let* ((base (string-append (uri-path uri) "/"))
@@ -297,7 +293,9 @@ for PATH."
(values #f #f))))
(define* (lookup-narinfos cache paths
- #:key (open-connection guix:open-connection-for-uri))
+ #:key (open-connection guix:open-connection-for-uri)
+ (make-progress-reporter
+ (const progress-reporter/silent)))
"Return the narinfos for PATHS, invoking the server at CACHE when no
information is available locally."
(let-values (((cached missing)
@@ -312,15 +310,20 @@ information is available locally."
'()
'()
paths)))
- (if (null? missing)
- cached
- (let ((missing (fetch-narinfos cache missing
- #:open-connection open-connection)))
- (append cached (or missing '()))))))
+ (values (if (null? missing)
+ cached
+ (let ((missing (fetch-narinfos cache missing
+ #:open-connection open-connection
+ #:make-progress-reporter
+ make-progress-reporter)))
+ (append cached (or missing '()))))
+ (length missing))))
(define* (lookup-narinfos/diverse caches paths authorized?
#:key (open-connection
- guix:open-connection-for-uri))
+ guix:open-connection-for-uri)
+ (make-progress-reporter
+ (const progress-reporter/silent)))
"Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order.
That is, when a cache lacks an AUTHORIZED? narinfo, look it up in the next
cache, and so on.
@@ -353,7 +356,9 @@ AUTHORIZED? narinfo."
(match caches
((cache rest ...)
(let* ((narinfos (lookup-narinfos cache paths
- #:open-connection open-connection))
+ #:open-connection open-connection
+ #:make-progress-reporter
+ make-progress-reporter))
(definite (map narinfo-path (filter authorized? narinfos)))
(missing (lset-difference string=? paths definite))) ;XXX: perf
(loop rest missing
diff --git a/guix/tests.scm b/guix/tests.scm
index 4c6c7d95db..da75835099 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -143,7 +143,7 @@ no external store to talk to."
(lambda ()
;; Since we're using a different store we must clear the
;; package-derivation cache.
- (hash-clear! (@@ (guix derivations) %derivation-cache))
+ (hash-clear! (@@ (guix packages) %derivation-cache))
(proc store))
(lambda ()
diff --git a/guix/tests/http.scm b/guix/tests/http.scm
index 4119e9ce01..8f50eaefca 100644
--- a/guix/tests/http.scm
+++ b/guix/tests/http.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -21,12 +22,12 @@
#:use-module (web server)
#:use-module (web server http)
#:use-module (web response)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-39)
#:use-module (ice-9 match)
#:export (with-http-server
call-with-http-server
%http-server-port
- http-server-can-listen?
%local-url))
;;; Commentary:
@@ -37,12 +38,13 @@
(define %http-server-port
;; TCP port to use for the stub HTTP server.
- (make-parameter 9999))
+ ;; If 0, the OS will automatically choose
+ ;; a port.
+ (make-parameter 0))
(define (open-http-server-socket)
- "Return a listening socket for the web server. It is useful to export it so
-that tests can check whether we succeeded opening the socket and tests skip if
-needed."
+ "Return a listening socket for the web server and the port
+actually listened at (in case %http-server-port was 0)."
(catch 'system-error
(lambda ()
(let ((sock (socket PF_INET SOCK_STREAM 0)))
@@ -50,22 +52,18 @@ needed."
(bind sock
(make-socket-address AF_INET INADDR_LOOPBACK
(%http-server-port)))
- sock))
+ (values sock
+ (sockaddr:port (getsockname sock)))))
(lambda args
(let ((err (system-error-errno args)))
(format (current-error-port)
"warning: cannot run Web server for tests: ~a~%"
(strerror err))
- #f))))
-
-(define (http-server-can-listen?)
- "Return #t if we managed to open a listening socket."
- (and=> (open-http-server-socket)
- (lambda (socket)
- (close-port socket)
- #t)))
+ (values #f #f)))))
(define* (%local-url #:optional (port (%http-server-port)))
+ (when (= port 0)
+ (error "no web server is running!"))
;; URL to use for 'home-page' tests.
(string-append "http://localhost:" (number->string port)
"/foo/bar"))
@@ -73,7 +71,10 @@ needed."
(define* (call-with-http-server responses+data thunk)
"Call THUNK with an HTTP server running and returning RESPONSES+DATA on HTTP
requests. Each element of RESPONSES+DATA must be a tuple containing a
-response and a string, or an HTTP response code and a string."
+response and a string, or an HTTP response code and a string.
+
+%http-server-port will be set to the port listened at
+The port listened at will be set for the dynamic extent of THUNK."
(define responses
(map (match-lambda
(((? response? response) data)
@@ -100,6 +101,7 @@ response and a string, or an HTTP response code and a string."
;; Mutex and condition variable to synchronize with the HTTP server.
(define %http-server-lock (make-mutex))
(define %http-server-ready (make-condition-variable))
+ (define %http-real-server-port #f)
(define (http-open . args)
"Start listening for HTTP requests and signal %HTTP-SERVER-READY."
@@ -122,7 +124,8 @@ response and a string, or an HTTP response code and a string."
(set! responses rest)
(values response data))))
- (let ((socket (open-http-server-socket)))
+ (let-values (((socket port) (open-http-server-socket)))
+ (set! %http-real-server-port port)
(catch 'quit
(lambda ()
(run-server handle stub-http-server
@@ -134,7 +137,8 @@ response and a string, or an HTTP response code and a string."
(let ((server (make-thread server-body)))
(wait-condition-variable %http-server-ready %http-server-lock)
;; Normally SERVER exits automatically once it has received a request.
- (thunk))))
+ (parameterize ((%http-server-port %http-real-server-port))
+ (thunk)))))
(define-syntax with-http-server
(syntax-rules ()
diff --git a/guix/utils.scm b/guix/utils.scm
index 96cd8c791e..7db9f52ff6 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -10,6 +10,7 @@
;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -48,6 +49,7 @@
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module ((ice-9 iconv) #:prefix iconv:)
+ #:autoload (zlib) (make-zlib-input-port make-zlib-output-port)
#:use-module (system foreign)
#:re-export (<location> ;for backwards compatibility
location
@@ -83,6 +85,7 @@
target-arm32?
target-aarch64?
target-arm?
+ target-powerpc?
target-64bit?
cc-for-target
cxx-for-target
@@ -234,8 +237,9 @@ a symbol such as 'xz."
(match compression
((or #f 'none) (values input '()))
('bzip2 (filtered-port `(,%bzip2 "-dc") input))
- ('xz (filtered-port `(,%xz "-dc" ,@(%xz-parallel-args)) input))
- ('gzip (filtered-port `(,%gzip "-dc") input))
+ ('xz (filtered-port `(,%xz "-dc") input))
+ ('gzip (values (make-zlib-input-port input #:format 'gzip)
+ '()))
('lzip (values (lzip-port 'make-lzip-input-port input)
'()))
('zstd (values (zstd-port 'make-zstd-input-port input)
@@ -307,9 +311,9 @@ program--e.g., '(\"--fast\")."
(match compression
((or #f 'none) (values output '()))
('bzip2 (filtered-output-port `(,%bzip2 "-c" ,@options) output))
- ('xz (filtered-output-port `(,%xz "-c" ,@(%xz-parallel-args)
- ,@options) output))
- ('gzip (filtered-output-port `(,%gzip "-c" ,@options) output))
+ ('xz (filtered-output-port `(,%xz "-c" ,@options) output))
+ ('gzip (values (make-zlib-output-port output #:format 'gzip)
+ '()))
('lzip (values (lzip-port 'make-lzip-output-port output)
'()))
('zstd (values (zstd-port 'make-zstd-output-port output)
@@ -555,9 +559,13 @@ a character other than '@'."
(%current-system))))
(or (target-arm32? target) (target-aarch64? target)))
+(define* (target-powerpc? #:optional (target (or (%current-target-system)
+ (%current-system))))
+ (string-prefix? "powerpc" target))
+
(define* (target-64bit? #:optional (system (or (%current-target-system)
(%current-system))))
- (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "ppc64")))
+ (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "powerpc64")))
(define* (cc-for-target #:optional (target (%current-target-system)))
(if target