From d4623d50edac4a6e81f5986a91c2818f5fc4965d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 7 Nov 2018 11:47:39 +0100 Subject: base: Register GC roots for build results. Fixes . * 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'. --- bin/cuirass.in | 9 ++++++++- doc/cuirass.texi | 11 +++++++++++ src/cuirass/base.scm | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 71 insertions(+), 2 deletions(-) diff --git a/bin/cuirass.in b/bin/cuirass.in index a7af5b2..b09ca27 100644 --- a/bin/cuirass.in +++ b/bin/cuirass.in @@ -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")) diff --git a/doc/cuirass.texi b/doc/cuirass.texi index 08ca832..ebb1fa5 100644 --- a/doc/cuirass.texi +++ b/doc/cuirass.texi @@ -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 diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm index 35e748d..fe0ec6c 100644 --- a/src/cuirass/base.scm +++ b/src/cuirass/base.scm @@ -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) -- cgit v1.2.3