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