From e2f8be0664609223369f01290b69b44196783ab3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 13 Jun 2018 23:39:24 +0200 Subject: pull: Add '--list-generations'. * guix/scripts/pull.scm (show-help, %options): Add '--list-generations'. (display-profile-content, process-query): New procedures. (guix-pull): Honor '--list-generations'. --- guix/scripts/pull.scm | 149 +++++++++++++++++++++++++++++++++++++------------- 1 file changed, 111 insertions(+), 38 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 499de0ec45..7202e3cc16 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -45,6 +45,7 @@ #:use-module ((gnu packages certs) #:select (le-certs)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:export (guix-pull)) @@ -109,6 +110,9 @@ Download and deploy the latest version of Guix.\n")) --commit=COMMIT download the specified COMMIT")) (display (G_ " --branch=BRANCH download the tip of the specified BRANCH")) + (display (G_ " + -l, --list-generations[=PATTERN] + list generations matching PATTERN")) (display (G_ " --bootstrap use the bootstrap Guile to build the new Guix")) (newline) @@ -125,6 +129,10 @@ Download and deploy the latest version of Guix.\n")) (cons* (option '("verbose") #f #f (lambda (opt name arg result) (alist-cons 'verbose? #t result))) + (option '(#\l "list-generations") #f #t + (lambda (opt name arg result) + (cons `(query list-generations ,(or arg "")) + result))) (option '("url") #t #f (lambda (opt name arg result) (alist-cons 'repository-url arg @@ -273,6 +281,66 @@ certificates~%")) (lambda (key err) (report-git-error err)))) + +;;; +;;; 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." + (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) + _ ...)) + (format #t (G_ " repository URL: ~a~%") url) + (when branch + (format #t (G_ " branch: ~a~%") branch)) + (format #t (G_ " commit: ~a~%") commit)) + (_ #f))) + + ;; Show most recently installed packages last. + (reverse + (manifest-entries + (profile-manifest (generation-file-name profile number)))))) + +(define (process-query opts) + "Process any query specified by OPTS." + (define profile + (string-append (config-directory) "/current")) + + (match (assoc-ref opts 'query) + (('list-generations pattern) + (define (list-generation display-function number) + (unless (zero? number) + (display-generation profile number) + (display-function profile number) + (newline))) + + (leave-on-EPIPE + (cond ((not (file-exists? profile)) ; XXX: race condition + (raise (condition (&profile-not-found-error + (profile profile))))) + ((string-null? pattern) + (for-each (lambda (generation) + (list-generation display-profile-content generation)) + (profile-generations profile))) + ((matching-generations pattern profile) + => + (match-lambda + (() + (exit 1)) + ((numbers ...) + (for-each (lambda (generation) + (list-generation display-profile-content generation)) + numbers))))))))) + (define (guix-pull . args) (define (use-le-certs? url) @@ -287,43 +355,48 @@ certificates~%")) (cache (string-append (cache-directory) "/pull"))) (ensure-guile-git!) - (unless (assoc-ref opts 'dry-run?) ;XXX: not very useful - (with-store store - (parameterize ((%graft? (assoc-ref opts 'graft?))) - (set-build-options-from-command-line store opts) - - ;; For reproducibility, always refer to the LE certificates when we - ;; know we're talking to Savannah. - (when (use-le-certs? url) - (honor-lets-encrypt-certificates! store)) - - (format (current-error-port) - (G_ "Updating from Git repository at '~a'...~%") - url) - - (let-values (((checkout commit) - (latest-repository-commit store url - #:ref ref - #:cache-directory cache))) - - (format (current-error-port) - (G_ "Building from Git commit ~a...~%") - commit) - (parameterize ((%guile-for-build - (package-derivation - store - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (canonical-package guile-2.2))))) - (run-with-store store - (build-and-install checkout (config-directory) - #:url url - #:branch (match ref - (('branch . branch) - branch) - (_ #f)) - #:commit commit - #:verbose? - (assoc-ref opts 'verbose?)))))))))))) + (cond ((assoc-ref opts 'query) + (process-query opts)) + ((assoc-ref opts 'dry-run?) + #t) ;XXX: not very useful + (else + (with-store store + (parameterize ((%graft? (assoc-ref opts 'graft?))) + (set-build-options-from-command-line store opts) + + ;; For reproducibility, always refer to the LE certificates + ;; when we know we're talking to Savannah. + (when (use-le-certs? url) + (honor-lets-encrypt-certificates! store)) + + (format (current-error-port) + (G_ "Updating from Git repository at '~a'...~%") + url) + + (let-values (((checkout commit) + (latest-repository-commit store url + #:ref ref + #:cache-directory + cache))) + + (format (current-error-port) + (G_ "Building from Git commit ~a...~%") + commit) + (parameterize ((%guile-for-build + (package-derivation + store + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (canonical-package guile-2.2))))) + (run-with-store store + (build-and-install checkout (config-directory) + #:url url + #:branch (match ref + (('branch . branch) + branch) + (_ #f)) + #:commit commit + #:verbose? + (assoc-ref opts 'verbose?))))))))))))) ;;; pull.scm ends here -- cgit v1.2.3