summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorMarius Bakke <marius@gnu.org>2021-05-22 17:21:57 +0200
committerMarius Bakke <marius@gnu.org>2021-05-22 17:21:57 +0200
commit4ea6852c5ff1606cf6848f3ddbb669120b228c13 (patch)
tree6f21e3cad7a3cad4eb847f404b6ba6450dfc2bef /guix
parentfcf45f8d756b92c5a99308d671af8992b489c4b4 (diff)
parentd4ffa9630277fa8699c783c08381d688626d4bc3 (diff)
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r--guix/inferior.scm22
-rw-r--r--guix/scripts/challenge.scm3
-rw-r--r--guix/scripts/discover.scm18
-rw-r--r--guix/scripts/publish.scm30
-rw-r--r--guix/substitutes.scm6
-rw-r--r--guix/ui.scm34
6 files changed, 79 insertions, 34 deletions
diff --git a/guix/inferior.scm b/guix/inferior.scm
index eb457f81f9..7c8e478f2a 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -90,6 +90,7 @@
inferior-package-native-search-paths
inferior-package-transitive-native-search-paths
inferior-package-search-paths
+ inferior-package-replacement
inferior-package-provenance
inferior-package-derivation
@@ -462,6 +463,27 @@ package."
(define inferior-package-transitive-native-search-paths
(cut %inferior-package-search-paths <> 'package-transitive-native-search-paths))
+(define (inferior-package-replacement package)
+ "Return the replacement for PACKAGE. This will either be an inferior
+package, or #f."
+ (match (inferior-package-field
+ package
+ '(compose (match-lambda
+ ((? package? package)
+ (let ((id (object-address package)))
+ (hashv-set! %package-table id package)
+ (list id
+ (package-name package)
+ (package-version package))))
+ (#f #f))
+ package-replacement))
+ (#f #f)
+ ((id name version)
+ (inferior-package (inferior-package-inferior package)
+ name
+ version
+ id))))
+
(define (inferior-package-provenance package)
"Return a \"provenance sexp\" for PACKAGE, an inferior package. The result
is similar to the sexp returned by 'package-provenance' for regular packages."
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index 07477f816e..69c2781abb 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -257,7 +257,8 @@ NARINFO."
(http-fetch uri)))
(define reporter
(progress-reporter/file (narinfo-path narinfo)
- (max size (or actual-size 0)) ;defensive
+ (and size
+ (max size (or actual-size 0))) ;defensive
#:abbreviation (const (uri-host uri))))
(define result
diff --git a/guix/scripts/discover.scm b/guix/scripts/discover.scm
index be1eaa6e95..dadade81bb 100644
--- a/guix/scripts/discover.scm
+++ b/guix/scripts/discover.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
+;;; Copyright © 2020, 2021 Mathieu Othacehe <othacehe@gnu.org>
;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; This file is part of GNU Guix.
@@ -26,6 +26,7 @@
#:use-module (guix build syscalls)
#:use-module (guix build utils)
#:use-module (guix scripts publish)
+ #:use-module (avahi)
#:use-module (ice-9 rdelim)
#:use-module (srfi srfi-37)
#:export (read-substitute-urls
@@ -138,5 +139,16 @@ to synchronize with the writer."
(parameterize ((%publish-file publish-file))
(mkdir-p (dirname publish-file))
(false-if-exception (delete-file publish-file))
- (avahi-browse-service-thread service-proc
- #:types %services)))))
+ (catch 'avahi-error
+ (lambda ()
+ (avahi-browse-service-thread service-proc
+ #:types %services))
+ (lambda (key err function . _)
+ (cond
+ ((eq? err error/no-daemon)
+ (warning (G_ "Avahi daemon is not running, \
+cannot auto-discover substitutes servers.~%")))
+ (else
+ (report-error (G_ "an Avahi error was raised by `~a': ~a~%")
+ function (error->string err))))
+ (exit 1)))))))
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index 39bb224cad..ef6fa5f074 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2020 by Amar M. Singh <nly@disroot.org>
-;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;;
@@ -102,6 +102,8 @@ Publish ~a over HTTP.\n") %store-directory)
(display (G_ "
--ttl=TTL announce narinfos can be cached for TTL seconds"))
(display (G_ "
+ --negative-ttl=TTL announce missing narinfos can be cached for TTL seconds"))
+ (display (G_ "
--nar-path=PATH use PATH as the prefix for nar URLs"))
(display (G_ "
--public-key=FILE use FILE as the public key for signatures"))
@@ -224,6 +226,13 @@ usage."
(leave (G_ "~a: invalid duration~%") arg))
(alist-cons 'narinfo-ttl (time-second duration)
result))))
+ (option '("negative-ttl") #t #f
+ (lambda (opt name arg result)
+ (let ((duration (string->duration arg)))
+ (unless duration
+ (leave (G_ "~a: invalid duration~%") arg))
+ (alist-cons 'narinfo-negative-ttl (time-second duration)
+ result))))
(option '("nar-path") #t #f
(lambda (opt name arg result)
(alist-cons 'nar-path arg result)))
@@ -390,14 +399,14 @@ References: ~a~%"
(define* (render-narinfo store request hash
#:key ttl (compressions (list %no-compression))
- (nar-path "nar"))
+ (nar-path "nar") negative-ttl)
"Render metadata for the store path corresponding to HASH. If TTL is true,
advertise it as the maximum validity period (in seconds) via the
'Cache-Control' header. This allows 'guix substitute' to cache it for an
appropriate duration. NAR-PATH specifies the prefix for nar URLs."
(let ((store-path (hash-part->path store hash)))
(if (string-null? store-path)
- (not-found request #:phrase "")
+ (not-found request #:phrase "" #:ttl negative-ttl)
(values `((content-type . (application/x-nix-narinfo))
,@(if ttl
`((cache-control (max-age . ,ttl)))
@@ -512,7 +521,7 @@ interpreted as the basename of a store item."
(define* (render-narinfo/cached store request hash
#:key ttl (compressions (list %no-compression))
- (nar-path "nar")
+ (nar-path "nar") negative-ttl
cache pool)
"Respond to the narinfo request for REQUEST. If the narinfo is available in
CACHE, then send it; otherwise, return 404 and \"bake\" that nar and narinfo
@@ -536,7 +545,7 @@ requested using POOL."
#:compression
(first compressions)))))
(cond ((string-null? item)
- (not-found request))
+ (not-found request #:ttl negative-ttl))
((file-exists? cached)
;; Narinfo is in cache, send it.
(values `((content-type . (application/x-nix-narinfo))
@@ -584,7 +593,7 @@ requested using POOL."
#:phrase "We're baking it"
#:ttl 300))) ;should be available within 5m
(else
- (not-found request #:phrase "")))))
+ (not-found request #:phrase "" #:ttl negative-ttl)))))
(define (compress-nar cache item compression)
"Save in directory CACHE the nar for ITEM compressed with COMPRESSION."
@@ -974,7 +983,7 @@ methods, return the applicable compression."
(define* (make-request-handler store
#:key
cache pool
- narinfo-ttl
+ narinfo-ttl narinfo-negative-ttl
(nar-path "nar")
(compressions (list %no-compression)))
(define compression-type?
@@ -1006,10 +1015,12 @@ methods, return the applicable compression."
#:cache cache
#:pool pool
#:ttl narinfo-ttl
+ #:negative-ttl narinfo-negative-ttl
#:nar-path nar-path
#:compressions compressions)
(render-narinfo store request hash
#:ttl narinfo-ttl
+ #:negative-ttl narinfo-negative-ttl
#:nar-path nar-path
#:compressions compressions)))
;; /nar/file/NAME/sha256/HASH
@@ -1068,7 +1079,7 @@ methods, return the applicable compression."
#:key
advertise? port
(compressions (list %no-compression))
- (nar-path "nar") narinfo-ttl
+ (nar-path "nar") narinfo-ttl narinfo-negative-ttl
cache pool)
(when advertise?
(let ((name (service-name)))
@@ -1084,6 +1095,7 @@ methods, return the applicable compression."
#:pool pool
#:nar-path nar-path
#:narinfo-ttl narinfo-ttl
+ #:narinfo-negative-ttl narinfo-negative-ttl
#:compressions compressions)
concurrent-http-server
`(#:socket ,socket)))
@@ -1127,6 +1139,7 @@ methods, return the applicable compression."
(user (assoc-ref opts 'user))
(port (assoc-ref opts 'port))
(ttl (assoc-ref opts 'narinfo-ttl))
+ (negative-ttl (assoc-ref opts 'narinfo-negative-ttl))
(compressions (match (filter-map (match-lambda
(('compression . compression)
compression)
@@ -1192,6 +1205,7 @@ consider using the '--user' option!~%")))
"publish worker"))
#:nar-path nar-path
#:compressions compressions
+ #:narinfo-negative-ttl negative-ttl
#:narinfo-ttl ttl))))))
;;; Local Variables:
diff --git a/guix/substitutes.scm b/guix/substitutes.scm
index 08f8c24efd..4987cda165 100644
--- a/guix/substitutes.scm
+++ b/guix/substitutes.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>
;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
@@ -72,11 +72,11 @@
(define %narinfo-negative-ttl
;; Likewise, but for negative lookups---i.e., cached lookup failures (404).
- (* 1 3600))
+ (* 10 60))
(define %narinfo-transient-error-ttl
;; Likewise, but for transient errors such as 504 ("Gateway timeout").
- (* 10 60))
+ (* 5 60))
(define %narinfo-cache-directory
;; A local cache of narinfos, to avoid going to the network. Most of the
diff --git a/guix/ui.scm b/guix/ui.scm
index e2cf2f1f5e..05b3f5f84c 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -73,7 +73,6 @@
#:use-module (ice-9 format)
#:use-module (ice-9 regex)
#:autoload (ice-9 popen) (open-pipe* close-pipe)
- #:autoload (system base compile) (compile-file)
#:autoload (system repl repl) (start-repl)
#:autoload (system repl debug) (make-debug stack->vector)
#:autoload (web uri) (encode-and-join-uri-path)
@@ -197,6 +196,18 @@ information, or #f if it could not be found."
(stack-ref stack 1) ;skip the 'throw' frame
last))))
+(cond-expand
+ (guile-3
+ (define-syntax-rule (without-compiler-optimizations exp)
+ ;; Compile with the baseline compiler (-O1), which is much less expensive
+ ;; than -O2.
+ (parameterize (((@ (system base compile) default-optimization-level) 1))
+ exp)))
+ (else
+ (define-syntax-rule (without-compiler-optimizations exp)
+ ;; No easy way to turn off optimizations on Guile 2.2.
+ exp)))
+
(define* (load* file user-module
#:key (on-error 'nothing-special))
"Load the user provided Scheme source code FILE."
@@ -211,17 +222,7 @@ information, or #f if it could not be found."
(catch #t
(lambda ()
;; XXX: Force a recompilation to avoid ABI issues.
- ;;
- ;; In 2.2.3, the bogus answer to <https://bugs.gnu.org/29226> was to
- ;; ignore all available .go, not just those from ~/.cache, which in turn
- ;; meant that we had to rebuild *everything*. Since this is too costly,
- ;; we have to turn off '%fresh-auto-compile' with that version, so to
- ;; avoid ABI breakage in the user's config file, we explicitly compile
- ;; it (the problem remains if the user's config is spread on several
- ;; modules.) See <https://bugs.gnu.org/29881>.
- (unless (string=? (version) "2.2.3")
- (set! %fresh-auto-compile #t))
-
+ (set! %fresh-auto-compile #t)
(set! %load-should-auto-compile #t)
(save-module-excursion
@@ -232,17 +233,12 @@ information, or #f if it could not be found."
(parameterize ((current-warning-port (%make-void-port "w")))
(call-with-prompt tag
(lambda ()
- (when (string=? (version) "2.2.3")
- (catch 'system-error
- (lambda ()
- (compile-file file #:env user-module))
- (const #f))) ;EACCES maybe, let's interpret it
-
;; Give 'load' an absolute file name so that it doesn't try to
;; search for FILE in %LOAD-PATH. Note: use 'load', not
;; 'primitive-load', so that FILE is compiled, which then allows
;; us to provide better error reporting with source line numbers.
- (load (canonicalize-path file)))
+ (without-compiler-optimizations
+ (load (canonicalize-path file))))
(const #f))))))
(lambda _
;; XXX: Errors are reported from the pre-unwind handler below, but