16/18: refresh: Allow updating to a specific version.

[guix-commits]

htgoebel pushed a commit to branch master
in repository guix.

commit 8aeccc6240ec45f0bc7bed655e0c8149ae4253eb
Author: Hartmut Goebel <h.goebel@crazy-compilers.com>
AuthorDate: Fri Jun 24 20:40:57 2022 +0200

    refresh: Allow updating to a specific version.
    
    * guix/scripts/refresh.scm (options->packages)[args-packages]: Handle 
version
      specification in package name arguments.
      (update-package): Add #:version argument and pass it on to called 
functions.
      (guix-refresh): When updating, pass the specified version (if any) to
      update-package.
      [package-list-without-versions, package-list-with-versions]: New 
functions.
---
 guix/scripts/refresh.scm | 49 ++++++++++++++++++++++++++++++++++++------------
 1 file changed, 37 insertions(+), 12 deletions(-)

diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index 14329751f8..e0b94ce48d 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -9,6 +9,7 @@
 ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
+;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -46,6 +47,7 @@
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 format)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
   #:use-module (srfi srfi-71)
@@ -181,7 +183,7 @@ specified with `--select'.\n"))
   (newline)
   (show-bug-report-information))
 
-(define (options->packages opts)
+(define (options->update-specs opts)
   "Return the list of packages requested by OPTS, honoring options like
 '--recursive'."
   (define core-package?
@@ -224,7 +226,7 @@ update would trigger a complete rebuild."
                          (('argument . spec)
                           ;; Take either the specified version or the
                           ;; latest one.
-                          (specification->package spec))
+                          (update-specification->update-spec spec))
                          (('expression . exp)
                           (read/eval-package-expression exp))
                          (_ #f))
@@ -255,6 +257,25 @@ update would trigger a complete rebuild."
         (return packages))))
 
 
+;;;
+;;; Utilities.
+;;;
+
+(define-record-type <update-spec>
+  (update-spec package version)
+  update?
+  (package update-spec-package)
+  (version update-spec-version))
+
+(define (update-specification->update-spec spec)
+  "Given SPEC, a package name like \"guile@2.0=2.0.8\", return a <update>
+record with two fields: the package to upgrade, and the target version."
+  (match (string-rindex spec #\=)
+    (#f  (update-spec (specification->package spec) #f))
+    (idx (update-spec (specification->package (substring spec 0 idx))
+                      (substring spec (1+ idx))))))
+
+
 ;;;
 ;;; Updates.
 ;;;
@@ -298,7 +319,7 @@ update would trigger a complete rebuild."
            (G_ "no updater for ~a~%")
            (package-name package)))
 
-(define* (update-package store package updaters
+(define* (update-package store package version updaters
                          #:key (key-download 'interactive) warn?)
   "Update the source file that defines PACKAGE with the new version.
 KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
@@ -307,7 +328,7 @@ warn about packages that have no matching updater."
   (if (lookup-updater package updaters)
       (let ((version output source
                      (package-update store package updaters
-                                     #:key-download key-download))
+                                     #:key-download key-download #:version 
version))
             (loc (or (package-field-location package 'version)
                      (package-location package))))
         (when version
@@ -540,12 +561,12 @@ all are dependent packages: ~{~a~^ ~}~%")
     (with-error-handling
       (with-store store
         (run-with-store store
-          (mlet %store-monad ((packages (options->packages opts)))
+          (mlet %store-monad ((update-specs (options->update-specs opts)))
             (cond
              (list-dependent?
-              (list-dependents packages))
+              (list-dependents (map update-spec-package update-specs)))
              (list-transitive?
-              (list-transitive packages))
+              (list-transitive (map update-spec-package update-specs)))
              (update?
               (parameterize ((%openpgp-key-server
                               (or (assoc-ref opts 'key-server)
@@ -558,13 +579,17 @@ all are dependent packages: ~{~a~^ ~}~%")
                                   (string-append (config-directory)
                                                  
"/upstream/trustedkeys.kbx"))))
                 (for-each
-                 (cut update-package store <> updaters
-                      #:key-download key-download
-                      #:warn? warn?)
-                 packages)
+                 (lambda (update)
+                   (update-package store
+                                   (update-spec-package update)
+                                   (update-spec-version update)
+                                   updaters
+                                   #:key-download key-download
+                                   #:warn? warn?))
+                 update-specs)
                 (return #t)))
              (else
               (for-each (cut check-for-package-update <> updaters
                              #:warn? warn?)
-                        packages)
+                        (map update-spec-package update-specs))
               (return #t)))))))))