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