guix/scripts/describe.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix scripts describe)
  21   #:use-module ((guix ui) #:hide (display-profile-content))
  22   #:use-module (guix channels)
  23   #:use-module (guix scripts)
  24   #:use-module (guix describe)
  25   #:use-module (guix profiles)
  26   #:use-module ((guix scripts pull) #:select (display-profile-content))
  27   #:use-module (git)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (srfi srfi-37)
  30   #:use-module (ice-9 match)
  31   #:autoload   (ice-9 pretty-print) (pretty-print)
  32   #:export (guix-describe))
  33
  34 \f
  35 ;;;
  36 ;;; Command-line options.
  37 ;;;
  38
  39 (define %options
  40   ;; Specifications of the command-line options.
  41   (list (option '(#\f "format") #t #f
  42                 (lambda (opt name arg result)
  43                   (unless (member arg '("human" "channels"))
  44                     (leave (G_ "~a: unsupported output format~%") arg))
  45                   (alist-cons 'format (string->symbol arg) result)))
  46         (option '(#\p "profile") #t #f
  47                 (lambda (opt name arg result)
  48                   (alist-cons 'profile (canonicalize-profile arg)
  49                               result)))
  50         (option '(#\h "help") #f #f
  51                 (lambda args
  52                   (show-help)
  53                   (exit 0)))
  54         (option '(#\V "version") #f #f
  55                 (lambda args
  56                   (show-version-and-exit "guix describe")))))
  57
  58 (define %default-options
  59   ;; Alist of default option values.
  60   '((format . human)))
  61
  62 (define (show-help)
  63   (display (G_ "Usage: guix describe [OPTION]...
  64 Display information about the channels currently in use.\n"))
  65   (display (G_ "
  66   -f, --format=FORMAT    display information in the given FORMAT"))
  67   (display (G_ "
  68   -p, --profile=PROFILE  display information about PROFILE"))
  69   (newline)
  70   (display (G_ "
  71   -h, --help             display this help and exit"))
  72   (display (G_ "
  73   -V, --version          display version information and exit"))
  74   (newline)
  75   (show-bug-report-information))
  76
  77 (define (display-package-search-path fmt)
  78   "Display GUIX_PACKAGE_PATH, if it is set, according to FMT."
  79   (match (getenv "GUIX_PACKAGE_PATH")
  80     (#f #t)
  81     (string
  82      (match fmt
  83        ('human
  84         (format #t "~%GUIX_PACKAGE_PATH=\"~a\"~%" string))
  85        ('channels
  86         (format #t (G_ "~%;; warning: GUIX_PACKAGE_PATH=\"~a\"~%")
  87                 string))))))
  88
  89 (define (channel->sexp channel)
  90   `(channel
  91     (name ,(channel-name channel))
  92     (url ,(channel-url channel))
  93     (commit ,(channel-commit channel))))
  94
  95 (define* (display-checkout-info fmt #:optional directory)
  96   "Display information about the current checkout according to FMT, a symbol
  97 denoting the requested format.  Exit if the current directory does not lie
  98 within a Git checkout."
  99   (let* ((program    (or directory (car (command-line))))
 100          (directory  (catch 'git-error
 101                        (lambda ()
 102                          (repository-discover (dirname program)))
 103                        (lambda (key err)
 104                          (leave (G_ "failed to determine origin~%")))))
 105          (repository (repository-open directory))
 106          (head       (repository-head repository))
 107          (commit     (oid->string (reference-target head))))
 108     (match fmt
 109       ('human
 110        (format #t (G_ "Git checkout:~%"))
 111        (format #t (G_ "  repository: ~a~%") (dirname directory))
 112        (format #t (G_ "  branch: ~a~%") (reference-shorthand head))
 113        (format #t (G_ "  commit: ~a~%") commit))
 114       ('channels
 115        (pretty-print `(list ,(channel->sexp (channel (name 'guix)
 116                                                      (url (dirname directory))
 117                                                      (commit commit)))))))
 118     (display-package-search-path fmt)))
 119
 120 (define (display-profile-info profile fmt)
 121   "Display information about PROFILE, a profile as created by (guix channels),
 122 in the format specified by FMT."
 123   (define number
 124     (generation-number profile))
 125
 126   (define channels
 127     (map (lambda (entry)
 128            (match (assq 'source (manifest-entry-properties entry))
 129              (('source ('repository ('version 0)
 130                                     ('url url)
 131                                     ('branch branch)
 132                                     ('commit commit)
 133                                     _ ...))
 134               (channel (name (string->symbol (manifest-entry-name entry)))
 135                        (url url)
 136                        (commit commit)))
 137
 138              ;; Pre-0.15.0 Guix does not provide that information,
 139              ;; so there's not much we can do in that case.
 140              (_ (channel (name 'guix)
 141                          (url "?")
 142                          (commit "?")))))
 143
 144          ;; Show most recently installed packages last.
 145          (reverse
 146           (manifest-entries
 147            (profile-manifest
 148             (if (zero? number)
 149                 profile
 150                 (generation-file-name profile number)))))))
 151
 152   (match fmt
 153     ('human
 154      (display-profile-content profile number))
 155     ('channels
 156      (pretty-print `(list ,@(map channel->sexp channels)))))
 157   (display-package-search-path fmt))
 158
 159 \f
 160 ;;;
 161 ;;; Entry point.
 162 ;;;
 163
 164 (define (guix-describe . args)
 165   (let* ((opts    (args-fold* args %options
 166                               (lambda (opt name arg result)
 167                                 (leave (G_ "~A: unrecognized option~%")
 168                                        name))
 169                               cons
 170                               %default-options))
 171          (format  (assq-ref opts 'format))
 172          (profile (or (assq-ref opts 'profile) (current-profile))))
 173     (with-error-handling
 174       (match profile
 175         (#f
 176          (display-checkout-info format))
 177         (profile
 178          (display-profile-info (canonicalize-profile profile) format))))))