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.
 
 
 
 
 
 

460 lines
18 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2010, 2011, 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
  4. ;;;
  5. ;;; This file is part of GNU Guix.
  6. ;;;
  7. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  8. ;;; under the terms of the GNU General Public License as published by
  9. ;;; the Free Software Foundation; either version 3 of the License, or (at
  10. ;;; your option) any later version.
  11. ;;;
  12. ;;; GNU Guix is distributed in the hope that it will be useful, but
  13. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. ;;; GNU General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  19. (define-module (guix gnu-maintenance)
  20. #:use-module (web uri)
  21. #:use-module (web client)
  22. #:use-module (web response)
  23. #:use-module (ice-9 regex)
  24. #:use-module (ice-9 match)
  25. #:use-module (srfi srfi-1)
  26. #:use-module (srfi srfi-11)
  27. #:use-module (srfi srfi-26)
  28. #:use-module (system foreign)
  29. #:use-module (guix http-client)
  30. #:use-module (guix ftp-client)
  31. #:use-module (guix ui)
  32. #:use-module (guix utils)
  33. #:use-module (guix records)
  34. #:use-module (guix packages)
  35. #:use-module ((guix download) #:select (download-to-store))
  36. #:use-module (guix gnupg)
  37. #:use-module (rnrs io ports)
  38. #:use-module (guix base32)
  39. #:use-module ((guix build utils)
  40. #:select (substitute))
  41. #:export (gnu-package-name
  42. gnu-package-mundane-name
  43. gnu-package-copyright-holder
  44. gnu-package-savannah
  45. gnu-package-fsd
  46. gnu-package-language
  47. gnu-package-logo
  48. gnu-package-doc-category
  49. gnu-package-doc-summary
  50. gnu-package-doc-description
  51. gnu-package-doc-urls
  52. gnu-package-download-url
  53. official-gnu-packages
  54. find-packages
  55. gnu-package?
  56. releases
  57. latest-release
  58. gnu-package-name->name+version
  59. package-update-path
  60. package-update
  61. update-package-source))
  62. ;;; Commentary:
  63. ;;;
  64. ;;; Code for dealing with the maintenance of GNU packages, such as
  65. ;;; auto-updates.
  66. ;;;
  67. ;;; Code:
  68. ;;;
  69. ;;; List of GNU packages.
  70. ;;;
  71. (define %gnumaint-base-url
  72. "http://cvs.savannah.gnu.org/viewvc/*checkout*/gnumaint/")
  73. (define %package-list-url
  74. (string->uri
  75. (string-append %gnumaint-base-url "gnupackages.txt?root=womb")))
  76. (define %package-description-url
  77. ;; This file contains package descriptions in recutils format.
  78. ;; See <https://lists.gnu.org/archive/html/guix-devel/2013-10/msg00071.html>.
  79. (string->uri
  80. (string-append %gnumaint-base-url "pkgblurbs.txt?root=womb")))
  81. (define-record-type* <gnu-package-descriptor>
  82. gnu-package-descriptor
  83. make-gnu-package-descriptor
  84. gnu-package-descriptor?
  85. (name gnu-package-name)
  86. (mundane-name gnu-package-mundane-name)
  87. (copyright-holder gnu-package-copyright-holder)
  88. (savannah gnu-package-savannah)
  89. (fsd gnu-package-fsd)
  90. (language gnu-package-language) ; list of strings
  91. (logo gnu-package-logo)
  92. (doc-category gnu-package-doc-category)
  93. (doc-summary gnu-package-doc-summary)
  94. (doc-description gnu-package-doc-description) ; taken from 'pkgdescr.txt'
  95. (doc-urls gnu-package-doc-urls) ; list of strings
  96. (download-url gnu-package-download-url))
  97. (define (official-gnu-packages)
  98. "Return a list of records, which are GNU packages."
  99. (define (read-records port)
  100. ;; Return a list of alists. Each alist contains fields of a GNU
  101. ;; package.
  102. (let loop ((alist (recutils->alist port))
  103. (result '()))
  104. (if (null? alist)
  105. (reverse result)
  106. (loop (recutils->alist port)
  107. (cons alist result)))))
  108. (define official-description
  109. (let ((db (read-records (http-fetch %package-description-url
  110. #:text? #t))))
  111. (lambda (name)
  112. ;; Return the description found upstream for package NAME, or #f.
  113. (and=> (find (lambda (alist)
  114. (equal? name (assoc-ref alist "package")))
  115. db)
  116. (lambda (record)
  117. (let ((field (assoc-ref record "blurb")))
  118. ;; The upstream description file uses "redirect PACKAGE" as
  119. ;; a blurb in cases where the description of the two
  120. ;; packages should be considered the same (e.g., GTK+ has
  121. ;; "redirect gnome".) This is usually not acceptable for
  122. ;; us because we prefer to have distinct descriptions in
  123. ;; such cases. Thus, ignore the 'blurb' field when that
  124. ;; happens.
  125. (and field
  126. (not (string-prefix? "redirect " field))
  127. field)))))))
  128. (map (lambda (alist)
  129. (let ((name (assoc-ref alist "package")))
  130. (alist->record `(("description" . ,(official-description name))
  131. ,@alist)
  132. make-gnu-package-descriptor
  133. (list "package" "mundane-name" "copyright-holder"
  134. "savannah" "fsd" "language" "logo"
  135. "doc-category" "doc-summary" "description"
  136. "doc-url"
  137. "download-url")
  138. '("doc-url" "language"))))
  139. (read-records (http-fetch %package-list-url #:text? #t))))
  140. (define (find-packages regexp)
  141. "Find GNU packages which satisfy REGEXP."
  142. (let ((name-rx (make-regexp regexp)))
  143. (filter (lambda (package)
  144. (false-if-exception
  145. (regexp-exec name-rx (gnu-package-name package))))
  146. (official-gnu-packages))))
  147. (define gnu-package?
  148. (memoize
  149. (let ((official-gnu-packages (memoize official-gnu-packages)))
  150. (lambda (package)
  151. "Return true if PACKAGE is a GNU package. This procedure may access the
  152. network to check in GNU's database."
  153. (define (mirror-type url)
  154. (let ((uri (string->uri url)))
  155. (and (eq? (uri-scheme uri) 'mirror)
  156. (if (member (uri-host uri) '("gnu" "gnupg" "gcc"))
  157. 'gnu
  158. 'non-gnu))))
  159. (let ((url (and=> (package-source package) origin-uri))
  160. (name (package-name package)))
  161. (case (and (string? url) (mirror-type url))
  162. ((gnu) #t)
  163. ((non-gnu) #f)
  164. (else
  165. ;; Last resort: resort to the network.
  166. (and (member name (map gnu-package-name (official-gnu-packages)))
  167. #t))))))))
  168. ;;;
  169. ;;; Latest release.
  170. ;;;
  171. (define (ftp-server/directory project)
  172. "Return the FTP server and directory where PROJECT's tarball are
  173. stored."
  174. (define quirks
  175. '(("commoncpp2" "ftp.gnu.org" "/gnu/commoncpp")
  176. ("ucommon" "ftp.gnu.org" "/gnu/commoncpp")
  177. ("libzrtpcpp" "ftp.gnu.org" "/gnu/ccrtp")
  178. ("libosip2" "ftp.gnu.org" "/gnu/osip")
  179. ("libgcrypt" "ftp.gnupg.org" "/gcrypt/libgcrypt")
  180. ("libgpg-error" "ftp.gnupg.org" "/gcrypt/libgpg-error")
  181. ("libassuan" "ftp.gnupg.org" "/gcrypt/libassuan")
  182. ("gnupg" "ftp.gnupg.org" "/gcrypt/gnupg")
  183. ("freefont-ttf" "ftp.gnu.org" "/gnu/freefont")
  184. ("gnu-ghostscript" "ftp.gnu.org" "/gnu/ghostscript")
  185. ("mit-scheme" "ftp.gnu.org" "/gnu/mit-scheme/stable.pkg")
  186. ("icecat" "ftp.gnu.org" "/gnu/gnuzilla")
  187. ("source-highlight" "ftp.gnu.org" "/gnu/src-highlite")
  188. ("glib" "ftp.gnome.org" "/pub/gnome/sources/glib")
  189. ("gnutls" "ftp.gnutls.org" "/gcrypt/gnutls")
  190. ("TeXmacs" "ftp.texmacs.org" "/TeXmacs/targz")))
  191. (match (assoc project quirks)
  192. ((_ server directory)
  193. (values server directory))
  194. (_
  195. (values "ftp.gnu.org" (string-append "/gnu/" project)))))
  196. (define (sans-extension tarball)
  197. "Return TARBALL without its .tar.* extension."
  198. (let ((end (string-contains tarball ".tar")))
  199. (substring tarball 0 end)))
  200. (define %tarball-rx
  201. (make-regexp "^(.+)-([0-9]|[^-])*(-src)?\\.tar\\."))
  202. (define %alpha-tarball-rx
  203. (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
  204. (define (release-file project file)
  205. "Return #f if FILE is not a release tarball of PROJECT, otherwise return
  206. PACKAGE-VERSION."
  207. (and (not (string-suffix? ".sig" file))
  208. (and=> (regexp-exec %tarball-rx file)
  209. (lambda (match)
  210. ;; Filter out unrelated files, like `guile-www-1.1.1'.
  211. (equal? project (match:substring match 1))))
  212. (not (regexp-exec %alpha-tarball-rx file))
  213. (let ((s (sans-extension file)))
  214. (and (regexp-exec %package-name-rx s) s))))
  215. (define (releases project)
  216. "Return the list of releases of PROJECT as a list of release name/directory
  217. pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). "
  218. ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
  219. (let-values (((server directory) (ftp-server/directory project)))
  220. (define conn (ftp-open server))
  221. (let loop ((directories (list directory))
  222. (result '()))
  223. (match directories
  224. (()
  225. (ftp-close conn)
  226. result)
  227. ((directory rest ...)
  228. (let* ((files (ftp-list conn directory))
  229. (subdirs (filter-map (match-lambda
  230. ((name 'directory . _) name)
  231. (_ #f))
  232. files)))
  233. (loop (append (map (cut string-append directory "/" <>)
  234. subdirs)
  235. rest)
  236. (append
  237. ;; Filter out signatures, deltas, and files which
  238. ;; are potentially not releases of PROJECT--e.g.,
  239. ;; in /gnu/guile, filter out guile-oops and
  240. ;; guile-www; in mit-scheme, filter out binaries.
  241. (filter-map (match-lambda
  242. ((file 'file . _)
  243. (and=> (release-file project file)
  244. (cut cons <> directory)))
  245. (_ #f))
  246. files)
  247. result))))))))
  248. (define* (latest-release project
  249. #:key (ftp-open ftp-open) (ftp-close ftp-close))
  250. "Return (\"FOO-X.Y\" . \"/bar/foo\") or #f. Use FTP-OPEN and FTP-CLOSE to
  251. open (resp. close) FTP connections; this can be useful to reuse connections."
  252. (define (latest a b)
  253. (if (version>? a b) a b))
  254. (define contains-digit?
  255. (cut string-any char-set:digit <>))
  256. (define patch-directory-name?
  257. ;; Return #t for patch directory names such as 'bash-4.2-patches'.
  258. (cut string-suffix? "patches" <>))
  259. (let-values (((server directory) (ftp-server/directory project)))
  260. (define conn (ftp-open server))
  261. (let loop ((directory directory))
  262. (let* ((entries (ftp-list conn directory))
  263. ;; Filter out sub-directories that do not contain digits---e.g.,
  264. ;; /gnuzilla/lang and /gnupg/patches.
  265. (subdirs (filter-map (match-lambda
  266. (((? patch-directory-name? dir)
  267. 'directory . _)
  268. #f)
  269. (((? contains-digit? dir) 'directory . _)
  270. dir)
  271. (_ #f))
  272. entries)))
  273. (match subdirs
  274. (()
  275. ;; No sub-directories, so assume that tarballs are here.
  276. (let ((files (filter-map (match-lambda
  277. ((file 'file . _)
  278. (release-file project file))
  279. (_ #f))
  280. entries)))
  281. (ftp-close conn)
  282. (and=> (reduce latest #f files)
  283. (cut cons <> directory))))
  284. ((subdirs ...)
  285. ;; Assume that SUBDIRS correspond to versions, and jump into the
  286. ;; one with the highest version number.
  287. (let ((target (reduce latest #f subdirs)))
  288. (if target
  289. (loop (string-append directory "/" target))
  290. (begin
  291. (ftp-close conn)
  292. #f)))))))))
  293. (define %package-name-rx
  294. ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses
  295. ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed.
  296. (make-regexp "^(.*)-(([0-9]|\\.)+)(-src)?"))
  297. (define (gnu-package-name->name+version name+version)
  298. "Return the package name and version number extracted from NAME+VERSION."
  299. (let ((match (regexp-exec %package-name-rx name+version)))
  300. (if (not match)
  301. (values name+version #f)
  302. (values (match:substring match 1) (match:substring match 2)))))
  303. ;;;
  304. ;;; Auto-update.
  305. ;;;
  306. (define (package-update-path package)
  307. "Return an update path for PACKAGE, or #f if no update is needed."
  308. (and (gnu-package? package)
  309. (match (latest-release (package-name package))
  310. ((name+version . directory)
  311. (let-values (((_ new-version)
  312. (package-name->name+version name+version)))
  313. (and (version>? name+version (package-full-name package))
  314. `(,new-version . ,directory))))
  315. (_ #f))))
  316. (define* (download-tarball store project directory version
  317. #:key (archive-type "gz")
  318. (key-download 'interactive))
  319. "Download PROJECT's tarball over FTP and check its OpenPGP signature. On
  320. success, return the tarball file name. KEY-DOWNLOAD specifies a download
  321. policy for missing OpenPGP keys; allowed values: 'interactive' (default),
  322. 'always', and 'never'."
  323. (let* ((server (ftp-server/directory project))
  324. (base (string-append project "-" version ".tar." archive-type))
  325. (url (string-append "ftp://" server "/" directory "/" base))
  326. (sig-url (string-append url ".sig"))
  327. (tarball (download-to-store store url))
  328. (sig (download-to-store store sig-url)))
  329. (let ((ret (gnupg-verify* sig tarball #:key-download key-download)))
  330. (if ret
  331. tarball
  332. (begin
  333. (warning (_ "signature verification failed for `~a'~%")
  334. base)
  335. (warning (_ "(could be because the public key is not in your keyring)~%"))
  336. #f)))))
  337. (define* (package-update store package #:key (key-download 'interactive))
  338. "Return the new version and the file name of the new version tarball for
  339. PACKAGE, or #f and #f when PACKAGE is up-to-date. KEY-DOWNLOAD specifies a
  340. download policy for missing OpenPGP keys; allowed values: 'always', 'never',
  341. and 'interactive' (default)."
  342. (match (package-update-path package)
  343. ((version . directory)
  344. (let-values (((name)
  345. (package-name package))
  346. ((archive-type)
  347. (let ((source (package-source package)))
  348. (or (and (origin? source)
  349. (file-extension (origin-uri source)))
  350. "gz"))))
  351. (let ((tarball (download-tarball store name directory version
  352. #:archive-type archive-type
  353. #:key-download key-download)))
  354. (values version tarball))))
  355. (_
  356. (values #f #f))))
  357. (define (update-package-source package version hash)
  358. "Modify the source file that defines PACKAGE to refer to VERSION,
  359. whose tarball has SHA256 HASH (a bytevector). Return the new version string
  360. if an update was made, and #f otherwise."
  361. (define (new-line line matches replacement)
  362. ;; Iterate over MATCHES and return the modified line based on LINE.
  363. ;; Replace each match with REPLACEMENT.
  364. (let loop ((m* matches) ; matches
  365. (o 0) ; offset in L
  366. (r '())) ; result
  367. (match m*
  368. (()
  369. (let ((r (cons (substring line o) r)))
  370. (string-concatenate-reverse r)))
  371. ((m . rest)
  372. (loop rest
  373. (match:end m)
  374. (cons* replacement
  375. (substring line o (match:start m))
  376. r))))))
  377. (define (update-source file old-version version
  378. old-hash hash)
  379. ;; Update source file FILE, replacing occurrences OLD-VERSION by VERSION
  380. ;; and occurrences of OLD-HASH by HASH (base32 representation thereof).
  381. ;; TODO: Currently this is a bit of a sledgehammer: if VERSION occurs in
  382. ;; different unrelated places, we may modify it more than needed, for
  383. ;; instance. We should try to make changes only within the sexp that
  384. ;; corresponds to the definition of PACKAGE.
  385. (let ((old-hash (bytevector->nix-base32-string old-hash))
  386. (hash (bytevector->nix-base32-string hash)))
  387. (substitute file
  388. `((,(regexp-quote old-version)
  389. . ,(cut new-line <> <> version))
  390. (,(regexp-quote old-hash)
  391. . ,(cut new-line <> <> hash))))
  392. version))
  393. (let ((name (package-name package))
  394. (loc (package-field-location package 'version)))
  395. (if loc
  396. (let ((old-version (package-version package))
  397. (old-hash (origin-sha256 (package-source package)))
  398. (file (and=> (location-file loc)
  399. (cut search-path %load-path <>))))
  400. (if file
  401. (update-source file
  402. old-version version
  403. old-hash hash)
  404. (begin
  405. (warning (_ "~a: could not locate source file")
  406. (location-file loc))
  407. #f)))
  408. (begin
  409. (format (current-error-port)
  410. (_ "~a: ~a: no `version' field in source; skipping~%")
  411. (location->string (package-location package))
  412. name)))))
  413. ;;; gnu-maintenance.scm ends here