From e318b62df361624e3bac70f658bcf5600ba5ca79 Mon Sep 17 00:00:00 2001 From: Attila Lendvai Date: Sat, 29 Jul 2023 14:02:37 +0200 Subject: ssh: Also print the user when authentication fails. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/ssh.scm (open-ssh-session): Show user in error message. Co-authored-by: Ludovic Courtès --- guix/ssh.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/ssh.scm b/guix/ssh.scm index b7b9807ebf..c4617d2c74 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -175,8 +175,9 @@ (define* (open-ssh-session host #:key user port identity (disconnect! session) (raise (condition (&message - (message (format #f (G_ "SSH authentication failed for '~a': ~a~%") - host (get-error session))))))))))) + (message (format #f (G_ "SSH authentication failed for '~a@~a': ~a~%") + (session-get session 'user) host + (get-error session))))))))))) (x ;; Connection failed or timeout expired. (raise (formatted-message (G_ "SSH connection to '~a' failed: ~a~%") -- cgit v1.2.3 From 91c8bd01f8e0b09f561d1021462ef99409ce87c8 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Wed, 9 Aug 2023 13:59:14 -0400 Subject: download: Add mirrors for Qt. * guix/download.scm (%mirrors): Augment with qt mirrors. Series-changes: 2 - Move authoritative mirror last, as it's too slow. --- guix/download.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/download.scm b/guix/download.scm index 30d7c5a86e..ce6ebd0df8 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -358,7 +358,15 @@ (define %mirrors "https://mirror.esc7.net/pub/OpenBSD/") (mate "https://pub.mate-desktop.org/releases/" - "http://pub.mate-desktop.org/releases/")))) + "http://pub.mate-desktop.org/releases/") + (qt + "https://mirrors.ocf.berkeley.edu/qt/official_releases/" + "https://ftp.jaist.ac.jp/pub/qtproject/official_releases/" + "https://ftp.nluug.nl/languages/qt/official_releases/" + "https://mirrors.cloud.tencent.com/qt/official_releases/" + "https://mirrors.sjtug.sjtu.edu.cn/qt/official_releases/" + "https://qtproject.mirror.liquidtelecom.com/official_releases/" + "https://download.qt.io/official_releases/")))) ;slow (define %mirror-file ;; Copy of the list of mirrors to a file. This allows us to keep a single -- cgit v1.2.3 From c655231b72ac28b5a433069fcf86a835c9c83691 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Mon, 21 Aug 2023 16:20:54 -0400 Subject: gnu-maintenance: Improve check for disabled host names. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Found while investigating . * guix/gnu-maintenance.scm (html-updatable-package?): Tighten predicate. Reviewed-by: Ludovic Courtès --- guix/gnu-maintenance.scm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 32712f7218..5c16a7617d 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -846,7 +846,11 @@ (define http-url? (let ((scheme (uri-scheme uri)) (host (uri-host uri))) (and (memq scheme '(http https)) - (not (member host hosting-sites))))))))) + ;; HOST may contain prefixes, + ;; e.g. "profanity-im.github.io", hence the + ;; suffix-based test below. + (not (any (cut string-suffix? <> host) + hosting-sites))))))))) (lambda (package) (or (assoc-ref (package-properties package) 'release-monitoring-url) -- cgit v1.2.3 From 5898b2e8a3dbf7797e83b39a2783c5b543015725 Mon Sep 17 00:00:00 2001 From: Janneke Nieuwenhuizen Date: Thu, 22 Jun 2023 08:30:25 +0200 Subject: self: Build gnu/packages/*.go in 26 steps. Similar to the Makefile.am change, this breaks-up gnu/packages into 26 chunks when building on 32bit. Also force garbage collection. * guix/self.scm (compiled-modules)[process-directory]: Split building of "gnu/packages" into 26 chunks. --- guix/self.scm | 33 ++++++++++++++++++++++++++------- 1 file changed, 26 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 81a36e007f..239727dfa8 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017-2023 Ludovic Courtès ;;; Copyright © 2020 Martin Becze +;;; Copyright © 2023 Janneke Nieuwenhuizen ;;; ;;; This file is part of GNU Guix. ;;; @@ -1210,9 +1211,12 @@ (define build '((guix build compile) (guix build utils))) #~(begin - (use-modules (srfi srfi-26) + (use-modules (srfi srfi-1) + (srfi srfi-26) + (srfi srfi-71) (ice-9 match) (ice-9 format) + (ice-9 regex) (ice-9 threads) (guix build compile) (guix build utils)) @@ -1244,12 +1248,27 @@ (define (report-compilation file total completed) (force-output)) (define (process-directory directory files output) - ;; Hide compilation warnings. - (parameterize ((current-warning-port (%make-void-port "w"))) - (compile-files directory #$output files - #:workers (parallel-job-count) - #:report-load report-load - #:report-compilation report-compilation))) + ;; Split gnu/packages in 26 chunks to avoid OOM errors + (let* ((chunks (map (compose + (cute partition <> files) + (lambda (regex) + (cute string-match regex <>)) + (cute string-append "^gnu/packages/" <>) + (cute make-string 1 <>) + integer->char + (cute + (char->integer #\a) <>)) + (iota 26))) + (chunks (filter pair? chunks))) + (for-each + (lambda (chunck) + ;; Hide compilation warnings. + (parameterize ((current-warning-port (%make-void-port "w"))) + (compile-files directory #$output chunck + #:workers (parallel-job-count) + #:report-load report-load + #:report-compilation report-compilation)) + (gc)) + chunks))) (setvbuf (current-output-port) 'line) (setvbuf (current-error-port) 'line) -- cgit v1.2.3 From f4d0d0bd5e7d0e67281d84d81068f7fd5eb480ea Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 22 Aug 2023 23:46:05 +0200 Subject: Revert "self: Build gnu/packages/*.go in 26 steps." This reverts commit 5898b2e8a3dbf7797e83b39a2783c5b543015725, which led to Guix where many .go files would be missing, as reported in . --- guix/self.scm | 33 +++++++-------------------------- 1 file changed, 7 insertions(+), 26 deletions(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 239727dfa8..81a36e007f 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -1,7 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017-2023 Ludovic Courtès ;;; Copyright © 2020 Martin Becze -;;; Copyright © 2023 Janneke Nieuwenhuizen ;;; ;;; This file is part of GNU Guix. ;;; @@ -1211,12 +1210,9 @@ (define build '((guix build compile) (guix build utils))) #~(begin - (use-modules (srfi srfi-1) - (srfi srfi-26) - (srfi srfi-71) + (use-modules (srfi srfi-26) (ice-9 match) (ice-9 format) - (ice-9 regex) (ice-9 threads) (guix build compile) (guix build utils)) @@ -1248,27 +1244,12 @@ (define (report-compilation file total completed) (force-output)) (define (process-directory directory files output) - ;; Split gnu/packages in 26 chunks to avoid OOM errors - (let* ((chunks (map (compose - (cute partition <> files) - (lambda (regex) - (cute string-match regex <>)) - (cute string-append "^gnu/packages/" <>) - (cute make-string 1 <>) - integer->char - (cute + (char->integer #\a) <>)) - (iota 26))) - (chunks (filter pair? chunks))) - (for-each - (lambda (chunck) - ;; Hide compilation warnings. - (parameterize ((current-warning-port (%make-void-port "w"))) - (compile-files directory #$output chunck - #:workers (parallel-job-count) - #:report-load report-load - #:report-compilation report-compilation)) - (gc)) - chunks))) + ;; Hide compilation warnings. + (parameterize ((current-warning-port (%make-void-port "w"))) + (compile-files directory #$output files + #:workers (parallel-job-count) + #:report-load report-load + #:report-compilation report-compilation))) (setvbuf (current-output-port) 'line) (setvbuf (current-error-port) 'line) -- cgit v1.2.3 From 738b0e4ccc2bac3d77bb29dd6d51026d887d6b16 Mon Sep 17 00:00:00 2001 From: Nicolas Goaziou Date: Thu, 24 Aug 2023 16:03:18 +0200 Subject: guix: profiles: Detect TeX Live packages propagated from non-TeX Live inputs. This fixes . * guix/profiles.scm (texlive-font-maps): Also check for TeX Live dependencies in non "texlive-" prefixed packages. For example, PYTHON-NBCONVERT propagates TeX Live inputs. Those need to be found out when building ".map"" files. Co-authored-by: Andreas Enge --- guix/profiles.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 2bd6477cf8..fea766879d 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1786,7 +1786,7 @@ (define entry->texlive-input (if (string-prefix? "texlive-" name) (cons (gexp-input thing output) (append-map entry->texlive-input deps)) - '())))) + (append-map entry->texlive-input deps))))) (define texlive-scripts-entry? (match-lambda (($ name version output thing deps) -- cgit v1.2.3 From d57cab764122af69d52d8cc9c843456044e5d7bc Mon Sep 17 00:00:00 2001 From: Josselin Poiret Date: Thu, 27 Jul 2023 18:28:18 +0200 Subject: image: Add mbr-raw-image-type and use by default. * gnu/system/image.scm (mbr-disk-image, mbr-raw-image-type): New variables. (qcow2-image-type): Inherit mbr-disk-image. * guix/scripts/system.scm (%default-options): Use mbr-raw-image-type by default. * gnu/tests/install.scm (run-install): Use mbr-raw in the tests. * doc/guix-cookbook.texi (Guix System Image API): Update the list of image types. * doc/guix.texi (Invoking guix system, System Images, image-type Reference): Add mbr-raw and switch documented default to it. --- doc/guix-cookbook.texi | 12 +++++++++--- doc/guix.texi | 16 ++++++++++------ gnu/system/image.scm | 19 +++++++++++++++++-- gnu/tests/install.scm | 4 ++-- guix/scripts/system.scm | 2 +- 5 files changed, 39 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/doc/guix-cookbook.texi b/doc/guix-cookbook.texi index 87430b741a..e90d611171 100644 --- a/doc/guix-cookbook.texi +++ b/doc/guix-cookbook.texi @@ -2019,17 +2019,23 @@ One can run: mathieu@@cervin:~$ guix system --list-image-types The available image types are: + - unmatched-raw + - rock64-raw - pinebook-pro-raw - pine64-raw - novena-raw - hurd-raw - hurd-qcow2 - qcow2 + - iso9660 - uncompressed-iso9660 + - tarball - efi-raw - - arm64-raw - - arm32-raw - - iso9660 + - mbr-raw + - docker + - wsl2 + - raw-with-offset + - efi32-raw @end example and by writing an @code{operating-system} file based on diff --git a/doc/guix.texi b/doc/guix.texi index e8c67b0cd8..f03a88482e 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -40884,7 +40884,7 @@ QEMU monitor and the VM. @cindex image, creating disk images The @code{image} command can produce various image types. The image type can be selected using the @option{--image-type} option. It -defaults to @code{efi-raw}. When its value is @code{iso9660}, the +defaults to @code{mbr-raw}. When its value is @code{iso9660}, the @option{--label} option can be used to specify a volume ID with @code{image}. By default, the root file system of a disk image is mounted non-volatile; the @option{--volatile} option can be provided to @@ -40903,7 +40903,7 @@ qemu-system-x86_64 -enable-kvm -hda /tmp/my-image.qcow2 -m 1000 \ -bios $(guix build ovmf)/share/firmware/ovmf_x64.bin @end example -When using the @code{efi-raw} image type, a raw disk image is produced; +When using the @code{mbr-raw} image type, a raw disk image is produced; it can be copied as is to a USB stick, for instance. Assuming @code{/dev/sdc} is the device corresponding to a USB stick, one can copy the image to it using the following command: @@ -41041,7 +41041,7 @@ of the image. For the @code{image} action, create an image with given @var{type}. When this option is omitted, @command{guix system} uses the -@code{efi-raw} image type. +@code{mbr-raw} image type. @cindex ISO-9660 format @cindex CD image format @@ -45193,7 +45193,7 @@ then directly boot from it, without any kind of installation procedure. The @command{guix system image} command is able to turn an operating system definition into a bootable image. This command supports -different image types, such as @code{efi-raw}, @code{iso9660} and +different image types, such as @code{mbr-raw}, @code{iso9660} and @code{docker}. Any modern @code{x86_64} machine will probably be able to boot from an @code{iso9660} image. However, there are a few machines out there that require specific image types. Those machines, in general @@ -45545,6 +45545,10 @@ record. There are several @code{image-type} records provided by the @code{(gnu system image)} and the @code{(gnu system images @dots{})} modules. +@defvar mbr-raw-image-type +Build an image based on the @code{mbr-disk-image} image. +@end defvar + @defvar efi-raw-image-type Build an image based on the @code{efi-disk-image} image. @end defvar @@ -45554,7 +45558,7 @@ Build an image based on the @code{efi32-disk-image} image. @end defvar @defvar qcow2-image-type -Build an image based on the @code{efi-disk-image} image but with the +Build an image based on the @code{mbr-disk-image} image but with the @code{compressed-qcow2} image format. @end defvar @@ -45625,7 +45629,7 @@ wsl -d Guix So, if we get back to the @code{guix system image} command taking an @code{operating-system} declaration as argument. By default, the -@code{efi-raw-image-type} is used to turn the provided +@code{mbr-raw-image-type} is used to turn the provided @code{operating-system} into an actual bootable image. To use a different @code{image-type}, the @code{--image-type} option can diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 841e7e0c7e..5b8da2f896 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -76,6 +76,7 @@ (define-module (gnu system image) esp32-partition root-partition + mbr-disk-image efi-disk-image iso9660-image docker-image @@ -84,6 +85,7 @@ (define-module (gnu system image) raw-with-offset-disk-image image-with-os + mbr-raw-image-type efi-raw-image-type efi32-raw-image-type qcow2-image-type @@ -145,6 +147,15 @@ (define root-partition (flags '(boot)) (initializer (gexp initialize-root-partition)))) +(define mbr-disk-image + (image-without-os + (format 'disk-image) + (partition-table-type 'mbr) + (partitions + (list (partition + (inherit root-partition) + (offset root-offset)))))) + (define efi-disk-image (image-without-os (format 'disk-image) @@ -201,6 +212,11 @@ (define-syntax-rule (image-with-os base-image os) (inherit base-image) (operating-system os))) +(define mbr-raw-image-type + (image-type + (name 'mbr-raw) + (constructor (cut image-with-os mbr-disk-image <>)))) + (define efi-raw-image-type (image-type (name 'efi-raw) @@ -216,8 +232,7 @@ (define qcow2-image-type (name 'qcow2) (constructor (cut image-with-os (image - (inherit efi-disk-image) - (partition-table-type 'mbr) + (inherit mbr-disk-image) (name 'image.qcow2) (format 'compressed-qcow2)) <>)))) diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm index 0f4204d1a6..daa4647299 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.scm @@ -229,7 +229,7 @@ (define* (run-install target-os target-os-source (gnu installer tests) (guix combinators)))) (uefi-support? #f) - (installation-image-type 'efi-raw) + (installation-image-type 'mbr-raw) (install-size 'guess) (target-size (* 2200 MiB)) (number-of-disks 1)) @@ -291,7 +291,7 @@ (define marionette '("-bios" #$uefi-firmware) '()) #$@(cond - ((eq? 'efi-raw installation-image-type) + ((eq? 'mbr-raw installation-image-type) #~("-drive" ,(string-append "file=" #$image ",if=virtio,readonly"))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index acbe3dab2c..ec331809ef 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1169,7 +1169,7 @@ (define %default-options (debug . 0) (verbosity . #f) ;default (validate-reconfigure . ,ensure-forward-reconfigure) - (image-type . efi-raw) + (image-type . mbr-raw) (image-size . guess) (install-bootloader? . #t) (label . #f) -- cgit v1.2.3 From 106ad23ae44c34f275b8857cfdac2356d5962e6a Mon Sep 17 00:00:00 2001 From: Josselin Poiret Date: Fri, 25 Aug 2023 14:24:43 +0200 Subject: graph: Add GraphML backend. * guix/graph.scm (emit-graphml-prologue, emit-graphml-epilogue, emit-graphml-node, emit-graphml-edge): New procedures. (%graphml-backend): New variable. (%graph-backends): Add %graphml-backend. --- guix/graph.scm | 36 +++++++++++++++++++++++++++++++++++- 1 file changed, 35 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/graph.scm b/guix/graph.scm index aee0021d6c..9f1111a0ae 100644 --- a/guix/graph.scm +++ b/guix/graph.scm @@ -29,6 +29,7 @@ (define-module (guix graph) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (ice-9 match) + #:use-module (ice-9 string-fun) #:use-module (ice-9 vlist) #:export (node-type node-type? @@ -49,6 +50,7 @@ (define-module (guix graph) %graph-backends %d3js-backend %graphviz-backend + %graphml-backend lookup-backend graph-backend? @@ -328,6 +330,37 @@ (define %cypher-backend emit-cypher-prologue emit-cypher-epilogue emit-cypher-node emit-cypher-edge)) + +;;; +;;; GraphML export. +;;; + +(define (emit-graphml-prologue name port) + (format port " + + ~%")) + +(define (emit-graphml-epilogue port) + (format port " +")) + +(define (emit-graphml-node id label port) + (format port " ~%" + (string-replace-substring (object->string id) "\"" "\\\""))) + +(define (emit-graphml-edge id1 id2 port) + (format port " ~%" + (string-replace-substring (object->string id1) "\"" "\\\"") + (string-replace-substring (object->string id2) "\"" "\\\""))) + +(define %graphml-backend + (graph-backend "graphml" + "Generate GraphML." + emit-graphml-prologue emit-graphml-epilogue + emit-graphml-node emit-graphml-edge)) ;;; @@ -337,7 +370,8 @@ (define %cypher-backend (define %graph-backends (list %graphviz-backend %d3js-backend - %cypher-backend)) + %cypher-backend + %graphml-backend)) (define (lookup-backend name) "Return the graph backend called NAME. Raise an error if it is not found." -- cgit v1.2.3 From 4110cc4f75997ff01318414e764aedd15610fab8 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Wed, 9 Aug 2023 13:35:03 -0400 Subject: gnu-maintenance: Make base-url argument of import-html-release required. It doesn't make sense to have it default to something like "https://kernel.org/pub"; it should always be provided explicitly. * guix/gnu-maintenance.scm (import-html-release) <#:base-url>: Turn keyword argument into a positional argument. Update doc. * guix/gnu-maintenance.scm (import-savannah-release): Adjust call accordingly. (import-kernel.org-release): Likewise. (import-html-updatable-release): Likewise. --- guix/gnu-maintenance.scm | 18 +++++++----------- 1 file changed, 7 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 5c16a7617d..198d72fc86 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -483,15 +483,14 @@ (define (html-links sxml) (_ links)))) -(define* (import-html-release package +(define* (import-html-release base-url 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. Optionally include a VERSION string to fetch a -specific version. + "Return an for the latest release of PACKAGE (a string) +under DIRECTORY at BASE-URL, 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'. @@ -730,9 +729,8 @@ (define* (import-savannah-release package #:key (version #f)) (directory (dirname (uri-path uri)))) ;; Note: We use the default 'file->signature', which adds ".sig", ".asc", ;; or whichever detached signature naming scheme PACKAGE uses. - (import-html-release package + (import-html-release %savannah-base package #:version version - #:base-url %savannah-base #:directory directory))) (define* (latest-sourceforge-release package #:key (version #f)) @@ -824,9 +822,8 @@ (define (file->signature file) ((uri mirrors ...) uri)))) (package (package-upstream-name package)) (directory (dirname (uri-path uri)))) - (import-html-release package + (import-html-release %kernel.org-base package #:version version - #:base-url %kernel.org-base #:directory directory #:file->signature file->signature))) @@ -874,9 +871,8 @@ (define* (import-html-updatable-release package #:key (version #f)) (dirname (uri-path uri)))) (package (package-upstream-name package))) (false-if-networking-error - (import-html-release package + (import-html-release base package #:version version - #:base-url base #:directory directory)))) (define %gnu-updater -- cgit v1.2.3 From 610d0e30e079582c73ed8f995630ef7a71d559e7 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Wed, 9 Aug 2023 14:54:04 -0400 Subject: gnu-maintenance: Fix docstring. * guix/gnu-maintenance.scm (import-kernel.org-release): Fix docstring. --- guix/gnu-maintenance.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 198d72fc86..6db0dd952c 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -489,7 +489,7 @@ (define* (import-html-release base-url package (directory (string-append "/" package)) file->signature) "Return an for the latest release of PACKAGE (a string) -under DIRECTORY at BASE-URL, or #f. Optionally include a VERSION string to +under DIRECTORY at BASE-URL, 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 @@ -806,7 +806,7 @@ (define* (import-xorg-release package #:key (version #f)) (string-append "/pub/xorg/" (dirname (uri-path uri))))))) (define* (import-kernel.org-release package #:key (version #f)) - "Return the latest release of PACKAGE, the name of a kernel.org package. + "Return the latest release of PACKAGE, a Linux kernel 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 -- cgit v1.2.3 From f6cfc993acef3dad6985d12d8fc2e52334829b25 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Wed, 9 Aug 2023 22:40:01 -0400 Subject: gnu-maintenance: Extract url->links procedure. * guix/gnu-maintenance.scm (url->links): New procedure. (import-html-release): Use it. --- guix/gnu-maintenance.scm | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 6db0dd952c..fc9cf50f29 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -483,6 +483,14 @@ (define (html-links sxml) (_ links)))) +(define (url->links url) + "Return the unique links on the HTML page accessible at URL." + (let* ((uri (string->uri url)) + (port (http-fetch/cached uri #:ttl 3600)) + (sxml (html->sxml port))) + (close-port port) + (delete-duplicates (html-links sxml)))) + (define* (import-html-release base-url package #:key (version #f) @@ -499,12 +507,10 @@ (define* (import-html-release base-url package if any. Otherwise, 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." - (let* ((uri (string->uri (if (string-null? directory) - base-url - (string-append base-url directory "/")))) - (port (http-fetch/cached uri #:ttl 3600)) - (sxml (html->sxml port)) - (links (delete-duplicates (html-links sxml)))) + (let* ((url (if (string-null? directory) + base-url + (string-append base-url directory "/"))) + (links (url->links url))) (define (file->signature/guess url) (let ((base (basename url))) (any (lambda (link) @@ -562,7 +568,6 @@ (define (url->release url) (define candidates (filter-map url->release links)) - (close-port port) (match candidates (() #f) ((first . _) -- cgit v1.2.3 From a5e67dec2a73ce0d8886a90fc703f7eaa2bc0fa3 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Wed, 9 Aug 2023 22:41:20 -0400 Subject: gnu-maintenance: Fix indentation. * guix/gnu-maintenance.scm: Re-indent file. --- guix/gnu-maintenance.scm | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index fc9cf50f29..30792db60f 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -578,11 +578,11 @@ (define candidates (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))))))) + (if (version>? (upstream-source-version r1) + (upstream-source-version r2)) + r1 r2)) + first + (coalesce-sources candidates))))))) ;;; @@ -656,20 +656,20 @@ (define (find-latest-tarball-version tarballs) (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)))))))) + (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)))))))) (define %package-name-rx ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses -- cgit v1.2.3 From c6b5eeac92d023195f5c4adae248f2e540a09d64 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Wed, 9 Aug 2023 22:53:03 -0400 Subject: gnu-maintenance: Accept package object in 'import-html-release' procedure. This is in preparation for a new URL rewriting feature, which will need to have the current version information available. * guix/gnu-maintenance.scm (import-html-release): Update doc. Adjust default value of the DIRECTORY argument. Bind PACKAGE in lexical scope so that its value there is unchanged. (import-savannah-release, import-kernel.org-release) (import-html-updatable-release): Adjust accordingly. --- guix/gnu-maintenance.scm | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 30792db60f..eea75095b5 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -494,11 +494,12 @@ (define (url->links url) (define* (import-html-release base-url package #:key (version #f) - (directory (string-append "/" package)) + (directory (string-append + "/" (package-upstream-name package))) file->signature) - "Return an for the latest release of PACKAGE (a string) -under DIRECTORY at BASE-URL, or #f. Optionally include a VERSION string to -fetch a specific version. + "Return an for the latest release of PACKAGE under +DIRECTORY at BASE-URL, 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'. @@ -507,7 +508,8 @@ (define* (import-html-release base-url package if any. Otherwise, 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." - (let* ((url (if (string-null? directory) + (let* ((package (package-upstream-name package)) + (url (if (string-null? directory) base-url (string-append base-url directory "/"))) (links (url->links url))) @@ -730,7 +732,6 @@ (define* (import-savannah-release package #:key (version #f)) (match (origin-uri (package-source package)) ((? string? uri) uri) ((uri mirrors ...) uri)))) - (package (package-upstream-name package)) (directory (dirname (uri-path uri)))) ;; Note: We use the default 'file->signature', which adds ".sig", ".asc", ;; or whichever detached signature naming scheme PACKAGE uses. @@ -825,7 +826,6 @@ (define (file->signature file) (match (origin-uri (package-source package)) ((? string? uri) uri) ((uri mirrors ...) uri)))) - (package (package-upstream-name package)) (directory (dirname (uri-path uri)))) (import-html-release %kernel.org-base package #:version version @@ -873,8 +873,7 @@ (define* (import-html-updatable-release package #:key (version #f)) "://" (uri-host uri)))) (directory (if custom "" - (dirname (uri-path uri)))) - (package (package-upstream-name package))) + (dirname (uri-path uri))))) (false-if-networking-error (import-html-release base package #:version version -- cgit v1.2.3 From 265423266084e75877fa758691276b368e61da0a Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Thu, 10 Aug 2023 12:06:05 -0400 Subject: gnu-maintenance: Document nested procedures in 'import-html-release'. * guix/gnu-maintenance.scm (import-html-release): Add docstring to the 'file->signature/guess' and 'url->release' nested procedures. --- guix/gnu-maintenance.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index eea75095b5..6f08e2e295 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -514,6 +514,7 @@ (define* (import-html-release base-url package (string-append base-url directory "/"))) (links (url->links url))) (define (file->signature/guess url) + "Return the first link that matches a signature extension, else #f." (let ((base (basename url))) (any (lambda (link) (any (lambda (extension) @@ -524,6 +525,8 @@ (define (file->signature/guess url) links))) (define (url->release url) + "Return an object if a release file was found at URL, +else #f." (let* ((base (basename url)) (base-url (string-append base-url directory)) (url (cond ((and=> (string->uri url) uri-scheme) ;full URL? @@ -574,7 +577,7 @@ (define candidates (() #f) ((first . _) (if version - ;; find matching release version and return it + ;; Find matching release version and return it. (find (lambda (upstream) (string=? (upstream-source-version upstream) version)) (coalesce-sources candidates)) -- cgit v1.2.3 From 6fb8cc312dcf561817c99eced8c8d58d38e0150a Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Thu, 10 Aug 2023 16:54:52 -0400 Subject: gnu-maintenance: Extract 'canonicalize-url' from 'import-html-release'. * guix/gnu-maintenance.scm (canonicalize-url): New procedure, extracted from... (import-html-release): ... here. Use it. Rename inner PACKAGE variable to NAME, to explicit it is a string and not a package object. --- guix/gnu-maintenance.scm | 70 +++++++++++++++++++++++------------------------- 1 file changed, 34 insertions(+), 36 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 6f08e2e295..9eff98217e 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -491,6 +491,33 @@ (define (url->links url) (close-port port) (delete-duplicates (html-links sxml)))) +(define (canonicalize-url url base-url) + "Make relative URL absolute, by appending URL to BASE-URL as required. If +URL is a directory instead of a file, it should be suffixed with a slash (/)." + (cond ((and=> (string->uri url) uri-scheme) + ;; Fully specified URL. + url) + ((string-prefix? "//" url) + ;; Full URL lacking a URI scheme. Reuse the URI scheme of the + ;; document that contains the URL. + (string-append (symbol->string (uri-scheme (string->uri base-url))) + ":" url)) + ((string-prefix? "/" url) + ;; Absolute URL. + (let ((uri (string->uri base-url))) + (uri->string + (build-uri (uri-scheme uri) + #:host (uri-host uri) + #:port (uri-port uri) + #:path url)))) + ;; URL is relative to BASE-URL, which is assumed to be a directory. + ((string-suffix? "/" base-url) + (string-append base-url url)) + (else + ;; URL is relative to BASE-URL, which is assumed to denote a file + ;; within a directory. + (string-append (dirname base-url) "/" url)))) + (define* (import-html-release base-url package #:key (version #f) @@ -508,11 +535,12 @@ (define* (import-html-release base-url package if any. Otherwise, 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." - (let* ((package (package-upstream-name package)) + (let* ((name (package-upstream-name package)) (url (if (string-null? directory) base-url (string-append base-url directory "/"))) - (links (url->links url))) + (links (map (cut canonicalize-url <> url) (url->links url)))) + (define (file->signature/guess url) "Return the first link that matches a signature extension, else #f." (let ((base (basename url))) @@ -526,42 +554,12 @@ (define (file->signature/guess url) (define (url->release url) "Return an object if a release file was found at URL, -else #f." - (let* ((base (basename url)) - (base-url (string-append base-url directory)) - (url (cond ((and=> (string->uri url) uri-scheme) ;full URL? - url) - ;; full URL, except for URI scheme. Reuse the URI - ;; scheme of the document that contains the link. - ((string-prefix? "//" url) - (string-append - (symbol->string (uri-scheme (string->uri base-url))) - ":" url)) - ((string-prefix? "/" url) ;absolute path? - (let ((uri (string->uri base-url))) - (uri->string - (build-uri (uri-scheme uri) - #:host (uri-host uri) - #:port (uri-port uri) - #:path url)))) - - ;; URL is a relative path and BASE-URL may or may not - ;; end in slash. - ((string-suffix? "/" base-url) - (string-append base-url url)) - (else - ;; If DIRECTORY is non-empty, assume BASE-URL - ;; denotes a directory; otherwise, assume BASE-URL - ;; denotes a file within a directory, and that URL - ;; is relative to that directory. - (string-append (if (string-null? directory) - (dirname base-url) - base-url) - "/" url))))) - (and (release-file? package base) +else #f. URL is assumed to fully specified." + (let ((base (basename url))) + (and (release-file? name base) (let ((version (tarball->version base))) (upstream-source - (package package) + (package name) (version version) ;; uri-mirror-rewrite: Don't turn nice mirror:// URIs into ftp:// ;; URLs during "guix refresh -u". -- cgit v1.2.3 From 6953fb924111c400a064255d8274a2caa68f7436 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Thu, 10 Aug 2023 11:42:22 -0400 Subject: gnu-maintenance: Add support to rewrite version in URL path. Fixes . Fixes . Previously, the generic HTML updater would only look for the list of files found at the parent of its current source URL, ignoring that the URL may embed the version elsewhere in its path. This could cause 'guix refresh' to report no updates available, while in fact there were, such as for 'libuv'. * guix/gnu-maintenance.scm (strip-trailing-slash): New procedure. (%version-rx): New variable. (rewrite-url): New procedure. (import-html-release): New rewrite-url? argument. When true, use the above procedure. (import-html-updatable-release): Call import-html-release with #:rewrite-url set to #t. * tests/gnu-maintenance.scm ("rewrite-url, to-version specified") ("rewrite-url, without to-version"): New tests. --- guix/gnu-maintenance.scm | 102 ++++++++++++++++++++++++++++++++++++++++++++-- tests/gnu-maintenance.scm | 43 +++++++++++++++++++ 2 files changed, 142 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 9eff98217e..228a84bd4b 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2012, 2013 Nikita Karetnikov ;;; Copyright © 2021 Simon Tournier ;;; Copyright © 2022 Maxime Devos +;;; Copyright © 2023 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,6 +27,7 @@ (define-module (guix gnu-maintenance) #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (rnrs io ports) @@ -61,6 +63,7 @@ (define-module (guix gnu-maintenance) gnu-package? uri-mirror-rewrite + rewrite-url release-file? releases @@ -518,9 +521,93 @@ (define (canonicalize-url url base-url) ;; within a directory. (string-append (dirname base-url) "/" url)))) +(define (strip-trailing-slash s) + "Strip any trailing slash from S, a string." + (if (string-suffix? "/" s) + (string-drop-right s 1) + s)) + +;;; TODO: Extend to support the RPM and GNOME version schemes? +(define %version-rx "[0-9.]+") + +(define* (rewrite-url url version #:key to-version) + "Rewrite URL so that the URL path components matching the current VERSION or +VERSION-MAJOR.VERSION-MINOR are updated with that of the latest version found +by crawling the corresponding URL directories. Alternatively, when TO-VERSION +is specified, rewrite version matches directly to it without crawling URL. + +For example, the URL +\"https://dist.libuv.org/dist/v1.45.0/libuv-v1.45.0.tar.gz\" could be +rewritten to something like +\"https://dist.libuv.org/dist/v1.46.0/libuv-v1.46.0.tar.gz\"." + ;; XXX: major-minor may be #f if version is not a triplet but a single + ;; number such as "2". + (let* ((major-minor (false-if-exception (version-major+minor version))) + (to-major-minor (false-if-exception + (and=> to-version version-major+minor))) + (uri (string->uri url)) + (url-prefix (string-drop-right url (string-length (uri-path uri)))) + (url-prefix-components (string-split url-prefix #\/)) + (path (uri-path uri)) + ;; Strip a forward slash on the path to avoid a double slash when + ;; string-joining later. + (path (if (string-prefix? "/" path) + (string-drop path 1) + path)) + (path-components (string-split path #\/))) + (string-join + (reverse + (fold + (lambda (s parents) + (if to-version + ;; Direct rewrite case; the archive is assumed to exist. + (let ((u (string-replace-substring s version to-version))) + (cons (if (and major-minor to-major-minor) + (string-replace-substring u major-minor to-major-minor) + u) + parents)) + ;; More involved HTML crawl case. + (let* ((pattern (if major-minor + (format #f "(~a|~a)" version major-minor) + (format #f "(~a)" version))) + (m (string-match pattern s))) + (if m + ;; Crawl parent and rewrite current component. + (let* ((parent-url (string-join (reverse parents) "/")) + (links (url->links parent-url)) + ;; The pattern matching the version. + (pattern (string-append "^" (match:prefix m) + "(" %version-rx ")" + (match:suffix m) "$")) + (candidates (filter-map + (lambda (l) + ;; Links may be followed by a + ;; trailing '/' in the case of + ;; directories. + (and-let* + ((l (strip-trailing-slash l)) + (m (string-match pattern l)) + (v (match:substring m 1))) + (cons v l))) + links))) + ;; Retrieve the item having the largest version. + (if (null? candidates) + (error "no candidates found in rewrite-url") + (cons (cdr (first (sort candidates + (lambda (x y) + (version>? (car x) + (car y)))))) + parents))) + ;; No version found in path component; continue. + (cons s parents))))) + (reverse url-prefix-components) + path-components)) + "/"))) + (define* (import-html-release base-url package #:key - (version #f) + rewrite-url? + version (directory (string-append "/" (package-upstream-name package))) file->signature) @@ -534,11 +621,19 @@ (define* (import-html-release base-url package 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 file URL and must return the corresponding signature URL, or #f it signatures -are unavailable." - (let* ((name (package-upstream-name package)) +are unavailable. + +When REWRITE-URL? is #t, versioned components in BASE-URL and/or DIRECTORY are +also updated to the latest version, as explained in the doc of the +\"rewrite-url\" procedure used." + (let* ((current-version (package-version package)) + (name (package-upstream-name package)) (url (if (string-null? directory) base-url (string-append base-url directory "/"))) + (url (if rewrite-url? + (rewrite-url url current-version #:to-version version) + url)) (links (map (cut canonicalize-url <> url) (url->links url)))) (define (file->signature/guess url) @@ -877,6 +972,7 @@ (define* (import-html-updatable-release package #:key (version #f)) (dirname (uri-path uri))))) (false-if-networking-error (import-html-release base package + #:rewrite-url? #t #:version version #:directory directory)))) diff --git a/tests/gnu-maintenance.scm b/tests/gnu-maintenance.scm index 516e02ec6a..196a6f9092 100644 --- a/tests/gnu-maintenance.scm +++ b/tests/gnu-maintenance.scm @@ -147,4 +147,47 @@ (define expected-signature-url (equal? (list expected-signature-url) (upstream-source-signature-urls update)))))) +(test-equal "rewrite-url, to-version specified" + "https://download.qt.io/official_releases/qt/6.5/6.5.2/\ +submodules/qtbase-everywhere-src-6.5.2.tar.xz" + (rewrite-url "https://download.qt.io/official_releases/qt/6.3/6.3.2/\ +submodules/qtbase-everywhere-src-6.3.2.tar.xz" "6.3.2" #:to-version "6.5.2")) + +(test-equal "rewrite-url, without to-version" + "https://dist.libuv.org/dist/v1.46.0/libuv-v1.46.0.tar.gz" + (with-http-server + ;; First reply, crawling https://dist.libuv.org/dist/. + `((200 "\ + + +Index of dist + +../ +v1.44.0/ +v1.44.1/ +v1.44.2/ +v1.45.0/ +v1.46.0/ + +") + ;; Second reply, crawling https://dist.libuv.org/dist/v1.46.0/. + (200 "\ + + +Index of dist/v1.46.0 + +../ + + libuv-v1.46.0-dist.tar.gz +libuv-v1.46.0-dist.tar.gz.sign + + libuv-v1.46.0.tar.gz + + libuv-v1.46.0.tar.gz.sign + +")) + (rewrite-url "https://dist.libuv.org/dist/v1.45.0/libuv-v1.45.0.tar.gz" + "1.45.0"))) + (test-end) -- cgit v1.2.3 From bdaef69556f68595e5ec0db1710bf8ad208abe20 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Fri, 11 Aug 2023 11:21:42 -0400 Subject: gnu-maintenance: Allow mirror URLs to fallback to the generic HTML updater. * guix/gnu-maintenance.scm (http-url?): Extract from html-updatable-package?, modify to return the HTTP URL, and support the mirror:// scheme. (%disallowed-hosting-sites): New variable, extracted from html-updatable-package. (html-updatable-package?): Rewrite a mirror:// URL to an HTTP or HTTPS one. * guix/download.scm (%mirrors): Update comment. --- guix/download.scm | 5 +++- guix/gnu-maintenance.scm | 65 +++++++++++++++++++++++++++++------------------- 2 files changed, 44 insertions(+), 26 deletions(-) (limited to 'guix') diff --git a/guix/download.scm b/guix/download.scm index ce6ebd0df8..31a41e8183 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -51,7 +51,10 @@ (define-module (guix download) ;;; Code: (define %mirrors - ;; Mirror lists used when `mirror://' URLs are passed. + ;; Mirror lists used when `mirror://' URLs are passed. The first mirror + ;; entry of each set should ideally be the most authoritative one, as that's + ;; what the generic HTML updater will pick to look for updates, with + ;; possible exceptions when the authoritative mirror is too slow. (let* ((gnu-mirrors '(;; This one redirects to a (supposedly) nearby and (supposedly) ;; up-to-date mirror. diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 228a84bd4b..eb30b7874f 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -928,31 +928,43 @@ (define (file->signature file) #:directory directory #:file->signature file->signature))) -(define html-updatable-package? - ;; Return true if the given package may be handled by the generic HTML - ;; updater. - (let ((hosting-sites '("github.com" "github.io" "gitlab.com" - "notabug.org" "sr.ht" "gitlab.inria.fr" - "ftp.gnu.org" "download.savannah.gnu.org" - "pypi.org" "crates.io" "rubygems.org" - "bioconductor.org"))) - (define http-url? - (url-predicate (lambda (url) - (match (string->uri url) - (#f #f) - (uri - (let ((scheme (uri-scheme uri)) - (host (uri-host uri))) - (and (memq scheme '(http https)) - ;; HOST may contain prefixes, - ;; e.g. "profanity-im.github.io", hence the - ;; suffix-based test below. - (not (any (cut string-suffix? <> host) - hosting-sites))))))))) - - (lambda (package) - (or (assoc-ref (package-properties package) 'release-monitoring-url) - (http-url? package))))) +;;; These sites are disallowed for the generic HTML updater as there are +;;; better means to query them. +(define %disallowed-hosting-sites + '("github.com" "github.io" "gitlab.com" + "notabug.org" "sr.ht" "gitlab.inria.fr" + "ftp.gnu.org" "download.savannah.gnu.org" + "pypi.org" "crates.io" "rubygems.org" + "bioconductor.org")) + +(define (http-url? url) + "Return URL if URL has HTTP or HTTPS as its protocol. If URL uses the +special mirror:// protocol, substitute it with the first HTTP or HTTPS URL +prefix from its set." + (match (string->uri url) + (#f #f) + (uri + (let ((scheme (uri-scheme uri)) + (host (uri-host uri))) + (or (and (memq scheme '(http https)) + ;; HOST may contain prefixes, e.g. "profanity-im.github.io", + ;; hence the suffix-based test below. + (not (any (cut string-suffix? <> host) + %disallowed-hosting-sites)) + url) + (and (eq? scheme 'mirror) + (and=> (find http-url? + (assoc-ref %mirrors + (string->symbol host))) + (lambda (url) + (string-append (strip-trailing-slash url) + (uri-path uri)))))))))) + +(define (html-updatable-package? package) + "Return true if the given package may be handled by the generic HTML +updater." + (or (assoc-ref (package-properties package) 'release-monitoring-url) + ((url-predicate http-url?) package))) (define* (import-html-updatable-release package #:key (version #f)) "Return the latest release of PACKAGE. Do that by crawling the HTML page of @@ -960,6 +972,9 @@ (define* (import-html-updatable-release package #:key (version #f)) string to fetch a specific version." (let* ((uri (string->uri (match (origin-uri (package-source package)) + ((? (cut string-prefix? "mirror://" <>) url) + ;; Retrieve the authoritative HTTP URL from a mirror. + (http-url? url)) ((? string? url) url) ((url _ ...) url)))) (custom (assoc-ref (package-properties package) -- cgit v1.2.3 From 1dce88777691b7a38ad66ba58b17a9b368c11e07 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Fri, 11 Aug 2023 13:44:28 -0400 Subject: gnu-maintenance: Consider Qt source tarballs as "release files". * guix/gnu-maintenance.scm (release-file?): Use positive logic in doc. Add a special case for Qt source archives. * tests/gnu-maintenance.scm ("release-file?"): Update test. --- guix/gnu-maintenance.scm | 18 +++++++++++++----- tests/gnu-maintenance.scm | 5 ++++- 2 files changed, 17 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index eb30b7874f..ee6e0db747 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -258,8 +258,7 @@ (define %alpha-tarball-rx (make-regexp "^.*-.*[0-9](-|~|\\.)?(alpha|beta|rc|RC|cvs|svn|git)-?[0-9\\.]*\\.tar\\.")) (define (release-file? project file) - "Return #f if FILE is not a release tarball of PROJECT, otherwise return -true." + "Return true if FILE is a release tarball of PROJECT." (and (not (member (file-extension file) '("sig" "sign" "asc" "md5sum" "sha1sum" "sha256sum"))) @@ -268,12 +267,21 @@ (define (release-file? project file) ;; Filter out unrelated files, like `guile-www-1.1.1'. ;; Case-insensitive for things like "TeXmacs" vs. "texmacs". ;; The "-src" suffix is for "freefont-src-20120503.tar.gz". + ;; The '-everywhere-src' suffix is for Qt modular components. (and=> (match:substring match 1) (lambda (name) (or (string-ci=? name project) - (string-ci=? name - (string-append project - "-src"))))))) + (string-ci=? name (string-append project "-src")) + (string-ci=? + name (string-append project "-everywhere-src")) + ;; For older Qt releases such as version 5. + (string-ci=? + name (string-append + project "-everywhere-opensource-src")) + ;; For Qt Creator. + (string-ci=? + name (string-append + project "-opensource-src"))))))) (not (regexp-exec %alpha-tarball-rx file)) (let ((s (tarball-sans-extension file))) (regexp-exec %package-name-rx s)))) diff --git a/tests/gnu-maintenance.scm b/tests/gnu-maintenance.scm index 196a6f9092..61ae295b96 100644 --- a/tests/gnu-maintenance.scm +++ b/tests/gnu-maintenance.scm @@ -40,7 +40,10 @@ (define-module (test-gnu-maintenance) ("exiv2" "exiv2-0.27.3-Source.tar.gz") ("mpg321" "mpg321_0.3.2.orig.tar.gz") ("bvi" "bvi-1.4.1.src.tar.gz") - ("hostscope" "hostscope-V2.1.tgz"))) + ("hostscope" "hostscope-V2.1.tgz") + ("qtbase" "qtbase-everywhere-src-6.5.2.tar.xz") + ("qtbase" "qtbase-everywhere-opensource-src-5.15.10.tar.xz") + ("qt-creator" "qt-creator-opensource-src-11.0.1.tar.xz"))) (every (lambda (project+file) (not (apply release-file? project+file))) '(("guile" "guile-www-1.1.1.tar.gz") -- cgit v1.2.3