From 7df3ab0f0d21e6414a22b113c832dc18475f34a7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 21 Jan 2021 16:06:10 +0100 Subject: store: Add 'find-roots' RPC. * guix/serialization.scm (read-string-pairs): New procedure. * guix/store.scm (read-arg): Add support for 'string-pairs'. (find-roots): New procedure. * tests/store.scm ("add-indirect-root and find-roots"): New test. --- guix/serialization.scm | 16 ++++++++++++---- guix/store.scm | 17 +++++++++++++++-- tests/store.scm | 13 ++++++++++++- 3 files changed, 39 insertions(+), 7 deletions(-) diff --git a/guix/serialization.scm b/guix/serialization.scm index 59cd93fb18..9d0739f6c5 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -34,7 +34,7 @@ (define-module (guix serialization) write-bytevector write-string read-string read-latin1-string read-maybe-utf8-string write-string-list read-string-list - write-string-pairs + write-string-pairs read-string-pairs write-store-path read-store-path write-store-path-list read-store-path-list (dump . dump-port*) @@ -166,6 +166,14 @@ (define (write-string-list l p) (write-int (length l) p) (for-each (cut write-string <> p) l)) +(define (read-string-list p) + (let ((len (read-int p))) + (unfold (cut >= <> len) + (lambda (i) + (read-string p)) + 1+ + 0))) + (define (write-string-pairs l p) (write-int (length l) p) (for-each (match-lambda @@ -174,11 +182,11 @@ (define (write-string-pairs l p) (write-string second p))) l)) -(define (read-string-list p) +(define (read-string-pairs p) (let ((len (read-int p))) (unfold (cut >= <> len) (lambda (i) - (read-string p)) + (cons (read-string p) (read-string p))) 1+ 0))) diff --git a/guix/store.scm b/guix/store.scm index 4da39971b5..e0b15abce3 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2018 Jan Nieuwenhuizen ;;; Copyright © 2019, 2020 Mathieu Othacehe ;;; Copyright © 2020 Florian Pelz @@ -114,6 +114,7 @@ (define-module (guix store) query-failed-paths clear-failed-paths ensure-path + find-roots add-temp-root add-indirect-root add-permanent-root @@ -340,7 +341,8 @@ (define-syntax write-arg (write-string (bytevector->base16-string arg) p)))) (define-syntax read-arg - (syntax-rules (integer boolean string store-path store-path-list string-list + (syntax-rules (integer boolean string store-path + store-path-list string-list string-pairs substitutable-path-list path-info base16) ((_ integer p) (read-int p)) @@ -354,6 +356,8 @@ (define-syntax read-arg (read-store-path-list p)) ((_ string-list p) (read-string-list p)) + ((_ string-pairs p) + (read-string-pairs p)) ((_ substitutable-path-list p) (read-substitutable-path-list p)) ((_ path-info p) @@ -1404,6 +1408,15 @@ (define-operation (ensure-path (store-path path)) to call ADD-TEMP-ROOT on that store path." boolean) +(define-operation (find-roots) + "Return a list of root/target pairs: for each pair, the first element is the +GC root file name and the second element is its target in the store. + +When talking to a local daemon, this operation is equivalent to the 'gc-roots' +procedure in (guix store roots), except that the 'find-roots' excludes +potential roots that do not point to store items." + string-pairs) + (define-operation (add-temp-root (store-path path)) "Make PATH a temporary root for the duration of the current session. Return #t." diff --git a/tests/store.scm b/tests/store.scm index c9a08ac690..cda0e0302f 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -201,6 +201,17 @@ (define %shell ;; (valid-path? %store p1) ;; (member (pk p2) (live-paths %store))))) +(test-assert "add-indirect-root and find-roots" + (call-with-temporary-directory + (lambda (directory) + (let* ((item (add-text-to-store %store "something" (random-text))) + (root (string-append directory "/gc-root"))) + (symlink item root) + (add-indirect-root %store root) + (let ((result (member (cons root item) (find-roots %store)))) + (delete-file root) + result))))) + (test-assert "permanent root" (let* ((p (with-store store (let ((p (add-text-to-store store "random-text" -- cgit v1.2.3