diff options
Diffstat (limited to 'guix')
-rw-r--r-- | guix/inferior.scm | 22 | ||||
-rw-r--r-- | guix/scripts/challenge.scm | 3 | ||||
-rw-r--r-- | guix/scripts/discover.scm | 18 | ||||
-rw-r--r-- | guix/scripts/publish.scm | 30 | ||||
-rw-r--r-- | guix/substitutes.scm | 6 | ||||
-rw-r--r-- | guix/ui.scm | 34 |
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 |