From babd39e84389c544e8dab44be8ddec57e52709c9 Mon Sep 17 00:00:00 2001 From: Herman Rimm Date: Tue, 20 Feb 2024 21:45:11 +0100 Subject: utils: Add insert-expression procedure. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/utils.scm (define-module): Use (guix read-print) and export (insert-expression). (insert-expression): Add procedure. * tests/utils.scm ("insert-expression"): Add test. Change-Id: I971a43a78aa6ecaaef33c1a7a0db4b287eb85036 Signed-off-by: Ludovic Courtès --- tests/utils.scm | 14 ++++++++++++++ 1 file changed, 14 insertions(+) (limited to 'tests') diff --git a/tests/utils.scm b/tests/utils.scm index 5664165c85..cd54112846 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2021 Simon Tournier ;;; Copyright © 2021 Maxime Devos ;;; Copyright © 2023 Foundation Devices, Inc. +;;; Copyright © 2024 Herman Rimm ;;; ;;; This file is part of GNU Guix. ;;; @@ -274,6 +275,19 @@ (define (test-compression/decompression method run?) string-reverse) (call-with-input-file temp-file get-string-all))) +(test-equal "insert-expression" + "(define-public package-1\n 'package)\n +(define-public package-2\n 'package)\n" + (begin + (call-with-output-file temp-file + (lambda (port) + (display "(define-public package-2\n 'package)\n" port))) + (insert-expression `((filename . ,temp-file) + (line . 0) + (column . 0)) + `(define-public package-1 'package)) + (call-with-input-file temp-file get-string-all))) + (test-equal "string-distance" '(0 1 1 5 5) (list -- cgit v1.2.3 From 50e514c1bc674b1c36344407c8c4b418d17759c5 Mon Sep 17 00:00:00 2001 From: Herman Rimm Date: Tue, 20 Feb 2024 21:45:12 +0100 Subject: utils: Add find-definition-insertion-location procedure. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/utils.scm (find-definition-insertion-location): Add and export procedure. * tests/utils.scm ("find-definition-insertion-location"): Add test. Change-Id: Ie17e1b4a94790f58518ce121411a38d357f49feb Signed-off-by: Ludovic Courtès --- guix/utils.scm | 19 +++++++++++++++++++ tests/utils.scm | 14 ++++++++++++++ 2 files changed, 33 insertions(+) (limited to 'tests') diff --git a/guix/utils.scm b/guix/utils.scm index 94b4d753d0..29ad09d9f7 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -148,6 +148,7 @@ (define-module (guix utils) edit-expression delete-expression insert-expression + find-definition-insertion-location filtered-port decompressed-port @@ -513,6 +514,24 @@ (define (insert-expression source-properties expr) (string-append expr "\n\n" str)))) (edit-expression source-properties insert))) +(define (find-definition-insertion-location file term) + "Search in FILE for a top-level public definition whose defined term +alphabetically succeeds TERM. Return the location if found, or #f +otherwise." + (let ((search-term (symbol->string term))) + (call-with-input-file file + (lambda (port) + (do ((syntax (read-syntax port) + (read-syntax port))) + ((match (syntax->datum syntax) + (('define-public current-term _ ...) + (string> (symbol->string current-term) + search-term)) + ((? eof-object?) #t) + (_ #f)) + (and (not (eof-object? syntax)) + (syntax-source syntax)))))))) + ;;; ;;; Keyword arguments. diff --git a/tests/utils.scm b/tests/utils.scm index cd54112846..52f3b58ede 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -288,6 +288,20 @@ (define-public package-2\n 'package)\n" `(define-public package-1 'package)) (call-with-input-file temp-file get-string-all))) +(test-equal "find-definition-insertion-location" + (list `((filename . ,temp-file) (line . 0) (column . 0)) + `((filename . ,temp-file) (line . 5) (column . 0)) + #f) + (begin + (call-with-output-file temp-file + (lambda (port) + (display "(define-public package-1\n 'foo)\n\n" port) + (display "(define foo 'bar)\n\n" port) + (display "(define-public package-2\n 'baz)\n" port))) + (map (lambda (term) + (find-definition-insertion-location temp-file term)) + (list 'package 'package-1 'package-2)))) + (test-equal "string-distance" '(0 1 1 5 5) (list -- cgit v1.2.3 From 47a0e5d9fb2209a27c2bffa163becbcb3356bf00 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 Feb 2024 17:53:52 +0100 Subject: lint: archival: Trigger “Save Code Now” for VCSes other than Git. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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(-) (limited to 'tests') 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 (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 + ;; . + (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 - (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 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. - (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 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) '() 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 -- cgit v1.2.3 From ddd455c0dd5a527f3c7e94b8b9056155facb37e6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 20 Feb 2024 16:52:34 +0100 Subject: swh: ‘lookup-origin-revision’ handles branches pointing to directories. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . * guix/swh.scm (branch-target): Add clause for 'directory and 'alias. (lookup-origin-revision): Iterate over all the visits of ORIGIN instead of just the first one. Handle the case where ‘branch-target’ returns something other than a release or revision. * tests/swh.scm ("lookup-origin-revision"): New test. Change-Id: I7f636739a719908763bca1d3e7376341dd62e816 --- guix/swh.scm | 60 ++++++++++++++++++++++++++---------------------- tests/swh.scm | 74 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 107 insertions(+), 27 deletions(-) (limited to 'tests') diff --git a/guix/swh.scm b/guix/swh.scm index 14c65f6806..f602cd89d1 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -516,14 +516,20 @@ (define (lookup-snapshot-branch snapshot name) (_ #f))))) (define (branch-target branch) - "Return the target of BRANCH, either a or a ." + "Return the target of BRANCH: a , a , or the SWHID of a +directory." (match (branch-target-type branch) ('release (call (swh-url (branch-target-url branch)) json->release)) ('revision (call (swh-url (branch-target-url branch)) - json->revision)))) + json->revision)) + ((or 'directory 'alias) + (match (string-tokenize (branch-target-url branch) + (char-set-complement (char-set #\/))) + ((_ ... "directory" id) + (string-append "swh:1:dir:" id)))))) (define (lookup-origin-revision url tag) "Return a corresponding to the given TAG for the repository @@ -537,31 +543,31 @@ (define (lookup-origin-revision url tag) (match (lookup-origin url) (#f #f) (origin - (match (filter (lambda (visit) - ;; Return #f if (visit-snapshot VISIT) would return #f. - (and (visit-snapshot-url visit) - (eq? 'full (visit-status visit)))) - (origin-visits origin)) - ((visit . _) - (let ((snapshot (visit-snapshot visit))) - (match (and=> (find (lambda (branch) - (or - ;; Git specific. - (string=? (string-append "refs/tags/" tag) - (branch-name branch)) - ;; Hg specific. - (string=? tag - (branch-name branch)))) - (snapshot-branches snapshot)) - branch-target) - ((? release? release) - (release-target release)) - ((? revision? revision) - revision) - (#f ;tag not found - #f)))) - (() - #f))))) + (any (lambda (visit) + (and (visit-snapshot-url visit) + (eq? 'full (visit-status visit)) + (let ((snapshot (visit-snapshot visit))) + (match (and=> (find (lambda (branch) + (or + ;; Git specific. + (string=? (string-append "refs/tags/" tag) + (branch-name branch)) + ;; Hg specific. + (string=? tag + (branch-name branch)))) + (snapshot-branches snapshot)) + branch-target) + ((? release? release) + (release-target release)) + ((? revision? revision) + revision) + (_ + ;; Either the branch points to a directory rather than + ;; a revision (this is the case for visits of type + ;; 'git-checkout, 'hg-checkout, 'tarball-directory, + ;; etc.), or TAG was not found. + #f))))) + (origin-visits origin 30))))) (define (release-target release) "Return the revision that is the target of RELEASE." diff --git a/tests/swh.scm b/tests/swh.scm index e7ced6b50c..11dcbdddd8 100644 --- a/tests/swh.scm +++ b/tests/swh.scm @@ -109,6 +109,80 @@ (define-syntax-rule (with-json-result str exp ...) (directory-entry-length entry))) (lookup-directory "123")))) +(test-equal "lookup-origin-revision" + '("cd86c72084993d9ef26fc9e24b73cea612b8c97b" + "d173c707ee88e3c89401ad77fafa65fcd9e9f5be") + (let () + ;; Make sure that 'lookup-origin-revision' does the job, and in particular + ;; that it doesn't stop until it has found an actual revision: + ;; 'git-checkout visits point to directories instead of revisions. + ;; See . + (define visits + ;; Two visits of differing types: the first visit (type 'git-checkout') + ;; points to a directory, the second one (type 'git') points to a + ;; revision. + "[ { + \"origin\": \"https://example.org/repo.git\", + \"visit\": 1, + \"type\": \"git-checkout\", + \"date\": \"2020-05-17T21:43:45.422977+00:00\", + \"status\": \"full\", + \"metadata\": {}, + \"type\": \"git-checkout\", + \"origin_visit_url\": \"/visit/42\", + \"snapshot_url\": \"/snapshot/1\" + }, { + \"origin\": \"https://example.org/repo.git\", + \"visit\": 2, + \"type\": \"git\", + \"date\": \"2020-05-17T21:43:49.422977+00:00\", + \"status\": \"full\", + \"metadata\": {}, + \"type\": \"git\", + \"origin_visit_url\": \"/visit/41\", + \"snapshot_url\": \"/snapshot/2\" + } ]") + (define snapshot-for-git-checkout + "{ \"id\": 42, + \"branches\": { \"1.3.2\": { + \"target\": \"e4a4be18fae8d9c6528abff3bc9088feb19a76c7\", + \"target_type\": \"directory\", + \"target_url\": \"/directory/e4a4be18fae8d9c6528abff3bc9088feb19a76c7\" + }} + }") + (define snapshot-for-git + "{ \"id\": 42, + \"branches\": { \"1.3.2\": { + \"target\": \"e4a4be18fae8d9c6528abff3bc9088feb19a76c7\", + \"target_type\": \"revision\", + \"target_url\": \"/revision/e4a4be18fae8d9c6528abff3bc9088feb19a76c7\" + }} + }") + (define revision + "{ \"author\": {}, + \"committer\": {}, + \"committer_date\": \"2018-05-17T21:43:49.422977+00:00\", + \"date\": \"2018-05-17T21:43:49.422977+00:00\", + \"directory\": \"d173c707ee88e3c89401ad77fafa65fcd9e9f5be\", + \"directory_url\": \"/directory/d173c707ee88e3c89401ad77fafa65fcd9e9f5be\", + \"id\": \"cd86c72084993d9ef26fc9e24b73cea612b8c97b\", + \"merge\": false, + \"message\": \"Fix.\", + \"parents\": [], + \"type\": \"what type?\" + }") + + (with-http-server `((200 ,%origin) + (200 ,visits) + (200 ,snapshot-for-git-checkout) + (200 ,snapshot-for-git) + (200 ,revision)) + (parameterize ((%swh-base-url (%local-url))) + (let ((revision (lookup-origin-revision "https://example.org/repo.git" + "1.3.2"))) + (list (revision-id revision) + (revision-directory revision))))))) + (test-equal "lookup-directory-by-nar-hash" "swh:1:dir:84a8b34591712c0a90bab0af604188bcd1fe3153" (with-json-result %external-id -- cgit v1.2.3 From a26bce55e60aa3444c4378d3996f3aa41b9661e9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 11 Mar 2024 22:07:43 +0100 Subject: time-machine: Allow time travels to v0.16.0. * guix/scripts/time-machine.scm (%oldest-possible-commit): Change to v0.16.0. * tests/guix-time-machine.sh: Adjust comment. Change-Id: I9ad82bd45fee0d172b5348a8ae16e990338a3a97 --- guix/scripts/time-machine.scm | 4 ++-- tests/guix-time-machine.sh | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) (limited to 'tests') diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm index 2c30fe7cfd..d9ce85df84 100644 --- a/guix/scripts/time-machine.scm +++ b/guix/scripts/time-machine.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Konrad Hinsen -;;; Copyright © 2019, 2020, 2021, 2023 Ludovic Courtès +;;; Copyright © 2019-2021, 2023-2024 Ludovic Courtès ;;; Copyright © 2021 Simon Tournier ;;; Copyright © 2023 Maxim Cournoyer ;;; @@ -147,7 +147,7 @@ (define (parse-args args) ;;; firmed up in v1.0.0; it is the oldest, safest commit that can be travelled ;;; to. (define %oldest-possible-commit - "6298c3ffd9654d3231a6f25390b056483e8f407c") ;v1.0.0 + "4a0b87f0ec5b6c2dcf82b372dd20ca7ea6acdd9c") ;v0.16.0 (define %reference-channels (list (channel (inherit %default-guix-channel) diff --git a/tests/guix-time-machine.sh b/tests/guix-time-machine.sh index 983f796225..df75c681da 100644 --- a/tests/guix-time-machine.sh +++ b/tests/guix-time-machine.sh @@ -1,6 +1,6 @@ # GNU Guix --- Functional package management for GNU # Copyright © 2023 Maxim Cournoyer -# Copyright © 2023 Ludovic Courtès +# Copyright © 2023-2024 Ludovic Courtès # # This file is part of GNU Guix. # @@ -39,7 +39,7 @@ else EXTRA_OPTIONS="" fi -# Visiting a commit older than v1.0.0 must fail (this test is expensive +# Visiting a commit older than v0.16.0 must fail (this test is expensive # because it clones the whole repository). guix time-machine -q --commit=v0.15.0 $EXTRA_OPTIONS -- describe && false -- cgit v1.2.3