07/09: lint: archival: Check with ‘lookup-directory-by-nar-hash’.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 29f3089c841f00144f24f5c32296aebf22d752cc
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri Jan 26 14:41:37 2024 +0100

    lint: archival: Check with ‘lookup-directory-by-nar-hash’.
    
    While this method is new and nar-sha256 ExtIDs are currently available
    only for new visits, it is fundamentally more reliable than the other
    methods, which is why it comes first.
    
    * guix/lint.scm (check-archival)[lookup-by-nar-hash]: New procedure.
    Call ‘lookup-by-nar-hash’ before the other lookup methods.
    * tests/lint.scm ("archival: content available")
    ("archival: content unavailable but disarchive available")
    ("archival: missing revision")
    ("archival: revision available"): Add a 404 response corresponding to
    the ‘lookup-external-id’ request.
    * tests/lint.scm ("archival: nar-sha256 extid available"): New test.
    
    Change-Id: I4a81d6e022a3b72e6484726549d7fbae627f8e73
---
 guix/lint.scm  | 30 +++++++++++++++++++-----------
 tests/lint.scm | 33 ++++++++++++++++++++++++++++-----
 2 files changed, 47 insertions(+), 16 deletions(-)

diff --git a/guix/lint.scm b/guix/lint.scm
index 861e352b93..c95de85e69 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
 ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2013-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
 ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org>
 ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
@@ -1658,24 +1658,31 @@ try again later")
     (or (not (request-rate-limit-reached? url method))
         (throw skip-key #t)))
 
+  (define (lookup-by-nar-hash hash)
+    (lookup-directory-by-nar-hash (content-hash-value hash)
+                                  (content-hash-algorithm hash)))
+
   (parameterize ((%allow-request? skip-when-limit-reached))
     (catch #t
       (lambda ()
         (match (package-source package)
           (#f                                     ;no source
            '())
-          ((and (? origin?)
+          ((and (? origin? origin)
                 (= origin-uri (? git-reference? reference)))
            (define url
              (git-reference-url reference))
            (define commit
              (git-reference-commit reference))
-
-           (match (if (commit-id? commit)
-                      (or (lookup-revision commit)
-                          (lookup-origin-revision url commit))
-                      (lookup-origin-revision url commit))
-             ((? revision? revision)
+           (define hash
+             (origin-hash origin))
+
+           (match (or (lookup-by-nar-hash hash)
+                      (if (commit-id? commit)
+                          (or (lookup-revision commit)
+                              (lookup-origin-revision url commit))
+                          (lookup-origin-revision url commit)))
+             ((or (? string?) (? revision?))
               '())
              (#f
               ;; Revision is missing from the archive, attempt to save it.
@@ -1704,9 +1711,10 @@ try again later")
            (if (and=> (origin-hash origin)          ;XXX: for 
ungoogled-chromium
                       content-hash-value)           ;& icecat
                (let ((hash (origin-hash origin)))
-                 (match (lookup-content (content-hash-value hash)
-                                        (symbol->string
-                                         (content-hash-algorithm hash)))
+                 (match (or (lookup-by-nar-hash hash)
+                            (lookup-content (content-hash-value hash)
+                                            (symbol->string
+                                             (content-hash-algorithm hash))))
                    (#f
                     ;; If SWH doesn't have HASH as is, it may be because it's
                     ;; a hand-crafted tarball.  In that case, check whether
diff --git a/tests/lint.scm b/tests/lint.scm
index a52a82237b..87213fcc78 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013 Cyril Roelandt <tipecaml@gmail.com>
 ;;; Copyright © 2014, 2015, 2016 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2014-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
 ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
 ;;; Copyright © 2017 Alex Kost <alezost@gmail.com>
@@ -1358,7 +1358,8 @@
          ;; https://archive.softwareheritage.org/api/1/content/
          (content  "{ \"checksums\": {}, \"data_url\": \"xyz\",
                       \"length\": 42 }"))
-    (with-http-server `((200 ,content))
+    (with-http-server `((404 "")                  ;extid
+                        (200 ,content))
       (parameterize ((%swh-base-url (%local-url)))
         (check-archival (dummy-package "x" (source origin)))))))
 
@@ -1378,7 +1379,8 @@
                          \"type\": \"file\",
                          \"name\": \"README\"
                          \"length\": 42 } ]"))
-    (with-http-server `((404 "")                  ;lookup-content
+    (with-http-server `((404 "")                  ;lookup-directory-by-nar-hash
+                        (404 "")                  ;lookup-content
                         (200 ,disarchive)         ;Disarchive database lookup
                         (200 ,directory))         ;lookup-directory
       (mock ((guix download) %disarchive-mirrors (list (%local-url)))
@@ -1397,7 +1399,8 @@
                       \"save_request_date\": \"2014-11-17T22:09:38+01:00\",
                       \"save_request_status\": \"accepted\",
                       \"save_task_status\": \"scheduled\" }")
-         (warnings (with-http-server `((404 "No revision.") ;lookup-revision
+         (warnings (with-http-server `((404 "No extid.") 
;lookup-directory-by-nar-hash
+                                       (404 "No revision.") ;lookup-revision
                                        (404 "No origin.")   ;lookup-origin
                                        (200 ,save))         ;save-origin
                      (parameterize ((%swh-base-url (%local-url)))
@@ -1415,7 +1418,27 @@
          ;; https://archive.softwareheritage.org/api/1/revision/
          (revision "{ \"author\": {}, \"parents\": [],
                       \"date\": \"2014-11-17T22:09:38+01:00\" }"))
-    (with-http-server `((200 ,revision))
+    (with-http-server `((404 "No directory.")     ;lookup-directory-by-nar-hash
+                        (200 ,revision))
+      (parameterize ((%swh-base-url (%local-url)))
+        (check-archival (dummy-package "x" (source origin)))))))
+
+(test-equal "archival: nar-sha256 extid available"
+  '()
+  (let* ((origin   (origin
+                     (method git-fetch)
+                     (uri (git-reference
+                           (url "http://example.org/foo.git";)
+                           (commit 
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))
+                     (sha256 (make-bytevector 32))))
+         ;; https://archive.softwareheritage.org/api/1/extid/doc/
+         (extid   "{ \"extid_type\": \"nar-sha256\",
+                     \"extid\": \"1234\",
+                     \"extid_version\": 0,
+                     \"target\": \"swh:1:dir:cabba93\",
+                     \"target_url\": \"boo\"
+                   }"))
+    (with-http-server `((200 ,extid))
       (parameterize ((%swh-base-url (%local-url)))
         (check-archival (dummy-package "x" (source origin)))))))