From 1563d6c79f759cb9a6cc5561463653f0f184cb36 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 17 Apr 2017 22:04:31 +0200 Subject: Add (guix workers). * guix/workers.scm, tests/workers.scm: New files. * Makefile.am (MODULES, SCM_TESTS): Add them. * .dir-locals.el: Add rule for 'eventually'. --- tests/workers.scm | 45 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) create mode 100644 tests/workers.scm (limited to 'tests') diff --git a/tests/workers.scm b/tests/workers.scm new file mode 100644 index 0000000000..44b882f691 --- /dev/null +++ b/tests/workers.scm @@ -0,0 +1,45 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ludovic Courtès +;;; +;;; 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 . + +(define-module (test-workers) + #:use-module (guix workers) + #:use-module (ice-9 threads) + #:use-module (srfi srfi-64)) + +(test-begin "workers") + +(test-equal "enqueue" + 4242 + (let* ((pool (make-pool)) + (result 0) + (1+! (let ((lock (make-mutex))) + (lambda () + (with-mutex lock + (set! result (+ result 1))))))) + (let loop ((i 4242)) + (unless (zero? i) + (pool-enqueue! pool 1+!) + (loop (- i 1)))) + (let poll () + (unless (pool-idle? pool) + (pk 'busy result) + (sleep 1) + (poll))) + result)) + +(test-end) -- cgit v1.2.3 From 00753f7038234a0f5a79be3ec9ab949840a18743 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 17 Apr 2017 23:13:40 +0200 Subject: publish: Add '--cache' and '--workers'. Fixes . Reported by . These options allow nars to be "baked" off-line and cached instead of being compressed on the fly. As a side-effect, this allows us to provide a 'Content-Length' header for nars. * guix/scripts/publish.scm (show-help, %options): Add '--cache' and '--workers'. (%default-options): Add 'workers'. (nar-cache-file, narinfo-cache-file, run-single-baker): New procedures. (single-baker): New macro. (render-narinfo/cached, bake-narinfo+nar) (render-nar/cached): New procedures. (make-request-handler): Add #:cache and #:pool parameters and honor them. (run-publish-server): Likewise. (guix-publish): Honor '--cache' and '--workers'. * tests/publish.scm ("with cache"): New test. * doc/guix.texi (Invoking guix publish): Document it. --- doc/guix.texi | 46 ++++++++++- guix/scripts/publish.scm | 197 +++++++++++++++++++++++++++++++++++++++++++---- tests/publish.scm | 54 +++++++++++++ 3 files changed, 280 insertions(+), 17 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index fd3483ee5d..bbb2ba732d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6522,6 +6522,13 @@ archive}), the daemon may download substitutes from it: guix-daemon --substitute-urls=http://example.org:8080 @end example +By default, @command{guix publish} compresses archives on the fly as it +serves them. This ``on-the-fly'' mode is convenient in that it requires +no setup and is immediately available. However, when serving lots of +clients, we recommend using the @option{--cache} option, which enables +caching of the archives before they are sent to clients---see below for +details. + As a bonus, @command{guix publish} also serves as a content-addressed mirror for source files referenced in @code{origin} records (@pxref{origin Reference}). For instance, assuming @command{guix @@ -6559,10 +6566,43 @@ disable compression. The range 1 to 9 corresponds to different gzip compression levels: 1 is the fastest, and 9 is the best (CPU-intensive). The default is 3. -Compression occurs on the fly and the compressed streams are not +Unless @option{--cache} is used, compression occurs on the fly and +the compressed streams are not cached. Thus, to reduce load on the machine that runs @command{guix -publish}, it may be a good idea to choose a low compression level, or to -run @command{guix publish} behind a caching proxy. +publish}, it may be a good idea to choose a low compression level, to +run @command{guix publish} behind a caching proxy, or to use +@option{--cache}. Using @option{--cache} has the advantage that it +allows @command{guix publish} to add @code{Content-Length} HTTP header +to its responses. + +@item --cache=@var{directory} +@itemx -c @var{directory} +Cache archives and meta-data (@code{.narinfo} URLs) to @var{directory} +and only serve archives that are in cache. + +When this option is omitted, archives and meta-data are created +on-the-fly. This can reduce the available bandwidth, especially when +compression is enabled, since this may become CPU-bound. Another +drawback of the default mode is that the length of archives is not known +in advance, so @command{guix publish} does not add a +@code{Content-Length} HTTP header to its responses, which in turn +prevents clients from knowing the amount of data being downloaded. + +Conversely, when @option{--cache} is used, the first request for a store +item (@i{via} a @code{.narinfo} URL) returns 404 and triggers a +background process to @dfn{bake} the archive---computing its +@code{.narinfo} and compressing the archive, if needed. Once the +archive is cached in @var{directory}, subsequent requests succeed and +are served directly from the cache, which guarantees that clients get +the best possible bandwidth. + +The ``baking'' process is performed by worker threads. By default, one +thread per CPU core is created, but this can be customized. See +@option{--workers} below. + +@item --workers=@var{N} +When @option{--cache} is used, request the allocation of @var{N} worker +threads to ``bake'' archives. @item --ttl=@var{ttl} Produce @code{Cache-Control} HTTP headers that advertise a time-to-live diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index f54757b4c9..70d914d60c 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -24,6 +24,7 @@ (define-module (guix scripts publish) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 rdelim) + #:use-module (ice-9 threads) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) @@ -45,13 +46,15 @@ (define-module (guix scripts publish) #:use-module (guix hash) #:use-module (guix pki) #:use-module (guix pk-crypto) + #:use-module (guix workers) #:use-module (guix store) #:use-module ((guix serialization) #:select (write-file)) #:use-module (guix zlib) #:use-module (guix ui) #:use-module (guix scripts) - #:use-module ((guix utils) #:select (compressed-file?)) - #:use-module ((guix build utils) #:select (dump-port)) + #:use-module ((guix utils) + #:select (with-atomic-file-output compressed-file?)) + #:use-module ((guix build utils) #:select (dump-port mkdir-p)) #:export (%public-key %private-key @@ -69,6 +72,10 @@ (define (show-help) (display (_ " -C, --compression[=LEVEL] compress archives at LEVEL")) + (display (_ " + -c, --cache=DIRECTORY cache published items to DIRECTORY")) + (display (_ " + --workers=N use N workers to bake items")) (display (_ " --ttl=TTL announce narinfos can be cached for TTL seconds")) (display (_ " @@ -154,6 +161,13 @@ (define %options (warning (_ "zlib support is missing; \ compression disabled~%")) result)))))) + (option '(#\c "cache") #t #f + (lambda (opt name arg result) + (alist-cons 'cache arg result))) + (option '("workers") #t #f + (lambda (opt name arg result) + (alist-cons 'workers (string->number* arg) + result))) (option '("ttl") #t #f (lambda (opt name arg result) (let ((duration (string->duration arg))) @@ -190,6 +204,9 @@ (define %default-options %default-gzip-compression %no-compression)) + ;; Default number of workers when caching is enabled. + (workers . ,(current-processor-count)) + (address . ,(make-socket-address AF_INET INADDR_ANY 0)) (repl . #f))) @@ -308,6 +325,121 @@ (define* (render-narinfo store request hash #:compression compression) <>))))) +(define* (nar-cache-file directory item + #:key (compression %no-compression)) + (string-append directory "/" + (symbol->string (compression-type compression)) + "/" (basename item) ".nar")) + +(define* (narinfo-cache-file directory item + #:key (compression %no-compression)) + (string-append directory "/" + (symbol->string (compression-type compression)) + "/" (basename item) + ".narinfo")) + +(define run-single-baker + (let ((baking (make-weak-value-hash-table)) + (mutex (make-mutex))) + (lambda (item thunk) + "Run THUNK, which is supposed to bake ITEM, but make sure only one +thread is baking ITEM at a given time." + (define selected? + (with-mutex mutex + (and (not (hash-ref baking item)) + (begin + (hash-set! baking item (current-thread)) + #t)))) + + (when selected? + (dynamic-wind + (const #t) + thunk + (lambda () + (with-mutex mutex + (hash-remove! baking item)))))))) + +(define-syntax-rule (single-baker item exp ...) + "Bake ITEM by evaluating EXP, but make sure there's only one baker for ITEM +at a time." + (run-single-baker item (lambda () exp ...))) + + +(define* (render-narinfo/cached store request hash + #:key ttl (compression %no-compression) + (nar-path "nar") + 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 +requested using POOL." + (let* ((item (hash-part->path store hash)) + (compression (actual-compression item compression)) + (cached (and (not (string-null? item)) + (narinfo-cache-file cache item + #:compression compression)))) + (cond ((string-null? item) + (not-found request)) + ((file-exists? cached) + ;; Narinfo is in cache, send it. + (values `((content-type . (application/x-nix-narinfo)) + ,@(if ttl + `((cache-control (max-age . ,ttl))) + '())) + (lambda (port) + (display (call-with-input-file cached + read-string) + port)))) + ((valid-path? store item) + ;; Nothing in cache: bake the narinfo and nar in the background and + ;; return 404. + (eventually pool + (single-baker item + ;; (format #t "baking ~s~%" item) + (bake-narinfo+nar cache item + #:ttl ttl + #:compression compression + #:nar-path nar-path))) + (not-found request)) + (else + (not-found request))))) + +(define* (bake-narinfo+nar cache item + #:key ttl (compression %no-compression) + (nar-path "/nar")) + "Write the narinfo and nar for ITEM to CACHE." + (let* ((compression (actual-compression item compression)) + (nar (nar-cache-file cache item + #:compression compression)) + (narinfo (narinfo-cache-file cache item + #:compression compression))) + + (mkdir-p (dirname nar)) + (match (compression-type compression) + ('gzip + ;; Note: the file port gets closed along with the gzip port. + (call-with-gzip-output-port (open-output-file (string-append nar ".tmp")) + (lambda (port) + (write-file item port)) + #:level (compression-level compression)) + (rename-file (string-append nar ".tmp") nar)) + ('none + ;; When compression is disabled, we retrieve files directly from the + ;; store; no need to cache them. + #t)) + + (mkdir-p (dirname narinfo)) + (with-atomic-file-output narinfo + (lambda (port) + ;; Open a new connection to the store. We cannot reuse the main + ;; thread's connection to the store since we would end up sending + ;; stuff concurrently on the same channel. + (with-store store + (display (narinfo-string store item + (%private-key) + #:nar-path nar-path + #:compression compression) + port)))))) + ;; XXX: Declare the 'Guix-Compression' HTTP header, which is in fact for ;; internal consumption: it allows us to pass the compression info to ;; 'http-write', as part of the workaround to . @@ -339,6 +471,21 @@ (define* (render-nar store request store-item store-path) (not-found request)))) +(define* (render-nar/cached store cache request store-item + #:key (compression %no-compression)) + "Respond to REQUEST with a nar for STORE-ITEM. If the nar is in CACHE, +return it; otherwise, return 404." + (let ((cached (nar-cache-file cache store-item + #:compression compression))) + (if (file-exists? cached) + (values `((content-type . (application/octet-stream + (charset . "ISO-8859-1")))) + ;; XXX: We're not returning the actual contents, deferring + ;; instead to 'http-write'. This is a hack to work around + ;; . + cached) + (not-found request)))) + (define (render-content-addressed-file store request name algo hash) "Return the content of the result of the fixed-output derivation NAME that @@ -495,6 +642,7 @@ (define-server-impl concurrent-http-server (define* (make-request-handler store #:key + cache pool narinfo-ttl (nar-path "nar") (compression %no-compression)) @@ -515,10 +663,17 @@ (define nar-path? (((= extract-narinfo-hash (? string? hash))) ;; TODO: Register roots for HASH that will somehow remain for ;; NARINFO-TTL. - (render-narinfo store request hash - #:ttl narinfo-ttl - #:nar-path nar-path - #:compression compression)) + (if cache + (render-narinfo/cached store request hash + #:cache cache + #:pool pool + #:ttl narinfo-ttl + #:nar-path nar-path + #:compression compression) + (render-narinfo store request hash + #:ttl narinfo-ttl + #:nar-path nar-path + #:compression compression))) ;; /nar/file/NAME/sha256/HASH (("file" name "sha256" hash) (guard (c ((invalid-base32-character? c) @@ -534,13 +689,16 @@ (define nar-path? ;; /nar/gzip/ ((components ... "gzip" store-item) (if (and (nar-path? components) (zlib-available?)) - (render-nar store request store-item - #:compression - (match compression - (($ 'gzip) - compression) - (_ - %default-gzip-compression))) + (let ((compression (match compression + (($ 'gzip) + compression) + (_ + %default-gzip-compression)))) + (if cache + (render-nar/cached store cache request store-item + #:compression compression) + (render-nar store request store-item + #:compression compression))) (not-found request))) ;; /nar/ @@ -555,8 +713,11 @@ (define nar-path? (define* (run-publish-server socket store #:key (compression %no-compression) - (nar-path "nar") narinfo-ttl) + (nar-path "nar") narinfo-ttl + cache pool) (run-server (make-request-handler store + #:cache cache + #:pool pool #:nar-path nar-path #:narinfo-ttl narinfo-ttl #:compression compression) @@ -606,6 +767,8 @@ (define (guix-publish . args) (socket (open-server-socket address)) (nar-path (assoc-ref opts 'nar-path)) (repl-port (assoc-ref opts 'repl)) + (cache (assoc-ref opts 'cache)) + (workers (assoc-ref opts 'workers)) ;; Read the key right away so that (1) we fail early on if we can't ;; access them, and (2) we can then drop privileges. @@ -631,6 +794,12 @@ (define (guix-publish . args) (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port))) (with-store store (run-publish-server socket store + #:cache cache + #:pool (and cache (make-pool workers)) #:nar-path nar-path #:compression compression #:narinfo-ttl ttl)))))) + +;;; Local Variables: +;;; eval: (put 'single-baker 'scheme-indent-function 1) +;;; End: diff --git a/tests/publish.scm b/tests/publish.scm index ea0f4a3477..233b71ce93 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -314,4 +314,58 @@ (define (wait-until-ready port) (call-with-input-string "" port-sha256)))))) (response-code (http-get uri)))) +(unless (zlib-available?) + (test-skip 1)) +(test-equal "with cache" + (list #t + `(("StorePath" . ,%item) + ("URL" . ,(string-append "nar/gzip/" (basename %item))) + ("Compression" . "gzip")) + 200 ;nar/gzip/… + #t ;Content-Length + 200) ;nar/… + (call-with-temporary-directory + (lambda (cache) + (define (wait-for-file file) + (let loop ((i 20)) + (or (file-exists? file) + (begin + (pk 'wait-for-file file) + (sleep 1) + (loop (- i 1)))))) + + (let ((thread (with-separate-output-ports + (call-with-new-thread + (lambda () + (guix-publish "--port=6797" "-C2" + (string-append "--cache=" cache))))))) + (wait-until-ready 6797) + (let* ((base "http://localhost:6797/") + (part (store-path-hash-part %item)) + (url (string-append base part ".narinfo")) + (nar-url (string-append base "/nar/gzip/" (basename %item))) + (cached (string-append cache "/gzip/" (basename %item) + ".narinfo")) + (nar (string-append cache "/gzip/" + (basename %item) ".nar")) + (response (http-get url))) + (and (= 404 (response-code response)) + (wait-for-file cached) + (let ((body (http-get-port url)) + (compressed (http-get nar-url)) + (uncompressed (http-get (string-append base "nar/" + (basename %item))))) + (list (file-exists? nar) + (filter (lambda (item) + (match item + (("Compression" . _) #t) + (("StorePath" . _) #t) + (("URL" . _) #t) + (_ #f))) + (recutils->alist body)) + (response-code compressed) + (= (response-content-length compressed) + (stat:size (stat nar))) + (response-code uncompressed))))))))) + (test-end "publish") -- cgit v1.2.3 From 2ea2aac6e9d58a07c029504f94fb5015cd407e31 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 18 Apr 2017 22:07:49 +0200 Subject: Add (guix cache) and use it in (guix scripts substitute). * guix/cache.scm, tests/cache.scm: New files. * Makefile.am (MODULES, SCM_TESTS): Add them. * guix/scripts/substitute.scm (obsolete?): Remove. (remove-expired-cached-narinfos): Rename to... (cached-narinfo-expiration-time): ... this. Remove the removal part and only keep the expiration time part. (narinfo-cache-directories): Add optional 'directory' parameter and honor it. (maybe-remove-expired-cached-narinfo): Remove. (cached-narinfo-files): New procedure. (guix-substitute): Use 'maybe-remove-expired-cache-entries' instead of 'maybe-remove-expired-cached-narinfo'. --- Makefile.am | 2 + guix/cache.scm | 106 ++++++++++++++++++++++++++++++++++++++++++++ guix/scripts/substitute.scm | 97 +++++++++++++++------------------------- tests/cache.scm | 81 +++++++++++++++++++++++++++++++++ 4 files changed, 225 insertions(+), 61 deletions(-) create mode 100644 guix/cache.scm create mode 100644 tests/cache.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index 46f9547117..a997ed8b99 100644 --- a/Makefile.am +++ b/Makefile.am @@ -60,6 +60,7 @@ MODULES = \ guix/upstream.scm \ guix/licenses.scm \ guix/graph.scm \ + guix/cache.scm \ guix/cve.scm \ guix/workers.scm \ guix/zlib.scm \ @@ -296,6 +297,7 @@ SCM_TESTS = \ tests/size.scm \ tests/graph.scm \ tests/challenge.scm \ + tests/cache.scm \ tests/cve.scm \ tests/workers.scm \ tests/zlib.scm \ diff --git a/guix/cache.scm b/guix/cache.scm new file mode 100644 index 0000000000..077b0780bd --- /dev/null +++ b/guix/cache.scm @@ -0,0 +1,106 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix cache) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:export (obsolete? + delete-file* + file-expiration-time + remove-expired-cache-entries + maybe-remove-expired-cache-entries)) + +;;; Commentary: +;;; +;;; This module provides tools to manage a simple on-disk cache consisting of +;;; individual files. +;;; +;;; Code: + +(define (obsolete? date now ttl) + "Return #t if DATE is obsolete compared to NOW + TTL seconds." + (time>? (subtract-duration now (make-time time-duration 0 ttl)) + (make-time time-monotonic 0 date))) + +(define (delete-file* file) + "Like 'delete-file', but does not raise an error when FILE does not exist." + (catch 'system-error + (lambda () + (delete-file file)) + (lambda args + (unless (= ENOENT (system-error-errno args)) + (apply throw args))))) + +(define (file-expiration-time ttl) + "Return a procedure that, when passed a file, returns its \"expiration +time\" computed as its last-access time + TTL seconds." + (lambda (file) + (match (stat file #f) + (#f 0) ;FILE may have been deleted in the meantime + (st (+ (stat:atime st) ttl))))) + +(define* (remove-expired-cache-entries entries + #:key + (now (current-time time-monotonic)) + (entry-expiration + (file-expiration-time 3600)) + (delete-entry delete-file*)) + "Given ENTRIES, a list of file names, remove those whose expiration time, +as returned by ENTRY-EXPIRATION, has passed. Use DELETE-ENTRY to delete +them." + (for-each (lambda (entry) + (when (<= (entry-expiration entry) (time-second now)) + (delete-entry entry))) + entries)) + +(define* (maybe-remove-expired-cache-entries cache + cache-entries + #:key + (entry-expiration + (file-expiration-time 3600)) + (delete-entry delete-file*) + (cleanup-period (* 24 3600))) + "Remove expired narinfo entries from the cache if deemed necessary. Call +CACHE-ENTRIES with CACHE to retrieve the list of cache entries. + +ENTRY-EXPIRATION must be a procedure that, when passed an entry, returns the +expiration time of that entry in seconds since the Epoch. DELETE-ENTRY is a +procedure that removes the entry passed as an argument. Finally, +CLEANUP-PERIOD denotes the minimum time between two cache cleanups." + (define now + (current-time time-monotonic)) + + (define expiry-file + (string-append cache "/last-expiry-cleanup")) + + (define last-expiry-date + (catch 'system-error + (lambda () + (call-with-input-file expiry-file read)) + (const 0))) + + (when (obsolete? last-expiry-date now cleanup-period) + (remove-expired-cache-entries (cache-entries cache) + #:now now + #:entry-expiration entry-expiration + #:delete-entry delete-entry) + (call-with-output-file expiry-file + (cute write (time-second now) <>)))) + +;;; cache.scm ends here diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index d3bccf4ddb..748c334e3c 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -28,6 +28,7 @@ (define-module (guix scripts substitute) #:use-module (guix hash) #:use-module (guix base32) #:use-module (guix base64) + #:use-module (guix cache) #:use-module (guix pk-crypto) #:use-module (guix pki) #:use-module ((guix build utils) #:select (mkdir-p dump-port)) @@ -440,12 +441,6 @@ (define (string->narinfo str cache-uri) the cache STR originates form." (call-with-input-string str (cut read-narinfo <> cache-uri))) -(define (obsolete? date now ttl) - "Return #t if DATE is obsolete compared to NOW + TTL seconds." - (time>? (subtract-duration now (make-time time-duration 0 ttl)) - (make-time time-monotonic 0 date))) - - (define (narinfo-cache-file cache-url path) "Return the name of the local file that contains an entry for PATH. The entry is stored in a sub-directory specific to CACHE-URL." @@ -718,43 +713,28 @@ (define (lookup-narinfo caches path) ((answer) answer) (_ #f))) -(define (remove-expired-cached-narinfos directory) - "Remove expired narinfo entries from DIRECTORY. The sole purpose of this -function is to make sure `%narinfo-cache-directory' doesn't grow -indefinitely." - (define now - (current-time time-monotonic)) +(define (cached-narinfo-expiration-time file) + "Return the expiration time for FILE, which is a cached narinfo." + (catch 'system-error + (lambda () + (call-with-input-file file + (lambda (port) + (match (read port) + (('narinfo ('version 2) ('cache-uri uri) + ('date date) ('ttl ttl) ('value #f)) + (+ date %narinfo-negative-ttl)) + (('narinfo ('version 2) ('cache-uri uri) + ('date date) ('ttl ttl) ('value value)) + (+ date ttl)) + (x + 0))))) + (lambda args + ;; FILE may have been deleted. + 0))) - (define (expired? file) - (catch 'system-error - (lambda () - (call-with-input-file file - (lambda (port) - (match (read port) - (('narinfo ('version 2) ('cache-uri _) - ('date date) ('ttl _) ('value #f)) - (obsolete? date now %narinfo-negative-ttl)) - (('narinfo ('version 2) ('cache-uri _) - ('date date) ('ttl ttl) ('value _)) - (obsolete? date now ttl)) - (_ #t))))) - (lambda args - ;; FILE may have been deleted. - #t))) - - (for-each (lambda (file) - (let ((file (string-append directory "/" file))) - (when (expired? file) - ;; Wrap in `false-if-exception' because FILE might have been - ;; deleted in the meantime (TOCTTOU). - (false-if-exception (delete-file file))))) - (scandir directory - (lambda (file) - (= (string-length file) 32))))) - -(define (narinfo-cache-directories) +(define (narinfo-cache-directories directory) "Return the list of narinfo cache directories (one per cache URL.)" - (map (cut string-append %narinfo-cache-directory "/" <>) + (map (cut string-append directory "/" <>) (scandir %narinfo-cache-directory (lambda (item) (and (not (member item '("." ".."))) @@ -762,25 +742,15 @@ (define (narinfo-cache-directories) (string-append %narinfo-cache-directory "/" item))))))) -(define (maybe-remove-expired-cached-narinfo) - "Remove expired narinfo entries from the cache if deemed necessary." - (define now - (current-time time-monotonic)) - - (define expiry-file - (string-append %narinfo-cache-directory "/last-expiry-cleanup")) - - (define last-expiry-date - (or (false-if-exception - (call-with-input-file expiry-file read)) - 0)) - - (when (obsolete? last-expiry-date now - %narinfo-expired-cache-entry-removal-delay) - (for-each remove-expired-cached-narinfos - (narinfo-cache-directories)) - (call-with-output-file expiry-file - (cute write (time-second now) <>)))) +(define* (cached-narinfo-files #:optional + (directory %narinfo-cache-directory)) + "Return the list of cached narinfo files under DIRECTORY." + (append-map (lambda (directory) + (map (cut string-append directory "/" <>) + (scandir directory + (lambda (file) + (= (string-length file) 32))))) + (narinfo-cache-directories directory))) (define (progress-report-port report-progress port) "Return a port that calls REPORT-PROGRESS every time something is read from @@ -1013,7 +983,12 @@ (define (client-terminal-columns) (define (guix-substitute . args) "Implement the build daemon's substituter protocol." (mkdir-p %narinfo-cache-directory) - (maybe-remove-expired-cached-narinfo) + (maybe-remove-expired-cache-entries %narinfo-cache-directory + cached-narinfo-files + #:entry-expiration + cached-narinfo-expiration-time + #:cleanup-period + %narinfo-expired-cache-entry-removal-delay) (check-acl-initialized) ;; Starting from commit 22144afa in Nix, we are allowed to bail out directly diff --git a/tests/cache.scm b/tests/cache.scm new file mode 100644 index 0000000000..0e1e08b693 --- /dev/null +++ b/tests/cache.scm @@ -0,0 +1,81 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ludovic Courtès +;;; +;;; 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 . + +(define-module (test-cache) + #:use-module (guix cache) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-64) + #:use-module ((guix utils) #:select (call-with-temporary-directory)) + #:use-module (ice-9 match)) + +(test-begin "cache") + +(test-equal "remove-expired-cache-entries" + '("o" "l" "d") + (let* ((removed '()) + (now (time-second (current-time time-monotonic))) + (ttl 100) + (stamp (match-lambda + ((or "n" "e" "w") (+ now 100)) + ((or "o" "l" "d") (- now 100)))) + (delete (lambda (entry) + (set! removed (cons entry removed))))) + (remove-expired-cache-entries (reverse '("n" "e" "w" + "o" "l" "d")) + #:entry-expiration stamp + #:delete-entry delete) + removed)) + +(define-syntax-rule (test-cache-cleanup cache exp ...) + (call-with-temporary-directory + (lambda (cache) + (let* ((deleted '()) + (delete! (lambda (entry) + (set! deleted (cons entry deleted))))) + exp ... + (maybe-remove-expired-cache-entries cache + (const '("a" "b" "c")) + #:entry-expiration (const 0) + #:delete-entry delete!) + (reverse deleted))))) + +(test-equal "maybe-remove-expired-cache-entries, first cleanup" + '("a" "b" "c") + (test-cache-cleanup cache)) + +(test-equal "maybe-remove-expired-cache-entries, no cleanup needed" + '() + (test-cache-cleanup cache + (call-with-output-file (string-append cache "/last-expiry-cleanup") + (lambda (port) + (display (+ (time-second (current-time time-monotonic)) 100) + port))))) + +(test-equal "maybe-remove-expired-cache-entries, cleanup needed" + '("a" "b" "c") + (test-cache-cleanup cache + (call-with-output-file (string-append cache "/last-expiry-cleanup") + (lambda (port) + (display 0 port))))) + +(test-end "cache") + +;;; Local Variables: +;;; eval: (put 'test-cache-cleanup 'scheme-indent-function 1) +;;; End: -- cgit v1.2.3 From 2363bdd707ba382d89c96e03c04038c047d7228c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 19 Apr 2017 16:11:25 +0200 Subject: gexp: 'gexp-modules' accepts plain Scheme objects. * guix/gexp.scm (gexp-modules): Return '() when not (gexp? GEXP). * tests/gexp.scm ("gexp-modules and literal Scheme object"): New test. --- guix/gexp.scm | 33 ++++++++++++++++++--------------- tests/gexp.scm | 4 ++++ 2 files changed, 22 insertions(+), 15 deletions(-) (limited to 'tests') diff --git a/guix/gexp.scm b/guix/gexp.scm index 80d8f735b3..d9c4cb461e 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -459,21 +459,24 @@ (define (write-gexp-output output port) (set-record-type-printer! write-gexp-output) (define (gexp-modules gexp) - "Return the list of Guile module names GEXP relies on." - (delete-duplicates - (append (gexp-self-modules gexp) - (append-map (match-lambda - (($ (? gexp? exp)) - (gexp-modules exp)) - (($ (lst ...)) - (append-map (lambda (item) - (if (gexp? item) - (gexp-modules item) - '())) - lst)) - (_ - '())) - (gexp-references gexp))))) + "Return the list of Guile module names GEXP relies on. If (gexp? GEXP) is +false, meaning that GEXP is a plain Scheme object, return the empty list." + (if (gexp? gexp) + (delete-duplicates + (append (gexp-self-modules gexp) + (append-map (match-lambda + (($ (? gexp? exp)) + (gexp-modules exp)) + (($ (lst ...)) + (append-map (lambda (item) + (if (gexp? item) + (gexp-modules item) + '())) + lst)) + (_ + '())) + (gexp-references gexp)))) + '())) ;plain Scheme data type (define* (lower-inputs inputs #:key system target) diff --git a/tests/gexp.scm b/tests/gexp.scm index 41a53ae5a4..cf88a9db80 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -627,6 +627,10 @@ (define (match-input thing) #~(foo #$@(list (with-imported-modules '((foo)) #~+) (with-imported-modules '((bar)) #~-))))) +(test-equal "gexp-modules and literal Scheme object" + '() + (gexp-modules #t)) + (test-assertm "gexp->derivation #:modules" (mlet* %store-monad ((build -> #~(begin -- cgit v1.2.3 From 1397b422e254929de1805aaf1d0759cd5da6a60b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Apr 2017 11:39:49 +0200 Subject: store: 'GUIX_DAEMON_SOCKET' can now be a URI. * guix/store.scm (%daemon-socket-file): Rename to... (%daemon-socket-uri): ... this. (connect-to-daemon): New procedure. (open-connection): Rename 'file' to 'uri'. Use 'connect-to-daemon' instead of 'open-unix-domain-socket'. * guix/tests.scm (open-connection-for-tests): Rename 'file' to 'uri'. * tests/guix-build.sh: Add tests. * tests/store.scm ("open-connection with file:// URI"): New tests. --- doc/guix.texi | 26 +++++++++++++++++++++++--- guix/store.scm | 36 ++++++++++++++++++++++++++++-------- guix/tests.scm | 6 +++--- tests/guix-build.sh | 8 ++++++++ tests/store.scm | 8 ++++++++ 5 files changed, 70 insertions(+), 14 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 753c3998e5..5f973e2fe1 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3666,10 +3666,30 @@ accidental modifications. @end quotation The @code{(guix store)} module provides procedures to connect to the -daemon, and to perform RPCs. These are described below. +daemon, and to perform RPCs. These are described below. By default, +@code{open-connection}, and thus all the @command{guix} commands, +connect to the local daemon or to the URI specified by the +@code{GUIX_DAEMON_SOCKET} environment variable. -@deffn {Scheme Procedure} open-connection [@var{file}] [#:reserve-space? #t] -Connect to the daemon over the Unix-domain socket at @var{file}. When +@defvr {Environment Variable} GUIX_DAEMON_SOCKET +When set, the value of this variable should be a file name or a URI +designating the daemon endpoint. When it is a file name, it denotes a +Unix-domain socket to connect to. In addition to file names, the +supported URI schemes are: + +@table @code +@item file +@itemx unix +These are for Unix-domain sockets. +@code{file:///var/guix/daemon-socket/socket} is equivalent to +@file{/var/guix/daemon-socket/socket}. +@end table + +Additional URI schemes may be supported in the future. +@end defvr + +@deffn {Scheme Procedure} open-connection [@var{uri}] [#:reserve-space? #t] +Connect to the daemon over the Unix-domain socket at @var{uri} (a string). When @var{reserve-space?} is true, instruct it to reserve a little bit of extra space on the file system so that the garbage collector can still operate should the disk become full. Return a server object. diff --git a/guix/store.scm b/guix/store.scm index 2f05351767..bd07976c37 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -39,7 +39,8 @@ (define-module (guix store) #:use-module (ice-9 regex) #:use-module (ice-9 vlist) #:use-module (ice-9 popen) - #:export (%daemon-socket-file + #:use-module (web uri) + #:export (%daemon-socket-uri %gc-roots-directory %default-substitute-urls @@ -216,8 +217,8 @@ (define-enumerate-type gc-action (define %default-socket-path (string-append %state-directory "/daemon-socket/socket")) -(define %daemon-socket-file - ;; File name of the socket the daemon listens too. +(define %daemon-socket-uri + ;; URI or file name of the socket the daemon listens too. (make-parameter (or (getenv "GUIX_DAEMON_SOCKET") %default-socket-path))) @@ -369,10 +370,29 @@ (define (open-unix-domain-socket file) (file file) (errno errno))))))))) -(define* (open-connection #:optional (file (%daemon-socket-file)) +(define (connect-to-daemon uri) + "Connect to the daemon at URI, a string that may be an actual URI or a file +name." + (define connect + (match (string->uri uri) + (#f ;URI is a file name + open-unix-domain-socket) + ((? uri? uri) + (match (uri-scheme uri) + ((or #f 'file 'unix) + (lambda (_) + (open-unix-domain-socket (uri-path uri)))) + (x + (raise (condition (&nix-connection-error + (file (uri->string uri)) + (errno ENOTSUP))))))))) + + (connect uri)) + +(define* (open-connection #:optional (uri (%daemon-socket-uri)) #:key port (reserve-space? #t) cpu-affinity) - "Connect to the daemon over the Unix-domain socket at FILE, or, if PORT is -not #f, use it as the I/O port over which to communicate to a build daemon. + "Connect to the daemon at URI (a string), or, if PORT is not #f, use it as +the I/O port over which to communicate to a build daemon. When RESERVE-SPACE? is true, instruct it to reserve a little bit of extra space on the file system so that the garbage collector can still operate, @@ -383,10 +403,10 @@ (define* (open-connection #:optional (file (%daemon-socket-file)) ;; One of the 'write-' or 'read-' calls below failed, but this is ;; really a connection error. (raise (condition - (&nix-connection-error (file (or port file)) + (&nix-connection-error (file (or port uri)) (errno EPROTO)) (&message (message "build daemon handshake failed")))))) - (let ((port (or port (open-unix-domain-socket file)))) + (let ((port (or port (connect-to-daemon uri)))) (write-int %worker-magic-1 port) (let ((r (read-int port))) (and (eqv? r %worker-magic-2) diff --git a/guix/tests.scm b/guix/tests.scm index 5110075e7d..34e3e0fc2a 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 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -56,13 +56,13 @@ (define %test-substitute-urls (or (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL") list) '()))) -(define* (open-connection-for-tests #:optional (file (%daemon-socket-file))) +(define* (open-connection-for-tests #:optional (uri (%daemon-socket-uri))) "Open a connection to the build daemon for tests purposes and return it." (guard (c ((nix-error? c) (format (current-error-port) "warning: build daemon error: ~s~%" c) #f)) - (let ((store (open-connection file))) + (let ((store (open-connection uri))) ;; Make sure we build everything by ourselves. (set-build-options store #:use-substitutes? #f diff --git a/tests/guix-build.sh b/tests/guix-build.sh index ab911b7210..9494e7371f 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -36,6 +36,14 @@ guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)' | \ guix build hello -d | \ grep -e '-hello-[0-9\.]\+\.drv$' +# Passing a URI. +GUIX_DAEMON_SOCKET="file://$NIX_STATE_DIR/daemon-socket/socket" \ +guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)' + +( if GUIX_DAEMON_SOCKET="weird://uri" \ + guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'; \ + then exit 1; fi ) + # Check --sources option with its arguments module_dir="t-guix-build-$$" mkdir "$module_dir" diff --git a/tests/store.scm b/tests/store.scm index 45150d36ca..3eb8b7be5a 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -48,6 +48,14 @@ (define %store (test-begin "store") +(test-assert "open-connection with file:// URI" + (let ((store (open-connection (string-append "file://" + (%daemon-socket-uri))))) + (and (add-text-to-store store "foo" "bar") + (begin + (close-connection store) + #t)))) + (test-equal "connection handshake error" EPROTO (let ((port (%make-void-port "rw"))) -- cgit v1.2.3 From 9231ef12f2a595b8f1e677dbe50cc499555302b6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Apr 2017 22:43:28 +0200 Subject: derivations: Restore UTF-8 encoding of build scripts. Reported by Mark H Weaver at . * guix/derivations.scm (build-expression->derivation): Use a string output port for the expression. This reverts part of 2dce88d5bbe7a65e101c0734d1c6db44ecc8c299. * tests/derivations.scm ("build-expression->derivation and builder encoding"): New test. --- guix/derivations.scm | 10 ++++------ tests/derivations.scm | 13 +++++++++++++ 2 files changed, 17 insertions(+), 6 deletions(-) (limited to 'tests') diff --git a/guix/derivations.scm b/guix/derivations.scm index 410c41083e..d5e0f453e2 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -1238,16 +1238,15 @@ (define %build-inputs ;; Guile sets it, but remove it to avoid conflicts when ;; building Guile-using packages. (unsetenv "LD_LIBRARY_PATH"))) - (builder (add-data-to-store store + (builder (add-text-to-store store (string-append name "-guile-builder") ;; Explicitly use UTF-8 for determinism, ;; and also because UTF-8 output is faster. (with-fluids ((%default-port-encoding "UTF-8")) - (call-with-values - open-bytevector-output-port - (lambda (port get-bv) + (call-with-output-string + (lambda (port) (write prologue port) (write `(exit @@ -1255,8 +1254,7 @@ (define %build-inputs ((_ ...) (remove module-form? exp)) (_ `(,exp)))) - port) - (get-bv)))) + port)))) ;; The references don't really matter ;; since the builder is always used in diff --git a/tests/derivations.scm b/tests/derivations.scm index 75c8d1dfb1..626e4d20e2 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -701,6 +701,19 @@ (define %coreutils #:modules '((guix module that does not exist))))) +(test-equal "build-expression->derivation and builder encoding" + '("UTF-8" #t) + (let* ((exp '(λ (α) (+ α 1))) + (drv (build-expression->derivation %store "foo" exp))) + (match (derivation-builder-arguments drv) + ((... builder) + (call-with-input-file builder + (lambda (port) + (list (port-encoding port) + (->bool + (string-contains (get-string-all port) + "(λ (α) (+ α 1))"))))))))) + (test-assert "build-expression->derivation and derivation-prerequisites" (let ((drv (build-expression->derivation %store "fail" #f))) (any (match-lambda -- cgit v1.2.3 From 904c6c42eb8c3805edd293666eeb4b3837e2b7a6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Apr 2017 22:53:59 +0200 Subject: tests: Adjust to the addition of a new Coreutils version. * tests/scripts-build.scm ("options->transformation, with-input"): Use 'specification->package' rather than refer to Coreutils by its variable. This is a followup to e162050dfc0dee708a7ac5bfcf37d2afd6081604. --- tests/scripts-build.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/tests/scripts-build.scm b/tests/scripts-build.scm index a1f684c736..a408ea6f8d 100644 --- a/tests/scripts-build.scm +++ b/tests/scripts-build.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Ludovic Courtès +;;; Copyright © 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,6 +23,7 @@ (define-module (test-scripts-build) #:use-module (guix scripts build) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (gnu packages) #:use-module (gnu packages base) #:use-module (gnu packages busybox) #:use-module (ice-9 match) @@ -97,8 +98,8 @@ (define-module (test-scripts-build) (test-assert "options->transformation, with-input" (let* ((p (dummy-package "guix.scm" - (inputs `(("foo" ,coreutils) - ("bar" ,grep) + (inputs `(("foo" ,(specification->package "coreutils")) + ("bar" ,(specification->package "grep")) ("baz" ,(dummy-package "chbouib" (native-inputs `(("x" ,grep))))))))) (t (options->transformation '((with-input . "coreutils=busybox") -- cgit v1.2.3 From 8a8e2d2ed5932a13a73583d32b152133d28aedf5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 22 Apr 2017 14:05:38 +0200 Subject: derivations: Adjust builder encoding test. This is a followup to 9231ef12f2a595b8f1e677dbe50cc499555302b6. * tests/derivations.scm ("build-expression->derivation and builder encoding"): Set '%default-port-encoding' to "UTF-8". --- tests/derivations.scm | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) (limited to 'tests') diff --git a/tests/derivations.scm b/tests/derivations.scm index 626e4d20e2..cabbf7b951 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -707,12 +707,13 @@ (define %coreutils (drv (build-expression->derivation %store "foo" exp))) (match (derivation-builder-arguments drv) ((... builder) - (call-with-input-file builder - (lambda (port) - (list (port-encoding port) - (->bool - (string-contains (get-string-all port) - "(λ (α) (+ α 1))"))))))))) + (with-fluids ((%default-port-encoding "UTF-8")) + (call-with-input-file builder + (lambda (port) + (list (port-encoding port) + (->bool + (string-contains (get-string-all port) + "(λ (α) (+ α 1))")))))))))) (test-assert "build-expression->derivation and derivation-prerequisites" (let ((drv (build-expression->derivation %store "fail" #f))) -- cgit v1.2.3 From 25a49294caf2386e65fc1b12a2508324be0b1cc2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 22 Apr 2017 14:40:51 +0200 Subject: cache: Work around 'time-monotonic' bug in Guile 2.2.2. * guix/cache.scm (time-monotonic) [guile-2.2]: New variable. * tests/cache.scm (time-monotonic) [guile-2.2]: Likewise. * guix/build/download.scm (time-monotonic) [guile-2.2]: Adjust comment: it's a 2.2.2 bug. --- guix/build/download.scm | 5 ++--- guix/cache.scm | 7 +++++++ tests/cache.scm | 7 +++++++ 3 files changed, 16 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/guix/build/download.scm b/guix/build/download.scm index 6563341b9f..67a8952599 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -142,9 +142,8 @@ (define* (store-path-abbreviation store-path #:optional (prefix-length 6)) (cond-expand (guile-2.2 - ;; Guile 2.2.0 to 2.2.2 included has a bug whereby 'time-monotonic' objects - ;; have seconds and nanoseconds swapped (fixed in Guile commit 886ac3e). - ;; Work around it. + ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and + ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. (define time-monotonic time-tai)) (else #t)) diff --git a/guix/cache.scm b/guix/cache.scm index 077b0780bd..1dc0083f1d 100644 --- a/guix/cache.scm +++ b/guix/cache.scm @@ -33,6 +33,13 @@ (define-module (guix cache) ;;; ;;; Code: +(cond-expand + (guile-2.2 + ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and + ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. + (define time-monotonic time-tai)) + (else #t)) + (define (obsolete? date now ttl) "Return #t if DATE is obsolete compared to NOW + TTL seconds." (time>? (subtract-duration now (make-time time-duration 0 ttl)) diff --git a/tests/cache.scm b/tests/cache.scm index 0e1e08b693..e46cdd816d 100644 --- a/tests/cache.scm +++ b/tests/cache.scm @@ -24,6 +24,13 @@ (define-module (test-cache) #:use-module ((guix utils) #:select (call-with-temporary-directory)) #:use-module (ice-9 match)) +(cond-expand + (guile-2.2 + ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and + ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. + (define time-monotonic time-tai)) + (else #t)) + (test-begin "cache") (test-equal "remove-expired-cache-entries" -- cgit v1.2.3