diff options
Diffstat (limited to 'guix/scripts/pull.scm')
| -rw-r--r-- | guix/scripts/pull.scm | 80 |
1 files changed, 5 insertions, 75 deletions
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 |