06/07: guix gc: Add '--free-space'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 0054e47036b13d46f0f026bbc04d19770c2ecbad
Author: Ludovic Courtès <address@hidden>
Date:   Mon Apr 25 22:19:33 2016 +0200

    guix gc: Add '--free-space'.
    
    * guix/scripts/gc.scm (show-help, %options): Add '--free-space'.
    (guix-gc)[ensure-free-space]: New procedure.
    Handle '--free-space'.
---
 doc/guix.texi       |    9 +++++++++
 guix/scripts/gc.scm |   33 ++++++++++++++++++++++++++++-----
 2 files changed, 37 insertions(+), 5 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index ab07d10..6d64772 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -1974,6 +1974,15 @@ suffix, such as @code{MiB} for mebibytes and @code{GB} 
for gigabytes
 
 When @var{min} is omitted, collect all the garbage.
 
address@hidden address@hidden
address@hidden -F @var{free}
+Collect garbage until @var{free} space is available under
address@hidden/gnu/store}, if possible; @var{free} denotes storage space, such
+as @code{500MiB}, as described above.
+
+When @var{free} or more is already available in @file{/gnu/store}, do
+nothing and exit immediately.
+
 @item --delete
 @itemx -d
 Attempt to delete all the store files and directories specified as
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index fe1bb93..4ec9ff9 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2015 Ludovic Courtès <address@hidden>
+;;; Copyright © 2012, 2013, 2015, 2016 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,6 +20,7 @@
   #:use-module (guix ui)
   #:use-module (guix scripts)
   #:use-module (guix store)
+  #:autoload   (guix build syscalls) (statfs)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
@@ -43,6 +44,8 @@ Invoke the garbage collector.\n"))
   -C, --collect-garbage[=MIN]
                          collect at least MIN bytes of garbage"))
   (display (_ "
+  -F, --free-space=FREE  attempt to reach FREE available space in the store"))
+  (display (_ "
   -d, --delete           attempt to delete PATHS"))
   (display (_ "
       --optimize         optimize the store by deduplicating identical files"))
@@ -96,6 +99,9 @@ Invoke the garbage collector.\n"))
                             (leave (_ "invalid amount of storage: ~a~%")
                                    arg))))
                      (#f result)))))
+        (option '(#\F "free-space") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'free-space (size->number arg) result)))
         (option '(#\d "delete") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'action 'delete
@@ -175,6 +181,18 @@ Invoke the garbage collector.\n"))
                         (cut match:substring <> 1)))
         file))
 
+  (define (ensure-free-space store space)
+    ;; Attempt to have at least SPACE bytes available in STORE.
+    (let* ((fs    (statfs (%store-prefix)))
+           (free  (* (file-system-block-size fs)
+                     (file-system-blocks-available fs))))
+      (if (> free space)
+          (info (_ "already ~h bytes available on ~a, nothing to do~%")
+                free (%store-prefix))
+          (let ((to-free (- space free)))
+            (info (_ "freeing ~h bytes~%") to-free)
+            (collect-garbage store to-free)))))
+
   (with-error-handling
     (let* ((opts  (parse-options))
            (store (open-connection))
@@ -197,10 +215,15 @@ Invoke the garbage collector.\n"))
       (case (assoc-ref opts 'action)
         ((collect-garbage)
          (assert-no-extra-arguments)
-         (let ((min-freed (assoc-ref opts 'min-freed)))
-           (if min-freed
-               (collect-garbage store min-freed)
-               (collect-garbage store))))
+         (let ((min-freed  (assoc-ref opts 'min-freed))
+               (free-space (assoc-ref opts 'free-space)))
+           (cond
+            (free-space
+             (ensure-free-space store free-space))
+            (min-freed
+             (collect-garbage store min-freed))
+            (else
+             (collect-garbage store)))))
         ((delete)
          (delete-paths store (map direct-store-path paths)))
         ((list-references)