guix/scripts.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020, 2021, 2021 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 ;;; Copyright © 2021 Ricardo Wurmus <rekado@elephly.net>
   7 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
   8 ;;;
   9 ;;; This file is part of GNU Guix.
  10 ;;;
  11 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  12 ;;; under the terms of the GNU General Public License as published by
  13 ;;; the Free Software Foundation; either version 3 of the License, or (at
  14 ;;; your option) any later version.
  15 ;;;
  16 ;;; GNU Guix is distributed in the hope that it will be useful, but
  17 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;;; GNU General Public License for more details.
  20 ;;;
  21 ;;; You should have received a copy of the GNU General Public License
  22 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 (define-module (guix scripts)
  25   #:use-module (guix grafts)
  26   #:use-module (guix utils)
  27   #:use-module (guix ui)
  28   #:use-module (guix store)
  29   #:use-module (guix monads)
  30   #:use-module (guix packages)
  31   #:use-module (guix derivations)
  32   #:use-module ((guix profiles) #:select (%profile-directory))
  33   #:autoload   (guix describe) (current-profile-date)
  34   #:use-module (guix build syscalls)
  35   #:use-module (srfi srfi-1)
  36   #:use-module (srfi srfi-19)
  37   #:use-module (srfi srfi-37)
  38   #:use-module (ice-9 match)
  39   #:export (synopsis
  40             category
  41             define-command
  42             %command-categories
  43
  44             args-fold*
  45             parse-command-line
  46             maybe-build
  47             build-package
  48             build-package-source
  49             %distro-age-warning
  50             warn-about-old-distro
  51             %disk-space-warning
  52             warn-about-disk-space))
  53
  54 ;;; Commentary:
  55 ;;;
  56 ;;; General code for Guix scripts.
  57 ;;;
  58 ;;; Code:
  59
  60 ;; Syntactic keywords.
  61 (define synopsis 'command-synopsis)
  62 (define category 'command-category)
  63
  64 (define-syntax define-command-categories
  65   (syntax-rules (G_)
  66     "Define command categories."
  67     ((_ name assert-valid (identifiers (G_ synopses)) ...)
  68      (begin
  69        (define-public identifiers
  70          ;; Define and export syntactic keywords.
  71          (list 'syntactic-keyword-for-command-category))
  72        ...
  73
  74        (define-syntax assert-valid
  75          ;; Validate at expansion time that we're passed a valid category.
  76          (syntax-rules (identifiers ...)
  77            ((_ identifiers) #t)
  78            ...))
  79
  80        (define name
  81          ;; Alist mapping category name to synopsis.
  82          `((identifiers . synopses) ...))))))
  83
  84 ;; Command categories.
  85 (define-command-categories %command-categories
  86   assert-valid-command-category
  87   (main        (G_ "main commands"))
  88   (development (G_ "software development commands"))
  89   (packaging   (G_ "packaging commands"))
  90   (plumbing    (G_ "plumbing commands"))
  91   (internal    (G_ "internal commands"))
  92   (extension   (G_ "extension commands")))
  93
  94 (define-syntax define-command
  95   (syntax-rules (category synopsis)
  96     "Define the given command as a procedure along with its synopsis and,
  97 optionally, its category.  The synopsis becomes the docstring of the
  98 procedure, but both the category and synopsis are meant to be read (parsed) by
  99 'guix help'."
 100     ;; The (synopsis ...) form is here so that xgettext sees those strings as
 101     ;; translatable.
 102     ((_ (name . args)
 103         (synopsis doc) body ...)
 104      (define (name . args)
 105        doc
 106        body ...))
 107     ((_ (name . args)
 108         (category cat) (synopsis doc)
 109         body ...)
 110      (begin
 111        (assert-valid-command-category cat)
 112        (define (name . args)
 113          doc
 114          body ...)))))
 115
 116 (define (option-hint guess options)
 117   "Return the closest long-name OPTIONS from GUESS,
 118 according to'string-distance'."
 119   (define (options->long-names options)
 120     (filter string? (append-map option-names options)))
 121   (match guess
 122     ((? string?)
 123      (match (string-split guess #\=)
 124        ((name rest ...)
 125         (string-closest name (options->long-names options) #:threshold 3))))
 126     (_ #f)))
 127
 128 (define (args-fold* args options unrecognized-option-proc operand-proc . seeds)
 129   "A wrapper on top of `args-fold' that does proper user-facing error
 130 reporting."
 131   (catch 'misc-error
 132     (lambda ()
 133       (apply args-fold args options unrecognized-option-proc
 134              operand-proc seeds))
 135     (lambda (key proc msg args . rest)
 136       ;; XXX: MSG is not i18n'd.
 137       (leave (G_ "invalid argument: ~a~%")
 138              (apply format #f msg args)))))
 139
 140 (define (environment-build-options)
 141   "Return additional build options passed as environment variables."
 142   (arguments-from-environment-variable "GUIX_BUILD_OPTIONS"))
 143
 144 (define %default-argument-handler
 145   ;; The default handler for non-option command-line arguments.
 146   (lambda (arg result)
 147     (alist-cons 'argument arg result)))
 148
 149 (define* (parse-command-line args options seeds
 150                              #:key
 151                              (build-options? #t)
 152                              (argument-handler %default-argument-handler))
 153   "Parse the command-line arguments ARGS according to OPTIONS (a list of
 154 SRFI-37 options) and return the result, seeded by SEEDS.  When BUILD-OPTIONS?
 155 is true, also pass arguments passed via the 'GUIX_BUILD_OPTIONS' environment
 156 variable.  Command-line options take precedence those passed via
 157 'GUIX_BUILD_OPTIONS'.
 158
 159 ARGUMENT-HANDLER is called for non-option arguments, like the 'operand-proc'
 160 parameter of 'args-fold'."
 161   (define (parse-options-from args seeds)
 162     ;; Actual parsing takes place here.
 163     (apply args-fold* args options
 164            (lambda (opt name arg . rest)
 165              (let ((hint (option-hint name options)))
 166                (report-error (G_ "~A: unrecognized option~%") name)
 167                (when hint
 168                  (display-hint
 169                   (format #f (G_ "Did you mean @code{~a}?~%") hint)))
 170                (exit 1)))
 171            argument-handler
 172            seeds))
 173
 174   (call-with-values
 175       (lambda ()
 176         (if build-options?
 177             (parse-options-from (environment-build-options) seeds)
 178             (apply values seeds)))
 179     (lambda seeds
 180       ;; ARGS take precedence over what the environment variable specifies.
 181       (parse-options-from args seeds))))
 182
 183 (define* (maybe-build drvs
 184                       #:key dry-run? use-substitutes?)
 185   "Show what will/would be built, and actually build DRVS, unless DRY-RUN? is
 186 true."
 187   (with-monad %store-monad
 188     (>>= (show-what-to-build* drvs
 189                               #:dry-run? dry-run?
 190                               #:use-substitutes? use-substitutes?)
 191          (lambda (_)
 192            (if dry-run?
 193                (return #f)
 194                (built-derivations drvs))))))
 195
 196 (define* (build-package package
 197                         #:key dry-run? (use-substitutes? #t)
 198                         #:allow-other-keys
 199                         #:rest build-options)
 200   "Build PACKAGE using BUILD-OPTIONS acceptable by 'set-build-options'.
 201 Show what and how will/would be built."
 202   (mlet %store-monad ((grafting? ((lift0 %graft? %store-monad))))
 203     (apply set-build-options*
 204            #:use-substitutes? use-substitutes?
 205            (strip-keyword-arguments '(#:dry-run?) build-options))
 206     (mlet %store-monad ((derivation (package->derivation
 207                                      package #:graft? (and (not dry-run?)
 208                                                            grafting?))))
 209       (mbegin %store-monad
 210         (maybe-build (list derivation)
 211                      #:use-substitutes? use-substitutes?
 212                      #:dry-run? dry-run?)
 213         (return (show-derivation-outputs derivation))))))
 214
 215 (define* (build-package-source package
 216                                #:key dry-run? (use-substitutes? #t)
 217                                #:allow-other-keys
 218                                #:rest build-options)
 219   "Build PACKAGE source using BUILD-OPTIONS."
 220   (mbegin %store-monad
 221     (apply set-build-options*
 222            #:use-substitutes? use-substitutes?
 223            (strip-keyword-arguments '(#:dry-run?) build-options))
 224     (mlet %store-monad ((derivation (origin->derivation
 225                                      (package-source package))))
 226       (mbegin %store-monad
 227         (maybe-build (list derivation)
 228                      #:use-substitutes? use-substitutes?
 229                      #:dry-run? dry-run?)
 230         (return (show-derivation-outputs derivation))))))
 231
 232 (define %distro-age-warning
 233   ;; The age (in seconds) above which we warn that the distro is too old.
 234   (make-parameter (match (and=> (getenv "GUIX_DISTRO_AGE_WARNING")
 235                                 string->duration)
 236                     (#f  (* 7 24 3600))
 237                     (age (time-second age)))))
 238
 239 (define* (warn-about-old-distro #:optional (old (%distro-age-warning))
 240                                 #:key (suggested-command
 241                                        "guix package -u"))
 242   "Emit a warning if Guix is older than OLD seconds."
 243   (define (seconds->days seconds)
 244     (round (/ seconds (* 3600 24))))
 245
 246   (define age
 247     (match (current-profile-date)
 248       (#f    #f)
 249       (date  (- (time-second (current-time time-utc))
 250                 date))))
 251
 252   (when (and age (>= age old))
 253     (warning (N_ "Your Guix installation is ~a day old.\n"
 254                  "Your Guix installation is ~a days old.\n"
 255                  (seconds->days age))
 256              (seconds->days age)))
 257   (when (and (or (not age) (>= age old))
 258              (not (getenv "GUIX_UNINSTALLED")))
 259     (warning (G_ "Consider running 'guix pull' followed by
 260 '~a' to get up-to-date packages and security updates.\n")
 261              suggested-command)
 262     (newline (guix-warning-port))))
 263
 264 (define %disk-space-warning
 265   ;; Return a pair of absolute threshold (number of bytes) and relative
 266   ;; threshold (fraction between 0 and 1) for the free disk space below which
 267   ;; a warning is emitted.
 268   ;; GUIX_DISK_SPACE_WARNING can contain both thresholds.  A value in [0;100)
 269   ;; is a relative threshold, otherwise it's absolute.  The following
 270   ;; example values are valid:
 271   ;; - 1GiB;10%      ;1 GiB absolute, and 10% relative.
 272   ;; - 15G           ;15 GiB absolute, and default relative.
 273   ;; - 99%           ;99% relative, and default absolute.
 274   ;; - 99            ;Same.
 275   ;; - 100           ;100 absolute, and default relative.
 276   (let* ((default-absolute-threshold (size->number "5GiB"))
 277          (default-relative-threshold 0.05)
 278          (percentage->float (lambda (percentage)
 279                               (or (and=> (string->number
 280                                           (car (string-split percentage #\%)))
 281                                          (lambda (n) (/ n 100.0)))
 282                                   default-relative-threshold)))
 283          (size->number* (lambda (size)
 284                           (or (false-if-exception (size->number size))
 285                               default-absolute-threshold)))
 286          (absolute? (lambda (size)
 287                       (not (or (string-suffix? "%" size)
 288                                (false-if-exception (< (size->number size) 100)))))))
 289     (make-parameter
 290      (match (getenv "GUIX_DISK_SPACE_WARNING")
 291        (#f (list default-absolute-threshold
 292                  default-relative-threshold))
 293        (env-string (match (string-split env-string #\;)
 294                      ((threshold)
 295                       (if (absolute? threshold)
 296                           (list (size->number* threshold)
 297                                 default-relative-threshold)
 298                           (list default-absolute-threshold
 299                                 (percentage->float threshold))))
 300                      ((threshold1 threshold2)
 301                       (if (absolute? threshold1)
 302                           (list (size->number* threshold1)
 303                                 (percentage->float threshold2))
 304                           (list (size->number* threshold2)
 305                                 (percentage->float threshold1))))))))))
 306
 307 (define* (warn-about-disk-space #:optional profile
 308                                 #:key
 309                                 (thresholds (%disk-space-warning)))
 310   "Display a hint about 'guix gc' if less than THRESHOLD of /gnu/store is
 311 available.
 312 THRESHOLDS is a pair (ABSOLUTE-THRESHOLD . RELATIVE-THRESHOLD)."
 313   (define GiB (expt 2 30))
 314
 315   (let* ((stats      (statfs (%store-prefix)))
 316          (block-size (file-system-block-size stats))
 317          (available  (* block-size (file-system-blocks-available stats)))
 318          (total      (* block-size (file-system-block-count stats)))
 319          (relative-threshold-in-bytes (* total (cadr thresholds)))
 320          (absolute-threshold-in-bytes (car thresholds)))
 321     (when (< available (min relative-threshold-in-bytes
 322                             absolute-threshold-in-bytes))
 323       (warning (G_ "only ~,1f GiB of free space available on ~a~%")
 324                (/ available 1. GiB) (%store-prefix))
 325       (display-hint (format #f (G_ "Consider deleting old profile
 326 generations and collecting garbage, along these lines:
 327
 328 @example
 329 guix gc --delete-generations=1m
 330 @end example\n"))))))
 331
 332 ;;; scripts.scm ends here