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.
This commit is contained in:
parent
63abd1e2a3
commit
62a14bd26f
|
@ -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:
|
||||
|
||||
@example
|
||||
guix package -p ~s --delete-generations=1m
|
||||
guix gc
|
||||
@end example\n")
|
||||
profile))
|
||||
(display-hint (G_ "Consider running @command{guix gc} to free
|
||||
space."))))))
|
||||
|
||||
;;; scripts.scm ends here
|
||||
|
|
|
@ -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))))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue