You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

278 lines
12 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
  4. ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
  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. (define-module (guix scripts refresh)
  21. #:use-module (guix ui)
  22. #:use-module (guix hash)
  23. #:use-module (guix store)
  24. #:use-module (guix utils)
  25. #:use-module (guix packages)
  26. #:use-module (guix gnu-maintenance)
  27. #:use-module (guix gnupg)
  28. #:use-module (gnu packages)
  29. #:use-module ((gnu packages commencement) #:select (%final-inputs))
  30. #:use-module (ice-9 match)
  31. #:use-module (ice-9 regex)
  32. #:use-module (ice-9 vlist)
  33. #:use-module (ice-9 format)
  34. #:use-module (srfi srfi-1)
  35. #:use-module (srfi srfi-11)
  36. #:use-module (srfi srfi-26)
  37. #:use-module (srfi srfi-37)
  38. #:use-module (rnrs io ports)
  39. #:export (guix-refresh))
  40. ;;;
  41. ;;; Command-line options.
  42. ;;;
  43. (define %default-options
  44. ;; Alist of default option values.
  45. '())
  46. (define %options
  47. ;; Specification of the command-line options.
  48. (list (option '(#\u "update") #f #f
  49. (lambda (opt name arg result)
  50. (alist-cons 'update? #t result)))
  51. (option '(#\s "select") #t #f
  52. (lambda (opt name arg result)
  53. (match arg
  54. ((or "core" "non-core")
  55. (alist-cons 'select (string->symbol arg)
  56. result))
  57. (x
  58. (leave (_ "~a: invalid selection; expected `core' or `non-core'")
  59. arg)))))
  60. (option '(#\l "list-dependent") #f #f
  61. (lambda (opt name arg result)
  62. (alist-cons 'list-dependent? #t result)))
  63. (option '("key-server") #t #f
  64. (lambda (opt name arg result)
  65. (alist-cons 'key-server arg result)))
  66. (option '("gpg") #t #f
  67. (lambda (opt name arg result)
  68. (alist-cons 'gpg-command arg result)))
  69. (option '("key-download") #t #f
  70. (lambda (opt name arg result)
  71. (match arg
  72. ((or "interactive" "always" "never")
  73. (alist-cons 'key-download (string->symbol arg)
  74. result))
  75. (_
  76. (leave (_ "unsupported policy: ~a~%")
  77. arg)))))
  78. (option '(#\h "help") #f #f
  79. (lambda args
  80. (show-help)
  81. (exit 0)))
  82. (option '(#\V "version") #f #f
  83. (lambda args
  84. (show-version-and-exit "guix refresh")))))
  85. (define (show-help)
  86. (display (_ "Usage: guix refresh [OPTION]... PACKAGE...
  87. Update package definitions to match the latest upstream version.
  88. When PACKAGE... is given, update only the specified packages. Otherwise
  89. update all the packages of the distribution, or the subset thereof
  90. specified with `--select'.\n"))
  91. (display (_ "
  92. -u, --update update source files in place"))
  93. (display (_ "
  94. -s, --select=SUBSET select all the packages in SUBSET, one of
  95. `core' or `non-core'"))
  96. (display (_ "
  97. -l, --list-dependent list top-level dependent packages that would need to
  98. be rebuilt as a result of upgrading PACKAGE..."))
  99. (newline)
  100. (display (_ "
  101. --key-server=HOST use HOST as the OpenPGP key server"))
  102. (display (_ "
  103. --gpg=COMMAND use COMMAND as the GnuPG 2.x command"))
  104. (display (_ "
  105. --key-download=POLICY
  106. handle missing OpenPGP keys according to POLICY:
  107. 'always', 'never', and 'interactive', which is also
  108. used when 'key-download' is not specified"))
  109. (newline)
  110. (display (_ "
  111. -h, --help display this help and exit"))
  112. (display (_ "
  113. -V, --version display version information and exit"))
  114. (newline)
  115. (show-bug-report-information))
  116. (define* (update-package store package #:key (key-download 'interactive))
  117. "Update the source file that defines PACKAGE with the new version.
  118. KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
  119. values: 'interactive' (default), 'always', and 'never'."
  120. (let-values (((version tarball)
  121. (catch #t
  122. (lambda ()
  123. (package-update store package #:key-download key-download))
  124. (lambda _
  125. (values #f #f))))
  126. ((loc)
  127. (or (package-field-location package
  128. 'version)
  129. (package-location package))))
  130. (when version
  131. (if (and=> tarball file-exists?)
  132. (begin
  133. (format (current-error-port)
  134. (_ "~a: ~a: updating from version ~a to version ~a...~%")
  135. (location->string loc)
  136. (package-name package)
  137. (package-version package) version)
  138. (let ((hash (call-with-input-file tarball
  139. port-sha256)))
  140. (update-package-source package version hash)))
  141. (warning (_ "~a: version ~a could not be \
  142. downloaded and authenticated; not updating")
  143. (package-name package) version)))))
  144. ;;;
  145. ;;; Entry point.
  146. ;;;
  147. (define (guix-refresh . args)
  148. (define (parse-options)
  149. ;; Return the alist of option values.
  150. (args-fold* args %options
  151. (lambda (opt name arg result)
  152. (leave (_ "~A: unrecognized option~%") name))
  153. (lambda (arg result)
  154. (alist-cons 'argument arg result))
  155. %default-options))
  156. (define (keep-newest package lst)
  157. ;; If a newer version of PACKAGE is already in LST, return LST; otherwise
  158. ;; return LST minus the other version of PACKAGE in it, plus PACKAGE.
  159. (let ((name (package-name package)))
  160. (match (find (lambda (p)
  161. (string=? (package-name p) name))
  162. lst)
  163. ((? package? other)
  164. (if (version>? (package-version other) (package-version package))
  165. lst
  166. (cons package (delq other lst))))
  167. (_
  168. (cons package lst)))))
  169. (define core-package?
  170. (let* ((input->package (match-lambda
  171. ((name (? package? package) _ ...) package)
  172. (_ #f)))
  173. (final-inputs (map input->package %final-inputs))
  174. (core (append final-inputs
  175. (append-map (compose (cut filter-map input->package <>)
  176. package-transitive-inputs)
  177. final-inputs)))
  178. (names (delete-duplicates (map package-name core))))
  179. (lambda (package)
  180. "Return true if PACKAGE is likely a \"core package\"---i.e., one whose
  181. update would trigger a complete rebuild."
  182. ;; Compare by name because packages in base.scm basically inherit
  183. ;; other packages. So, even if those packages are not core packages
  184. ;; themselves, updating them would also update those who inherit from
  185. ;; them.
  186. ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input.
  187. (member (package-name package) names))))
  188. (let* ((opts (parse-options))
  189. (update? (assoc-ref opts 'update?))
  190. (list-dependent? (assoc-ref opts 'list-dependent?))
  191. (key-download (assoc-ref opts 'key-download))
  192. (packages
  193. (match (concatenate
  194. (filter-map (match-lambda
  195. (('argument . value)
  196. (let ((p (find-packages-by-name value)))
  197. (when (null? p)
  198. (leave (_ "~a: no package by that name~%")
  199. value))
  200. p))
  201. (_ #f))
  202. opts))
  203. (() ; default to all packages
  204. (let ((select? (match (assoc-ref opts 'select)
  205. ('core core-package?)
  206. ('non-core (negate core-package?))
  207. (_ (const #t)))))
  208. (fold-packages (lambda (package result)
  209. (if (select? package)
  210. (keep-newest package result)
  211. result))
  212. '())))
  213. (some ; user-specified packages
  214. some))))
  215. (with-error-handling
  216. (cond
  217. (list-dependent?
  218. (let* ((rebuilds (map package-full-name
  219. (package-covering-dependents packages)))
  220. (total-dependents
  221. (length (package-transitive-dependents packages))))
  222. (if (= total-dependents 0)
  223. (format (current-output-port)
  224. (N_ "No dependents other than itself: ~{~a~}~%"
  225. "No dependents other than themselves: ~{~a~^ ~}~%"
  226. (length packages))
  227. (map package-full-name packages))
  228. (format (current-output-port)
  229. (N_ (N_ "A single dependent package: ~2*~{~a~}~%"
  230. "Building the following package would ensure ~d \
  231. dependent packages are rebuilt; ~*~{~a~^ ~}~%"
  232. total-dependents)
  233. "Building the following ~d packages would ensure ~d \
  234. dependent packages are rebuilt: ~{~a~^ ~}~%"
  235. (length rebuilds))
  236. (length rebuilds) total-dependents rebuilds))))
  237. (update?
  238. (let ((store (open-connection)))
  239. (parameterize ((%openpgp-key-server
  240. (or (assoc-ref opts 'key-server)
  241. (%openpgp-key-server)))
  242. (%gpg-command
  243. (or (assoc-ref opts 'gpg-command)
  244. (%gpg-command))))
  245. (for-each
  246. (cut update-package store <> #:key-download key-download)
  247. packages))))
  248. (else
  249. (for-each (lambda (package)
  250. (match (false-if-exception (package-update-path package))
  251. ((new-version . directory)
  252. (let ((loc (or (package-field-location package 'version)
  253. (package-location package))))
  254. (format (current-error-port)
  255. (_ "~a: ~a would be upgraded from ~a to ~a~%")
  256. (location->string loc)
  257. (package-name package) (package-version package)
  258. new-version)))
  259. (_ #f)))
  260. packages))))))