diff options
Diffstat (limited to 'guix/scripts/pull.scm')
| -rw-r--r-- | guix/scripts/pull.scm | 84 |
1 files changed, 68 insertions, 16 deletions
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 0ab688ac24..19410ad141 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -36,6 +36,8 @@ #:autoload (guix inferior) (open-inferior) #:use-module (guix scripts build) #:autoload (guix build utils) (which) + #:use-module ((guix build syscalls) + #:select (with-file-lock/no-wait)) #:use-module (guix git) #:use-module (git) #:use-module (gnu packages) @@ -52,6 +54,7 @@ #: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) @@ -69,7 +72,7 @@ ;; Alist of default option values. `((system . ,(%current-system)) (substitutes? . #t) - (build-hook? . #t) + (offload? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) @@ -182,6 +185,42 @@ 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 @@ -245,15 +284,20 @@ purposes." ;; When Texinfo markup is invalid, display it as-is. (const title))))))) -(define (display-news-entry entry language port) - "Display ENTRY, a <channel-news-entry>, in LANGUAGE, a language code, to -PORT." +(define (display-news-entry entry channel language port) + "Display ENTRY, a <channel-news-entry> from CHANNEL, in LANGUAGE, a language +code, to PORT." (define body (channel-news-entry-body entry)) + (define commit + (channel-news-entry-commit entry)) + (display-news-entry-title entry language port) (format port (dim (G_ " commit ~a~%")) - (channel-news-entry-commit entry)) + (if (supports-hyperlinks?) + (channel-commit-hyperlink channel commit) + commit)) (newline port) (let ((body (or (assoc-ref body language) (assoc-ref body (%default-message-language)) @@ -291,7 +335,7 @@ to display." (channel-name channel)) (for-each (if concise? (cut display-news-entry-title <> language port) - (cut display-news-entry <> language port)) + (cut display-news-entry <> channel language port)) entries) (newline port) #t)))))) @@ -526,10 +570,17 @@ way and displaying details about the channel's source code." ('branch branch) ('commit commit) _ ...)) - (format #t (G_ " repository URL: ~a~%") url) - (when branch - (format #t (G_ " branch: ~a~%") branch)) - (format #t (G_ " commit: ~a~%") 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. @@ -815,11 +866,12 @@ Use '~/.config/guix/channels.scm' instead.")) (if (assoc-ref opts 'bootstrap?) %bootstrap-guile (canonical-package guile-2.2))))) - (run-with-store store - (build-and-install instances profile - #:dry-run? - (assoc-ref opts 'dry-run?) - #:use-substitutes? - (assoc-ref opts 'substitutes?)))))))))))))) + (with-profile-lock profile + (run-with-store store + (build-and-install instances profile + #:dry-run? + (assoc-ref opts 'dry-run?) + #:use-substitutes? + (assoc-ref opts 'substitutes?))))))))))))))) ;;; pull.scm ends here |