gnu: Add r-flowsom.

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

diff --git a/guix/scripts.scm b/guix/scripts.scm
index bbee50b..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 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,14 +26,22 @@
   #: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)
   #:use-module (ice-9 match)
   #:export (args-fold*
             parse-command-line
             maybe-build
             build-package
-            build-package-source))
+            build-package-source
+            %distro-age-warning
+            warn-about-old-distro
+            %disk-space-warning
+            warn-about-disk-space))
 
 ;;; Commentary:
 ;;;
@@ -50,7 +58,7 @@ reporting."
              operand-proc seeds))
     (lambda (key proc msg args . rest)
       ;; XXX: MSG is not i18n'd.
-      (leave (_ "invalid argument: ~a~%")
+      (leave (G_ "invalid argument: ~a~%")
              (apply format #f msg args)))))
 
 (define (environment-build-options)
@@ -64,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'."
@@ -76,13 +86,15 @@ parameter of 'args-fold'."
     ;; Actual parsing takes place here.
     (apply args-fold* args options
            (lambda (opt name arg . rest)
-             (leave (_ "~A: unrecognized option~%") name))
+             (leave (G_ "~A: unrecognized option~%") name))
            argument-handler
            seeds))
 
   (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))))
@@ -136,4 +148,65 @@ Show what and how will/would be built."
                      #:dry-run? dry-run?)
         (return (show-derivation-outputs derivation))))))
 
+(define %distro-age-warning
+  ;; The age (in seconds) above which we warn that the distro is too old.
+  (make-parameter (match (and=> (getenv "GUIX_DISTRO_AGE_WARNING")
+                                string->duration)
+                    (#f  (* 7 24 3600))
+                    (age (time-second age)))))
+
+(define* (warn-about-old-distro #:optional (old (%distro-age-warning))
+                                #:key (suggested-command
+                                       "guix package -u"))
+  "Emit a warning if Guix is older than OLD seconds."
+  (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))))
+
+(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