guix/guix/ui.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix ui)
  #:use-module (guix utils)
  #:use-module (guix store)
  #:use-module (guix config)
  #:use-module (guix packages)
  #:use-module (guix build-system)
  #:use-module (guix derivations)
  #:use-module ((guix build utils) #:select (mkdir-p))
  #:use-module ((guix licenses) #:select (license? license-name))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-37)
  #:autoload   (ice-9 ftw)  (scandir)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (ice-9 regex)
  #:export (_
            N_
            P_
            leave
            show-version-and-exit
            show-bug-report-information
            string->number*
            size->number
            show-what-to-build
            call-with-error-handling
            with-error-handling
            read/eval
            read/eval-package-expression
            location->string
            switch-symlinks
            config-directory
            fill-paragraph
            string->recutils
            package->recutils
            package-specification->name+version+output
            string->generations
            string->duration
            args-fold*
            run-guix-command
            program-name
            guix-warning-port
            warning
            guix-main))

;;; Commentary:
;;;
;;; User interface facilities for command-line tools.
;;;
;;; Code:

(define %gettext-domain
  ;; Text domain for strings used in the tools.
  "guix")

(define %package-text-domain
  ;; Text domain for package synopses and descriptions.
  "guix-packages")

(define _ (cut gettext <> %gettext-domain))
(define N_ (cut ngettext <> <> <> %gettext-domain))
(define P_ (cut gettext <> %package-text-domain))

(define-syntax-rule (define-diagnostic name prefix)
  "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
messages."
  (define-syntax name
    (lambda (x)
      (define (augmented-format-string fmt)
        (string-append "~:[~*~;guix ~a: ~]~a" (syntax->datum fmt)))

      (syntax-case x ()
        ((name (underscore fmt) args (... ...))
         (and (string? (syntax->datum #'fmt))
              (free-identifier=? #'underscore #'_))
         (with-syntax ((fmt*   (augmented-format-string #'fmt))
                       (prefix (datum->syntax x prefix)))
           #'(format (guix-warning-port) (gettext fmt*)
                     (program-name) (program-name) prefix
                     args (... ...))))
        ((name (N-underscore singular plural n) args (... ...))
         (and (string? (syntax->datum #'singular))
              (string? (syntax->datum #'plural))
              (free-identifier=? #'N-underscore #'N_))
         (with-syntax ((s      (augmented-format-string #'singular))
                       (p      (augmented-format-string #'plural))
                       (prefix (datum->syntax x prefix)))
           #'(format (guix-warning-port)
                     (ngettext s p n %gettext-domain)
                     (program-name) (program-name) prefix
                     args (... ...))))))))

(define-diagnostic warning "warning: ") ; emit a warning

(define-diagnostic report-error "error: ")
(define-syntax-rule (leave args ...)
  "Emit an error message and exit."
  (begin
    (report-error args ...)
    (exit 1)))

(define (install-locale)
  "Install the current locale settings."
  (catch 'system-error
    (lambda _
      (setlocale LC_ALL ""))
    (lambda args
      (warning (_ "failed to install locale: ~a~%")
               (strerror (system-error-errno args))))))

(define (initialize-guix)
  "Perform the usual initialization for stand-alone Guix commands."
  (install-locale)
  (textdomain %gettext-domain)

  ;; Ignore SIGPIPE.  If the daemon closes the connection, we prefer to be
  ;; notified via an EPIPE later.
  (sigaction SIGPIPE SIG_IGN)

  (setvbuf (current-output-port) _IOLBF)
  (setvbuf (current-error-port) _IOLBF))

(define* (show-version-and-exit #:optional (command (car (command-line))))
  "Display version information for COMMAND and `(exit 0)'."
  (simple-format #t "~a (~a) ~a~%"
                 command %guix-package-name %guix-version)
  (display (_ "Copyright (C) 2014 the Guix authors
License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
This is free software: you are free to change and redistribute it.
There is NO WARRANTY, to the extent permitted by law.
"))
  (exit 0))

(define (show-bug-report-information)
  (format #t (_ "
Report bugs to: ~a.") %guix-bug-report-address)
  (format #t (_ "
~a home page: <~a>") %guix-package-name %guix-home-page-url)
  (display (_ "
General help using GNU software: <http://www.gnu.org/gethelp/>"))
  (newline))

(define (string->number* str)
  "Like `string->number', but error out with an error message on failure."
  (or (string->number str)
      (leave (_ "~a: invalid number~%") str)))

(define (size->number str)
  "Convert STR, a storage measurement representation such as \"1024\" or
\"1MiB\", to a number of bytes.  Raise an error if STR could not be
interpreted."
  (define unit-pos
    (string-rindex str char-set:digit))

  (define unit
    (and unit-pos (substring str (+ 1 unit-pos))))

  (let* ((numstr (if unit-pos
                     (substring str 0 (+ 1 unit-pos))
                     str))
         (num    (string->number numstr)))
    (unless num
      (leave (_ "invalid number: ~a~%") numstr))

    ((compose inexact->exact round)
     (* num
        (match unit
          ((or "KiB" "K" "k") (expt 2 10))
          ((or "MiB" "M")     (expt 2 20))
          ((or "GiB" "G")     (expt 2 30))
          ((or "TiB" "T")     (expt 2 40))
          ((or "PiB" "P")     (expt 2 50))
          ((or "EiB" "E")     (expt 2 60))
          ((or "ZiB" "Z")     (expt 2 70))
          ((or "YiB" "Y")     (expt 2 80))
          ("kB"  (expt 10 3))
          ("MB"  (expt 10 6))
          ("GB"  (expt 10 9))
          ("TB"  (expt 10 12))
          ("PB"  (expt 10 15))
          ("EB"  (expt 10 18))
          ("ZB"  (expt 10 21))
          ("YB"  (expt 10 24))
          (""    1)
          (_
           (leave (_ "unknown unit: ~a~%") unit)))))))

(define (call-with-error-handling thunk)
  "Call THUNK within a user-friendly error handler."
  (guard (c ((package-input-error? c)
             (let* ((package  (package-error-package c))
                    (input    (package-error-invalid-input c))
                    (location (package-location package))
                    (file     (location-file location))
                    (line     (location-line location))
                    (column   (location-column location)))
               (leave (_ "~a:~a:~a: package `~a' has an invalid input: ~s~%")
                      file line column
                      (package-full-name package) input)))
            ((package-cross-build-system-error? c)
             (let* ((package (package-error-package c))
                    (loc     (package-location package))
                    (system  (package-build-system package)))
               (leave (_ "~a: ~a: build system `~a' does not support cross builds~%")
                      (location->string loc)
                      (package-full-name package)
                      (build-system-name system))))
            ((nix-connection-error? c)
             (leave (_ "failed to connect to `~a': ~a~%")
                    (nix-connection-error-file c)
                    (strerror (nix-connection-error-code c))))
            ((nix-protocol-error? c)
             ;; FIXME: Server-provided error messages aren't i18n'd.
             (leave (_ "build failed: ~a~%")
                    (nix-protocol-error-message c)))
            ((message-condition? c)
             ;; Normally '&message' error conditions have an i18n'd message.
             (leave (_ "~a~%")
                    (gettext (condition-message c) %gettext-domain))))
    ;; Catch EPIPE and the likes.
    (catch 'system-error
      thunk
      (lambda (key proc format-string format-args . rest)
        (leave (_ "~a: ~a~%") proc
               (apply format #f format-string format-args))))))

(define %guix-user-module
  ;; Module in which user expressions are evaluated.
  ;; Compute lazily to avoid circularity with (guix gexp).
  (delay
    (let ((module (make-module)))
      (beautify-user-module! module)
      ;; Use (guix gexp) so that one can use #~ & co.
      (module-use! module (resolve-interface '(guix gexp)))
      module)))

(define (read/eval str)
  "Read and evaluate STR, raising an error if something goes wrong."
  (let ((exp (catch #t
               (lambda ()
                 (call-with-input-string str read))
               (lambda args
                 (leave (_ "failed to read expression ~s: ~s~%")
                        str args)))))
    (catch #t
      (lambda ()
        (eval exp (force %guix-user-module)))
      (lambda args
        (leave (_ "failed to evaluate expression `~a': ~s~%")
               exp args)))))

(define (read/eval-package-expression str)
  "Read and evaluate STR and return the package it refers to, or exit an
error."
  (match (read/eval str)
    ((? package? p) p)
    (_
     (leave (_ "expression ~s does not evaluate to a package~%")
            str))))

(define* (show-what-to-build store drv
                             #:key dry-run? (use-substitutes? #t))
  "Show what will or would (depending on DRY-RUN?) be built in realizing the
derivations listed in DRV.  Return #t if there's something to build, #f
otherwise.  When USE-SUBSTITUTES?, check and report what is prerequisites are
available for download."
  (define (built-or-substitutable? drv)
    (let ((out (derivation->output-path drv)))
      ;; If DRV has zero outputs, OUT is #f.
      (or (not out)
          (or (valid-path? store out)
              (and use-substitutes?
                   (has-substitutes? store out))))))

  (let*-values (((build download)
                 (fold2 (lambda (drv build download)
                          (let-values (((b d)
                                        (derivation-prerequisites-to-build
                                         store drv
                                         #:use-substitutes?
                                         use-substitutes?)))
                            (values (append b build)
                                    (append d download))))
                        '() '()
                        drv))
                ((build)                          ; add the DRV themselves
                 (delete-duplicates
                  (append (map derivation-file-name
                               (remove built-or-substitutable? drv))
                          (map derivation-input-path build))))
                ((download)                   ; add the references of DOWNLOAD
                 (if use-substitutes?
                     (delete-duplicates
                      (append download
                              (remove (cut valid-path? store <>)
                                      (append-map
                                       substitutable-references
                                       (substitutable-path-info store
                                                                download)))))
                     download)))
    ;; TODO: Show the installed size of DOWNLOAD.
    (if dry-run?
        (begin
          (format (current-error-port)
                  (N_ "~:[The following derivation would be built:~%~{   ~a~%~}~;~]"
                      "~:[The following derivations would be built:~%~{   ~a~%~}~;~]"
                      (length build))
                  (null? build) build)
          (format (current-error-port)
                  (N_ "~:[The following file would be downloaded:~%~{   ~a~%~}~;~]"
                      "~:[The following files would be downloaded:~%~{   ~a~%~}~;~]"
                      (length download))
                  (null? download) download))
        (begin
          (format (current-error-port)
                  (N_ "~:[The following derivation will be built:~%~{   ~a~%~}~;~]"
                      "~:[The following derivations will be built:~%~{   ~a~%~}~;~]"
                      (length build))
                  (null? build) build)
          (format (current-error-port)
                  (N_ "~:[The following file will be downloaded:~%~{   ~a~%~}~;~]"
                      "~:[The following files will be downloaded:~%~{   ~a~%~}~;~]"
                      (length download))
                  (null? download) download)))
    (pair? build)))

(define-syntax with-error-handling
  (syntax-rules ()
    "Run BODY within a user-friendly error condition handler."
    ((_ body ...)
     (call-with-error-handling
      (lambda ()
        body ...)))))

(define (location->string loc)
  "Return a human-friendly, GNU-standard representation of LOC."
  (match loc
    (#f (_ "<unknown location>"))
    (($ <location> file line column)
     (format #f "~a:~a:~a" file line column))))

(define (switch-symlinks link target)
  "Atomically switch LINK, a symbolic link, to point to TARGET.  Works
both when LINK already exists and when it does not."
  (let ((pivot (string-append link ".new")))
    (symlink target pivot)
    (rename-file pivot link)))

(define (config-directory)
  "Return the name of the configuration directory, after making sure that it
exists.  Honor the XDG specs,
<http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html>."
  (let ((dir (and=> (or (getenv "XDG_CONFIG_HOME")
                        (and=> (getenv "HOME")
                               (cut string-append <> "/.config")))
                    (cut string-append <> "/guix"))))
    (catch 'system-error
      (lambda ()
        (mkdir-p dir)
        dir)
      (lambda args
        (let ((err (system-error-errno args)))
          ;; ERR is necessarily different from EEXIST.
          (leave (_ "failed to create configuration directory `~a': ~a~%")
                 dir (strerror err)))))))

(define* (fill-paragraph str width #:optional (column 0))
  "Fill STR such that each line contains at most WIDTH characters, assuming
that the first character is at COLUMN.

When STR contains a single line break surrounded by other characters, it is
converted to a space; sequences of more than one line break are preserved."
  (define (maybe-break chr result)
    (match result
      ((column newlines chars)
       (case chr
         ((#\newline)
          `(,column ,(+ 1 newlines) ,chars))
         (else
          (let* ((spaces (if (and (pair? chars) (eqv? (car chars) #\.)) 2 1))
                 (chars  (case newlines
                           ((0) chars)
                           ((1)
                            (append (make-list spaces #\space) chars))
                           (else
                            (append (make-list newlines #\newline) chars))))
                 (column (case newlines
                           ((0) column)
                           ((1) (+ spaces column))
                           (else 0))))
            (let ((chars  (cons chr chars))
                  (column (+ 1 column)))
              (if (> column width)
                  (let*-values (((before after)
                                 (break (cut eqv? #\space <>) chars))
                                ((len)
                                 (length before)))
                    (if (<= len width)
                        `(,len
                          0
                          ,(if (null? after)
                               before
                               (append before
                                       (cons #\newline
                                             (drop-while (cut eqv? #\space <>)
                                                         after)))))
                        `(,column 0 ,chars)))     ; unbreakable
                  `(,column 0 ,chars)))))))))

  (match (string-fold maybe-break
                      `(,column 0 ())
                      str)
    ((_ _ chars)
     (list->string (reverse chars)))))


;;;
;;; Packages.
;;;

(define (string->recutils str)
  "Return a version of STR where newlines have been replaced by newlines
followed by \"+ \", which makes for a valid multi-line field value in the
`recutils' syntax."
  (list->string
   (string-fold-right (lambda (chr result)
                        (if (eqv? chr #\newline)
                            (cons* chr #\+ #\space result)
                            (cons chr result)))
                      '()
                      str)))

(define* (package->recutils p port
                            #:optional (width (or (and=> (getenv "WIDTH")
                                                         string->number)
                                                  80)))
  "Write to PORT a `recutils' record of package P, arranging to fit within
WIDTH columns."
  (define (description->recutils str)
    (let ((str (P_ str)))
      (string->recutils
       (fill-paragraph str width
                       (string-length "description: ")))))

  (define (dependencies->recutils packages)
    (let ((list (string-join (map package-full-name
                                  (sort packages package<?)) " ")))
      (string->recutils
       (fill-paragraph list width
                       (string-length "dependencies: ")))))

  (define (package<? p1 p2)
    (string<? (package-full-name p1) (package-full-name p2)))

  ;; Note: Don't i18n field names so that people can post-process it.
  (format port "name: ~a~%" (package-name p))
  (format port "version: ~a~%" (package-version p))
  (format port "dependencies: ~a~%"
          (match (package-direct-inputs p)
            (((labels inputs . _) ...)
             (dependencies->recutils (filter package? inputs)))))
  (format port "location: ~a~%"
          (or (and=> (package-location p) location->string)
              (_ "unknown")))

  ;; Note: Starting from version 1.6 or recutils, hyphens are not allowed in
  ;; field identifiers.
  (format port "homepage: ~a~%" (package-home-page p))

  (format port "license: ~a~%"
          (match (package-license p)
            (((? license? licenses) ...)
             (string-join (map license-name licenses)
                          ", "))
            ((? license? license)
             (license-name license))
            (x
             (_ "unknown"))))
  (format port "synopsis: ~a~%"
          (string-map (match-lambda
                       (#\newline #\space)
                       (chr       chr))
                      (or (and=> (package-synopsis p) P_)
                          "")))
  (format port "description: ~a~%"
          (and=> (package-description p) description->recutils))
  (newline port))

(define (string->generations str)
  "Return the list of generations matching a pattern in STR.  This function
accepts the following patterns: \"1\", \"1,2,3\", \"1..9\", \"1..\", \"..9\"."
  (define (maybe-integer)
    (let ((x (string->number str)))
      (and (integer? x)
           x)))

  (define (maybe-comma-separated-integers)
    (let ((lst (delete-duplicates
                (map string->number
                     (string-split str #\,)))))
      (and (every integer? lst)
           lst)))

  (cond ((maybe-integer)
         =>
         list)
        ((maybe-comma-separated-integers)
         =>
         identity)
        ((string-match "^([0-9]+)\\.\\.([0-9]+)$" str)
         =>
         (lambda (match)
           (let ((s (string->number (match:substring match 1)))
                 (e (string->number (match:substring match 2))))
             (and (every integer? (list s e))
                  (<= s e)
                  (iota (1+ (- e s)) s)))))
        ((string-match "^([0-9]+)\\.\\.$" str)
         =>
         (lambda (match)
           (let ((s (string->number (match:substring match 1))))
             (and (integer? s)
                  `(>= ,s)))))
        ((string-match "^\\.\\.([0-9]+)$" str)
         =>
         (lambda (match)
           (let ((e (string->number (match:substring match 1))))
             (and (integer? e)
                  `(<= ,e)))))
        (else #f)))

(define (string->duration str)
  "Return the duration matching a pattern in STR.  This function accepts the
following patterns: \"1d\", \"1w\", \"1m\"."
  (define (hours->duration hours match)
    (make-time time-duration 0
               (* 3600 hours (string->number (match:substring match 1)))))

  (cond ((string-match "^([0-9]+)d$" str)
         =>
         (lambda (match)
           (hours->duration 24 match)))
        ((string-match "^([0-9]+)w$" str)
         =>
         (lambda (match)
           (hours->duration (* 24 7) match)))
        ((string-match "^([0-9]+)m$" str)
         =>
         (lambda (match)
           (hours->duration (* 24 30) match)))
        (else #f)))

(define* (package-specification->name+version+output spec
                                                     #:optional (output "out"))
  "Parse package specification SPEC and return three value: the specified
package name, version number (or #f), and output name (or OUTPUT).  SPEC may
optionally contain a version number and an output name, as in these examples:

  guile
  guile-2.0.9
  guile:debug
  guile-2.0.9:debug
"
  (let*-values (((name sub-drv)
                 (match (string-rindex spec #\:)
                   (#f    (values spec output))
                   (colon (values (substring spec 0 colon)
                                  (substring spec (+ 1 colon))))))
                ((name version)
                 (package-name->name+version name)))
    (values name version sub-drv)))


;;;
;;; Command-line option processing.
;;;

(define (args-fold* options unrecognized-option-proc operand-proc . seeds)
  "A wrapper on top of `args-fold' that does proper user-facing error
reporting."
  (catch 'misc-error
    (lambda ()
      (apply args-fold options unrecognized-option-proc
             operand-proc seeds))
    (lambda (key proc msg args . rest)
      ;; XXX: MSG is not i18n'd.
      (leave (_ "invalid argument: ~a~%")
             (apply format #f msg args)))))

(define (show-guix-usage)
  (format (current-error-port)
          (_ "Try `guix --help' for more information.~%"))
  (exit 1))

(define (command-files)
  "Return the list of source files that define Guix sub-commands."
  (define directory
    (and=> (search-path %load-path "guix.scm")
           (compose (cut string-append <> "/guix/scripts")
                    dirname)))

  (define dot-scm?
    (cut string-suffix? ".scm" <>))

  ;; In Guile 2.0.5 `scandir' would return "." and ".." regardless even though
  ;; they don't match `dot-scm?'.  Work around it by doing additional
  ;; filtering.
  (if directory
      (filter dot-scm? (scandir directory dot-scm?))
      '()))

(define (commands)
  "Return the list of Guix command names."
  (map (compose (cut string-drop-right <> 4)
                basename)
       (command-files)))

(define (show-guix-help)
  (define (internal? command)
    (member command '("substitute-binary" "authenticate" "offload")))

  (format #t (_ "Usage: guix COMMAND ARGS...
Run COMMAND with ARGS.\n"))
  (newline)
  (format #t (_ "COMMAND must be one of the sub-commands listed below:\n"))
  (newline)
  ;; TODO: Display a synopsis of each command.
  (format #t "~{   ~a~%~}" (sort (remove internal? (commands))
                                 string<?))
  (show-bug-report-information))

(define program-name
  ;; Name of the command-line program currently executing, or #f.
  (make-parameter #f))

(define (run-guix-command command . args)
  "Run COMMAND with the given ARGS.  Report an error when COMMAND is not
found."
  (define module
    (catch 'misc-error
      (lambda ()
        (resolve-interface `(guix scripts ,command)))
      (lambda -
        (format (current-error-port)
                (_ "guix: ~a: command not found~%") command)
        (show-guix-usage))))

  (let ((command-main (module-ref module
                                  (symbol-append 'guix- command))))
    (parameterize ((program-name command))
      (apply command-main args))))

(define guix-warning-port
  (make-parameter (current-warning-port)))

(define (guix-main arg0 . args)
  (initialize-guix)
  (let ()
    (define (option? str) (string-prefix? "-" str))
    (match args
      (()
       (format (current-error-port)
               (_ "guix: missing command name~%"))
       (show-guix-usage))
      ((or ("-h") ("--help"))
       (show-guix-help))
      (("--version")
       (show-version-and-exit "guix"))
      (((? option? o) args ...)
       (format (current-error-port)
               (_ "guix: unrecognized option '~a'~%") o)
       (show-guix-usage))
      ((command args ...)
       (apply run-guix-command
              (string->symbol command)
              args)))))

;;; ui.scm ends here