[jackhill/guix/guix.git] / guix / scripts / describe.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2020 Ekaitz Zarraga <ekaitz@elenq.tech>
;;;
;;; 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 scripts describe)
  #:use-module ((guix config) #:select (%guix-version))
  #:use-module ((guix ui) #:hide (display-profile-content))
  #:use-module ((guix utils) #:select (string-replace-substring))
  #:use-module (guix channels)
  #:use-module (guix scripts)
  #:use-module (guix describe)
  #:use-module (guix profiles)
  #:autoload   (guix openpgp) (openpgp-format-fingerprint)
  #:use-module (git)
  #:use-module (json)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-37)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:autoload   (ice-9 pretty-print) (pretty-print)
  #:use-module (web uri)
  #:export (display-profile-content
            channel-commit-hyperlink

            guix-describe))

\f
;;;
;;; Command-line options.
;;;
(define %available-formats
  '("human" "channels" "channels-sans-intro" "json" "recutils"))

(define (list-formats)
  (display (G_ "The available formats are:\n"))
  (newline)
  (for-each (lambda (f)
              (format #t "  - ~a~%" f))
            %available-formats))

(define %options
  ;; Specifications of the command-line options.
  (list (option '(#\f "format") #t #f
                (lambda (opt name arg result)
                  (unless (member arg %available-formats)
                    (leave (G_ "~a: unsupported output format~%") arg))
                  (alist-cons 'format (string->symbol arg) result)))
        (option '("list-formats") #f #f
                (lambda (opt name arg result)
                  (list-formats)
                  (exit 0)))
        (option '(#\p "profile") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'profile (canonicalize-profile arg)
                              result)))
        (option '(#\h "help") #f #f
                (lambda args
                  (show-help)
                  (exit 0)))
        (option '(#\V "version") #f #f
                (lambda args
                  (show-version-and-exit "guix describe")))))

(define %default-options
  ;; Alist of default option values.
  '((format . human)))

(define (show-help)
  (display (G_ "Usage: guix describe [OPTION]...
Display information about the channels currently in use.\n"))
  (display (G_ "
  -f, --format=FORMAT    display information in the given FORMAT"))
  (display (G_ "
      --list-formats     display available formats"))
  (display (G_ "
  -p, --profile=PROFILE  display information about PROFILE"))
  (newline)
  (display (G_ "
  -h, --help             display this help and exit"))
  (display (G_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))

(define (display-package-search-path fmt)
  "Display GUIX_PACKAGE_PATH, if it is set, according to FMT."
  (match (getenv "GUIX_PACKAGE_PATH")
    (#f #t)
    (string
     (match fmt
       ('human
        (format #t "~%GUIX_PACKAGE_PATH=\"~a\"~%" string))
       ('channels
        (format #t (G_ "~%;; warning: GUIX_PACKAGE_PATH=\"~a\"~%")
                string))
       (_
        (warning (G_ "'GUIX_PACKAGE_PATH' is set but it is not captured~%")))))))

(define* (channel->sexp channel #:key (include-introduction? #t))
  (let ((intro (and include-introduction?
                    (channel-introduction channel))))
    `(channel
      (name ',(channel-name channel))
      (url ,(channel-url channel))
      (commit ,(channel-commit channel))
      ,@(if intro
            `((introduction (make-channel-introduction
                             ,(channel-introduction-first-signed-commit intro)
                             (openpgp-fingerprint
                              ,(openpgp-format-fingerprint
                                (channel-introduction-first-commit-signer
                                 intro))))))
            '()))))

(define (channel->json channel)
  (scm->json-string
   (let ((intro (channel-introduction channel)))
     `((name . ,(channel-name channel))
       (url . ,(channel-url channel))
       (commit . ,(channel-commit channel))
       ,@(if intro
             `((introduction
                . ((commit . ,(channel-introduction-first-signed-commit
                               intro))
                   (signer . ,(openpgp-format-fingerprint
                               (channel-introduction-first-commit-signer
                                intro))))))
             '())))))

(define (channel->recutils channel port)
  (define intro
    (channel-introduction channel))

  (format port "name: ~a~%" (channel-name channel))
  (format port "url: ~a~%" (channel-url channel))
  (format port "commit: ~a~%" (channel-commit channel))
  (when intro
    (format port "introductioncommit: ~a~%"
            (channel-introduction-first-signed-commit intro))
    (format port "introductionsigner: ~a~%"
            (openpgp-format-fingerprint
             (channel-introduction-first-commit-signer intro)))))

(define (display-checkout-info fmt)
  "Display information about the current checkout according to FMT, a symbol
denoting the requested format.  Exit if the current directory does not lie
within a Git checkout."
  (let* ((program    (car (command-line)))
         (directory  (catch 'git-error
                       (lambda ()
                         (repository-discover (dirname program)))
                       (lambda (key err)
                         (report-error (G_ "failed to determine origin~%"))
                         (display-hint (format #f (G_ "Perhaps this
@command{guix} command was not obtained with @command{guix pull}?  Its version
string is ~a.~%")
                                               %guix-version))
                         (exit 1))))
         (repository (repository-open directory))
         (head       (repository-head repository))
         (commit     (oid->string (reference-target head))))
    (match fmt
      ('human
       (format #t (G_ "Git checkout:~%"))
       (format #t (G_ "  repository: ~a~%") (dirname directory))
       (format #t (G_ "  branch: ~a~%") (reference-shorthand head))
       (format #t (G_ "  commit: ~a~%") commit))
      ('channels
       (pretty-print `(list ,(channel->sexp (channel (name 'guix)
                                                     (url (dirname directory))
                                                     (commit commit))))))
      ('json
       (display (channel->json (channel (name 'guix)
                                        (url (dirname directory))
                                        (commit commit))))
       (newline))
      ('recutils
       (channel->recutils (channel (name 'guix)
                                   (url (dirname directory))
                                   (commit commit))
                          (current-output-port))))
    (display-package-search-path fmt)))

(define (display-profile-info profile fmt)
  "Display information about PROFILE, a profile as created by (guix channels),
in the format specified by FMT."
  (define number
    (generation-number profile))

  (define channels
    (profile-channels (if (zero? number)
                          profile
                          (generation-file-name profile number))))

  (match fmt
    ('human
     (display-profile-content profile number))
    ('channels
     (pretty-print `(list ,@(map channel->sexp channels))))
    ('channels-sans-intro
     (pretty-print `(list ,@(map (cut channel->sexp <>
                                      #:include-introduction? #f)
                                 channels))))
    ('json
     (format #t "[~a]~%" (string-join (map channel->json channels) ",")))
    ('recutils
     (format #t "~{~a~%~}"
             (map (lambda (channel)
                    (with-output-to-string
                      (lambda ()
                        (channel->recutils channel (current-output-port)))))
                  channels))))
  (display-package-search-path fmt))

(define (display-profile-content profile number)
  "Display the packages in PROFILE, generation NUMBER, in a human-readable
way and displaying details about the channel's source code."
  (display-generation profile number)
  (for-each (lambda (entry)
              (format #t "  ~a ~a~%"
                      (manifest-entry-name entry)
                      (manifest-entry-version entry))
              (match (assq 'source (manifest-entry-properties entry))
                (('source ('repository ('version 0)
                                       ('url url)
                                       ('branch branch)
                                       ('commit commit)
                                       _ ...))
                 (let ((channel (channel (name 'nameless)
                                         (url url)
                                         (branch branch)
                                         (commit commit))))
                   (format #t (G_ "    repository URL: ~a~%") url)
                   (when branch
                     (format #t (G_ "    branch: ~a~%") branch))
                   (format #t (G_ "    commit: ~a~%")
                           (if (supports-hyperlinks?)
                               (channel-commit-hyperlink channel commit)
                               commit))))
                (_ #f)))

            ;; Show most recently installed packages last.
            (reverse
             (manifest-entries
              (profile-manifest (if (zero? number)
                                    profile
                                    (generation-file-name profile number)))))))

(define %vcs-web-views
  ;; Hard-coded list of host names and corresponding web view URL templates.
  ;; TODO: Allow '.guix-channel' files to specify a URL template.
  (let ((labhub-url (lambda (repository-url commit)
                      (string-append
                       (if (string-suffix? ".git" repository-url)
                           (string-drop-right repository-url 4)
                           repository-url)
                       "/commit/" commit))))
    `(("git.savannah.gnu.org"
       ,(lambda (repository-url commit)
          (string-append (string-replace-substring repository-url
                                                   "/git/" "/cgit/")
                         "/commit/?id=" commit)))
      ("notabug.org" ,labhub-url)
      ("framagit.org" ,labhub-url)
      ("gitlab.com" ,labhub-url)
      ("gitlab.inria.fr" ,labhub-url)
      ("github.com" ,labhub-url))))

(define* (channel-commit-hyperlink channel
                                   #:optional
                                   (commit (channel-commit channel)))
  "Return a hyperlink for COMMIT in CHANNEL, using COMMIT as the hyperlink's
text.  The hyperlink links to a web view of COMMIT, when available."
  (let* ((url  (channel-url channel))
         (uri  (string->uri url))
         (host (and uri (uri-host uri))))
    (if host
        (match (assoc host %vcs-web-views)
          (#f
           commit)
          ((_ template)
           (hyperlink (template url commit) commit)))
        commit)))

\f
;;;
;;; Entry point.
;;;

(define-command (guix-describe . args)
  (synopsis "describe the channel revisions currently used")
  (let* ((opts    (args-fold* args %options
                              (lambda (opt name arg result)
                                (leave (G_ "~A: unrecognized option~%")
                                       name))
                              cons
                              %default-options))
         (format  (assq-ref opts 'format))
         (profile (or (assq-ref opts 'profile) (current-profile))))
    (with-error-handling
      (match profile
        (#f
         (display-checkout-info format))
        (profile
         (display-profile-info (canonicalize-profile profile) format))))))
Commit	Line	Data
bd747018	1	;;; GNU Guix --- Functional package management for GNU
1d88470e	2	;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
8548f995	3	;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
9a27d84b	4	;;; Copyright © 2020 Ekaitz Zarraga <ekaitz@elenq.tech>
bd747018 LC	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 scripts describe)
06633026	22	#:use-module ((guix config) #:select (%guix-version))
bd747018	23	#:use-module ((guix ui) #:hide (display-profile-content))
1d88470e	24	#:use-module ((guix utils) #:select (string-replace-substring))
8548f995	25	#:use-module (guix channels)
bd747018 LC	26	#:use-module (guix scripts)
	27	#:use-module (guix describe)
	28	#:use-module (guix profiles)
6d39f0cb	29	#:autoload (guix openpgp) (openpgp-format-fingerprint)
bd747018	30	#:use-module (git)
81a40ee0	31	#:use-module (json)
bd747018	32	#:use-module (srfi srfi-1)
6d39f0cb	33	#:use-module (srfi srfi-26)
bd747018 LC	34	#:use-module (srfi srfi-37)
bd747018 LC	35	#:use-module (ice-9 match)
25b267af	36	#:use-module (ice-9 format)
bd747018	37	#:autoload (ice-9 pretty-print) (pretty-print)
1d88470e LC	38	#:use-module (web uri)
	39	#:export (display-profile-content
	40	channel-commit-hyperlink
	41
	42	guix-describe))
bd747018 LC	43
	44	\f
	45	;;;
	46	;;; Command-line options.
	47	;;;
6d39f0cb LC	48	(define %available-formats
6d39f0cb LC	49	'("human" "channels" "channels-sans-intro" "json" "recutils"))
9a27d84b EZ	50
	51	(define (list-formats)
	52	(display (G_ "The available formats are:\n"))
	53	(newline)
	54	(for-each (lambda (f)
	55	(format #t " - ~a~%" f))
	56	%available-formats))
bd747018 LC	57
	58	(define %options
	59	;; Specifications of the command-line options.
	60	(list (option '(#\f "format") #t #f
	61	(lambda (opt name arg result)
9a27d84b	62	(unless (member arg %available-formats)
bd747018	63	(leave (G_ "~a: unsupported output format~%") arg))
3dd28aa3	64	(alist-cons 'format (string->symbol arg) result)))
9a27d84b EZ	65	(option '("list-formats") #f #f
	66	(lambda (opt name arg result)
	67	(list-formats)
	68	(exit 0)))
1255400f OP	69	(option '(#\p "profile") #t #f
	70	(lambda (opt name arg result)
	71	(alist-cons 'profile (canonicalize-profile arg)
	72	result)))
bd747018 LC	73	(option '(#\h "help") #f #f
	74	(lambda args
	75	(show-help)
	76	(exit 0)))
	77	(option '(#\V "version") #f #f
	78	(lambda args
	79	(show-version-and-exit "guix describe")))))
	80
	81	(define %default-options
	82	;; Alist of default option values.
	83	'((format . human)))
	84
	85	(define (show-help)
	86	(display (G_ "Usage: guix describe [OPTION]...
	87	Display information about the channels currently in use.\n"))
	88	(display (G_ "
	89	-f, --format=FORMAT display information in the given FORMAT"))
9a27d84b EZ	90	(display (G_ "
9a27d84b EZ	91	--list-formats display available formats"))
1255400f OP	92	(display (G_ "
1255400f OP	93	-p, --profile=PROFILE display information about PROFILE"))
bd747018 LC	94	(newline)
	95	(display (G_ "
	96	-h, --help display this help and exit"))
	97	(display (G_ "
	98	-V, --version display version information and exit"))
	99	(newline)
	100	(show-bug-report-information))
	101
	102	(define (display-package-search-path fmt)
	103	"Display GUIX_PACKAGE_PATH, if it is set, according to FMT."
	104	(match (getenv "GUIX_PACKAGE_PATH")
	105	(#f #t)
	106	(string
	107	(match fmt
	108	('human
	109	(format #t "~%GUIX_PACKAGE_PATH=\"~a\"~%" string))
	110	('channels
	111	(format #t (G_ "~%;; warning: GUIX_PACKAGE_PATH=\"~a\"~%")
b6fd086a LC	112	string))
	113	(_
	114	(warning (G_ "'GUIX_PACKAGE_PATH' is set but it is not captured~%")))))))
bd747018	115
6d39f0cb LC	116	(define* (channel->sexp channel #:key (include-introduction? #t))
	117	(let ((intro (and include-introduction?
	118	(channel-introduction channel))))
	119	`(channel
	120	(name ',(channel-name channel))
	121	(url ,(channel-url channel))
	122	(commit ,(channel-commit channel))
	123	,@(if intro
	124	`((introduction (make-channel-introduction
	125	,(channel-introduction-first-signed-commit intro)
	126	(openpgp-fingerprint
	127	,(openpgp-format-fingerprint
	128	(channel-introduction-first-commit-signer
	129	intro))))))
	130	'()))))
8548f995	131
81a40ee0	132	(define (channel->json channel)
6d39f0cb LC	133	(scm->json-string
	134	(let ((intro (channel-introduction channel)))
	135	`((name . ,(channel-name channel))
	136	(url . ,(channel-url channel))
	137	(commit . ,(channel-commit channel))
	138	,@(if intro
	139	`((introduction
	140	. ((commit . ,(channel-introduction-first-signed-commit
	141	intro))
	142	(signer . ,(openpgp-format-fingerprint
	143	(channel-introduction-first-commit-signer
	144	intro))))))
	145	'())))))
81a40ee0	146
85e9c4b9	147	(define (channel->recutils channel port)
6d39f0cb LC	148	(define intro
	149	(channel-introduction channel))
	150
85e9c4b9 OP	151	(format port "name: ~a~%" (channel-name channel))
85e9c4b9 OP	152	(format port "url: ~a~%" (channel-url channel))
6d39f0cb LC	153	(format port "commit: ~a~%" (channel-commit channel))
	154	(when intro
	155	(format port "introductioncommit: ~a~%"
	156	(channel-introduction-first-signed-commit intro))
	157	(format port "introductionsigner: ~a~%"
	158	(openpgp-format-fingerprint
	159	(channel-introduction-first-commit-signer intro)))))
85e9c4b9	160
01262f1e	161	(define (display-checkout-info fmt)
bd747018 LC	162	"Display information about the current checkout according to FMT, a symbol
	163	denoting the requested format. Exit if the current directory does not lie
	164	within a Git checkout."
01262f1e	165	(let* ((program (car (command-line)))
bd747018 LC	166	(directory (catch 'git-error
	167	(lambda ()
	168	(repository-discover (dirname program)))
	169	(lambda (key err)
06633026 LC	170	(report-error (G_ "failed to determine origin~%"))
	171	(display-hint (format #f (G_ "Perhaps this
	172	@command{guix} command was not obtained with @command{guix pull}? Its version
	173	string is ~a.~%")
	174	%guix-version))
	175	(exit 1))))
bd747018 LC	176	(repository (repository-open directory))
	177	(head (repository-head repository))
	178	(commit (oid->string (reference-target head))))
	179	(match fmt
	180	('human
	181	(format #t (G_ "Git checkout:~%"))
	182	(format #t (G_ " repository: ~a~%") (dirname directory))
	183	(format #t (G_ " branch: ~a~%") (reference-shorthand head))
	184	(format #t (G_ " commit: ~a~%") commit))
	185	('channels
8548f995 OP	186	(pretty-print `(list ,(channel->sexp (channel (name 'guix)
8548f995 OP	187	(url (dirname directory))
81a40ee0 OP	188	(commit commit))))))
	189	('json
	190	(display (channel->json (channel (name 'guix)
	191	(url (dirname directory))
	192	(commit commit))))
85e9c4b9 OP	193	(newline))
	194	('recutils
	195	(channel->recutils (channel (name 'guix)
	196	(url (dirname directory))
	197	(commit commit))
	198	(current-output-port))))
bd747018 LC	199	(display-package-search-path fmt)))
	200
	201	(define (display-profile-info profile fmt)
	202	"Display information about PROFILE, a profile as created by (guix channels),
	203	in the format specified by FMT."
	204	(define number
da34a19f	205	(generation-number profile))
bd747018	206
8548f995	207	(define channels
a7c714d3 LC	208	(profile-channels (if (zero? number)
	209	profile
	210	(generation-file-name profile number))))
8548f995	211
bd747018 LC	212	(match fmt
	213	('human
	214	(display-profile-content profile number))
	215	('channels
81a40ee0	216	(pretty-print `(list ,@(map channel->sexp channels))))
6d39f0cb LC	217	('channels-sans-intro
	218	(pretty-print `(list ,@(map (cut channel->sexp <>
	219	#:include-introduction? #f)
	220	channels))))
81a40ee0	221	('json
85e9c4b9 OP	222	(format #t "[~a]~%" (string-join (map channel->json channels) ",")))
	223	('recutils
	224	(format #t "~{~a~%~}"
	225	(map (lambda (channel)
	226	(with-output-to-string
	227	(lambda ()
	228	(channel->recutils channel (current-output-port)))))
	229	channels))))
bd747018 LC	230	(display-package-search-path fmt))
bd747018 LC	231
1d88470e LC	232	(define (display-profile-content profile number)
	233	"Display the packages in PROFILE, generation NUMBER, in a human-readable
	234	way and displaying details about the channel's source code."
	235	(display-generation profile number)
	236	(for-each (lambda (entry)
	237	(format #t " ~a ~a~%"
	238	(manifest-entry-name entry)
	239	(manifest-entry-version entry))
	240	(match (assq 'source (manifest-entry-properties entry))
	241	(('source ('repository ('version 0)
	242	('url url)
	243	('branch branch)
	244	('commit commit)
	245	_ ...))
	246	(let ((channel (channel (name 'nameless)
	247	(url url)
	248	(branch branch)
	249	(commit commit))))
	250	(format #t (G_ " repository URL: ~a~%") url)
	251	(when branch
	252	(format #t (G_ " branch: ~a~%") branch))
	253	(format #t (G_ " commit: ~a~%")
	254	(if (supports-hyperlinks?)
	255	(channel-commit-hyperlink channel commit)
c2f9ea2b	256	commit))))
1d88470e LC	257	(_ #f)))
	258
	259	;; Show most recently installed packages last.
	260	(reverse
	261	(manifest-entries
	262	(profile-manifest (if (zero? number)
	263	profile
	264	(generation-file-name profile number)))))))
	265
	266	(define %vcs-web-views
	267	;; Hard-coded list of host names and corresponding web view URL templates.
	268	;; TODO: Allow '.guix-channel' files to specify a URL template.
	269	(let ((labhub-url (lambda (repository-url commit)
	270	(string-append
	271	(if (string-suffix? ".git" repository-url)
	272	(string-drop-right repository-url 4)
	273	repository-url)
	274	"/commit/" commit))))
	275	`(("git.savannah.gnu.org"
	276	,(lambda (repository-url commit)
	277	(string-append (string-replace-substring repository-url
	278	"/git/" "/cgit/")
	279	"/commit/?id=" commit)))
	280	("notabug.org" ,labhub-url)
	281	("framagit.org" ,labhub-url)
	282	("gitlab.com" ,labhub-url)
	283	("gitlab.inria.fr" ,labhub-url)
	284	("github.com" ,labhub-url))))
	285
	286	(define* (channel-commit-hyperlink channel
	287	#:optional
c2f9ea2b	288	(commit (channel-commit channel)))
1d88470e	289	"Return a hyperlink for COMMIT in CHANNEL, using COMMIT as the hyperlink's
c2f9ea2b	290	text. The hyperlink links to a web view of COMMIT, when available."
1d88470e LC	291	(let* ((url (channel-url channel))
	292	(uri (string->uri url))
	293	(host (and uri (uri-host uri))))
	294	(if host
	295	(match (assoc host %vcs-web-views)
	296	(#f
	297	commit)
	298	((_ template)
c2f9ea2b	299	(hyperlink (template url commit) commit)))
1d88470e LC	300	commit)))
1d88470e LC	301
bd747018 LC	302	\f
	303	;;;
	304	;;; Entry point.
	305	;;;
	306
3794ce93 LC	307	(define-command (guix-describe . args)
3794ce93 LC	308	(synopsis "describe the channel revisions currently used")
1255400f OP	309	(let* ((opts (args-fold* args %options
	310	(lambda (opt name arg result)
	311	(leave (G_ "~A: unrecognized option~%")
	312	name))
	313	cons
	314	%default-options))
	315	(format (assq-ref opts 'format))
	316	(profile (or (assq-ref opts 'profile) (current-profile))))
bd747018	317	(with-error-handling
1255400f	318	(match profile
bd747018 LC	319	(#f
	320	(display-checkout-info format))
	321	(profile
e0caff9e	322	(display-profile-info (canonicalize-profile profile) format))))))