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