diff options
| -rw-r--r-- | guix/scripts/describe.scm | 80 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 80 |
2 files changed, 82 insertions, 78 deletions
diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index 99a88c50fa..f13f221da9 100644 --- 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)) ;;; @@ -173,6 +177,76 @@ 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)))) + (_ #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))) + ;;; ;;; Entry point. diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index cb1be989e1..51d4da209a 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -18,7 +18,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix scripts pull) - #:use-module (guix ui) + #:use-module ((guix ui) #:hide (display-profile-content)) #:use-module (guix colors) #:use-module (guix utils) #:use-module ((guix status) #:select (with-status-verbosity)) @@ -37,6 +37,7 @@ inferior-available-packages close-inferior) #:use-module (guix scripts build) + #:use-module (guix scripts describe) #:autoload (guix build utils) (which) #:use-module ((guix build syscalls) #:select (with-file-lock/no-wait)) @@ -56,13 +57,12 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) - #:use-module (web uri) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (ice-9 format) - #:export (display-profile-content - channel-list - channel-commit-hyperlink + #:re-export (display-profile-content + channel-commit-hyperlink) + #:export (channel-list with-git-error-handling guix-pull)) @@ -188,42 +188,6 @@ Download and deploy the latest version of Guix.\n")) %standard-build-options)) -(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))) - (define* (display-profile-news profile #:key concise? current-is-newer?) "Display what's up in PROFILE--new packages, and all that. If @@ -559,40 +523,6 @@ true, display what would be built without actually building it." ;;; Queries. ;;; -(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 (indented-string str indent) "Return STR with each newline preceded by IDENT spaces." (define indent-string |