Commit | Line | Data |
---|---|---|
bd747018 | 1 | ;;; GNU Guix --- Functional package management for GNU |
b6fd086a | 2 | ;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> |
8548f995 | 3 | ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> |
bd747018 LC |
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) | |
06633026 | 21 | #:use-module ((guix config) #:select (%guix-version)) |
bd747018 | 22 | #:use-module ((guix ui) #:hide (display-profile-content)) |
8548f995 | 23 | #:use-module (guix channels) |
bd747018 LC |
24 | #:use-module (guix scripts) |
25 | #:use-module (guix describe) | |
26 | #:use-module (guix profiles) | |
27 | #:use-module ((guix scripts pull) #:select (display-profile-content)) | |
28 | #:use-module (git) | |
81a40ee0 | 29 | #:use-module (json) |
bd747018 LC |
30 | #:use-module (srfi srfi-1) |
31 | #:use-module (srfi srfi-37) | |
32 | #:use-module (ice-9 match) | |
33 | #:autoload (ice-9 pretty-print) (pretty-print) | |
34 | #:export (guix-describe)) | |
35 | ||
36 | \f | |
37 | ;;; | |
38 | ;;; Command-line options. | |
39 | ;;; | |
40 | ||
41 | (define %options | |
42 | ;; Specifications of the command-line options. | |
43 | (list (option '(#\f "format") #t #f | |
44 | (lambda (opt name arg result) | |
85e9c4b9 | 45 | (unless (member arg '("human" "channels" "json" "recutils")) |
bd747018 | 46 | (leave (G_ "~a: unsupported output format~%") arg)) |
3dd28aa3 | 47 | (alist-cons 'format (string->symbol arg) result))) |
1255400f OP |
48 | (option '(#\p "profile") #t #f |
49 | (lambda (opt name arg result) | |
50 | (alist-cons 'profile (canonicalize-profile arg) | |
51 | result))) | |
bd747018 LC |
52 | (option '(#\h "help") #f #f |
53 | (lambda args | |
54 | (show-help) | |
55 | (exit 0))) | |
56 | (option '(#\V "version") #f #f | |
57 | (lambda args | |
58 | (show-version-and-exit "guix describe"))))) | |
59 | ||
60 | (define %default-options | |
61 | ;; Alist of default option values. | |
62 | '((format . human))) | |
63 | ||
64 | (define (show-help) | |
65 | (display (G_ "Usage: guix describe [OPTION]... | |
66 | Display information about the channels currently in use.\n")) | |
67 | (display (G_ " | |
68 | -f, --format=FORMAT display information in the given FORMAT")) | |
1255400f OP |
69 | (display (G_ " |
70 | -p, --profile=PROFILE display information about PROFILE")) | |
bd747018 LC |
71 | (newline) |
72 | (display (G_ " | |
73 | -h, --help display this help and exit")) | |
74 | (display (G_ " | |
75 | -V, --version display version information and exit")) | |
76 | (newline) | |
77 | (show-bug-report-information)) | |
78 | ||
79 | (define (display-package-search-path fmt) | |
80 | "Display GUIX_PACKAGE_PATH, if it is set, according to FMT." | |
81 | (match (getenv "GUIX_PACKAGE_PATH") | |
82 | (#f #t) | |
83 | (string | |
84 | (match fmt | |
85 | ('human | |
86 | (format #t "~%GUIX_PACKAGE_PATH=\"~a\"~%" string)) | |
87 | ('channels | |
88 | (format #t (G_ "~%;; warning: GUIX_PACKAGE_PATH=\"~a\"~%") | |
b6fd086a LC |
89 | string)) |
90 | (_ | |
91 | (warning (G_ "'GUIX_PACKAGE_PATH' is set but it is not captured~%"))))))) | |
bd747018 | 92 | |
8548f995 OP |
93 | (define (channel->sexp channel) |
94 | `(channel | |
ed9c8eb4 | 95 | (name ',(channel-name channel)) |
8548f995 OP |
96 | (url ,(channel-url channel)) |
97 | (commit ,(channel-commit channel)))) | |
98 | ||
81a40ee0 OP |
99 | (define (channel->json channel) |
100 | (scm->json-string `((name . ,(channel-name channel)) | |
101 | (url . ,(channel-url channel)) | |
102 | (commit . ,(channel-commit channel))))) | |
103 | ||
85e9c4b9 OP |
104 | (define (channel->recutils channel port) |
105 | (format port "name: ~a~%" (channel-name channel)) | |
106 | (format port "url: ~a~%" (channel-url channel)) | |
107 | (format port "commit: ~a~%" (channel-commit channel))) | |
108 | ||
01262f1e | 109 | (define (display-checkout-info fmt) |
bd747018 LC |
110 | "Display information about the current checkout according to FMT, a symbol |
111 | denoting the requested format. Exit if the current directory does not lie | |
112 | within a Git checkout." | |
01262f1e | 113 | (let* ((program (car (command-line))) |
bd747018 LC |
114 | (directory (catch 'git-error |
115 | (lambda () | |
116 | (repository-discover (dirname program))) | |
117 | (lambda (key err) | |
06633026 LC |
118 | (report-error (G_ "failed to determine origin~%")) |
119 | (display-hint (format #f (G_ "Perhaps this | |
120 | @command{guix} command was not obtained with @command{guix pull}? Its version | |
121 | string is ~a.~%") | |
122 | %guix-version)) | |
123 | (exit 1)))) | |
bd747018 LC |
124 | (repository (repository-open directory)) |
125 | (head (repository-head repository)) | |
126 | (commit (oid->string (reference-target head)))) | |
127 | (match fmt | |
128 | ('human | |
129 | (format #t (G_ "Git checkout:~%")) | |
130 | (format #t (G_ " repository: ~a~%") (dirname directory)) | |
131 | (format #t (G_ " branch: ~a~%") (reference-shorthand head)) | |
132 | (format #t (G_ " commit: ~a~%") commit)) | |
133 | ('channels | |
8548f995 OP |
134 | (pretty-print `(list ,(channel->sexp (channel (name 'guix) |
135 | (url (dirname directory)) | |
81a40ee0 OP |
136 | (commit commit)))))) |
137 | ('json | |
138 | (display (channel->json (channel (name 'guix) | |
139 | (url (dirname directory)) | |
140 | (commit commit)))) | |
85e9c4b9 OP |
141 | (newline)) |
142 | ('recutils | |
143 | (channel->recutils (channel (name 'guix) | |
144 | (url (dirname directory)) | |
145 | (commit commit)) | |
146 | (current-output-port)))) | |
bd747018 LC |
147 | (display-package-search-path fmt))) |
148 | ||
149 | (define (display-profile-info profile fmt) | |
150 | "Display information about PROFILE, a profile as created by (guix channels), | |
151 | in the format specified by FMT." | |
152 | (define number | |
da34a19f | 153 | (generation-number profile)) |
bd747018 | 154 | |
8548f995 OP |
155 | (define channels |
156 | (map (lambda (entry) | |
157 | (match (assq 'source (manifest-entry-properties entry)) | |
158 | (('source ('repository ('version 0) | |
159 | ('url url) | |
160 | ('branch branch) | |
161 | ('commit commit) | |
162 | _ ...)) | |
163 | (channel (name (string->symbol (manifest-entry-name entry))) | |
164 | (url url) | |
165 | (commit commit))) | |
166 | ||
167 | ;; Pre-0.15.0 Guix does not provide that information, | |
168 | ;; so there's not much we can do in that case. | |
169 | (_ (channel (name 'guix) | |
170 | (url "?") | |
171 | (commit "?"))))) | |
172 | ||
173 | ;; Show most recently installed packages last. | |
174 | (reverse | |
175 | (manifest-entries | |
176 | (profile-manifest | |
177 | (if (zero? number) | |
178 | profile | |
179 | (generation-file-name profile number))))))) | |
180 | ||
bd747018 LC |
181 | (match fmt |
182 | ('human | |
183 | (display-profile-content profile number)) | |
184 | ('channels | |
81a40ee0 OP |
185 | (pretty-print `(list ,@(map channel->sexp channels)))) |
186 | ('json | |
85e9c4b9 OP |
187 | (format #t "[~a]~%" (string-join (map channel->json channels) ","))) |
188 | ('recutils | |
189 | (format #t "~{~a~%~}" | |
190 | (map (lambda (channel) | |
191 | (with-output-to-string | |
192 | (lambda () | |
193 | (channel->recutils channel (current-output-port))))) | |
194 | channels)))) | |
bd747018 LC |
195 | (display-package-search-path fmt)) |
196 | ||
197 | \f | |
198 | ;;; | |
199 | ;;; Entry point. | |
200 | ;;; | |
201 | ||
202 | (define (guix-describe . args) | |
1255400f OP |
203 | (let* ((opts (args-fold* args %options |
204 | (lambda (opt name arg result) | |
205 | (leave (G_ "~A: unrecognized option~%") | |
206 | name)) | |
207 | cons | |
208 | %default-options)) | |
209 | (format (assq-ref opts 'format)) | |
210 | (profile (or (assq-ref opts 'profile) (current-profile)))) | |
bd747018 | 211 | (with-error-handling |
1255400f | 212 | (match profile |
bd747018 LC |
213 | (#f |
214 | (display-checkout-info format)) | |
215 | (profile | |
e0caff9e | 216 | (display-profile-info (canonicalize-profile profile) format)))))) |