From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp10.migadu.com ([2001:41d0:2:bcc0::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms5.migadu.com with LMTPS id 4KHiJ9+HoWNUawEAbAwnHQ (envelope-from ) for ; Tue, 20 Dec 2022 11:01:03 +0100 Received: from aspmx1.migadu.com ([2001:41d0:2:bcc0::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp10.migadu.com with LMTPS id mIIEJ9+HoWO9IwEAG6o9tA (envelope-from ) for ; Tue, 20 Dec 2022 11:01:03 +0100 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id 1559B3FE62 for ; Tue, 20 Dec 2022 11:01:02 +0100 (CET) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1p7Z2n-00056J-J2; Tue, 20 Dec 2022 04:36:17 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1p7Z1e-0004eH-Av for guix-patches@gnu.org; Tue, 20 Dec 2022 04:35:11 -0500 Received: from debbugs.gnu.org ([209.51.188.43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1p7Z1e-0002vB-0y for guix-patches@gnu.org; Tue, 20 Dec 2022 04:35:06 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1p7Z1d-0003R8-R7 for guix-patches@gnu.org; Tue, 20 Dec 2022 04:35:05 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#57460] [PATCH v3 05/18] gnu-maintenance: Allow updating to a specific version. Resent-From: Hartmut Goebel Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 20 Dec 2022 09:35:05 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 57460 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch moreinfo To: 57460@debbugs.gnu.org Received: via spool by 57460-submit@debbugs.gnu.org id=B57460.167152889213089 (code B ref 57460); Tue, 20 Dec 2022 09:35:05 +0000 Received: (at 57460) by debbugs.gnu.org; 20 Dec 2022 09:34:52 +0000 Received: from localhost ([127.0.0.1]:43731 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1p7Z1O-0003Ow-L3 for submit@debbugs.gnu.org; Tue, 20 Dec 2022 04:34:51 -0500 Received: from mout.kundenserver.de ([217.72.192.75]:43409) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1p7Z1G-0003Nn-68 for 57460@debbugs.gnu.org; Tue, 20 Dec 2022 04:34:44 -0500 Received: from hermia.goebel-consult.de ([87.176.134.225]) by mrelayeu.kundenserver.de (mreue108 [212.227.15.183]) with ESMTPSA (Nemesis) id 1N2m3G-1okRY802G4-0138tG for <57460@debbugs.gnu.org>; Tue, 20 Dec 2022 10:34:36 +0100 Received: from thisbe.goebel-consult.de (hermia.goebel-consult.de [192.168.110.7]) by hermia.goebel-consult.de (Postfix) with ESMTP id 6AD2E6696C; Tue, 20 Dec 2022 10:34:23 +0100 (CET) From: Hartmut Goebel Date: Tue, 20 Dec 2022 10:34:10 +0100 Message-Id: <215e393122cd3b18318ed1d5893af64d995b248e.1671527962.git.h.goebel@crazy-compilers.com> X-Mailer: git-send-email 2.30.6 In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-Provags-ID: V03:K1:UDLk4DOsQAga+2HXz6q8ynveAVcxMZXAtRWTkMa1sxpqODce3D6 zUf3Ed/VdyZsJeZ04bMDyu3v236NzBSw5byzi4ZaBb0inrPkvjpQKY6dYOcrGUiAtdSOSwO tQULTQHZXZMcVo4eQ/FtfxG9VkpB3oujMNxKqRvGeC9E91qM1Vwc1Wj3Lc/r5Kqt87sCeIG QZHC3H7/q7LnU6WboFJ5A== UI-OutboundReport: notjunk:1;M01:P0:fIYZEFIL0+E=;eAI3cQL6bk6LlZVAXwd0aLkqqnO pG4tJoyqaDVe6aNHDgF4AWzB0UEWej8W55R/i5WX5zbWsmG9UhUz2nvIV7iA0r+ZwUEcOqk0D Q9YJ96zfbWcAA8OvBHNd6iscgPtNHEwEtoV5BUlMhwABQjOaILp40hTC7L0TxijanGdTQFr4w TkmLgEEAgndKklXwJO7KJnPHlWrY6PLWaMSQoZnYxeWYxvRbu23KvGwCfxeFpKaGvniDil9N3 M8mVE8yoKHAsztTcWdFCI85SzjRGbTPHX4dIFY0YD/jTRwYZADj9/iE+M7uAdACx8SJhQAgS/ kLFhrjqj3N0lbrBntbFdpK+0kcZHuv2jo+rXYhJ/XFRFKUpfywIemwBxIA6vQwWEYTyERXXnh 5SA+0T7yPjwrhaWKcQDlYAS42Fn1Fc/xAzMPmyelRP7Wj1hqRGm18HqJvzkeCiHwBsxIbPJ0F 1xOmUZJuOLwZAXA06anJSREKVQ7hTtqYKQpVoGDw36Wmkhz7uLcUzUdGT76TSXd6lmUUxfzE2 DPA6r1slR2FfTs7dFsBd9ezSlheLYDEjNJiMixAGVTwFz6RxB5n+8ZUWJbzJnImbHk9zNKJK9 0LGcNcGqKcLp+pIpFNm5oyGDFKDaQRwrEhZ+SycEzKhcOGiynEvTF+MpBQH5CgSvoBEDgMOsJ fTf1IvhyWrirx0A1iSeBftBSdtdKrwIQyBmsi0rqDtBBYLfEeuJWHgNnXTnGn0M= X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+larch=yhetil.org@gnu.org Sender: guix-patches-bounces+larch=yhetil.org@gnu.org X-Migadu-Country: US X-Migadu-Flow: FLOW_IN ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=none; dmarc=none; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org" ARC-Seal: i=1; s=key1; d=yhetil.org; t=1671530463; a=rsa-sha256; cv=none; b=qCMOG9NN52yFxhZacgbYEDgdD+1W+0a51bh+uFH5mstsvuMNT9cBU7sCtb+zgkBT5Pcvap IimZGYBeljTgX3z3CutrGbqcd3wgtnH+wiaxRSEYJjWm5VEXj9jKL0DcIvpkyA865GrPZR xNFJwM70ug9fAPIoebi6ltqtjY21O04AimiFMucn16jAOH1mVT4n7GyrQVUx1jS63EKxnO +YwjiucKy5IvJW+5IeFhL1tMIzANrNn4yNRLhMSNS9hNDdy5wYTWLrDMpMtvwpkspCh6XR Kg8ZxESEjzw8EHFsH65xMrsx1kjKx/UypWmfm7FKwxDsDFSN1FGWgFBWe0D15Q== ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1671530463; h=from:from:sender:sender:reply-to:subject:subject:date:date: message-id:message-id:to:to:cc:mime-version:mime-version: content-type:content-type: content-transfer-encoding:content-transfer-encoding:resent-cc: resent-from:resent-sender:resent-message-id:in-reply-to:in-reply-to: references:references:list-id:list-help:list-unsubscribe: list-subscribe:list-post; bh=B2Lr5LgfLNcmC2jqJhgyIeGDe3s+shV82l0UQWH4aHA=; b=gNOWKgK1vaH5c3SFoOrM2qG+yFtiuRctDzjhUrPYwc+r1lbgG7CySGwo8/vyZIHkRqIeZw bQMkzb4Qp2iXqHD9/obOn5uamOZdOFSgbwOsWTzI87m8RO91FeQs57JjIme1NJdoY4LAFo vs7GMerXMbL7cUIBOoPQPjmAUDy4tBlxAB1ozWb0CuMdrvZJdhePSLCW3IxKwZKoJDRrqU hAd5ETsLgwLXhXQwAyIyfYZYz8eoNHnZjZzKpYSq1PzshqIhzt1S3Js9YRx7VJVosCTvMj ofl+XVYsg5GozNsdpHbbXfWtC5KLbxHGljen4E/25/rFBiTBQGJQysK6OgvBgA== Authentication-Results: aspmx1.migadu.com; dkim=none; dmarc=none; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org" X-Migadu-Scanner: scn1.migadu.com X-Migadu-Spam-Score: -1.99 X-Spam-Score: -1.99 X-Migadu-Queue-Id: 1559B3FE62 X-TUID: /8CgLHaUgrg2 * guix/gnu-maintenance.scm (latest-ftp-release): Rename to … (import-ftp-release) … this, add #:version argument. If version is given, try to find the respective version. (latest-html-release): Rename to … (import-html-release) … this, add #:version argument. If version is given, try to find the respective version. (latest-gnu-release): Rename to … (import-gnu-release) … this, add #:version argument. Refactor to first select archives for respective package, the find the requested or latest version, then create the upstream-source. (latest-release): Rename to … (import-release) … this, add #:version argument, pass on to … (import-ftp-release) … this. (import-release*): Rename to … (import-release*) … this, add #:version argument, pass on to … (latest-release) … this. (latest-savannah-release): Rename to … (import-savannah-release) … this, add keword-argument version, pass on to … (import-html-release) … this. (latest-xorg-release): Rename to … (import-xorg-release) … this, add keword-argument version, pass on to … (import-ftp-release) … this. (latest-kernel.org-release): Rename to … (import-kernel.org-release) … this, add #:version argument, pass on to … (import-html-release) … this. (latest-html-updatable-release): Rename to … (import-html-updatable-release) … this, add #:version argument, pass on to … (import-html-release) … this. * guix/import/gnu.scm(gnu->guix-package): Adjust function call. --- guix/gnu-maintenance.scm | 171 ++++++++++++++++++++++++--------------- guix/import/gnu.scm | 2 +- 2 files changed, 105 insertions(+), 68 deletions(-) diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index e414de8e28..e26702599d 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -333,14 +333,17 @@ name/directory pairs." files) result))))))) -(define* (latest-ftp-release project +(define* (import-ftp-release project #:key + (version #f) (server "ftp.gnu.org") (directory (string-append "/gnu/" project)) (file->signature (cut string-append <> ".sig"))) "Return an for the latest release of PROJECT on SERVER -under DIRECTORY, or #f. Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP -connections; this can be useful to reuse connections. +under DIRECTORY, or #f. Optionally include a VERSION string to fetch a specific version. + +Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP connections; this can be +useful to reuse connections. FILE->SIGNATURE must be a procedure; it is passed a source file URL and must return the corresponding signature URL, or #f it signatures are unavailable." @@ -407,8 +410,12 @@ return the corresponding signature URL, or #f it signatures are unavailable." ;; Assume that SUBDIRS correspond to versions, and jump into the ;; one with the highest version number. - (let* ((release (reduce latest-release #f - (coalesce-sources releases))) + (let* ((release (if version + (find (lambda (upstream) + (string=? (upstream-source-version upstream) version)) + (coalesce-sources releases)) + (reduce latest-release #f + (coalesce-sources releases)))) (result (if (and result release) (latest-release release result) (or release result))) @@ -420,13 +427,16 @@ return the corresponding signature URL, or #f it signatures are unavailable." (ftp-close conn) result)))))) -(define* (latest-release package +(define* (import-release package #:key + (version #f) (server "ftp.gnu.org") (directory (string-append "/gnu/" package))) "Return the for the latest version of PACKAGE or #f. -PACKAGE must be the canonical name of a GNU package." - (latest-ftp-release package +PACKAGE must be the canonical name of a GNU package. Optionally include a +VERSION string to fetch a specific version." + (import-ftp-release package + #:version version #:server server #:directory directory)) @@ -442,14 +452,15 @@ of EXP otherwise." (close-port port)) #f))) -(define (latest-release* package) - "Like 'latest-release', but (1) take a object, and (2) ignore FTP +(define* (import-release* package #:key (version #f)) + "Like 'import-release', but (1) take a object, and (2) ignore FTP errors that might occur when PACKAGE is not actually a GNU package, or not hosted on ftp.gnu.org, or not under that name (this is the case for \"emacs-auctex\", for instance.)" (let-values (((server directory) (ftp-server/directory package))) - (false-if-ftp-error (latest-release (package-upstream-name package) + (false-if-ftp-error (import-release (package-upstream-name package) + #:version version #:server server #:directory directory)))) @@ -474,14 +485,18 @@ hosted on ftp.gnu.org, or not under that name (this is the case for (_ links)))) -(define* (latest-html-release package +(define* (import-html-release package #:key + (version #f) (base-url "https://kernel.org/pub") (directory (string-append "/" package)) file->signature) "Return an for the latest release of PACKAGE (a string) on -SERVER under DIRECTORY, or #f. BASE-URL should be the URL of an HTML page, -typically a directory listing as found on 'https://kernel.org/pub'. +SERVER under DIRECTORY, or #f. Optionally include a VERSION string to fetch a +specific version. + +BASE-URL should be the URL of an HTML page, typically a directory listing as +found on 'https://kernel.org/pub'. When FILE->SIGNATURE is omitted or #f, guess the detached signature file name, if any. Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source @@ -554,13 +569,18 @@ are unavailable." (match candidates (() #f) ((first . _) - ;; Select the most recent release and return it. - (reduce (lambda (r1 r2) - (if (version>? (upstream-source-version r1) - (upstream-source-version r2)) - r1 r2)) - first - (coalesce-sources candidates)))))) + (if version + ;; find matching release version and return it + (find (lambda (upstream) + (string=? (upstream-source-version upstream) version)) + (coalesce-sources candidates)) + ;; Select the most recent release and return it. + (reduce (lambda (r1 r2) + (if (version>? (upstream-source-version r1) + (upstream-source-version r2)) + r1 r2)) + first + (coalesce-sources candidates))))))) ;;; @@ -592,9 +612,9 @@ are unavailable." (call-with-gzip-input-port port (compose string->lines get-string-all)))))) -(define (latest-gnu-release package) +(define* (import-gnu-release package #:key (version #f)) "Return the latest release of PACKAGE, a GNU package available via -ftp.gnu.org. +ftp.gnu.org. Optionally include a VERSION string to fetch a specific version. This method does not rely on FTP access at all; instead, it browses the file list available from %GNU-FILE-LIST-URI over HTTP(S)." @@ -604,42 +624,50 @@ list available from %GNU-FILE-LIST-URI over HTTP(S)." (define (better-tarball? tarball1 tarball2) (string=? (file-extension tarball1) archive-type)) + (define (find-latest-tarball-version tarballs) + (fold (lambda (file1 file2) + (if (and file2 + (version>? (tarball-sans-extension (basename file2)) + (tarball-sans-extension (basename file1)))) + file2 + file1)) + #f + tarballs)) + (let-values (((server directory) (ftp-server/directory package)) ((name) (package-upstream-name package))) (let* ((files (ftp.gnu.org-files)) + ;; select tarballs for this package (relevant (filter (lambda (file) (and (string-prefix? "/gnu" file) (string-contains file directory) (release-file? name (basename file)))) - files))) - (match (sort relevant (lambda (file1 file2) - (version>? (tarball-sans-extension - (basename file1)) - (tarball-sans-extension - (basename file2))))) - ((and tarballs (reference _ ...)) - (let* ((version (tarball->version reference)) - (tarballs (filter (lambda (file) - (string=? (tarball-sans-extension - (basename file)) - (tarball-sans-extension - (basename reference)))) - tarballs))) - (upstream-source - (package name) - (version version) - (urls (map (lambda (file) - (string-append "mirror://gnu/" - (string-drop file - (string-length "/gnu/")))) + files)) + ;; find latest version + (version (or version + (and (not (null? relevant)) + (tarball->version + (find-latest-tarball-version relevant))))) + ;; find tarballs matching this version + (tarballs (filter (lambda (file) + (string=? version (tarball->version file))) + relevant))) + (match tarballs + (() #f) + (_ + (upstream-source + (package name) + (version version) + (urls (map (lambda (file) + (string-append "mirror://gnu/" + (string-drop file + (string-length "/gnu/")))) ;; Sort so that the tarball with the same compression ;; format as currently used in PACKAGE comes first. (sort tarballs better-tarball?))) - (signature-urls (map (cut string-append <> ".sig") urls))))) - (() - #f))))) + (signature-urls (map (cut string-append <> ".sig") urls)))))))) (define %package-name-rx ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses @@ -693,8 +721,9 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." ;; HTML (unlike .) "https://de.freedif.org/savannah/") -(define (latest-savannah-release package) - "Return the latest release of PACKAGE." +(define* (import-savannah-release package #:key (version #f)) + "Return the latest release of PACKAGE. Optionally include a VERSION string +to fetch a specific version." (let* ((uri (string->uri (match (origin-uri (package-source package)) ((? string? uri) uri) @@ -703,12 +732,14 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." (directory (dirname (uri-path uri)))) ;; Note: We use the default 'file->signature', which adds ".sig", ".asc", ;; or whichever detached signature naming scheme PACKAGE uses. - (latest-html-release package + (import-html-release package + #:version version #:base-url %savannah-base #:directory directory))) (define* (latest-sourceforge-release package #:key (version #f)) - "Return the latest release of PACKAGE." + "Return the latest release of PACKAGE. Optionally include a VERSION string +to fetch a specific version." (define (uri-append uri extension) ;; Return URI with EXTENSION appended. (build-uri (uri-scheme uri) @@ -766,21 +797,24 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." (when port (close-port port)))))) -(define (latest-xorg-release package) - "Return the latest release of PACKAGE." +(define* (import-xorg-release package #:key (version #f)) + "Return the latest release of PACKAGE. Optionally include a VERSION string +to fetch a specific version." (let ((uri (string->uri (origin-uri (package-source package))))) (false-if-ftp-error - (latest-ftp-release + (import-ftp-release (package-name package) + #:version version #:server "ftp.freedesktop.org" #:directory (string-append "/pub/xorg/" (dirname (uri-path uri))))))) -(define (latest-kernel.org-release package) - "Return the latest release of PACKAGE, the name of a kernel.org package." +(define* (import-kernel.org-release package #:key (version #f)) + "Return the latest release of PACKAGE, the name of a kernel.org package. +Optionally include a VERSION string to fetch a specific version." (define %kernel.org-base ;; This URL and sub-directories thereof are nginx-generated directory - ;; listings suitable for 'latest-html-release'. + ;; listings suitable for 'import-html-release'. "https://mirrors.edge.kernel.org/pub") (define (file->signature file) @@ -792,7 +826,8 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." ((uri mirrors ...) uri)))) (package (package-upstream-name package)) (directory (dirname (uri-path uri)))) - (latest-html-release package + (import-html-release package + #:version version #:base-url %kernel.org-base #:directory directory #:file->signature file->signature))) @@ -819,9 +854,10 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." (or (assoc-ref (package-properties package) 'release-monitoring-url) (http-url? package))))) -(define (latest-html-updatable-release package) +(define* (import-html-updatable-release package #:key (version #f)) "Return the latest release of PACKAGE. Do that by crawling the HTML page of -the directory containing its source tarball." +the directory containing its source tarball. Optionally include a VERSION +string to fetch a specific version." (let* ((uri (string->uri (match (origin-uri (package-source package)) ((? string? url) url) @@ -838,7 +874,8 @@ the directory containing its source tarball." (catch #t (lambda () (guard (c ((http-get-error? c) #f)) - (latest-html-release package + (import-html-release package + #:version version #:base-url base #:directory directory))) (lambda (key . args) @@ -856,7 +893,7 @@ the directory containing its source tarball." (name 'gnu) (description "Updater for GNU packages") (pred gnu-hosted?) - (import latest-gnu-release))) + (import import-gnu-release))) (define %gnu-ftp-updater ;; This is for GNU packages taken from alternate locations, such as @@ -867,14 +904,14 @@ the directory containing its source tarball." (pred (lambda (package) (and (not (gnu-hosted? package)) (pure-gnu-package? package)))) - (import latest-release*))) + (import import-release*))) (define %savannah-updater (upstream-updater (name 'savannah) (description "Updater for packages hosted on savannah.gnu.org") (pred (url-prefix-predicate "mirror://savannah/")) - (import latest-savannah-release))) + (import import-savannah-release))) (define %sourceforge-updater (upstream-updater @@ -888,20 +925,20 @@ the directory containing its source tarball." (name 'xorg) (description "Updater for X.org packages") (pred (url-prefix-predicate "mirror://xorg/")) - (import latest-xorg-release))) + (import import-xorg-release))) (define %kernel.org-updater (upstream-updater (name 'kernel.org) (description "Updater for packages hosted on kernel.org") (pred (url-prefix-predicate "mirror://kernel.org/")) - (import latest-kernel.org-release))) + (import import-kernel.org-release))) (define %generic-html-updater (upstream-updater (name 'generic-html) (description "Updater that crawls HTML pages.") (pred html-updatable-package?) - (import latest-html-updatable-release))) + (import import-html-updatable-release))) ;;; gnu-maintenance.scm ends here diff --git a/guix/import/gnu.scm b/guix/import/gnu.scm index 2b9b71feb0..139c32a545 100644 --- a/guix/import/gnu.scm +++ b/guix/import/gnu.scm @@ -117,7 +117,7 @@ details.)" (unless package (raise (formatted-message (G_ "no GNU package found for ~a") name))) - (match (latest-release name) + (match (import-release name) ((? upstream-source? release) (let ((version (upstream-source-version release))) (gnu-package->sexp package release #:key-download key-download))) -- 2.30.6