@@ -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
+ ;; <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 @@ (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
- ;; <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 @@ (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)
'()
@@ -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
From: Ludovic Courtès <ludovic.courtes@inria.fr> Until now, ‘save-origin’ would be called only when given a <git-reference>. 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(-)