me
/
guix
Archived
1
0
Fork 0
Code

describe: Remove dependency on (guix scripts pull). 

Until now, 'guix describe' would perform ~3K stat calls and ~1K openat
calls because it was pulling (guix scripts pull), which in turn pulls in
many (gnu packages …) modules.

* guix/scripts/pull.scm (display-profile-content, %vcs-web-views)
(channel-commit-hyperlink): Move to...
* guix/scripts/describe.scm: ... here.  Remove import of (guix scripts
pull).
master
Ludovic Courtès 2020-02-11 12:17:33 +01:00
parent 1deca767be
commit 1d88470e10
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 82 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
guix/scripts/describe.scm
View File

@ -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.

80
guix/scripts/pull.scm
View File

@ -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