From 97d615b1761c2054561057f6b56e2a0caed13aa4 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sat, 24 Apr 2021 06:43:46 +0100 Subject: inferior: Support querying package replacements. I'm looking at this to help with adding support for looking up package replacements to store in the Guix Data Service. * guix/inferior.scm (inferior-package-replacement): New procedure. * tests/inferior.scm ("inferior-package-replacement"): New test. --- guix/inferior.scm | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) (limited to 'guix') 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." -- cgit v1.2.3 From dc3504913de4a2c549482001f7087362f5400f29 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 11 May 2021 15:04:20 +0200 Subject: substitutes: Reduce negative TTLs. * guix/substitutes.scm (%narinfo-negative-ttl): Change to 15mn. (%narinfo-transient-error-ttl): Halve. --- guix/substitutes.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2014 Nikita Karetnikov ;;; Copyright © 2018 Kyle Meyer ;;; Copyright © 2020 Christopher Baines @@ -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 -- cgit v1.2.3 From 938ffcbb0589adc07dc12c79eda3e1e2bb9e7cf8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 11 May 2021 15:01:00 +0200 Subject: publish: Add '--negative-ttl'. * guix/scripts/publish.scm (show-help, %options): Add '--negative-ttl'. (render-narinfo, render-narinfo/cached, make-request-handler): Add #:negative-ttl and honor it. (run-publish-server): Add #:narinfo-negative-ttl and honor it. (guix-publish): Honor '--negative-ttl'. * tests/publish.scm ("negative TTL", "no negative TTL"): New tests. --- doc/guix.texi | 10 ++++++++++ guix/scripts/publish.scm | 30 ++++++++++++++++++++++-------- tests/publish.scm | 32 +++++++++++++++++++++++++++++++- 3 files changed, 63 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index bfc714c5b6..a10943f2d5 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -12703,6 +12703,16 @@ Additionally, when @option{--cache} is used, cached entries that have not been accessed for @var{ttl} and that no longer have a corresponding item in the store, may be deleted. +@item --negative-ttl=@var{ttl} +Similarly produce @code{Cache-Control} HTTP headers to advertise the +time-to-live (TTL) of @emph{negative} lookups---missing store items, for +which the HTTP 404 code is returned. By default, no negative TTL is +advertised. + +This parameter can help adjust server load and substitute latency by +instructing cooperating clients to be more or less patient when a store +item is missing. + @item --cache-bypass-threshold=@var{size} When used in conjunction with @option{--cache}, store items smaller than @var{size} are immediately available, even when they are not yet in 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 ;;; Copyright © 2020 by Amar M. Singh -;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2020 Maxim Cournoyer ;;; Copyright © 2021 Simon Tournier ;;; @@ -101,6 +101,8 @@ Publish ~a over HTTP.\n") %store-directory) --workers=N use N workers to bake items")) (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_ " @@ -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/tests/publish.scm b/tests/publish.scm index 3e67c435ac..c3d086995a 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson ;;; Copyright © 2020 by Amar M. Singh -;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès +;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -700,6 +700,36 @@ References: ~%" (= (response-content-length response) (stat:size (stat log))) (first (response-content-type response)))))) +(test-equal "negative TTL" + `(404 42) + + (call-with-temporary-directory + (lambda (cache) + (let ((thread (with-separate-output-ports + (call-with-new-thread + (lambda () + (guix-publish "--port=6786" "-C0" + "--negative-ttl=42s")))))) + (wait-until-ready 6786) + + (let* ((base "http://localhost:6786/") + (url (string-append base (make-string 32 #\z) + ".narinfo")) + (response (http-get url))) + (list (response-code response) + (match (assq-ref (response-headers response) 'cache-control) + ((('max-age . ttl)) ttl) + (_ #f)))))))) + +(test-equal "no negative TTL" + `(404 #f) + (let* ((uri (publish-uri + (string-append "/" (make-string 32 #\z) + ".narinfo"))) + (response (http-get uri))) + (list (response-code response) + (assq-ref (response-headers response) 'cache-control)))) + (test-equal "/log/NAME not found" 404 (let ((uri (publish-uri "/log/does-not-exist"))) -- cgit v1.2.3 From 4288806111dd6d65a40e5e6dc915aef71810fb34 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 17 May 2021 22:47:18 +0200 Subject: ui: Remove Guile 2.2.3 workaround. This became dead code with commit 4f621a2b003e85d480999e4d0630e9dc3de85bc3. * guix/ui.scm (load*): Remove Guile 2.2.3 workaround. --- guix/ui.scm | 19 +------------------ 1 file changed, 1 insertion(+), 18 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index e2cf2f1f5e..a22024b62f 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) @@ -211,17 +210,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 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 . - (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,12 +221,6 @@ 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 -- cgit v1.2.3 From a0ad6361670e7d3bd831e1a1920b46661a480d0a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 17 May 2021 23:16:40 +0200 Subject: ui: 'load*' compiles with '-O1'. With this change, the wall-clock time of: guix system build --no-grafts -d gnu/system/install.scm goes from 5.0s to 2.3s on Guile 3.0.5. * guix/ui.scm (without-compiler-optimizations): New macro. (load*): Use it. --- guix/ui.scm | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index a22024b62f..05b3f5f84c 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -196,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." @@ -225,7 +237,8 @@ information, or #f if it could not be found." ;; 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 -- cgit v1.2.3 From 0471024acce5f760ac147326c06343c9c68ad3d1 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Thu, 20 May 2021 11:44:35 +0200 Subject: scripts: challenge: Fix regression. This is a follow-up of 3cde5231aa78aa5e31b27888cd78ee0b250a7a1c that fixes the challenge test. When dealing with uncompressed NAR, the file size is false. Propagate it to progress-reporter/file as it used to be the case. * guix/scripts/challenge.scm (call-with-nar): Accept false size. --- guix/scripts/challenge.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') 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 -- cgit v1.2.3 From bd8e7621b880c529cc69102bd6817d79257526ee Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 20 May 2021 16:26:46 +0200 Subject: guix: Build texlive-configuration only when texlive-base is present. Fixes . * guix/profiles.scm (texlive-configuration): Build only if texlive-base is present in the profile's manifest. --- guix/profiles.scm | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 0044851dc2..ca997a7125 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1745,16 +1745,15 @@ MANIFEST." maproot "updmap/pdftex/"))))) #t))) - (with-monad %store-monad - (if (any (cut string-prefix? "texlive-" <>) - (map manifest-entry-name (manifest-entries manifest))) - (gexp->derivation "texlive-configuration" build - #:substitutable? #f - #:local-build? #t - #:properties - `((type . profile-hook) - (hook . texlive-configuration))) - (return #f)))) + (mlet %store-monad ((texlive-base (manifest-lookup-package manifest "texlive-base"))) + (if texlive-base + (gexp->derivation "texlive-configuration" build + #:substitutable? #f + #:local-build? #t + #:properties + `((type . profile-hook) + (hook . texlive-configuration))) + (return #f)))) (define %default-profile-hooks ;; This is the list of derivation-returning procedures that are called by -- cgit v1.2.3 From 7003b2db526fc367664f3a7c4bdbe38a7c717da6 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Fri, 21 May 2021 15:21:15 +0200 Subject: scripts: discover: Report Avahi errors. Fixes: . * guix/scripts/discover (guix-discover): Report Avahi errors. --- guix/scripts/discover.scm | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2020, 2021 Mathieu Othacehe ;;; Copyright © 2021 Simon Tournier ;;; ;;; 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))))))) -- cgit v1.2.3