From patchwork Fri Feb 23 15:48:07 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 60929 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 7234727BBE9; Fri, 23 Feb 2024 16:15:47 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.7 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 010A227BBE2 for ; Fri, 23 Feb 2024 16:15:46 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1rdYCO-0006BK-85; Fri, 23 Feb 2024 11:14:56 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rdXo2-00048F-DJ for guix-patches@gnu.org; Fri, 23 Feb 2024 10:49:46 -0500 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1rdXo2-0007Fi-3v; Fri, 23 Feb 2024 10:49:46 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1rdXoP-0002Bn-30; Fri, 23 Feb 2024 10:50:09 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#69328] [PATCH 03/12] lint: archival: Trigger =?utf-8?b?4oCc?= =?utf-8?b?U2F2ZQ==?= Code =?utf-8?b?Tm934oCd?= for VCSes other than Git. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix@cbaines.net, dev@jpoiret.xyz, ludo@gnu.org, othacehe@gnu.org, rekado@elephly.net, zimon.toutoune@gmail.com, me@tobias.gr, guix-patches@gnu.org Resent-Date: Fri, 23 Feb 2024 15:50:09 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 69328 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 69328@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= , Christopher Baines , Josselin Poiret , Ludovic =?utf-8?q?Court=C3=A8s?= , Mathieu Othacehe , Ricardo Wurmus , Simon Tournier , Tobias Geerinckx-Rice X-Debbugs-Original-Xcc: Christopher Baines , Josselin Poiret , Ludovic =?utf-8?q?Court=C3=A8s?= , Mathieu Othacehe , Ricardo Wurmus , Simon Tournier , Tobias Geerinckx-Rice Received: via spool by 69328-submit@debbugs.gnu.org id=B69328.17087033998294 (code B ref 69328); Fri, 23 Feb 2024 15:50:09 +0000 Received: (at 69328) by debbugs.gnu.org; 23 Feb 2024 15:49:59 +0000 Received: from localhost ([127.0.0.1]:49275 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rdXoB-00029M-IX for submit@debbugs.gnu.org; Fri, 23 Feb 2024 10:49:59 -0500 Received: from eggs.gnu.org ([209.51.188.92]:52678) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rdXnY-00021h-AL for 69328@debbugs.gnu.org; Fri, 23 Feb 2024 10:49:19 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rdXmu-00077X-Ij; Fri, 23 Feb 2024 10:48:36 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:References:In-Reply-To:Date:Subject:To: From; bh=J2NKJ/7s0Llg3irvfcBHgHZYrMwIa3sokuS2T42kAy8=; b=FnxrxNhRzNWrQoSwGTjf PP2MU1s0Pv5G1pDmYdgplQwmCRRP0X4hvE+vYCS8BXrtoIyQUHrtFkgpb+52EPYYwn043Q3rTExNr CvEoumbIK3pYKVoJcMPfF9O8iNwMMxeETpcePGcgCHfUAwxBOeQYHkDA5+LKSjToo1hUSx04QiP3b w0C3IygrxsMRoCc2uy5/IjPGI4kXT5toZ/fR8ZK/PGYU2Sy34Vtjz8XR5eutEiZju6cGKdz8Zmae5 TYbgc11ytvPqIj1ifRHzwSeG5fo+7nYMgzYk7Go1j3Y6ciV0c84UtNFtgY9f6ehbNQvB6Xb7Ki5HI xpMfaOJbWafbzQ==; From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Fri, 23 Feb 2024 16:48:07 +0100 Message-ID: <38211161ee2bf6fbaab40362ebd654dc1cbad986.1708697539.git.ludo@gnu.org> X-Mailer: git-send-email 2.41.0 In-Reply-To: References: MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches From: Ludovic Courtès Until now, ‘save-origin’ would be called only when given a . With this change, ‘save-origin’ gets called for other version control systems as well. * guix/lint.scm (swh-response->warning): New procedure, formerly in ‘check-archival’. (vcs-origin, save-package-source): New procedures. (check-archival)[response->warning]: Remove. Call ‘save-package-source’ in both the Git and the non-Git cases. * tests/lint.scm ("archival: missing svn revision"): New test. Change-Id: I535e4ec89488faf83bfa544d5e4935fa73ef54fb --- guix/lint.scm | 140 +++++++++++++++++++++++++++++++------------------ tests/lint.scm | 20 +++++++ 2 files changed, 109 insertions(+), 51 deletions(-) diff --git a/guix/lint.scm b/guix/lint.scm index ad84048660..68d532968d 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -67,6 +67,10 @@ (define-module (guix lint) svn-multi-reference-url svn-multi-reference-user-name svn-multi-reference-password) + #:autoload (guix hg-download) (hg-reference? + hg-reference-url) + #:autoload (guix bzr-download) (bzr-reference? + bzr-reference-url) #:use-module (guix import stackage) #:use-module (ice-9 match) #:use-module (ice-9 regex) @@ -1632,6 +1636,69 @@ (define (lookup-disarchive-spec hash) (extract-swh-id spec))))) %disarchive-mirrors)) +(define (swh-response->warning package url method response) + "Given RESPONSE, the response of METHOD on URL, return a suitable warning +list for PACKAGE." + (if (request-rate-limit-reached? url method) + (list (make-warning package + (G_ "Software Heritage rate limit reached; \ +try again later") + #:field 'source)) + (list (make-warning package + (G_ "'~a' returned ~a") + (list url (response-code response)) + #:field 'source)))) + +(define (vcs-origin origin) + "Return two values: the URL and type (a string) of the version-control used +for ORIGIN. Return #f and #f if ORIGIN is not a version-control checkout." + (match (and=> origin origin-uri) + ((? git-reference? ref) + (values (git-reference-url ref) "git")) + ((? svn-reference? ref) + (values (svn-reference-url ref) "svn")) + ((? svn-multi-reference? ref) + (values (svn-multi-reference-url ref) "svn")) + ((? hg-reference? ref) + (values (hg-reference-url ref) "hg")) + ((? bzr-reference? ref) + (values (bzr-reference-url ref) "bzr")) + ;; XXX: Not sure what to do with the weird CVS URIs (:pserver: etc.). + (_ + (values #f #f)))) + +(define (save-package-source package) + "Attempt to save the source of PACKAGE on SWH. Return a list of warnings." + (let* ((origin (package-source package)) + (url type (if origin (vcs-origin origin) (values #f #f)))) + (cond ((and url type) + (catch 'swh-error + (lambda () + (save-origin url type) + (list (make-warning + package + ;; TRANSLATORS: "Software Heritage" is a proper noun that + ;; must remain untranslated. See + ;; . + (G_ "scheduled Software Heritage archival") + #:field 'source))) + (lambda (key url method response . _) + (cond ((= 429 (response-code response)) + (list (make-warning + package + (G_ "archival rate limit exceeded; \ +try again later") + #:field 'source))) + (else + (swh-response->warning package url method response)))))) + ((not origin) + '()) + (else + (list (make-warning + package + (G_ "source code cannot be archived") + #:field 'source)))))) + (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\" @@ -1640,17 +1707,6 @@ (define (check-archival package) Software Heritage imposes limits on the request rate per client IP address. This checker prints a notice and stops doing anything once that limit has been reached." - (define (response->warning url method response) - (if (request-rate-limit-reached? url method) - (list (make-warning package - (G_ "Software Heritage rate limit reached; \ -try again later") - #:field 'source)) - (list (make-warning package - (G_ "'~a' returned ~a") - (list url (response-code response)) - #:field 'source)))) - (define skip-key (gensym "skip-archival-check")) (define (skip-when-limit-reached url method) @@ -1685,28 +1741,8 @@ (define (check-archival package) '()) (#f ;; Revision is missing from the archive, attempt to save it. - (catch 'swh-error - (lambda () - (save-origin (git-reference-url reference) "git") - (list (make-warning - package - ;; TRANSLATORS: "Software Heritage" is a proper noun - ;; that must remain untranslated. See - ;; . - (G_ "scheduled Software Heritage archival") - #:field 'source))) - (lambda (key url method response . _) - (cond ((= 429 (response-code response)) - (list (make-warning - package - (G_ "archival rate limit exceeded; \ -try again later") - #:field 'source))) - (else - (response->warning url method response)))))))) + (save-package-source package)))) ((? origin? origin) - ;; Since "save" origins are not supported for non-VCS source, all - ;; we can do is tell whether a given tarball is available or not. (if (and=> (origin-hash origin) ;XXX: for ungoogled-chromium content-hash-value) ;& icecat (let ((hash (origin-hash origin))) @@ -1715,26 +1751,28 @@ (define (check-archival package) (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 - ;; the Disarchive database has an entry for that tarball. - (match (lookup-disarchive-spec hash) - (#f - (list (make-warning package - (G_ "source not archived on Software \ + ;; 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))))))) + (list id) + #:field 'source)))))))) ((? content?) '()) ((? string? swhid) @@ -1749,7 +1787,7 @@ (define (check-archival package) #:field 'source))))) (match-lambda* (('swh-error url method response) - (response->warning url method response)) + (swh-response->warning package url method response)) ((key . args) (if (eq? key skip-key) '() diff --git a/tests/lint.scm b/tests/lint.scm index 87213fcc78..95d82d7490 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -1407,6 +1407,26 @@ (define (package-with-phase-changes changes) (check-archival (dummy-package "x" (source origin))))))) (warning-contains? "scheduled" warnings))) +(test-assert "archival: missing svn revision" + (let* ((origin (origin + (method svn-fetch) + (uri (svn-reference + (url "http://example.org/svn/foo") + (revision "1234"))) + (sha256 (make-bytevector 32)))) + ;; https://archive.softwareheritage.org/api/1/origin/save/ + (save "{ \"origin_url\": \"http://example.org/svn/foo\", + \"save_request_date\": \"2014-11-17T22:09:38+01:00\", + \"save_request_status\": \"accepted\", + \"save_task_status\": \"scheduled\" }") + (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))) + (check-archival (dummy-package "x" (source origin))))))) + (warning-contains? "scheduled" warnings))) + (test-equal "archival: revision available" '() (let* ((origin (origin