ui: Only display link in capable terminals.

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

diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm
index fa6b6ca..5e00067 100644 (file)
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -20,18 +20,22 @@
 (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)
-  #:use-module ((guix scripts pull) #:select (display-profile-content))
   #:use-module (git)
   #:use-module (json)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
   #:autoload   (ice-9 pretty-print) (pretty-print)
-  #:export (guix-describe))
+  #:use-module (web uri)
+  #:export (display-profile-content
+            channel-commit-hyperlink
+
+            guix-describe))
 
 \f
 ;;;
@@ -153,30 +157,9 @@ in the format specified by FMT."
     (generation-number profile))
 
   (define channels
-    (map (lambda (entry)
-           (match (assq 'source (manifest-entry-properties entry))
-             (('source ('repository ('version 0)
-                                    ('url url)
-                                    ('branch branch)
-                                    ('commit commit)
-                                    _ ...))
-              (channel (name (string->symbol (manifest-entry-name entry)))
-                       (url url)
-                       (commit commit)))
-
-             ;; Pre-0.15.0 Guix does not provide that information,
-             ;; so there's not much we can do in that case.
-             (_ (channel (name 'guix)
-                         (url "?")
-                         (commit "?")))))
-
-         ;; Show most recently installed packages last.
-         (reverse
-          (manifest-entries
-           (profile-manifest
-            (if (zero? number)
-                profile
-                (generation-file-name profile number)))))))
+    (profile-channels (if (zero? number)
+                          profile
+                          (generation-file-name profile number))))
 
   (match fmt
     ('human
@@ -194,6 +177,83 @@ in the format specified by FMT."
                   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))
+                   (when (not (supports-hyperlinks?))
+                     (format #t (G_ "    URL: ~a~%")
+                             (channel-commit-hyperlink channel commit
+                                                       (lambda (url msg) url))))))
+                (_ #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))
+                                   (transformer hyperlink))
+  "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.
+TRANSFORMER is a procedure of 2 arguments, a URI and text, and returns a
+string for display."
+  (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)
+           (transformer (template url commit) commit)))
+        commit)))
+
 \f
 ;;;
 ;;; Entry point.