store: Add GC-related operations.

* guix/store.scm (gc-action): New enumerate type.
  (read-long-long, read-string-list, write-store-path,
  write-store-path-list, read-store-path-list): New procedures.
  (write-arg): Add support for `store-path' and `store-path-list'.
  (read-arg): Add support for `store-path-list'.
  (define-operation): Add support for multiple-value returns.
  (run-gc, live-paths, dead-paths, collect-garbage, delete-paths): New
  procedures.
  (%long-long-max): New macro.
* tests/store.scm: New file.
* Makefile.am (TESTS): Add it.

1 files changed, 98 insertions, 4 deletions

diff --git a/guix/store.scm b/guix/store.scm
index 67620a1767..204364f319 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -50,8 +50,14 @@
             add-text-to-store
             add-to-store
             build-derivations
+            add-temp-root
             add-indirect-root
 
+            live-paths
+            dead-paths
+            collect-garbage
+            delete-paths
+
             current-build-output-port
 
             %store-prefix
@@ -111,8 +117,16 @@
   (sha1 2)
   (sha256 3))
 
+(define-enumerate-type gc-action
+  ;; store-api.hh
+  (return-live 0)
+  (return-dead 1)
+  (delete-dead 2)
+  (delete-specific 3))
+
 (define %nix-state-dir
   (or (getenv "NIX_STATE_DIR") "/nix/var/nix"))
+
 (define %default-socket-path
   (string-append %nix-state-dir "/daemon-socket/socket"))
 
@@ -133,6 +147,10 @@
     (bytevector-u64-set! b 0 n (endianness little))
     (put-bytevector p b)))
 
+(define (read-long-long p)
+  (let ((b (get-bytevector-n p 8)))
+    (bytevector-u64-ref b 0 (endianness little))))
+
 (define write-padding
   (let ((zero (make-bytevector 8 0)))
     (lambda (n p)
@@ -159,9 +177,23 @@
   (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-store-path f p)
+  (write-string f p))                             ; TODO: assert path
+
 (define (read-store-path p)
   (read-string p))                                ; TODO: assert path
 
+(define write-store-path-list write-string-list)
+(define read-store-path-list read-string-list)
+
 (define (write-contents file p)
   "Write the contents of FILE to output port P."
   (define (dump in size)
@@ -223,7 +255,8 @@
       (write-string ")" p))))
 
 (define-syntax write-arg
-  (syntax-rules (integer boolean file string string-list base16)
+  (syntax-rules (integer boolean file string string-list
+                 store-path store-path-list base16)
     ((_ integer arg p)
      (write-int arg p))
     ((_ boolean arg p)
@@ -234,11 +267,15 @@
      (write-string arg p))
     ((_ string-list arg p)
      (write-string-list arg p))
+    ((_ store-path arg p)
+     (write-store-path arg p))
+    ((_ store-path-list arg p)
+     (write-store-path-list arg p))
     ((_ base16 arg p)
      (write-string (bytevector->base16-string arg) p))))
 
 (define-syntax read-arg
-  (syntax-rules (integer boolean string store-path base16)
+  (syntax-rules (integer boolean string store-path store-path-list base16)
     ((_ integer p)
      (read-int p))
     ((_ boolean p)
@@ -247,6 +284,8 @@
      (read-string p))
     ((_ store-path p)
      (read-store-path p))
+    ((_ store-path-list p)
+     (read-store-path-list p))
     ((_ hash p)
      (base16-string->bytevector (read-string p)))))
 
@@ -385,7 +424,7 @@ again until #t is returned or an error is raised."
 
 (define-syntax define-operation
   (syntax-rules ()
-    ((_ (name (type arg) ...) docstring return)
+    ((_ (name (type arg) ...) docstring return ...)
      (define (name server arg ...)
        docstring
        (let ((s (nix-server-socket server)))
@@ -395,7 +434,7 @@ again until #t is returned or an error is raised."
          ;; Loop until the server is done sending error output.
          (let loop ((done? (process-stderr server)))
            (or done? (loop (process-stderr server))))
-         (read-arg return s))))))
+         (values (read-arg return s) ...))))))
 
 (define-operation (valid-path? (string path))
   "Return #t when PATH is a valid store path."
@@ -436,6 +475,61 @@ name--it is the caller's responsibility to ensure that it is an absolute
 file name.  Return #t on success."
   boolean)
 
+(define (run-gc server action to-delete min-freed)
+  "Perform the garbage-collector operation ACTION, one of the
+`gc-action' values.  When ACTION is `delete-specific', the TO-DELETE is
+the list of store paths to delete.  IGNORE-LIVENESS? should always be
+#f.  MIN-FREED is the minimum amount of disk space to be freed, in
+bytes, before the GC can stop.  Return the list of store paths delete,
+and the number of bytes freed."
+  (let ((s (nix-server-socket server)))
+    (write-int (operation-id collect-garbage) s)
+    (write-int action s)
+    (write-store-path-list to-delete s)
+    (write-arg boolean #f s)                      ; ignore-liveness?
+    (write-long-long min-freed s)
+    (write-int 0 s)                               ; obsolete
+    (when (>= (nix-server-minor-version server) 5)
+      ;; Obsolete `use-atime' and `max-atime' parameters.
+      (write-int 0 s)
+      (write-int 0 s))
+
+    ;; Loop until the server is done sending error output.
+    (let loop ((done? (process-stderr server)))
+      (or done? (loop (process-stderr server))))
+
+    (let ((paths    (read-store-path-list s))
+          (freed    (read-long-long s))
+          (obsolete (read-long-long s)))
+     (values paths freed))))
+
+(define-syntax-rule (%long-long-max)
+  ;; Maximum unsigned 64-bit integer.
+  (- (expt 2 64) 1))
+
+(define (live-paths server)
+  "Return the list of live store paths---i.e., store paths still
+referenced, and thus not subject to being garbage-collected."
+  (run-gc server (gc-action return-live) '() (%long-long-max)))
+
+(define (dead-paths server)
+  "Return the list of dead store paths---i.e., store paths no longer
+referenced, and thus subject to being garbage-collected."
+  (run-gc server (gc-action return-dead) '() (%long-long-max)))
+
+(define* (collect-garbage server #:optional (min-freed (%long-long-max)))
+  "Collect garbage from the store at SERVER.  If MIN-FREED is non-zero,
+then collect at least MIN-FREED bytes.  Return the paths that were
+collected, and the number of bytes freed."
+  (run-gc server (gc-action delete-dead) '() min-freed))
+
+(define* (delete-paths server paths #:optional (min-freed (%long-long-max)))
+  "Delete PATHS from the store at SERVER, if they are no longer
+referenced.  If MIN-FREED is non-zero, then stop after at least
+MIN-FREED bytes have been collected.  Return the paths that were
+collected, and the number of bytes freed."
+  (run-gc server (gc-action delete-specific) paths min-freed))
+
 
 ;;;
 ;;; Store paths.