| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> |
| 3 | ;;; Copyright © 2013, 2018 Mark H Weaver <mhw@netris.org> |
| 4 | ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> |
| 5 | ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com> |
| 6 | ;;; Copyright © 2014 Cyrill Schenkel <cyrill.schenkel@gmail.com> |
| 7 | ;;; Copyright © 2014, 2015, 2017 Alex Kost <alezost@gmail.com> |
| 8 | ;;; Copyright © 2015 David Thompson <davet@gnu.org> |
| 9 | ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> |
| 10 | ;;; Copyright © 2016 Roel Janssen <roel@gnu.org> |
| 11 | ;;; Copyright © 2016 Benz Schenk <benz.schenk@uzh.ch> |
| 12 | ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> |
| 13 | ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> |
| 14 | ;;; Copyright © 2019 Chris Marusich <cmmarusich@gmail.com> |
| 15 | ;;; Copyright © 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr> |
| 16 | ;;; Copyright © 2019, 2021 Simon Tournier <zimon.toutoune@gmail.com> |
| 17 | ;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net> |
| 18 | ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> |
| 19 | ;;; |
| 20 | ;;; This file is part of GNU Guix. |
| 21 | ;;; |
| 22 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
| 23 | ;;; under the terms of the GNU General Public License as published by |
| 24 | ;;; the Free Software Foundation; either version 3 of the License, or (at |
| 25 | ;;; your option) any later version. |
| 26 | ;;; |
| 27 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
| 28 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
| 29 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 30 | ;;; GNU General Public License for more details. |
| 31 | ;;; |
| 32 | ;;; You should have received a copy of the GNU General Public License |
| 33 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
| 34 | |
| 35 | (define-module (guix ui) |
| 36 | #:use-module (guix i18n) |
| 37 | #:use-module (guix colors) |
| 38 | #:use-module (guix diagnostics) |
| 39 | #:use-module (guix gexp) |
| 40 | #:use-module (guix sets) |
| 41 | #:use-module (guix utils) |
| 42 | #:use-module (guix store) |
| 43 | #:use-module (guix config) |
| 44 | #:use-module (guix packages) |
| 45 | #:use-module (guix profiles) |
| 46 | #:use-module (guix derivations) |
| 47 | #:use-module (guix build-system) |
| 48 | #:use-module (guix serialization) |
| 49 | #:use-module ((guix licenses) |
| 50 | #:select (license? license-name license-uri)) |
| 51 | #:use-module ((guix build syscalls) |
| 52 | #:select (free-disk-space terminal-columns terminal-rows |
| 53 | with-file-lock/no-wait)) |
| 54 | #:use-module ((guix build utils) |
| 55 | ;; XXX: All we need are the bindings related to |
| 56 | ;; '&invoke-error'. However, to work around the bug described |
| 57 | ;; in 5d669883ecc104403c5d3ba7d172e9c02234577c, #:hide |
| 58 | ;; unwanted bindings instead of #:select'ing the needed |
| 59 | ;; bindings. |
| 60 | #:hide (package-name->name+version |
| 61 | ;; Avoid "overrides core binding" warning. |
| 62 | delete)) |
| 63 | #:use-module (srfi srfi-1) |
| 64 | #:use-module (srfi srfi-9 gnu) |
| 65 | #:use-module (srfi srfi-11) |
| 66 | #:use-module (srfi srfi-19) |
| 67 | #:use-module (srfi srfi-26) |
| 68 | #:use-module (srfi srfi-31) |
| 69 | #:use-module (srfi srfi-34) |
| 70 | #:use-module (srfi srfi-35) |
| 71 | #:autoload (ice-9 ftw) (scandir) |
| 72 | #:use-module (ice-9 match) |
| 73 | #:use-module (ice-9 format) |
| 74 | #:use-module (ice-9 regex) |
| 75 | #:autoload (ice-9 popen) (open-pipe* close-pipe) |
| 76 | #:autoload (system base compile) (compile-file) |
| 77 | #:autoload (system repl repl) (start-repl) |
| 78 | #:autoload (system repl debug) (make-debug stack->vector) |
| 79 | #:autoload (web uri) (encode-and-join-uri-path) |
| 80 | #:use-module (texinfo) |
| 81 | #:use-module (texinfo plain-text) |
| 82 | #:use-module (texinfo string-utils) |
| 83 | |
| 84 | ;; Re-exports for backward compatibility. |
| 85 | #:re-export (G_ N_ P_ ;now in (guix i18n) |
| 86 | |
| 87 | warning info report-error leave ;now in (guix diagnostics) |
| 88 | location->string |
| 89 | guix-warning-port program-name) |
| 90 | #:export (display-hint |
| 91 | make-user-module |
| 92 | load* |
| 93 | warn-about-load-error |
| 94 | show-version-and-exit |
| 95 | show-bug-report-information |
| 96 | make-regexp* |
| 97 | string->number* |
| 98 | size->number |
| 99 | show-derivation-outputs |
| 100 | build-notifier |
| 101 | show-what-to-build |
| 102 | show-what-to-build* |
| 103 | show-manifest-transaction |
| 104 | guard* |
| 105 | call-with-error-handling |
| 106 | with-error-handling |
| 107 | with-unbound-variable-handling |
| 108 | leave-on-EPIPE |
| 109 | read/eval |
| 110 | read/eval-package-expression |
| 111 | check-available-space |
| 112 | indented-string |
| 113 | fill-paragraph |
| 114 | %text-width |
| 115 | texi->plain-text |
| 116 | package-description-string |
| 117 | package-synopsis-string |
| 118 | string->recutils |
| 119 | package->recutils |
| 120 | package-specification->name+version+output |
| 121 | |
| 122 | supports-hyperlinks? |
| 123 | hyperlink |
| 124 | file-hyperlink |
| 125 | location->hyperlink |
| 126 | |
| 127 | with-paginated-output-port |
| 128 | relevance |
| 129 | package-relevance |
| 130 | display-search-results |
| 131 | |
| 132 | with-profile-lock |
| 133 | string->generations |
| 134 | string->duration |
| 135 | matching-generations |
| 136 | display-generation |
| 137 | display-profile-content |
| 138 | display-profile-content-diff |
| 139 | roll-back* |
| 140 | switch-to-generation* |
| 141 | delete-generation* |
| 142 | |
| 143 | %default-message-language |
| 144 | current-message-language |
| 145 | |
| 146 | run-guix-command |
| 147 | run-guix |
| 148 | guix-main)) |
| 149 | |
| 150 | ;;; Commentary: |
| 151 | ;;; |
| 152 | ;;; User interface facilities for command-line tools. |
| 153 | ;;; |
| 154 | ;;; Code: |
| 155 | |
| 156 | (define (print-unbound-variable-error port key args default-printer) |
| 157 | ;; Print unbound variable errors more nicely, and in the right language. |
| 158 | (match args |
| 159 | ((proc message (variable) _ ...) |
| 160 | ;; We can always omit PROC because when it's useful (i.e., different from |
| 161 | ;; "module-lookup"), it gets displayed before. |
| 162 | (format port (G_ "error: ~a: unbound variable") variable)) |
| 163 | (_ |
| 164 | (default-printer)))) |
| 165 | |
| 166 | (set-exception-printer! 'unbound-variable print-unbound-variable-error) |
| 167 | |
| 168 | (define (make-user-module modules) |
| 169 | "Return a new user module with the additional MODULES loaded." |
| 170 | ;; Module in which the machine description file is loaded. |
| 171 | (let ((module (make-fresh-user-module))) |
| 172 | (for-each (lambda (iface) |
| 173 | (module-use! module (resolve-interface iface))) |
| 174 | modules) |
| 175 | module)) |
| 176 | |
| 177 | (define (last-frame-with-source stack) |
| 178 | "Walk stack upwards and return the last frame that has source location |
| 179 | information, or #f if it could not be found." |
| 180 | (define (frame-with-source frame) |
| 181 | ;; Walk from FRAME upwards until source location information is found. |
| 182 | (let loop ((frame frame) |
| 183 | (previous frame)) |
| 184 | (if (not frame) |
| 185 | previous |
| 186 | |
| 187 | ;; On Guile 3, the latest frame with source may be that of |
| 188 | ;; 'raise-exception' in boot-9.scm. Skip it. |
| 189 | (if (and (frame-source frame) |
| 190 | (not (eq? 'raise-exception (frame-procedure-name frame)))) |
| 191 | frame |
| 192 | (loop (frame-previous frame) frame))))) |
| 193 | |
| 194 | (let* ((depth (stack-length stack)) |
| 195 | (last (and (> depth 0) (stack-ref stack 0)))) |
| 196 | (frame-with-source (if (> depth 1) |
| 197 | (stack-ref stack 1) ;skip the 'throw' frame |
| 198 | last)))) |
| 199 | |
| 200 | (define* (load* file user-module |
| 201 | #:key (on-error 'nothing-special)) |
| 202 | "Load the user provided Scheme source code FILE." |
| 203 | (define (error-string frame args) |
| 204 | (call-with-output-string |
| 205 | (lambda (port) |
| 206 | (apply display-error frame port (cdr args))))) |
| 207 | |
| 208 | (define tag |
| 209 | (make-prompt-tag "user-code")) |
| 210 | |
| 211 | (catch #t |
| 212 | (lambda () |
| 213 | ;; XXX: Force a recompilation to avoid ABI issues. |
| 214 | ;; |
| 215 | ;; In 2.2.3, the bogus answer to <https://bugs.gnu.org/29226> was to |
| 216 | ;; ignore all available .go, not just those from ~/.cache, which in turn |
| 217 | ;; meant that we had to rebuild *everything*. Since this is too costly, |
| 218 | ;; we have to turn off '%fresh-auto-compile' with that version, so to |
| 219 | ;; avoid ABI breakage in the user's config file, we explicitly compile |
| 220 | ;; it (the problem remains if the user's config is spread on several |
| 221 | ;; modules.) See <https://bugs.gnu.org/29881>. |
| 222 | (unless (string=? (version) "2.2.3") |
| 223 | (set! %fresh-auto-compile #t)) |
| 224 | |
| 225 | (set! %load-should-auto-compile #t) |
| 226 | |
| 227 | (save-module-excursion |
| 228 | (lambda () |
| 229 | (set-current-module user-module) |
| 230 | |
| 231 | ;; Hide the "auto-compiling" messages. |
| 232 | (parameterize ((current-warning-port (%make-void-port "w"))) |
| 233 | (call-with-prompt tag |
| 234 | (lambda () |
| 235 | (when (string=? (version) "2.2.3") |
| 236 | (catch 'system-error |
| 237 | (lambda () |
| 238 | (compile-file file #:env user-module)) |
| 239 | (const #f))) ;EACCES maybe, let's interpret it |
| 240 | |
| 241 | ;; Give 'load' an absolute file name so that it doesn't try to |
| 242 | ;; search for FILE in %LOAD-PATH. Note: use 'load', not |
| 243 | ;; 'primitive-load', so that FILE is compiled, which then allows |
| 244 | ;; us to provide better error reporting with source line numbers. |
| 245 | (load (canonicalize-path file))) |
| 246 | (const #f)))))) |
| 247 | (lambda _ |
| 248 | ;; XXX: Errors are reported from the pre-unwind handler below, but |
| 249 | ;; calling 'exit' from there has no effect, so we call it here. |
| 250 | (exit 1)) |
| 251 | (rec (handle-error . args) |
| 252 | ;; Capture the stack up to this procedure call, excluded, and pass |
| 253 | ;; the faulty stack frame to 'report-load-error'. |
| 254 | (let* ((stack (make-stack #t handle-error tag)) |
| 255 | (frame (last-frame-with-source stack))) |
| 256 | |
| 257 | (report-load-error file args frame) |
| 258 | |
| 259 | (case on-error |
| 260 | ((debug) |
| 261 | (newline) |
| 262 | (display (G_ "entering debugger; type ',bt' for a backtrace\n")) |
| 263 | (start-repl #:debug (make-debug (stack->vector stack) 0 |
| 264 | (error-string frame args) |
| 265 | #f))) |
| 266 | ((backtrace) |
| 267 | (newline (current-error-port)) |
| 268 | (display-backtrace stack (current-error-port))) |
| 269 | (else |
| 270 | #t)))))) |
| 271 | |
| 272 | (define (known-variable-definition variable) |
| 273 | "Search among the currently loaded modules one that defines a variable named |
| 274 | VARIABLE and return it, or #f if none was found." |
| 275 | (define (module<? m1 m2) |
| 276 | (match (module-name m2) |
| 277 | (('gnu _ ...) #t) |
| 278 | (('guix _ ...) |
| 279 | (match (module-name m1) |
| 280 | (('gnu _ ...) #f) |
| 281 | (_ #t))) |
| 282 | (_ #f))) |
| 283 | |
| 284 | (let loop ((modules (list (resolve-module '() #f #f #:ensure #f))) |
| 285 | (suggestions '()) |
| 286 | (visited (setq))) |
| 287 | (match modules |
| 288 | (() |
| 289 | ;; Pick the "best" suggestion. |
| 290 | (match (sort suggestions module<?) |
| 291 | (() #f) |
| 292 | ((first _ ...) first))) |
| 293 | ((head tail ...) |
| 294 | (if (set-contains? visited head) |
| 295 | (loop tail suggestions visited) |
| 296 | (let ((visited (set-insert head visited)) |
| 297 | (next (append tail |
| 298 | (hash-map->list (lambda (name module) |
| 299 | module) |
| 300 | (module-submodules head))))) |
| 301 | (match (and=> (module-public-interface head) |
| 302 | (cut module-local-variable <> variable)) |
| 303 | (#f (loop next suggestions visited)) |
| 304 | (_ |
| 305 | (match (module-name head) |
| 306 | (('gnu _ ...) head) ;must be that one |
| 307 | (_ (loop next (cons head suggestions) visited))))))))))) |
| 308 | |
| 309 | (define %hint-color (color BOLD CYAN)) |
| 310 | |
| 311 | (define* (display-hint message #:optional (port (current-error-port))) |
| 312 | "Display MESSAGE, a l10n message possibly containing Texinfo markup, to |
| 313 | PORT." |
| 314 | (define colorize |
| 315 | (if (color-output? port) |
| 316 | (lambda (str) |
| 317 | (colorize-string str %hint-color)) |
| 318 | identity)) |
| 319 | |
| 320 | (display (colorize (G_ "hint: ")) port) |
| 321 | (display |
| 322 | ;; XXX: We should arrange so that the initial indent is wider. |
| 323 | (parameterize ((%text-width (max 15 (- (terminal-columns) 5)))) |
| 324 | (texi->plain-text message)) |
| 325 | port)) |
| 326 | |
| 327 | (define* (report-unbound-variable-error args #:key frame) |
| 328 | "Return the given unbound-variable error, where ARGS is the list of 'throw' |
| 329 | arguments." |
| 330 | (match args |
| 331 | ((key . args) |
| 332 | (print-exception (current-error-port) frame key args))) |
| 333 | (match args |
| 334 | (('unbound-variable proc message (variable) _ ...) |
| 335 | (match (known-variable-definition variable) |
| 336 | (#f |
| 337 | (display-hint (G_ "Did you forget a @code{use-modules} form?"))) |
| 338 | ((? module? module) |
| 339 | (display-hint (format #f (G_ "Did you forget @code{(use-modules ~a)}?") |
| 340 | (module-name module)))))))) |
| 341 | |
| 342 | (define (check-module-matches-file module file) |
| 343 | "Check whether FILE starts with 'define-module MODULE' and print a hint if |
| 344 | it doesn't." |
| 345 | ;; This is a common mistake when people start writing their own package |
| 346 | ;; definitions and try loading them with 'guix build -L …', so help them |
| 347 | ;; diagnose the problem. |
| 348 | (define (hint) |
| 349 | (display-hint (format #f (G_ "File @file{~a} should probably start with: |
| 350 | |
| 351 | @example\n(define-module ~a)\n@end example") |
| 352 | file module))) |
| 353 | |
| 354 | (catch 'system-error |
| 355 | (lambda () |
| 356 | (let* ((sexp (call-with-input-file file read)) |
| 357 | (loc (and (pair? sexp) |
| 358 | (source-properties->location (source-properties sexp))))) |
| 359 | (match sexp |
| 360 | (('define-module (names ...) _ ...) |
| 361 | (unless (equal? module names) |
| 362 | (warning loc |
| 363 | (G_ "module name ~a does not match file name '~a'~%") |
| 364 | names (module->source-file-name module)) |
| 365 | (hint))) |
| 366 | ((? eof-object?) |
| 367 | (warning (G_ "~a: file is empty~%") file)) |
| 368 | (else |
| 369 | (hint))))) |
| 370 | (const #f))) |
| 371 | |
| 372 | (define* (report-load-error file args #:optional frame) |
| 373 | "Report the failure to load FILE, a user-provided Scheme file. |
| 374 | ARGS is the list of arguments received by the 'throw' handler." |
| 375 | (match args |
| 376 | (('system-error . rest) |
| 377 | (let ((err (system-error-errno args))) |
| 378 | (report-error (G_ "failed to load '~a': ~a~%") file (strerror err)))) |
| 379 | (('read-error "scm_i_lreadparen" message _ ...) |
| 380 | ;; Guile's missing-paren messages are obscure so we make them more |
| 381 | ;; intelligible here. |
| 382 | (if (string-suffix? "end of file" message) |
| 383 | (let ((location (string-drop-right message |
| 384 | (string-length "end of file")))) |
| 385 | (format (current-error-port) (G_ "~amissing closing parenthesis~%") |
| 386 | location)) |
| 387 | (apply throw args))) |
| 388 | (('syntax-error proc message properties form subform . rest) |
| 389 | (let ((loc (source-properties->location properties))) |
| 390 | (report-error loc (G_ "~s: ~a~%") |
| 391 | (or subform form) message))) |
| 392 | (('unbound-variable _ ...) |
| 393 | (report-unbound-variable-error args #:frame frame)) |
| 394 | (((or 'srfi-34 '%exception) obj) |
| 395 | (cond ((message-condition? obj) |
| 396 | (report-error (and (error-location? obj) |
| 397 | (error-location obj)) |
| 398 | (G_ "~a~%") |
| 399 | (gettext (condition-message obj) %gettext-domain))) |
| 400 | ((formatted-message? obj) |
| 401 | (apply report-error |
| 402 | (and (error-location? obj) (error-location obj)) |
| 403 | (gettext (formatted-message-string obj) %gettext-domain) |
| 404 | (formatted-message-arguments obj))) |
| 405 | (else |
| 406 | (report-error (G_ "exception thrown: ~s~%") obj))) |
| 407 | (when (fix-hint? obj) |
| 408 | (display-hint (condition-fix-hint obj)))) |
| 409 | ((key args ...) |
| 410 | (report-error (G_ "failed to load '~a':~%") file) |
| 411 | (match args |
| 412 | (((? symbol? proc) (? string? message) (args ...) . rest) |
| 413 | (display-error frame (current-error-port) proc message |
| 414 | args rest)) |
| 415 | (_ |
| 416 | ;; Some exceptions like 'git-error' do not follow Guile's convention |
| 417 | ;; above and need to be printed with 'print-exception'. |
| 418 | (print-exception (current-error-port) frame key args)))))) |
| 419 | |
| 420 | (define (warn-about-load-error file module args) ;FIXME: factorize with ↑ |
| 421 | "Report the failure to load FILE, a user-provided Scheme file, without |
| 422 | exiting. ARGS is the list of arguments received by the 'throw' handler." |
| 423 | (match args |
| 424 | (('system-error . rest) |
| 425 | (let ((err (system-error-errno args))) |
| 426 | (warning (G_ "failed to load '~a': ~a~%") module (strerror err)))) |
| 427 | (('syntax-error proc message properties form . rest) |
| 428 | (let ((loc (source-properties->location properties))) |
| 429 | (warning loc (G_ "~a~%") message))) |
| 430 | (('unbound-variable _ ...) |
| 431 | (report-unbound-variable-error args)) |
| 432 | (((or 'srfi-34 '%exception) obj) |
| 433 | (cond ((message-condition? obj) |
| 434 | (warning (G_ "failed to load '~a': ~a~%") |
| 435 | file |
| 436 | (gettext (condition-message obj) %gettext-domain))) |
| 437 | ((formatted-message? obj) |
| 438 | (warning (G_ "failed to load '~a': ~a~%") |
| 439 | file |
| 440 | (apply format #f |
| 441 | (gettext (formatted-message-string obj) |
| 442 | %gettext-domain) |
| 443 | (formatted-message-arguments obj)))) |
| 444 | (else |
| 445 | (warning (G_ "failed to load '~a': exception thrown: ~s~%") |
| 446 | file obj)))) |
| 447 | ((error args ...) |
| 448 | (warning (G_ "failed to load '~a':~%") module) |
| 449 | (apply display-error #f (current-error-port) args) |
| 450 | (check-module-matches-file module file)))) |
| 451 | |
| 452 | (define (call-with-unbound-variable-handling thunk) |
| 453 | (define tag |
| 454 | (make-prompt-tag "user-code")) |
| 455 | |
| 456 | (catch 'unbound-variable |
| 457 | (lambda () |
| 458 | (call-with-prompt tag |
| 459 | thunk |
| 460 | (const #f))) |
| 461 | (const #t) |
| 462 | (rec (handle-error . args) |
| 463 | (let* ((stack (make-stack #t handle-error tag)) |
| 464 | (frame (and stack (last-frame-with-source stack)))) |
| 465 | (report-unbound-variable-error args #:frame frame) |
| 466 | (exit 1))))) |
| 467 | |
| 468 | (define-syntax-rule (with-unbound-variable-handling exp ...) |
| 469 | "Capture 'unbound-variable' exceptions in the dynamic extent of EXP... and |
| 470 | report them in a user-friendly way." |
| 471 | (call-with-unbound-variable-handling (lambda () exp ...))) |
| 472 | |
| 473 | (define %default-message-language |
| 474 | ;; Default language to use for messages. |
| 475 | (make-parameter "en")) |
| 476 | |
| 477 | (define (current-message-language) |
| 478 | "Return the language used for messages according to the current locale. |
| 479 | Return %DEFAULT-MESSAGE-LANGUAGE if that information could not be obtained. The |
| 480 | result is an ISO-639-2 language code such as \"ar\", without the territory |
| 481 | part." |
| 482 | (let ((locale (setlocale LC_MESSAGES))) |
| 483 | (match (string-index locale #\_) |
| 484 | (#f locale) |
| 485 | (index (string-take locale index))))) |
| 486 | |
| 487 | (define (install-locale) |
| 488 | "Install the current locale settings." |
| 489 | (catch 'system-error |
| 490 | (lambda _ |
| 491 | (setlocale LC_ALL "")) |
| 492 | (lambda args |
| 493 | (display-hint (G_ "Consider installing the @code{glibc-utf8-locales} or |
| 494 | @code{glibc-locales} package and defining @code{GUIX_LOCPATH}, along these |
| 495 | lines: |
| 496 | |
| 497 | @example |
| 498 | guix install glibc-utf8-locales |
| 499 | export GUIX_LOCPATH=\"$HOME/.guix-profile/lib/locale\" |
| 500 | @end example |
| 501 | |
| 502 | See the \"Application Setup\" section in the manual, for more info.\n")) |
| 503 | ;; We're now running in the "C" locale. Try to install a UTF-8 locale |
| 504 | ;; instead. This one is guaranteed to be available in 'guix' from 'guix |
| 505 | ;; pull'. |
| 506 | (false-if-exception (setlocale LC_ALL "en_US.utf8"))))) |
| 507 | |
| 508 | (define (initialize-guix) |
| 509 | "Perform the usual initialization for stand-alone Guix commands." |
| 510 | ;; By default don't annoy users with deprecation warnings. In practice, |
| 511 | ;; 'define-deprecated' in (ice-9 deprecated) arranges so that those warnings |
| 512 | ;; are emitted at expansion-time only, but there are cases where they could |
| 513 | ;; slip through, for instance when interpreting code. |
| 514 | (unless (getenv "GUILE_WARN_DEPRECATED") |
| 515 | (debug-disable 'warn-deprecated)) |
| 516 | |
| 517 | (install-locale) |
| 518 | (textdomain %gettext-domain) |
| 519 | |
| 520 | ;; Ignore SIGPIPE. If the daemon closes the connection, we prefer to be |
| 521 | ;; notified via an EPIPE later. |
| 522 | (sigaction SIGPIPE SIG_IGN) |
| 523 | |
| 524 | (setvbuf (current-output-port) 'line) |
| 525 | (setvbuf (current-error-port) 'line)) |
| 526 | |
| 527 | (define* (show-version-and-exit #:optional (command (car (command-line)))) |
| 528 | "Display version information for COMMAND and `(exit 0)'." |
| 529 | (simple-format #t "~a (~a) ~a~%" |
| 530 | command %guix-package-name %guix-version) |
| 531 | (format #t "Copyright ~a 2021 ~a" |
| 532 | ;; TRANSLATORS: Translate "(C)" to the copyright symbol |
| 533 | ;; (C-in-a-circle), if this symbol is available in the user's |
| 534 | ;; locale. Otherwise, do not translate "(C)"; leave it as-is. */ |
| 535 | (G_ "(C)") |
| 536 | (G_ "the Guix authors\n")) |
| 537 | (display (G_"\ |
| 538 | License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html> |
| 539 | This is free software: you are free to change and redistribute it. |
| 540 | There is NO WARRANTY, to the extent permitted by law. |
| 541 | ")) |
| 542 | (exit 0)) |
| 543 | |
| 544 | (define (show-bug-report-information) |
| 545 | ;; TRANSLATORS: The placeholder indicates the bug-reporting address for this |
| 546 | ;; package. Please add another line saying "Report translation bugs to |
| 547 | ;; ...\n" with the address for translation bugs (typically your translation |
| 548 | ;; team's web or email address). |
| 549 | (format #t (G_ " |
| 550 | Report bugs to: ~a.") %guix-bug-report-address) |
| 551 | (format #t (G_ " |
| 552 | ~a home page: <~a>") %guix-package-name %guix-home-page-url) |
| 553 | (format #t (G_ " |
| 554 | General help using Guix and GNU software: <~a>") |
| 555 | ;; TRANSLATORS: Change the "/en" bit of this URL appropriately if |
| 556 | ;; the web site is translated in your language. |
| 557 | (G_ "https://guix.gnu.org/en/help/")) |
| 558 | (newline)) |
| 559 | |
| 560 | (define (augmented-system-error-handler file) |
| 561 | "Return a 'system-error' handler that mentions FILE in its message." |
| 562 | (lambda (key proc fmt args errno) |
| 563 | ;; Augment the FMT and ARGS with information about TARGET (this |
| 564 | ;; information is missing as of Guile 2.0.11, making the exception |
| 565 | ;; uninformative.) |
| 566 | (apply throw key proc "~A: ~S" |
| 567 | (list (strerror (car errno)) file) |
| 568 | (list errno)))) |
| 569 | |
| 570 | (define-syntax apply-formals |
| 571 | (syntax-rules () |
| 572 | ((_ proc (args ...)) (proc args ...)) |
| 573 | ((_ proc (arg1 args ... . rest)) (apply proc arg1 args ... rest)))) |
| 574 | |
| 575 | (define-syntax-rule (error-reporting-wrapper proc formals file) |
| 576 | "Wrap PROC such that its 'system-error' exceptions are augmented to mention |
| 577 | FILE." |
| 578 | (let ((real-proc (@ (guile) proc))) |
| 579 | (lambda formals |
| 580 | (catch 'system-error |
| 581 | (lambda () |
| 582 | (apply-formals real-proc formals)) |
| 583 | (augmented-system-error-handler file))))) |
| 584 | |
| 585 | (set! symlink |
| 586 | ;; We 'set!' the global binding because (gnu build ...) modules and similar |
| 587 | ;; typically don't use (guix ui). |
| 588 | (error-reporting-wrapper symlink (source target) target)) |
| 589 | |
| 590 | (set! copy-file |
| 591 | ;; Note: here we use 'set!', not #:replace, because UIs typically use |
| 592 | ;; 'copy-recursively', which doesn't use (guix ui). |
| 593 | (error-reporting-wrapper copy-file (source target) target)) |
| 594 | |
| 595 | (set! canonicalize-path |
| 596 | (error-reporting-wrapper canonicalize-path (file) file)) |
| 597 | |
| 598 | (set! delete-file |
| 599 | (error-reporting-wrapper delete-file (file) file)) |
| 600 | |
| 601 | (set! execlp |
| 602 | (error-reporting-wrapper execlp (filename . args) filename)) |
| 603 | |
| 604 | (define (make-regexp* regexp . flags) |
| 605 | "Like 'make-regexp' but error out if REGEXP is invalid, reporting the error |
| 606 | nicely." |
| 607 | (catch 'regular-expression-syntax |
| 608 | (lambda () |
| 609 | (apply make-regexp regexp flags)) |
| 610 | (lambda (key proc message . rest) |
| 611 | (leave (G_ "'~a' is not a valid regular expression: ~a~%") |
| 612 | regexp message)))) |
| 613 | |
| 614 | (define (string->number* str) |
| 615 | "Like `string->number', but error out with an error message on failure." |
| 616 | (or (string->number str) |
| 617 | (leave (G_ "~a: invalid number~%") str))) |
| 618 | |
| 619 | (define (size->number str) |
| 620 | "Convert STR, a storage measurement representation such as \"1024\" or |
| 621 | \"1MiB\", to a number of bytes. Raise an error if STR could not be |
| 622 | interpreted." |
| 623 | (define unit-pos |
| 624 | (string-rindex str |
| 625 | (char-set-union (char-set #\.) char-set:digit))) |
| 626 | |
| 627 | (define unit |
| 628 | (and unit-pos (substring str (+ 1 unit-pos)))) |
| 629 | |
| 630 | (let* ((numstr (if unit-pos |
| 631 | (substring str 0 (+ 1 unit-pos)) |
| 632 | str)) |
| 633 | (num (string->number numstr))) |
| 634 | (unless num |
| 635 | (leave (G_ "invalid number: ~a~%") numstr)) |
| 636 | |
| 637 | ((compose inexact->exact round) |
| 638 | (* num |
| 639 | (match unit |
| 640 | ((or "KiB" "K" "k") (expt 2 10)) |
| 641 | ((or "MiB" "M") (expt 2 20)) |
| 642 | ((or "GiB" "G") (expt 2 30)) |
| 643 | ((or "TiB" "T") (expt 2 40)) |
| 644 | ((or "PiB" "P") (expt 2 50)) |
| 645 | ((or "EiB" "E") (expt 2 60)) |
| 646 | ((or "ZiB" "Z") (expt 2 70)) |
| 647 | ((or "YiB" "Y") (expt 2 80)) |
| 648 | ("kB" (expt 10 3)) |
| 649 | ("MB" (expt 10 6)) |
| 650 | ("GB" (expt 10 9)) |
| 651 | ("TB" (expt 10 12)) |
| 652 | ("PB" (expt 10 15)) |
| 653 | ("EB" (expt 10 18)) |
| 654 | ("ZB" (expt 10 21)) |
| 655 | ("YB" (expt 10 24)) |
| 656 | ("" 1) |
| 657 | (x |
| 658 | (leave (G_ "unknown unit: ~a~%") unit))))))) |
| 659 | |
| 660 | (define (display-collision-resolution-hint collision) |
| 661 | "Display hints on how to resolve COLLISION, a &profile-collistion-error." |
| 662 | (define (top-most-entry entry) |
| 663 | (let loop ((entry entry)) |
| 664 | (match (force (manifest-entry-parent entry)) |
| 665 | (#f entry) |
| 666 | (parent (loop parent))))) |
| 667 | |
| 668 | (let* ((first (profile-collision-error-entry collision)) |
| 669 | (second (profile-collision-error-conflict collision)) |
| 670 | (name1 (manifest-entry-name (top-most-entry first))) |
| 671 | (name2 (manifest-entry-name (top-most-entry second)))) |
| 672 | (if (string=? name1 name2) |
| 673 | (display-hint (format #f (G_ "You cannot have two different versions |
| 674 | or variants of @code{~a} in the same profile.") |
| 675 | name1)) |
| 676 | (display-hint (format #f (G_ "Try upgrading both @code{~a} and @code{~a}, |
| 677 | or remove one of them from the profile.") |
| 678 | name1 name2))))) |
| 679 | |
| 680 | (cond-expand |
| 681 | (guile-3 |
| 682 | ;; On Guile 3.0, in 'call-with-error-handling' we need to re-raise. To |
| 683 | ;; preserve useful backtraces in case of unhandled errors, we want that to |
| 684 | ;; happen before the stack has been unwound, hence 'guard*'. |
| 685 | (define-syntax-rule (guard* (var clauses ...) exp ...) |
| 686 | "This variant of SRFI-34 'guard' does not unwind the stack before |
| 687 | evaluating the tests and bodies of CLAUSES." |
| 688 | (with-exception-handler |
| 689 | (lambda (var) |
| 690 | (cond clauses ... (else (raise var)))) |
| 691 | (lambda () exp ...) |
| 692 | #:unwind? #f))) |
| 693 | (else |
| 694 | (define-syntax-rule (guard* (var clauses ...) exp ...) |
| 695 | (guard (var clauses ...) exp ...)))) |
| 696 | |
| 697 | (define (call-with-error-handling thunk) |
| 698 | "Call THUNK within a user-friendly error handler." |
| 699 | (define (port-filename* port) |
| 700 | ;; 'port-filename' returns #f for non-file ports, but it raises an |
| 701 | ;; exception for file ports that are closed. Work around that. |
| 702 | (and (not (port-closed? port)) |
| 703 | (port-filename port))) |
| 704 | |
| 705 | (guard* (c ((package-input-error? c) |
| 706 | (let* ((package (package-error-package c)) |
| 707 | (input (package-error-invalid-input c)) |
| 708 | (location (package-location package)) |
| 709 | (file (location-file location)) |
| 710 | (line (location-line location)) |
| 711 | (column (location-column location))) |
| 712 | (leave (G_ "~a:~a:~a: package `~a' has an invalid input: ~s~%") |
| 713 | file line column |
| 714 | (package-full-name package) input))) |
| 715 | ((package-cross-build-system-error? c) |
| 716 | (let* ((package (package-error-package c)) |
| 717 | (loc (package-location package)) |
| 718 | (system (package-build-system package))) |
| 719 | (leave (G_ "~a: ~a: build system `~a' does not support cross builds~%") |
| 720 | (location->string loc) |
| 721 | (package-full-name package) |
| 722 | (build-system-name system)))) |
| 723 | ((gexp-input-error? c) |
| 724 | (let ((input (gexp-error-invalid-input c))) |
| 725 | (leave (G_ "~s: invalid G-expression input~%") |
| 726 | (gexp-error-invalid-input c)))) |
| 727 | ((profile-not-found-error? c) |
| 728 | (leave (G_ "profile '~a' does not exist~%") |
| 729 | (profile-error-profile c))) |
| 730 | ((missing-generation-error? c) |
| 731 | (leave (G_ "generation ~a of profile '~a' does not exist~%") |
| 732 | (missing-generation-error-generation c) |
| 733 | (profile-error-profile c))) |
| 734 | ((unmatched-pattern-error? c) |
| 735 | (let ((pattern (unmatched-pattern-error-pattern c))) |
| 736 | (leave (G_ "package '~a~@[@~a~]~@[:~a~]' not found in profile~%") |
| 737 | (manifest-pattern-name pattern) |
| 738 | (manifest-pattern-version pattern) |
| 739 | (match (manifest-pattern-output pattern) |
| 740 | ("out" #f) |
| 741 | (output output))))) |
| 742 | ((profile-collision-error? c) |
| 743 | (let ((entry (profile-collision-error-entry c)) |
| 744 | (conflict (profile-collision-error-conflict c))) |
| 745 | (define (report-parent-entries entry) |
| 746 | (let ((parent (force (manifest-entry-parent entry)))) |
| 747 | (when (manifest-entry? parent) |
| 748 | (report-error (G_ " ... propagated from ~a@~a~%") |
| 749 | (manifest-entry-name parent) |
| 750 | (manifest-entry-version parent)) |
| 751 | (report-parent-entries parent)))) |
| 752 | |
| 753 | (define (manifest-entry-output* entry) |
| 754 | (match (manifest-entry-output entry) |
| 755 | ("out" "") |
| 756 | (output (string-append ":" output)))) |
| 757 | |
| 758 | (report-error (G_ "profile contains conflicting entries for ~a~a~%") |
| 759 | (manifest-entry-name entry) |
| 760 | (manifest-entry-output* entry)) |
| 761 | (report-error (G_ " first entry: ~a@~a~a ~a~%") |
| 762 | (manifest-entry-name entry) |
| 763 | (manifest-entry-version entry) |
| 764 | (manifest-entry-output* entry) |
| 765 | (manifest-entry-item entry)) |
| 766 | (report-parent-entries entry) |
| 767 | (report-error (G_ " second entry: ~a@~a~a ~a~%") |
| 768 | (manifest-entry-name conflict) |
| 769 | (manifest-entry-version conflict) |
| 770 | (manifest-entry-output* conflict) |
| 771 | (manifest-entry-item conflict)) |
| 772 | (report-parent-entries conflict) |
| 773 | (display-collision-resolution-hint c) |
| 774 | (exit 1))) |
| 775 | ((nar-error? c) |
| 776 | (let ((file (nar-error-file c)) |
| 777 | (port (nar-error-port c))) |
| 778 | (if file |
| 779 | (leave (G_ "corrupt input while restoring '~a' from ~s~%") |
| 780 | file (or (port-filename* port) port)) |
| 781 | (leave (G_ "corrupt input while restoring archive from ~s~%") |
| 782 | (or (port-filename* port) port))))) |
| 783 | ((store-connection-error? c) |
| 784 | (leave (G_ "failed to connect to `~a': ~a~%") |
| 785 | (store-connection-error-file c) |
| 786 | (strerror (store-connection-error-code c)))) |
| 787 | ((store-protocol-error? c) |
| 788 | ;; FIXME: Server-provided error messages aren't i18n'd. |
| 789 | (leave (G_ "~a~%") |
| 790 | (store-protocol-error-message c))) |
| 791 | ((derivation-missing-output-error? c) |
| 792 | (leave (G_ "reference to invalid output '~a' of derivation '~a'~%") |
| 793 | (derivation-missing-output c) |
| 794 | (derivation-file-name (derivation-error-derivation c)))) |
| 795 | ((file-search-error? c) |
| 796 | (leave (G_ "file '~a' could not be found in these \ |
| 797 | directories:~{ ~a~}~%") |
| 798 | (file-search-error-file-name c) |
| 799 | (file-search-error-search-path c))) |
| 800 | ((invoke-error? c) |
| 801 | (leave (G_ "program exited\ |
| 802 | ~@[ with non-zero exit status ~a~]\ |
| 803 | ~@[ terminated by signal ~a~]\ |
| 804 | ~@[ stopped by signal ~a~]: ~s~%") |
| 805 | (invoke-error-exit-status c) |
| 806 | (invoke-error-term-signal c) |
| 807 | (invoke-error-stop-signal c) |
| 808 | (cons (invoke-error-program c) |
| 809 | (invoke-error-arguments c)))) |
| 810 | |
| 811 | ((formatted-message? c) |
| 812 | (apply report-error |
| 813 | (and (error-location? c) (error-location c)) |
| 814 | (gettext (formatted-message-string c) %gettext-domain) |
| 815 | (formatted-message-arguments c)) |
| 816 | (when (fix-hint? c) |
| 817 | (display-hint (condition-fix-hint c))) |
| 818 | (exit 1)) |
| 819 | |
| 820 | ;; On Guile 3.0.0, exceptions such as 'unbound-variable' are |
| 821 | ;; compound and include a '&message'. However, that message only |
| 822 | ;; contains the format string. Thus, special-case it here to |
| 823 | ;; avoid displaying a bare format string. |
| 824 | ;; |
| 825 | ;; Furthermore, use of 'guard*' ensures that the stack has not |
| 826 | ;; been unwound when we re-raise, since that would otherwise show |
| 827 | ;; useless backtraces. |
| 828 | ((cond-expand |
| 829 | (guile-3 |
| 830 | ((exception-predicate &exception-with-kind-and-args) c)) |
| 831 | (else #f)) |
| 832 | (raise c)) |
| 833 | |
| 834 | ((message-condition? c) |
| 835 | ;; Normally '&message' error conditions have an i18n'd message. |
| 836 | (report-error (and (error-location? c) (error-location c)) |
| 837 | (G_ "~a~%") |
| 838 | (gettext (condition-message c) %gettext-domain)) |
| 839 | (when (fix-hint? c) |
| 840 | (display-hint (condition-fix-hint c))) |
| 841 | (exit 1))) |
| 842 | ;; Catch EPIPE and the likes. |
| 843 | (catch 'system-error |
| 844 | thunk |
| 845 | (lambda (key proc format-string format-args . rest) |
| 846 | (leave (G_ "~a: ~a~%") proc |
| 847 | (apply format #f format-string format-args)))))) |
| 848 | |
| 849 | (define-syntax-rule (leave-on-EPIPE exp ...) |
| 850 | "Run EXP... in a context where EPIPE errors are caught and lead to 'exit' |
| 851 | with successful exit code. This is useful when writing to the standard output |
| 852 | may lead to EPIPE, because the standard output is piped through 'head' or |
| 853 | similar." |
| 854 | (catch 'system-error |
| 855 | (lambda () |
| 856 | exp ...) |
| 857 | (lambda args |
| 858 | ;; We really have to exit this brutally, otherwise Guile eventually |
| 859 | ;; attempts to flush all the ports, leading to an uncaught EPIPE down |
| 860 | ;; the path. |
| 861 | (if (= EPIPE (system-error-errno args)) |
| 862 | (primitive-_exit 0) |
| 863 | (apply throw args))))) |
| 864 | |
| 865 | (define %guix-user-module |
| 866 | ;; Module in which user expressions are evaluated. |
| 867 | ;; Compute lazily to avoid circularity with (guix gexp). |
| 868 | (delay |
| 869 | (let ((module (make-module))) |
| 870 | (beautify-user-module! module) |
| 871 | ;; Use (guix gexp) so that one can use #~ & co. |
| 872 | (module-use! module (resolve-interface '(guix gexp))) |
| 873 | module))) |
| 874 | |
| 875 | (define (read/eval str) |
| 876 | "Read and evaluate STR, raising an error if something goes wrong." |
| 877 | (let ((exp (catch #t |
| 878 | (lambda () |
| 879 | (call-with-input-string str read)) |
| 880 | (lambda args |
| 881 | (leave (G_ "failed to read expression ~s: ~s~%") |
| 882 | str args))))) |
| 883 | (catch #t |
| 884 | (lambda () |
| 885 | (eval exp (force %guix-user-module))) |
| 886 | (lambda args |
| 887 | (report-error (G_ "failed to evaluate expression '~a':~%") exp) |
| 888 | (match args |
| 889 | (('syntax-error proc message properties form . rest) |
| 890 | (report-error (G_ "syntax error: ~a~%") message)) |
| 891 | (((or 'srfi-34 '%exception) obj) |
| 892 | (cond ((message-condition? obj) |
| 893 | (report-error (G_ "~a~%") |
| 894 | (gettext (condition-message obj) |
| 895 | %gettext-domain))) |
| 896 | ((formatted-message? obj) |
| 897 | (apply report-error #f |
| 898 | (gettext (formatted-message-string obj) |
| 899 | %gettext-domain) |
| 900 | (formatted-message-arguments obj))) |
| 901 | (else |
| 902 | (report-error (G_ "exception thrown: ~s~%") obj)))) |
| 903 | ((error args ...) |
| 904 | (apply display-error #f (current-error-port) args)) |
| 905 | (what? #f)) |
| 906 | (exit 1))))) |
| 907 | |
| 908 | (define (read/eval-package-expression str) |
| 909 | "Read and evaluate STR and return the package it refers to, or exit an |
| 910 | error." |
| 911 | (match (read/eval str) |
| 912 | ((? package? p) p) |
| 913 | (x |
| 914 | (leave (G_ "expression ~s does not evaluate to a package~%") |
| 915 | str)))) |
| 916 | |
| 917 | (define (show-derivation-outputs derivation) |
| 918 | "Show the output file names of DERIVATION, which can be a derivation or a |
| 919 | derivation input." |
| 920 | (define (show-outputs derivation outputs) |
| 921 | (format #t "~{~a~%~}" |
| 922 | (map (cut derivation->output-path derivation <>) |
| 923 | outputs))) |
| 924 | |
| 925 | (match derivation |
| 926 | ((? derivation?) |
| 927 | (show-outputs derivation (derivation-output-names derivation))) |
| 928 | ((? derivation-input? input) |
| 929 | (show-outputs (derivation-input-derivation input) |
| 930 | (derivation-input-sub-derivations input))))) |
| 931 | |
| 932 | (define* (check-available-space need |
| 933 | #:optional (directory (%store-prefix))) |
| 934 | "Make sure at least NEED bytes are available in DIRECTORY. Otherwise emit a |
| 935 | warning." |
| 936 | (let ((free (catch 'system-error |
| 937 | (lambda () |
| 938 | (free-disk-space directory)) |
| 939 | (const #f)))) |
| 940 | (when (and free (>= need free)) |
| 941 | (warning (G_ "at least ~,1h MB needed but only ~,1h MB available in ~a~%") |
| 942 | (/ need 1e6) (/ free 1e6) directory)))) |
| 943 | |
| 944 | (define (graft-derivation? drv) |
| 945 | "Return true if DRV is definitely a graft derivation, false otherwise." |
| 946 | (match (assq-ref (derivation-properties drv) 'type) |
| 947 | ('graft #t) |
| 948 | (_ #f))) |
| 949 | |
| 950 | (define (profile-hook-derivation? drv) |
| 951 | "Return true if DRV is definitely a profile hook derivation, false otherwise." |
| 952 | (match (assq-ref (derivation-properties drv) 'type) |
| 953 | ('profile-hook #t) |
| 954 | (_ #f))) |
| 955 | |
| 956 | (define (colorize-store-file-name file) |
| 957 | "Colorize FILE, a store file name, such that the hash part is less prominent |
| 958 | that the rest." |
| 959 | (let ((len (string-length file)) |
| 960 | (prefix (+ (string-length (%store-prefix)) 32 2))) |
| 961 | (if (< len prefix) |
| 962 | file |
| 963 | (string-append (colorize-string (string-take file prefix) |
| 964 | (color DARK)) |
| 965 | (string-drop file prefix))))) |
| 966 | |
| 967 | (define %default-verbosity |
| 968 | ;; Default verbosity level for 'show-what-to-build'. |
| 969 | 2) |
| 970 | |
| 971 | (define* (show-what-to-build store drv |
| 972 | #:key dry-run? (use-substitutes? #t) |
| 973 | (verbosity %default-verbosity) |
| 974 | (mode (build-mode normal))) |
| 975 | "Show what will or would (depending on DRY-RUN?) be built in realizing the |
| 976 | derivations listed in DRV using MODE, a 'build-mode' value. The elements of |
| 977 | DRV can be either derivations or derivation inputs. |
| 978 | |
| 979 | Return two values: a Boolean indicating whether there's something to build, |
| 980 | and a Boolean indicating whether there's something to download. |
| 981 | |
| 982 | When USE-SUBSTITUTES?, check and report what is prerequisites are available |
| 983 | for download. VERBOSITY is an integer indicating the level of details to be |
| 984 | shown: level 2 and higher provide all the details, level 1 shows a high-level |
| 985 | summary, and level 0 shows nothing." |
| 986 | (define inputs |
| 987 | (map (match-lambda |
| 988 | ((? derivation? drv) (derivation-input drv)) |
| 989 | ((? derivation-input? input) input)) |
| 990 | drv)) |
| 991 | |
| 992 | (define substitutable-info |
| 993 | ;; Call 'substitution-oracle' upfront so we don't end up launching the |
| 994 | ;; substituter many times. This makes a big difference, especially when |
| 995 | ;; DRV is a long list as is the case with 'guix environment'. |
| 996 | (if use-substitutes? |
| 997 | (substitution-oracle store inputs #:mode mode) |
| 998 | (const #f))) |
| 999 | |
| 1000 | (define colorized-store-item |
| 1001 | (if (color-output? (current-error-port)) |
| 1002 | colorize-store-file-name |
| 1003 | identity)) |
| 1004 | |
| 1005 | (let*-values (((build/full download) |
| 1006 | (derivation-build-plan store inputs |
| 1007 | #:mode mode |
| 1008 | #:substitutable-info |
| 1009 | substitutable-info)) |
| 1010 | ((graft hook build) |
| 1011 | (match (fold (lambda (drv acc) |
| 1012 | (let ((file (derivation-file-name drv))) |
| 1013 | (match acc |
| 1014 | ((#:graft graft #:hook hook #:build build) |
| 1015 | (cond |
| 1016 | ((graft-derivation? drv) |
| 1017 | `(#:graft ,(cons file graft) |
| 1018 | #:hook ,hook |
| 1019 | #:build ,build)) |
| 1020 | ((profile-hook-derivation? drv) |
| 1021 | `(#:graft ,graft |
| 1022 | #:hook ,(cons file hook) |
| 1023 | #:build ,build)) |
| 1024 | (else |
| 1025 | `(#:graft ,graft |
| 1026 | #:hook ,hook |
| 1027 | #:build ,(cons file build)))))))) |
| 1028 | '(#:graft () #:hook () #:build ()) |
| 1029 | build/full) |
| 1030 | ((#:graft graft #:hook hook #:build build) |
| 1031 | (values graft hook build))))) |
| 1032 | (define installed-size |
| 1033 | (reduce + 0 (map substitutable-nar-size download))) |
| 1034 | |
| 1035 | (define download-size |
| 1036 | (/ (reduce + 0 (map substitutable-download-size download)) |
| 1037 | 1e6)) |
| 1038 | |
| 1039 | (define display-download-size? |
| 1040 | ;; Sometimes narinfos lack information about the download size. Only |
| 1041 | ;; display when we have information for all of DOWNLOAD. |
| 1042 | (not (any (compose zero? substitutable-download-size) download))) |
| 1043 | |
| 1044 | ;; Combinatorial explosion ahead along two axes: DRY-RUN? and VERBOSITY. |
| 1045 | ;; Unfortunately, this is hardly avoidable for proper i18n. |
| 1046 | (if dry-run? |
| 1047 | (begin |
| 1048 | (unless (zero? verbosity) |
| 1049 | (format (current-error-port) |
| 1050 | (N_ "~:[The following derivation would be built:~%~{ ~a~%~}~;~]" |
| 1051 | "~:[The following derivations would be built:~%~{ ~a~%~}~;~]" |
| 1052 | (length build)) |
| 1053 | (null? build) (map colorized-store-item build))) |
| 1054 | (cond ((>= verbosity 2) |
| 1055 | (if display-download-size? |
| 1056 | (format (current-error-port) |
| 1057 | ;; TRANSLATORS: "MB" is for "megabyte"; it should be |
| 1058 | ;; translated to the corresponding abbreviation. |
| 1059 | (G_ "~:[~,1h MB would be downloaded:~%~{ ~a~%~}~;~]") |
| 1060 | (null? download) |
| 1061 | download-size |
| 1062 | (map (compose colorized-store-item substitutable-path) |
| 1063 | download)) |
| 1064 | (format (current-error-port) |
| 1065 | (N_ "~:[The following file would be downloaded:~%~{ ~a~%~}~;~]" |
| 1066 | "~:[The following files would be downloaded:~%~{ ~a~%~}~;~]" |
| 1067 | (length download)) |
| 1068 | (null? download) |
| 1069 | (map (compose colorized-store-item substitutable-path) |
| 1070 | download))) |
| 1071 | (format (current-error-port) |
| 1072 | (N_ "~:[The following graft would be made:~%~{ ~a~%~}~;~]" |
| 1073 | "~:[The following grafts would be made:~%~{ ~a~%~}~;~]" |
| 1074 | (length graft)) |
| 1075 | (null? graft) (map colorized-store-item graft)) |
| 1076 | (format (current-error-port) |
| 1077 | (N_ "~:[The following profile hook would be built:~%~{ ~a~%~}~;~]" |
| 1078 | "~:[The following profile hooks would be built:~%~{ ~a~%~}~;~]" |
| 1079 | (length hook)) |
| 1080 | (null? hook) (map colorized-store-item hook))) |
| 1081 | ((= verbosity 1) |
| 1082 | ;; Display the bare minimum; don't mention grafts and hooks. |
| 1083 | (unless (null? build) |
| 1084 | (newline (current-error-port))) |
| 1085 | (if display-download-size? |
| 1086 | (format (current-error-port) |
| 1087 | ;; TRANSLATORS: "MB" is for "megabyte"; it should be |
| 1088 | ;; translated to the corresponding abbreviation. |
| 1089 | (highlight (G_ "~:[~,1h MB would be downloaded~%~;~]")) |
| 1090 | (null? download) download-size) |
| 1091 | (format (current-error-port) |
| 1092 | (highlight |
| 1093 | (N_ "~:[~h item would be downloaded~%~;~]" |
| 1094 | "~:[~h items would be downloaded~%~;~]" |
| 1095 | (length download))) |
| 1096 | (null? download) (length download)))))) |
| 1097 | |
| 1098 | (begin |
| 1099 | (unless (zero? verbosity) |
| 1100 | (format (current-error-port) |
| 1101 | (N_ "~:[The following derivation will be built:~%~{ ~a~%~}~;~]" |
| 1102 | "~:[The following derivations will be built:~%~{ ~a~%~}~;~]" |
| 1103 | (length build)) |
| 1104 | (null? build) (map colorized-store-item build))) |
| 1105 | (cond ((>= verbosity 2) |
| 1106 | (if display-download-size? |
| 1107 | (format (current-error-port) |
| 1108 | ;; TRANSLATORS: "MB" is for "megabyte"; it should be |
| 1109 | ;; translated to the corresponding abbreviation. |
| 1110 | (G_ "~:[~,1h MB will be downloaded:~%~{ ~a~%~}~;~]") |
| 1111 | (null? download) |
| 1112 | download-size |
| 1113 | (map (compose colorized-store-item substitutable-path) |
| 1114 | download)) |
| 1115 | (format (current-error-port) |
| 1116 | (N_ "~:[The following file will be downloaded:~%~{ ~a~%~}~;~]" |
| 1117 | "~:[The following files will be downloaded:~%~{ ~a~%~}~;~]" |
| 1118 | (length download)) |
| 1119 | (null? download) |
| 1120 | (map (compose colorized-store-item substitutable-path) |
| 1121 | download))) |
| 1122 | (format (current-error-port) |
| 1123 | (N_ "~:[The following graft will be made:~%~{ ~a~%~}~;~]" |
| 1124 | "~:[The following grafts will be made:~%~{ ~a~%~}~;~]" |
| 1125 | (length graft)) |
| 1126 | (null? graft) (map colorized-store-item graft)) |
| 1127 | (format (current-error-port) |
| 1128 | (N_ "~:[The following profile hook will be built:~%~{ ~a~%~}~;~]" |
| 1129 | "~:[The following profile hooks will be built:~%~{ ~a~%~}~;~]" |
| 1130 | (length hook)) |
| 1131 | (null? hook) (map colorized-store-item hook))) |
| 1132 | ((= verbosity 1) |
| 1133 | ;; Display the bare minimum; don't mention grafts and hooks. |
| 1134 | (unless (null? build) |
| 1135 | (newline (current-error-port))) |
| 1136 | (if display-download-size? |
| 1137 | (format (current-error-port) |
| 1138 | ;; TRANSLATORS: "MB" is for "megabyte"; it should be |
| 1139 | ;; translated to the corresponding abbreviation. |
| 1140 | (highlight (G_ "~:[~,1h MB will be downloaded~%~;~]")) |
| 1141 | (null? download) download-size) |
| 1142 | (format (current-error-port) |
| 1143 | (highlight |
| 1144 | (N_ "~:[~h item will be downloaded~%~;~]" |
| 1145 | "~:[~h items will be downloaded~%~;~]" |
| 1146 | (length download))) |
| 1147 | (null? download) (length download))))))) |
| 1148 | |
| 1149 | (check-available-space installed-size) |
| 1150 | |
| 1151 | (values (pair? build/full) (pair? download)))) |
| 1152 | |
| 1153 | (define show-what-to-build* |
| 1154 | (store-lift show-what-to-build)) |
| 1155 | |
| 1156 | (define* (build-notifier #:key (dry-run? #f) (use-substitutes? #t) |
| 1157 | (verbosity %default-verbosity)) |
| 1158 | "Return a procedure suitable for 'with-build-handler' that, when |
| 1159 | 'build-things' is called, invokes 'show-what-to-build' to display the build |
| 1160 | plan. When DRY-RUN? is true, the 'with-build-handler' form returns without |
| 1161 | any build happening." |
| 1162 | (define not-comma |
| 1163 | (char-set-complement (char-set #\,))) |
| 1164 | |
| 1165 | (define (read-derivation-from-file* item) |
| 1166 | (catch 'system-error |
| 1167 | (lambda () |
| 1168 | (read-derivation-from-file item)) |
| 1169 | (const #f))) |
| 1170 | |
| 1171 | (lambda (continue store things mode) |
| 1172 | (define inputs |
| 1173 | ;; List of derivation inputs to build. Filter out non-existent '.drv' |
| 1174 | ;; files because the daemon transparently tries to substitute them. |
| 1175 | (filter-map (match-lambda |
| 1176 | (((? derivation-path? drv) . output) |
| 1177 | (let ((drv (read-derivation-from-file* drv)) |
| 1178 | (outputs (string-tokenize output not-comma))) |
| 1179 | (and drv (derivation-input drv outputs)))) |
| 1180 | ((? derivation-path? drv) |
| 1181 | (and=> (read-derivation-from-file* drv) |
| 1182 | derivation-input)) |
| 1183 | (_ |
| 1184 | #f)) |
| 1185 | things)) |
| 1186 | |
| 1187 | (let-values (((build? download?) |
| 1188 | (show-what-to-build store inputs |
| 1189 | #:dry-run? dry-run? |
| 1190 | #:use-substitutes? use-substitutes? |
| 1191 | #:verbosity verbosity |
| 1192 | #:mode mode))) |
| 1193 | |
| 1194 | (unless (and (or build? download?) |
| 1195 | dry-run?) |
| 1196 | (continue #t))))) |
| 1197 | |
| 1198 | (define (right-arrow port) |
| 1199 | "Return either a string containing the 'RIGHT ARROW' character, or an ASCII |
| 1200 | replacement if PORT is not Unicode-capable." |
| 1201 | (let ((encoding (port-encoding port)) |
| 1202 | (arrow "→")) |
| 1203 | (catch 'encoding-error |
| 1204 | (lambda () |
| 1205 | (call-with-output-string |
| 1206 | (lambda (port) |
| 1207 | (set-port-encoding! port encoding) |
| 1208 | (set-port-conversion-strategy! port 'error) |
| 1209 | (display arrow port)))) |
| 1210 | (lambda (key . args) |
| 1211 | "->")))) |
| 1212 | |
| 1213 | (define* (tabulate rows #:key (initial-indent 0) (max-width 25) |
| 1214 | (inter-column " ")) |
| 1215 | "Return a list of strings where each string is a tabulated representation of |
| 1216 | an element of ROWS. All the ROWS must be lists of the same number of cells. |
| 1217 | |
| 1218 | Add INITIAL-INDENT white space at the beginning of each row. Ensure that |
| 1219 | columns are at most MAX-WIDTH characters wide. Use INTER-COLUMN as a |
| 1220 | separator between subsequent columns." |
| 1221 | (define column-widths |
| 1222 | ;; List of column widths. |
| 1223 | (let loop ((rows rows) |
| 1224 | (widths '())) |
| 1225 | (match rows |
| 1226 | (((? null?) ...) |
| 1227 | (reverse widths)) |
| 1228 | (((column rest ...) ...) |
| 1229 | (loop rest |
| 1230 | (cons (min (apply max (map string-length column)) |
| 1231 | max-width) |
| 1232 | widths)))))) |
| 1233 | |
| 1234 | (define indent |
| 1235 | (make-string initial-indent #\space)) |
| 1236 | |
| 1237 | (define (string-pad-right* str len) |
| 1238 | (if (> (string-length str) len) |
| 1239 | str |
| 1240 | (string-pad-right str len))) |
| 1241 | |
| 1242 | (map (lambda (row) |
| 1243 | (string-trim-right |
| 1244 | (string-append indent |
| 1245 | (string-join |
| 1246 | (map string-pad-right* row column-widths) |
| 1247 | inter-column)))) |
| 1248 | rows)) |
| 1249 | |
| 1250 | (define* (show-manifest-transaction store manifest transaction |
| 1251 | #:key dry-run?) |
| 1252 | "Display what will/would be installed/removed from MANIFEST by TRANSACTION." |
| 1253 | (define* (package-strings names versions outputs #:key old-versions) |
| 1254 | (tabulate (stable-sort |
| 1255 | (zip (map (lambda (name output) |
| 1256 | (if (string=? output "out") |
| 1257 | name |
| 1258 | (string-append name ":" output))) |
| 1259 | names outputs) |
| 1260 | (if old-versions |
| 1261 | (map (lambda (old new) |
| 1262 | (if (string=? old new) |
| 1263 | (G_ "(dependencies or package changed)") |
| 1264 | (string-append old " " → " " new))) |
| 1265 | old-versions versions) |
| 1266 | versions)) |
| 1267 | (lambda (x y) |
| 1268 | (string<? (first x) (first y)))) |
| 1269 | #:initial-indent 3)) |
| 1270 | |
| 1271 | (define → ;an arrow that can be represented on stderr |
| 1272 | (right-arrow (current-error-port))) |
| 1273 | |
| 1274 | (let-values (((remove install upgrade downgrade) |
| 1275 | (manifest-transaction-effects manifest transaction))) |
| 1276 | (match remove |
| 1277 | ((($ <manifest-entry> name version output item) ..1) |
| 1278 | (let ((len (length name)) |
| 1279 | (remove (package-strings name version output))) |
| 1280 | (if dry-run? |
| 1281 | (format (current-error-port) |
| 1282 | (N_ "The following package would be removed:~%~{~a~%~}~%" |
| 1283 | "The following packages would be removed:~%~{~a~%~}~%" |
| 1284 | len) |
| 1285 | remove) |
| 1286 | (format (current-error-port) |
| 1287 | (N_ "The following package will be removed:~%~{~a~%~}~%" |
| 1288 | "The following packages will be removed:~%~{~a~%~}~%" |
| 1289 | len) |
| 1290 | remove)))) |
| 1291 | (x #f)) |
| 1292 | (match downgrade |
| 1293 | (((($ <manifest-entry> name old-version) |
| 1294 | . ($ <manifest-entry> _ new-version output item)) ..1) |
| 1295 | (let ((len (length name)) |
| 1296 | (downgrade (package-strings name new-version output |
| 1297 | #:old-versions old-version))) |
| 1298 | (if dry-run? |
| 1299 | (format (current-error-port) |
| 1300 | (N_ "The following package would be downgraded:~%~{~a~%~}~%" |
| 1301 | "The following packages would be downgraded:~%~{~a~%~}~%" |
| 1302 | len) |
| 1303 | downgrade) |
| 1304 | (format (current-error-port) |
| 1305 | (N_ "The following package will be downgraded:~%~{~a~%~}~%" |
| 1306 | "The following packages will be downgraded:~%~{~a~%~}~%" |
| 1307 | len) |
| 1308 | downgrade)))) |
| 1309 | (x #f)) |
| 1310 | (match upgrade |
| 1311 | (((($ <manifest-entry> name old-version) |
| 1312 | . ($ <manifest-entry> _ new-version output item)) ..1) |
| 1313 | (let ((len (length name)) |
| 1314 | (upgrade (package-strings name new-version output |
| 1315 | #:old-versions old-version))) |
| 1316 | (if dry-run? |
| 1317 | (format (current-error-port) |
| 1318 | (N_ "The following package would be upgraded:~%~{~a~%~}~%" |
| 1319 | "The following packages would be upgraded:~%~{~a~%~}~%" |
| 1320 | len) |
| 1321 | upgrade) |
| 1322 | (format (current-error-port) |
| 1323 | (N_ "The following package will be upgraded:~%~{~a~%~}~%" |
| 1324 | "The following packages will be upgraded:~%~{~a~%~}~%" |
| 1325 | len) |
| 1326 | upgrade)))) |
| 1327 | (x #f)) |
| 1328 | (match install |
| 1329 | ((($ <manifest-entry> name version output item _) ..1) |
| 1330 | (let ((len (length name)) |
| 1331 | (install (package-strings name version output))) |
| 1332 | (if dry-run? |
| 1333 | (format (current-error-port) |
| 1334 | (N_ "The following package would be installed:~%~{~a~%~}~%" |
| 1335 | "The following packages would be installed:~%~{~a~%~}~%" |
| 1336 | len) |
| 1337 | install) |
| 1338 | (format (current-error-port) |
| 1339 | (N_ "The following package will be installed:~%~{~a~%~}~%" |
| 1340 | "The following packages will be installed:~%~{~a~%~}~%" |
| 1341 | len) |
| 1342 | install)))) |
| 1343 | (x #f)))) |
| 1344 | |
| 1345 | (define-syntax with-error-handling |
| 1346 | (syntax-rules () |
| 1347 | "Run BODY within a user-friendly error condition handler." |
| 1348 | ((_ body ...) |
| 1349 | (call-with-error-handling |
| 1350 | (lambda () |
| 1351 | body ...))))) |
| 1352 | |
| 1353 | (define* (indented-string str indent |
| 1354 | #:key (initial-indent? #t)) |
| 1355 | "Return STR with each newline preceded by INDENT spaces. When |
| 1356 | INITIAL-INDENT? is true, the first line is also indented." |
| 1357 | (define indent-string |
| 1358 | (make-list indent #\space)) |
| 1359 | |
| 1360 | (list->string |
| 1361 | (string-fold-right (lambda (chr result) |
| 1362 | (if (eqv? chr #\newline) |
| 1363 | (cons chr (append indent-string result)) |
| 1364 | (cons chr result))) |
| 1365 | '() |
| 1366 | (if initial-indent? |
| 1367 | (string-append (list->string indent-string) str) |
| 1368 | str)))) |
| 1369 | |
| 1370 | (define* (fill-paragraph str width #:optional (column 0)) |
| 1371 | "Fill STR such that each line contains at most WIDTH characters, assuming |
| 1372 | that the first character is at COLUMN. |
| 1373 | |
| 1374 | When STR contains a single line break surrounded by other characters, it is |
| 1375 | converted to a space; sequences of more than one line break are preserved." |
| 1376 | (define (maybe-break chr result) |
| 1377 | (match result |
| 1378 | ((column newlines chars) |
| 1379 | (case chr |
| 1380 | ((#\newline) |
| 1381 | `(,column ,(+ 1 newlines) ,chars)) |
| 1382 | (else |
| 1383 | (let* ((spaces (if (and (pair? chars) (eqv? (car chars) #\.)) 2 1)) |
| 1384 | (chars (case newlines |
| 1385 | ((0) chars) |
| 1386 | ((1) |
| 1387 | (append (make-list spaces #\space) chars)) |
| 1388 | (else |
| 1389 | (append (make-list newlines #\newline) chars)))) |
| 1390 | (column (case newlines |
| 1391 | ((0) column) |
| 1392 | ((1) (+ spaces column)) |
| 1393 | (else 0)))) |
| 1394 | (let ((chars (cons chr chars)) |
| 1395 | (column (+ 1 column))) |
| 1396 | (if (> column width) |
| 1397 | (let*-values (((before after) |
| 1398 | (break (cut eqv? #\space <>) chars)) |
| 1399 | ((len) |
| 1400 | (length before))) |
| 1401 | (if (<= len width) |
| 1402 | `(,len |
| 1403 | 0 |
| 1404 | ,(if (null? after) |
| 1405 | before |
| 1406 | (append before |
| 1407 | (cons #\newline |
| 1408 | (drop-while (cut eqv? #\space <>) |
| 1409 | after))))) |
| 1410 | `(,column 0 ,chars))) ; unbreakable |
| 1411 | `(,column 0 ,chars))))))))) |
| 1412 | |
| 1413 | (match (string-fold maybe-break |
| 1414 | `(,column 0 ()) |
| 1415 | str) |
| 1416 | ((column newlines chars) |
| 1417 | (list->string (reverse chars))))) |
| 1418 | |
| 1419 | \f |
| 1420 | ;;; |
| 1421 | ;;; Packages. |
| 1422 | ;;; |
| 1423 | |
| 1424 | (define %text-width |
| 1425 | ;; '*line-width*' was introduced in Guile 2.2.7/3.0.1. On older versions of |
| 1426 | ;; Guile, monkey-patch 'wrap*' below. |
| 1427 | (if (defined? '*line-width*) |
| 1428 | (let ((parameter (fluid->parameter *line-width*))) |
| 1429 | (parameter (terminal-columns)) |
| 1430 | parameter) |
| 1431 | (make-parameter (terminal-columns)))) |
| 1432 | |
| 1433 | (unless (defined? '*line-width*) ;Guile < 2.2.7 |
| 1434 | (set! (@@ (texinfo plain-text) wrap*) |
| 1435 | ;; XXX: Monkey patch this private procedure to let 'package->recutils' |
| 1436 | ;; parameterize the fill of description field correctly. |
| 1437 | (lambda strings |
| 1438 | (let ((indent (fluid-ref (@@ (texinfo plain-text) *indent*)))) |
| 1439 | (fill-string (string-concatenate strings) |
| 1440 | #:line-width (%text-width) #:initial-indent indent |
| 1441 | #:subsequent-indent indent))))) |
| 1442 | |
| 1443 | (define (texi->plain-text str) |
| 1444 | "Return a plain-text representation of texinfo fragment STR." |
| 1445 | ;; 'texi-fragment->stexi' uses a string port so make sure it's a |
| 1446 | ;; Unicode-capable one (see <http://bugs.gnu.org/11197>.) |
| 1447 | (with-fluids ((%default-port-encoding "UTF-8")) |
| 1448 | (stexi->plain-text (texi-fragment->stexi str)))) |
| 1449 | |
| 1450 | (define (package-field-string package field-accessor) |
| 1451 | "Return a plain-text representation of PACKAGE field." |
| 1452 | (and=> (field-accessor package) |
| 1453 | (compose texi->plain-text P_))) |
| 1454 | |
| 1455 | (define (package-description-string package) |
| 1456 | "Return a plain-text representation of PACKAGE description field." |
| 1457 | (package-field-string package package-description)) |
| 1458 | |
| 1459 | (define (package-synopsis-string package) |
| 1460 | "Return a plain-text representation of PACKAGE synopsis field." |
| 1461 | (package-field-string package package-synopsis)) |
| 1462 | |
| 1463 | (define (string->recutils str) |
| 1464 | "Return a version of STR where newlines have been replaced by newlines |
| 1465 | followed by \"+ \", which makes for a valid multi-line field value in the |
| 1466 | `recutils' syntax." |
| 1467 | (list->string |
| 1468 | (string-fold-right (lambda (chr result) |
| 1469 | (if (eqv? chr #\newline) |
| 1470 | (cons* chr #\+ #\space result) |
| 1471 | (cons chr result))) |
| 1472 | '() |
| 1473 | str))) |
| 1474 | |
| 1475 | (define (hyperlink uri text) |
| 1476 | "Return a string that denotes a hyperlink using an OSC escape sequence as |
| 1477 | documented at |
| 1478 | <https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda>." |
| 1479 | (string-append "\x1b]8;;" uri "\x1b\\" |
| 1480 | text "\x1b]8;;\x1b\\")) |
| 1481 | |
| 1482 | (define* (supports-hyperlinks? #:optional (port (current-output-port))) |
| 1483 | "Return true if PORT is a terminal that supports hyperlink escapes." |
| 1484 | ;; Note that terminals are supposed to ignore OSC escapes they don't |
| 1485 | ;; understand (this is the case of xterm as of version 349, for instance.) |
| 1486 | ;; However, Emacs comint as of 26.3 does not ignore it and instead lets it |
| 1487 | ;; through, hence the 'INSIDE_EMACS' special case below. |
| 1488 | (and (isatty?* port) |
| 1489 | (not (getenv "INSIDE_EMACS")))) |
| 1490 | |
| 1491 | (define* (file-hyperlink file #:optional (text file)) |
| 1492 | "Return TEXT with escapes for a hyperlink to FILE." |
| 1493 | (hyperlink (string-append "file://" (gethostname) |
| 1494 | (encode-and-join-uri-path |
| 1495 | (string-split file #\/))) |
| 1496 | text)) |
| 1497 | |
| 1498 | (define (location->hyperlink location) |
| 1499 | "Return a string corresponding to LOCATION, with escapes for a hyperlink." |
| 1500 | (let ((str (location->string location)) |
| 1501 | (file (if (string-prefix? "/" (location-file location)) |
| 1502 | (location-file location) |
| 1503 | (search-path %load-path (location-file location))))) |
| 1504 | (if file |
| 1505 | (file-hyperlink file str) |
| 1506 | str))) |
| 1507 | |
| 1508 | (define* (package->recutils p port #:optional (width (%text-width)) |
| 1509 | #:key |
| 1510 | (hyperlinks? (supports-hyperlinks? port)) |
| 1511 | (extra-fields '())) |
| 1512 | "Write to PORT a `recutils' record of package P, arranging to fit within |
| 1513 | WIDTH columns. EXTRA-FIELDS is a list of symbol/value pairs to emit. When |
| 1514 | HYPERLINKS? is true, emit hyperlink escape sequences when appropriate." |
| 1515 | (define width* |
| 1516 | ;; The available number of columns once we've taken into account space for |
| 1517 | ;; the initial "+ " prefix. |
| 1518 | (if (> width 2) (- width 2) width)) |
| 1519 | |
| 1520 | (define (dependencies->recutils packages) |
| 1521 | (let ((list (string-join (delete-duplicates |
| 1522 | (map package-full-name |
| 1523 | (sort packages package<?))) " "))) |
| 1524 | (string->recutils |
| 1525 | (fill-paragraph list width* |
| 1526 | (string-length "dependencies: "))))) |
| 1527 | |
| 1528 | (define (package<? p1 p2) |
| 1529 | (string<? (package-full-name p1) (package-full-name p2))) |
| 1530 | |
| 1531 | ;; Note: Don't i18n field names so that people can post-process it. |
| 1532 | (format port "name: ~a~%" (package-name p)) |
| 1533 | (format port "version: ~a~%" (package-version p)) |
| 1534 | (format port "outputs: ~a~%" (string-join (package-outputs p))) |
| 1535 | (format port "systems: ~a~%" |
| 1536 | (string-join (package-transitive-supported-systems p))) |
| 1537 | (format port "dependencies: ~a~%" |
| 1538 | (match (package-direct-inputs p) |
| 1539 | (((labels inputs . _) ...) |
| 1540 | (dependencies->recutils (filter package? inputs))))) |
| 1541 | (format port "location: ~a~%" |
| 1542 | (or (and=> (package-location p) |
| 1543 | (if hyperlinks? location->hyperlink location->string)) |
| 1544 | (G_ "unknown"))) |
| 1545 | |
| 1546 | ;; Note: Starting from version 1.6 or recutils, hyphens are not allowed in |
| 1547 | ;; field identifiers. |
| 1548 | (format port "homepage: ~a~%" (package-home-page p)) |
| 1549 | |
| 1550 | (format port "license: ~a~%" |
| 1551 | (match (package-license p) |
| 1552 | (((? license? licenses) ...) |
| 1553 | (string-join (map license-name licenses) |
| 1554 | ", ")) |
| 1555 | ((? license? license) |
| 1556 | (let ((text (license-name license)) |
| 1557 | (uri (license-uri license))) |
| 1558 | (if (and hyperlinks? uri (string-prefix? "http" uri)) |
| 1559 | (hyperlink uri text) |
| 1560 | text))) |
| 1561 | (x |
| 1562 | (G_ "unknown")))) |
| 1563 | (format port "synopsis: ~a~%" |
| 1564 | (string-map (match-lambda |
| 1565 | (#\newline #\space) |
| 1566 | (chr chr)) |
| 1567 | (or (package-synopsis-string p) ""))) |
| 1568 | (format port "~a~%" |
| 1569 | (string->recutils |
| 1570 | (string-trim-right |
| 1571 | (parameterize ((%text-width width*)) |
| 1572 | ;; Call 'texi->plain-text' on the concatenated string to account |
| 1573 | ;; for the width of "description:" in paragraph filling. |
| 1574 | (texi->plain-text |
| 1575 | (string-append "description: " |
| 1576 | (or (and=> (package-description p) P_) |
| 1577 | "")))) |
| 1578 | #\newline))) |
| 1579 | (for-each (match-lambda |
| 1580 | ((field . value) |
| 1581 | (let ((field (symbol->string field))) |
| 1582 | (format port "~a: ~a~%" |
| 1583 | field |
| 1584 | (fill-paragraph (object->string value) width* |
| 1585 | (string-length field)))))) |
| 1586 | extra-fields) |
| 1587 | (newline port)) |
| 1588 | |
| 1589 | \f |
| 1590 | ;;; |
| 1591 | ;;; Searching. |
| 1592 | ;;; |
| 1593 | |
| 1594 | (define (relevance obj regexps metrics) |
| 1595 | "Compute a \"relevance score\" for OBJ as a function of its number of |
| 1596 | matches of REGEXPS and accordingly to METRICS. METRICS is list of |
| 1597 | field/weight pairs, where FIELD is a procedure that returns a string or list |
| 1598 | of strings describing OBJ, and WEIGHT is a positive integer denoting the |
| 1599 | weight of this field in the final score. |
| 1600 | |
| 1601 | A score of zero means that OBJ does not match any of REGEXPS. The higher the |
| 1602 | score, the more relevant OBJ is to REGEXPS." |
| 1603 | (define (score regexp str) |
| 1604 | (fold-matches regexp str 0 |
| 1605 | (lambda (m score) |
| 1606 | (+ score |
| 1607 | (if (string=? (match:substring m) str) |
| 1608 | 5 ;exact match |
| 1609 | 1))))) |
| 1610 | |
| 1611 | (define (regexp->score regexp) |
| 1612 | (let ((score-regexp (lambda (str) (score regexp str)))) |
| 1613 | (fold (lambda (metric relevance) |
| 1614 | (match metric |
| 1615 | ((field . weight) |
| 1616 | (match (field obj) |
| 1617 | (#f relevance) |
| 1618 | ((? string? str) |
| 1619 | (+ relevance (* (score-regexp str) weight))) |
| 1620 | ((lst ...) |
| 1621 | (+ relevance (* weight (apply + (map score-regexp lst))))))))) |
| 1622 | 0 metrics))) |
| 1623 | |
| 1624 | (let loop ((regexps regexps) |
| 1625 | (total-score 0)) |
| 1626 | (match regexps |
| 1627 | ((head . tail) |
| 1628 | (let ((score (regexp->score head))) |
| 1629 | ;; Return zero if one of PATTERNS doesn't match. |
| 1630 | (if (zero? score) |
| 1631 | 0 |
| 1632 | (loop tail (+ total-score score))))) |
| 1633 | (() total-score)))) |
| 1634 | |
| 1635 | (define %package-metrics |
| 1636 | ;; Metrics used to compute the "relevance score" of a package against a set |
| 1637 | ;; of regexps. |
| 1638 | `((,package-name . 4) |
| 1639 | |
| 1640 | ;; Match against uncommon outputs. |
| 1641 | (,(lambda (package) |
| 1642 | (filter (lambda (output) |
| 1643 | (not (member output |
| 1644 | ;; Some common outputs shared by many packages. |
| 1645 | '("out" "doc" "debug" "lib" "include" "bin")))) |
| 1646 | (package-outputs package))) |
| 1647 | . 1) |
| 1648 | |
| 1649 | ;; Match regexps on the raw Texinfo since formatting it is quite expensive |
| 1650 | ;; and doesn't have much of an effect on search results. |
| 1651 | (,(lambda (package) |
| 1652 | (and=> (package-synopsis package) P_)) . 3) |
| 1653 | (,(lambda (package) |
| 1654 | (and=> (package-description package) P_)) . 2) |
| 1655 | |
| 1656 | (,(lambda (type) |
| 1657 | (match (and=> (package-location type) location-file) |
| 1658 | ((? string? file) (basename file ".scm")) |
| 1659 | (#f ""))) |
| 1660 | . 1))) |
| 1661 | |
| 1662 | (define (package-relevance package regexps) |
| 1663 | "Return a score denoting the relevance of PACKAGE for REGEXPS. A score of |
| 1664 | zero means that PACKAGE does not match any of REGEXPS." |
| 1665 | (relevance package regexps %package-metrics)) |
| 1666 | |
| 1667 | (define* (call-with-paginated-output-port proc |
| 1668 | #:key (less-options "FrX")) |
| 1669 | (let ((pager-command-line (or (getenv "GUIX_PAGER") |
| 1670 | (getenv "PAGER") |
| 1671 | "less"))) |
| 1672 | ;; Setting PAGER to the empty string conventionally disables paging. |
| 1673 | (if (and (not (string-null? pager-command-line)) |
| 1674 | (isatty?* (current-output-port))) |
| 1675 | ;; Set 'LESS' so that 'less' exits if everything fits on the screen |
| 1676 | ;; (F), lets ANSI escapes through (r), does not send the termcap |
| 1677 | ;; initialization string (X). Set it unconditionally because some |
| 1678 | ;; distros set it to something that doesn't work here. |
| 1679 | ;; |
| 1680 | ;; For things that produce long lines, such as 'guix processes', use |
| 1681 | ;; 'R' instead of 'r': this strips hyperlinks but allows 'less' to |
| 1682 | ;; make a good estimate of the line length. |
| 1683 | (let* ((pager (with-environment-variables `(("LESS" ,less-options)) |
| 1684 | (apply open-pipe* OPEN_WRITE |
| 1685 | ;; Split into arguments. Treat runs of multiple |
| 1686 | ;; whitespace characters as one. libpipeline- |
| 1687 | ;; style "cmd one\ arg" escaping is unsupported. |
| 1688 | (remove (lambda (s) (string-null? s)) |
| 1689 | (string-split pager-command-line |
| 1690 | char-set:whitespace)))))) |
| 1691 | (dynamic-wind |
| 1692 | (const #t) |
| 1693 | (lambda () (proc pager)) |
| 1694 | (lambda () (close-pipe pager)))) |
| 1695 | (proc (current-output-port))))) |
| 1696 | |
| 1697 | (define-syntax with-paginated-output-port |
| 1698 | (syntax-rules () |
| 1699 | "Evaluate EXP... with PORT bound to a port that talks to the pager if |
| 1700 | standard output is a tty, or with PORT set to the current output port." |
| 1701 | ((_ port exp ... #:less-options opts) |
| 1702 | (call-with-paginated-output-port (lambda (port) exp ...) |
| 1703 | #:less-options opts)) |
| 1704 | ((_ port exp ...) |
| 1705 | (call-with-paginated-output-port (lambda (port) exp ...))))) |
| 1706 | |
| 1707 | (define* (display-search-results matches port |
| 1708 | #:key |
| 1709 | (command "guix search") |
| 1710 | (print package->recutils)) |
| 1711 | "Display MATCHES, a list of object/score pairs, by calling PRINT on each of |
| 1712 | them. If PORT is a terminal, print at most a full screen of results." |
| 1713 | (define first-line |
| 1714 | (port-line port)) |
| 1715 | |
| 1716 | (define max-rows |
| 1717 | (and first-line (isatty? port) |
| 1718 | (terminal-rows port))) |
| 1719 | |
| 1720 | (define (line-count str) |
| 1721 | (string-count str #\newline)) |
| 1722 | |
| 1723 | (with-paginated-output-port paginated |
| 1724 | (let loop ((matches matches)) |
| 1725 | (match matches |
| 1726 | (((package . score) rest ...) |
| 1727 | (let* ((links? (supports-hyperlinks? port))) |
| 1728 | (print package paginated |
| 1729 | #:hyperlinks? links? |
| 1730 | #:extra-fields `((relevance . ,score))) |
| 1731 | (loop rest))) |
| 1732 | (() |
| 1733 | #t))))) |
| 1734 | |
| 1735 | \f |
| 1736 | (define (string->generations str) |
| 1737 | "Return the list of generations matching a pattern in STR. This function |
| 1738 | accepts the following patterns: \"1\", \"1,2,3\", \"1..9\", \"1..\", \"..9\"." |
| 1739 | (define (maybe-integer) |
| 1740 | (let ((x (string->number str))) |
| 1741 | (and (integer? x) |
| 1742 | x))) |
| 1743 | |
| 1744 | (define (maybe-comma-separated-integers) |
| 1745 | (let ((lst (delete-duplicates |
| 1746 | (map string->number |
| 1747 | (string-split str #\,))))) |
| 1748 | (and (every integer? lst) |
| 1749 | lst))) |
| 1750 | |
| 1751 | (cond ((maybe-integer) |
| 1752 | => |
| 1753 | list) |
| 1754 | ((maybe-comma-separated-integers) |
| 1755 | => |
| 1756 | identity) |
| 1757 | ((string-match "^([0-9]+)\\.\\.([0-9]+)$" str) |
| 1758 | => |
| 1759 | (lambda (match) |
| 1760 | (let ((s (string->number (match:substring match 1))) |
| 1761 | (e (string->number (match:substring match 2)))) |
| 1762 | (and (every integer? (list s e)) |
| 1763 | (<= s e) |
| 1764 | (iota (1+ (- e s)) s))))) |
| 1765 | ((string-match "^([0-9]+)\\.\\.$" str) |
| 1766 | => |
| 1767 | (lambda (match) |
| 1768 | (let ((s (string->number (match:substring match 1)))) |
| 1769 | (and (integer? s) |
| 1770 | `(>= ,s))))) |
| 1771 | ((string-match "^\\.\\.([0-9]+)$" str) |
| 1772 | => |
| 1773 | (lambda (match) |
| 1774 | (let ((e (string->number (match:substring match 1)))) |
| 1775 | (and (integer? e) |
| 1776 | `(<= ,e))))) |
| 1777 | (else #f))) |
| 1778 | |
| 1779 | (define (string->duration str) |
| 1780 | "Return the duration matching a pattern in STR. This function accepts the |
| 1781 | following patterns: \"1d\", \"1w\", \"1m\"." |
| 1782 | (define (hours->duration hours match) |
| 1783 | (make-time time-duration 0 |
| 1784 | (* 3600 hours (string->number (match:substring match 1))))) |
| 1785 | |
| 1786 | (cond ((string-match "^([0-9]+)s$" str) |
| 1787 | => |
| 1788 | (lambda (match) |
| 1789 | (make-time time-duration 0 |
| 1790 | (string->number (match:substring match 1))))) |
| 1791 | ((string-match "^([0-9]+)h$" str) |
| 1792 | => |
| 1793 | (lambda (match) |
| 1794 | (hours->duration 1 match))) |
| 1795 | ((string-match "^([0-9]+)d$" str) |
| 1796 | => |
| 1797 | (lambda (match) |
| 1798 | (hours->duration 24 match))) |
| 1799 | ((string-match "^([0-9]+)w$" str) |
| 1800 | => |
| 1801 | (lambda (match) |
| 1802 | (hours->duration (* 24 7) match))) |
| 1803 | ((string-match "^([0-9]+)m$" str) |
| 1804 | => |
| 1805 | (lambda (match) |
| 1806 | (hours->duration (* 24 30) match))) |
| 1807 | (else #f))) |
| 1808 | |
| 1809 | (define* (matching-generations str profile |
| 1810 | #:key (duration-relation <=)) |
| 1811 | "Return the list of available generations matching a pattern in STR. See |
| 1812 | 'string->generations' and 'string->duration' for the list of valid patterns. |
| 1813 | When STR is a duration pattern, return all the generations whose ctime has |
| 1814 | DURATION-RELATION with the current time." |
| 1815 | (define (valid-generations lst) |
| 1816 | (define (valid-generation? n) |
| 1817 | (any (cut = n <>) (generation-numbers profile))) |
| 1818 | |
| 1819 | (fold-right (lambda (x acc) |
| 1820 | (if (valid-generation? x) |
| 1821 | (cons x acc) |
| 1822 | acc)) |
| 1823 | '() |
| 1824 | lst)) |
| 1825 | |
| 1826 | (define (filter-generations generations) |
| 1827 | (match generations |
| 1828 | (() '()) |
| 1829 | (('>= n) |
| 1830 | (drop-while (cut > n <>) |
| 1831 | (generation-numbers profile))) |
| 1832 | (('<= n) |
| 1833 | (valid-generations (iota n 1))) |
| 1834 | ((lst ..1) |
| 1835 | (valid-generations lst)) |
| 1836 | (x #f))) |
| 1837 | |
| 1838 | (define (filter-by-duration duration) |
| 1839 | (define (time-at-midnight time) |
| 1840 | ;; Return TIME at midnight by setting nanoseconds, seconds, minutes, and |
| 1841 | ;; hours to zeros. |
| 1842 | (let ((d (time-utc->date time))) |
| 1843 | (date->time-utc |
| 1844 | (make-date 0 0 0 0 |
| 1845 | (date-day d) (date-month d) |
| 1846 | (date-year d) (date-zone-offset d))))) |
| 1847 | |
| 1848 | (define generation-ctime-alist |
| 1849 | (map (lambda (number) |
| 1850 | (cons number |
| 1851 | (time-second |
| 1852 | (time-at-midnight |
| 1853 | (generation-time profile number))))) |
| 1854 | (generation-numbers profile))) |
| 1855 | |
| 1856 | (match duration |
| 1857 | (#f #f) |
| 1858 | (res |
| 1859 | (let ((s (time-second |
| 1860 | (subtract-duration (time-at-midnight (current-time)) |
| 1861 | duration)))) |
| 1862 | (delete #f (map (lambda (x) |
| 1863 | (and (duration-relation s (cdr x)) |
| 1864 | (first x))) |
| 1865 | generation-ctime-alist)))))) |
| 1866 | |
| 1867 | (cond ((string->generations str) |
| 1868 | => |
| 1869 | filter-generations) |
| 1870 | ((string->duration str) |
| 1871 | => |
| 1872 | filter-by-duration) |
| 1873 | (else |
| 1874 | (raise |
| 1875 | (formatted-message (G_ "invalid syntax: ~a~%") str))))) |
| 1876 | |
| 1877 | (define (display-generation profile number) |
| 1878 | "Display a one-line summary of generation NUMBER of PROFILE." |
| 1879 | (unless (zero? number) |
| 1880 | (let* ((file (generation-file-name profile number)) |
| 1881 | (link (if (supports-hyperlinks?) |
| 1882 | (cut file-hyperlink file <>) |
| 1883 | identity)) |
| 1884 | (header (format #f (link (highlight (G_ "Generation ~a\t~a"))) |
| 1885 | number |
| 1886 | (date->string |
| 1887 | (time-utc->date |
| 1888 | (generation-time profile number)) |
| 1889 | ;; TRANSLATORS: This is a format-string for date->string. |
| 1890 | ;; Please choose a format that corresponds to the |
| 1891 | ;; usual way of presenting dates in your locale. |
| 1892 | ;; See https://www.gnu.org/software/guile/manual/html_node/SRFI_002d19-Date-to-string.html |
| 1893 | ;; for details. |
| 1894 | (G_ "~b ~d ~Y ~T")))) |
| 1895 | (current (generation-number profile))) |
| 1896 | (if (= number current) |
| 1897 | ;; TRANSLATORS: The word "current" here is an adjective for |
| 1898 | ;; "Generation", as in "current generation". Use the appropriate |
| 1899 | ;; gender where applicable. |
| 1900 | (format #t (G_ "~a\t(current)~%") header) |
| 1901 | (format #t "~a~%" header))))) |
| 1902 | |
| 1903 | (define (display-profile-content-diff profile gen1 gen2) |
| 1904 | "Display the changed packages in PROFILE GEN2 compared to generation GEN1." |
| 1905 | |
| 1906 | (define (equal-entry? first second) |
| 1907 | (string= (manifest-entry-item first) (manifest-entry-item second))) |
| 1908 | |
| 1909 | (define (display-entry entry prefix) |
| 1910 | (match entry |
| 1911 | (($ <manifest-entry> name version output location _) |
| 1912 | (format #t " ~a ~a\t~a\t~a\t~a~%" prefix name version output location)))) |
| 1913 | |
| 1914 | (define (list-entries number) |
| 1915 | (manifest-entries (profile-manifest (generation-file-name profile number)))) |
| 1916 | |
| 1917 | (define (display-diff profile old new) |
| 1918 | (display-generation profile new) |
| 1919 | (let ((added (lset-difference |
| 1920 | equal-entry? (list-entries new) (list-entries old))) |
| 1921 | (removed (lset-difference |
| 1922 | equal-entry? (list-entries old) (list-entries new)))) |
| 1923 | (for-each (cut display-entry <> "+") added) |
| 1924 | (for-each (cut display-entry <> "-") removed) |
| 1925 | (newline))) |
| 1926 | |
| 1927 | (display-diff profile gen1 gen2)) |
| 1928 | |
| 1929 | (define (profile-lock-handler profile errno . _) |
| 1930 | "Handle failure to acquire PROFILE's lock." |
| 1931 | ;; NFS mounts can return ENOLCK. When that happens, there's not much that |
| 1932 | ;; can be done, so warn the user and keep going. |
| 1933 | (if (= errno ENOLCK) |
| 1934 | (warning (G_ "cannot lock profile ~a: ~a~%") |
| 1935 | profile (strerror errno)) |
| 1936 | (leave (G_ "profile ~a is locked by another process~%") |
| 1937 | profile))) |
| 1938 | |
| 1939 | (define profile-lock-file |
| 1940 | (cut string-append <> ".lock")) |
| 1941 | |
| 1942 | (define-syntax-rule (with-profile-lock profile exp ...) |
| 1943 | "Grab PROFILE's lock and evaluate EXP... Call 'leave' if the lock is |
| 1944 | already taken." |
| 1945 | (with-file-lock/no-wait (profile-lock-file profile) |
| 1946 | (cut profile-lock-handler profile <...>) |
| 1947 | exp ...)) |
| 1948 | |
| 1949 | (define (display-profile-content profile number) |
| 1950 | "Display the packages in PROFILE, generation NUMBER, in a human-readable |
| 1951 | way." |
| 1952 | (for-each (match-lambda |
| 1953 | (($ <manifest-entry> name version output location _) |
| 1954 | (format #t " ~a\t~a\t~a\t~a~%" |
| 1955 | name version output location))) |
| 1956 | |
| 1957 | ;; Show most recently installed packages last. |
| 1958 | (reverse |
| 1959 | (manifest-entries |
| 1960 | (profile-manifest (generation-file-name profile number)))))) |
| 1961 | |
| 1962 | (define (display-generation-change previous current) |
| 1963 | (format #t (G_ "switched from generation ~a to ~a~%") previous current)) |
| 1964 | |
| 1965 | (define (roll-back* store profile) |
| 1966 | "Like 'roll-back', but display what is happening." |
| 1967 | (call-with-values |
| 1968 | (lambda () |
| 1969 | (roll-back store profile)) |
| 1970 | display-generation-change)) |
| 1971 | |
| 1972 | (define (switch-to-generation* profile number) |
| 1973 | "Like 'switch-to-generation', but display what is happening." |
| 1974 | (let ((previous (switch-to-generation profile number))) |
| 1975 | (display-generation-change previous number))) |
| 1976 | |
| 1977 | (define (delete-generation* store profile generation) |
| 1978 | "Like 'delete-generation', but display what is going on." |
| 1979 | (format #t (G_ "deleting ~a~%") |
| 1980 | (generation-file-name profile generation)) |
| 1981 | (delete-generation store profile generation)) |
| 1982 | |
| 1983 | (define* (package-specification->name+version+output spec |
| 1984 | #:optional (output "out")) |
| 1985 | "Parse package specification SPEC and return three value: the specified |
| 1986 | package name, version number (or #f), and output name (or OUTPUT). SPEC may |
| 1987 | optionally contain a version number and an output name, as in these examples: |
| 1988 | |
| 1989 | guile |
| 1990 | guile@2.0.9 |
| 1991 | guile:debug |
| 1992 | guile@2.0.9:debug |
| 1993 | " |
| 1994 | (let*-values (((name sub-drv) |
| 1995 | (match (string-rindex spec #\:) |
| 1996 | (#f (values spec output)) |
| 1997 | (colon (values (substring spec 0 colon) |
| 1998 | (substring spec (+ 1 colon)))))) |
| 1999 | ((name version) |
| 2000 | (package-name->name+version name))) |
| 2001 | (values name version sub-drv))) |
| 2002 | |
| 2003 | \f |
| 2004 | ;;; |
| 2005 | ;;; Command-line option processing. |
| 2006 | ;;; |
| 2007 | |
| 2008 | (define (show-guix-usage) |
| 2009 | (format (current-error-port) |
| 2010 | (G_ "Try `guix --help' for more information.~%")) |
| 2011 | (exit 1)) |
| 2012 | |
| 2013 | ;; Representation of a 'guix' command. |
| 2014 | (define-immutable-record-type <command> |
| 2015 | (command name synopsis category) |
| 2016 | command? |
| 2017 | (name command-name) |
| 2018 | (synopsis command-synopsis) |
| 2019 | (category command-category)) |
| 2020 | |
| 2021 | (define (source-file-command file) |
| 2022 | "Read FILE, a Scheme source file, and return either a <command> object based |
| 2023 | on the 'define-command' top-level form found therein, or #f if FILE does not |
| 2024 | contain a 'define-command' form." |
| 2025 | (define command-name |
| 2026 | (match (filter (negate string-null?) |
| 2027 | (string-split file #\/)) |
| 2028 | ((_ ... "guix" (or "scripts" "extensions") name) |
| 2029 | (list (file-sans-extension name))) |
| 2030 | ((_ ... "guix" (or "scripts" "extensions") first second) |
| 2031 | (list first (file-sans-extension second))))) |
| 2032 | |
| 2033 | ;; The strategy here is to parse FILE. This is much cheaper than a |
| 2034 | ;; technique based on run-time introspection where we'd load FILE and all |
| 2035 | ;; the modules it depends on. |
| 2036 | (call-with-input-file file |
| 2037 | (lambda (port) |
| 2038 | (let loop () |
| 2039 | (match (read port) |
| 2040 | (('define-command _ ('synopsis synopsis) |
| 2041 | _ ...) |
| 2042 | (command command-name synopsis 'main)) |
| 2043 | (('define-command _ |
| 2044 | ('category category) ('synopsis synopsis) |
| 2045 | _ ...) |
| 2046 | (command command-name synopsis category)) |
| 2047 | ((? eof-object?) |
| 2048 | #f) |
| 2049 | (_ |
| 2050 | (loop))))))) |
| 2051 | |
| 2052 | (define* (command-files #:optional directory) |
| 2053 | "Return the list of source files that define Guix sub-commands." |
| 2054 | (define directory* |
| 2055 | (or directory |
| 2056 | (and=> (search-path %load-path "guix.scm") |
| 2057 | (compose (cut string-append <> "/guix/scripts") |
| 2058 | dirname)))) |
| 2059 | |
| 2060 | (define dot-scm? |
| 2061 | (cut string-suffix? ".scm" <>)) |
| 2062 | |
| 2063 | (if directory* |
| 2064 | (map (cut string-append directory* "/" <>) |
| 2065 | (scandir directory* dot-scm?)) |
| 2066 | '())) |
| 2067 | |
| 2068 | (define (extension-directories) |
| 2069 | "Return the list of directories containing Guix extensions." |
| 2070 | (filter file-exists? |
| 2071 | (parse-path |
| 2072 | (getenv "GUIX_EXTENSIONS_PATH")))) |
| 2073 | |
| 2074 | (define (commands) |
| 2075 | "Return the list of commands, alphabetically sorted." |
| 2076 | (filter-map source-file-command |
| 2077 | (append (command-files) |
| 2078 | (append-map command-files |
| 2079 | (extension-directories))))) |
| 2080 | |
| 2081 | (define (show-guix-help) |
| 2082 | (define (internal? command) |
| 2083 | (member command '("substitute" "authenticate" "offload" |
| 2084 | "perform-download"))) |
| 2085 | |
| 2086 | (define (display-commands commands) |
| 2087 | (let* ((names (map (lambda (command) |
| 2088 | (string-join (command-name command))) |
| 2089 | commands)) |
| 2090 | (max-width (reduce max 0 (map string-length names)))) |
| 2091 | (for-each (lambda (name command) |
| 2092 | (format #t " ~a ~a~%" |
| 2093 | (string-pad-right name max-width) |
| 2094 | (G_ (command-synopsis command)))) |
| 2095 | names |
| 2096 | commands))) |
| 2097 | |
| 2098 | (define (category-predicate category) |
| 2099 | (lambda (command) |
| 2100 | (eq? category (command-category command)))) |
| 2101 | |
| 2102 | (format #t (G_ "Usage: guix COMMAND ARGS... |
| 2103 | Run COMMAND with ARGS.\n")) |
| 2104 | (newline) |
| 2105 | (format #t (G_ "COMMAND must be one of the sub-commands listed below:\n")) |
| 2106 | |
| 2107 | (let ((commands (commands)) |
| 2108 | (categories (module-ref (resolve-interface '(guix scripts)) |
| 2109 | '%command-categories))) |
| 2110 | (for-each (match-lambda |
| 2111 | (('internal . _) |
| 2112 | #t) ;hide internal commands |
| 2113 | ((category . synopsis) |
| 2114 | (let ((relevant-commands (filter (category-predicate category) |
| 2115 | commands))) |
| 2116 | ;; Only print categories that contain commands. |
| 2117 | (match relevant-commands |
| 2118 | ((one . more) |
| 2119 | (format #t "~% ~a~%" (G_ synopsis)) |
| 2120 | (display-commands relevant-commands)) |
| 2121 | (_ #f))))) |
| 2122 | categories)) |
| 2123 | (show-bug-report-information)) |
| 2124 | |
| 2125 | (define (run-guix-command command . args) |
| 2126 | "Run COMMAND with the given ARGS. Report an error when COMMAND is not |
| 2127 | found." |
| 2128 | (define (command-hint guess commands) |
| 2129 | (define command-names |
| 2130 | (map (lambda (command) |
| 2131 | (match (command-name command) |
| 2132 | ((head tail ...) head))) |
| 2133 | commands)) |
| 2134 | (string-closest (symbol->string guess) command-names #:threshold 3)) |
| 2135 | |
| 2136 | (define module |
| 2137 | ;; Check if there is a matching extension. |
| 2138 | (match (search-path (extension-directories) |
| 2139 | (format #f "~a.scm" command)) |
| 2140 | (#f |
| 2141 | (catch 'misc-error |
| 2142 | (lambda () |
| 2143 | (resolve-interface `(guix scripts ,command))) |
| 2144 | (lambda _ |
| 2145 | (let ((hint (command-hint command (commands)))) |
| 2146 | (format (current-error-port) |
| 2147 | (G_ "guix: ~a: command not found~%") command) |
| 2148 | (when hint |
| 2149 | (display-hint (format #f (G_ "Did you mean @code{~a}?") |
| 2150 | hint))) |
| 2151 | (show-guix-usage))))) |
| 2152 | (file |
| 2153 | (load file) |
| 2154 | (resolve-interface `(guix extensions ,command))))) |
| 2155 | |
| 2156 | (let ((command-main (module-ref module |
| 2157 | (symbol-append 'guix- command)))) |
| 2158 | (parameterize ((program-name command)) |
| 2159 | ;; Disable canonicalization so we don't don't stat unreasonably. |
| 2160 | (with-fluids ((%file-port-name-canonicalization #f)) |
| 2161 | (dynamic-wind |
| 2162 | (const #f) |
| 2163 | (lambda () |
| 2164 | (apply command-main args)) |
| 2165 | (lambda () |
| 2166 | ;; Abuse 'exit-hook' (which is normally meant to be used by the |
| 2167 | ;; REPL) to run things like profiling hooks upon completion. |
| 2168 | (run-hook exit-hook))))))) |
| 2169 | |
| 2170 | (define (run-guix . args) |
| 2171 | "Run the 'guix' command defined by command line ARGS. |
| 2172 | Unlike 'guix-main', this procedure assumes that locale, i18n support, |
| 2173 | and signal handling have already been set up." |
| 2174 | (define option? (cut string-prefix? "-" <>)) |
| 2175 | |
| 2176 | ;; The default %LOAD-EXTENSIONS includes the empty string, which doubles the |
| 2177 | ;; number of 'stat' calls per entry in %LOAD-PATH. Shamelessly remove it. |
| 2178 | (set! %load-extensions '(".scm")) |
| 2179 | |
| 2180 | (match args |
| 2181 | (() |
| 2182 | (format (current-error-port) |
| 2183 | (G_ "guix: missing command name~%")) |
| 2184 | (show-guix-usage)) |
| 2185 | ((or ("-h") ("--help")) |
| 2186 | (leave-on-EPIPE (show-guix-help))) |
| 2187 | ((or ("-V") ("--version")) |
| 2188 | (show-version-and-exit "guix")) |
| 2189 | (((? option? o) args ...) |
| 2190 | (format (current-error-port) |
| 2191 | (G_ "guix: unrecognized option '~a'~%") o) |
| 2192 | (show-guix-usage)) |
| 2193 | (("help" command) |
| 2194 | (apply run-guix-command (string->symbol command) |
| 2195 | '("--help"))) |
| 2196 | (("help" args ...) |
| 2197 | (leave-on-EPIPE (show-guix-help))) |
| 2198 | ((command args ...) |
| 2199 | (apply run-guix-command |
| 2200 | (string->symbol command) |
| 2201 | args)))) |
| 2202 | |
| 2203 | (define (guix-main arg0 . args) |
| 2204 | (initialize-guix) |
| 2205 | (apply run-guix args)) |
| 2206 | |
| 2207 | ;;; Local Variables: |
| 2208 | ;;; eval: (put 'guard* 'scheme-indent-function 2) |
| 2209 | ;;; End: |
| 2210 | |
| 2211 | ;;; ui.scm ends here |