02/04: store: Add 'find-roots' RPC.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 7df3ab0f0d21e6414a22b113c832dc18475f34a7
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Jan 21 16:06:10 2021 +0100

    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 59cd93f..9d0739f 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 <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 
Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -34,7 +34,7 @@
             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 @@ substitute invalid byte sequences with question marks.  
This is a
   (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 @@ substitute invalid byte sequences with question marks.  
This is a
               (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 4da3997..e0b15ab 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 <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 
Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
@@ -114,6 +114,7 @@
             query-failed-paths
             clear-failed-paths
             ensure-path
+            find-roots
             add-temp-root
             add-indirect-root
             add-permanent-root
@@ -340,7 +341,8 @@
      (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 @@
      (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 @@ running a substitute.  As a GC root is not created by 
the daemon, you may want
 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 c9a08ac..cda0e03 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 <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 
Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -201,6 +201,17 @@
 ;;          (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"