[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
|
From: |
Ludovic Courtès |
|
Date: |
Wed, 13 Sep 2023 13:05:39 -0400 (EDT) |
branch: wip-actors
commit b0f93551bc15bb589c247380f5e91221113e036e
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Sep 13 16:15:14 2023 +0200
Move store and GC helpers from (cuirass base) to (cuirass store).
* src/cuirass/base.scm (default-gc-root-directory, %gc-root-directory)
(%gc-root-ttl, gc-roots, gc-root-expiration-time)
(register-gc-root, register-gc-roots)
(non-blocking-port, ensure-non-blocking-store-connection)
(with-store/non-blocking, process-build-log, build-derivations&): Move
to…
* src/cuirass/store.scm: … here. New file.
* src/cuirass/scripts/remote-server.scm: Adjust accordingly.
* src/cuirass/scripts/remote-worker.scm: Likewise.
* src/cuirass/scripts/register.scm: Likewise.
* Makefile.am (dist_pkgmodule_DATA): Add ‘src/cuirass/store.scm’.
---
Makefile.am | 1 +
src/cuirass/base.scm | 164 +---------------------------
src/cuirass/scripts/register.scm | 3 +-
src/cuirass/scripts/remote-server.scm | 3 +-
src/cuirass/scripts/remote-worker.scm | 5 +-
src/cuirass/store.scm | 199 ++++++++++++++++++++++++++++++++++
6 files changed, 210 insertions(+), 165 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index d8ed3f7..8a6f87a 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -48,6 +48,7 @@ jsdir = $(staticdir)/js
systemdservicedir = $(libdir)/systemd/system
dist_pkgmodule_DATA = \
+ src/cuirass/store.scm \
src/cuirass/base.scm \
src/cuirass/database.scm \
src/cuirass/http.scm \
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 8ecc15f..329ddb8 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -27,6 +27,7 @@
#:use-module (cuirass database)
#:use-module (cuirass remote)
#:use-module (cuirass specification)
+ #:use-module (cuirass store)
#:use-module (cuirass utils)
#:use-module ((cuirass config) #:select (%localstatedir))
#:use-module (gnu packages)
@@ -36,9 +37,7 @@
#:use-module (guix store)
#:use-module (guix ui)
#:use-module (guix git)
- #:use-module (guix cache)
#:use-module (zlib)
- #:use-module ((guix config) #:select (%state-directory))
#:use-module (git)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 control)
@@ -46,12 +45,9 @@
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
#:use-module (ice-9 ports internal)
- #:use-module (ice-9 rdelim)
- #:use-module (ice-9 receive)
#:use-module (ice-9 regex)
- #:use-module (ice-9 atomic)
#:use-module (ice-9 ftw)
- #:use-module (ice-9 threads)
+ #:autoload (ice-9 threads) (current-processor-count)
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
@@ -61,13 +57,9 @@
#:use-module (srfi srfi-35)
#:use-module (rnrs bytevectors)
#:export (;; Procedures.
- default-gc-root-directory
call-with-time-display
- register-gc-roots
read-parameters
evaluate
- with-store/non-blocking
- build-derivations&
set-build-successful!
clear-build-queue
cancel-old-builds
@@ -88,8 +80,6 @@
;; Parameters.
%bridge-socket-file-name
%package-cachedir
- %gc-root-directory
- %gc-root-ttl
%build-remote?
%fallback?))
@@ -112,71 +102,6 @@
(scm-error 'wrong-type-arg
"%package-cachedir" "Not a string: ~S" (list #f) #f)))))
-(define (default-gc-root-directory)
- (string-append %state-directory
- "/gcroots/profiles/per-user/"
- (passwd:name (getpwuid (getuid)))
- "/cuirass"))
-
-(define %gc-root-directory
- ;; Directory where garbage collector roots are stored. We register build
- ;; outputs there.
- (make-parameter (default-gc-root-directory)))
-
-(define %gc-root-ttl
- ;; The "time to live" (TTL) of GC roots.
- (make-parameter (* 30 24 3600)))
-
-(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 '("." "..")))))))
-
-(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* (register-gc-roots drv
- #:key (mode 'outputs))
- "Register GC roots for the outputs of the given DRV when MODE is 'outputs or
-for DRV itself when MODE is 'derivation. Also remove the expired GC roots if
-any."
- (catch 'system-error
- (lambda ()
- (case mode
- ((outputs)
- (for-each (match-lambda
- ((name . output)
- (register-gc-root output)))
- (derivation-path->output-paths drv)))
- ((derivation)
- (register-gc-root drv))))
- (lambda args
- (unless (= ENOENT (system-error-errno args)) ;collected in the meantime
- (apply throw args))))
-
- (maybe-remove-expired-cache-entries (%gc-root-directory)
- gc-roots
- #:entry-expiration
- gc-root-expiration-time))
-
(define (report-git-error error)
"Report the given Guile-Git error."
(format (current-error-port)
@@ -194,30 +119,6 @@ any."
(name evaluation-error-spec-name)
(id evaluation-error-id))
-(define (non-blocking-port port)
- "Make PORT non-blocking and return it."
- (let ((flags (fcntl port F_GETFL)))
- (when (zero? (logand O_NONBLOCK flags))
- (fcntl port F_SETFL (logior O_NONBLOCK flags)))
- port))
-
-(define (ensure-non-blocking-store-connection store)
- "Mark the file descriptor that backs STORE, a <store-connection>, as
-O_NONBLOCK."
- (match (store-connection-socket store)
- ((? file-port? port)
- (non-blocking-port port))
- (_ #f)))
-
-(define-syntax-rule (with-store/non-blocking store exp ...)
- "Like 'with-store', bind STORE to a connection to the store, but ensure that
-said connection is non-blocking (O_NONBLOCK). Evaluate EXP... in that
-context."
- (with-store store
- (ensure-non-blocking-store-connection store)
- (let ()
- exp ...)))
-
(define %cuirass-state-directory
;; Directory where state files are stored, usually "/var".
(make-parameter (or (getenv "CUIRASS_STATE_DIRECTORY")
@@ -243,67 +144,6 @@ context."
(load* file modules)))
-;;;
-;;; Build status.
-;;;
-
-(define (process-build-log port proc seed)
- "Read from PORT the build log, calling PROC for each build event like 'fold'
-does. Return the result of the last call to PROC."
- (define (process-line line state)
- (when (string-prefix? "@ " line)
- (match (string-tokenize (string-drop line 2))
- (((= string->symbol event-name) args ...)
- (proc (cons event-name args) state)))))
-
- (let loop ((state seed))
- (match (read-line port)
- ((? eof-object?)
- state)
- ((? string? line)
- (loop (process-line line state))))))
-
-(define (build-derivations& store lst)
- "Like 'build-derivations' but return two values: a file port from which to
-read the build log, and a thunk to call after EOF has been read. The thunk
-returns the value of the underlying 'build-derivations' call, or raises the
-exception that 'build-derivations' raised.
-
-Essentially this procedure inverts the inversion-of-control that
-'build-derivations' imposes, whereby 'build-derivations' writes to
-'current-build-output-port'."
- ;; XXX: Make this part of (guix store)?
- (define result
- (make-atomic-box #f))
-
- (match (pipe)
- ((input . output)
- (call-with-new-thread
- (lambda ()
- (catch #t
- (lambda ()
- ;; String I/O primitives are going to be used on PORT so make it
- ;; Unicode-capable and resilient to encoding issues.
- (set-port-encoding! output "UTF-8")
- (set-port-conversion-strategy! output 'substitute)
-
- (guard (c ((store-error? c)
- (atomic-box-set! result c)))
- (parameterize ((current-build-output-port output))
- (let ((x (build-derivations store lst)))
- (atomic-box-set! result x))))
- (close-port output))
- (lambda _
- (close-port output)))))
-
- (values (non-blocking-port input)
- (lambda ()
- (match (atomic-box-ref result)
- ((? condition? c)
- (raise c))
- (x x)))))))
-
-
;;;
;;; Building packages.
;;;
diff --git a/src/cuirass/scripts/register.scm b/src/cuirass/scripts/register.scm
index 9fab157..6d3ee75 100644
--- a/src/cuirass/scripts/register.scm
+++ b/src/cuirass/scripts/register.scm
@@ -21,13 +21,14 @@
(define-module (cuirass scripts register)
#:use-module (cuirass)
- #:use-module (cuirass base)
#:use-module (cuirass database)
#:use-module (cuirass ui)
#:use-module (cuirass logging)
#:use-module (cuirass metrics)
#:use-module (cuirass notification)
#:use-module (cuirass specification)
+ #:use-module ((cuirass store)
+ #:select (%gc-root-directory %gc-root-ttl))
#:use-module (cuirass utils)
#:use-module (cuirass zabbix)
#:use-module (guix ui)
diff --git a/src/cuirass/scripts/remote-server.scm
b/src/cuirass/scripts/remote-server.scm
index 95f1499..bbe19f1 100644
--- a/src/cuirass/scripts/remote-server.scm
+++ b/src/cuirass/scripts/remote-server.scm
@@ -18,7 +18,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (cuirass scripts remote-server)
- #:use-module (cuirass base)
+ #:autoload (cuirass base) (read-parameters set-build-successful!)
#:use-module (cuirass config)
#:use-module (cuirass database)
#:use-module (cuirass logging)
@@ -26,6 +26,7 @@
#:use-module (cuirass notification)
#:use-module (cuirass parameters)
#:use-module (cuirass remote)
+ #:use-module (cuirass store)
#:use-module (cuirass utils)
#:use-module (gcrypt pk-crypto)
#:use-module (guix avahi)
diff --git a/src/cuirass/scripts/remote-worker.scm
b/src/cuirass/scripts/remote-worker.scm
index 039c0be..6295584 100644
--- a/src/cuirass/scripts/remote-worker.scm
+++ b/src/cuirass/scripts/remote-worker.scm
@@ -20,7 +20,10 @@
(define-module (cuirass scripts remote-worker)
#:use-module (fibers)
#:use-module (fibers channels)
- #:use-module (cuirass base)
+ #:autoload (cuirass store) (build-derivations&
+ register-gc-roots
+ %gc-root-directory
+ %gc-root-ttl)
#:use-module (cuirass logging)
#:use-module (cuirass remote)
#:use-module (cuirass ui)
diff --git a/src/cuirass/store.scm b/src/cuirass/store.scm
new file mode 100644
index 0000000..9cf9b7d
--- /dev/null
+++ b/src/cuirass/store.scm
@@ -0,0 +1,199 @@
+;;; store.scm -- Fiberized access to the store.
+;;; Copyright © 2016-2019, 2022-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2020, 2021 Mathieu Othacehe <othacehe@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass 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.
+;;;
+;;; Cuirass 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 Cuirass. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (cuirass store)
+ #:use-module (guix store)
+ #:autoload (guix derivations) (build-derivations
+ derivation-path->output-paths)
+ #:use-module ((guix config) #:select (%state-directory))
+ #:autoload (guix cache) (maybe-remove-expired-cache-entries)
+ #:autoload (srfi srfi-26) (cut)
+ #:use-module (srfi srfi-34)
+ #:use-module ((srfi srfi-35) #:select (condition?))
+ #:use-module (ice-9 atomic)
+ #:use-module (ice-9 match)
+ #:autoload (ice-9 ftw) (scandir)
+ #:autoload (ice-9 rdelim) (read-line)
+ #:use-module (ice-9 threads)
+ #:export (non-blocking-port
+ with-store/non-blocking
+ process-build-log
+ build-derivations&
+
+ register-gc-root
+ register-gc-roots
+ default-gc-root-directory
+ %gc-root-directory
+ %gc-root-ttl))
+
+
+;;;
+;;; Garbage collector roots.
+;;;
+
+(define (default-gc-root-directory)
+ (string-append %state-directory
+ "/gcroots/profiles/per-user/"
+ (passwd:name (getpwuid (getuid)))
+ "/cuirass"))
+
+(define %gc-root-directory
+ ;; Directory where garbage collector roots are stored. We register build
+ ;; outputs there.
+ (make-parameter (default-gc-root-directory)))
+
+(define %gc-root-ttl
+ ;; The "time to live" (TTL) of GC roots.
+ (make-parameter (* 30 24 3600)))
+
+(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 '("." "..")))))))
+
+(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* (register-gc-roots drv
+ #:key (mode 'outputs))
+ "Register GC roots for the outputs of the given DRV when MODE is 'outputs or
+for DRV itself when MODE is 'derivation. Also remove the expired GC roots if
+any."
+ (catch 'system-error
+ (lambda ()
+ (case mode
+ ((outputs)
+ (for-each (match-lambda
+ ((name . output)
+ (register-gc-root output)))
+ (derivation-path->output-paths drv)))
+ ((derivation)
+ (register-gc-root drv))))
+ (lambda args
+ (unless (= ENOENT (system-error-errno args)) ;collected in the meantime
+ (apply throw args))))
+
+ (maybe-remove-expired-cache-entries (%gc-root-directory)
+ gc-roots
+ #:entry-expiration
+ gc-root-expiration-time))
+
+
+;;;
+;;; Fiberized access to the store.
+;;;
+
+(define (non-blocking-port port)
+ "Make PORT non-blocking and return it."
+ (let ((flags (fcntl port F_GETFL)))
+ (when (zero? (logand O_NONBLOCK flags))
+ (fcntl port F_SETFL (logior O_NONBLOCK flags)))
+ port))
+
+(define (ensure-non-blocking-store-connection store)
+ "Mark the file descriptor that backs STORE, a <store-connection>, as
+O_NONBLOCK."
+ (match (store-connection-socket store)
+ ((? file-port? port)
+ (non-blocking-port port))
+ (_ #f)))
+
+(define-syntax-rule (with-store/non-blocking store exp ...)
+ "Like 'with-store', bind STORE to a connection to the store, but ensure that
+said connection is non-blocking (O_NONBLOCK). Evaluate EXP... in that
+context."
+ (with-store store
+ (ensure-non-blocking-store-connection store)
+ (let ()
+ exp ...)))
+
+(define (process-build-log port proc seed)
+ "Read from PORT the build log, calling PROC for each build event like 'fold'
+does. Return the result of the last call to PROC."
+ (define (process-line line state)
+ (when (string-prefix? "@ " line)
+ (match (string-tokenize (string-drop line 2))
+ (((= string->symbol event-name) args ...)
+ (proc (cons event-name args) state)))))
+
+ (let loop ((state seed))
+ (match (read-line port)
+ ((? eof-object?)
+ state)
+ ((? string? line)
+ (loop (process-line line state))))))
+
+(define (build-derivations& store lst)
+ "Like 'build-derivations' but return two values: a file port from which to
+read the build log, and a thunk to call after EOF has been read. The thunk
+returns the value of the underlying 'build-derivations' call, or raises the
+exception that 'build-derivations' raised.
+
+Essentially this procedure inverts the inversion-of-control that
+'build-derivations' imposes, whereby 'build-derivations' writes to
+'current-build-output-port'."
+ ;; XXX: Make this part of (guix store)?
+ (define result
+ (make-atomic-box #f))
+
+ (match (pipe)
+ ((input . output)
+ (call-with-new-thread
+ (lambda ()
+ (catch #t
+ (lambda ()
+ ;; String I/O primitives are going to be used on PORT so make it
+ ;; Unicode-capable and resilient to encoding issues.
+ (set-port-encoding! output "UTF-8")
+ (set-port-conversion-strategy! output 'substitute)
+
+ (guard (c ((store-error? c)
+ (atomic-box-set! result c)))
+ (parameterize ((current-build-output-port output))
+ (let ((x (build-derivations store lst)))
+ (atomic-box-set! result x))))
+ (close-port output))
+ (lambda _
+ (close-port output)))))
+
+ (values (non-blocking-port input)
+ (lambda ()
+ (match (atomic-box-ref result)
+ ((? condition? c)
+ (raise c))
+ (x x)))))))
+
- branch wip-actors created (now 0346ac2), Ludovic Courtès, 2023/09/13
- [no subject], Ludovic Courtès, 2023/09/13
- [no subject], Ludovic Courtès, 2023/09/13
- [no subject], Ludovic Courtès, 2023/09/13
- [no subject], Ludovic Courtès, 2023/09/13
- [no subject], Ludovic Courtès, 2023/09/13
- [no subject], Ludovic Courtès, 2023/09/13
- [no subject], Ludovic Courtès, 2023/09/13
- [no subject], Ludovic Courtès, 2023/09/13
- [no subject],
Ludovic Courtès <=
- [no subject], Ludovic Courtès, 2023/09/13
- [no subject], Ludovic Courtès, 2023/09/13
- [no subject], Ludovic Courtès, 2023/09/13
- [no subject], Ludovic Courtès, 2023/09/13
- [no subject], Ludovic Courtès, 2023/09/13