summaryrefslogtreecommitdiff
path: root/guix/scripts/pull.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/scripts/pull.scm')
-rw-r--r--guix/scripts/pull.scm140
1 files changed, 127 insertions, 13 deletions
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 7202e3cc16..433502b5de 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -28,9 +28,12 @@
#:use-module (guix profiles)
#:use-module (guix gexp)
#:use-module (guix grafts)
+ #:use-module (guix memoization)
#:use-module (guix monads)
+ #:autoload (guix inferior) (open-inferior)
#:use-module (guix scripts build)
#:autoload (guix self) (whole-package)
+ #:use-module (gnu packages)
#:autoload (gnu packages ssh) (guile-ssh)
#:autoload (gnu packages tls) (gnutls)
#:use-module ((guix scripts package) #:select (build-and-use-profile))
@@ -45,9 +48,11 @@
#:use-module ((gnu packages certs) #:select (le-certs))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
#:use-module (ice-9 match)
+ #:use-module (ice-9 vlist)
#:export (guix-pull))
(module-autoload! (resolve-module '(guix scripts pull))
@@ -230,12 +235,32 @@ URL, BRANCH, and COMMIT as a property in the manifest entry."
(branch ,branch)
(commit ,commit))))))))))
+(define (display-profile-news profile)
+ "Display what's up in PROFILE--new packages, and all that."
+ (match (memv (generation-number profile)
+ (reverse (profile-generations profile)))
+ ((current previous _ ...)
+ (newline)
+ (let ((old (fold-packages (lambda (package result)
+ (alist-cons (package-name package)
+ (package-version package)
+ result))
+ '()))
+ (new (profile-package-alist
+ (generation-file-name profile current))))
+ (display-new/upgraded-packages old new
+ #:heading (G_ "New in this revision:\n"))))
+ (_ #t)))
+
(define* (build-and-install source config-dir
#:key verbose? url branch commit)
"Build the tool from SOURCE, and install it in CONFIG-DIR."
(define update-profile
(store-lift build-and-use-profile))
+ (define profile
+ (string-append config-dir "/current"))
+
(mlet* %store-monad ((drv (build-from-source source
#:commit commit
#:verbose? verbose?))
@@ -243,8 +268,9 @@ URL, BRANCH, and COMMIT as a property in the manifest entry."
#:url url
#:branch branch
#:commit commit)))
- (update-profile (string-append config-dir "/current")
- (manifest (list entry)))))
+ (mbegin %store-monad
+ (update-profile profile (manifest (list entry)))
+ (return (display-profile-news profile)))))
(define (honor-lets-encrypt-certificates! store)
"Tell Guile-Git to use the Let's Encrypt certificates."
@@ -289,6 +315,7 @@ certificates~%"))
(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)
@@ -310,6 +337,90 @@ way and displaying details about the channel's source code."
(manifest-entries
(profile-manifest (generation-file-name profile number))))))
+(define (indented-string str indent)
+ "Return STR with each newline preceded by IDENT spaces."
+ (define indent-string
+ (make-list indent #\space))
+
+ (list->string
+ (string-fold-right (lambda (chr result)
+ (if (eqv? chr #\newline)
+ (cons chr (append indent-string result))
+ (cons chr result)))
+ '()
+ str)))
+
+(define profile-package-alist
+ (mlambda (profile)
+ "Return a name/version alist representing the packages in PROFILE."
+ (fold (lambda (package lst)
+ (alist-cons (inferior-package-name package)
+ (inferior-package-version package)
+ lst))
+ '()
+ (let* ((inferior (open-inferior profile))
+ (packages (inferior-packages inferior)))
+ (close-inferior inferior)
+ packages))))
+
+(define* (display-new/upgraded-packages alist1 alist2
+ #:key (heading ""))
+ "Given the two package name/version alists ALIST1 and ALIST2, display the
+list of new and upgraded packages going from ALIST1 to ALIST2. When ALIST1
+and ALIST2 differ, display HEADING upfront."
+ (let* ((old (fold (match-lambda*
+ (((name . version) table)
+ (vhash-cons name version table)))
+ vlist-null
+ alist1))
+ (new (remove (match-lambda
+ ((name . _)
+ (vhash-assoc name old)))
+ alist2))
+ (upgraded (filter-map (match-lambda
+ ((name . new-version)
+ (match (vhash-fold* cons '() name old)
+ (() #f)
+ ((= (cut sort <> version>?) old-versions)
+ (and (version>? new-version
+ (first old-versions))
+ (string-append name "@"
+ new-version))))))
+ alist2)))
+ (unless (and (null? new) (null? upgraded))
+ (display heading))
+
+ (match (length new)
+ (0 #t)
+ (count
+ (format #t (N_ " ~h new package: ~a~%"
+ " ~h new packages: ~a~%" count)
+ count
+ (indented-string
+ (fill-paragraph (string-join (sort (map first new) string<?)
+ ", ")
+ (- (%text-width) 4) 30)
+ 4))))
+ (match (length upgraded)
+ (0 #t)
+ (count
+ (format #t (N_ " ~h package upgraded: ~a~%"
+ " ~h packages upgraded: ~a~%" count)
+ count
+ (indented-string
+ (fill-paragraph (string-join (sort upgraded string<?) ", ")
+ (- (%text-width) 4) 35)
+ 4))))))
+
+(define (display-profile-content-diff profile gen1 gen2)
+ "Display the changes in PROFILE GEN2 compared to generation GEN1."
+ (define (package-alist generation)
+ (profile-package-alist (generation-file-name profile generation)))
+
+ (display-profile-content profile gen2)
+ (display-new/upgraded-packages (package-alist gen1)
+ (package-alist gen2)))
+
(define (process-query opts)
"Process any query specified by OPTS."
(define profile
@@ -317,29 +428,32 @@ way and displaying details about the channel's source code."
(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)))
+ (define (list-generations profile numbers)
+ (match numbers
+ ((first rest ...)
+ (display-profile-content profile first)
+ (let loop ((numbers numbers))
+ (match numbers
+ ((first second rest ...)
+ (display-profile-content-diff profile
+ first second)
+ (loop (cons second rest)))
+ ((_) #t)
+ (() #t))))))
(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)))
+ (list-generations profile (profile-generations profile)))
((matching-generations pattern profile)
=>
(match-lambda
(()
(exit 1))
((numbers ...)
- (for-each (lambda (generation)
- (list-generation display-profile-content generation))
- numbers)))))))))
+ (list-generations profile numbers)))))))))
(define (guix-pull . args)