all messages for Guix-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
From: Pierre Neidhardt <mail@ambrevar.xyz>
To: 39734@debbugs.gnu.org
Subject: [bug#39734] [PATCH] scripts: Emit GC hint if free space is lower than absolute and relative threshold.
Date: Tue, 25 Feb 2020 11:23:30 +0100	[thread overview]
Message-ID: <20200225102330.4825-1-mail@ambrevar.xyz> (raw)
In-Reply-To: <87lforarw6.fsf@ambrevar.xyz>

* guix/scripts.scm (%disk-space-warning-absolute): New variable.
(warn-about-disk-space): Test against %disk-space-warning-absolute.
Fix error in display-hint due to extraneous 'profile' argument.
---
 guix/scripts.scm | 65 +++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 51 insertions(+), 14 deletions(-)

diff --git a/guix/scripts.scm b/guix/scripts.scm
index 77cbf12350..7ad1d5194c 100644
--- a/guix/scripts.scm
+++ b/guix/scripts.scm
@@ -181,32 +181,69 @@ Show what and how will/would be built."
     (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.)))))
+  ;; Return a pair of absolute threshold (number of bytes) and relative
+  ;; threshold (fraction between 0 and 1) for the free disk space below which
+  ;; a warning is emitted.
+  ;; GUIX_DISK_SPACE_WARNING can contain both thresholds.  A value in [0;100)
+  ;; is a relative threshold, otherwise it's absolute.  The following
+  ;; example values are valid:
+  ;; - 1GiB;10%      ;1 GiB absolute, and 10% relative.
+  ;; - 15G           ;15 GiB absolute, and default relative.
+  ;; - 99%           ;99% relative, and default absolute.
+  ;; - 99            ;Same.
+  ;; - 100           ;100 absolute, and default relative.
+  (let* ((default-absolute-threshold (size->number "5GiB"))
+         (default-relative-threshold 0.05)
+         (percentage->float (lambda (percentage)
+                              (or (and=> (string->number
+                                          (car (string-split percentage #\%)))
+                                         (lambda (n) (/ n 100.0)))
+                                  default-relative-threshold)))
+         (size->number* (lambda (size)
+                          (or (false-if-exception (size->number size))
+                              default-absolute-threshold)))
+         (absolute? (lambda (size)
+                      (not (or (string-suffix? "%" size)
+                               (false-if-exception (< (size->number size) 100)))))))
+    (make-parameter
+     (match (getenv "GUIX_DISK_SPACE_WARNING")
+       (#f (list default-absolute-threshold
+                 default-relative-threshold))
+       (env-string (match (string-split env-string #\;)
+                     ((threshold)
+                      (if (absolute? threshold)
+                          (list (size->number* threshold)
+                                default-relative-threshold)
+                          (list default-absolute-threshold
+                                (percentage->float threshold))))
+                     ((threshold1 threshold2)
+                      (if (absolute? threshold1)
+                          (list (size->number* threshold1)
+                                (percentage->float threshold2))
+                          (list (size->number* threshold2)
+                                (percentage->float threshold1))))))))))
 
 (define* (warn-about-disk-space #:optional profile
                                 #:key
-                                (threshold (%disk-space-warning)))
+                                (thresholds (%disk-space-warning)))
   "Display a hint about 'guix gc' if less than THRESHOLD of /gnu/store is
-available."
+available.
+THRESHOLD is a pair of (ABSOLUTE-THRESHOLD RELATIVE-THRESHOLD)."
   (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))
+         (relative-threshold-in-bytes (* total (cadr thresholds)))
+         (absolute-threshold-in-bytes (* 1024 1024 1024 (car thresholds))))
+    (when (< available (min relative-threshold-in-bytes
+                            absolute-threshold-in-bytes))
+      (warning (G_ "only ~,1f GiB of free space available on ~a~%")
+               available (%store-prefix))
       (display-hint (format #f (G_ "Consider deleting old profile
 generations and collecting garbage, along these lines:
 
 @example
 guix gc --delete-generations=1m
-@end example\n")
-                            profile)))))
+@end example\n"))))))
 
 ;;; scripts.scm ends here
-- 
2.25.0

  reply	other threads:[~2020-02-25 10:24 UTC|newest]

Thread overview: 26+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2020-02-22 10:46 [bug#39734] [PATCH] scripts: Emit GC hint if free space is lower than absolute and relative threshold Pierre Neidhardt
2020-02-22 11:12 ` Ludovic Courtès
2020-02-22 11:39   ` Pierre Neidhardt
2020-02-23 11:46     ` Ludovic Courtès
2020-02-23 11:49       ` Pierre Neidhardt
2020-02-23 14:34         ` Ludovic Courtès
2020-02-23 14:41           ` Pierre Neidhardt
2020-02-23 16:09             ` Ludovic Courtès
2020-02-23 16:36               ` Pierre Neidhardt
2020-02-23 21:05               ` Pierre Neidhardt
2020-02-23 21:11                 ` Pierre Neidhardt
2020-02-24 10:21                   ` Ludovic Courtès
2020-02-24 10:26                     ` Pierre Neidhardt
2020-02-24 13:20                       ` Pierre Neidhardt
2020-02-24 21:08                         ` Ludovic Courtès
2020-02-25 10:22                           ` Pierre Neidhardt
2020-02-25 10:23                             ` Pierre Neidhardt [this message]
2020-02-27 23:19                               ` Ludovic Courtès
2020-02-28  7:17                                 ` Pierre Neidhardt
2020-03-05 16:29                                   ` Ludovic Courtès
2020-03-06  7:32                                     ` Pierre Neidhardt
2020-02-26 21:06                             ` bug#39734: " Ludovic Courtès
2020-02-24 13:20                       ` [bug#39734] " Pierre Neidhardt
2020-02-23 21:40                 ` Ludovic Courtès
2020-02-24  7:51                   ` Pierre Neidhardt
2020-02-24  7:52                   ` Pierre Neidhardt

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=20200225102330.4825-1-mail@ambrevar.xyz \
    --to=mail@ambrevar.xyz \
    --cc=39734@debbugs.gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
Code repositories for project(s) associated with this external index

	https://git.savannah.gnu.org/cgit/guix.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.