guix/ui.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
   4 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (guix ui)
  22   #:use-module (guix utils)
  23   #:use-module (guix store)
  24   #:use-module (guix config)
  25   #:use-module (guix packages)
  26   #:use-module (guix build-system)
  27   #:use-module (guix derivations)
  28   #:use-module ((guix licenses) #:select (license? license-name))
  29   #:use-module (srfi srfi-1)
  30   #:use-module (srfi srfi-11)
  31   #:use-module (srfi srfi-26)
  32   #:use-module (srfi srfi-34)
  33   #:use-module (srfi srfi-37)
  34   #:autoload   (ice-9 ftw)  (scandir)
  35   #:use-module (ice-9 match)
  36   #:use-module (ice-9 format)
  37   #:export (_
  38             N_
  39             leave
  40             show-version-and-exit
  41             show-bug-report-information
  42             string->number*
  43             show-what-to-build
  44             call-with-error-handling
  45             with-error-handling
  46             read/eval-package-expression
  47             location->string
  48             switch-symlinks
  49             config-directory
  50             fill-paragraph
  51             string->recutils
  52             package->recutils
  53             args-fold*
  54             run-guix-command
  55             program-name
  56             guix-warning-port
  57             warning
  58             guix-main))
  59
  60 ;;; Commentary:
  61 ;;;
  62 ;;; User interface facilities for command-line tools.
  63 ;;;
  64 ;;; Code:
  65
  66 (define %gettext-domain
  67   "guix")
  68
  69 (define _ (cut gettext <> %gettext-domain))
  70 (define N_ (cut ngettext <> <> <> %gettext-domain))
  71
  72 (define-syntax-rule (define-diagnostic name prefix)
  73   "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
  74 messages."
  75   (define-syntax name
  76     (lambda (x)
  77       (define (augmented-format-string fmt)
  78         (string-append "~:[~*~;guix ~a: ~]~a" (syntax->datum fmt)))
  79
  80       (syntax-case x ()
  81         ((name (underscore fmt) args (... ...))
  82          (and (string? (syntax->datum #'fmt))
  83               (free-identifier=? #'underscore #'_))
  84          (with-syntax ((fmt*   (augmented-format-string #'fmt))
  85                        (prefix (datum->syntax x prefix)))
  86            #'(format (guix-warning-port) (gettext fmt*)
  87                      (program-name) (program-name) prefix
  88                      args (... ...))))
  89         ((name (N-underscore singular plural n) args (... ...))
  90          (and (string? (syntax->datum #'singular))
  91               (string? (syntax->datum #'plural))
  92               (free-identifier=? #'N-underscore #'N_))
  93          (with-syntax ((s      (augmented-format-string #'singular))
  94                        (p      (augmented-format-string #'plural))
  95                        (prefix (datum->syntax x prefix)))
  96            #'(format (guix-warning-port)
  97                      (ngettext s p n %gettext-domain)
  98                      (program-name) (program-name) prefix
  99                      args (... ...))))))))
 100
 101 (define-diagnostic warning "warning: ") ; emit a warning
 102
 103 (define-diagnostic report-error "error: ")
 104 (define-syntax-rule (leave args ...)
 105   "Emit an error message and exit."
 106   (begin
 107     (report-error args ...)
 108     (exit 1)))
 109
 110 (define (install-locale)
 111   "Install the current locale settings."
 112   (catch 'system-error
 113     (lambda _
 114       (setlocale LC_ALL ""))
 115     (lambda args
 116       (warning (_ "failed to install locale: ~a~%")
 117                (strerror (system-error-errno args))))))
 118
 119 (define (initialize-guix)
 120   "Perform the usual initialization for stand-alone Guix commands."
 121   (install-locale)
 122   (textdomain "guix")
 123
 124   ;; Ignore SIGPIPE.  If the daemon closes the connection, we prefer to be
 125   ;; notified via an EPIPE later.
 126   (sigaction SIGPIPE SIG_IGN)
 127
 128   (setvbuf (current-output-port) _IOLBF)
 129   (setvbuf (current-error-port) _IOLBF))
 130
 131 (define* (show-version-and-exit #:optional (command (car (command-line))))
 132   "Display version information for COMMAND and `(exit 0)'."
 133   (simple-format #t "~a (~a) ~a~%"
 134                  command %guix-package-name %guix-version)
 135   (exit 0))
 136
 137 (define (show-bug-report-information)
 138   (format #t (_ "
 139 Report bugs to: ~a.") %guix-bug-report-address)
 140   (format #t (_ "
 141 ~a home page: <~a>") %guix-package-name %guix-home-page-url)
 142   (display (_ "
 143 General help using GNU software: <http://www.gnu.org/gethelp/>"))
 144   (newline))
 145
 146 (define (string->number* str)
 147   "Like `string->number', but error out with an error message on failure."
 148   (or (string->number str)
 149       (leave (_ "~a: invalid number~%") str)))
 150
 151 (define (call-with-error-handling thunk)
 152   "Call THUNK within a user-friendly error handler."
 153   (guard (c ((package-input-error? c)
 154              (let* ((package  (package-error-package c))
 155                     (input    (package-error-invalid-input c))
 156                     (location (package-location package))
 157                     (file     (location-file location))
 158                     (line     (location-line location))
 159                     (column   (location-column location)))
 160                (leave (_ "~a:~a:~a: package `~a' has an invalid input: ~s~%")
 161                       file line column
 162                       (package-full-name package) input)))
 163             ((package-cross-build-system-error? c)
 164              (let* ((package (package-error-package c))
 165                     (loc     (package-location package))
 166                     (system  (package-build-system package)))
 167                (leave (_ "~a: ~a: build system `~a' does not support cross builds~%")
 168                       (location->string loc)
 169                       (package-full-name package)
 170                       (build-system-name system))))
 171             ((nix-connection-error? c)
 172              (leave (_ "failed to connect to `~a': ~a~%")
 173                     (nix-connection-error-file c)
 174                     (strerror (nix-connection-error-code c))))
 175             ((nix-protocol-error? c)
 176              ;; FIXME: Server-provided error messages aren't i18n'd.
 177              (leave (_ "build failed: ~a~%")
 178                     (nix-protocol-error-message c))))
 179     ;; Catch EPIPE and the likes.
 180     (catch 'system-error
 181       thunk
 182       (lambda args
 183         (leave (_ "~a~%")
 184                (strerror (system-error-errno args)))))))
 185
 186 (define (read/eval-package-expression str)
 187   "Read and evaluate STR and return the package it refers to, or exit an
 188 error."
 189   (let ((exp (catch #t
 190                (lambda ()
 191                  (call-with-input-string str read))
 192                (lambda args
 193                  (leave (_ "failed to read expression ~s: ~s~%")
 194                         str args)))))
 195     (let ((p (catch #t
 196                (lambda ()
 197                  (eval exp the-scm-module))
 198                (lambda args
 199                  (leave (_ "failed to evaluate expression `~a': ~s~%")
 200                         exp args)))))
 201       (if (package? p)
 202           p
 203           (leave (_ "expression `~s' does not evaluate to a package~%")
 204                  exp)))))
 205
 206 (define* (show-what-to-build store drv
 207                              #:key dry-run? (use-substitutes? #t))
 208   "Show what will or would (depending on DRY-RUN?) be built in realizing the
 209 derivations listed in DRV.  Return #t if there's something to build, #f
 210 otherwise.  When USE-SUBSTITUTES?, check and report what is prerequisites are
 211 available for download."
 212   (let*-values (((build download)
 213                  (fold2 (lambda (drv-path build download)
 214                           (let ((drv (call-with-input-file drv-path
 215                                        read-derivation)))
 216                             (let-values (((b d)
 217                                           (derivation-prerequisites-to-build
 218                                            store drv
 219                                            #:use-substitutes?
 220                                            use-substitutes?)))
 221                               (values (append b build)
 222                                       (append d download)))))
 223                         '() '()
 224                         drv))
 225                 ((build)                          ; add the DRV themselves
 226                  (delete-duplicates
 227                   (append (remove (compose (lambda (out)
 228                                              (or (valid-path? store out)
 229                                                  (and use-substitutes?
 230                                                       (has-substitutes? store
 231                                                                         out))))
 232                                            derivation-path->output-path)
 233                                   drv)
 234                           (map derivation-input-path build))))
 235                 ((download)                   ; add the references of DOWNLOAD
 236                  (if use-substitutes?
 237                      (delete-duplicates
 238                       (append download
 239                               (remove (cut valid-path? store <>)
 240                                       (append-map
 241                                        substitutable-references
 242                                        (substitutable-path-info store
 243                                                                 download)))))
 244                      download)))
 245     (if dry-run?
 246         (begin
 247           (format (current-error-port)
 248                   (N_ "~:[The following derivation would be built:~%~{   ~a~%~}~;~]"
 249                       "~:[The following derivations would be built:~%~{   ~a~%~}~;~]"
 250                       (length build))
 251                   (null? build) build)
 252           (format (current-error-port)
 253                   (N_ "~:[The following file would be downloaded:~%~{   ~a~%~}~;~]"
 254                       "~:[The following files would be downloaded:~%~{   ~a~%~}~;~]"
 255                       (length download))
 256                   (null? download) download))
 257         (begin
 258           (format (current-error-port)
 259                   (N_ "~:[The following derivation will be built:~%~{   ~a~%~}~;~]"
 260                       "~:[The following derivations will be built:~%~{   ~a~%~}~;~]"
 261                       (length build))
 262                   (null? build) build)
 263           (format (current-error-port)
 264                   (N_ "~:[The following file will be downloaded:~%~{   ~a~%~}~;~]"
 265                       "~:[The following files will be downloaded:~%~{   ~a~%~}~;~]"
 266                       (length download))
 267                   (null? download) download)))
 268     (pair? build)))
 269
 270 (define-syntax with-error-handling
 271   (syntax-rules ()
 272     "Run BODY within a user-friendly error condition handler."
 273     ((_ body ...)
 274      (call-with-error-handling
 275       (lambda ()
 276         body ...)))))
 277
 278 (define (location->string loc)
 279   "Return a human-friendly, GNU-standard representation of LOC."
 280   (match loc
 281     (#f (_ "<unknown location>"))
 282     (($ <location> file line column)
 283      (format #f "~a:~a:~a" file line column))))
 284
 285 (define (switch-symlinks link target)
 286   "Atomically switch LINK, a symbolic link, to point to TARGET.  Works
 287 both when LINK already exists and when it does not."
 288   (let ((pivot (string-append link ".new")))
 289     (symlink target pivot)
 290     (rename-file pivot link)))
 291
 292 (define (config-directory)
 293   "Return the name of the configuration directory, after making sure that it
 294 exists.  Honor the XDG specs,
 295 <http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html>."
 296   (let ((dir (and=> (or (getenv "XDG_CONFIG_HOME")
 297                         (and=> (getenv "HOME")
 298                                (cut string-append <> "/.config")))
 299                     (cut string-append <> "/guix"))))
 300     (catch 'system-error
 301       (lambda ()
 302         (mkdir dir)
 303         dir)
 304       (lambda args
 305         (match (system-error-errno args)
 306           ((or EEXIST 0)
 307            dir)
 308           (err
 309            (leave (_ "failed to create configuration directory `~a': ~a~%")
 310                   dir (strerror err))))))))
 311
 312 (define* (fill-paragraph str width #:optional (column 0))
 313   "Fill STR such that each line contains at most WIDTH characters, assuming
 314 that the first character is at COLUMN.
 315
 316 When STR contains a single line break surrounded by other characters, it is
 317 converted to a space; sequences of more than one line break are preserved."
 318   (define (maybe-break chr result)
 319     (match result
 320       ((column newlines chars)
 321        (case chr
 322          ((#\newline)
 323           `(,column ,(+ 1 newlines) ,chars))
 324          (else
 325           (let ((chars  (case newlines
 326                           ((0) chars)
 327                           ((1) (cons #\space chars))
 328                           (else
 329                            (append (make-list newlines #\newline) chars))))
 330                 (column (case newlines
 331                           ((0) column)
 332                           ((1) (+ 1 column))
 333                           (else 0))))
 334             (let ((chars  (cons chr chars))
 335                   (column (+ 1 column)))
 336               (if (> column width)
 337                   (let*-values (((before after)
 338                                  (break (cut eqv? #\space <>) chars))
 339                                 ((len)
 340                                  (length before)))
 341                     (if (<= len width)
 342                         `(,len
 343                           0
 344                           ,(if (null? after)
 345                                before
 346                                (append before (cons #\newline (cdr after)))))
 347                         `(,column 0 ,chars)))     ; unbreakable
 348                   `(,column 0 ,chars)))))))))
 349
 350   (match (string-fold maybe-break
 351                       `(,column 0 ())
 352                       str)
 353     ((_ _ chars)
 354      (list->string (reverse chars)))))
 355
 356 (define (string->recutils str)
 357   "Return a version of STR where newlines have been replaced by newlines
 358 followed by \"+ \", which makes for a valid multi-line field value in the
 359 `recutils' syntax."
 360   (list->string
 361    (string-fold-right (lambda (chr result)
 362                         (if (eqv? chr #\newline)
 363                             (cons* chr #\+ #\space result)
 364                             (cons chr result)))
 365                       '()
 366                       str)))
 367
 368 (define* (package->recutils p port
 369                             #:optional (width (or (and=> (getenv "WIDTH")
 370                                                          string->number)
 371                                                   80)))
 372   "Write to PORT a `recutils' record of package P, arranging to fit within
 373 WIDTH columns."
 374   (define (description->recutils str)
 375     (let ((str (_ str)))
 376       (string->recutils
 377        (fill-paragraph str width
 378                        (string-length "description: ")))))
 379
 380   ;; Note: Don't i18n field names so that people can post-process it.
 381   (format port "name: ~a~%" (package-name p))
 382   (format port "version: ~a~%" (package-version p))
 383   (format port "location: ~a~%"
 384           (or (and=> (package-location p) location->string)
 385               (_ "unknown")))
 386   (format port "home-page: ~a~%" (package-home-page p))
 387   (format port "license: ~a~%"
 388           (match (package-license p)
 389             (((? license? licenses) ...)
 390              (string-join (map license-name licenses)
 391                           ", "))
 392             ((? license? license)
 393              (license-name license))
 394             (x
 395              (_ "unknown"))))
 396   (format port "synopsis: ~a~%"
 397           (string-map (match-lambda
 398                        (#\newline #\space)
 399                        (chr       chr))
 400                       (or (and=> (package-synopsis p) _)
 401                           "")))
 402   (format port "description: ~a~%"
 403           (and=> (package-description p) description->recutils))
 404   (newline port))
 405
 406 (define (args-fold* options unrecognized-option-proc operand-proc . seeds)
 407   "A wrapper on top of `args-fold' that does proper user-facing error
 408 reporting."
 409   (catch 'misc-error
 410     (lambda ()
 411       (apply args-fold options unrecognized-option-proc
 412              operand-proc seeds))
 413     (lambda (key proc msg args . rest)
 414       ;; XXX: MSG is not i18n'd.
 415       (leave (_ "invalid argument: ~a~%")
 416              (apply format #f msg args)))))
 417
 418 (define (show-guix-usage)
 419   (format (current-error-port)
 420           (_ "Try `guix --help' for more information.~%"))
 421   (exit 1))
 422
 423 (define (command-files)
 424   "Return the list of source files that define Guix sub-commands."
 425   (define directory
 426     (and=> (search-path %load-path "guix.scm")
 427            (compose (cut string-append <> "/guix/scripts")
 428                     dirname)))
 429
 430   (define dot-scm?
 431     (cut string-suffix? ".scm" <>))
 432
 433   ;; In Guile 2.0.5 `scandir' would return "." and ".." regardless even though
 434   ;; they don't match `dot-scm?'.  Work around it by doing additional
 435   ;; filtering.
 436   (if directory
 437       (filter dot-scm? (scandir directory dot-scm?))
 438       '()))
 439
 440 (define (commands)
 441   "Return the list of Guix command names."
 442   (map (compose (cut string-drop-right <> 4)
 443                 basename)
 444        (command-files)))
 445
 446 (define (show-guix-help)
 447   (format #t (_ "Usage: guix COMMAND ARGS...
 448 Run COMMAND with ARGS.\n"))
 449   (newline)
 450   (format #t (_ "COMMAND must be one of the sub-commands listed below:\n"))
 451   (newline)
 452   ;; TODO: Display a synopsis of each command.
 453   (format #t "~{   ~a~%~}" (sort (commands) string<?))
 454   (show-bug-report-information))
 455
 456 (define program-name
 457   ;; Name of the command-line program currently executing, or #f.
 458   (make-parameter #f))
 459
 460 (define (run-guix-command command . args)
 461   "Run COMMAND with the given ARGS.  Report an error when COMMAND is not
 462 found."
 463   (define module
 464     (catch 'misc-error
 465       (lambda ()
 466         (resolve-interface `(guix scripts ,command)))
 467       (lambda -
 468         (format (current-error-port)
 469                 (_ "guix: ~a: command not found~%") command)
 470         (show-guix-usage))))
 471
 472   (let ((command-main (module-ref module
 473                                   (symbol-append 'guix- command))))
 474     (parameterize ((program-name command))
 475       (apply command-main args))))
 476
 477 (define guix-warning-port
 478   (make-parameter (current-warning-port)))
 479
 480 (define (guix-main arg0 . args)
 481   (initialize-guix)
 482   (let ()
 483     (define (option? str) (string-prefix? "-" str))
 484     (match args
 485       (()
 486        (format (current-error-port)
 487                (_ "guix: missing command name~%"))
 488        (show-guix-usage))
 489       (("--help")
 490        (show-guix-help))
 491       (("--version")
 492        (show-version-and-exit "guix"))
 493       (((? option? o) args ...)
 494        (format (current-error-port)
 495                (_ "guix: unrecognized option '~a'~%") o)
 496        (show-guix-usage))
 497       ((command args ...)
 498        (apply run-guix-command
 499               (string->symbol command)
 500               args)))))
 501
 502 ;;; ui.scm ends here