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

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 (extract-swh-id spec)
               (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 hash
               '())
              (#f
               ;; Revision is missing from the archive, attempt to save it.
-              (catch 'swh-error
+              (save-package-source package))))
-                (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))))))))
           ((? 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 hash
                                             (symbol->string
                                              (content-hash-algorithm hash))))
                    (#f
-                    ;; If SWH doesn't have HASH as is, it may be because it's
+                    ;; If ORIGIN is a version-control checkout, save it now.
-                    ;; a hand-crafted tarball.  In that case, check whether
+                    ;; If not, check whether HASH is in the Disarchive
-                    ;; the Disarchive database has an entry for that tarball.
+                    ;; database ("Save Code Now" does not accept tarballs).
-                    (match (lookup-disarchive-spec hash)
+                    (if (vcs-origin origin)
-                      (#f
+                        (save-package-source package)
-                       (list (make-warning package
+                        (match (lookup-disarchive-spec hash)
-                                           (G_ "source not archived on Software \
+                          (#f
+                           (list (make-warning package
+                                               (G_ "source not archived on Software \
 Heritage and missing from the Disarchive database")
-                                           #:field 'source)))
+                                               #:field 'source)))
-                      (directory-ids
+                          (directory-ids
-                       (match (find (lambda (id)
+                           (match (find (lambda (id)
-                                      (not (lookup-directory id)))
+                                          (not (lookup-directory id)))
-                                    directory-ids)
+                                        directory-ids)
-                         (#f '())
+                             (#f '())
-                         (id
+                             (id
-                          (list (make-warning package
+                              (list (make-warning package
-                                              (G_ "\
+                                                  (G_ "\
 Disarchive entry refers to non-existent SWH directory '~a'")
-                                              (list id)
+                                                  (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)
              '()

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