mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
lint: archival: Trigger “Save Code Now” for VCSes other than Git.
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
This commit is contained in:
Ludovic Courtès
Ludovic Courtès
parent
3328dec087
commit
47a0e5d9fb
2 changed files with 109 additions and 51 deletions
108
guix/lint.scm
108
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,15 +1636,9 @@ (define (extract-swh-id spec)
|
|||
(extract-swh-id spec)))))
|
||||
%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\"
|
||||
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)
|
||||
(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; \
|
||||
|
|
@ -1651,6 +1649,64 @@ (define (response->warning url method response)
|
|||
(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\"
|
||||
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 skip-key (gensym "skip-archival-check"))
|
||||
|
||||
(define (skip-when-limit-reached url method)
|
||||
|
|
@ -1685,28 +1741,8 @@ (define hash
|
|||
'())
|
||||
(#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,9 +1751,11 @@ (define hash
|
|||
(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.
|
||||
;; 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
|
||||
|
|
@ -1734,7 +1772,7 @@ (define hash
|
|||
(G_ "\
|
||||
Disarchive entry refers to non-existent SWH directory '~a'")
|
||||
(list id)
|
||||
#:field 'source)))))))
|
||||
#:field 'source))))))))
|
||||
((? content?)
|
||||
'())
|
||||
((? string? swhid)
|
||||
|
|
@ -1749,7 +1787,7 @@ (define hash
|
|||
#: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
|
||||
|
|
|
|||
Loading…
Reference in a new issue