Merge branch 'staging' into core-updates

Conflicts resolved in: gnu/local.mk gnu/packages/cran.scm gnu/packages/gnome.scm gnu/packages/gtk.scm gnu/packages/icu4c.scm gnu/packages/java.scm gnu/packages/machine-learning.scm gnu/packages/tex.scm
author: Maxim Cournoyer <[email protected]> 2022-09-27 15:59:30 -0400
committer: Maxim Cournoyer <[email protected]> 2022-09-27 15:59:30 -0400
commit: 990a4822f1cb45c1470fe38cbf17fd7bb54d0088 (patch)
tree: 1c1ff41c9264fe5af5ee0b8723d1e367e958c051 /tests
parent: 91db77c955cc7ef95dd8b535e40d6b4cf28669ec (diff)
parent: 3c6e220d8100281074c414a43c1efe9a01b53771 (diff)
4 files changed, 123 insertions, 1 deletions
diff --git a/tests/gnu-maintenance.scm b/tests/gnu-maintenance.scm
index 89b0684c25..abe74d799c 100644
--- a/tests/gnu-maintenance.scm
+++ b/tests/gnu-maintenance.scm
@@ -84,4 +84,66 @@
            (equal? (upstream-source-version update) "2")
            (equal? (list expected-new-url) (upstream-source-urls update))))))
 
+(test-assert "latest-html-release, no signature"
+  (with-http-server
+      `((200 "<html xmlns=\"http://www.w3.org/1999/xhtml\">
+<head>
+<title>Releases!</title>
+</head>
+<body>
+<a href=\"bar/foo-1.tar.gz\">version 1</a>
+<a href=\"bar/foo-2.tar.gz\">version 2</a>
+</body>
+</html>"))
+    (let ()
+      (define package
+        (dummy-package "foo"
+          (source
+           (dummy-origin
+            (uri (string-append (%local-url) "/foo-1.tar.gz"))))
+          (properties
+           `((release-monitoring-url . ,(%local-url))))))
+      (define update ((upstream-updater-latest %generic-html-updater) package))
+      (define expected-new-url
+        (string-append (%local-url) "/foo-2.tar.gz"))
+      (and (pk 'u update)
+           (equal? (upstream-source-version update) "2")
+           (equal? (list expected-new-url)
+                   (upstream-source-urls update))
+           (null? ;; both #false and the empty list are acceptable
+            (or (upstream-source-signature-urls update) '()))))))
+
+(test-assert "latest-html-release, signature"
+  (with-http-server
+      `((200 "<html xmlns=\"http://www.w3.org/1999/xhtml\">
+<head>
+<title>Signed releases!</title>
+</head>
+<body>
+<a href=\"bar/foo-1.tar.gz\">version 1</a>
+<a href=\"bar/foo-2.tar.gz\">version 2</a>
+<a href=\"bar/foo-1.tar.gz.sig\">version 1 signature</a>
+<a href=\"bar/foo-2.tar.gz.sig\">version 2 signature</a>
+</body>
+</html>"))
+    (let ()
+      (define package
+        (dummy-package "foo"
+          (source
+           (dummy-origin
+            (uri (string-append (%local-url) "/foo-1.tar.gz"))))
+          (properties
+           `((release-monitoring-url . ,(%local-url))))))
+      (define update ((upstream-updater-latest %generic-html-updater) package))
+      (define expected-new-url
+        (string-append (%local-url) "/foo-2.tar.gz"))
+      (define expected-signature-url
+        (string-append (%local-url) "/foo-2.tar.gz.sig"))
+      (and (pk 'u update)
+           (equal? (upstream-source-version update) "2")
+           (equal? (list expected-new-url)
+                   (upstream-source-urls update))
+           (equal? (list expected-signature-url)
+                   (upstream-source-signature-urls update))))))
+
 (test-end)
diff --git a/tests/home-import.scm b/tests/home-import.scm
index d62a6de648..04b7b76156 100644
--- a/tests/home-import.scm
+++ b/tests/home-import.scm
@@ -23,6 +23,7 @@
   #:use-module (guix build utils)
   #:use-module (guix packages)
   #:use-module (ice-9 match)
+  #:use-module ((guix read-print) #:select (blank?))
   #:use-module ((guix profiles) #:hide (manifest->code))
   #:use-module ((guix build syscalls) #:select (mkdtemp!))
   #:use-module ((guix scripts package)
@@ -85,13 +86,21 @@ corresponding file."
               ((file . content) (create-file file content)))
             files-alist))
 
+(define (remove-recursively pred sexp)
+  "Like SRFI-1 'remove', but recurse within SEXP."
+  (let loop ((sexp sexp))
+    (match sexp
+      ((lst ...)
+       (map loop (remove pred lst)))
+      (x x))))
+
 (define (eval-test-with-home-environment files-alist manifest matcher)
   (create-temporary-home files-alist)
   (setenv "HOME" %temporary-home-directory)
   (mkdir-p %temporary-home-directory)
   (let* ((home-environment (manifest+configuration-files->code
                             manifest %destination-directory))
-         (result (matcher home-environment)))
+         (result (matcher (remove-recursively blank? home-environment))))
     (delete-file-recursively %temporary-home-directory)
     result))
 
diff --git a/tests/read-print.scm b/tests/read-print.scm
index ca3f3193f7..ea52a52145 100644
--- a/tests/read-print.scm
+++ b/tests/read-print.scm
@@ -294,6 +294,11 @@ mnopqrstuvwxyz.\")"
   ;; page break above
   end)")
 
+(test-pretty-print "\
+(home-environment
+  (services
+   (list (service-type home-bash-service-type))))")
+
 (test-pretty-print/sequence "\
 ;;; This is a top-level comment.
 
diff --git a/tests/substitute.scm b/tests/substitute.scm
index 049e6ba762..5315292987 100644
--- a/tests/substitute.scm
+++ b/tests/substitute.scm
@@ -137,6 +137,12 @@ version identifier.."
   (string-append (dirname %main-substitute-directory)
                  "/substituter-alt-data"))
 
+(define %unroutable-substitute-url
+  ;; Substitute URL with an unroutable server address, as per
+  ;; <https://www.rfc-editor.org/rfc/rfc5737>.
+  "http://203.0.113.1")
+
+
 (define %narinfo
   ;; Skeleton of the narinfo used below.
   (string-append "StorePath: " (%store-prefix)
@@ -305,6 +311,24 @@ Deriver: " (%store-prefix) "/foo.drv")
            (lambda ()
              (guix-substitute "--query"))))))))
 
+(test-equal "query narinfo signed with authorized key, unroutable URL first"
+  (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+
+  (with-narinfo (string-append %narinfo "Signature: "
+                               (signature-field %narinfo)
+                               "\n")
+    (string-trim-both
+     (with-output-to-string
+       (lambda ()
+         (with-input-from-string (string-append "have " (%store-prefix)
+                                                "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+           (lambda ()
+             (parameterize ((substitute-urls
+                             (list %unroutable-substitute-url
+                                   (string-append "file://"
+                                                  %main-substitute-directory))))
+               (guix-substitute "--query")))))))))
+
 (test-equal "query narinfo signed with unauthorized key"
   ""                                              ; not substitutable
 
@@ -417,6 +441,28 @@ System: mips64el-linux\n")))
       (lambda ()
         (false-if-exception (delete-file "substitute-retrieved"))))))
 
+(test-equal "substitute, authorized key, first substitute URL is unroutable"
+  '("Substitutable data." 1 #o444)
+  (with-narinfo (string-append %narinfo "Signature: "
+                               (signature-field %narinfo))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        ;; Pick an unroutable URL as the first one.  This shouldn't be a
+        ;; problem.
+        (parameterize ((substitute-urls
+                        (list %unroutable-substitute-url
+                              (string-append "file://"
+                                             %main-substitute-directory))))
+          (request-substitution (string-append (%store-prefix)
+                                               "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+                                "substitute-retrieved")
+          (list (call-with-input-file "substitute-retrieved" get-string-all)
+                (stat:mtime (lstat "substitute-retrieved"))
+                (stat:perms (lstat "substitute-retrieved")))))
+      (lambda ()
+        (false-if-exception (delete-file "substitute-retrieved"))))))
+
 (test-equal "substitute, unauthorized narinfo comes first"
   "Substitutable data."
   (with-narinfo*
author	Maxim Cournoyer <[email protected]>	2022-09-27 15:59:30 -0400
committer	Maxim Cournoyer <[email protected]>	2022-09-27 15:59:30 -0400
commit	990a4822f1cb45c1470fe38cbf17fd7bb54d0088 (patch)
tree	1c1ff41c9264fe5af5ee0b8723d1e367e958c051 /tests
parent	91db77c955cc7ef95dd8b535e40d6b4cf28669ec (diff)
parent	3c6e220d8100281074c414a43c1efe9a01b53771 (diff)