Subject: [PATCH] guix: lint: Honor 'no-archival?' package property.

From: Simon Tournier <[email-masked]>
Date: Fri, 21 Jun 2024 19:22:24 +0200

* guix/lint.scm (check-archival): Skip the checker if the package is marked.
* doc/guix.texi: Document it.

Change-Id: I2e21b60ee4f02255f298740a2e9ebb1717e490ff
---
 doc/guix.texi |  15 ++++-
 guix/lint.scm | 154 ++++++++++++++++++++++++++------------------------
 2 files changed, 93 insertions(+), 76 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 769ca1399f..5c1cb89686 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -71,7 +71,7 @@
 Copyright @copyright{} 2019 Alex Griffin@*
 Copyright @copyright{} 2019, 2020, 2021, 2022 Guillaume Le Vaillant@*
 Copyright @copyright{} 2020 Liliana Marie Prikler@*
-Copyright @copyright{} 2019, 2020, 2021, 2022, 2023 Simon Tournier@*
+Copyright @copyright{} 2019, 2020, 2021, 2022, 2023, 2024 Simon Tournier@*
 Copyright @copyright{} 2020 Wiktor Żelazny@*
 Copyright @copyright{} 2020 Damien Cassou@*
 Copyright @copyright{} 2020 Jakub Kądziołka@*
@@ -15380,6 +15380,19 @@ Invoking guix lint
 prints a message and the @code{archival} checker stops doing anything until
 that limit has been reset.
 
+Sometimes it is not desired to send a request for archiving each time
+@command{guix lint} is run.  The package might be marked to skip the
+@code{archival} checker by honoring the @code{no-archival?} property in
+package definition:
+
+@lisp
+(define-public python-scikit-learn
+  (package
+    (name "python-scikit-learn")
+    ;; @dots{}
+    (properties '((no-archival? . #t)))))
+@end lisp
+
 @item cve
 @cindex security vulnerabilities
 @cindex CVE, Common Vulnerabilities and Exposures
diff --git a/guix/lint.scm b/guix/lint.scm
index 68d532968d..4c33ec6598 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -1717,84 +1717,88 @@ (define (check-archival package)
     (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? origin)
-                (= origin-uri (? git-reference? reference)))
-           (define url
-             (git-reference-url reference))
-           (define commit
-             (git-reference-commit reference))
-           (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.
-              (save-package-source package))))
-          ((? origin? origin)
-           (if (and=> (origin-hash origin)          ;XXX: for ungoogled-chromium
-                      content-hash-value)           ;& icecat
-               (let ((hash (origin-hash origin)))
-                 (match (or (lookup-by-nar-hash hash)
-                            (lookup-content (content-hash-value hash)
-                                            (symbol->string
-                                             (content-hash-algorithm hash))))
-                   (#f
-                    ;; If ORIGIN is a version-control checkout, save it now.
-                    ;; If not, check whether HASH is in the Disarchive
-                    ;; database ("Save Code Now" does not accept tarballs).
-                    (if (vcs-origin origin)
-                        (save-package-source package)
-                        (match (lookup-disarchive-spec hash)
-                          (#f
-                           (list (make-warning package
-                                               (G_ "source not archived on Software \
+  (if (not (assq 'no-archival? (package-properties package)))
+    (parameterize ((%allow-request? skip-when-limit-reached))
+      (catch #t
+        (lambda ()
+          (match (package-source package)
+            (#f                                     ;no source
+             '())
+            ((and (? origin? origin)
+                  (= origin-uri (? git-reference? reference)))
+             (define url
+               (git-reference-url reference))
+             (define commit
+               (git-reference-commit reference))
+             (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.
+                (save-package-source package))))
+            ((? origin? origin)
+             (if (and=> (origin-hash origin)          ;XXX: for ungoogled-chromium
+                        content-hash-value)           ;& icecat
+                 (let ((hash (origin-hash origin)))
+                   (match (or (lookup-by-nar-hash hash)
+                              (lookup-content (content-hash-value hash)
+                                              (symbol->string
+                                               (content-hash-algorithm hash))))
+                     (#f
+                      ;; If ORIGIN is a version-control checkout, save it now.
+                      ;; If not, check whether HASH is in the Disarchive
+                      ;; database ("Save Code Now" does not accept tarballs).
+                      (if (vcs-origin origin)
+                          (save-package-source package)
+                          (match (lookup-disarchive-spec hash)
+                            (#f
+                             (list (make-warning package
+                                                 (G_ "source not archived on Software \
 Heritage and missing from the Disarchive database")
-                                               #:field 'source)))
-                          (directory-ids
-                           (match (find (lambda (id)
-                                          (not (lookup-directory id)))
-                                        directory-ids)
-                             (#f '())
-                             (id
-                              (list (make-warning package
-                                                  (G_ "\
+                                                 #:field 'source)))
+                            (directory-ids
+                             (match (find (lambda (id)
+                                            (not (lookup-directory id)))
+                                          directory-ids)
+                               (#f '())
+                               (id
+                                (list (make-warning package
+                                                    (G_ "\
 Disarchive entry refers to non-existent SWH directory '~a'")
-                                                  (list id)
-                                                  #:field 'source))))))))
-                   ((? content?)
-                    '())
-                   ((? string? swhid)
-                    '())))
-               '()))
-          ((? local-file?)
-           '())
-          (_
-           (list (make-warning package
-                               (G_ "\
+                                                    (list id)
+                                                    #:field 'source))))))))
+                     ((? content?)
+                      '())
+                     ((? string? swhid)
+                      '())))
+                 '()))
+            ((? local-file?)
+             '())
+            (_
+             (list (make-warning package
+                                 (G_ "\
 source is not an origin, it cannot be archived")
-                               #:field 'source)))))
-      (match-lambda*
-        (('swh-error url method response)
-         (swh-response->warning package url method response))
-        ((key . args)
-         (if (eq? key skip-key)
-             '()
-             (with-networking-fail-safe
-              (G_ "while connecting to Software Heritage")
-              '()
-              (apply throw key args))))))))
+                                 #:field 'source)))))
+        (match-lambda*
+          (('swh-error url method response)
+           (swh-response->warning package url method response))
+          ((key . args)
+           (if (eq? key skip-key)
+               '()
+               (with-networking-fail-safe
+                (G_ "while connecting to Software Heritage")
+                '()
+                (apply throw key args)))))))
+    (list
+     (make-warning package
+                   (G_ "skip archiving as marked by package")))))
 
 (define (check-haskell-stackage package)
   "Check whether PACKAGE is a Haskell package ahead of the current

base-commit: bc8a41f4a8d9f1f0525d7bc97c67ed3c8aea3111
-- 
2.41.0