guix/ui.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
   4 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
   5 ;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
   6 ;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com>
   7 ;;;
   8 ;;; This file is part of GNU Guix.
   9 ;;;
  10 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  11 ;;; under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or (at
  13 ;;; your option) any later version.
  14 ;;;
  15 ;;; GNU Guix is distributed in the hope that it will be useful, but
  16 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 (define-module (guix ui)
  24   #:use-module (guix utils)
  25   #:use-module (guix store)
  26   #:use-module (guix config)
  27   #:use-module (guix packages)
  28   #:use-module (guix profiles)
  29   #:use-module (guix derivations)
  30   #:use-module (guix build-system)
  31   #:use-module (guix serialization)
  32   #:use-module ((guix build utils) #:select (mkdir-p))
  33   #:use-module ((guix licenses) #:select (license? license-name))
  34   #:use-module (srfi srfi-1)
  35   #:use-module (srfi srfi-11)
  36   #:use-module (srfi srfi-19)
  37   #:use-module (srfi srfi-26)
  38   #:use-module (srfi srfi-31)
  39   #:use-module (srfi srfi-34)
  40   #:use-module (srfi srfi-35)
  41   #:use-module (srfi srfi-37)
  42   #:autoload   (ice-9 ftw)  (scandir)
  43   #:use-module (ice-9 match)
  44   #:use-module (ice-9 format)
  45   #:use-module (ice-9 regex)
  46   #:autoload   (system repl repl)  (start-repl)
  47   #:autoload   (system repl debug) (make-debug stack->vector)
  48   #:export (_
  49             N_
  50             P_
  51             report-error
  52             leave
  53             make-user-module
  54             load*
  55             warn-about-load-error
  56             show-version-and-exit
  57             show-bug-report-information
  58             string->number*
  59             size->number
  60             show-what-to-build
  61             show-what-to-build*
  62             show-manifest-transaction
  63             call-with-error-handling
  64             with-error-handling
  65             read/eval
  66             read/eval-package-expression
  67             location->string
  68             switch-symlinks
  69             config-directory
  70             fill-paragraph
  71             string->recutils
  72             package->recutils
  73             package-specification->name+version+output
  74             string->generations
  75             string->duration
  76             args-fold*
  77             parse-command-line
  78             run-guix-command
  79             program-name
  80             guix-warning-port
  81             warning
  82             guix-main))
  83
  84 ;;; Commentary:
  85 ;;;
  86 ;;; User interface facilities for command-line tools.
  87 ;;;
  88 ;;; Code:
  89
  90 (define %gettext-domain
  91   ;; Text domain for strings used in the tools.
  92   "guix")
  93
  94 (define %package-text-domain
  95   ;; Text domain for package synopses and descriptions.
  96   "guix-packages")
  97
  98 (define _ (cut gettext <> %gettext-domain))
  99 (define N_ (cut ngettext <> <> <> %gettext-domain))
 100 (define P_ (cut gettext <> %package-text-domain))
 101
 102 (define-syntax-rule (define-diagnostic name prefix)
 103   "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
 104 messages."
 105   (define-syntax name
 106     (lambda (x)
 107       (define (augmented-format-string fmt)
 108         (string-append "~:[~*~;guix ~a: ~]~a" (syntax->datum fmt)))
 109
 110       (syntax-case x ()
 111         ((name (underscore fmt) args (... ...))
 112          (and (string? (syntax->datum #'fmt))
 113               (free-identifier=? #'underscore #'_))
 114          (with-syntax ((fmt*   (augmented-format-string #'fmt))
 115                        (prefix (datum->syntax x prefix)))
 116            #'(format (guix-warning-port) (gettext fmt*)
 117                      (program-name) (program-name) prefix
 118                      args (... ...))))
 119         ((name (N-underscore singular plural n) args (... ...))
 120          (and (string? (syntax->datum #'singular))
 121               (string? (syntax->datum #'plural))
 122               (free-identifier=? #'N-underscore #'N_))
 123          (with-syntax ((s      (augmented-format-string #'singular))
 124                        (p      (augmented-format-string #'plural))
 125                        (prefix (datum->syntax x prefix)))
 126            #'(format (guix-warning-port)
 127                      (ngettext s p n %gettext-domain)
 128                      (program-name) (program-name) prefix
 129                      args (... ...))))))))
 130
 131 (define-diagnostic warning "warning: ") ; emit a warning
 132
 133 (define-diagnostic report-error "error: ")
 134 (define-syntax-rule (leave args ...)
 135   "Emit an error message and exit."
 136   (begin
 137     (report-error args ...)
 138     (exit 1)))
 139
 140 (define (make-user-module modules)
 141   "Return a new user module with the additional MODULES loaded."
 142   ;; Module in which the machine description file is loaded.
 143   (let ((module (make-fresh-user-module)))
 144     (for-each (lambda (iface)
 145                 (module-use! module (resolve-interface iface)))
 146               modules)
 147     module))
 148
 149 (define* (load* file user-module
 150                 #:key (on-error 'nothing-special))
 151   "Load the user provided Scheme source code FILE."
 152   (define (frame-with-source frame)
 153     ;; Walk from FRAME upwards until source location information is found.
 154     (let loop ((frame    frame)
 155                (previous frame))
 156       (if (not frame)
 157           previous
 158           (if (frame-source frame)
 159               frame
 160               (loop (frame-previous frame) frame)))))
 161
 162   (define (error-string frame args)
 163     (call-with-output-string
 164      (lambda (port)
 165        (apply display-error frame port (cdr args)))))
 166
 167   (define tag
 168     (make-prompt-tag "user-code"))
 169
 170   (catch #t
 171     (lambda ()
 172       ;; XXX: Force a recompilation to avoid ABI issues.
 173       (set! %fresh-auto-compile #t)
 174       (set! %load-should-auto-compile #t)
 175
 176       (save-module-excursion
 177        (lambda ()
 178          (set-current-module user-module)
 179
 180          ;; Hide the "auto-compiling" messages.
 181          (parameterize ((current-warning-port (%make-void-port "w")))
 182            (call-with-prompt tag
 183              (lambda ()
 184                ;; Give 'load' an absolute file name so that it doesn't try to
 185                ;; search for FILE in %LOAD-PATH.  Note: use 'load', not
 186                ;; 'primitive-load', so that FILE is compiled, which then allows us
 187                ;; to provide better error reporting with source line numbers.
 188                (load (canonicalize-path file)))
 189              (const #f))))))
 190     (lambda _
 191       ;; XXX: Errors are reported from the pre-unwind handler below, but
 192       ;; calling 'exit' from there has no effect, so we call it here.
 193       (exit 1))
 194     (rec (handle-error . args)
 195          ;; Capture the stack up to this procedure call, excluded, and pass
 196          ;; the faulty stack frame to 'report-load-error'.
 197          (let* ((stack (make-stack #t handle-error tag))
 198                 (depth (stack-length stack))
 199                 (last  (and (> depth 0) (stack-ref stack 0)))
 200                 (frame (frame-with-source
 201                         (if (> depth 1)
 202                             (stack-ref stack 1)   ;skip the 'throw' frame
 203                             last))))
 204
 205            (report-load-error file args frame)
 206
 207            (case on-error
 208              ((debug)
 209               (newline)
 210               (display (_ "entering debugger; type ',bt' for a backtrace\n"))
 211               (start-repl #:debug (make-debug (stack->vector stack) 0
 212                                               (error-string frame args)
 213                                               #f)))
 214              ((backtrace)
 215               (newline (current-error-port))
 216               (display-backtrace stack (current-error-port)))
 217              (else
 218               #t))))))
 219
 220 (define* (report-load-error file args #:optional frame)
 221   "Report the failure to load FILE, a user-provided Scheme file.
 222 ARGS is the list of arguments received by the 'throw' handler."
 223   (match args
 224     (('system-error . _)
 225      (let ((err (system-error-errno args)))
 226        (report-error (_ "failed to load '~a': ~a~%") file (strerror err))))
 227     (('syntax-error proc message properties form . rest)
 228      (let ((loc (source-properties->location properties)))
 229        (format (current-error-port) (_ "~a: error: ~a~%")
 230                (location->string loc) message)))
 231     (('srfi-34 obj)
 232      (report-error (_ "exception thrown: ~s~%") obj))
 233     ((error args ...)
 234      (report-error (_ "failed to load '~a':~%") file)
 235      (apply display-error frame (current-error-port) args))))
 236
 237 (define (warn-about-load-error file args)         ;FIXME: factorize with ↑
 238   "Report the failure to load FILE, a user-provided Scheme file, without
 239 exiting.  ARGS is the list of arguments received by the 'throw' handler."
 240   (match args
 241     (('system-error . _)
 242      (let ((err (system-error-errno args)))
 243        (warning (_ "failed to load '~a': ~a~%") file (strerror err))))
 244     (('syntax-error proc message properties form . rest)
 245      (let ((loc (source-properties->location properties)))
 246        (format (current-error-port) (_ "~a: warning: ~a~%")
 247                (location->string loc) message)))
 248     (('srfi-34 obj)
 249      (warning (_ "failed to load '~a': exception thrown: ~s~%")
 250               file obj))
 251     ((error args ...)
 252      (warning (_ "failed to load '~a':~%") file)
 253      (apply display-error #f (current-error-port) args))))
 254
 255 (define (install-locale)
 256   "Install the current locale settings."
 257   (catch 'system-error
 258     (lambda _
 259       (setlocale LC_ALL ""))
 260     (lambda args
 261       (warning (_ "failed to install locale: ~a~%")
 262                (strerror (system-error-errno args))))))
 263
 264 (define (initialize-guix)
 265   "Perform the usual initialization for stand-alone Guix commands."
 266   (install-locale)
 267   (textdomain %gettext-domain)
 268
 269   ;; Ignore SIGPIPE.  If the daemon closes the connection, we prefer to be
 270   ;; notified via an EPIPE later.
 271   (sigaction SIGPIPE SIG_IGN)
 272
 273   (setvbuf (current-output-port) _IOLBF)
 274   (setvbuf (current-error-port) _IOLBF))
 275
 276 (define* (show-version-and-exit #:optional (command (car (command-line))))
 277   "Display version information for COMMAND and `(exit 0)'."
 278   (simple-format #t "~a (~a) ~a~%"
 279                  command %guix-package-name %guix-version)
 280   (display (_ "Copyright (C) 2015 the Guix authors
 281 License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
 282 This is free software: you are free to change and redistribute it.
 283 There is NO WARRANTY, to the extent permitted by law.
 284 "))
 285   (exit 0))
 286
 287 (define (show-bug-report-information)
 288   (format #t (_ "
 289 Report bugs to: ~a.") %guix-bug-report-address)
 290   (format #t (_ "
 291 ~a home page: <~a>") %guix-package-name %guix-home-page-url)
 292   (display (_ "
 293 General help using GNU software: <http://www.gnu.org/gethelp/>"))
 294   (newline))
 295
 296 (set! symlink
 297   ;; We 'set!' the global binding because (gnu build ...) modules and similar
 298   ;; typically don't use (guix ui).
 299   (let ((real-symlink (@ (guile) symlink)))
 300     (lambda (target link)
 301       "This is a 'symlink' replacement that provides proper error reporting."
 302       (catch 'system-error
 303         (lambda ()
 304           (real-symlink target link))
 305         (lambda (key proc fmt args errno)
 306           ;; Augment the FMT and ARGS with information about LINK (this
 307           ;; information is missing as of Guile 2.0.11, making the exception
 308           ;; uninformative.)
 309           (apply throw key proc "~A: ~S"
 310                  (list (strerror (car errno)) link)
 311                  (list errno)))))))
 312
 313 (set! copy-file
 314   ;; Note: here we use 'set!', not #:replace, because UIs typically use
 315   ;; 'copy-recursively', which doesn't use (guix ui).
 316   (let ((real-copy-file (@ (guile) copy-file)))
 317     (lambda (source target)
 318       "This is a 'copy-file' replacement that provides proper error reporting."
 319       (catch 'system-error
 320         (lambda ()
 321           (real-copy-file source target))
 322         (lambda (key proc fmt args errno)
 323           ;; Augment the FMT and ARGS with information about TARGET (this
 324           ;; information is missing as of Guile 2.0.11, making the exception
 325           ;; uninformative.)
 326           (apply throw key proc "~A: ~S"
 327                  (list (strerror (car errno)) target)
 328                  (list errno)))))))
 329
 330 (define (string->number* str)
 331   "Like `string->number', but error out with an error message on failure."
 332   (or (string->number str)
 333       (leave (_ "~a: invalid number~%") str)))
 334
 335 (define (size->number str)
 336   "Convert STR, a storage measurement representation such as \"1024\" or
 337 \"1MiB\", to a number of bytes.  Raise an error if STR could not be
 338 interpreted."
 339   (define unit-pos
 340     (string-rindex str char-set:digit))
 341
 342   (define unit
 343     (and unit-pos (substring str (+ 1 unit-pos))))
 344
 345   (let* ((numstr (if unit-pos
 346                      (substring str 0 (+ 1 unit-pos))
 347                      str))
 348          (num    (string->number numstr)))
 349     (unless num
 350       (leave (_ "invalid number: ~a~%") numstr))
 351
 352     ((compose inexact->exact round)
 353      (* num
 354         (match unit
 355           ((or "KiB" "K" "k") (expt 2 10))
 356           ((or "MiB" "M")     (expt 2 20))
 357           ((or "GiB" "G")     (expt 2 30))
 358           ((or "TiB" "T")     (expt 2 40))
 359           ((or "PiB" "P")     (expt 2 50))
 360           ((or "EiB" "E")     (expt 2 60))
 361           ((or "ZiB" "Z")     (expt 2 70))
 362           ((or "YiB" "Y")     (expt 2 80))
 363           ("kB"  (expt 10 3))
 364           ("MB"  (expt 10 6))
 365           ("GB"  (expt 10 9))
 366           ("TB"  (expt 10 12))
 367           ("PB"  (expt 10 15))
 368           ("EB"  (expt 10 18))
 369           ("ZB"  (expt 10 21))
 370           ("YB"  (expt 10 24))
 371           (""    1)
 372           (_
 373            (leave (_ "unknown unit: ~a~%") unit)))))))
 374
 375 (define (call-with-error-handling thunk)
 376   "Call THUNK within a user-friendly error handler."
 377   (guard (c ((package-input-error? c)
 378              (let* ((package  (package-error-package c))
 379                     (input    (package-error-invalid-input c))
 380                     (location (package-location package))
 381                     (file     (location-file location))
 382                     (line     (location-line location))
 383                     (column   (location-column location)))
 384                (leave (_ "~a:~a:~a: package `~a' has an invalid input: ~s~%")
 385                       file line column
 386                       (package-full-name package) input)))
 387             ((package-cross-build-system-error? c)
 388              (let* ((package (package-error-package c))
 389                     (loc     (package-location package))
 390                     (system  (package-build-system package)))
 391                (leave (_ "~a: ~a: build system `~a' does not support cross builds~%")
 392                       (location->string loc)
 393                       (package-full-name package)
 394                       (build-system-name system))))
 395             ((profile-not-found-error? c)
 396              (leave (_ "profile '~a' does not exist~%")
 397                     (profile-error-profile c)))
 398             ((missing-generation-error? c)
 399              (leave (_ "generation ~a of profile '~a' does not exist~%")
 400                     (missing-generation-error-generation c)
 401                     (profile-error-profile c)))
 402             ((nar-error? c)
 403              (let ((file (nar-error-file c))
 404                    (port (nar-error-port c)))
 405                (if file
 406                    (leave (_ "corrupt input while restoring '~a' from ~s~%")
 407                           file (or (port-filename port) port))
 408                    (leave (_ "corrupt input while restoring archive from ~s~%")
 409                           (or (port-filename port) port)))))
 410             ((nix-connection-error? c)
 411              (leave (_ "failed to connect to `~a': ~a~%")
 412                     (nix-connection-error-file c)
 413                     (strerror (nix-connection-error-code c))))
 414             ((nix-protocol-error? c)
 415              ;; FIXME: Server-provided error messages aren't i18n'd.
 416              (leave (_ "build failed: ~a~%")
 417                     (nix-protocol-error-message c)))
 418             ((derivation-missing-output-error? c)
 419              (leave (_ "reference to invalid output '~a' of derivation '~a'~%")
 420                     (derivation-missing-output c)
 421                     (derivation-file-name (derivation-error-derivation c))))
 422             ((message-condition? c)
 423              ;; Normally '&message' error conditions have an i18n'd message.
 424              (leave (_ "~a~%")
 425                     (gettext (condition-message c) %gettext-domain))))
 426     ;; Catch EPIPE and the likes.
 427     (catch 'system-error
 428       thunk
 429       (lambda (key proc format-string format-args . rest)
 430         (leave (_ "~a: ~a~%") proc
 431                (apply format #f format-string format-args))))))
 432
 433 (define %guix-user-module
 434   ;; Module in which user expressions are evaluated.
 435   ;; Compute lazily to avoid circularity with (guix gexp).
 436   (delay
 437     (let ((module (make-module)))
 438       (beautify-user-module! module)
 439       ;; Use (guix gexp) so that one can use #~ & co.
 440       (module-use! module (resolve-interface '(guix gexp)))
 441       module)))
 442
 443 (define (read/eval str)
 444   "Read and evaluate STR, raising an error if something goes wrong."
 445   (let ((exp (catch #t
 446                (lambda ()
 447                  (call-with-input-string str read))
 448                (lambda args
 449                  (leave (_ "failed to read expression ~s: ~s~%")
 450                         str args)))))
 451     (catch #t
 452       (lambda ()
 453         (eval exp (force %guix-user-module)))
 454       (lambda args
 455         (report-error (_ "failed to evaluate expression '~a':~%") exp)
 456         (match args
 457           (('syntax-error proc message properties form . rest)
 458            (report-error (_ "syntax error: ~a~%") message))
 459           (('srfi-34 obj)
 460            (report-error (_ "exception thrown: ~s~%") obj))
 461           ((error args ...)
 462            (apply display-error #f (current-error-port) args))
 463           (what? #f))
 464         (exit 1)))))
 465
 466 (define (read/eval-package-expression str)
 467   "Read and evaluate STR and return the package it refers to, or exit an
 468 error."
 469   (match (read/eval str)
 470     ((? package? p) p)
 471     (_
 472      (leave (_ "expression ~s does not evaluate to a package~%")
 473             str))))
 474
 475 (define* (show-what-to-build store drv
 476                              #:key dry-run? (use-substitutes? #t))
 477   "Show what will or would (depending on DRY-RUN?) be built in realizing the
 478 derivations listed in DRV.  Return #t if there's something to build, #f
 479 otherwise.  When USE-SUBSTITUTES?, check and report what is prerequisites are
 480 available for download."
 481   (define substitutable?
 482     ;; Call 'substitutation-oracle' upfront so we don't end up launching the
 483     ;; substituter many times.  This makes a big difference, especially when
 484     ;; DRV is a long list as is the case with 'guix environment'.
 485     (if use-substitutes?
 486         (substitution-oracle store drv)
 487         (const #f)))
 488
 489   (define (built-or-substitutable? drv)
 490     (or (null? (derivation-outputs drv))
 491         (let ((out (derivation->output-path drv))) ;XXX: assume "out" exists
 492           (or (valid-path? store out)
 493               (substitutable? out)))))
 494
 495   (let*-values (((build download)
 496                  (fold2 (lambda (drv build download)
 497                           (let-values (((b d)
 498                                         (derivation-prerequisites-to-build
 499                                          store drv
 500                                          #:substitutable? substitutable?)))
 501                             (values (append b build)
 502                                     (append d download))))
 503                         '() '()
 504                         drv))
 505                 ((build)                          ; add the DRV themselves
 506                  (delete-duplicates
 507                   (append (map derivation-file-name
 508                                (remove built-or-substitutable? drv))
 509                           (map derivation-input-path build))))
 510                 ((download)                   ; add the references of DOWNLOAD
 511                  (if use-substitutes?
 512                      (delete-duplicates
 513                       (append download
 514                               (remove (cut valid-path? store <>)
 515                                       (append-map
 516                                        substitutable-references
 517                                        (substitutable-path-info store
 518                                                                 download)))))
 519                      download)))
 520     ;; TODO: Show the installed size of DOWNLOAD.
 521     (if dry-run?
 522         (begin
 523           (format (current-error-port)
 524                   (N_ "~:[The following derivation would be built:~%~{   ~a~%~}~;~]"
 525                       "~:[The following derivations would be built:~%~{   ~a~%~}~;~]"
 526                       (length build))
 527                   (null? build) build)
 528           (format (current-error-port)
 529                   (N_ "~:[The following file would be downloaded:~%~{   ~a~%~}~;~]"
 530                       "~:[The following files would be downloaded:~%~{   ~a~%~}~;~]"
 531                       (length download))
 532                   (null? download) download))
 533         (begin
 534           (format (current-error-port)
 535                   (N_ "~:[The following derivation will be built:~%~{   ~a~%~}~;~]"
 536                       "~:[The following derivations will be built:~%~{   ~a~%~}~;~]"
 537                       (length build))
 538                   (null? build) build)
 539           (format (current-error-port)
 540                   (N_ "~:[The following file will be downloaded:~%~{   ~a~%~}~;~]"
 541                       "~:[The following files will be downloaded:~%~{   ~a~%~}~;~]"
 542                       (length download))
 543                   (null? download) download)))
 544     (pair? build)))
 545
 546 (define show-what-to-build*
 547   (store-lift show-what-to-build))
 548
 549 (define (right-arrow port)
 550   "Return either a string containing the 'RIGHT ARROW' character, or an ASCII
 551 replacement if PORT is not Unicode-capable."
 552   (with-fluids ((%default-port-encoding (port-encoding port)))
 553     (let ((arrow "→"))
 554       (catch 'encoding-error
 555         (lambda ()
 556           (call-with-output-string
 557             (lambda (port)
 558               (set-port-conversion-strategy! port 'error)
 559               (display arrow port))))
 560         (lambda (key . args)
 561           "->")))))
 562
 563 (define* (show-manifest-transaction store manifest transaction
 564                                     #:key dry-run?)
 565   "Display what will/would be installed/removed from MANIFEST by TRANSACTION."
 566   (define (package-strings name version output item)
 567     (map (lambda (name version output item)
 568            (format #f "   ~a~:[:~a~;~*~]\t~a\t~a"
 569                    name
 570                    (equal? output "out") output version
 571                    (if (package? item)
 572                        (package-output store item output)
 573                        item)))
 574          name version output item))
 575
 576   (define →                        ;an arrow that can be represented on stderr
 577     (right-arrow (current-error-port)))
 578
 579   (define (upgrade-string name old-version new-version output item)
 580     (format #f "   ~a~:[:~a~;~*~]\t~a ~a ~a\t~a"
 581             name (equal? output "out") output
 582             old-version → new-version
 583             (if (package? item)
 584                 (package-output store item output)
 585                 item)))
 586
 587   (let-values (((remove install upgrade downgrade)
 588                 (manifest-transaction-effects manifest transaction)))
 589     (match remove
 590       ((($ <manifest-entry> name version output item) ..1)
 591        (let ((len    (length name))
 592              (remove (package-strings name version output item)))
 593          (if dry-run?
 594              (format (current-error-port)
 595                      (N_ "The following package would be removed:~%~{~a~%~}~%"
 596                          "The following packages would be removed:~%~{~a~%~}~%"
 597                          len)
 598                      remove)
 599              (format (current-error-port)
 600                      (N_ "The following package will be removed:~%~{~a~%~}~%"
 601                          "The following packages will be removed:~%~{~a~%~}~%"
 602                          len)
 603                      remove))))
 604       (_ #f))
 605     (match downgrade
 606       (((($ <manifest-entry> name old-version)
 607          . ($ <manifest-entry> _ new-version output item)) ..1)
 608        (let ((len       (length name))
 609              (downgrade (map upgrade-string
 610                              name old-version new-version output item)))
 611          (if dry-run?
 612              (format (current-error-port)
 613                      (N_ "The following package would be downgraded:~%~{~a~%~}~%"
 614                          "The following packages would be downgraded:~%~{~a~%~}~%"
 615                          len)
 616                      downgrade)
 617              (format (current-error-port)
 618                      (N_ "The following package will be downgraded:~%~{~a~%~}~%"
 619                          "The following packages will be downgraded:~%~{~a~%~}~%"
 620                          len)
 621                      downgrade))))
 622       (_ #f))
 623     (match upgrade
 624       (((($ <manifest-entry> name old-version)
 625          . ($ <manifest-entry> _ new-version output item)) ..1)
 626        (let ((len     (length name))
 627              (upgrade (map upgrade-string
 628                            name old-version new-version output item)))
 629          (if dry-run?
 630              (format (current-error-port)
 631                      (N_ "The following package would be upgraded:~%~{~a~%~}~%"
 632                          "The following packages would be upgraded:~%~{~a~%~}~%"
 633                          len)
 634                      upgrade)
 635              (format (current-error-port)
 636                      (N_ "The following package will be upgraded:~%~{~a~%~}~%"
 637                          "The following packages will be upgraded:~%~{~a~%~}~%"
 638                          len)
 639                      upgrade))))
 640       (_ #f))
 641     (match install
 642       ((($ <manifest-entry> name version output item _) ..1)
 643        (let ((len     (length name))
 644              (install (package-strings name version output item)))
 645          (if dry-run?
 646              (format (current-error-port)
 647                      (N_ "The following package would be installed:~%~{~a~%~}~%"
 648                          "The following packages would be installed:~%~{~a~%~}~%"
 649                          len)
 650                      install)
 651              (format (current-error-port)
 652                      (N_ "The following package will be installed:~%~{~a~%~}~%"
 653                          "The following packages will be installed:~%~{~a~%~}~%"
 654                          len)
 655                      install))))
 656       (_ #f))))
 657
 658 (define-syntax with-error-handling
 659   (syntax-rules ()
 660     "Run BODY within a user-friendly error condition handler."
 661     ((_ body ...)
 662      (call-with-error-handling
 663       (lambda ()
 664         body ...)))))
 665
 666 (define (location->string loc)
 667   "Return a human-friendly, GNU-standard representation of LOC."
 668   (match loc
 669     (#f (_ "<unknown location>"))
 670     (($ <location> file line column)
 671      (format #f "~a:~a:~a" file line column))))
 672
 673 (define (switch-symlinks link target)
 674   "Atomically switch LINK, a symbolic link, to point to TARGET.  Works
 675 both when LINK already exists and when it does not."
 676   (let ((pivot (string-append link ".new")))
 677     (symlink target pivot)
 678     (rename-file pivot link)))
 679
 680 (define (config-directory)
 681   "Return the name of the configuration directory, after making sure that it
 682 exists.  Honor the XDG specs,
 683 <http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html>."
 684   (let ((dir (and=> (or (getenv "XDG_CONFIG_HOME")
 685                         (and=> (getenv "HOME")
 686                                (cut string-append <> "/.config")))
 687                     (cut string-append <> "/guix"))))
 688     (catch 'system-error
 689       (lambda ()
 690         (mkdir-p dir)
 691         dir)
 692       (lambda args
 693         (let ((err (system-error-errno args)))
 694           ;; ERR is necessarily different from EEXIST.
 695           (leave (_ "failed to create configuration directory `~a': ~a~%")
 696                  dir (strerror err)))))))
 697
 698 (define* (fill-paragraph str width #:optional (column 0))
 699   "Fill STR such that each line contains at most WIDTH characters, assuming
 700 that the first character is at COLUMN.
 701
 702 When STR contains a single line break surrounded by other characters, it is
 703 converted to a space; sequences of more than one line break are preserved."
 704   (define (maybe-break chr result)
 705     (match result
 706       ((column newlines chars)
 707        (case chr
 708          ((#\newline)
 709           `(,column ,(+ 1 newlines) ,chars))
 710          (else
 711           (let* ((spaces (if (and (pair? chars) (eqv? (car chars) #\.)) 2 1))
 712                  (chars  (case newlines
 713                            ((0) chars)
 714                            ((1)
 715                             (append (make-list spaces #\space) chars))
 716                            (else
 717                             (append (make-list newlines #\newline) chars))))
 718                  (column (case newlines
 719                            ((0) column)
 720                            ((1) (+ spaces column))
 721                            (else 0))))
 722             (let ((chars  (cons chr chars))
 723                   (column (+ 1 column)))
 724               (if (> column width)
 725                   (let*-values (((before after)
 726                                  (break (cut eqv? #\space <>) chars))
 727                                 ((len)
 728                                  (length before)))
 729                     (if (<= len width)
 730                         `(,len
 731                           0
 732                           ,(if (null? after)
 733                                before
 734                                (append before
 735                                        (cons #\newline
 736                                              (drop-while (cut eqv? #\space <>)
 737                                                          after)))))
 738                         `(,column 0 ,chars)))     ; unbreakable
 739                   `(,column 0 ,chars)))))))))
 740
 741   (match (string-fold maybe-break
 742                       `(,column 0 ())
 743                       str)
 744     ((_ _ chars)
 745      (list->string (reverse chars)))))
 746
 747 \f
 748 ;;;
 749 ;;; Packages.
 750 ;;;
 751
 752 (define (string->recutils str)
 753   "Return a version of STR where newlines have been replaced by newlines
 754 followed by \"+ \", which makes for a valid multi-line field value in the
 755 `recutils' syntax."
 756   (list->string
 757    (string-fold-right (lambda (chr result)
 758                         (if (eqv? chr #\newline)
 759                             (cons* chr #\+ #\space result)
 760                             (cons chr result)))
 761                       '()
 762                       str)))
 763
 764 (define* (package->recutils p port
 765                             #:optional (width (or (and=> (getenv "WIDTH")
 766                                                          string->number)
 767                                                   80)))
 768   "Write to PORT a `recutils' record of package P, arranging to fit within
 769 WIDTH columns."
 770   (define (description->recutils str)
 771     (let ((str (P_ str)))
 772       (string->recutils
 773        (fill-paragraph str width
 774                        (string-length "description: ")))))
 775
 776   (define (dependencies->recutils packages)
 777     (let ((list (string-join (map package-full-name
 778                                   (sort packages package<?)) " ")))
 779       (string->recutils
 780        (fill-paragraph list width
 781                        (string-length "dependencies: ")))))
 782
 783   (define (package<? p1 p2)
 784     (string<? (package-full-name p1) (package-full-name p2)))
 785
 786   ;; Note: Don't i18n field names so that people can post-process it.
 787   (format port "name: ~a~%" (package-name p))
 788   (format port "version: ~a~%" (package-version p))
 789   (format port "systems: ~a~%"
 790           (string-join (package-transitive-supported-systems p)))
 791   (format port "dependencies: ~a~%"
 792           (match (package-direct-inputs p)
 793             (((labels inputs . _) ...)
 794              (dependencies->recutils (filter package? inputs)))))
 795   (format port "location: ~a~%"
 796           (or (and=> (package-location p) location->string)
 797               (_ "unknown")))
 798
 799   ;; Note: Starting from version 1.6 or recutils, hyphens are not allowed in
 800   ;; field identifiers.
 801   (format port "homepage: ~a~%" (package-home-page p))
 802
 803   (format port "license: ~a~%"
 804           (match (package-license p)
 805             (((? license? licenses) ...)
 806              (string-join (map license-name licenses)
 807                           ", "))
 808             ((? license? license)
 809              (license-name license))
 810             (x
 811              (_ "unknown"))))
 812   (format port "synopsis: ~a~%"
 813           (string-map (match-lambda
 814                        (#\newline #\space)
 815                        (chr       chr))
 816                       (or (and=> (package-synopsis p) P_)
 817                           "")))
 818   (format port "description: ~a~%"
 819           (and=> (package-description p) description->recutils))
 820   (newline port))
 821
 822 (define (string->generations str)
 823   "Return the list of generations matching a pattern in STR.  This function
 824 accepts the following patterns: \"1\", \"1,2,3\", \"1..9\", \"1..\", \"..9\"."
 825   (define (maybe-integer)
 826     (let ((x (string->number str)))
 827       (and (integer? x)
 828            x)))
 829
 830   (define (maybe-comma-separated-integers)
 831     (let ((lst (delete-duplicates
 832                 (map string->number
 833                      (string-split str #\,)))))
 834       (and (every integer? lst)
 835            lst)))
 836
 837   (cond ((maybe-integer)
 838          =>
 839          list)
 840         ((maybe-comma-separated-integers)
 841          =>
 842          identity)
 843         ((string-match "^([0-9]+)\\.\\.([0-9]+)$" str)
 844          =>
 845          (lambda (match)
 846            (let ((s (string->number (match:substring match 1)))
 847                  (e (string->number (match:substring match 2))))
 848              (and (every integer? (list s e))
 849                   (<= s e)
 850                   (iota (1+ (- e s)) s)))))
 851         ((string-match "^([0-9]+)\\.\\.$" str)
 852          =>
 853          (lambda (match)
 854            (let ((s (string->number (match:substring match 1))))
 855              (and (integer? s)
 856                   `(>= ,s)))))
 857         ((string-match "^\\.\\.([0-9]+)$" str)
 858          =>
 859          (lambda (match)
 860            (let ((e (string->number (match:substring match 1))))
 861              (and (integer? e)
 862                   `(<= ,e)))))
 863         (else #f)))
 864
 865 (define (string->duration str)
 866   "Return the duration matching a pattern in STR.  This function accepts the
 867 following patterns: \"1d\", \"1w\", \"1m\"."
 868   (define (hours->duration hours match)
 869     (make-time time-duration 0
 870                (* 3600 hours (string->number (match:substring match 1)))))
 871
 872   (cond ((string-match "^([0-9]+)d$" str)
 873          =>
 874          (lambda (match)
 875            (hours->duration 24 match)))
 876         ((string-match "^([0-9]+)w$" str)
 877          =>
 878          (lambda (match)
 879            (hours->duration (* 24 7) match)))
 880         ((string-match "^([0-9]+)m$" str)
 881          =>
 882          (lambda (match)
 883            (hours->duration (* 24 30) match)))
 884         (else #f)))
 885
 886 (define* (package-specification->name+version+output spec
 887                                                      #:optional (output "out"))
 888   "Parse package specification SPEC and return three value: the specified
 889 package name, version number (or #f), and output name (or OUTPUT).  SPEC may
 890 optionally contain a version number and an output name, as in these examples:
 891
 892   guile
 893   guile-2.0.9
 894   guile:debug
 895   guile-2.0.9:debug
 896 "
 897   (let*-values (((name sub-drv)
 898                  (match (string-rindex spec #\:)
 899                    (#f    (values spec output))
 900                    (colon (values (substring spec 0 colon)
 901                                   (substring spec (+ 1 colon))))))
 902                 ((name version)
 903                  (package-name->name+version name)))
 904     (values name version sub-drv)))
 905
 906 \f
 907 ;;;
 908 ;;; Command-line option processing.
 909 ;;;
 910
 911 (define (args-fold* options unrecognized-option-proc operand-proc . seeds)
 912   "A wrapper on top of `args-fold' that does proper user-facing error
 913 reporting."
 914   (catch 'misc-error
 915     (lambda ()
 916       (apply args-fold options unrecognized-option-proc
 917              operand-proc seeds))
 918     (lambda (key proc msg args . rest)
 919       ;; XXX: MSG is not i18n'd.
 920       (leave (_ "invalid argument: ~a~%")
 921              (apply format #f msg args)))))
 922
 923 (define (environment-build-options)
 924   "Return additional build options passed as environment variables."
 925   (arguments-from-environment-variable "GUIX_BUILD_OPTIONS"))
 926
 927 (define %default-argument-handler
 928   ;; The default handler for non-option command-line arguments.
 929   (lambda (arg result)
 930     (alist-cons 'argument arg result)))
 931
 932 (define* (parse-command-line args options seeds
 933                              #:key
 934                              (argument-handler %default-argument-handler))
 935   "Parse the command-line arguments ARGS as well as arguments passed via the
 936 'GUIX_BUILD_OPTIONS' environment variable according to OPTIONS (a list of
 937 SRFI-37 options) and return the result, seeded by SEEDS.
 938 Command-line options take precedence those passed via 'GUIX_BUILD_OPTIONS'.
 939
 940 ARGUMENT-HANDLER is called for non-option arguments, like the 'operand-proc'
 941 parameter of 'args-fold'."
 942   (define (parse-options-from args seeds)
 943     ;; Actual parsing takes place here.
 944     (apply args-fold* args options
 945            (lambda (opt name arg . rest)
 946              (leave (_ "~A: unrecognized option~%") name))
 947            argument-handler
 948            seeds))
 949
 950   (call-with-values
 951       (lambda ()
 952         (parse-options-from (environment-build-options) seeds))
 953     (lambda seeds
 954       ;; ARGS take precedence over what the environment variable specifies.
 955       (parse-options-from args seeds))))
 956
 957 (define (show-guix-usage)
 958   (format (current-error-port)
 959           (_ "Try `guix --help' for more information.~%"))
 960   (exit 1))
 961
 962 (define (command-files)
 963   "Return the list of source files that define Guix sub-commands."
 964   (define directory
 965     (and=> (search-path %load-path "guix.scm")
 966            (compose (cut string-append <> "/guix/scripts")
 967                     dirname)))
 968
 969   (define dot-scm?
 970     (cut string-suffix? ".scm" <>))
 971
 972   (if directory
 973       (scandir directory dot-scm?)
 974       '()))
 975
 976 (define (commands)
 977   "Return the list of Guix command names."
 978   (map (compose (cut string-drop-right <> 4)
 979                 basename)
 980        (command-files)))
 981
 982 (define (show-guix-help)
 983   (define (internal? command)
 984     (member command '("substitute" "authenticate" "offload")))
 985
 986   (format #t (_ "Usage: guix COMMAND ARGS...
 987 Run COMMAND with ARGS.\n"))
 988   (newline)
 989   (format #t (_ "COMMAND must be one of the sub-commands listed below:\n"))
 990   (newline)
 991   ;; TODO: Display a synopsis of each command.
 992   (format #t "~{   ~a~%~}" (sort (remove internal? (commands))
 993                                  string<?))
 994   (show-bug-report-information))
 995
 996 (define program-name
 997   ;; Name of the command-line program currently executing, or #f.
 998   (make-parameter #f))
 999
1000 (define (run-guix-command command . args)
1001   "Run COMMAND with the given ARGS.  Report an error when COMMAND is not
1002 found."
1003   (define module
1004     (catch 'misc-error
1005       (lambda ()
1006         (resolve-interface `(guix scripts ,command)))
1007       (lambda -
1008         (format (current-error-port)
1009                 (_ "guix: ~a: command not found~%") command)
1010         (show-guix-usage))))
1011
1012   (let ((command-main (module-ref module
1013                                   (symbol-append 'guix- command))))
1014     (parameterize ((program-name command))
1015       (apply command-main args))))
1016
1017 (define guix-warning-port
1018   (make-parameter (current-warning-port)))
1019
1020 (define (guix-main arg0 . args)
1021   (initialize-guix)
1022   (let ()
1023     (define (option? str) (string-prefix? "-" str))
1024     (match args
1025       (()
1026        (format (current-error-port)
1027                (_ "guix: missing command name~%"))
1028        (show-guix-usage))
1029       ((or ("-h") ("--help"))
1030        (show-guix-help))
1031       (("--version")
1032        (show-version-and-exit "guix"))
1033       (((? option? o) args ...)
1034        (format (current-error-port)
1035                (_ "guix: unrecognized option '~a'~%") o)
1036        (show-guix-usage))
1037       (("help" args ...)
1038        (show-guix-help))
1039       ((command args ...)
1040        (apply run-guix-command
1041               (string->symbol command)
1042               args)))))
1043
1044 ;;; ui.scm ends here