gnu: Add r-flowsom.

[jackhill/guix/guix.git] / guix / scripts.scm

diff --git a/guix/scripts.scm b/guix/scripts.scm
index d5c53de..77cbf12 100644 (file)
--- a/guix/scripts.scm
+++ b/guix/scripts.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com>
 ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
 ;;;
@@ -26,6 +26,9 @@
   #:use-module (guix monads)
   #:use-module (guix packages)
   #:use-module (guix derivations)
+  #:use-module ((guix profiles) #:select (%profile-directory))
+  #:autoload   (guix describe) (current-profile-date)
+  #:use-module (guix build syscalls)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-37)
@@ -36,7 +39,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:
 ;;;
@@ -67,11 +72,13 @@ reporting."
 
 (define* (parse-command-line args options seeds
                              #:key
+                             (build-options? #t)
                              (argument-handler %default-argument-handler))
-  "Parse the command-line arguments ARGS as well as arguments passed via the
-'GUIX_BUILD_OPTIONS' environment variable according to OPTIONS (a list of
-SRFI-37 options) and return the result, seeded by SEEDS.
-Command-line options take precedence those passed via 'GUIX_BUILD_OPTIONS'.
+  "Parse the command-line arguments ARGS according to OPTIONS (a list of
+SRFI-37 options) and return the result, seeded by SEEDS.  When BUILD-OPTIONS?
+is true, also pass arguments passed via the 'GUIX_BUILD_OPTIONS' environment
+variable.  Command-line options take precedence those passed via
+'GUIX_BUILD_OPTIONS'.
 
 ARGUMENT-HANDLER is called for non-option arguments, like the 'operand-proc'
 parameter of 'args-fold'."
@@ -85,7 +92,9 @@ parameter of 'args-fold'."
 
   (call-with-values
       (lambda ()
-        (parse-options-from (environment-build-options) seeds))
+        (if build-options?
+            (parse-options-from (environment-build-options) seeds)
+            (apply values seeds)))
     (lambda seeds
       ;; ARGS take precedence over what the environment variable specifies.
       (parse-options-from args seeds))))
@@ -150,35 +159,54 @@ Show what and how will/would be built."
                                 #:key (suggested-command
                                        "guix package -u"))
   "Emit a warning if Guix is older than OLD seconds."
-  (let-syntax ((false-if-not-found
-                (syntax-rules ()
-                  ((_ exp)
-                   (catch 'system-error
-                     (lambda ()
-                       exp)
-                     (lambda args
-                       (if (= ENOENT (system-error-errno args))
-                           #f
-                           (apply throw args))))))))
-    (define (seconds->days seconds)
-      (round (/ seconds (* 3600 24))))
-
-    (define age
-      (match (false-if-not-found
-              (lstat (string-append (config-directory) "/latest")))
-        (#f    #f)
-        (stat  (- (time-second (current-time time-utc))
-                  (stat:mtime stat)))))
-
-    (when (and age (>= age old))
-      (warning (N_ "Your Guix installation is ~a day old.\n"
-                   "Your Guix installation is ~a days old.\n"
-                   (seconds->days age))
-               (seconds->days age)))
-    (when (or (not age) (>= age old))
-      (warning (G_ "Consider running 'guix pull' followed by
+  (define (seconds->days seconds)
+    (round (/ seconds (* 3600 24))))
+
+  (define age
+    (match (current-profile-date)
+      (#f    #f)
+      (date  (- (time-second (current-time time-utc))
+                date))))
+
+  (when (and age (>= age old))
+    (warning (N_ "Your Guix installation is ~a day old.\n"
+                 "Your Guix installation is ~a days old.\n"
+                 (seconds->days age))
+             (seconds->days age)))
+  (when (and (or (not age) (>= age old))
+             (not (getenv "GUIX_UNINSTALLED")))
+    (warning (G_ "Consider running 'guix pull' followed by
 '~a' to get up-to-date packages and security updates.\n")
-               suggested-command)
-      (newline (guix-warning-port)))))
+             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))
+      (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)))))
 
 ;;; scripts.scm ends here