futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add (guix cache) and use it in (guix scripts substitute).

Browse Source 
* 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'.
This commit is contained in:
Ludovic Courtès 2017-04-18 22:07:49 +02:00
parent 00753f7038
commit 2ea2aac6e9
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
4 changed files with 225 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile.am
View File

@ -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 \

106
guix/cache.scm Normal file
View File

@ -0,0 +1,106 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017 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 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

97
guix/scripts/substitute.scm
View File

@ -28,6 +28,7 @@
#: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 @@ or is signed by an unauthorized key."
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 @@ was found."
((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 @@ indefinitely."
(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 @@ default value."
(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

81
tests/cache.scm Normal file
View File

@ -0,0 +1,81 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 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 (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: