guix/scripts.scm

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