guix/scripts.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com>
   4 ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
   5 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   6 ;;;
   7 ;;; This file is part of GNU Guix.
   8 ;;;
   9 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  10 ;;; under the terms of the GNU General Public License as published by
  11 ;;; the Free Software Foundation; either version 3 of the License, or (at
  12 ;;; your option) any later version.
  13 ;;;
  14 ;;; GNU Guix is distributed in the hope that it will be useful, but
  15 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU General Public License
  20 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 (define-module (guix scripts)
  23   #:use-module (guix grafts)
  24   #:use-module (guix utils)
  25   #:use-module (guix ui)
  26   #:use-module (guix store)
  27   #:use-module (guix monads)
  28   #:use-module (guix packages)
  29   #:use-module (guix derivations)
  30   #:use-module ((guix profiles) #:select (%profile-directory))
  31   #:autoload   (guix describe) (current-profile-date)
  32   #:use-module (guix build syscalls)
  33   #:use-module (srfi srfi-1)
  34   #:use-module (srfi srfi-19)
  35   #:use-module (srfi srfi-37)
  36   #:use-module (ice-9 match)
  37   #:export (args-fold*
  38             parse-command-line
  39             maybe-build
  40             build-package
  41             build-package-source
  42             %distro-age-warning
  43             warn-about-old-distro
  44             %disk-space-warning
  45             warn-about-disk-space))
  46
  47 ;;; Commentary:
  48 ;;;
  49 ;;; General code for Guix scripts.
  50 ;;;
  51 ;;; Code:
  52
  53 (define (args-fold* args options unrecognized-option-proc operand-proc . seeds)
  54   "A wrapper on top of `args-fold' that does proper user-facing error
  55 reporting."
  56   (catch 'misc-error
  57     (lambda ()
  58       (apply args-fold args options unrecognized-option-proc
  59              operand-proc seeds))
  60     (lambda (key proc msg args . rest)
  61       ;; XXX: MSG is not i18n'd.
  62       (leave (G_ "invalid argument: ~a~%")
  63              (apply format #f msg args)))))
  64
  65 (define (environment-build-options)
  66   "Return additional build options passed as environment variables."
  67   (arguments-from-environment-variable "GUIX_BUILD_OPTIONS"))
  68
  69 (define %default-argument-handler
  70   ;; The default handler for non-option command-line arguments.
  71   (lambda (arg result)
  72     (alist-cons 'argument arg result)))
  73
  74 (define* (parse-command-line args options seeds
  75                              #:key
  76                              (build-options? #t)
  77                              (argument-handler %default-argument-handler))
  78   "Parse the command-line arguments ARGS according to OPTIONS (a list of
  79 SRFI-37 options) and return the result, seeded by SEEDS.  When BUILD-OPTIONS?
  80 is true, also pass arguments passed via the 'GUIX_BUILD_OPTIONS' environment
  81 variable.  Command-line options take precedence those passed via
  82 'GUIX_BUILD_OPTIONS'.
  83
  84 ARGUMENT-HANDLER is called for non-option arguments, like the 'operand-proc'
  85 parameter of 'args-fold'."
  86   (define (parse-options-from args seeds)
  87     ;; Actual parsing takes place here.
  88     (apply args-fold* args options
  89            (lambda (opt name arg . rest)
  90              (leave (G_ "~A: unrecognized option~%") name))
  91            argument-handler
  92            seeds))
  93
  94   (call-with-values
  95       (lambda ()
  96         (if build-options?
  97             (parse-options-from (environment-build-options) seeds)
  98             (apply values seeds)))
  99     (lambda seeds
 100       ;; ARGS take precedence over what the environment variable specifies.
 101       (parse-options-from args seeds))))
 102
 103 (define* (maybe-build drvs
 104                       #:key dry-run? use-substitutes?)
 105   "Show what will/would be built, and actually build DRVS, unless DRY-RUN? is
 106 true."
 107   (with-monad %store-monad
 108     (>>= (show-what-to-build* drvs
 109                               #:dry-run? dry-run?
 110                               #:use-substitutes? use-substitutes?)
 111          (lambda (_)
 112            (if dry-run?
 113                (return #f)
 114                (built-derivations drvs))))))
 115
 116 (define* (build-package package
 117                         #:key dry-run? (use-substitutes? #t)
 118                         #:allow-other-keys
 119                         #:rest build-options)
 120   "Build PACKAGE using BUILD-OPTIONS acceptable by 'set-build-options'.
 121 Show what and how will/would be built."
 122   (mlet %store-monad ((grafting? ((lift0 %graft? %store-monad))))
 123     (apply set-build-options*
 124            #:use-substitutes? use-substitutes?
 125            (strip-keyword-arguments '(#:dry-run?) build-options))
 126     (mlet %store-monad ((derivation (package->derivation
 127                                      package #:graft? (and (not dry-run?)
 128                                                            grafting?))))
 129       (mbegin %store-monad
 130         (maybe-build (list derivation)
 131                      #:use-substitutes? use-substitutes?
 132                      #:dry-run? dry-run?)
 133         (return (show-derivation-outputs derivation))))))
 134
 135 (define* (build-package-source package
 136                                #:key dry-run? (use-substitutes? #t)
 137                                #:allow-other-keys
 138                                #:rest build-options)
 139   "Build PACKAGE source using BUILD-OPTIONS."
 140   (mbegin %store-monad
 141     (apply set-build-options*
 142            #:use-substitutes? use-substitutes?
 143            (strip-keyword-arguments '(#:dry-run?) build-options))
 144     (mlet %store-monad ((derivation (origin->derivation
 145                                      (package-source package))))
 146       (mbegin %store-monad
 147         (maybe-build (list derivation)
 148                      #:use-substitutes? use-substitutes?
 149                      #:dry-run? dry-run?)
 150         (return (show-derivation-outputs derivation))))))
 151
 152 (define %distro-age-warning
 153   ;; The age (in seconds) above which we warn that the distro is too old.
 154   (make-parameter (match (and=> (getenv "GUIX_DISTRO_AGE_WARNING")
 155                                 string->duration)
 156                     (#f  (* 7 24 3600))
 157                     (age (time-second age)))))
 158
 159 (define* (warn-about-old-distro #:optional (old (%distro-age-warning))
 160                                 #:key (suggested-command
 161                                        "guix package -u"))
 162   "Emit a warning if Guix is older than OLD seconds."
 163   (define (seconds->days seconds)
 164     (round (/ seconds (* 3600 24))))
 165
 166   (define age
 167     (match (current-profile-date)
 168       (#f    #f)
 169       (date  (- (time-second (current-time time-utc))
 170                 date))))
 171
 172   (when (and age (>= age old))
 173     (warning (N_ "Your Guix installation is ~a day old.\n"
 174                  "Your Guix installation is ~a days old.\n"
 175                  (seconds->days age))
 176              (seconds->days age)))
 177   (when (and (or (not age) (>= age old))
 178              (not (getenv "GUIX_UNINSTALLED")))
 179     (warning (G_ "Consider running 'guix pull' followed by
 180 '~a' to get up-to-date packages and security updates.\n")
 181              suggested-command)
 182     (newline (guix-warning-port))))
 183
 184 (define %disk-space-warning
 185   ;; Return a pair of absolute threshold (number of bytes) and relative
 186   ;; threshold (fraction between 0 and 1) for the free disk space below which
 187   ;; a warning is emitted.
 188   ;; GUIX_DISK_SPACE_WARNING can contain both thresholds.  A value in [0;100)
 189   ;; is a relative threshold, otherwise it's absolute.  The following
 190   ;; example values are valid:
 191   ;; - 1GiB;10%      ;1 GiB absolute, and 10% relative.
 192   ;; - 15G           ;15 GiB absolute, and default relative.
 193   ;; - 99%           ;99% relative, and default absolute.
 194   ;; - 99            ;Same.
 195   ;; - 100           ;100 absolute, and default relative.
 196   (let* ((default-absolute-threshold (size->number "5GiB"))
 197          (default-relative-threshold 0.05)
 198          (percentage->float (lambda (percentage)
 199                               (or (and=> (string->number
 200                                           (car (string-split percentage #\%)))
 201                                          (lambda (n) (/ n 100.0)))
 202                                   default-relative-threshold)))
 203          (size->number* (lambda (size)
 204                           (or (false-if-exception (size->number size))
 205                               default-absolute-threshold)))
 206          (absolute? (lambda (size)
 207                       (not (or (string-suffix? "%" size)
 208                                (false-if-exception (< (size->number size) 100)))))))
 209     (make-parameter
 210      (match (getenv "GUIX_DISK_SPACE_WARNING")
 211        (#f (list default-absolute-threshold
 212                  default-relative-threshold))
 213        (env-string (match (string-split env-string #\;)
 214                      ((threshold)
 215                       (if (absolute? threshold)
 216                           (list (size->number* threshold)
 217                                 default-relative-threshold)
 218                           (list default-absolute-threshold
 219                                 (percentage->float threshold))))
 220                      ((threshold1 threshold2)
 221                       (if (absolute? threshold1)
 222                           (list (size->number* threshold1)
 223                                 (percentage->float threshold2))
 224                           (list (size->number* threshold2)
 225                                 (percentage->float threshold1))))))))))
 226
 227 (define* (warn-about-disk-space #:optional profile
 228                                 #:key
 229                                 (thresholds (%disk-space-warning)))
 230   "Display a hint about 'guix gc' if less than THRESHOLD of /gnu/store is
 231 available.
 232 THRESHOLDS is a pair (ABSOLUTE-THRESHOLD . RELATIVE-THRESHOLD)."
 233   (define GiB (expt 2 30))
 234
 235   (let* ((stats      (statfs (%store-prefix)))
 236          (block-size (file-system-block-size stats))
 237          (available  (* block-size (file-system-blocks-available stats)))
 238          (total      (* block-size (file-system-block-count stats)))
 239          (relative-threshold-in-bytes (* total (cadr thresholds)))
 240          (absolute-threshold-in-bytes (car thresholds)))
 241     (when (< available (min relative-threshold-in-bytes
 242                             absolute-threshold-in-bytes))
 243       (warning (G_ "only ~,1f GiB of free space available on ~a~%")
 244                (/ available 1. GiB) (%store-prefix))
 245       (display-hint (format #f (G_ "Consider deleting old profile
 246 generations and collecting garbage, along these lines:
 247
 248 @example
 249 guix gc --delete-generations=1m
 250 @end example\n"))))))
 251
 252 ;;; scripts.scm ends here