From patchwork Sun Aug 28 13:18:31 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Hartmut Goebel X-Patchwork-Id: 42025 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 1C99B27BBE9; Sun, 28 Aug 2022 14:20:35 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 6AC5C27BBEA for ; Sun, 28 Aug 2022 14:20:33 +0100 (BST) Received: from localhost ([::1]:59252 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1oSIDI-0002q2-IY for patchwork@mira.cbaines.net; Sun, 28 Aug 2022 09:20:32 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:49042) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1oSICr-0002mN-5X for guix-patches@gnu.org; Sun, 28 Aug 2022 09:20:05 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:39834) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1oSICq-0002eG-T3 for guix-patches@gnu.org; Sun, 28 Aug 2022 09:20:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1oSICq-0006y0-OX for guix-patches@gnu.org; Sun, 28 Aug 2022 09:20:04 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#57460] [PATCH 05/20] refresh: Allow updating to a specific version (gnu-maintenance) Resent-From: Hartmut Goebel Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sun, 28 Aug 2022 13:20:04 +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 To: 57460@debbugs.gnu.org Received: via spool by 57460-submit@debbugs.gnu.org id=B57460.166169275826531 (code B ref 57460); Sun, 28 Aug 2022 13:20:04 +0000 Received: (at 57460) by debbugs.gnu.org; 28 Aug 2022 13:19:18 +0000 Received: from localhost ([127.0.0.1]:57774 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1oSIC5-0006to-2F for submit@debbugs.gnu.org; Sun, 28 Aug 2022 09:19:17 -0400 Received: from mout.kundenserver.de ([212.227.126.134]:37379) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1oSIBu-0006s4-Bb for 57460@debbugs.gnu.org; Sun, 28 Aug 2022 09:19:07 -0400 Received: from hermia.goebel-consult.de ([46.87.137.46]) by mrelayeu.kundenserver.de (mreue010 [212.227.15.167]) with ESMTPSA (Nemesis) id 1MgNQd-1p473L2n3n-00hvlo for <57460@debbugs.gnu.org>; Sun, 28 Aug 2022 15:19:00 +0200 Received: from lenashee.fritz.box (lenashee.goebel-consult.de [192.168.110.2]) by hermia.goebel-consult.de (Postfix) with ESMTP id 993C365A34; Sun, 28 Aug 2022 15:18:55 +0200 (CEST) From: Hartmut Goebel Date: Sun, 28 Aug 2022 15:18:31 +0200 Message-Id: <51528a9d139e8178faa1365f49d29e55ed320ada.1661691694.git.h.goebel@crazy-compilers.com> X-Mailer: git-send-email 2.30.4 In-Reply-To: References: MIME-Version: 1.0 X-Provags-ID: V03:K1:BXi9guQ90yR8iu8GW+yXtk819EoXQoF3nAAuP7jhDmg11QAyy1E ydiJ17TVrXlnnBYab2SxUrl620zdSKnbSnoSdD/lyJHebOcXKmIcGXXIeUSSOZkFq5WADs4 g5xdUGhZSa4FdSnHfJHzlvOqAwujIS255OoAMNJuUypa+eX9lvDuvpsqWf/RZbEDznS7c9u ZBnjNINv1Rp3w2QYj3mqA== X-UI-Out-Filterresults: notjunk:1;V03:K0:dnFfYUsUeMY=:kgx8/0hrHzXQ+3arTSP1HX nZwPKTmQc3o8whsuHCQiCzspOkdSCFVhZdy3/e+TdY9C0D8YIqCE0BSlQhke4z5VgSEj4l9tB xCh24FiYHchFeOQG3e0sh2EO44dI0Xb2Kcv2IbTiIx+bq4pIr4PWWbu+XnZ3RzMZmCWvTyLh2 DDS2izsKBsIWMtR+MDo3N5uBPjhjyzDEVCGAMTfm3ZLszMO+XI1XUHJTFXnRk9rS4TPnsMKVz FTMUgsWheKQE0Rsjy0O6+0z4s8zK0qjUKrKYFOZNRacXUAINFYRCXqPfyq6Mx0ZbFBk0X0Xq2 thCPsqWY/TKts6WbZh6Z/n8mF7yWcjR/k3cyd2Q+tUs9sOkiG7Iy597YAz/i/bBvu06JHM7tt ZdFjj+VmGwVIztiH7oaQOGluuhgVXOH35C9ayU2ats1wXQy+0v3kkpEtR8m8UTxRXEFQDRljd UyP0+bYKAnh4JCuD5vrJ9DunRtmd4+XQ8FO1QBlAUtuIrFmWwaPh/m3cOi9ou2JUR8TEEbwTc Aa4JNZV8W3EMHlmlsJ6Swq/Eb2t1Qwdo4v/TjeqOIJpsUfcNcAU97pVWpg6+UIAyjgQkqGh0Z v4+OafMvpoyLQEySWkUVvGM0Ted4vItensleJ/abO0JfOZIcTVNDpZkGFytG3q88oplGCMTiZ JcQQBHtj97mfOIH+ql4uoDrKSw05p4ahqmSWOFcYW/xwI9TH8QdtRyxatey1yniQR7hpcWh/M 01E004UeX7wfQ8xHvpudTFVBiBYOqY1l7Uwrf6tl8rqlnHm+/UWu1EwPTYc= 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+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/gnu-maintenance.scm (latest-ftp-release): Rename to (import-ftp-release), add keyword-argument 'version'. If version is given, try to find the respective version. (latest-html-release): Rename to (import-html-release), add keyword-argument 'version'. If version is given, try to find the respective version. (latest-gnu-release): Rename to (import-gnu-release), add keyword-argument 'version'. 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), add keyword-argument 'version', pass on to import-ftp-release. (import-release*): Rename to (import-release*), add keyword-argument 'version', pass on to latest-release. (latest-savannah-release): Rename to (import-savannah-release), add keword-argument version, pass on to import-html-release. (latest-xorg-release): Rename to (import-xorg-release), add keword-argument version, pass on to import-ftp-release. (latest-kernel.org-release): Rename to (import-kernel.org-release), add keyword-argument 'version', pass on to import-html-release. (latest-html-updatable-release): Rename to (import-html-updatable-release), add keyword-argument 'version', pass on to import-html-release. * guix/import/gnu.scm(gnu->guix-package): Adjust function call. --- guix/gnu-maintenance.scm | 140 +++++++++++++++++++++++---------------- guix/import/gnu.scm | 2 +- 2 files changed, 84 insertions(+), 58 deletions(-) diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 8446a59fb5..ea3394e9e8 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -328,8 +328,9 @@ 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"))) @@ -400,8 +401,11 @@ 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 + (car (filter (lambda (r) (string=? version (upstream-source-version r))) + (coalesce-sources releases))) + (reduce latest-release #f + (coalesce-sources releases)))) (result (if (and result release) (latest-release release result) (or release result))) @@ -413,13 +417,15 @@ 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 + (import-ftp-release package + #:version version #:server server #:directory directory)) @@ -435,14 +441,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)))) @@ -467,8 +474,9 @@ 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) @@ -538,13 +546,17 @@ 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 + (car (filter (lambda (r) (string=? version (upstream-source-version r))) + (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))))))) ;;; @@ -576,46 +588,55 @@ 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. 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)." + + (define (find-latest-archive-version archives) + (fold (lambda (file1 file2) + (if (and file2 + (version>? (tarball-sans-extension (basename file2)) + (tarball-sans-extension (basename file1)))) + file2 + file1)) + #f + archives)) + (let-values (((server directory) (ftp-server/directory package)) ((name) (package-upstream-name package))) (let* ((files (ftp.gnu.org-files)) + ;; select archives 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/")))) - tarballs)) - (signature-urls (map (cut string-append <> ".sig") urls))))) - (() - #f))))) + files)) + ;; find latest version + (version (or version + (and (not (null? relevant)) + (tarball->version + (find-latest-archive-version relevant))))) + ;; find archives matching this version + (archives (filter (lambda (file) + (string=? version (tarball->version file))) + relevant))) + (match archives + (() #f) + (_ + (upstream-source + (package name) + (version version) + (urls (map (lambda (file) + (string-append "mirror://gnu/" + (string-drop file + (string-length "/gnu/")))) + archives)) + (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 @@ -668,7 +689,7 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." ;; HTML (unlike .) "https://nongnu.freemirror.org/nongnu") -(define (latest-savannah-release package) +(define* (import-savannah-release package #:key (version #f)) "Return the latest release of PACKAGE." (let* ((uri (string->uri (match (origin-uri (package-source package)) @@ -680,7 +701,8 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." "mirror://savannah"))) ;; Note: We use the default 'file->signature', which adds ".sig", ".asc", ;; or whichever detached signature naming scheme PACKAGE uses. - (and=> (latest-html-release package + (and=> (import-html-release package + #:version version #:base-url %savannah-base #:directory directory) (cut adjusted-upstream-source <> rewrite)))) @@ -744,21 +766,22 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." (when port (close-port port)))))) -(define (latest-xorg-release package) +(define* (import-xorg-release package #:key (version #f)) "Return the latest release of PACKAGE." (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) +(define* (import-kernel.org-release package #:key (version #f)) "Return the latest release of PACKAGE, the name of a kernel.org package." (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) @@ -772,7 +795,8 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." (directory (dirname (uri-path uri))) (rewrite (url-prefix-rewrite %kernel.org-base "mirror://kernel.org"))) - (and=> (latest-html-release package + (and=> (import-html-release package + #:version version #:base-url %kernel.org-base #:directory directory #:file->signature file->signature) @@ -801,7 +825,7 @@ 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." (let* ((uri (string->uri @@ -817,10 +841,12 @@ the directory containing its source tarball." "" (dirname (uri-path uri)))) (package (package-upstream-name package))) + (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) @@ -838,7 +864,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 @@ -849,14 +875,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 @@ -870,20 +896,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)))