From be773bd192466fa7e26938a157c0885adf46139e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 25 Jan 2024 22:53:56 +0100 Subject: swh: Add bindings for the “ExtID” API. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This interface was deployed at archive.softwareheritage.org a few days ago. Our main use case will be looking up directories by “nar-sha256” hashes. * guix/swh.scm (): New JSON-mapped record type. (lookup-external-id, lookup-directory-by-nar-hash): New procedures. * tests/swh.scm (%external-id): New variable. ("lookup-directory-by-nar-hash"): New test. Change-Id: Ib671c7798aeb6f8132ac78f2b06b9285da8e7bd5 --- tests/swh.scm | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/swh.scm b/tests/swh.scm index a36f951241..e7ced6b50c 100644 --- a/tests/swh.scm +++ b/tests/swh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019, 2020, 2021 Ludovic Courtès +;;; Copyright © 2019-2021, 2024 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,6 +18,7 @@ (define-module (test-swh) #:use-module (guix swh) + #:use-module (guix base32) #:use-module (guix tests http) #:use-module (web response) #:use-module (srfi srfi-19) @@ -56,6 +57,16 @@ (define %directory-entries \"length\": 456, \"dir_id\": 2 } ]") +(define %external-id + "{ \"extid_type\": \"nar-sha256\", + \"extid\": +\"0b56ba94c2b83b8f74e3772887c1109135802eb3e8962b628377987fe97e1e63\", + \"version\": 0, + \"target\": \"swh:1:dir:84a8b34591712c0a90bab0af604188bcd1fe3153\", + \"target_url\": +\"https://archive.softwareheritage.org/swh:1:dir:84a8b34591712c0a90bab0af604188bcd1fe3153\" + }") + (define-syntax-rule (with-json-result str exp ...) (with-http-server `((200 ,str)) (parameterize ((%swh-base-url (%local-url))) @@ -98,6 +109,14 @@ (define-syntax-rule (with-json-result str exp ...) (directory-entry-length entry))) (lookup-directory "123")))) +(test-equal "lookup-directory-by-nar-hash" + "swh:1:dir:84a8b34591712c0a90bab0af604188bcd1fe3153" + (with-json-result %external-id + (lookup-directory-by-nar-hash + (nix-base32-string->bytevector + "0qqygvlpz63phdi2p5p8ncp80dci230qfa3pwds8yfxqqaablmhb") + 'sha256))) + (test-equal "rate limit reached" 3000000000 (let ((too-many (build-response -- cgit v1.2.3 From 29f3089c841f00144f24f5c32296aebf22d752cc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 26 Jan 2024 14:41:37 +0100 Subject: lint: archival: Check with ‘lookup-directory-by-nar-hash’. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit While this method is new and nar-sha256 ExtIDs are currently available only for new visits, it is fundamentally more reliable than the other methods, which is why it comes first. * guix/lint.scm (check-archival)[lookup-by-nar-hash]: New procedure. Call ‘lookup-by-nar-hash’ before the other lookup methods. * tests/lint.scm ("archival: content available") ("archival: content unavailable but disarchive available") ("archival: missing revision") ("archival: revision available"): Add a 404 response corresponding to the ‘lookup-external-id’ request. * tests/lint.scm ("archival: nar-sha256 extid available"): New test. Change-Id: I4a81d6e022a3b72e6484726549d7fbae627f8e73 --- guix/lint.scm | 30 +++++++++++++++++++----------- tests/lint.scm | 33 ++++++++++++++++++++++++++++----- 2 files changed, 47 insertions(+), 16 deletions(-) (limited to 'tests') diff --git a/guix/lint.scm b/guix/lint.scm index 861e352b93..c95de85e69 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Cyril Roelandt ;;; Copyright © 2014, 2015 Eric Bavier -;;; Copyright © 2013-2023 Ludovic Courtès +;;; Copyright © 2013-2024 Ludovic Courtès ;;; Copyright © 2015, 2016 Mathieu Lirzin ;;; Copyright © 2016 Danny Milosavljevic ;;; Copyright © 2016 Hartmut Goebel @@ -1658,24 +1658,31 @@ (define (skip-when-limit-reached url method) (or (not (request-rate-limit-reached? url method)) (throw skip-key #t))) + (define (lookup-by-nar-hash hash) + (lookup-directory-by-nar-hash (content-hash-value hash) + (content-hash-algorithm hash))) + (parameterize ((%allow-request? skip-when-limit-reached)) (catch #t (lambda () (match (package-source package) (#f ;no source '()) - ((and (? origin?) + ((and (? origin? origin) (= origin-uri (? git-reference? reference))) (define url (git-reference-url reference)) (define commit (git-reference-commit reference)) - - (match (if (commit-id? commit) - (or (lookup-revision commit) - (lookup-origin-revision url commit)) - (lookup-origin-revision url commit)) - ((? revision? revision) + (define hash + (origin-hash origin)) + + (match (or (lookup-by-nar-hash hash) + (if (commit-id? commit) + (or (lookup-revision commit) + (lookup-origin-revision url commit)) + (lookup-origin-revision url commit))) + ((or (? string?) (? revision?)) '()) (#f ;; Revision is missing from the archive, attempt to save it. @@ -1704,9 +1711,10 @@ (define commit (if (and=> (origin-hash origin) ;XXX: for ungoogled-chromium content-hash-value) ;& icecat (let ((hash (origin-hash origin))) - (match (lookup-content (content-hash-value hash) - (symbol->string - (content-hash-algorithm hash))) + (match (or (lookup-by-nar-hash hash) + (lookup-content (content-hash-value 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 diff --git a/tests/lint.scm b/tests/lint.scm index a52a82237b..87213fcc78 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Cyril Roelandt ;;; Copyright © 2014, 2015, 2016 Eric Bavier -;;; Copyright © 2014-2023 Ludovic Courtès +;;; Copyright © 2014-2024 Ludovic Courtès ;;; Copyright © 2015, 2016 Mathieu Lirzin ;;; Copyright © 2016 Hartmut Goebel ;;; Copyright © 2017 Alex Kost @@ -1358,7 +1358,8 @@ (define (package-with-phase-changes changes) ;; https://archive.softwareheritage.org/api/1/content/ (content "{ \"checksums\": {}, \"data_url\": \"xyz\", \"length\": 42 }")) - (with-http-server `((200 ,content)) + (with-http-server `((404 "") ;extid + (200 ,content)) (parameterize ((%swh-base-url (%local-url))) (check-archival (dummy-package "x" (source origin))))))) @@ -1378,7 +1379,8 @@ (define (package-with-phase-changes changes) \"type\": \"file\", \"name\": \"README\" \"length\": 42 } ]")) - (with-http-server `((404 "") ;lookup-content + (with-http-server `((404 "") ;lookup-directory-by-nar-hash + (404 "") ;lookup-content (200 ,disarchive) ;Disarchive database lookup (200 ,directory)) ;lookup-directory (mock ((guix download) %disarchive-mirrors (list (%local-url))) @@ -1397,7 +1399,8 @@ (define (package-with-phase-changes changes) \"save_request_date\": \"2014-11-17T22:09:38+01:00\", \"save_request_status\": \"accepted\", \"save_task_status\": \"scheduled\" }") - (warnings (with-http-server `((404 "No revision.") ;lookup-revision + (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))) @@ -1415,7 +1418,27 @@ (define (package-with-phase-changes changes) ;; https://archive.softwareheritage.org/api/1/revision/ (revision "{ \"author\": {}, \"parents\": [], \"date\": \"2014-11-17T22:09:38+01:00\" }")) - (with-http-server `((200 ,revision)) + (with-http-server `((404 "No directory.") ;lookup-directory-by-nar-hash + (200 ,revision)) + (parameterize ((%swh-base-url (%local-url))) + (check-archival (dummy-package "x" (source origin))))))) + +(test-equal "archival: nar-sha256 extid available" + '() + (let* ((origin (origin + (method git-fetch) + (uri (git-reference + (url "http://example.org/foo.git") + (commit "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))) + (sha256 (make-bytevector 32)))) + ;; https://archive.softwareheritage.org/api/1/extid/doc/ + (extid "{ \"extid_type\": \"nar-sha256\", + \"extid\": \"1234\", + \"extid_version\": 0, + \"target\": \"swh:1:dir:cabba93\", + \"target_url\": \"boo\" + }")) + (with-http-server `((200 ,extid)) (parameterize ((%swh-base-url (%local-url))) (check-archival (dummy-package "x" (source origin))))))) -- cgit v1.2.3 From 6ae32db25ee0e1064f37cd754aa12e7e0560237f 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 --- guix/utils.scm | 11 +++++++++++ tests/utils.scm | 14 ++++++++++++++ 2 files changed, 25 insertions(+) (limited to 'tests') diff --git a/guix/utils.scm b/guix/utils.scm index e4e9d922e7..94b4d753d0 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -20,6 +20,7 @@ ;;; Copyright © 2023 Janneke Nieuwenhuizen ;;; Copyright © 2023 Zheng Junjie <873216071@qq.com> ;;; Copyright © 2023 Foundation Devices, Inc. +;;; Copyright © 2024 Herman Rimm ;;; ;;; This file is part of GNU Guix. ;;; @@ -38,6 +39,7 @@ (define-module (guix utils) #:use-module (guix config) + #:autoload (guix read-print) (object->string*) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -145,6 +147,7 @@ (define-module (guix utils) go-to-location edit-expression delete-expression + insert-expression filtered-port decompressed-port @@ -502,6 +505,14 @@ (define (delete-expression source-properties) "Delete the expression specified by SOURCE-PROPERTIES." (edit-expression source-properties (const "") #:include-trailing-newline? #t)) +(define (insert-expression source-properties expr) + "Insert EXPR before the top-level expression specified by +SOURCE-PROPERTIES." + (let* ((expr (object->string* expr 0)) + (insert (lambda (str) + (string-append expr "\n\n" str)))) + (edit-expression source-properties insert))) + ;;; ;;; Keyword arguments. 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 a85405095aa14d388d8f15ba464b2ccb66cb55ce 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