05/06: store: Add #:select? parameter to 'add-to-store'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 1ec32f4a9d35f235a9947f288370af1445f8ab8b
Author: Ludovic Courtès <address@hidden>
Date:   Wed Jun 15 11:51:16 2016 +0200

    store: Add #:select? parameter to 'add-to-store'.
    
    * guix/store.scm (write-arg): Remove 'file' case.
    (true): New procedure.
    (add-to-store): Add #:select? parameter and honor it.  Use hand-coded
    stub instead of 'operation'.
    (interned-file): Add #:select? parameter and honor it.
    * doc/guix.texi (The Store Monad): Adjust 'interned-file' documentation
    accordingly.
---
 doc/guix.texi  |    7 ++++++-
 guix/store.scm |   60 +++++++++++++++++++++++++++++++++++++++-----------------
 2 files changed, 48 insertions(+), 19 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 18a1960..97c01be 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -3502,7 +3502,7 @@ resulting text file refers to; it defaults to the empty 
list.
 @end deffn
 
 @deffn {Monadic Procedure} interned-file @var{file} address@hidden @
-         [#:recursive? #t]
+         [#:recursive? #t] [#:select? (const #t)]
 Return the name of @var{file} once interned in the store.  Use
 @var{name} as its store name, or the basename of @var{file} if
 @var{name} is omitted.
@@ -3511,6 +3511,11 @@ When @var{recursive?} is true, the contents of 
@var{file} are added
 recursively; if @var{file} designates a flat file and @var{recursive?}
 is true, its contents are added, and its permission bits are kept.
 
+When @var{recursive?} is true, call @code{(@var{select?} @var{file}
address@hidden)} for each directory entry, where @var{file} is the entry's
+absolute file name and @var{stat} is the result of @code{lstat}; exclude
+entries for which @var{select?} does not return true.
+
 The example below adds a file to the store, under two different names:
 
 @example
diff --git a/guix/store.scm b/guix/store.scm
index e3033ee..a640166 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -263,14 +263,12 @@
     (path-info deriver hash refs registration-time nar-size)))
 
 (define-syntax write-arg
-  (syntax-rules (integer boolean file string string-list string-pairs
+  (syntax-rules (integer boolean string string-list string-pairs
                  store-path store-path-list base16)
     ((_ integer arg p)
      (write-int arg p))
     ((_ boolean arg p)
      (write-int (if arg 1 0) p))
-    ((_ file arg p)
-     (write-file arg p))
     ((_ string arg p)
      (write-string arg p))
     ((_ string-list arg p)
@@ -653,30 +651,51 @@ path."
               (hash-set! cache args path)
               path))))))
 
+(define true
+  ;; Define it once and for all since we use it as a default value for
+  ;; 'add-to-store' and want to make sure two default values are 'eq?' for the
+  ;; purposes or memoization.
+  (lambda (file stat)
+    #t))
+
 (define add-to-store
   ;; A memoizing version of `add-to-store'.  This is important because
   ;; `add-to-store' leads to huge data transfers to the server, and
   ;; because it's often called many times with the very same argument.
-  (let ((add-to-store (operation (add-to-store (string basename)
-                                               (boolean fixed?) ; obsolete, 
must be #t
-                                               (boolean recursive?)
-                                               (string hash-algo)
-                                               (file file-name))
-                                 #f
-                                 store-path)))
-    (lambda (server basename recursive? hash-algo file-name)
+  (let ((add-to-store
+         (lambda* (server basename recursive? hash-algo file-name
+                          #:key (select? true))
+           ;; We don't use the 'operation' macro so we can pass SELECT? to
+           ;; 'write-file'.
+           (let ((port (nix-server-socket server)))
+             (write-int (operation-id add-to-store) port)
+             (write-string basename port)
+             (write-int 1 port)                   ;obsolete, must be #t
+             (write-int (if recursive? 1 0) port)
+             (write-string hash-algo port)
+             (write-file file-name port #:select? select?)
+             (let loop ((done? (process-stderr server)))
+               (or done? (loop (process-stderr server))))
+             (read-store-path port)))))
+    (lambda* (server basename recursive? hash-algo file-name
+                     #:key (select? true))
       "Add the contents of FILE-NAME under BASENAME to the store.  When
 RECURSIVE? is false, FILE-NAME must designate a regular file--not a directory
 nor a symlink.  When RECURSIVE? is true and FILE-NAME designates a directory,
 the contents of FILE-NAME are added recursively; if FILE-NAME designates a
 flat file and RECURSIVE? is true, its contents are added, and its permission
-bits are kept.  HASH-ALGO must be a string such as \"sha256\"."
+bits are kept.  HASH-ALGO must be a string such as \"sha256\".
+
+When RECURSIVE? is true, call (SELECT?  FILE STAT) for each directory entry,
+where FILE is the entry's absolute file name and STAT is the result of
+'lstat'; exclude entries for which SELECT? does not return true."
       (let* ((st    (false-if-exception (lstat file-name)))
-             (args  `(,st ,basename ,recursive? ,hash-algo))
+             (args  `(,st ,basename ,recursive? ,hash-algo ,select?))
              (cache (nix-server-add-to-store-cache server)))
         (or (and st (hash-ref cache args))
-            (let ((path (add-to-store server basename #t recursive?
-                                      hash-algo file-name)))
+            (let ((path (add-to-store server basename recursive?
+                                      hash-algo file-name
+                                      #:select? select?)))
               (hash-set! cache args path)
               path))))))
 
@@ -1111,16 +1130,21 @@ resulting text file refers to; it defaults to the empty 
list."
             store)))
 
 (define* (interned-file file #:optional name
-                        #:key (recursive? #t))
+                        #:key (recursive? #t) (select? true))
   "Return the name of FILE once interned in the store.  Use NAME as its store
 name, or the basename of FILE if NAME is omitted.
 
 When RECURSIVE? is true, the contents of FILE are added recursively; if FILE
 designates a flat file and RECURSIVE? is true, its contents are added, and its
-permission bits are kept."
+permission bits are kept.
+
+When RECURSIVE? is true, call (SELECT?  FILE STAT) for each directory entry,
+where FILE is the entry's absolute file name and STAT is the result of
+'lstat'; exclude entries for which SELECT? does not return true."
   (lambda (store)
     (values (add-to-store store (or name (basename file))
-                          recursive? "sha256" file)
+                          recursive? "sha256" file
+                          #:select? select?)
             store)))
 
 (define build