01/14: gexp: Add 'references-file'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 774f8804bafbf42a65eca492d1395da57deeb467
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Apr 13 19:59:03 2022 +0200

    gexp: Add 'references-file'.
    
    * gnu/services/base.scm (references-file): Remove.
    * guix/gexp.scm (references-file): New procedure.
    * tests/gexp.scm ("references-file"): New test.
---
 gnu/services/base.scm | 22 ----------------------
 guix/gexp.scm         | 44 ++++++++++++++++++++++++++++++++++++++++++++
 tests/gexp.scm        | 18 ++++++++++++++++++
 3 files changed, 62 insertions(+), 22 deletions(-)

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index f1649eb084..e324864744 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -219,8 +219,6 @@
             pam-limits-service-type
             pam-limits-service
 
-            references-file
-
             %base-services))
 
 ;;; Commentary:
@@ -1768,26 +1766,6 @@ proxy of 'guix-daemon'...~%")
               (substitute-key-authorization authorized-keys guix)
               #~#f))))
 
-(define* (references-file item #:optional (name "references"))
-  "Return a file that contains the list of references of ITEM."
-  (if (struct? item)                              ;lowerable object
-      (computed-file name
-                     (with-extensions (list guile-gcrypt) ;for store-copy
-                       (with-imported-modules (source-module-closure
-                                               '((guix build store-copy)))
-                         #~(begin
-                             (use-modules (guix build store-copy))
-
-                             (call-with-output-file #$output
-                               (lambda (port)
-                                 (write (map store-info-item
-                                             (call-with-input-file "graph"
-                                               read-reference-graph))
-                                        port))))))
-                     #:options `(#:local-build? #f
-                                 #:references-graphs (("graph" ,item))))
-      (plain-file name "()")))
-
 (define guix-service-type
   (service-type
    (name 'guix)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 9fdb7a30be..ef92223048 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -118,6 +118,7 @@
             mixed-text-file
             file-union
             directory-union
+            references-file
 
             imported-files
             imported-modules
@@ -2173,6 +2174,49 @@ is true, the derivation will not print anything."
                                            #:resolve-collision
                                            (ungexp resolve-collision)))))))))
 
+(define* (references-file item #:optional (name "references")
+                          #:key guile)
+  "Return a file that contains the list of direct and indirect references (the
+closure) of ITEM."
+  (if (struct? item)                              ;lowerable object
+      (computed-file name
+                     (gexp (begin
+                             (use-modules (srfi srfi-1)
+                                          (ice-9 rdelim)
+                                          (ice-9 match))
+
+                             (define (drop-lines port n)
+                               ;; Drop N lines read from PORT.
+                               (let loop ((n n))
+                                 (unless (zero? n)
+                                   (read-line port)
+                                   (loop (- n 1)))))
+
+                             (define (read-graph port)
+                               ;; Return the list of references read from
+                               ;; PORT.  This is a stripped-down version of
+                               ;; 'read-reference-graph'.
+                               (let loop ((items '()))
+                                 (match (read-line port)
+                                   ((? eof-object?)
+                                    (delete-duplicates items))
+                                   ((? string? item)
+                                    (let ((deriver (read-line port))
+                                          (count
+                                           (string->number (read-line port))))
+                                      (drop-lines port count)
+                                      (loop (cons item items)))))))
+
+                             (call-with-output-file (ungexp output)
+                               (lambda (port)
+                                 (write (call-with-input-file "graph"
+                                          read-graph)
+                                        port)))))
+                     #:guile guile
+                     #:options `(#:local-build? #t
+                                 #:references-graphs (("graph" ,item))))
+      (plain-file name "()")))
+
 
 ;;;
 ;;; Syntactic sugar.
diff --git a/tests/gexp.scm b/tests/gexp.scm
index c80ca13fab..35bd99e6d4 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -1606,6 +1606,24 @@ importing.* \\(guix config\\) from the host"
                    (not (member (derivation-file-name native) refs))
                    (member (derivation-file-name cross) refs))))))
 
+(test-assertm "references-file"
+  (let* ((exp      #~(symlink #$%bootstrap-guile #$output))
+         (computed (computed-file "computed" exp
+                                  #:guile %bootstrap-guile))
+         (refs     (references-file computed "refs"
+                                    #:guile %bootstrap-guile)))
+    (mlet* %store-monad ((drv0 (lower-object %bootstrap-guile))
+                         (drv1 (lower-object computed))
+                         (drv2 (lower-object refs)))
+      (mbegin %store-monad
+        (built-derivations (list drv2))
+        (mlet %store-monad ((refs ((store-lift requisites)
+                                   (list (derivation->output-path drv1)))))
+          (return (lset= string=?
+                         (call-with-input-file (derivation->output-path drv2)
+                           read)
+                         refs)))))))
+
 (test-assert "lower-object & gexp-input-error?"
   (guard (c ((gexp-input-error? c)
              (gexp-error-invalid-input c)))