[jackhill/guix/guix.git] / guix / scripts / refresh.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix scripts refresh)
  #:use-module (guix ui)
  #:use-module (guix hash)
  #:use-module (guix scripts)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix packages)
  #:use-module (guix upstream)
  #:use-module ((guix gnu-maintenance) #:select (%gnu-updater))
  #:use-module (guix import elpa)
  #:use-module (guix gnupg)
  #:use-module (gnu packages)
  #:use-module ((gnu packages commencement) #:select (%final-inputs))
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 format)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-37)
  #:use-module (rnrs io ports)
  #:export (guix-refresh))

\f
;;;
;;; Command-line options.
;;;

(define %default-options
  ;; Alist of default option values.
  '())

(define %options
  ;; Specification of the command-line options.
  (list (option '(#\u "update") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'update? #t result)))
        (option '(#\s "select") #t #f
                (lambda (opt name arg result)
                  (match arg
                    ((or "core" "non-core")
                     (alist-cons 'select (string->symbol arg)
                                 result))
                    (x
                     (leave (_ "~a: invalid selection; expected `core' or `non-core'~%")
                            arg)))))
        (option '(#\l "list-dependent") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'list-dependent? #t result)))

        (option '("key-server") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'key-server arg result)))
        (option '("gpg") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'gpg-command arg result)))
        (option '("key-download") #t #f
                (lambda (opt name arg result)
                  (match arg
                    ((or "interactive" "always" "never")
                     (alist-cons 'key-download (string->symbol arg)
                                 result))
                    (_
                     (leave (_ "unsupported policy: ~a~%")
                            arg)))))

        (option '(#\h "help") #f #f
                (lambda args
                  (show-help)
                  (exit 0)))
        (option '(#\V "version") #f #f
                (lambda args
                  (show-version-and-exit "guix refresh")))))

(define (show-help)
  (display (_ "Usage: guix refresh [OPTION]... PACKAGE...
Update package definitions to match the latest upstream version.

When PACKAGE... is given, update only the specified packages.  Otherwise
update all the packages of the distribution, or the subset thereof
specified with `--select'.\n"))
  (display (_ "
  -u, --update           update source files in place"))
  (display (_ "
  -s, --select=SUBSET    select all the packages in SUBSET, one of
                         `core' or `non-core'"))
  (display (_ "
  -l, --list-dependent   list top-level dependent packages that would need to
                         be rebuilt as a result of upgrading PACKAGE..."))
  (newline)
  (display (_ "
      --key-server=HOST  use HOST as the OpenPGP key server"))
  (display (_ "
      --gpg=COMMAND      use COMMAND as the GnuPG 2.x command"))
  (display (_ "
      --key-download=POLICY
                         handle missing OpenPGP keys according to POLICY:
                         'always', 'never', and 'interactive', which is also
                         used when 'key-download' is not specified"))
  (newline)
  (display (_ "
  -h, --help             display this help and exit"))
  (display (_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))

\f
;;;
;;; Updates.
;;;

(define %updaters
  ;; List of "updaters" used by default.  They are consulted in this order.
  (list %gnu-updater
        %elpa-updater))

(define* (update-package store package #:key (key-download 'interactive))
  "Update the source file that defines PACKAGE with the new version.
KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
values: 'interactive' (default), 'always', and 'never'."
  (let-values (((version tarball)
                (catch #t
                  (lambda ()
                    (package-update store package %updaters
                                    #:key-download key-download))
                  (lambda _
                    (values #f #f))))
               ((loc)
                (or (package-field-location package 'version)
                    (package-location package))))
    (when version
      (if (and=> tarball file-exists?)
          (begin
            (format (current-error-port)
                    (_ "~a: ~a: updating from version ~a to version ~a...~%")
                    (location->string loc)
                    (package-name package)
                    (package-version package) version)
            (let ((hash (call-with-input-file tarball
                          port-sha256)))
              (update-package-source package version hash)))
          (warning (_ "~a: version ~a could not be \
downloaded and authenticated; not updating~%")
                   (package-name package) version)))))

\f
;;;
;;; Entry point.
;;;

(define (guix-refresh . args)
  (define (parse-options)
    ;; Return the alist of option values.
    (args-fold* args %options
                (lambda (opt name arg result)
                  (leave (_ "~A: unrecognized option~%") name))
                (lambda (arg result)
                  (alist-cons 'argument arg result))
                %default-options))

  (define (keep-newest package lst)
    ;; If a newer version of PACKAGE is already in LST, return LST; otherwise
    ;; return LST minus the other version of PACKAGE in it, plus PACKAGE.
    (let ((name (package-name package)))
      (match (find (lambda (p)
                     (string=? (package-name p) name))
                   lst)
        ((? package? other)
         (if (version>? (package-version other) (package-version package))
             lst
             (cons package (delq other lst))))
        (_
         (cons package lst)))))

  (define core-package?
    (let* ((input->package (match-lambda
                            ((name (? package? package) _ ...) package)
                            (_ #f)))
           (final-inputs   (map input->package %final-inputs))
           (core           (append final-inputs
                                   (append-map (compose (cut filter-map input->package <>)
                                                        package-transitive-inputs)
                                               final-inputs)))
           (names          (delete-duplicates (map package-name core))))
      (lambda (package)
        "Return true if PACKAGE is likely a \"core package\"---i.e., one whose
update would trigger a complete rebuild."
        ;; Compare by name because packages in base.scm basically inherit
        ;; other packages.  So, even if those packages are not core packages
        ;; themselves, updating them would also update those who inherit from
        ;; them.
        ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input.
        (member (package-name package) names))))

  (let* ((opts            (parse-options))
         (update?         (assoc-ref opts 'update?))
         (list-dependent? (assoc-ref opts 'list-dependent?))
         (key-download    (assoc-ref opts 'key-download))
         (packages
          (match (filter-map (match-lambda
                               (('argument . spec)
                                ;; Take either the specified version or the
                                ;; latest one.
                                (specification->package spec))
                               (_ #f))
                             opts)
                 (()                          ; default to all packages
                  (let ((select? (match (assoc-ref opts 'select)
                                        ('core core-package?)
                                        ('non-core (negate core-package?))
                                        (_ (const #t)))))
                    (fold-packages (lambda (package result)
                                     (if (select? package)
                                         (keep-newest package result)
                                         result))
                                   '())))
                 (some                        ; user-specified packages
                  some))))
    (with-error-handling
      (cond
       (list-dependent?
        (let* ((rebuilds (map package-full-name
                              (package-covering-dependents packages)))
               (total-dependents
                (length (package-transitive-dependents packages))))
          (if (= total-dependents 0)
              (format (current-output-port)
                      (N_ "No dependents other than itself: ~{~a~}~%"
                          "No dependents other than themselves: ~{~a~^ ~}~%"
                          (length packages))
                      (map package-full-name packages))
              (format (current-output-port)
                      (N_ (N_ "A single dependent package: ~2*~{~a~}~%"
                              "Building the following package would ensure ~d \
dependent packages are rebuilt; ~*~{~a~^ ~}~%"
                              total-dependents)
                          "Building the following ~d packages would ensure ~d \
dependent packages are rebuilt: ~{~a~^ ~}~%"
                          (length rebuilds))
                      (length rebuilds) total-dependents rebuilds))))
       (update?
        (let ((store (open-connection)))
          (parameterize ((%openpgp-key-server
                          (or (assoc-ref opts 'key-server)
                              (%openpgp-key-server)))
                         (%gpg-command
                          (or (assoc-ref opts 'gpg-command)
                              (%gpg-command))))
            (for-each
             (cut update-package store <> #:key-download key-download)
             packages))))
       (else
        (for-each (lambda (package)
                    (match (package-update-path package %updaters)
                      ((? upstream-source? source)
                       (let ((loc (or (package-field-location package 'version)
                                      (package-location package))))
                         (format (current-error-port)
                                 (_ "~a: ~a would be upgraded from ~a to ~a~%")
                                 (location->string loc)
                                 (package-name package) (package-version package)
                                 (upstream-source-version source))))
                      (#f #f)))
                  packages))))))
Commit	Line	Data
0fdd3bea	1	;;; GNU Guix --- Functional package management for GNU
4b9b3cbb	2	;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
392b5d8c	3	;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
7d193ec3	4	;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
0fdd3bea LC	5	;;;
	6	;;; This file is part of GNU Guix.
	7	;;;
	8	;;; GNU Guix is free software; you can redistribute it and/or modify it
	9	;;; under the terms of the GNU General Public License as published by
	10	;;; the Free Software Foundation; either version 3 of the License, or (at
	11	;;; your option) any later version.
	12	;;;
	13	;;; GNU Guix is distributed in the hope that it will be useful, but
	14	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	15	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	16	;;; GNU General Public License for more details.
	17	;;;
	18	;;; You should have received a copy of the GNU General Public License
	19	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	20
	21	(define-module (guix scripts refresh)
	22	#:use-module (guix ui)
72626a71	23	#:use-module (guix hash)
88981dd3	24	#:use-module (guix scripts)
0fdd3bea LC	25	#:use-module (guix store)
	26	#:use-module (guix utils)
	27	#:use-module (guix packages)
0a7c5a09 LC	28	#:use-module (guix upstream)
0a7c5a09 LC	29	#:use-module ((guix gnu-maintenance) #:select (%gnu-updater))
a7aac936	30	#:use-module (guix import elpa)
f9230085	31	#:use-module (guix gnupg)
0fdd3bea	32	#:use-module (gnu packages)
bdb36958	33	#:use-module ((gnu packages commencement) #:select (%final-inputs))
0fdd3bea LC	34	#:use-module (ice-9 match)
0fdd3bea LC	35	#:use-module (ice-9 regex)
7d193ec3	36	#:use-module (ice-9 vlist)
65ea7111	37	#:use-module (ice-9 format)
0fdd3bea LC	38	#:use-module (srfi srfi-1)
	39	#:use-module (srfi srfi-11)
	40	#:use-module (srfi srfi-26)
	41	#:use-module (srfi srfi-37)
	42	#:use-module (rnrs io ports)
	43	#:export (guix-refresh))
	44
	45	\f
	46	;;;
	47	;;; Command-line options.
	48	;;;
	49
	50	(define %default-options
	51	;; Alist of default option values.
	52	'())
	53
	54	(define %options
	55	;; Specification of the command-line options.
313109e0	56	(list (option '(#\u "update") #f #f
0fdd3bea	57	(lambda (opt name arg result)
313109e0	58	(alist-cons 'update? #t result)))
37a53402 LC	59	(option '(#\s "select") #t #f
	60	(lambda (opt name arg result)
	61	(match arg
	62	((or "core" "non-core")
	63	(alist-cons 'select (string->symbol arg)
	64	result))
	65	(x
05b4226a	66	(leave (_ "~a: invalid selection; expected `core' or `non-core'~%")
37a53402	67	arg)))))
7d193ec3 EB	68	(option '(#\l "list-dependent") #f #f
	69	(lambda (opt name arg result)
	70	(alist-cons 'list-dependent? #t result)))
0fdd3bea	71
f9230085 LC	72	(option '("key-server") #t #f
	73	(lambda (opt name arg result)
	74	(alist-cons 'key-server arg result)))
	75	(option '("gpg") #t #f
	76	(lambda (opt name arg result)
	77	(alist-cons 'gpg-command arg result)))
392b5d8c NK	78	(option '("key-download") #t #f
	79	(lambda (opt name arg result)
	80	(match arg
	81	((or "interactive" "always" "never")
	82	(alist-cons 'key-download (string->symbol arg)
	83	result))
	84	(_
	85	(leave (_ "unsupported policy: ~a~%")
	86	arg)))))
f9230085	87
0fdd3bea LC	88	(option '(#\h "help") #f #f
	89	(lambda args
	90	(show-help)
	91	(exit 0)))
	92	(option '(#\V "version") #f #f
	93	(lambda args
	94	(show-version-and-exit "guix refresh")))))
	95
	96	(define (show-help)
	97	(display (_ "Usage: guix refresh [OPTION]... PACKAGE...
37a53402 LC	98	Update package definitions to match the latest upstream version.
	99
	100	When PACKAGE... is given, update only the specified packages. Otherwise
	101	update all the packages of the distribution, or the subset thereof
	102	specified with `--select'.\n"))
0fdd3bea	103	(display (_ "
313109e0	104	-u, --update update source files in place"))
37a53402 LC	105	(display (_ "
	106	-s, --select=SUBSET select all the packages in SUBSET, one of
	107	`core' or `non-core'"))
7d193ec3 EB	108	(display (_ "
	109	-l, --list-dependent list top-level dependent packages that would need to
	110	be rebuilt as a result of upgrading PACKAGE..."))
0fdd3bea	111	(newline)
f9230085 LC	112	(display (_ "
	113	--key-server=HOST use HOST as the OpenPGP key server"))
	114	(display (_ "
	115	--gpg=COMMAND use COMMAND as the GnuPG 2.x command"))
392b5d8c NK	116	(display (_ "
	117	--key-download=POLICY
	118	handle missing OpenPGP keys according to POLICY:
	119	'always', 'never', and 'interactive', which is also
	120	used when 'key-download' is not specified"))
f9230085	121	(newline)
0fdd3bea LC	122	(display (_ "
	123	-h, --help display this help and exit"))
	124	(display (_ "
	125	-V, --version display version information and exit"))
	126	(newline)
	127	(show-bug-report-information))
	128
0a7c5a09 LC	129	\f
	130	;;;
	131	;;; Updates.
	132	;;;
	133
	134	(define %updaters
a7aac936 LC	135	;; List of "updaters" used by default. They are consulted in this order.
	136	(list %gnu-updater
	137	%elpa-updater))
0a7c5a09	138
392b5d8c NK	139	(define* (update-package store package #:key (key-download 'interactive))
	140	"Update the source file that defines PACKAGE with the new version.
	141	KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
	142	values: 'interactive' (default), 'always', and 'never'."
f9230085 LC	143	(let-values (((version tarball)
	144	(catch #t
	145	(lambda ()
0a7c5a09 LC	146	(package-update store package %updaters
0a7c5a09 LC	147	#:key-download key-download))
f9230085 LC	148	(lambda _
	149	(values #f #f))))
	150	((loc)
0a7c5a09	151	(or (package-field-location package 'version)
f9230085 LC	152	(package-location package))))
	153	(when version
	154	(if (and=> tarball file-exists?)
	155	(begin
	156	(format (current-error-port)
	157	(_ "~a: ~a: updating from version ~a to version ~a...~%")
	158	(location->string loc)
	159	(package-name package)
	160	(package-version package) version)
	161	(let ((hash (call-with-input-file tarball
b0fad8a2	162	port-sha256)))
f9230085 LC	163	(update-package-source package version hash)))
f9230085 LC	164	(warning (_ "~a: version ~a could not be \
3d20ebd6	165	downloaded and authenticated; not updating~%")
f9230085 LC	166	(package-name package) version)))))
f9230085 LC	167
0fdd3bea LC	168	\f
	169	;;;
	170	;;; Entry point.
	171	;;;
	172
	173	(define (guix-refresh . args)
	174	(define (parse-options)
	175	;; Return the alist of option values.
a5975ced LC	176	(args-fold* args %options
	177	(lambda (opt name arg result)
	178	(leave (_ "~A: unrecognized option~%") name))
	179	(lambda (arg result)
	180	(alist-cons 'argument arg result))
	181	%default-options))
0fdd3bea	182
560d4787 LC	183	(define (keep-newest package lst)
	184	;; If a newer version of PACKAGE is already in LST, return LST; otherwise
	185	;; return LST minus the other version of PACKAGE in it, plus PACKAGE.
	186	(let ((name (package-name package)))
	187	(match (find (lambda (p)
	188	(string=? (package-name p) name))
	189	lst)
	190	((? package? other)
	191	(if (version>? (package-version other) (package-version package))
	192	lst
	193	(cons package (delq other lst))))
	194	(_
	195	(cons package lst)))))
	196
37a53402 LC	197	(define core-package?
	198	(let* ((input->package (match-lambda
	199	((name (? package? package) _ ...) package)
	200	(_ #f)))
	201	(final-inputs (map input->package %final-inputs))
	202	(core (append final-inputs
	203	(append-map (compose (cut filter-map input->package <>)
	204	package-transitive-inputs)
	205	final-inputs)))
	206	(names (delete-duplicates (map package-name core))))
	207	(lambda (package)
	208	"Return true if PACKAGE is likely a \"core package\"---i.e., one whose
	209	update would trigger a complete rebuild."
	210	;; Compare by name because packages in base.scm basically inherit
	211	;; other packages. So, even if those packages are not core packages
	212	;; themselves, updating them would also update those who inherit from
	213	;; them.
	214	;; XXX: Fails to catch MPFR/MPC, whose source is used as input.
	215	(member (package-name package) names))))
	216
7d193ec3 EB	217	(let* ((opts (parse-options))
	218	(update? (assoc-ref opts 'update?))
	219	(list-dependent? (assoc-ref opts 'list-dependent?))
	220	(key-download (assoc-ref opts 'key-download))
392b5d8c	221	(packages
4b9b3cbb LC	222	(match (filter-map (match-lambda
	223	(('argument . spec)
	224	;; Take either the specified version or the
	225	;; latest one.
	226	(specification->package spec))
392b5d8c	227	(_ #f))
4b9b3cbb	228	opts)
392b5d8c NK	229	(() ; default to all packages
	230	(let ((select? (match (assoc-ref opts 'select)
	231	('core core-package?)
	232	('non-core (negate core-package?))
	233	(_ (const #t)))))
392b5d8c NK	234	(fold-packages (lambda (package result)
392b5d8c NK	235	(if (select? package)
560d4787	236	(keep-newest package result)
392b5d8c NK	237	result))
	238	'())))
	239	(some ; user-specified packages
	240	some))))
37a53402	241	(with-error-handling
7d193ec3 EB	242	(cond
	243	(list-dependent?
	244	(let* ((rebuilds (map package-full-name
	245	(package-covering-dependents packages)))
	246	(total-dependents
	247	(length (package-transitive-dependents packages))))
	248	(if (= total-dependents 0)
	249	(format (current-output-port)
	250	(N_ "No dependents other than itself: ~{~a~}~%"
	251	"No dependents other than themselves: ~{~a~^ ~}~%"
	252	(length packages))
	253	(map package-full-name packages))
	254	(format (current-output-port)
	255	(N_ (N_ "A single dependent package: ~2*~{~a~}~%"
	256	"Building the following package would ensure ~d \
	257	dependent packages are rebuilt; ~*~{~a~^ ~}~%"
	258	total-dependents)
	259	"Building the following ~d packages would ensure ~d \
	260	dependent packages are rebuilt: ~{~a~^ ~}~%"
	261	(length rebuilds))
	262	(length rebuilds) total-dependents rebuilds))))
	263	(update?
	264	(let ((store (open-connection)))
	265	(parameterize ((%openpgp-key-server
	266	(or (assoc-ref opts 'key-server)
	267	(%openpgp-key-server)))
	268	(%gpg-command
	269	(or (assoc-ref opts 'gpg-command)
	270	(%gpg-command))))
	271	(for-each
	272	(cut update-package store <> #:key-download key-download)
	273	packages))))
	274	(else
	275	(for-each (lambda (package)
0a7c5a09 LC	276	(match (package-update-path package %updaters)
0a7c5a09 LC	277	((? upstream-source? source)
7d193ec3 EB	278	(let ((loc (or (package-field-location package 'version)
	279	(package-location package))))
	280	(format (current-error-port)
	281	(_ "~a: ~a would be upgraded from ~a to ~a~%")
	282	(location->string loc)
	283	(package-name package) (package-version package)
0a7c5a09 LC	284	(upstream-source-version source))))
0a7c5a09 LC	285	(#f #f)))
7d193ec3	286	packages))))))