base: Register GC roots for build results.
Fixes <https://bugs.gnu.org/33124>. * src/cuirass/base.scm (%gc-root-directory, %gc-root-ttl): New variables. (gc-root-expiration-time, register-gc-root): New procedures. (handle-build-event)[gc-roots]: New procedure. Upon 'build-succeeded' events, call 'register-gc-root' and 'maybe-remove-expired-cache-entries'. * bin/cuirass.in (show-help, %options): Add '--ttl'. (main): Parameterize %GC-ROOT-TTL. Create %GC-ROOT-DIRECTORY. * doc/cuirass.texi (Invocation): Document '--ttl'.
This commit is contained in:
parent
c5487cafab
commit
d4623d50ed
|
@ -31,8 +31,10 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
|
|||
(cuirass logging)
|
||||
(cuirass utils)
|
||||
(guix ui)
|
||||
((guix build utils) #:select (mkdir-p))
|
||||
(fibers)
|
||||
(fibers channels)
|
||||
(srfi srfi-19)
|
||||
(ice-9 threads) ;for 'current-processor-count'
|
||||
(ice-9 getopt-long))
|
||||
|
||||
|
@ -46,6 +48,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
|
|||
-S --specifications=SPECFILE
|
||||
Add specifications from SPECFILE to database.
|
||||
-D --database=DB Use DB to store build results.
|
||||
--ttl=DURATION Keep build results live for at least DURATION.
|
||||
-p --port=NUM Port of the HTTP server.
|
||||
--listen=HOST Listen on the network interface for HOST
|
||||
-I, --interval=N Wait N seconds between each poll
|
||||
|
@ -67,6 +70,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
|
|||
(use-substitutes (value #f))
|
||||
(threads (value #t))
|
||||
(fallback (value #f))
|
||||
(ttl (value #t))
|
||||
(version (single-char #\V) (value #f))
|
||||
(help (single-char #\h) (value #f))))
|
||||
|
||||
|
@ -88,7 +92,9 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
|
|||
(%package-cachedir
|
||||
(option-ref opts 'cache-directory (%package-cachedir)))
|
||||
(%use-substitutes? (option-ref opts 'use-substitutes #f))
|
||||
(%fallback? (option-ref opts 'fallback #f)))
|
||||
(%fallback? (option-ref opts 'fallback #f))
|
||||
(%gc-root-ttl
|
||||
(time-second (string->duration (option-ref opts 'ttl "30d")))))
|
||||
(cond
|
||||
((option-ref opts 'help #f)
|
||||
(show-help)
|
||||
|
@ -97,6 +103,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
|
|||
(show-version)
|
||||
(exit 0))
|
||||
(else
|
||||
(mkdir-p (%gc-root-directory))
|
||||
(let ((one-shot? (option-ref opts 'one-shot #f))
|
||||
(port (string->number (option-ref opts 'port "8080")))
|
||||
(host (option-ref opts 'listen "localhost"))
|
||||
|
|
|
@ -203,6 +203,17 @@ build results. Since @code{cuirass} uses SQLite as a database engine,
|
|||
@var{database} must be a file name. If the file doesn't exist, it will
|
||||
be created.
|
||||
|
||||
@item --ttl=@var{duration}
|
||||
Cuirass registers build results as garbage collector (GC) roots, thereby
|
||||
preventing them from being deleted by the GC. The @option{--ttl} option
|
||||
instructs it to keep those GC roots live for at least @var{duration}---e.g.,
|
||||
@code{1m} for one month, @code{2w} for two weeks, and so on. The default is
|
||||
30 days.
|
||||
|
||||
Those GC roots are typically stored in
|
||||
@file{/var/guix/gcroots/per-user/@var{user}/cuirass}, where @var{user} is the
|
||||
user under which Cuirass is running.
|
||||
|
||||
@item --port=@var{num}
|
||||
@itemx -p @var{num}
|
||||
Make the HTTP interface listen on port @var{num}. Use port 8080 by
|
||||
|
|
|
@ -30,6 +30,8 @@
|
|||
#:use-module (guix derivations)
|
||||
#:use-module (guix store)
|
||||
#:use-module (guix git)
|
||||
#:use-module (guix cache)
|
||||
#:use-module ((guix config) #:select (%state-directory))
|
||||
#:use-module (git)
|
||||
#:use-module (ice-9 binary-ports)
|
||||
#:use-module (ice-9 format)
|
||||
|
@ -61,6 +63,8 @@
|
|||
process-specs
|
||||
;; Parameters.
|
||||
%package-cachedir
|
||||
%gc-root-directory
|
||||
%gc-root-ttl
|
||||
%use-substitutes?
|
||||
%fallback?))
|
||||
|
||||
|
@ -112,6 +116,37 @@
|
|||
(scm-error 'wrong-type-arg
|
||||
"%package-cachedir" "Not a string: ~S" (list #f) #f)))))
|
||||
|
||||
(define %gc-root-directory
|
||||
;; Directory where garbage collector roots are stored. We register build
|
||||
;; outputs there.
|
||||
(make-parameter (string-append %state-directory
|
||||
"/gcroots/profiles/per-user/"
|
||||
(passwd:name (getpwuid (getuid)))
|
||||
"/cuirass")))
|
||||
|
||||
(define %gc-root-ttl
|
||||
;; The "time to live" (TTL) of GC roots.
|
||||
(make-parameter (* 30 24 3600)))
|
||||
|
||||
(define (gc-root-expiration-time file)
|
||||
"Return \"expiration time\" of FILE (a symlink in %GC-ROOT-DIRECTORY)
|
||||
computed as its modification time + TTL seconds."
|
||||
(match (false-if-exception (lstat file))
|
||||
(#f 0) ;FILE may have been deleted in the meantime
|
||||
(st (+ (stat:mtime st) (%gc-root-ttl)))))
|
||||
|
||||
(define (register-gc-root item)
|
||||
"Create a GC root pointing to ITEM, a store item."
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(symlink item
|
||||
(string-append (%gc-root-directory)
|
||||
"/" (basename item))))
|
||||
(lambda args
|
||||
;; If the symlink already exist, assume it points to ITEM.
|
||||
(unless (= EEXIST (system-error-errno args))
|
||||
(apply throw args)))))
|
||||
|
||||
(define (call-with-time thunk kont)
|
||||
"Call THUNK and pass KONT the elapsed time followed by THUNK's return
|
||||
values."
|
||||
|
@ -473,6 +508,13 @@ updating the database accordingly."
|
|||
(and (store-path? file)
|
||||
(string-suffix? ".drv" file)))
|
||||
|
||||
(define (gc-roots directory)
|
||||
;; Return the list of GC roots (symlinks) in DIRECTORY.
|
||||
(map (cut string-append directory "/" <>)
|
||||
(scandir directory
|
||||
(lambda (file)
|
||||
(not (member file '("." "..")))))))
|
||||
|
||||
(match event
|
||||
(('build-started drv _ ...)
|
||||
(if (valid? drv)
|
||||
|
@ -486,7 +528,16 @@ updating the database accordingly."
|
|||
(if (valid? drv)
|
||||
(begin
|
||||
(log-message "build succeeded: '~a'" drv)
|
||||
(db-update-build-status! drv (build-status succeeded)))
|
||||
(db-update-build-status! drv (build-status succeeded))
|
||||
|
||||
(for-each (match-lambda
|
||||
((name . output)
|
||||
(register-gc-root output)))
|
||||
(derivation-path->output-paths drv))
|
||||
(maybe-remove-expired-cache-entries (%gc-root-directory)
|
||||
gc-roots
|
||||
#:entry-expiration
|
||||
gc-root-expiration-time))
|
||||
(log-message "bogus build-succeeded event for '~a'" drv)))
|
||||
(('build-failed drv _ ...)
|
||||
(if (valid? drv)
|
||||
|
|
Loading…
Reference in New Issue