GNU bug report logs - #48437
[PATCH] lint: archival: Lookup content in Disarchive database.

Previous Next

Full log

View this message in rfc822 format

From: Ludovic Courtès <ludo <at> gnu.org>
To: 48437 <at> debbugs.gnu.org
Cc: Timothy Sample <samplet <at> ngyro.com>, Ludovic Courtès <ludo <at> gnu.org>
Subject: [bug#48437] [PATCH] lint: archival: Lookup content in Disarchive database.
Date: Sat, 15 May 2021 12:28:14 +0200

* guix/lint.scm (lookup-disarchive-spec): New procedure.
(check-archival): When 'lookup-content' returns #f, call
'lookup-disarchive-spec'.
* guix/download.scm (%disarchive-mirrors): Make public.
---
 guix/download.scm |  1 +
 guix/lint.scm     | 31 +++++++++++++++++++++++++++----
 2 files changed, 28 insertions(+), 4 deletions(-)

Hello!

This patch makes the ‘archival’ checker check the Disarchive database(s)
when SWH ‘lookup-content’ returns #f.  For example, before the patch,
we get:

  $ guix lint -c archival guile-json
  gnu/packages/guile.scm:622:12: guile-json <at> 4.5.2: source not archived on Software Heritage

After the patch, we get nothing (success) thanks to Disarchive metadata
available at:

  https://disarchive.ngyro.com/sha256/1ab046ec36b1c44c041ac275568d818784d71fab9a5d95f9128cfe8a25051933

It assumes that the swhid found in the Disarchive metadata is valid, a
reasonable assumption IMO.

Thoughts?

Ludo’.

diff --git a/guix/download.scm b/guix/download.scm
index 72094e7318..b6eb97e6fa 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -35,6 +35,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:export (%mirrors
+            %disarchive-mirrors
             (url-fetch* . url-fetch)
             url-fetch/executable
             url-fetch/tarbomb
diff --git a/guix/lint.scm b/guix/lint.scm
index 1bebfe03d3..c6ad54ddeb 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -30,6 +30,7 @@
 
 (define-module (guix lint)
   #:use-module (guix store)
+  #:autoload   (guix base16) (bytevector->base16-string)
   #:use-module (guix base32)
   #:use-module (guix diagnostics)
   #:use-module (guix download)
@@ -1227,6 +1228,23 @@ upstream releases")
                             #:field 'source)))))))
 
 
+(define (lookup-disarchive-spec hash)
+  "Return true if Disarchive mirrors have a spec for HASH, false otherwise."
+  (any (lambda (mirror)
+         (with-networking-fail-safe
+          (format #f (G_ "failed to access Disarchive database at ~a")
+                  mirror)
+          #f
+          (let* ((url (string-append mirror
+                                     (symbol->string
+                                      (content-hash-algorithm hash))
+                                     "/"
+                                     (bytevector->base16-string
+                                      (content-hash-value hash))))
+                 (response (http-head url)))
+            (= 200 (response-code response)))))
+       %disarchive-mirrors))
+
 (define (check-archival package)
   "Check whether PACKAGE's source code is archived on Software Heritage.  If
 it's not, and if its source code is a VCS snapshot, then send a \"save\"
@@ -1302,10 +1320,15 @@ try again later")
                                         (symbol->string
                                          (content-hash-algorithm hash)))
                    (#f
-                    (list (make-warning package
-                                        (G_ "source not archived on Software \
-Heritage")
-                                        #:field 'source)))
+                    ;; If SWH doesn't have HASH as is, it may be because it's
+                    ;; a hand-crafted tarball.  In that case, check whether
+                    ;; the Disarchive database has an entry for that tarball.
+                    (if (lookup-disarchive-spec hash)
+                        '()
+                        (list (make-warning package
+                                            (G_ "source not archived on Software \
+Heritage and missing from the Disarchive database")
+                                            #:field 'source))))
                    ((? content?)
                     '())))
                '()))))
-- 
2.31.1

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.