gnu-maintenance.scm 43 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2010-2023 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
  4. ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
  5. ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
  6. ;;; Copyright © 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
  7. ;;;
  8. ;;; This file is part of GNU Guix.
  9. ;;;
  10. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  11. ;;; under the terms of the GNU General Public License as published by
  12. ;;; the Free Software Foundation; either version 3 of the License, or (at
  13. ;;; your option) any later version.
  14. ;;;
  15. ;;; GNU Guix is distributed in the hope that it will be useful, but
  16. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  18. ;;; GNU General Public License for more details.
  19. ;;;
  20. ;;; You should have received a copy of the GNU General Public License
  21. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  22. (define-module (guix gnu-maintenance)
  23. #:use-module (web uri)
  24. #:use-module (web client)
  25. #:use-module (web response)
  26. #:use-module (ice-9 regex)
  27. #:use-module (ice-9 match)
  28. #:use-module (srfi srfi-1)
  29. #:use-module (srfi srfi-2)
  30. #:use-module (srfi srfi-11)
  31. #:use-module (srfi srfi-26)
  32. #:use-module (rnrs io ports)
  33. #:use-module ((guix http-client) #:hide (open-socket-for-uri))
  34. ;; not required in many cases, so autoloaded to reduce start-up costs.
  35. #:autoload (guix download) (%mirrors)
  36. #:use-module (guix ftp-client)
  37. #:use-module (guix utils)
  38. #:use-module (guix diagnostics)
  39. #:use-module (guix i18n)
  40. #:use-module (guix memoization)
  41. #:use-module (guix records)
  42. #:use-module (guix upstream)
  43. #:use-module (guix packages)
  44. #:autoload (guix import utils) (false-if-networking-error)
  45. #:autoload (zlib) (call-with-gzip-input-port)
  46. #:autoload (htmlprag) (html->sxml) ;from Guile-Lib
  47. #:export (gnu-package-name
  48. gnu-package-mundane-name
  49. gnu-package-copyright-holder
  50. gnu-package-savannah
  51. gnu-package-fsd
  52. gnu-package-language
  53. gnu-package-logo
  54. gnu-package-doc-category
  55. gnu-package-doc-summary
  56. gnu-package-doc-description
  57. gnu-package-doc-urls
  58. gnu-package-download-url
  59. official-gnu-packages
  60. find-package
  61. gnu-package?
  62. uri-mirror-rewrite
  63. rewrite-url
  64. release-file?
  65. releases
  66. import-release
  67. gnu-release-archive-types
  68. gnu-package-name->name+version
  69. %gnu-updater
  70. %gnu-ftp-updater
  71. %savannah-updater
  72. %sourceforge-updater
  73. %xorg-updater
  74. %kernel.org-updater
  75. %generic-html-updater))
  76. ;;; Commentary:
  77. ;;;
  78. ;;; Code for dealing with the maintenance of GNU packages, such as
  79. ;;; auto-updates.
  80. ;;;
  81. ;;; Code:
  82. ;;;
  83. ;;; List of GNU packages.
  84. ;;;
  85. (define %gnumaint-base-url
  86. "https://web.cvs.savannah.gnu.org/viewvc/*checkout*/www/www/prep/gnumaint/")
  87. (define %package-list-url
  88. (string->uri
  89. (string-append %gnumaint-base-url "rec/gnupackages.rec")))
  90. (define %package-description-url
  91. ;; This file contains package descriptions in recutils format.
  92. ;; See <https://lists.gnu.org/archive/html/guix-devel/2013-10/msg00071.html>
  93. ;; and <https://lists.gnu.org/archive/html/guix-devel/2018-06/msg00362.html>.
  94. (string->uri
  95. (string-append %gnumaint-base-url "rec/pkgblurbs.rec")))
  96. (define-record-type* <gnu-package-descriptor>
  97. gnu-package-descriptor
  98. make-gnu-package-descriptor
  99. gnu-package-descriptor?
  100. (name gnu-package-name)
  101. (mundane-name gnu-package-mundane-name)
  102. (copyright-holder gnu-package-copyright-holder)
  103. (savannah gnu-package-savannah)
  104. (fsd gnu-package-fsd)
  105. (language gnu-package-language) ; list of strings
  106. (logo gnu-package-logo)
  107. (doc-category gnu-package-doc-category)
  108. (doc-summary gnu-package-doc-summary)
  109. (doc-description gnu-package-doc-description) ; taken from 'pkgdescr.txt'
  110. (doc-urls gnu-package-doc-urls) ; list of strings
  111. (download-url gnu-package-download-url))
  112. (define* (official-gnu-packages
  113. #:optional (fetch http-fetch/cached))
  114. "Return a list of records, which are GNU packages. Use FETCH,
  115. to fetch the list of GNU packages over HTTP."
  116. (define (read-records port)
  117. ;; Return a list of alists. Each alist contains fields of a GNU
  118. ;; package.
  119. (let loop ((alist (recutils->alist port))
  120. (result '()))
  121. (if (null? alist)
  122. (reverse result)
  123. (loop (recutils->alist port)
  124. ;; Ignore things like "%rec" (info "(recutils) Record
  125. ;; Descriptors").
  126. (if (assoc-ref alist "package")
  127. (cons alist result)
  128. result)))))
  129. (define official-description
  130. (let ((db (read-records (fetch %package-description-url #:text? #t))))
  131. (lambda (name)
  132. ;; Return the description found upstream for package NAME, or #f.
  133. (and=> (find (lambda (alist)
  134. (equal? name (assoc-ref alist "package")))
  135. db)
  136. (lambda (record)
  137. (let ((field (assoc-ref record "blurb")))
  138. ;; The upstream description file uses "redirect PACKAGE" as
  139. ;; a blurb in cases where the description of the two
  140. ;; packages should be considered the same (e.g., GTK+ has
  141. ;; "redirect gnome".) This is usually not acceptable for
  142. ;; us because we prefer to have distinct descriptions in
  143. ;; such cases. Thus, ignore the 'blurb' field when that
  144. ;; happens.
  145. (and field
  146. (not (string-prefix? "redirect " field))
  147. field)))))))
  148. (map (lambda (alist)
  149. (let ((name (assoc-ref alist "package")))
  150. (alist->record `(("description" . ,(official-description name))
  151. ,@alist)
  152. make-gnu-package-descriptor
  153. (list "package" "mundane_name" "copyright_holder"
  154. "savannah" "fsd" "language" "logo"
  155. "doc_category" "doc_summary" "description"
  156. "doc_url"
  157. "download_url")
  158. '("doc_url" "language"))))
  159. (let* ((port (fetch %package-list-url #:text? #t))
  160. (lst (read-records port)))
  161. (close-port port)
  162. lst)))
  163. (define (find-package name)
  164. "Find GNU package called NAME and return it. Return #f if it was not
  165. found."
  166. (find (lambda (package)
  167. (string=? name (gnu-package-name package)))
  168. (official-gnu-packages)))
  169. (define gnu-package?
  170. (let ((official-gnu-packages (memoize official-gnu-packages)))
  171. (mlambdaq (package)
  172. "Return true if PACKAGE is a GNU package. This procedure may access the
  173. network to check in GNU's database."
  174. (define (mirror-type url)
  175. (let ((uri (string->uri url)))
  176. (and (eq? (uri-scheme uri) 'mirror)
  177. (cond
  178. ((member (uri-host uri)
  179. '("gnu" "gnupg" "gcc" "gnome"))
  180. ;; Definitely GNU.
  181. 'gnu)
  182. ((equal? (uri-host uri) "cran")
  183. ;; Possibly GNU: mirror://cran could be either GNU R itself
  184. ;; or a non-GNU package.
  185. #f)
  186. (else
  187. ;; Definitely non-GNU.
  188. 'non-gnu)))))
  189. (define (gnu-home-page? package)
  190. (letrec-syntax ((>> (syntax-rules ()
  191. ((_ value proc)
  192. (and=> value proc))
  193. ((_ value proc rest ...)
  194. (and=> value
  195. (lambda (next)
  196. (>> (proc next) rest ...)))))))
  197. (>> package package-home-page
  198. string->uri uri-host
  199. (lambda (host)
  200. (member host '("www.gnu.org" "gnu.org"))))))
  201. (or (gnu-home-page? package)
  202. (match (package-source package)
  203. ((? origin? origin)
  204. (let ((url (origin-uri origin))
  205. (name (package-upstream-name package)))
  206. (case (and (string? url) (mirror-type url))
  207. ((gnu) #t)
  208. ((non-gnu) #f)
  209. (else
  210. (and (member name (map gnu-package-name (official-gnu-packages)))
  211. #t)))))
  212. (_ #f))))))
  213. ;;;
  214. ;;; Latest FTP release.
  215. ;;;
  216. (define (ftp-server/directory package)
  217. "Return the FTP server and directory where PACKAGE's tarball are stored."
  218. (let ((name (package-upstream-name package)))
  219. (values (or (assoc-ref (package-properties package) 'ftp-server)
  220. "ftp.gnu.org")
  221. (or (assoc-ref (package-properties package) 'ftp-directory)
  222. (string-append "/gnu/" name)))))
  223. (define %tarball-rx
  224. ;; The .zip extensions is notably used for freefont-ttf.
  225. ;; The "-src" pattern is for "TeXmacs-1.0.7.9-src.tar.gz".
  226. ;; The "-gnu[0-9]" pattern is for "icecat-38.4.0-gnu1.tar.bz2".
  227. ;; Accept underscores as in "PKG_1.2.tar.gz" for some non-GNU packages.
  228. ;; Accept 'v' or 'V' prefix as in 'PKG-v2.3.tgz'.
  229. (make-regexp "^([^.]+)[-_][vV]?([0-9]|[^-])+(-(src|[sS]ource|gnu[0-9]))?\\.(tar\\.|tgz|zip$)"))
  230. (define %alpha-tarball-rx
  231. (make-regexp "^.*-.*[0-9](-|~|\\.)?(alpha|beta|rc|RC|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
  232. (define (release-file? project file)
  233. "Return true if FILE is a release tarball of PROJECT."
  234. (and (not (member (file-extension file)
  235. '("sig" "sign" "asc"
  236. "md5sum" "sha1sum" "sha256sum")))
  237. (and=> (regexp-exec %tarball-rx file)
  238. (lambda (match)
  239. ;; Filter out unrelated files, like `guile-www-1.1.1'.
  240. ;; Case-insensitive for things like "TeXmacs" vs. "texmacs".
  241. ;; The "-src" suffix is for "freefont-src-20120503.tar.gz".
  242. ;; The '-everywhere-src' suffix is for Qt modular components.
  243. (and=> (match:substring match 1)
  244. (lambda (name)
  245. (or (string-ci=? name project)
  246. (string-ci=? name (string-append project "-src"))
  247. (string-ci=?
  248. name (string-append project "-everywhere-src"))
  249. ;; For older Qt releases such as version 5.
  250. (string-ci=?
  251. name (string-append
  252. project "-everywhere-opensource-src"))
  253. ;; For Qt Creator.
  254. (string-ci=?
  255. name (string-append
  256. project "-opensource-src")))))))
  257. (not (regexp-exec %alpha-tarball-rx file))
  258. (let ((s (tarball-sans-extension file)))
  259. (regexp-exec %package-name-rx s))))
  260. (define (tarball->version tarball)
  261. "Return the version TARBALL corresponds to. TARBALL is a file name like
  262. \"coreutils-8.23.tar.xz\"."
  263. (let-values (((name version)
  264. (gnu-package-name->name+version
  265. (tarball-sans-extension tarball))))
  266. version))
  267. (define* (releases project
  268. #:key
  269. (server "ftp.gnu.org")
  270. (directory (string-append "/gnu/" project)))
  271. "Return the list of <upstream-release> of PROJECT as a list of release
  272. name/directory pairs."
  273. ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
  274. (define conn (ftp-open server))
  275. (let loop ((directories (list directory))
  276. (result '()))
  277. (match directories
  278. (()
  279. (ftp-close conn)
  280. (coalesce-sources result))
  281. ((directory rest ...)
  282. (let* ((files (ftp-list conn directory))
  283. (subdirs (filter-map (match-lambda
  284. ((name 'directory . _) name)
  285. (_ #f))
  286. files)))
  287. (define (file->url file)
  288. (string-append "ftp://" server directory "/" file))
  289. (define (file->source file)
  290. (let ((url (file->url file)))
  291. (upstream-source
  292. (package project)
  293. (version (tarball->version file))
  294. (urls (list url))
  295. (signature-urls (list (string-append url ".sig"))))))
  296. (loop (append (map (cut string-append directory "/" <>)
  297. subdirs)
  298. rest)
  299. (append
  300. ;; Filter out signatures, deltas, and files which
  301. ;; are potentially not releases of PROJECT--e.g.,
  302. ;; in /gnu/guile, filter out guile-oops and
  303. ;; guile-www; in mit-scheme, filter out binaries.
  304. (filter-map (match-lambda
  305. ((file 'file . _)
  306. (and (release-file? project file)
  307. (file->source file)))
  308. (_ #f))
  309. files)
  310. result)))))))
  311. (define* (import-ftp-release project
  312. #:key
  313. (version #f)
  314. (server "ftp.gnu.org")
  315. (directory (string-append "/gnu/" project))
  316. (file->signature (cut string-append <> ".sig")))
  317. "Return an <upstream-source> for the latest release of PROJECT on SERVER
  318. under DIRECTORY, or #f. Optionally include a VERSION string to fetch a specific version.
  319. Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP connections; this can be
  320. useful to reuse connections.
  321. FILE->SIGNATURE must be a procedure; it is passed a source file URL and must
  322. return the corresponding signature URL, or #f it signatures are unavailable."
  323. (define (latest a b)
  324. (if (version>? a b) a b))
  325. (define (latest-release a b)
  326. (if (version>? (upstream-source-version a) (upstream-source-version b))
  327. a b))
  328. (define patch-directory-name?
  329. ;; Return #t for patch directory names such as 'bash-4.2-patches'.
  330. (cut string-suffix? "patches" <>))
  331. (define conn (ftp-open server #:timeout 5))
  332. (define (file->url directory file)
  333. (string-append "ftp://" server directory "/" file))
  334. (define (file->source directory file)
  335. (let ((url (file->url directory file)))
  336. (upstream-source
  337. (package project)
  338. (version (tarball->version file))
  339. ;; uri-mirror-rewrite: Don't turn nice mirror:// URIs into ftp://
  340. ;; URLs during "guix refresh -u".
  341. (urls (list (uri-mirror-rewrite url)))
  342. (signature-urls (match (file->signature url)
  343. (#f #f)
  344. (sig (list (uri-mirror-rewrite sig))))))))
  345. (let loop ((directory directory)
  346. (result #f))
  347. (let* ((entries (catch 'ftp-error
  348. (lambda _ (ftp-list conn directory))
  349. (const '())))
  350. ;; Filter out things like /gnupg/patches. Filter out "w32"
  351. ;; directories as found on ftp.gnutls.org.
  352. (subdirs (filter-map (match-lambda
  353. (((? patch-directory-name? dir)
  354. 'directory . _)
  355. #f)
  356. (("w32" 'directory . _)
  357. #f)
  358. (("unstable" 'directory . _)
  359. ;; As seen at ftp.gnupg.org/gcrypt/pinentry.
  360. #f)
  361. ((directory 'directory . _)
  362. directory)
  363. (_ #f))
  364. entries))
  365. ;; Whether or not SUBDIRS is empty, compute the latest releases
  366. ;; for the current directory. This is necessary for packages
  367. ;; such as 'sharutils' that have a sub-directory that contains
  368. ;; only an older release.
  369. (releases (filter-map (match-lambda
  370. ((file 'file . _)
  371. (and (release-file? project file)
  372. (file->source directory file)))
  373. (_ #f))
  374. entries)))
  375. ;; Assume that SUBDIRS correspond to versions, and jump into the
  376. ;; one with the highest version number.
  377. (let* ((release (if version
  378. (find (lambda (upstream)
  379. (string=? (upstream-source-version upstream) version))
  380. (coalesce-sources releases))
  381. (reduce latest-release #f
  382. (coalesce-sources releases))))
  383. (result (if (and result release)
  384. (latest-release release result)
  385. (or release result)))
  386. (target (reduce latest #f subdirs)))
  387. (if target
  388. (loop (string-append directory "/" target)
  389. result)
  390. (begin
  391. (ftp-close conn)
  392. result))))))
  393. (define* (import-release package
  394. #:key
  395. (version #f)
  396. (server "ftp.gnu.org")
  397. (directory (string-append "/gnu/" package)))
  398. "Return the <upstream-source> for the latest version of PACKAGE or #f.
  399. PACKAGE must be the canonical name of a GNU package. Optionally include a
  400. VERSION string to fetch a specific version."
  401. (import-ftp-release package
  402. #:version version
  403. #:server server
  404. #:directory directory))
  405. (define-syntax-rule (false-if-ftp-error exp)
  406. "Return #f if an FTP error is raise while evaluating EXP; return the result
  407. of EXP otherwise."
  408. (catch 'ftp-error
  409. (lambda ()
  410. exp)
  411. (lambda (key port . rest)
  412. (if (ftp-connection? port)
  413. (ftp-close port)
  414. (close-port port))
  415. #f)))
  416. (define* (import-release* package #:key (version #f))
  417. "Like 'import-release', but (1) take a <package> object, and (2) ignore FTP
  418. errors that might occur when PACKAGE is not actually a GNU package, or not
  419. hosted on ftp.gnu.org, or not under that name (this is the case for
  420. \"emacs-auctex\", for instance.)"
  421. (let-values (((server directory)
  422. (ftp-server/directory package)))
  423. (false-if-ftp-error (import-release (package-upstream-name package)
  424. #:version version
  425. #:server server
  426. #:directory directory))))
  427. ;;;
  428. ;;; Latest HTTP release.
  429. ;;;
  430. (define (html-links sxml)
  431. "Return the list of links found in SXML, the SXML tree of an HTML page."
  432. (let loop ((sxml sxml)
  433. (links '()))
  434. (match sxml
  435. (('a ('@ attributes ...) body ...)
  436. (match (assq 'href attributes)
  437. (#f (fold loop links body))
  438. (('href url) (fold loop (cons url links) body))))
  439. ((tag ('@ _ ...) body ...)
  440. (fold loop links body))
  441. ((tag body ...)
  442. (fold loop links body))
  443. (_
  444. links))))
  445. (define (url->links url)
  446. "Return the unique links on the HTML page accessible at URL."
  447. (let* ((uri (string->uri url))
  448. (port (http-fetch/cached uri #:ttl 3600))
  449. (sxml (html->sxml port)))
  450. (close-port port)
  451. (delete-duplicates (html-links sxml))))
  452. (define (canonicalize-url url base-url)
  453. "Make relative URL absolute, by appending URL to BASE-URL as required. If
  454. URL is a directory instead of a file, it should be suffixed with a slash (/)."
  455. (cond ((and=> (string->uri url) uri-scheme)
  456. ;; Fully specified URL.
  457. url)
  458. ((string-prefix? "//" url)
  459. ;; Full URL lacking a URI scheme. Reuse the URI scheme of the
  460. ;; document that contains the URL.
  461. (string-append (symbol->string (uri-scheme (string->uri base-url)))
  462. ":" url))
  463. ((string-prefix? "/" url)
  464. ;; Absolute URL.
  465. (let ((uri (string->uri base-url)))
  466. (uri->string
  467. (build-uri (uri-scheme uri)
  468. #:host (uri-host uri)
  469. #:port (uri-port uri)
  470. #:path url))))
  471. ;; URL is relative to BASE-URL, which is assumed to be a directory.
  472. ((string-suffix? "/" base-url)
  473. (string-append base-url url))
  474. (else
  475. ;; URL is relative to BASE-URL, which is assumed to denote a file
  476. ;; within a directory.
  477. (string-append (dirname base-url) "/" url))))
  478. (define (strip-trailing-slash s)
  479. "Strip any trailing slash from S, a string."
  480. (if (string-suffix? "/" s)
  481. (string-drop-right s 1)
  482. s))
  483. ;;; TODO: Extend to support the RPM and GNOME version schemes?
  484. (define %version-rx "[0-9.]+")
  485. (define* (rewrite-url url version #:key to-version)
  486. "Rewrite URL so that the URL path components matching the current VERSION or
  487. VERSION-MAJOR.VERSION-MINOR are updated with that of the latest version found
  488. by crawling the corresponding URL directories. Alternatively, when TO-VERSION
  489. is specified, rewrite version matches directly to it without crawling URL.
  490. For example, the URL
  491. \"https://dist.libuv.org/dist/v1.45.0/libuv-v1.45.0.tar.gz\" could be
  492. rewritten to something like
  493. \"https://dist.libuv.org/dist/v1.46.0/libuv-v1.46.0.tar.gz\"."
  494. ;; XXX: major-minor may be #f if version is not a triplet but a single
  495. ;; number such as "2".
  496. (let* ((major-minor (false-if-exception (version-major+minor version)))
  497. (to-major-minor (false-if-exception
  498. (and=> to-version version-major+minor)))
  499. (uri (string->uri url))
  500. (url-prefix (string-drop-right url (string-length (uri-path uri))))
  501. (url-prefix-components (string-split url-prefix #\/))
  502. (path (uri-path uri))
  503. ;; Strip a forward slash on the path to avoid a double slash when
  504. ;; string-joining later.
  505. (path (if (string-prefix? "/" path)
  506. (string-drop path 1)
  507. path))
  508. (path-components (string-split path #\/)))
  509. (string-join
  510. (reverse
  511. (fold
  512. (lambda (s parents)
  513. (if to-version
  514. ;; Direct rewrite case; the archive is assumed to exist.
  515. (let ((u (string-replace-substring s version to-version)))
  516. (cons (if (and major-minor to-major-minor)
  517. (string-replace-substring u major-minor to-major-minor)
  518. u)
  519. parents))
  520. ;; More involved HTML crawl case.
  521. (let* ((pattern (if major-minor
  522. (format #f "(~a|~a)" version major-minor)
  523. (format #f "(~a)" version)))
  524. (m (string-match pattern s)))
  525. (if m
  526. ;; Crawl parent and rewrite current component.
  527. (let* ((parent-url (string-join (reverse parents) "/"))
  528. (links (url->links parent-url))
  529. ;; The pattern matching the version.
  530. (pattern (string-append "^" (match:prefix m)
  531. "(" %version-rx ")"
  532. (match:suffix m) "$"))
  533. (candidates (filter-map
  534. (lambda (l)
  535. ;; Links may be followed by a
  536. ;; trailing '/' in the case of
  537. ;; directories.
  538. (and-let*
  539. ((l (strip-trailing-slash l))
  540. (m (string-match pattern l))
  541. (v (match:substring m 1)))
  542. (cons v l)))
  543. links)))
  544. ;; Retrieve the item having the largest version.
  545. (if (null? candidates)
  546. parents
  547. (cons (cdr (first (sort candidates
  548. (lambda (x y)
  549. (version>? (car x)
  550. (car y))))))
  551. parents)))
  552. ;; No version found in path component; continue.
  553. (cons s parents)))))
  554. (reverse url-prefix-components)
  555. path-components))
  556. "/")))
  557. (define* (import-html-release base-url package
  558. #:key
  559. rewrite-url?
  560. version
  561. (directory (string-append
  562. "/" (package-upstream-name package)))
  563. file->signature)
  564. "Return an <upstream-source> for the latest release of PACKAGE under
  565. DIRECTORY at BASE-URL, or #f. Optionally include a VERSION string to fetch a
  566. specific version.
  567. BASE-URL should be the URL of an HTML page, typically a directory listing as
  568. found on 'https://kernel.org/pub'.
  569. When FILE->SIGNATURE is omitted or #f, guess the detached signature file name,
  570. if any. Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
  571. file URL and must return the corresponding signature URL, or #f it signatures
  572. are unavailable.
  573. When REWRITE-URL? is #t, versioned components in BASE-URL and/or DIRECTORY are
  574. also updated to the latest version, as explained in the doc of the
  575. \"rewrite-url\" procedure used."
  576. (let* ((current-version (package-version package))
  577. (name (package-upstream-name package))
  578. (url (if (string-null? directory)
  579. base-url
  580. (string-append base-url directory "/")))
  581. (url (if rewrite-url?
  582. (rewrite-url url current-version #:to-version version)
  583. url))
  584. (links (map (cut canonicalize-url <> url) (url->links url))))
  585. (define (file->signature/guess url)
  586. "Return the first link that matches a signature extension, else #f."
  587. (let ((base (basename url)))
  588. (any (lambda (link)
  589. (any (lambda (extension)
  590. (and (string=? (string-append base extension)
  591. (basename link))
  592. (string-append url extension)))
  593. '(".asc" ".sig" ".sign")))
  594. links)))
  595. (define (url->release url)
  596. "Return an <upstream-source> object if a release file was found at URL,
  597. else #f. URL is assumed to fully specified."
  598. (let ((base (basename url)))
  599. (and (release-file? name base)
  600. (let ((version (tarball->version base)))
  601. (upstream-source
  602. (package name)
  603. (version version)
  604. ;; uri-mirror-rewrite: Don't turn nice mirror:// URIs into ftp://
  605. ;; URLs during "guix refresh -u".
  606. (urls (list (uri-mirror-rewrite url)))
  607. (signature-urls
  608. (and=> ((or file->signature file->signature/guess) url)
  609. (lambda (url) (list (uri-mirror-rewrite url))))))))))
  610. (define candidates
  611. (filter-map url->release links))
  612. (match candidates
  613. (() #f)
  614. ((first . _)
  615. (if version
  616. ;; Find matching release version and return it.
  617. (find (lambda (upstream)
  618. (string=? (upstream-source-version upstream) version))
  619. (coalesce-sources candidates))
  620. ;; Select the most recent release and return it.
  621. (reduce (lambda (r1 r2)
  622. (if (version>? (upstream-source-version r1)
  623. (upstream-source-version r2))
  624. r1 r2))
  625. first
  626. (coalesce-sources candidates)))))))
  627. ;;;
  628. ;;; Updaters.
  629. ;;;
  630. (define %gnu-file-list-uri
  631. ;; URI of the file list for ftp.gnu.org.
  632. (string->uri "https://ftp.gnu.org/find.txt.gz"))
  633. (define ftp.gnu.org-files
  634. (mlambda ()
  635. "Return the list of files available at ftp.gnu.org."
  636. ;; XXX: Memoize the whole procedure to work around the fact that
  637. ;; 'http-fetch/cached' caches the gzipped version.
  638. (define (trim-leading-components str)
  639. ;; Trim the leading ".", if any, in "./gnu/foo".
  640. (string-trim str (char-set #\.)))
  641. (define (string->lines str)
  642. (string-tokenize str (char-set-complement (char-set #\newline))))
  643. ;; Since https://ftp.gnu.org honors 'If-Modified-Since', the hard-coded
  644. ;; TTL can be relatively short.
  645. (let ((port (http-fetch/cached %gnu-file-list-uri #:ttl (* 15 60))))
  646. (map trim-leading-components
  647. (call-with-gzip-input-port port
  648. (compose string->lines get-string-all))))))
  649. (define* (import-gnu-release package #:key (version #f))
  650. "Return the latest release of PACKAGE, a GNU package available via
  651. ftp.gnu.org. Optionally include a VERSION string to fetch a specific version.
  652. This method does not rely on FTP access at all; instead, it browses the file
  653. list available from %GNU-FILE-LIST-URI over HTTP(S)."
  654. (define archive-type
  655. (package-archive-type package))
  656. (define (better-tarball? tarball1 tarball2)
  657. (string=? (file-extension tarball1) archive-type))
  658. (define (find-latest-tarball-version tarballs)
  659. (fold (lambda (file1 file2)
  660. (if (and file2
  661. (version>? (tarball-sans-extension (basename file2))
  662. (tarball-sans-extension (basename file1))))
  663. file2
  664. file1))
  665. #f
  666. tarballs))
  667. (let-values (((server directory)
  668. (ftp-server/directory package))
  669. ((name)
  670. (package-upstream-name package)))
  671. (let* ((files (ftp.gnu.org-files))
  672. ;; select tarballs for this package
  673. (relevant (filter (lambda (file)
  674. (and (string-prefix? "/gnu" file)
  675. (string-contains file directory)
  676. (release-file? name (basename file))))
  677. files))
  678. ;; find latest version
  679. (version (or version
  680. (and (not (null? relevant))
  681. (tarball->version
  682. (find-latest-tarball-version relevant)))))
  683. ;; find tarballs matching this version
  684. (tarballs (filter (lambda (file)
  685. (string=? version (tarball->version file)))
  686. relevant)))
  687. (match tarballs
  688. (() #f)
  689. (_
  690. (upstream-source
  691. (package name)
  692. (version version)
  693. (urls (map (lambda (file)
  694. (string-append "mirror://gnu/"
  695. (string-drop file
  696. (string-length "/gnu/"))))
  697. ;; Sort so that the tarball with the same compression
  698. ;; format as currently used in PACKAGE comes first.
  699. (sort tarballs better-tarball?)))
  700. (signature-urls (map (cut string-append <> ".sig") urls))))))))
  701. (define %package-name-rx
  702. ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses
  703. ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed.
  704. (make-regexp "^(.*)[-_][vV]?(([0-9]|\\.)+)(-src|\\.src|\\.orig)?"))
  705. (define (gnu-package-name->name+version name+version)
  706. "Return the package name and version number extracted from NAME+VERSION."
  707. (let ((match (regexp-exec %package-name-rx name+version)))
  708. (if (not match)
  709. (values name+version #f)
  710. (values (match:substring match 1) (match:substring match 2)))))
  711. (define gnome-package?
  712. (url-prefix-predicate "mirror://gnome/"))
  713. (define (pure-gnu-package? package)
  714. "Return true if PACKAGE is a non-Emacs and non-GNOME GNU package. This
  715. excludes AucTeX, for instance, whose releases are now uploaded to
  716. elpa.gnu.org, GNU Radio, which has releases at www.gnuradio.org, and all the
  717. GNOME packages; EMMS is included though, because its releases are on gnu.org."
  718. (and (or (not (string-prefix? "emacs-" (package-name package)))
  719. (gnu-hosted? package))
  720. (not (gnome-package? package))
  721. (not (string-prefix? "gnuradio" (package-name package)))
  722. (gnu-package? package)))
  723. (define gnu-hosted?
  724. (url-prefix-predicate "mirror://gnu/"))
  725. (define (uri-mirror-rewrite uri)
  726. "Rewrite URI to a mirror:// URI if possible, or return URI unmodified."
  727. (if (string-prefix? "mirror://" uri)
  728. uri ;nothing to do, it's already a mirror URI
  729. (let loop ((mirrors %mirrors))
  730. (match mirrors
  731. (()
  732. uri)
  733. (((mirror-id mirror-urls ...) rest ...)
  734. (match (find (cut string-prefix? <> uri) mirror-urls)
  735. (#f
  736. (loop rest))
  737. (prefix
  738. (format #f "mirror://~a/~a"
  739. mirror-id
  740. (string-drop uri (string-length prefix))))))))))
  741. (define %savannah-base
  742. ;; One of the Savannah mirrors listed at
  743. ;; <https://download.savannah.gnu.org/mirmon/savannah/> that serves valid
  744. ;; HTML (unlike <https://download.savannah.nongnu.org/releases>.)
  745. "https://de.freedif.org/savannah/")
  746. (define* (import-savannah-release package #:key (version #f))
  747. "Return the latest release of PACKAGE. Optionally include a VERSION string
  748. to fetch a specific version."
  749. (let* ((uri (string->uri
  750. (match (origin-uri (package-source package))
  751. ((? string? uri) uri)
  752. ((uri mirrors ...) uri))))
  753. (directory (dirname (uri-path uri))))
  754. ;; Note: We use the default 'file->signature', which adds ".sig", ".asc",
  755. ;; or whichever detached signature naming scheme PACKAGE uses.
  756. (import-html-release %savannah-base package
  757. #:version version
  758. #:directory directory)))
  759. (define* (latest-sourceforge-release package #:key (version #f))
  760. "Return the latest release of PACKAGE. Optionally include a VERSION string
  761. to fetch a specific version."
  762. (define (uri-append uri extension)
  763. ;; Return URI with EXTENSION appended.
  764. (build-uri (uri-scheme uri)
  765. #:host (uri-host uri)
  766. #:path (string-append (uri-path uri) extension)))
  767. (define (valid-uri? uri port)
  768. ;; Return true if URI is reachable.
  769. (false-if-exception
  770. (case (response-code (http-head uri #:port port #:keep-alive? #t))
  771. ((200 302) #t)
  772. (else #f))))
  773. (when version
  774. (error
  775. (formatted-message
  776. (G_ "Updating to a specific version is not yet implemented for ~a, sorry.")
  777. "sourceforge")))
  778. (let* ((name (package-upstream-name package))
  779. (base (string-append "https://sourceforge.net/projects/"
  780. name "/files"))
  781. (url (string-append base "/latest/download"))
  782. (uri (string->uri url))
  783. (port (false-if-exception (open-socket-for-uri uri)))
  784. (response (and port
  785. (http-head uri #:port port #:keep-alive? #t))))
  786. (dynamic-wind
  787. (const #t)
  788. (lambda ()
  789. (and response
  790. (= 302 (response-code response))
  791. (response-location response)
  792. (match (string-tokenize (uri-path (response-location response))
  793. (char-set-complement (char-set #\/)))
  794. ((_ components ...)
  795. (let* ((path (string-join components "/"))
  796. (url (string-append "mirror://sourceforge/" path)))
  797. (and (release-file? name (basename path))
  798. ;; Take the heavy-handed approach of probing 3 additional
  799. ;; URLs. XXX: Would be nicer if this could be avoided.
  800. (let* ((loc (response-location response))
  801. (sig (any (lambda (extension)
  802. (let ((uri (uri-append loc extension)))
  803. (and (valid-uri? uri port)
  804. (string-append url extension))))
  805. '(".asc" ".sig" ".sign"))))
  806. (upstream-source
  807. (package name)
  808. (version (tarball->version (basename path)))
  809. (urls (list url))
  810. (signature-urls (and sig (list sig)))))))))))
  811. (lambda ()
  812. (when port
  813. (close-port port))))))
  814. (define* (import-xorg-release package #:key (version #f))
  815. "Return the latest release of PACKAGE. Optionally include a VERSION string
  816. to fetch a specific version."
  817. (let ((uri (string->uri (origin-uri (package-source package)))))
  818. (false-if-ftp-error
  819. (import-ftp-release
  820. (package-name package)
  821. #:version version
  822. #:server "ftp.freedesktop.org"
  823. #:directory
  824. (string-append "/pub/xorg/" (dirname (uri-path uri)))))))
  825. (define* (import-kernel.org-release package #:key (version #f))
  826. "Return the latest release of PACKAGE, a Linux kernel package.
  827. Optionally include a VERSION string to fetch a specific version."
  828. (define %kernel.org-base
  829. ;; This URL and sub-directories thereof are nginx-generated directory
  830. ;; listings suitable for 'import-html-release'.
  831. "https://mirrors.edge.kernel.org/pub")
  832. (define (file->signature file)
  833. (string-append (file-sans-extension file) ".sign"))
  834. (let* ((uri (string->uri
  835. (match (origin-uri (package-source package))
  836. ((? string? uri) uri)
  837. ((uri mirrors ...) uri))))
  838. (directory (dirname (uri-path uri))))
  839. (import-html-release %kernel.org-base package
  840. #:version version
  841. #:directory directory
  842. #:file->signature file->signature)))
  843. ;;; These sites are disallowed for the generic HTML updater as there are
  844. ;;; better means to query them.
  845. (define %disallowed-hosting-sites
  846. '("github.com" "github.io" "gitlab.com"
  847. "notabug.org" "sr.ht" "gitlab.inria.fr"
  848. "ftp.gnu.org" "download.savannah.gnu.org"
  849. "pypi.org" "crates.io" "rubygems.org"
  850. "bioconductor.org"))
  851. (define (http-url? url)
  852. "Return URL if URL has HTTP or HTTPS as its protocol. If URL uses the
  853. special mirror:// protocol, substitute it with the first HTTP or HTTPS URL
  854. prefix from its set."
  855. (match (string->uri url)
  856. (#f #f)
  857. (uri
  858. (let ((scheme (uri-scheme uri))
  859. (host (uri-host uri)))
  860. (or (and (memq scheme '(http https))
  861. ;; HOST may contain prefixes, e.g. "profanity-im.github.io",
  862. ;; hence the suffix-based test below.
  863. (not (any (cut string-suffix? <> host)
  864. %disallowed-hosting-sites))
  865. url)
  866. (and (eq? scheme 'mirror)
  867. (and=> (find http-url?
  868. (assoc-ref %mirrors
  869. (string->symbol host)))
  870. (lambda (url)
  871. (string-append (strip-trailing-slash url)
  872. (uri-path uri))))))))))
  873. (define (html-updatable-package? package)
  874. "Return true if the given package may be handled by the generic HTML
  875. updater."
  876. (or (assoc-ref (package-properties package) 'release-monitoring-url)
  877. ((url-predicate http-url?) package)))
  878. (define* (import-html-updatable-release package #:key (version #f))
  879. "Return the latest release of PACKAGE else #f. Do that by crawling the HTML
  880. page of the directory containing its source tarball. Optionally include a
  881. VERSION string to fetch a specific version."
  882. (define (expand-uri uri)
  883. (match uri
  884. ((and (? string?) (? (cut string-prefix? "mirror://" <>) url))
  885. ;; Retrieve the authoritative HTTP URL from a mirror.
  886. (http-url? url))
  887. ((? string? url)
  888. url)
  889. ((url _ ...)
  890. ;; This case is for when the URI is a list of possibly
  891. ;; mirror URLs as well as HTTP URLs.
  892. (expand-uri url))))
  893. (let* ((uri (string->uri
  894. (expand-uri (origin-uri (package-source package)))))
  895. (custom (assoc-ref (package-properties package)
  896. 'release-monitoring-url))
  897. (base (or custom
  898. (string-append (symbol->string (uri-scheme uri))
  899. "://" (uri-host uri))))
  900. (directory (if custom
  901. ""
  902. (dirname (uri-path uri)))))
  903. (false-if-networking-error
  904. (import-html-release base package
  905. #:rewrite-url? #t
  906. #:version version
  907. #:directory directory))))
  908. (define %gnu-updater
  909. ;; This is for everything at ftp.gnu.org.
  910. (upstream-updater
  911. (name 'gnu)
  912. (description "Updater for GNU packages")
  913. (pred (lambda (package)
  914. (false-if-networking-error (gnu-hosted? package))))
  915. (import import-gnu-release)))
  916. (define %gnu-ftp-updater
  917. ;; This is for GNU packages taken from alternate locations, such as
  918. ;; alpha.gnu.org, ftp.gnupg.org, etc. It is obsolescent.
  919. (upstream-updater
  920. (name 'gnu-ftp)
  921. (description "Updater for GNU packages only available via FTP")
  922. (pred (lambda (package)
  923. (false-if-networking-error
  924. (and (not (gnu-hosted? package))
  925. (pure-gnu-package? package)))))
  926. (import import-release*)))
  927. (define %savannah-updater
  928. (upstream-updater
  929. (name 'savannah)
  930. (description "Updater for packages hosted on savannah.gnu.org")
  931. (pred (url-prefix-predicate "mirror://savannah/"))
  932. (import import-savannah-release)))
  933. (define %sourceforge-updater
  934. (upstream-updater
  935. (name 'sourceforge)
  936. (description "Updater for packages hosted on sourceforge.net")
  937. (pred (url-prefix-predicate "mirror://sourceforge/"))
  938. (import latest-sourceforge-release)))
  939. (define %xorg-updater
  940. (upstream-updater
  941. (name 'xorg)
  942. (description "Updater for X.org packages")
  943. (pred (url-prefix-predicate "mirror://xorg/"))
  944. (import import-xorg-release)))
  945. (define %kernel.org-updater
  946. (upstream-updater
  947. (name 'kernel.org)
  948. (description "Updater for packages hosted on kernel.org")
  949. (pred (url-prefix-predicate "mirror://kernel.org/"))
  950. (import import-kernel.org-release)))
  951. (define %generic-html-updater
  952. (upstream-updater
  953. (name 'generic-html)
  954. (description "Updater that crawls HTML pages.")
  955. (pred html-updatable-package?)
  956. (import import-html-updatable-release)))
  957. ;;; gnu-maintenance.scm ends here