From 1575da60628cf2594cd7b1ab0812ec4c50ac5092 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 29 Mar 2021 17:28:34 +0200 Subject: gnu-maintenance: Recognize "-source" tarball suffix. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by Léo Le Bouter . * guix/gnu-maintenance.scm (%tarball-rx): Add "-[Ss]ource" suffix. * tests/gnu-maintenance.scm ("release-file?"): Add exiv2 example. --- tests/gnu-maintenance.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/gnu-maintenance.scm b/tests/gnu-maintenance.scm index a3e48a0933..59e79905c5 100644 --- a/tests/gnu-maintenance.scm +++ b/tests/gnu-maintenance.scm @@ -30,7 +30,8 @@ ("texmacs" "TeXmacs-1.0.7.9-src.tar.gz") ("icecat" "icecat-38.4.0-gnu1.tar.bz2") ("mit-scheme" "mit-scheme-9.2.tar.gz") - ("mediainfo" "mediainfo_20.09.tar.xz"))) + ("mediainfo" "mediainfo_20.09.tar.xz") + ("exiv2" "exiv2-0.27.3-Source.tar.gz"))) (every (lambda (project+file) (not (apply release-file? project+file))) '(("guile" "guile-www-1.1.1.tar.gz") -- cgit v1.2.3 From c536f0b217714917988d2f412999d978c2f2f495 Mon Sep 17 00:00:00 2001 From: Cees de Groot Date: Tue, 30 Mar 2021 17:11:48 +0200 Subject: tests: Make 'publish' test umask-insensitive. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by Konrad Hinsen . * tests/publish.scm ("with cache"): Pass the result of 'stat:perms' to 'logand' to be umask-insensitive. Signed-off-by: Ludovic Courtès --- tests/publish.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/tests/publish.scm b/tests/publish.scm index 52101876b5..3e67c435ac 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -452,8 +452,8 @@ References: ~%" (wait-for-file cached) ;; Both the narinfo and nar should be world-readable. - (= #o644 (stat:perms (lstat cached))) - (= #o644 (stat:perms (lstat nar))) + (= #o444 (logand #o444 (stat:perms (lstat cached)))) + (= #o444 (logand #o444 (stat:perms (lstat nar)))) (let* ((body (http-get-port url)) (compressed (http-get nar-url)) -- cgit v1.2.3 From ceeea60bbc1e2be6a86cef208fcd80eb61c92934 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 5 Apr 2021 11:30:20 +0200 Subject: gnu-maintenance: Recognize more source tarball naming schemes. * guix/gnu-maintenance.scm (%package-name-rx): Add ".src" and ".orig" suffixes. * tests/gnu-maintenance.scm ("release-file?"): Add mpg321 and bvi examples. ("tarball->version"): New test. --- guix/gnu-maintenance.scm | 2 +- tests/gnu-maintenance.scm | 18 ++++++++++++++++-- 2 files changed, 17 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index c7972d13a5..0390df59f1 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -595,7 +595,7 @@ list available from %GNU-FILE-LIST-URI over HTTP(S)." (define %package-name-rx ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed. - (make-regexp "^(.*)[-_](([0-9]|\\.)+)(-src)?")) + (make-regexp "^(.*)[-_](([0-9]|\\.)+)(-src|\\.src|\\.orig)?")) (define (gnu-package-name->name+version name+version) "Return the package name and version number extracted from NAME+VERSION." diff --git a/tests/gnu-maintenance.scm b/tests/gnu-maintenance.scm index 59e79905c5..837b80063a 100644 --- a/tests/gnu-maintenance.scm +++ b/tests/gnu-maintenance.scm @@ -19,7 +19,8 @@ (define-module (test-gnu-maintenance) #:use-module (guix gnu-maintenance) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-64)) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match)) (test-begin "gnu-maintenance") @@ -31,7 +32,9 @@ ("icecat" "icecat-38.4.0-gnu1.tar.bz2") ("mit-scheme" "mit-scheme-9.2.tar.gz") ("mediainfo" "mediainfo_20.09.tar.xz") - ("exiv2" "exiv2-0.27.3-Source.tar.gz"))) + ("exiv2" "exiv2-0.27.3-Source.tar.gz") + ("mpg321" "mpg321_0.3.2.orig.tar.gz") + ("bvi" "bvi-1.4.1.src.tar.gz"))) (every (lambda (project+file) (not (apply release-file? project+file))) '(("guile" "guile-www-1.1.1.tar.gz") @@ -40,4 +43,15 @@ ("mit-scheme" "mit-scheme-9.2-doc-pdf.tar.gz") ("gnutls" "gnutls-3.2.18-w32.zip"))))) +(test-assert "tarball->version" + (let ((tarball->version (@@ (guix gnu-maintenance) tarball->version))) + (every (match-lambda + ((file version) + (equal? (tarball->version file) version))) + '(("coreutils-8.32.tar.gz" "8.32") + ("mediainfo_20.09.tar.xz" "20.09") + ("exiv2-0.27.3-Source.tar.gz" "0.27.3") + ("mpg321_0.3.2.orig.tar.gz" "0.3.2") + ("bvi-1.4.1.src.tar.gz" "1.4.1"))))) + (test-end) -- cgit v1.2.3 From 2d73086262e1fb33cd0f0f16f74a495fe06b38aa Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 Apr 2021 12:10:29 +0200 Subject: daemon: 'guix substitute' replies on FD 4. This avoids the situation where error messages would unintentionally go to stderr and be wrongfully interpreted as a reply by the daemon. Fixes . This is a followup to ee3226e9d54891c7e696912245e4904435be191c. * guix/scripts/substitute.scm (display-narinfo-data): Add 'port' parameter and honor it. (process-query): Likewise. (process-substitution): Likewise. (%error-to-file-descriptor-4?, with-redirected-error-port): Remove. (%reply-file-descriptor): New variable. (guix-substitute): Remove use of 'with-redirected-error-port'. Define 'reply-port' and pass it to 'process-query' and 'process-substitution'. * nix/libstore/build.cc (SubstitutionGoal::handleChildOutput): Swap 'builderOut' and 'fromAgent'. * nix/libstore/local-store.cc (LocalStore::getLineFromSubstituter): Likewise. * tests/substitute.scm : Set '%reply-file-descriptor' rather than '%error-to-file-descriptor-4?'. --- guix/scripts/substitute.scm | 191 +++++++++++++++++++++----------------------- nix/libstore/build.cc | 4 +- nix/libstore/local-store.cc | 12 +-- tests/substitute.scm | 4 +- 4 files changed, 99 insertions(+), 112 deletions(-) (limited to 'tests') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 79eaabd8fd..48309f9b3a 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -63,7 +63,7 @@ #:use-module (web uri) #:use-module (guix http-client) #:export (%allow-unauthenticated-substitutes? - %error-to-file-descriptor-4? + %reply-file-descriptor substitute-urls guix-substitute)) @@ -279,29 +279,29 @@ Internal tool to substitute a pre-built binary to a local build.\n")) "Evaluate EXP... Return its CPU usage as a fraction between 0 and 1." (call-with-cpu-usage-monitoring (lambda () exp ...))) -(define (display-narinfo-data narinfo) - "Write to the current output port the contents of NARINFO in the format -expected by the daemon." - (format #t "~a\n~a\n~a\n" +(define (display-narinfo-data port narinfo) + "Write to PORT the contents of NARINFO in the format expected by the +daemon." + (format port "~a\n~a\n~a\n" (narinfo-path narinfo) (or (and=> (narinfo-deriver narinfo) (cute string-append (%store-prefix) "/" <>)) "") (length (narinfo-references narinfo))) - (for-each (cute format #t "~a/~a~%" (%store-prefix) <>) + (for-each (cute format port "~a/~a~%" (%store-prefix) <>) (narinfo-references narinfo)) (let-values (((uri compression file-size) (narinfo-best-uri narinfo #:fast-decompression? %prefer-fast-decompression?))) - (format #t "~a\n~a\n" + (format port "~a\n~a\n" (or file-size 0) (or (narinfo-size narinfo) 0)))) -(define* (process-query command +(define* (process-query port command #:key cache-urls acl) - "Reply to COMMAND, a query as written by the daemon to this process's + "Reply on PORT to COMMAND, a query as written by the daemon to this process's standard input. Use ACL as the access-control list against which to check authorized substitutes." (define valid? @@ -338,17 +338,17 @@ authorized substitutes." #:open-connection open-connection-for-uri/cached #:make-progress-reporter make-progress-reporter))) (for-each (lambda (narinfo) - (format #t "~a~%" (narinfo-path narinfo))) + (format port "~a~%" (narinfo-path narinfo))) substitutable) - (newline))) + (newline port))) (("info" paths ..1) ;; Reply info about PATHS if it's in CACHE-URLS. (let ((substitutable (lookup-narinfos/diverse cache-urls paths valid? #:open-connection open-connection-for-uri/cached #:make-progress-reporter make-progress-reporter))) - (for-each display-narinfo-data substitutable) - (newline))) + (for-each (cut display-narinfo-data port <>) substitutable) + (newline port))) (wtf (error "unknown `--query' command" wtf)))) @@ -428,14 +428,14 @@ server certificates." "Bind PORT with EXP... to a socket connected to URI." (call-with-cached-connection uri (lambda (port) exp ...))) -(define* (process-substitution store-item destination +(define* (process-substitution port store-item destination #:key cache-urls acl deduplicate? print-build-trace?) "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to DESTINATION as a nar file. Verify the substitute against ACL, and verify its hash against what appears in the narinfo. When DEDUPLICATE? is true, and if -DESTINATION is in the store, deduplicate its files. Print a status line on -the current output port." +DESTINATION is in the store, deduplicate its files. Print a status line to +PORT." (define narinfo (lookup-narinfo cache-urls store-item (if (%allow-unauthenticated-substitutes?) @@ -565,10 +565,10 @@ the current output port." (let ((actual (get-hash))) (if (bytevector=? actual expected) ;; Tell the daemon that we're done. - (format (current-output-port) "success ~a ~a~%" + (format port "success ~a ~a~%" (narinfo-hash narinfo) (narinfo-size narinfo)) ;; The actual data has a different hash than that in NARINFO. - (format (current-output-port) "hash-mismatch ~a ~a ~a~%" + (format port "hash-mismatch ~a ~a ~a~%" (hash-algorithm-name algorithm) (bytevector->nix-base32-string expected) (bytevector->nix-base32-string actual))))))) @@ -682,28 +682,10 @@ default value." (unless (string->uri uri) (leave (G_ "~a: invalid URI~%") uri))) -(define %error-to-file-descriptor-4? - ;; Whether to direct 'current-error-port' to file descriptor 4 like - ;; 'guix-daemon' expects. - (make-parameter #t)) - -;; The daemon's agent code opens file descriptor 4 for us and this is where -;; stderr should go. -(define-syntax-rule (with-redirected-error-port exp ...) - "Evaluate EXP... with the current error port redirected to file descriptor 4 -if needed, as expected by the daemon's agent." - (let ((thunk (lambda () exp ...))) - (if (%error-to-file-descriptor-4?) - (parameterize ((current-error-port (fdopen 4 "wl"))) - ;; Redirect diagnostics to file descriptor 4 as well. - (guix-warning-port (current-error-port)) - - ;; 'with-continuation-barrier' captures the initial value of - ;; 'current-error-port' to report backtraces in case of uncaught - ;; exceptions. Without it, backtraces would be printed to FD 2, - ;; thereby confusing the daemon. - (with-continuation-barrier thunk)) - (thunk)))) +(define %reply-file-descriptor + ;; The file descriptor where replies to the daemon must be sent, or #f to + ;; use the current output port instead. + (make-parameter 4)) (define-command (guix-substitute . args) (category internal) @@ -719,68 +701,73 @@ if needed, as expected by the daemon's agent." (define deduplicate? (find-daemon-option "deduplicate")) - (with-redirected-error-port - (mkdir-p %narinfo-cache-directory) - (maybe-remove-expired-cache-entries %narinfo-cache-directory - cached-narinfo-files - #:entry-expiration - cached-narinfo-expiration-time - #:cleanup-period - %narinfo-expired-cache-entry-removal-delay) - (check-acl-initialized) - - ;; Sanity-check SUBSTITUTE-URLS so we can provide a meaningful error - ;; message. - (for-each validate-uri (substitute-urls)) - - ;; Attempt to install the client's locale so that messages are suitably - ;; translated. LC_CTYPE must be a UTF-8 locale; it's the case by default - ;; so don't change it. - (match (or (find-daemon-option "untrusted-locale") - (find-daemon-option "locale")) - (#f #f) - (locale (false-if-exception (setlocale LC_MESSAGES locale)))) - - (catch 'system-error - (lambda () - (set-thread-name "guix substitute")) - (const #t)) ;GNU/Hurd lacks 'prctl' - - (with-networking - (with-error-handling ; for signature errors - (match args - (("--query") - (let ((acl (current-acl))) - (let loop ((command (read-line))) - (or (eof-object? command) - (begin - (process-query command - #:cache-urls (substitute-urls) - #:acl acl) - (loop (read-line))))))) - (("--substitute") - ;; Download STORE-PATH and store it as a Nar in file DESTINATION. - ;; Specify the number of columns of the terminal so the progress - ;; report displays nicely. - (parameterize ((current-terminal-columns (client-terminal-columns))) - (let loop () - (match (read-line) - ((? eof-object?) - #t) - ((= string-tokenize ("substitute" store-path destination)) - (process-substitution store-path destination - #:cache-urls (substitute-urls) - #:acl (current-acl) - #:deduplicate? deduplicate? - #:print-build-trace? - print-build-trace?) - (loop)))))) - ((or ("-V") ("--version")) - (show-version-and-exit "guix substitute")) - (("--help") - (show-help)) - (opts - (leave (G_ "~a: unrecognized options~%") opts))))))) + (define reply-port + ;; Port used to reply to the daemon. + (if (%reply-file-descriptor) + (fdopen (%reply-file-descriptor) "wl") + (current-output-port))) + + (mkdir-p %narinfo-cache-directory) + (maybe-remove-expired-cache-entries %narinfo-cache-directory + cached-narinfo-files + #:entry-expiration + cached-narinfo-expiration-time + #:cleanup-period + %narinfo-expired-cache-entry-removal-delay) + (check-acl-initialized) + + ;; Sanity-check SUBSTITUTE-URLS so we can provide a meaningful error + ;; message. + (for-each validate-uri (substitute-urls)) + + ;; Attempt to install the client's locale so that messages are suitably + ;; translated. LC_CTYPE must be a UTF-8 locale; it's the case by default + ;; so don't change it. + (match (or (find-daemon-option "untrusted-locale") + (find-daemon-option "locale")) + (#f #f) + (locale (false-if-exception (setlocale LC_MESSAGES locale)))) + + (catch 'system-error + (lambda () + (set-thread-name "guix substitute")) + (const #t)) ;GNU/Hurd lacks 'prctl' + + (with-networking + (with-error-handling ; for signature errors + (match args + (("--query") + (let ((acl (current-acl))) + (let loop ((command (read-line))) + (or (eof-object? command) + (begin + (process-query reply-port command + #:cache-urls (substitute-urls) + #:acl acl) + (loop (read-line))))))) + (("--substitute") + ;; Download STORE-PATH and store it as a Nar in file DESTINATION. + ;; Specify the number of columns of the terminal so the progress + ;; report displays nicely. + (parameterize ((current-terminal-columns (client-terminal-columns))) + (let loop () + (match (read-line) + ((? eof-object?) + #t) + ((= string-tokenize ("substitute" store-path destination)) + (process-substitution reply-port store-path destination + #:cache-urls (substitute-urls) + #:acl (current-acl) + #:deduplicate? deduplicate? + #:print-build-trace? + print-build-trace?) + (loop)))))) + ((or ("-V") ("--version")) + (show-version-and-exit "guix substitute")) + (("--help") + (show-help)) + (opts + (leave (G_ "~a: unrecognized options~%") opts)))))) ;;; Local Variables: ;;; eval: (put 'with-timeout 'scheme-indent-function 1) diff --git a/nix/libstore/build.cc b/nix/libstore/build.cc index 4f486f0822..5697ae5a43 100644 --- a/nix/libstore/build.cc +++ b/nix/libstore/build.cc @@ -3158,13 +3158,13 @@ void SubstitutionGoal::finished() void SubstitutionGoal::handleChildOutput(int fd, const string & data) { if (verbosity >= settings.buildVerbosity - && fd == substituter->builderOut.readSide) { + && fd == substituter->fromAgent.readSide) { writeToStderr(data); /* Don't write substitution output to a log file for now. We probably should, though. */ } - if (fd == substituter->fromAgent.readSide) { + if (fd == substituter->builderOut.readSide) { /* DATA may consist of several lines. Process them one by one. */ string input = data; while (!input.empty()) { diff --git a/nix/libstore/local-store.cc b/nix/libstore/local-store.cc index c304e2ddd1..675d1ba66f 100644 --- a/nix/libstore/local-store.cc +++ b/nix/libstore/local-store.cc @@ -780,8 +780,8 @@ Path LocalStore::queryPathFromHashPart(const string & hashPart) }); } -/* Read a line from the substituter's stdout, while also processing - its stderr. */ +/* Read a line from the substituter's reply file descriptor, while also + processing its stderr. */ string LocalStore::getLineFromSubstituter(Agent & run) { string res, err; @@ -802,9 +802,9 @@ string LocalStore::getLineFromSubstituter(Agent & run) } /* Completely drain stderr before dealing with stdout. */ - if (FD_ISSET(run.builderOut.readSide, &fds)) { + if (FD_ISSET(run.fromAgent.readSide, &fds)) { char buf[4096]; - ssize_t n = read(run.builderOut.readSide, (unsigned char *) buf, sizeof(buf)); + ssize_t n = read(run.fromAgent.readSide, (unsigned char *) buf, sizeof(buf)); if (n == -1) { if (errno == EINTR) continue; throw SysError("reading from substituter's stderr"); @@ -822,9 +822,9 @@ string LocalStore::getLineFromSubstituter(Agent & run) } /* Read from stdout until we get a newline or the buffer is empty. */ - else if (FD_ISSET(run.fromAgent.readSide, &fds)) { + else if (FD_ISSET(run.builderOut.readSide, &fds)) { unsigned char c; - readFull(run.fromAgent.readSide, (unsigned char *) &c, 1); + readFull(run.builderOut.readSide, (unsigned char *) &c, 1); if (c == '\n') { if (!err.empty()) printMsg(lvlError, "substitute: " + err); return res; diff --git a/tests/substitute.scm b/tests/substitute.scm index 697abc4684..21b513e1d8 100644 --- a/tests/substitute.scm +++ b/tests/substitute.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Nikita Karetnikov -;;; Copyright © 2014, 2015, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2014, 2015, 2017, 2018, 2019, 2021 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -198,7 +198,7 @@ a file for NARINFO." ;; Never use file descriptor 4, unlike what happens when invoked by the ;; daemon. -(%error-to-file-descriptor-4? #f) +(%reply-file-descriptor #f) (test-equal "query narinfo without signature" -- cgit v1.2.3 From 6aee902eaf9e38d5f41f568ef787fa0cc5203318 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Sun, 21 Mar 2021 23:53:21 -0400 Subject: import: go: Improve synopsis and description parsing. * guix/import/go.scm (%strict-tokenizer?): Set parameter to #t. (go-path-escape): Redefine to prevent inlining. (http-get*): Replace by ... (http-fetch*): this ... (json-fetch*): New procedure. (go.pkg.dev-info): Use http-fetch*. (go-package-licenses): Rewrite in terms of go.pkg.dev-info. (go-package-description): Likewise. (go-package-synopsis): Likewise. (fetch-go.mod): Use the memoized http-fetch*. (parse-go.mod): Adjust to receive content as a string. (fetch-module-meta-data): Adjust to use http-fetch*. (go-module->guix-package): Adjust to the modified fetch-go.mod return value. [inputs]: Use propagated inputs, which is the most common situations for Go libraries. [description]: Beautify description. [licenses]: Do no check for #f. The result of the license parsing is always a list. * tests/go.scm: Adjust following above changes. --- guix/import/go.scm | 213 +++++++++++++++++++++++++++++++------------------- guix/import/utils.scm | 4 +- tests/go.scm | 75 +++++++++--------- 3 files changed, 170 insertions(+), 122 deletions(-) (limited to 'tests') diff --git a/guix/import/go.scm b/guix/import/go.scm index 6c0231e113..8c8f20b109 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -33,7 +33,7 @@ #:use-module (guix http-client) #:use-module ((guix licenses) #:prefix license:) #:use-module (guix memoization) - #:autoload (htmlprag) (html->sxml) ;from Guile-Lib + #:use-module (htmlprag) ;from Guile-Lib #:autoload (guix git) (update-cached-checkout) #:autoload (gcrypt hash) (open-hash-port hash-algorithm sha256) #:autoload (guix serialization) (write-file) @@ -43,20 +43,28 @@ #:use-module (ice-9 rdelim) #:use-module (ice-9 receive) #:use-module (ice-9 regex) + #:use-module (ice-9 textual-ports) #:use-module ((rnrs io ports) #:select (call-with-port)) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) - #:use-module (sxml xpath) + #:use-module (sxml match) + #:use-module ((sxml xpath) #:renamer (lambda (s) + (if (eq? 'filter s) + 'xfilter + s))) #:use-module (web client) #:use-module (web response) #:use-module (web uri) - #:export (go-path-escape - go-module->guix-package + #:export (go-module->guix-package go-module-recursive-import)) +;;; Parameterize htmlprag to parse valid HTML more reliably. +(%strict-tokenizer? #t) + ;;; Commentary: ;;; ;;; (guix import go) attempts to make it easier to create Guix package @@ -90,6 +98,14 @@ ;;; Code: +(define http-fetch* + ;; Like http-fetch, but memoized and returning the body as a string. + (memoize (lambda args + (call-with-port (apply http-fetch args) get-string-all)))) + +(define json-fetch* + (memoize json-fetch)) + (define (go-path-escape path) "Escape a module path by replacing every uppercase letter with an exclamation mark followed with its lowercase equivalent, as per the module @@ -99,54 +115,73 @@ https://godoc.org/golang.org/x/mod/module#hdr-Escaped_Paths)." (string-append "!" (string-downcase (match:substring occurrence)))) (regexp-substitute/global #f "[A-Z]" path 'pre escape 'post)) +;; Prevent inlining of this procedure, which is accessed by unit tests. +(set! go-path-escape go-path-escape) + +(define (go.pkg.dev-info name) + (http-fetch* (string-append "https://pkg.go.dev/" name))) + (define (go-module-latest-version goproxy-url module-path) "Fetch the version number of the latest version for MODULE-PATH from the given GOPROXY-URL server." - (assoc-ref (json-fetch (format #f "~a/~a/@latest" goproxy-url - (go-path-escape module-path))) + (assoc-ref (json-fetch* (format #f "~a/~a/@latest" goproxy-url + (go-path-escape module-path))) "Version")) - (define (go-package-licenses name) "Retrieve the list of licenses that apply to NAME, a Go package or module -name (e.g. \"github.com/golang/protobuf/proto\"). The data is scraped from -the https://pkg.go.dev/ web site." - (let*-values (((url) (string-append "https://pkg.go.dev/" name - "?tab=licenses")) - ((response body) (http-get url)) - ;; Extract the text contained in a h2 child node of any - ;; element marked with a "License" class attribute. - ((select) (sxpath `(// (* (@ (equal? (class "License")))) - h2 // *text*)))) - (and (eq? (response-code response) 200) - (match (select (html->sxml body)) - (() #f) ;nothing selected - (licenses licenses))))) - -(define (go.pkg.dev-info name) - (http-get (string-append "https://pkg.go.dev/" name))) -(define go.pkg.dev-info* - (memoize go.pkg.dev-info)) +name (e.g. \"github.com/golang/protobuf/proto\")." + (let* ((body (go.pkg.dev-info (string-append name "?tab=licenses"))) + ;; Extract the text contained in a h2 child node of any + ;; element marked with a "License" class attribute. + (select (sxpath `(// (* (@ (equal? (class "License")))) + h2 // *text*)))) + (select (html->sxml body)))) + +(define (sxml->texi sxml-node) + "A very basic SXML to Texinfo converter which attempts to preserve HTML +formatting and links as text." + (sxml-match sxml-node + ((strong ,text) + (format #f "@strong{~a}" text)) + ((a (@ (href ,url)) ,text) + (format #f "@url{~a,~a}" url text)) + ((code ,text) + (format #f "@code{~a}" text)) + (,something-else something-else))) (define (go-package-description name) "Retrieve a short description for NAME, a Go package name, -e.g. \"google.golang.org/protobuf/proto\". The data is scraped from the -https://pkg.go.dev/ web site." - (let*-values (((response body) (go.pkg.dev-info* name)) - ;; Extract the text contained in a h2 child node of any - ;; element marked with a "License" class attribute. - ((select) (sxpath - `(// (section - (@ (equal? (class "Documentation-overview")))) - (p 1))))) - (and (eq? (response-code response) 200) - (match (select (html->sxml body)) - (() #f) ;nothing selected - (((p . strings)) - ;; The paragraph text is returned as a list of strings embedding - ;; newline characters. Join them and strip the newline - ;; characters. - (string-delete #\newline (string-join strings))))))) +e.g. \"google.golang.org/protobuf/proto\"." + (let* ((body (go.pkg.dev-info name)) + (sxml (html->sxml body)) + (overview ((sxpath + `(// + (* (@ (equal? (class "Documentation-overview")))) + (p 1))) sxml)) + ;; Sometimes, the first paragraph just contains images/links that + ;; has only "\n" for text. The following filter is designed to + ;; omit it. + (contains-text? (lambda (node) + (remove string-null? + (map string-trim-both + (filter (node-typeof? '*text*) + (cdr node)))))) + (select-content (sxpath + `(// + (* (@ (equal? (class "UnitReadme-content")))) + div // p ,(xfilter contains-text?)))) + ;; Fall-back to use content; this is less desirable as it is more + ;; verbose, but not every page has an overview. + (description (if (not (null? overview)) + overview + (select-content sxml))) + (description* (and (not (null? description)) + (first description)))) + (match description* + (() #f) ;nothing selected + ((p elements ...) + (apply string-append (filter string? (map sxml->texi elements))))))) (define (go-package-synopsis module-name) "Retrieve a short synopsis for a Go module named MODULE-NAME, @@ -154,17 +189,17 @@ e.g. \"google.golang.org/protobuf\". The data is scraped from the https://pkg.go.dev/ web site." ;; Note: Only the *module* (rather than package) page has the README title ;; used as a synopsis on the https://pkg.go.dev web site. - (let*-values (((response body) (go.pkg.dev-info* module-name)) - ;; Extract the text contained in a h2 child node of any - ;; element marked with a "License" class attribute. - ((select) (sxpath - `(// (div (@ (equal? (class "UnitReadme-content")))) - // h3 *text*)))) - (and (eq? (response-code response) 200) - (match (select (html->sxml body)) - (() #f) ;nothing selected - ((title more ...) ;title is the first string of the list - (string-trim-both title)))))) + (let* ((url (string-append "https://pkg.go.dev/" module-name)) + (body (http-fetch* url)) + ;; Extract the text contained in a h2 child node of any + ;; element marked with a "License" class attribute. + (select-title (sxpath + `(// (div (@ (equal? (class "UnitReadme-content")))) + // h3 *text*)))) + (match (select-title (html->sxml body)) + (() #f) ;nothing selected + ((title more ...) ;title is the first string of the list + (string-trim-both title))))) (define (list->licenses licenses) "Given a list of LICENSES mostly following the SPDX conventions, return the @@ -189,13 +224,13 @@ corresponding Guix license or 'unknown-license!" 'unknown-license!))) licenses)) -(define (fetch-go.mod goproxy-url module-path version) - "Fetches go.mod from the given GOPROXY-URL server for the given MODULE-PATH -and VERSION." - (let ((url (format #f "~a/~a/@v/~a.mod" goproxy-url +(define (fetch-go.mod goproxy module-path version) + "Fetch go.mod from the given GOPROXY server for the given MODULE-PATH +and VERSION and return an input port." + (let ((url (format #f "~a/~a/@v/~a.mod" goproxy (go-path-escape module-path) (go-path-escape version)))) - (http-fetch url))) + (http-fetch* url))) (define %go.mod-require-directive-rx ;; A line in a require directive is composed of a module path and @@ -216,9 +251,8 @@ and VERSION." "[[:blank:]]+" "=>" "[[:blank:]]+" "([^[:blank:]]+)([[:blank:]]+([^[:blank:]]+))?"))) -(define (parse-go.mod port) - "Parse the go.mod file accessible via the input PORT, returning a list of -requirements." +(define (parse-go.mod content) + "Parse the go.mod file CONTENT, returning a list of requirements." (define-record-type (make-results requirements replacements) results? @@ -229,7 +263,7 @@ requirements." (define (toplevel results) "Main parser, RESULTS is a pair of alist serving as accumulator for all encountered requirements and replacements." - (let ((line (read-line port))) + (let ((line (read-line))) (cond ((eof-object? line) ;; parsing ended, give back the result @@ -255,7 +289,7 @@ requirements." (toplevel results))))) (define (in-require results) - (let ((line (read-line port))) + (let ((line (read-line))) (cond ((eof-object? line) ;; this should never happen here but we ignore silently @@ -267,7 +301,7 @@ requirements." (in-require (require-directive results line)))))) (define (in-replace results) - (let ((line (read-line port))) + (let ((line (read-line))) (cond ((eof-object? line) ;; this should never happen here but we ignore silently @@ -306,7 +340,9 @@ requirements." (($ requirements replaced) (make-results (alist-cons module-path version requirements) replaced))))) - (let ((results (toplevel (make-results '() '())))) + (let ((results (with-input-from-string content + (lambda _ + (toplevel (make-results '() '())))))) (match results (($ requirements replaced) ;; At last we remove replaced modules from the requirements list @@ -325,8 +361,10 @@ requirements." (url-prefix vcs-url-prefix) (root-regex vcs-root-regex) (type vcs-type)) + (define (make-vcs prefix regexp type) - (%make-vcs prefix (make-regexp regexp) type)) + (%make-vcs prefix (make-regexp regexp) type)) + (define known-vcs ;; See the following URL for the official Go equivalent: ;; https://github.com/golang/go/blob/846dce9d05f19a1f53465e62a304dea21b99f910/src/cmd/go/internal/vcs/vcs.go#L1026-L1087 @@ -387,6 +425,14 @@ hence the need to derive this information." "/" "-") "_" "-")))) +(define (strip-.git-suffix/maybe repo-url) + "Strip a repository URL '.git' suffix from REPO-URL if hosted at GitHub." + (match repo-url + ((and (? (cut string-prefix? "https://github.com" <>)) + (? (cut string-suffix? ".git" <>))) + (string-drop-right repo-url 4)) + (_ repo-url))) + (define-record-type (make-module-meta import-prefix vcs repo-root) module-meta? @@ -399,21 +445,22 @@ hence the need to derive this information." because goproxy servers don't currently provide all the information needed to build a package." ;; - (let* ((port (http-fetch (format #f "https://~a?go-get=1" module-path))) + (let* ((meta-data (http-fetch* (format #f "https://~a?go-get=1" module-path))) (select (sxpath `(// head (meta (@ (equal? (name "go-import")))) // content)))) - (match (select (call-with-port port html->sxml)) - (() #f) ;nothing selected + (match (select (html->sxml meta-data)) + (() #f) ;nothing selected (((content content-text)) (match (string-split content-text #\space) ((root-path vcs repo-url) - (make-module-meta root-path (string->symbol vcs) repo-url))))))) + (make-module-meta root-path (string->symbol vcs) + (strip-.git-suffix/maybe repo-url)))))))) -(define (module-meta-data-repo-url meta-data goproxy-url) +(define (module-meta-data-repo-url meta-data goproxy) "Return the URL where the fetcher which will be used can download the source." (if (member (module-meta-vcs meta-data) '(fossil mod)) - goproxy-url + goproxy (module-meta-repo-root meta-data))) ;; XXX: Copied from (guix scripts hash). @@ -466,6 +513,9 @@ control system is being used." (method git-fetch) (uri (git-reference (url ,vcs-repo-url) + ;; This is done because the version field of the package, + ;; which the generated quoted expression refers to, has been + ;; stripped of any 'v' prefixed. (commit ,(if (and plain-version? v-prefixed?) '(string-append "v" version) '(go-version->git-ref version))))) @@ -505,8 +555,8 @@ control system is being used." (define* (go-module->guix-package module-path #:key (goproxy-url "https://proxy.golang.org")) (let* ((latest-version (go-module-latest-version goproxy-url module-path)) - (port (fetch-go.mod goproxy-url module-path latest-version)) - (dependencies (map car (call-with-port port parse-go.mod))) + (content (fetch-go.mod goproxy-url module-path latest-version)) + (dependencies (map car (parse-go.mod content))) (guix-name (go-module->guix-package-name module-path)) (root-module-path (module-path->repository-root module-path)) ;; The VCS type and URL are not included in goproxy information. For @@ -527,14 +577,17 @@ control system is being used." (build-system go-build-system) (arguments '(#:import-path ,root-module-path)) - ,@(maybe-inputs (map go-module->guix-package-name dependencies)) + ,@(maybe-propagated-inputs + (map go-module->guix-package-name dependencies)) (home-page ,(format #f "https://~a" root-module-path)) (synopsis ,synopsis) - (description ,description) - (license ,(match (and=> licenses list->licenses) - ((license) license) - ((licenses ...) `(list ,@licenses)) - (x x)))) + (description ,(and=> description beautify-description)) + (license ,(match (list->licenses licenses) + (() #f) ;unknown license + ((license) ;a single license + license) + ((license ...) ;a list of licenses + `(list ,@license))))) dependencies))) (define go-module->guix-package* (memoize go-module->guix-package)) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index c2db5a323b..adf90f84d7 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -446,8 +446,8 @@ obtain a node's uniquely identifying \"key\"." "Return a list of package expressions for PACKAGE-NAME and all its dependencies, sorted in topological order. For each package, call (REPO->GUIX-PACKAGE NAME :KEYS version repo), which should return a -package expression and a list of dependencies; call (GUIX-NAME NAME) to -obtain the Guix package name corresponding to the upstream name." +package expression and a list of dependencies; call (GUIX-NAME PACKAGE-NAME) +to obtain the Guix package name corresponding to the upstream name." (define-record-type (make-node name version package dependencies) node? diff --git a/tests/go.scm b/tests/go.scm index 6ab99f508a..fa8fa7a2a6 100644 --- a/tests/go.scm +++ b/tests/go.scm @@ -180,13 +180,9 @@ require github.com/kr/pretty v0.2.1 (define (testing-parse-mod name expected input) (define (inf? p1 p2) (stringguix-package" '(package - (name "go-github-com-go-check-check") - (version "0.0.0-20201130134442-10cb98267c6c") - (source - (origin - (method git-fetch) - (uri (git-reference - (url "https://github.com/go-check/check.git") - (commit (go-version->git-ref version)))) - (file-name (git-file-name name version)) - (sha256 - (base32 - "0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5")))) - (build-system go-build-system) - (arguments - (quote (#:import-path "github.com/go-check/check"))) - (inputs - (quasiquote (("go-github-com-kr-pretty" - (unquote go-github-com-kr-pretty))))) - (home-page "https://github.com/go-check/check") - (synopsis "Instructions") - (description #f) - (license license:bsd-2)) + (name "go-github-com-go-check-check") + (version "0.0.0-20201130134442-10cb98267c6c") + (source + (origin + (method git-fetch) + (uri (git-reference + (url "https://github.com/go-check/check") + (commit (go-version->git-ref version)))) + (file-name (git-file-name name version)) + (sha256 + (base32 + "0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5")))) + (build-system go-build-system) + (arguments + '(#:import-path "github.com/go-check/check")) + (propagated-inputs + `(("go-github-com-kr-pretty" ,go-github-com-kr-pretty))) + (home-page "https://github.com/go-check/check") + (synopsis "Instructions") + (description "Package check is a rich testing extension for Go's testing \ +package.") + (license license:bsd-2)) ;; Replace network resources with sample data. (call-with-temporary-directory (lambda (checkout) (mock ((web client) http-get (mock-http-get fixtures-go-check-test)) - (mock ((guix http-client) http-fetch - (mock-http-fetch fixtures-go-check-test)) - (mock ((guix git) update-cached-checkout - (lambda* (url #:key ref) - ;; Return an empty directory and its hash. - (values checkout - (nix-base32-string->bytevector - "0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5") - #f))) - (go-module->guix-package "github.com/go-check/check"))))))) + (mock ((guix http-client) http-fetch + (mock-http-fetch fixtures-go-check-test)) + (mock ((guix git) update-cached-checkout + (lambda* (url #:key ref) + ;; Return an empty directory and its hash. + (values checkout + (nix-base32-string->bytevector + "0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5") + #f))) + (go-module->guix-package "github.com/go-check/check"))))))) (test-end "go") - -- cgit v1.2.3 From a8b927a562aad7e5f77d0e4db2d9cee3434446d2 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Fri, 19 Mar 2021 16:41:51 -0400 Subject: import: go: Add an option to use pinned versions. The ability to pin versions is handy when having to deal to packages that bootstrap themselves through a chain of former versions. Not using pinned versions in these case could introduce dependency cycles. * guix/build-system/go.scm (guix) (%go-version-rx): Rename to... (%go-pseudo-version-rx): ... this. Simplify the regular expression, which in turns makes it more robust. * guix/build-system/go.scm (go-version->git-ref): Adjust following the above rename. (go-pseudo-version?): New predicate. (go-module-latest-version): Rename to ... (go-module-version-string): ... this. Rename goproxy-url argument to just goproxy. Add a VERSION keyword argument, update docstring and adjust to have it used. (go-module-available-versions): New procedure. (%go.mod-require-directive-rx): Document regexp. (parse-go.mod): Harmonize the way dependencies are recorded to a list of lists rather than a list of pairs, as done for other importers. Rewrite to directly pass multiple values rather than a record object. Filter the replaced modules in a functional style. (go-module->guix-package): Add docstring. [version, pin-versions?]: New arguments. Rename the GOPROXY-URL argument to GOPROXY. Adjust to the new returned value of fetch-go.mod, which is a string. Fail when the provided version doesn't exist. Return a list dependencies and their versions when in pinned versions mode, else just the dependencies. (go-module-recursive-import)[version, pin-versions?]: New arguments. Honor the new arguments and guard against network errors. * guix/scripts/import/go.scm (%default-options): Register a default value for the goproxy argument. (show-help): Document that a version can be specified. Remove the --version argument and add a --pin-versions argument. (%options)[version]: Remove option. [pin-versions]: Add option. (guix-import-go): Adjust so the version provided from the module name is honored, along the new pin-versions? argument. * tests/go.scm: Adjust and add new tests. --- guix/build-system/go.scm | 24 +++-- guix/import/go.scm | 239 +++++++++++++++++++++++++++------------------ guix/scripts/import/go.scm | 70 +++++++------ tests/go.scm | 64 ++++++------ 4 files changed, 234 insertions(+), 163 deletions(-) (limited to 'tests') diff --git a/guix/build-system/go.scm b/guix/build-system/go.scm index 0e2c1cd2ee..8f55796e86 100644 --- a/guix/build-system/go.scm +++ b/guix/build-system/go.scm @@ -31,6 +31,7 @@ go-build go-build-system + go-pseudo-version? go-version->git-ref)) ;; Commentary: @@ -40,17 +41,19 @@ ;; ;; Code: -(define %go-version-rx +(define %go-pseudo-version-rx + ;; Match only the end of the version string; this is so that matching the + ;; more complex leading semantic version pattern is not required. (make-regexp (string-append - "(v?[0-9]\\.[0-9]\\.[0-9])" ;"v" prefix can be omitted in version prefix - "(-|-pre\\.0\\.|-0\\.)" ;separator - "([0-9]{14})-" ;timestamp - "([0-9A-Fa-f]{12})"))) ;commit hash + "([0-9]{14}-)" ;timestamp + "([0-9A-Fa-f]{12})" ;commit hash + "(\\+incompatible)?$"))) ;optional +incompatible tag (define (go-version->git-ref version) "Parse VERSION, a \"pseudo-version\" as defined at , and extract the commit hash from -it, defaulting to full VERSION if a pseudo-version pattern is not recognized." +it, defaulting to full VERSION (stripped from the \"+incompatible\" suffix if +present) if a pseudo-version pattern is not recognized." ;; A module version like v1.2.3 is introduced by tagging a revision in the ;; underlying source repository. Untagged revisions can be referred to ;; using a "pseudo-version" like v0.0.0-yyyymmddhhmmss-abcdefabcdef, where @@ -65,11 +68,16 @@ it, defaulting to full VERSION if a pseudo-version pattern is not recognized." (if (string-suffix? "+incompatible" version) (string-drop-right version 13) version)) - (match (regexp-exec %go-version-rx version))) + (match (regexp-exec %go-pseudo-version-rx version))) (if match - (match:substring match 4) + (match:substring match 2) version))) +(define (go-pseudo-version? version) + "True if VERSION is a Go pseudo-version, i.e., a version string made of a +commit hash and its date rather than a proper release tag." + (regexp-exec %go-pseudo-version-rx version)) + (define %go-build-system-modules ;; Build-side modules imported and used by default. `((guix build go-build-system) diff --git a/guix/import/go.scm b/guix/import/go.scm index 8c8f20b109..ca2b9c6fa0 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -50,6 +50,7 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) #:use-module (sxml match) #:use-module ((sxml xpath) #:renamer (lambda (s) (if (eq? 'filter s) @@ -92,9 +93,7 @@ ;;; assumption that there will be no collision. ;;; TODO list -;;; - get correct hash in vcs->origin -;;; - print partial result during recursive imports (need to catch -;;; exceptions) +;;; - get correct hash in vcs->origin for Mercurial and Subversion ;;; Code: @@ -121,12 +120,26 @@ https://godoc.org/golang.org/x/mod/module#hdr-Escaped_Paths)." (define (go.pkg.dev-info name) (http-fetch* (string-append "https://pkg.go.dev/" name))) -(define (go-module-latest-version goproxy-url module-path) - "Fetch the version number of the latest version for MODULE-PATH from the -given GOPROXY-URL server." - (assoc-ref (json-fetch* (format #f "~a/~a/@latest" goproxy-url - (go-path-escape module-path))) - "Version")) +(define* (go-module-version-string goproxy name #:key version) + "Fetch the version string of the latest version for NAME from the given +GOPROXY server, or for VERSION when specified." + (let ((file (if version + (string-append "@v/" version ".info") + "@latest"))) + (assoc-ref (json-fetch* (format #f "~a/~a/~a" + goproxy (go-path-escape name) file)) + "Version"))) + +(define* (go-module-available-versions goproxy name) + "Retrieve the available versions for a given module from the module proxy. +Versions are being returned **unordered** and may contain different versioning +styles for the same package." + (let* ((url (string-append goproxy "/" (go-path-escape name) "/@v/list")) + (body (http-fetch* url)) + (versions (remove string-null? (string-split body #\newline)))) + (if (null? versions) + (list (go-module-version-string goproxy name)) ;latest version + versions))) (define (go-package-licenses name) "Retrieve the list of licenses that apply to NAME, a Go package or module @@ -238,119 +251,119 @@ and VERSION and return an input port." ;; the end. (make-regexp (string-append - "^[[:blank:]]*" - "([^[:blank:]]+)[[:blank:]]+([^[:blank:]]+)" - "([[:blank:]]+//.*)?"))) + "^[[:blank:]]*([^[:blank:]]+)[[:blank:]]+" ;the module path + "([^[:blank:]]+)" ;the version + "([[:blank:]]+//.*)?"))) ;an optional comment (define %go.mod-replace-directive-rx ;; ReplaceSpec = ModulePath [ Version ] "=>" FilePath newline ;; | ModulePath [ Version ] "=>" ModulePath Version newline . (make-regexp (string-append - "([^[:blank:]]+)([[:blank:]]+([^[:blank:]]+))?" - "[[:blank:]]+" "=>" "[[:blank:]]+" - "([^[:blank:]]+)([[:blank:]]+([^[:blank:]]+))?"))) + "([^[:blank:]]+)" ;the module path + "([[:blank:]]+([^[:blank:]]+))?" ;optional version + "[[:blank:]]+=>[[:blank:]]+" + "([^[:blank:]]+)" ;the file or module path + "([[:blank:]]+([^[:blank:]]+))?"))) ;the version (if a module path) (define (parse-go.mod content) "Parse the go.mod file CONTENT, returning a list of requirements." - (define-record-type - (make-results requirements replacements) - results? - (requirements results-requirements) - (replacements results-replacements)) ;; We parse only a subset of https://golang.org/ref/mod#go-mod-file-grammar ;; which we think necessary for our use case. - (define (toplevel results) - "Main parser, RESULTS is a pair of alist serving as accumulator for - all encountered requirements and replacements." + (define (toplevel requirements replaced) + "This is the main parser. The results are accumulated in THE REQUIREMENTS +and REPLACED lists." (let ((line (read-line))) (cond ((eof-object? line) ;; parsing ended, give back the result - results) + (values requirements replaced)) ((string=? line "require (") ;; a require block begins, delegate parsing to IN-REQUIRE - (in-require results)) + (in-require requirements replaced)) ((string=? line "replace (") ;; a replace block begins, delegate parsing to IN-REPLACE - (in-replace results)) + (in-replace requirements replaced)) ((string-prefix? "require " line) - ;; a standalone require directive - (let* ((stripped-line (string-drop line 8)) - (new-results (require-directive results stripped-line))) - (toplevel new-results))) + ;; a require directive by itself + (let* ((stripped-line (string-drop line 8))) + (call-with-values + (lambda () + (require-directive requirements replaced stripped-line)) + toplevel))) ((string-prefix? "replace " line) - ;; a standalone replace directive - (let* ((stripped-line (string-drop line 8)) - (new-results (replace-directive results stripped-line))) - (toplevel new-results))) + ;; a replace directive by itself + (let* ((stripped-line (string-drop line 8))) + (call-with-values + (lambda () + (replace-directive requirements replaced stripped-line)) + toplevel))) (#t ;; unrecognised line, ignore silently - (toplevel results))))) + (toplevel requirements replaced))))) - (define (in-require results) + (define (in-require requirements replaced) (let ((line (read-line))) (cond ((eof-object? line) ;; this should never happen here but we ignore silently - results) + (values requirements replaced)) ((string=? line ")") ;; end of block, coming back to toplevel - (toplevel results)) + (toplevel requirements replaced)) (#t - (in-require (require-directive results line)))))) + (call-with-values (lambda () + (require-directive requirements replaced line)) + in-require))))) - (define (in-replace results) + (define (in-replace requirements replaced) (let ((line (read-line))) (cond ((eof-object? line) ;; this should never happen here but we ignore silently - results) + (values requirements replaced)) ((string=? line ")") ;; end of block, coming back to toplevel - (toplevel results)) + (toplevel requirements replaced)) (#t - (in-replace (replace-directive results line)))))) - - (define (replace-directive results line) - "Extract replaced modules and new requirements from replace directive - in LINE and add to RESULTS." - (match results - (($ requirements replaced) - (let* ((rx-match (regexp-exec %go.mod-replace-directive-rx line)) - (module-path (match:substring rx-match 1)) - (version (match:substring rx-match 3)) - (new-module-path (match:substring rx-match 4)) - (new-version (match:substring rx-match 6)) - (new-replaced (alist-cons module-path version replaced)) - (new-requirements - (if (string-match "^\\.?\\./" new-module-path) - requirements - (alist-cons new-module-path new-version requirements)))) - (make-results new-requirements new-replaced))))) - (define (require-directive results line) - "Extract requirement from LINE and add it to RESULTS." + (call-with-values (lambda () + (replace-directive requirements replaced line)) + in-replace))))) + + (define (replace-directive requirements replaced line) + "Extract replaced modules and new requirements from the replace directive +in LINE and add them to the REQUIREMENTS and REPLACED lists." + (let* ((rx-match (regexp-exec %go.mod-replace-directive-rx line)) + (module-path (match:substring rx-match 1)) + (version (match:substring rx-match 3)) + (new-module-path (match:substring rx-match 4)) + (new-version (match:substring rx-match 6)) + (new-replaced (cons (list module-path version) replaced)) + (new-requirements + (if (string-match "^\\.?\\./" new-module-path) + requirements + (cons (list new-module-path new-version) requirements)))) + (values new-requirements new-replaced))) + + (define (require-directive requirements replaced line) + "Extract requirement from LINE and augment the REQUIREMENTS and REPLACED +lists." (let* ((rx-match (regexp-exec %go.mod-require-directive-rx line)) (module-path (match:substring rx-match 1)) - ;; we saw double-quoted string in the wild without escape - ;; sequences so we just trim the quotes + ;; Double-quoted strings were seen in the wild without escape + ;; sequences; trim the quotes to be on the safe side. (module-path (string-trim-both module-path #\")) (version (match:substring rx-match 2))) - (match results - (($ requirements replaced) - (make-results (alist-cons module-path version requirements) replaced))))) - - (let ((results (with-input-from-string content - (lambda _ - (toplevel (make-results '() '())))))) - (match results - (($ requirements replaced) - ;; At last we remove replaced modules from the requirements list - (fold - (lambda (replacedelem requirements) - (alist-delete! (car replacedelem) requirements)) - requirements - replaced))))) + (values (cons (list module-path version) requirements) replaced))) + + (with-input-from-string content + (lambda () + (receive (requirements replaced) + (toplevel '() '()) + ;; At last remove the replaced modules from the requirements list. + (remove (lambda (r) + (assoc (car r) replaced)) + requirements))))) ;; Prevent inlining of this procedure, which is accessed by unit tests. (set! parse-go.mod parse-go.mod) @@ -553,17 +566,32 @@ control system is being used." vcs-type vcs-repo-url))))) (define* (go-module->guix-package module-path #:key - (goproxy-url "https://proxy.golang.org")) - (let* ((latest-version (go-module-latest-version goproxy-url module-path)) - (content (fetch-go.mod goproxy-url module-path latest-version)) - (dependencies (map car (parse-go.mod content))) + (goproxy "https://proxy.golang.org") + version + pin-versions?) + "Return the package S-expression corresponding to MODULE-PATH at VERSION, a Go package. +The meta-data is fetched from the GOPROXY server and https://pkg.go.dev/. +When VERSION is unspecified, the latest version available is used." + (let* ((available-versions (go-module-available-versions goproxy module-path)) + (version* (or version + (go-module-version-string goproxy module-path))) ;latest + ;; Pseudo-versions do not appear in the versions list; skip the + ;; following check. + (_ (unless (or (go-pseudo-version? version*) + (member version* available-versions)) + (error (format #f "error: version ~s is not available +hint: use one of the following available versions ~a\n" + version* available-versions)))) + (content (fetch-go.mod goproxy module-path version*)) + (dependencies+versions (parse-go.mod content)) + (dependencies (map car dependencies+versions)) (guix-name (go-module->guix-package-name module-path)) (root-module-path (module-path->repository-root module-path)) ;; The VCS type and URL are not included in goproxy information. For ;; this we need to fetch it from the official module page. (meta-data (fetch-module-meta-data root-module-path)) (vcs-type (module-meta-vcs meta-data)) - (vcs-repo-url (module-meta-data-repo-url meta-data goproxy-url)) + (vcs-repo-url (module-meta-data-repo-url meta-data goproxy)) (synopsis (go-package-synopsis root-module-path)) (description (go-package-description module-path)) (licenses (go-package-licenses module-path))) @@ -571,14 +599,14 @@ control system is being used." `(package (name ,guix-name) ;; Elide the "v" prefix Go uses - (version ,(string-trim latest-version #\v)) + (version ,(string-trim version* #\v)) (source - ,(vcs->origin vcs-type vcs-repo-url latest-version)) + ,(vcs->origin vcs-type vcs-repo-url version*)) (build-system go-build-system) (arguments '(#:import-path ,root-module-path)) - ,@(maybe-propagated-inputs - (map go-module->guix-package-name dependencies)) + ,@(maybe-propagated-inputs (map go-module->guix-package-name + dependencies)) (home-page ,(format #f "https://~a" root-module-path)) (synopsis ,synopsis) (description ,(and=> description beautify-description)) @@ -588,16 +616,37 @@ control system is being used." license) ((license ...) ;a list of licenses `(list ,@license))))) - dependencies))) + (if pin-versions? + dependencies+versions + dependencies)))) (define go-module->guix-package* (memoize go-module->guix-package)) (define* (go-module-recursive-import package-name - #:key (goproxy-url "https://proxy.golang.org")) + #:key (goproxy "https://proxy.golang.org") + version + pin-versions?) + (recursive-import package-name - #:repo->guix-package (lambda* (name . _) - (go-module->guix-package* - name - #:goproxy-url goproxy-url)) - #:guix-name go-module->guix-package-name)) + #:repo->guix-package + (lambda* (name #:key version repo) + ;; Disable output buffering so that the following warning gets printed + ;; consistently. + (setvbuf (current-error-port) 'none) + (guard (c ((http-get-error? c) + (warning (G_ "Failed to import package ~s. +reason: ~s could not be fetched: HTTP error ~a (~s). +This package and its dependencies won't be imported.~%") + name + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) + (values '() '()))) + (receive (package-sexp dependencies) + (go-module->guix-package* name #:goproxy goproxy + #:version version + #:pin-versions? pin-versions?) + (values package-sexp dependencies)))) + #:guix-name go-module->guix-package-name + #:version version)) diff --git a/guix/scripts/import/go.scm b/guix/scripts/import/go.scm index afdba4e8f1..33d2470ce1 100644 --- a/guix/scripts/import/go.scm +++ b/guix/scripts/import/go.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2020 Katherine Cox-Buday +;;; Copyright © 2020 Katherine Cox-Buday +;;; Copyright © 2021 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,28 +28,30 @@ #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:use-module (ice-9 format) + #:use-module (ice-9 receive) #:export (guix-import-go)) - + ;;; ;;; Command-line options. ;;; (define %default-options - '()) + '((goproxy . "https://proxy.golang.org"))) (define (show-help) - (display (G_ "Usage: guix import go PACKAGE-PATH -Import and convert the Go module for PACKAGE-PATH.\n")) + (display (G_ "Usage: guix import go PACKAGE-PATH[@VERSION] +Import and convert the Go module for PACKAGE-PATH. Optionally, a version +can be specified after the arobas (@) character.\n")) (display (G_ " -h, --help display this help and exit")) (display (G_ " - -V, --version display version information and exit")) - (display (G_ " - -r, --recursive generate package expressions for all Go modules\ - that are not yet in Guix")) + -r, --recursive generate package expressions for all Go modules +that are not yet in Guix")) (display (G_ " -p, --goproxy=GOPROXY specify which goproxy server to use")) + (display (G_ " + --pin-versions use the exact versions of a module's dependencies")) (newline) (show-bug-report-information)) @@ -58,9 +61,6 @@ Import and convert the Go module for PACKAGE-PATH.\n")) (lambda args (show-help) (exit 0))) - (option '(#\V "version") #f #f - (lambda args - (show-version-and-exit "guix import go"))) (option '(#\r "recursive") #f #f (lambda (opt name arg result) (alist-cons 'recursive #t result))) @@ -69,9 +69,12 @@ Import and convert the Go module for PACKAGE-PATH.\n")) (alist-cons 'goproxy (string->symbol arg) (alist-delete 'goproxy result)))) + (option '("pin-versions") #f #f + (lambda (opt name arg result) + (alist-cons 'pin-versions? #t result))) %standard-import-options)) - + ;;; ;;; Entry point. ;;; @@ -93,25 +96,28 @@ Import and convert the Go module for PACKAGE-PATH.\n")) (_ #f)) (reverse opts)))) (match args - ((module-name) - (if (assoc-ref opts 'recursive) - (map (match-lambda - ((and ('package ('name name) . rest) pkg) - `(define-public ,(string->symbol name) - ,pkg)) - (_ #f)) - (go-module-recursive-import module-name - #:goproxy-url - (or (assoc-ref opts 'goproxy) - "https://proxy.golang.org"))) - (let ((sexp (go-module->guix-package module-name - #:goproxy-url - (or (assoc-ref opts 'goproxy) - "https://proxy.golang.org")))) - (unless sexp - (leave (G_ "failed to download meta-data for module '~a'~%") - module-name)) - sexp))) + ((spec) ;e.g., github.com/golang/protobuf@v1.3.1 + (receive (name version) + (package-name->name+version spec) + (let ((arguments (list name + #:goproxy (assoc-ref opts 'goproxy) + #:version version + #:pin-versions? + (assoc-ref opts 'pin-versions?)))) + (if (assoc-ref opts 'recursive) + ;; Recursive import. + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (apply go-module-recursive-import arguments)) + ;; Single import. + (let ((sexp (apply go-module->guix-package arguments))) + (unless sexp + (leave (G_ "failed to download meta-data for module '~a'~%") + module-name)) + sexp))))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/tests/go.scm b/tests/go.scm index fa8fa7a2a6..e5780e68b0 100644 --- a/tests/go.scm +++ b/tests/go.scm @@ -19,7 +19,7 @@ ;;; Summary ;; Tests for guix/import/go.scm -(define-module (test-import-go) +(define-module (tests-import-go) #:use-module (guix base32) #:use-module (guix build-system go) #:use-module (guix import go) @@ -147,7 +147,8 @@ require github.com/kr/pretty v0.2.1 ("https://pkg.go.dev/github.com/go-check/check" . ,pkg.go.dev) ("https://pkg.go.dev/github.com/go-check/check?tab=licenses" - . ,pkg.go.dev-licence)))) + . ,pkg.go.dev-licence) + ("https://proxy.golang.org/github.com/go-check/check/@v/list" . "")))) (test-begin "go") @@ -169,6 +170,12 @@ require github.com/kr/pretty v0.2.1 "daa7c04131f5" (go-version->git-ref "v1.2.4-0.20191109021931-daa7c04131f5")) +(test-assert "go-pseudo-version? multi-digit version number" + (go-pseudo-version? "v1.23.1-0.20200526195155-81db48ad09cc")) + +(test-assert "go-pseudo-version? semantic version with rc" + (go-pseudo-version? "v1.4.0-rc.4.0.20200313231945-b860323f09d0")) + ;;; Unit tests for (guix import go) (test-equal "go-path-escape" @@ -185,37 +192,38 @@ require github.com/kr/pretty v0.2.1 (sort ((@@ (guix import go) parse-go.mod) input) inf?))) (testing-parse-mod "parse-go.mod-simple" - '(("good/thing" . "v1.4.5") - ("new/thing/v2" . "v2.3.4") - ("other/thing" . "v1.0.2")) + '(("good/thing" "v1.4.5") + ("new/thing/v2" "v2.3.4") + ("other/thing" "v1.0.2")) fixture-go-mod-simple) (testing-parse-mod "parse-go.mod-with-block" - '(("A" . "v1") - ("B" . "v1.0.0") - ("C" . "v1.0.0") - ("D" . "v1.2.3") - ("E" . "dev")) + '(("A" "v1") + ("B" "v1.0.0") + ("C" "v1.0.0") + ("D" "v1.2.3") + ("E" "dev")) fixture-go-mod-with-block) -(testing-parse-mod "parse-go.mod-complete" - '(("github.com/corp/arbitrary-repo" . "v0.0.2") - ("quoted.example.com/abitrary/repo" . "v0.0.2") - ("one.example.com/abitrary/repo" . "v1.1.111") - ("hub.jazz.net/git/user/project/sub/directory" . "v1.1.19") - ("hub.jazz.net/git/user/project" . "v1.1.18") - ("launchpad.net/~user/project/branch/sub/directory" . "v1.1.17") - ("launchpad.net/~user/project/branch" . "v1.1.16") - ("launchpad.net/project/series/sub/directory" . "v1.1.15") - ("launchpad.net/project/series" . "v1.1.14") - ("launchpad.net/project" . "v1.1.13") - ("bitbucket.org/user/project/sub/directory" . "v1.11.21") - ("bitbucket.org/user/project" . "v1.11.20") - ("k8s.io/kubernetes/subproject" . "v1.1.101") - ("github.com/user/project/sub/directory" . "v1.1.12") - ("github.com/user/project" . "v1.1.11") - ("github.com/go-check/check" . "v0.0.0-20140225173054-eb6ee6f84d0a")) - fixture-go-mod-complete) +(testing-parse-mod + "parse-go.mod-complete" + '(("github.com/corp/arbitrary-repo" "v0.0.2") + ("quoted.example.com/abitrary/repo" "v0.0.2") + ("one.example.com/abitrary/repo" "v1.1.111") + ("hub.jazz.net/git/user/project/sub/directory" "v1.1.19") + ("hub.jazz.net/git/user/project" "v1.1.18") + ("launchpad.net/~user/project/branch/sub/directory" "v1.1.17") + ("launchpad.net/~user/project/branch" "v1.1.16") + ("launchpad.net/project/series/sub/directory" "v1.1.15") + ("launchpad.net/project/series" "v1.1.14") + ("launchpad.net/project" "v1.1.13") + ("bitbucket.org/user/project/sub/directory" "v1.11.21") + ("bitbucket.org/user/project" "v1.11.20") + ("k8s.io/kubernetes/subproject" "v1.1.101") + ("github.com/user/project/sub/directory" "v1.1.12") + ("github.com/user/project" "v1.1.11") + ("github.com/go-check/check" "v0.0.0-20140225173054-eb6ee6f84d0a")) + fixture-go-mod-complete) ;;; End-to-end tests for (guix import go) (define (mock-http-fetch testcase) -- cgit v1.2.3 From b18f45c21f5d697d384a7bd5c9d3ee314bba9e35 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 28 Dec 2018 01:07:58 +0100 Subject: Add (guix ipfs). MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This module allows for communicating with the IPFS gateway over the HTTP interface. The commit has been cherry-picked from . The procedures for adding and restoring file trees have been removed as according to a reply issue 33899, a different format will be used. The procedure 'add-data' has been exported as it will be used in the system test for IPFS. * guix/ipfs.scm: New file. * Makefile.am (MODULES): Add it. Signed-off-by: Ludovic Courtès --- Makefile.am | 1 + guix/ipfs.scm | 183 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/ipfs.scm | 55 +++++++++++++++++ 3 files changed, 239 insertions(+) create mode 100644 guix/ipfs.scm create mode 100644 tests/ipfs.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index 1c2d45527c..17ad236655 100644 --- a/Makefile.am +++ b/Makefile.am @@ -126,6 +126,7 @@ MODULES = \ guix/cache.scm \ guix/cve.scm \ guix/workers.scm \ + guix/ipfs.scm \ guix/build-system.scm \ guix/build-system/android-ndk.scm \ guix/build-system/ant.scm \ diff --git a/guix/ipfs.scm b/guix/ipfs.scm new file mode 100644 index 0000000000..31a89888a7 --- /dev/null +++ b/guix/ipfs.scm @@ -0,0 +1,183 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix ipfs) + #:use-module (json) + #:use-module (guix base64) + #:use-module ((guix build utils) #:select (dump-port)) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (rnrs io ports) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 match) + #:use-module (ice-9 ftw) + #:use-module (web uri) + #:use-module (web client) + #:use-module (web response) + #:export (%ipfs-base-url + add-data + add-file + + content? + content-name + content-hash + content-size + + add-empty-directory + add-to-directory + read-contents + publish-name)) + +;;; Commentary: +;;; +;;; This module implements bindings for the HTTP interface of the IPFS +;;; gateway, documented here: . It +;;; allows you to add and retrieve files over IPFS, and a few other things. +;;; +;;; Code: + +(define %ipfs-base-url + ;; URL of the IPFS gateway. + (make-parameter "http://localhost:5001")) + +(define* (call url decode #:optional (method http-post) + #:key body (false-if-404? #t) (headers '())) + "Invoke the endpoint at URL using METHOD. Decode the resulting JSON body +using DECODE, a one-argument procedure that takes an input port; when DECODE +is false, return the input port. When FALSE-IF-404? is true, return #f upon +404 responses." + (let*-values (((response port) + (method url #:streaming? #t + #:body body + + ;; Always pass "Connection: close". + #:keep-alive? #f + #:headers `((connection close) + ,@headers)))) + (cond ((= 200 (response-code response)) + (if decode + (let ((result (decode port))) + (close-port port) + result) + port)) + ((and false-if-404? + (= 404 (response-code response))) + (close-port port) + #f) + (else + (close-port port) + (throw 'ipfs-error url response))))) + +;; Result of a file addition. +(define-json-mapping make-content content? + json->content + (name content-name "Name") + (hash content-hash "Hash") + (bytes content-bytes "Bytes") + (size content-size "Size" string->number)) + +;; Result of a 'patch/add-link' operation. +(define-json-mapping make-directory directory? + json->directory + (hash directory-hash "Hash") + (links directory-links "Links" json->links)) + +;; A "link". +(define-json-mapping make-link link? + json->link + (name link-name "Name") + (hash link-hash "Hash") + (size link-size "Size" string->number)) + +;; A "binding", also known as a "name". +(define-json-mapping make-binding binding? + json->binding + (name binding-name "Name") + (value binding-value "Value")) + +(define (json->links json) + (match json + (#f '()) + (links (map json->link links)))) + +(define %multipart-boundary + ;; XXX: We might want to find a more reliable boundary. + (string-append (make-string 24 #\-) "2698127afd7425a6")) + +(define (bytevector->form-data bv port) + "Write to PORT a 'multipart/form-data' representation of BV." + (display (string-append "--" %multipart-boundary "\r\n" + "Content-Disposition: form-data\r\n" + "Content-Type: application/octet-stream\r\n\r\n") + port) + (put-bytevector port bv) + (display (string-append "\r\n--" %multipart-boundary "--\r\n") + port)) + +(define* (add-data data #:key (name "file.txt") recursive?) + "Add DATA, a bytevector, to IPFS. Return a content object representing it." + (call (string-append (%ipfs-base-url) + "/api/v0/add?arg=" (uri-encode name) + "&recursive=" + (if recursive? "true" "false")) + json->content + #:headers + `((content-type + . (multipart/form-data + (boundary . ,%multipart-boundary)))) + #:body + (call-with-bytevector-output-port + (lambda (port) + (bytevector->form-data data port))))) + +(define (not-dot? entry) + (not (member entry '("." "..")))) + +(define* (add-file file #:key (name (basename file))) + "Add FILE under NAME to the IPFS and return a content object for it." + (add-data (match (call-with-input-file file get-bytevector-all) + ((? eof-object?) #vu8()) + (bv bv)) + #:name name)) + +(define* (add-empty-directory #:key (name "directory")) + "Return a content object for an empty directory." + (add-data #vu8() #:recursive? #t #:name name)) + +(define* (add-to-directory directory file name) + "Add FILE to DIRECTORY under NAME, and return the resulting directory. +DIRECTORY and FILE must be hashes identifying objects in the IPFS store." + (call (string-append (%ipfs-base-url) + "/api/v0/object/patch/add-link?arg=" + (uri-encode directory) + "&arg=" (uri-encode name) "&arg=" (uri-encode file) + "&create=true") + json->directory)) + +(define* (read-contents object #:key offset length) + "Return an input port to read the content of OBJECT from." + (call (string-append (%ipfs-base-url) + "/api/v0/cat?arg=" object) + #f)) + +(define* (publish-name object) + "Publish OBJECT under the current peer ID." + (call (string-append (%ipfs-base-url) + "/api/v0/name/publish?arg=" object) + json->binding)) diff --git a/tests/ipfs.scm b/tests/ipfs.scm new file mode 100644 index 0000000000..3b662b22bd --- /dev/null +++ b/tests/ipfs.scm @@ -0,0 +1,55 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (test-ipfs) + #:use-module (guix ipfs) + #:use-module ((guix utils) #:select (call-with-temporary-directory)) + #:use-module (guix tests) + #:use-module (web uri) + #:use-module (srfi srfi-64)) + +;; Test the (guix ipfs) module. + +(define (ipfs-gateway-running?) + "Return true if the IPFS gateway is running at %IPFS-BASE-URL." + (let* ((uri (string->uri (%ipfs-base-url))) + (socket (socket AF_INET SOCK_STREAM 0))) + (define connected? + (catch 'system-error + (lambda () + (format (current-error-port) + "probing IPFS gateway at localhost:~a...~%" + (uri-port uri)) + (connect socket AF_INET INADDR_LOOPBACK (uri-port uri)) + #t) + (const #f))) + + (close-port socket) + connected?)) + +(unless (ipfs-gateway-running?) + (test-skip 1)) + +(test-assert "add-file-tree + restore-file-tree" + (call-with-temporary-directory + (lambda (directory) + (let* ((source (dirname (search-path %load-path "guix/base32.scm"))) + (target (string-append directory "/r")) + (content (pk 'content (add-file-tree source)))) + (restore-file-tree (content-name content) target) + (file=? source target))))) -- cgit v1.2.3 From 1bab9b9f17256a9e4f45f5b0cceb8b52e0a1b1ed Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 2 Apr 2021 18:36:50 -0400 Subject: grafts: Support rewriting UTF-16 and UTF-32 store references. Partially fixes . * guix/build/graft.scm (replace-store-references): Add support for finding and rewriting UTF-16 and UTF-32 store references. * tests/grafts.scm: Add tests. --- guix/build/graft.scm | 281 ++++++++++++++++++++++++++++++++++----------------- tests/grafts.scm | 83 +++++++++++++++ 2 files changed, 273 insertions(+), 91 deletions(-) (limited to 'tests') diff --git a/guix/build/graft.scm b/guix/build/graft.scm index c119ee71d1..f04c35fa74 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016, 2018 Ludovic Courtès -;;; Copyright © 2016 Mark H Weaver +;;; Copyright © 2016, 2021 Mark H Weaver ;;; ;;; This file is part of GNU Guix. ;;; @@ -55,6 +55,52 @@ (string->char-set "0123456789abcdfghijklmnpqrsvwxyz") <>)) +(define (nix-base32-char-or-nul? c) + "Return true if C is a nix-base32 character or NUL, otherwise return false." + (or (nix-base32-char? c) + (char=? c #\nul))) + +(define (possible-utf16-hash? buffer i w) + "Return true if (I - W) is large enough to hold a UTF-16 encoded +nix-base32 hash and if BUFFER contains NULs in all positions where NULs +are to be expected in a UTF-16 encoded hash+dash pattern whose dash is +found at position I. Otherwise, return false." + (and (<= (* 2 hash-length) (- i w)) + (let loop ((j (+ 1 (- i (* 2 hash-length))))) + (or (>= j i) + (and (zero? (bytevector-u8-ref buffer j)) + (loop (+ j 2))))))) + +(define (possible-utf32-hash? buffer i w) + "Return true if (I - W) is large enough to hold a UTF-32 encoded +nix-base32 hash and if BUFFER contains NULs in all positions where NULs +are to be expected in a UTF-32 encoded hash+dash pattern whose dash is +found at position I. Otherwise, return false." + (and (<= (* 4 hash-length) (- i w)) + (let loop ((j (+ 1 (- i (* 4 hash-length))))) + (or (>= j i) + (and (zero? (bytevector-u8-ref buffer j)) + (zero? (bytevector-u8-ref buffer (+ j 1))) + (zero? (bytevector-u8-ref buffer (+ j 2))) + (loop (+ j 4))))))) + +(define (insert-nuls char-size bv) + "Given a bytevector BV, return a bytevector containing the same bytes but +with (CHAR-SIZE - 1) NULs inserted between every two adjacent bytes from BV. +For example, (insert-nuls 4 #u8(1 2 3)) => #u8(1 0 0 0 2 0 0 0 3)." + (if (= char-size 1) + bv + (let* ((len (bytevector-length bv)) + (bv* (make-bytevector (+ 1 (* char-size + (- len 1))) + 0))) + (let loop ((i 0)) + (when (< i len) + (bytevector-u8-set! bv* (* i char-size) + (bytevector-u8-ref bv i)) + (loop (+ i 1)))) + bv*))) + (define* (replace-store-references input output replacement-table #:optional (store (%store-directory))) "Read data from INPUT, replacing store references according to @@ -76,9 +122,9 @@ bytevectors to the same value." (list->vector (map pred (iota 256))) <>)) - (define nix-base32-byte? + (define nix-base32-byte-or-nul? (optimize-u8-predicate - (compose nix-base32-char? + (compose nix-base32-char-or-nul? integer->char))) (define (dash? byte) (= byte 45)) @@ -86,100 +132,153 @@ bytevectors to the same value." (define request-size (expt 2 20)) ; 1 MiB ;; We scan the file for the following 33-byte pattern: 32 bytes of - ;; nix-base32 characters followed by a dash. To accommodate large files, - ;; we do not read the entire file, but instead work on buffers of up to - ;; 'request-size' bytes. To ensure that every 33-byte sequence appears - ;; entirely within exactly one buffer, adjacent buffers must overlap, - ;; i.e. they must share 32 byte positions. We accomplish this by - ;; "ungetting" the last 32 bytes of each buffer before reading the next - ;; buffer, unless we know that we've reached the end-of-file. + ;; nix-base32 characters followed by a dash. When we find such a pattern + ;; whose hash is in REPLACEMENT-TABLE, we perform the required rewrite and + ;; continue scanning. + ;; + ;; To support UTF-16 and UTF-32 store references, the 33 bytes comprising + ;; this hash+dash pattern may optionally be interspersed by extra NUL bytes. + ;; This simple approach works because the characters we are looking for are + ;; restricted to ASCII. UTF-16 hashes are interspersed with single NUL + ;; bytes ("\0"), and UTF-32 hashes are interspersed with triplets of NULs + ;; ("\0\0\0"). Note that we require NULs to be present only *between* the + ;; other bytes, and not at either end, in order to be insensitive to byte + ;; order. + ;; + ;; To accommodate large files, we do not read the entire file at once, but + ;; instead work on buffers of up to REQUEST-SIZE bytes. To ensure that + ;; every hash+dash pattern appears in its entirety in at least one buffer, + ;; adjacent buffers must overlap by one byte less than the maximum size of a + ;; hash+dash pattern. We accomplish this by "ungetting" a suffix of each + ;; buffer before reading the next buffer, unless we know that we've reached + ;; the end-of-file. (let ((buffer (make-bytevector request-size))) - (let loop () - ;; Note: We avoid 'get-bytevector-n' to work around - ;; . + (define-syntax-rule (byte-at i) + (bytevector-u8-ref buffer i)) + (let outer-loop () (match (get-bytevector-n! input buffer 0 request-size) ((? eof-object?) 'done) (end - ;; We scan the buffer for dashes that might be preceded by a - ;; nix-base32 hash. The key optimization here is that whenever we - ;; find a NON-nix-base32 character at position 'i', we know that it - ;; cannot be part of a hash, so the earliest position where the next - ;; hash could start is i+1 with the following dash at position i+33. - ;; - ;; Since nix-base32 characters comprise only 1/8 of the 256 possible - ;; byte values, and exclude some of the most common letters in - ;; English text (e t o u), in practice we can advance by 33 positions - ;; most of the time. - (let scan-from ((i hash-length) (written 0)) - ;; 'i' is the first position where we look for a dash. 'written' - ;; is the number of bytes in the buffer that have already been - ;; written. + (define (scan-from i w) + ;; Scan the buffer for dashes that might be preceded by nix hashes, + ;; where I is the minimum position where such a dash might be + ;; found, and W is the number of bytes in the buffer that have been + ;; written so far. We assume that I - W >= HASH-LENGTH. + ;; + ;; The key optimization here is that whenever we find a byte at + ;; position I that cannot occur within a nix hash (because it's + ;; neither a nix-base32 character nor NUL), we can infer that the + ;; earliest position where the next hash could start is at I + 1, + ;; and therefore the earliest position for the following dash is + ;; (+ I 1 HASH-LENGTH), which is I + 33. + ;; + ;; Since nix-base32-or-nul characters comprise only about 1/8 of + ;; the 256 possible byte values, and exclude some of the most + ;; common letters in English text (e t o u), we can advance 33 + ;; positions much of the time. (if (< i end) - (let ((byte (bytevector-u8-ref buffer i))) - (cond ((and (dash? byte) - ;; We've found a dash. Note that we do not know - ;; whether the preceeding 32 bytes are nix-base32 - ;; characters, but we do not need to know. If - ;; they are not, the following lookup will fail. - (lookup-replacement - (string-tabulate (lambda (j) - (integer->char - (bytevector-u8-ref buffer - (+ j (- i hash-length))))) - hash-length))) - => (lambda (replacement) - ;; We've found a hash that needs to be replaced. - ;; First, write out all bytes preceding the hash - ;; that have not yet been written. - (put-bytevector output buffer written - (- i hash-length written)) - ;; Now write the replacement string. - (put-bytevector output replacement) - ;; Since the byte at position 'i' is a dash, - ;; which is not a nix-base32 char, the earliest - ;; position where the next hash might start is - ;; i+1, and the earliest position where the - ;; following dash might start is (+ i 1 - ;; hash-length). Also, increase the write - ;; position to account for REPLACEMENT. - (let ((len (bytevector-length replacement))) - (scan-from (+ i 1 len) - (+ i (- len hash-length)))))) - ;; If the byte at position 'i' is a nix-base32 char, - ;; then the dash we're looking for might be as early as - ;; the following byte, so we can only advance by 1. - ((nix-base32-byte? byte) - (scan-from (+ i 1) written)) - ;; If the byte at position 'i' is NOT a nix-base32 - ;; char, then the earliest position where the next hash - ;; might start is i+1, with the following dash at - ;; position (+ i 1 hash-length). + (let ((byte (byte-at i))) + (cond ((dash? byte) + (found-dash i w)) + ((nix-base32-byte-or-nul? byte) + (scan-from (+ i 1) w)) (else - (scan-from (+ i 1 hash-length) written)))) - - ;; We have finished scanning the buffer. Now we determine how - ;; many bytes have not yet been written, and how many bytes to - ;; "unget". If 'end' is less than 'request-size' then we read - ;; less than we asked for, which indicates that we are at EOF, - ;; so we needn't unget anything. Otherwise, we unget up to - ;; 'hash-length' bytes (32 bytes). However, we must be careful - ;; not to unget bytes that have already been written, because - ;; that would cause them to be written again from the next - ;; buffer. In practice, this case occurs when a replacement is - ;; made near or beyond the end of the buffer. When REPLACEMENT - ;; went beyond END, we consume the extra bytes from INPUT. - (begin - (if (> written end) - (get-bytevector-n! input buffer 0 (- written end)) - (let* ((unwritten (- end written)) - (unget-size (if (= end request-size) - (min hash-length unwritten) - 0)) - (write-size (- unwritten unget-size))) - (put-bytevector output buffer written write-size) - (unget-bytevector input buffer (+ written write-size) - unget-size))) - (loop))))))))) + (not-part-of-hash i w)))) + (finish-buffer i w))) + + (define (not-part-of-hash i w) + ;; Position I is known to not be within a nix hash that we must + ;; rewrite. Therefore, the earliest position where the next hash + ;; might start is I + 1, and therefore the earliest position of + ;; the following dash is (+ I 1 HASH-LENGTH). + (scan-from (+ i 1 hash-length) w)) + + (define (found-dash i w) + ;; We know that there is a dash '-' at position I, and that + ;; I - W >= HASH-LENGTH. The immediately preceding bytes *might* + ;; contain a nix-base32 hash, but that is not yet known. Here, + ;; we rule out all but one possible encoding (ASCII, UTF-16, + ;; UTF-32) by counting how many NULs precede the dash. + (cond ((not (zero? (byte-at (- i 1)))) + ;; The dash is *not* preceded by a NUL, therefore it + ;; cannot possibly be a UTF-16 or UTF-32 hash. Proceed + ;; to check for an ASCII hash. + (found-possible-hash 1 i w)) + + ((not (zero? (byte-at (- i 2)))) + ;; The dash is preceded by exactly one NUL, therefore it + ;; cannot be an ASCII or UTF-32 hash. Proceed to check + ;; for a UTF-16 hash. + (if (possible-utf16-hash? buffer i w) + (found-possible-hash 2 i w) + (not-part-of-hash i w))) + + (else + ;; The dash is preceded by at least two NULs, therefore + ;; it cannot be an ASCII or UTF-16 hash. Proceed to + ;; check for a UTF-32 hash. + (if (possible-utf32-hash? buffer i w) + (found-possible-hash 4 i w) + (not-part-of-hash i w))))) + + (define (found-possible-hash char-size i w) + ;; We know that there is a dash '-' at position I, that + ;; I - W >= CHAR-SIZE * HASH-LENGTH, and that the only + ;; possible encoding for the preceding hash is as indicated by + ;; CHAR-SIZE. Here we check to see if the given hash is in + ;; REPLACEMENT-TABLE, and if so, we perform the required + ;; rewrite. + (let* ((hash (string-tabulate + (lambda (j) + (integer->char + (byte-at (- i (* char-size + (- hash-length j)))))) + hash-length)) + (replacement* (lookup-replacement hash)) + (replacement (and replacement* + (insert-nuls char-size replacement*)))) + (cond + ((not replacement) + (not-part-of-hash i w)) + (else + ;; We've found a hash that needs to be replaced. + ;; First, write out all bytes preceding the hash + ;; that have not yet been written. + (put-bytevector output buffer w + (- i (* char-size hash-length) w)) + ;; Now write the replacement string. + (put-bytevector output replacement) + ;; Now compute the new values of W and I and continue. + (let ((w (+ (- i (* char-size hash-length)) + (bytevector-length replacement)))) + (scan-from (+ w hash-length) w)))))) + + (define (finish-buffer i w) + ;; We have finished scanning the buffer. Now we determine how many + ;; bytes have not yet been written, and how many bytes to "unget". + ;; If END is less than REQUEST-SIZE then we read less than we asked + ;; for, which indicates that we are at EOF, so we needn't unget + ;; anything. Otherwise, we unget up to (* 4 HASH-LENGTH) bytes. + ;; However, we must be careful not to unget bytes that have already + ;; been written, because that would cause them to be written again + ;; from the next buffer. In practice, this case occurs when a + ;; replacement is made near or beyond the end of the buffer. When + ;; REPLACEMENT went beyond END, we consume the extra bytes from + ;; INPUT. + (if (> w end) + (get-bytevector-n! input buffer 0 (- w end)) + (let* ((unwritten (- end w)) + (unget-size (if (= end request-size) + (min (* 4 hash-length) + unwritten) + 0)) + (write-size (- unwritten unget-size))) + (put-bytevector output buffer w write-size) + (unget-bytevector input buffer (+ w write-size) + unget-size))) + (outer-loop)) + + (scan-from hash-length 0)))))) (define (rename-matching-files directory mapping) "Apply MAPPING to the names of all the files in DIRECTORY, where MAPPING is diff --git a/tests/grafts.scm b/tests/grafts.scm index a12c6a5911..7e1959e4a7 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2021 Mark H Weaver ;;; ;;; This file is part of GNU Guix. ;;; @@ -468,4 +469,86 @@ replacement "/gnu/store"))))) +(define (insert-nuls char-size str) + (string-join (map string (string->list str)) + (make-string (- char-size 1) #\nul))) + +(define (nuls-to-underscores s) + (string-replace-substring s "\0" "_")) + +(define (annotate-buffer-boundary s) + (string-append (string-take s buffer-size) + "|" + (string-drop s buffer-size))) + +(define (abbreviate-leading-fill s) + (let ((s* (string-trim s #\=))) + (format #f "[~a =s]~a" + (- (string-length s) + (string-length s*)) + s*))) + +(define (prettify-for-display s) + (abbreviate-leading-fill + (annotate-buffer-boundary + (nuls-to-underscores s)))) + +(define (two-sample-refs-with-gap char-size1 char-size2 gap offset + char1 name1 char2 name2) + (string-append + (make-string (- buffer-size offset) #\=) + (insert-nuls char-size1 + (string-append "/gnu/store/" (make-string 32 char1) name1)) + gap + (insert-nuls char-size2 + (string-append "/gnu/store/" (make-string 32 char2) name2)) + (list->string (map integer->char (iota 77 33))))) + +(define (sample-map-entry old-char new-char new-name) + (cons (make-string 32 old-char) + (string->utf8 (string-append (make-string 32 new-char) + new-name)))) + +(define (test-two-refs-with-gap char-size1 char-size2 gap offset) + (test-equal + (format #f "test-two-refs-with-gap, char-sizes ~a ~a, gap ~s, offset ~a" + char-size1 char-size2 gap offset) + (prettify-for-display + (two-sample-refs-with-gap char-size1 char-size2 gap offset + #\6 "-BlahBlaH" + #\8"-SoMeTHiNG")) + (prettify-for-display + (let* ((content (two-sample-refs-with-gap char-size1 char-size2 gap offset + #\5 "-blahblah" + #\7 "-something")) + (replacement (alist->vhash + (list (sample-map-entry #\5 #\6 "-BlahBlaH") + (sample-map-entry #\7 #\8 "-SoMeTHiNG"))))) + (call-with-output-string + (lambda (output) + ((@@ (guix build graft) replace-store-references) + (open-input-string content) output + replacement + "/gnu/store"))))))) + +(for-each (lambda (char-size1) + (for-each (lambda (char-size2) + (for-each (lambda (gap) + (for-each (lambda (offset) + (test-two-refs-with-gap char-size1 + char-size2 + gap + offset)) + ;; offsets to test + (map (lambda (i) + (+ i (* 40 char-size1))) + (iota 30)))) + ;; gaps + '("" "-" " " "a"))) + ;; char-size2 values to test + '(1 2))) + ;; char-size1 values to test + '(1 2 4)) + + (test-end) -- cgit v1.2.3