diff options
| -rw-r--r-- | guix/lint.scm | 140 | ||||
| -rw-r--r-- | 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 @@ 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 @@ directory identifiers the spec refers to. Otherwise return #f." (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 + ;; <https://www.softwareheritage.org>. + (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 @@ request to Software Heritage. 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 @@ try again later") '()) (#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 - ;; <https://www.softwareheritage.org>. - (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 @@ try again later") (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 @@ source is not an origin, it cannot be archived") #: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 @@ (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 |