01/01: scripts: Suggest running 'guix gc' when we're short on disk space.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 62a14bd26f2ed7cf416183528dcca4b1b29aaf0a
Author: Ludovic Courtès <address@hidden>
Date:   Tue Oct 23 00:56:25 2018 +0200

    scripts: Suggest running 'guix gc' when we're short on disk space.
    
    * guix/scripts.scm (%disk-space-warning): New variable.
    (warn-about-disk-space): New procedure.
    * guix/scripts/package.scm (build-and-use-profile): Use it.
    * guix/scripts/system.scm (process-action): Likewise.
---
 guix/scripts.scm         | 38 +++++++++++++++++++++++++++++++++++++-
 guix/scripts/package.scm |  4 +++-
 guix/scripts/system.scm  |  3 ++-
 3 files changed, 42 insertions(+), 3 deletions(-)

diff --git a/guix/scripts.scm b/guix/scripts.scm
index 98751bc..5e20ecd 100644
--- a/guix/scripts.scm
+++ b/guix/scripts.scm
@@ -27,6 +27,7 @@
   #:use-module (guix packages)
   #:use-module (guix derivations)
   #:use-module ((guix profiles) #:select (%profile-directory))
+  #:use-module (guix build syscalls)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-37)
@@ -37,7 +38,9 @@
             build-package
             build-package-source
             %distro-age-warning
-            warn-about-old-distro))
+            warn-about-old-distro
+            %disk-space-warning
+            warn-about-disk-space))
 
 ;;; Commentary:
 ;;;
@@ -186,4 +189,37 @@ Show what and how will/would be built."
                suggested-command)
       (newline (guix-warning-port)))))
 
+(define %disk-space-warning
+  ;; The fraction (between 0 and 1) of free disk space below which a warning
+  ;; is emitted.
+  (make-parameter (match (and=> (getenv "GUIX_DISK_SPACE_WARNING")
+                                string->number)
+                    (#f        .05)               ;5%
+                    (threshold (/ threshold 100.)))))
+
+(define* (warn-about-disk-space #:optional profile
+                                #:key
+                                (threshold (%disk-space-warning)))
+  "Display a hint about 'guix gc' if less than THRESHOLD of /gnu/store is
+available."
+  (let* ((stats      (statfs (%store-prefix)))
+         (block-size (file-system-block-size stats))
+         (available  (* block-size (file-system-blocks-available stats)))
+         (total      (* block-size (file-system-block-count stats)))
+         (ratio      (/ available total 1.)))
+    (when (< ratio threshold)
+      (warning (G_ "only ~,1f% of free space available on ~a~%")
+               (* ratio 100) (%store-prefix))
+      (if profile
+          (display-hint (format #f (G_ "Consider deleting old profile
+generations and collecting garbage, along these lines:
+
address@hidden
+guix package -p ~s --delete-generations=1m
+guix gc
address@hidden example\n")
+                                profile))
+          (display-hint (G_ "Consider running @command{guix gc} to free
+space."))))))
+
 ;;; scripts.scm ends here
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 5d146b8..500fc9a 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -164,7 +164,9 @@ do not treat collisions in MANIFEST as an error."
                               count)
                        count)
                (display-search-paths entries (list profile)
-                                     #:kind 'prefix))))))))
+                                     #:kind 'prefix)))
+
+        (warn-about-disk-space profile))))))
 
 
 ;;;
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index f9af38b..d2be0cf 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -1161,7 +1161,8 @@ resulting from command-line parsing."
                              #:target target
                              #:bootloader-target bootloader-target
                              #:gc-root (assoc-ref opts 'gc-root)))))
-        #:system system))))
+        #:system system))
+    (warn-about-disk-space)))
 
 (define (resolve-subcommand name)
   (let ((module (resolve-interface