guix/scripts/describe.scm

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